Beefy Boxes and Bandwidth Generously Provided by pair Networks
P is for Practical
 
PerlMonks  

Craft

( #481=superdoc: print w/ replies, xml ) Need Help??

This section is obsolete. To post new code, please use Cool Uses For Perl.

User craft
Poor mans Netcat
1 direct reply — Read more / Contribute
by Corion
on Nov 04, 2003 at 07:17
    #!/usr/bin/perl -w
    # As our unix printer setup is weird and I sometimes want to
    # print to networked (HP) printers, I needed something like
    # netcat. I was unsatisfied with <tt>telnet</tt>, as it did
    # output stuff I didn't want, and I didn't want to add the
    # redirection to /dev/null. Perl to the rescue:
    
    use strict;
    use IO::Socket;
    
    select IO::Socket::INET->new(PeerAddr => shift, PeerPort => (shift || 
    +23));
    print
      for <>;
    
    __END__
    # or, as a oneliner:
    perl -MIO::Socket -pe 'BEGIN{select IO::Socket::INET->new(PeerAddr=>sh
    +ift,PeerPort =>(shift||23))}'
    
divert based traffic shaper (bsd ipfirewall & ipchains divert patch)
1 direct reply — Read more / Contribute
by nothingmuch
on Oct 05, 2003 at 02:16
    #!/usr/bin/perl
    =foo
    Update: added rules
    Update: on my darwin i set up the relevant rule with
    
        ipfw add 65500 divert 65500 tcp from me to any via en0
    
    replace with your iface of choice, naturally. I haven't set this up on
    linux (yet), but I know divert sockets were ported at some point...
    ciao ciao!
    
    This little script was hell to write, because every time i didn't do t
    +he
    firewall rule right, and had a fix for the script, my netinfo server
    couldn't be contacted... this ment that i couldn't run
    
        ipfw flush
    
    regardless, i've finally made it. It now prioritises using a size base
    +d
    queue, which is really nothing compared to what you can do. Suprisingl
    +y
    it's not a resource hog, and there's still some stuff to implement, su
    +ch
    as timeout based dropping using a journal (the purger is written, but
    not the logger), and priority queue clipping using mapl's janus heaps.
    +..
    
    I guess i'll prioritize the cmp sub so that it puts tcp SYN packets, a
    +nd
    non piggybacked ACKS, aswell as short ICMP and UDP at the top
    automatically. Then I'll prioritise by service...
    
    so far only the heap has made bittorrent and perlmonks chat possible a
    +t
    the same time, even when running several bts at a time... I must say I
    was surprised.
    
    Replace "#print" with ";print" for debugging info.
    
    Unresolved bug: within the SIGIO handler recv will sometimes return
    undefined, but the loop check doesn't pick it up, so pack complains. I
    have no idea why.
    
    Bah. Enough yak, here's the stuff:
    =cut
    
    use strict;
    use warnings;
    
    use Socket;
    use Time::HiRes qw(time sleep alarm);
    use Fcntl qw(F_SETOWN F_GETFL F_SETFL O_ASYNC O_NONBLOCK);
    use Array::Heap;
    #use Array::Heap2; # same thing, with a different namespacs
    use NetPacket::IP qw(IP_PROTO_ICMP IP_PROTO_TCP IP_PROTO_UDP);
    use NetPacket::TCP;
    use NetPacket::UDP;
    use NetPacket::ICMP;
    use Scalar::Util qw(dualvar);
    
    ### KNOWN BUGS
    # this code is very dirty and hackish, may be resolved in the future
    
    ### CHANGES
    # added real rules to order the heaps. A simple API and examples at th
    +e bottom...
    # currently aggressively user oriented, with a bit of space for standa
    +rd unixish servers
    
    ### TODO
    # score changes dynamically based on time... Instability in heap could
    # be negligeable at this point, as TCP is fault tolerant and UDP
    # shouldn't care. ICMP should a have high enough priority
    #
    # purge using timeout, not just by clipping the queue
    #
    # both of these are theoretically solveable using references within th
    +e queue,
    # so that you could undef and change the value of the referants (thing
    +ys) in
    # the heap itself. I wonder if make_heap instead of push_heap would be
    + much worse.
    # This way we could take a reference to an element in the heap.
    
    # aggressive purging minimizes wasted bandwidth:
        # have an x second maximum queue life (to be implemented)
        # purge heap size:
        #   if (overflow){
        #       reverse order
        #       reverse heapify
        #       reverse pop
        #       reverse order
        #   }
        #   
        #   push 
    
    
    # user config
    sub PORT () { 65500 }; # the port to bind on
    sub WANTED_BYTES_PER_SECOND () { 94 * 128 }; # cap ( * 128 for kilobit
    +s, * 1024 for kilobytes )... divide by ERROR
    sub SLEEP_INTERVAL () { 0.05 }  ## smaller = smoother, more overhead. 
    +For some perspective:
                                    ## 0.01 is usually the size of a time 
    +slice on unices... (linux lets you get picky)
                                    ## 0.03 gives good response on ~10K, 0
    +.05 on 100K and more. the question is really
                                    ## how many packets do you burst befor
    +e delaying for them all. If you send 100 packets
                                    ## a second the overhead of calling sl
    +eep will cause a significant delay
    sub PURGE_INTERVAL () { 2 } ## how often are packets purged
    sub PURGE_TIMEOUT () { 20 } ## how long can a packet live in the queue
    +... only as accurate as PURGE_INTERVAL
    sub QUEUE_LIMIT () { 32 } ## how many packets are allowed to be in the
    + queue at any given time
    
    # constants
    sub ERROR () { 0.996 }; # clipped average on my machine, for 12 * 1024
    +, 64 * 1024, 128 * 1024
    sub BYTES_PER_SECOND () { WANTED_BYTES_PER_SECOND / ERROR };
    sub SLICE () { BYTES_PER_SECOND * SLEEP_INTERVAL }; # a slice of data 
    +corresponding to SLEEP_INTERVAL
    sub NOQUEUE () { O_ASYNC | O_NONBLOCK };
    sub PACK_QUEUE () { "a16 a*" };
    sub PACK_DEPT () { "d S" }; ## F: less overhead, innacurate. d: accura
    +te, more overhead,
                                ## D: less overhead, accurate, needs long 
    +double support (perl -V).
    sub PURGE_MARKERS () { int(PURGE_TIMEOUT / PURGE_INTERVAL) }
    
    # variables
    my ($dept,@dept) = (0);
    my ($qcnt,@qjournal,@queue) = (0,((undef) x PURGE_MARKERS));
    
    
    #print "Initializing...\n";
    #print "SLICE=", SLICE, "\n";
    
    my $rules = new Rules;
    install_rules($rules);
    
    
    ### hackery for priority queue implmentation
    
    sub queue (@) { ## use $rules to compute score, push, janusify and pop
    + if needed
        my @packets = @_;
        
        foreach my $packet (@packets){  
            $qcnt++;
            $packet = dualvar $rules->evaluate(substr($packet,16)), $packe
    +t;
            # add journal entry
        }
        
        if ($qcnt > QUEUE_LIMIT){
            #print "queue has exceeded limit, clipping\n";
            @queue = reverse @queue;
            make_heap_cmp { $b <=> $a } @queue;
            while ($qcnt > QUEUE_LIMIT){
                pop_heap_cmp { $b <=> $a } @queue;
                $qcnt--;
            }
            @queue = reverse @queue;
        }
        
        push_heap @queue, @packets;
    }
    
    sub dequeue (){ ### pop while defined
        $qcnt--;
        pop_heap @queue;
    }
    
    ### hackery ends
    
    
    ## set up socket
    socket D, PF_INET, SOCK_RAW, getprotobyname("divert") or die "$!";
    bind D,sockaddr_in(PORT,inet_aton("0.0.0.0")) or die "$!";
    fcntl D, F_SETOWN, $$;
    #print "fcntl returned async ", ((fcntl D, F_GETFL, 0 & NOQUEUE) ? "on
    +" : "off"), "\n";
    
    #$SIG{ALRM} = sub {
    #   if ($qcnt){
    #       while (defined $qjournal[0]){
    #           undef ${shift @qjournal}; # undefine the reference
    #           if (--$qcnt == 1){
    #               @queue = ();
    #               @qjournal = ((undef) x PURGE_MARKERS);
    #               return;
    #           }
    #       }; shift @qjournal; # take out one marker
    #       push @qjournal, undef; # put another in
    #   }
    #};
    #alarm PURGE_INTERVAL,PURGE_INTERVAL; # purge old packets every n
    
    my ($ts,$p); # lexical for SIGIO temp usage... don't alloc/daelloc eve
    +ry time
    $SIG{IO} = sub {
        #print time(), " SIGIO: queuing up\n";
        while (defined($ts = recv D, $p, 65535, 0)){    # we assume packet
    +s can come in faster than SIGIO can be called
                                                        # (on my machine, 
    +128 * 1024 cap, this loops usually picks up 3-4
                                                        # packets), so we'
    +ll save some context switching on high load,
            #print "undefined p ($!)\n" unless defined $p;
            #print "undefined ts ($!)\n" unless defined $ts;
            queue(pack(PACK_QUEUE, $ts, $p));
        }
    };
    
    #print "Initialization complete, starting read loop\n";
    
    # start loop
    my ($to, $t, $s, $l);
    #my ($start, $end, $total); # used to compute ERROR
    PACKET: { if (defined ($to = recv D, $_, 65535, 0)){    # blocking rea
    +d. the queue is empty. $to is reassigned
                                                            # because the 
    +packet could come from various rules. hack at it
                                                            # if it ticks 
    +you off.
        #print time(), " received packet\n";
        #print "received: " . length($to) . "\n";
        if ($dept < SLICE){
            #print time(), " dept is $dept - short circuited, should take 
    +", length($_) / BYTES_PER_SECOND, " seconds to deliver\n";
            send D, $_, 0, $to;
            $dept += length($_);
            push @dept, pack(PACK_DEPT, time(), length($_) );
            redo PACKET;
        } else {
            #print time(), " queued (too much dept: $dept)\n";
            queue(pack(PACK_QUEUE, $to, $_));   # pack is about 1.5 times 
    +faster than refs (benchmark)
        }
        
        # the queue is not empty, or dept needs purging
        
        #print time(), " clearing up queue\n";
        
        fcntl D, F_SETFL, ((fcntl D, F_GETFL, 0)|NOQUEUE); # switch to asy
    +nc
        #print "fcntl is now noqueue ", ((fcntl D, F_GETFL, 0 & NOQUEUE) ?
    + "on" : "off"), "\n";
        
        # use to compute ERROR
        #$start = time;
        #$total = 0;
        
        until (not $qcnt){ # until the queue is empty
            do {
                #print time(), " cleaning out and making up for dept\n";
                $t = time;
                for (my $i = 0; $i < @dept; $i++){
                    defined $dept[$i] or next;
                    ($s, $l) = unpack(PACK_DEPT, $dept[$i]);
                    #print time(), " diff is ", time - $s, ", ", ($l / BYT
    +ES_PER_SECOND)," diff needed queue length is $#queue, dept joural has
    + $#dept entries ($dept)\n";
                    if ($t > $s + ($l / BYTES_PER_SECOND) ){
                        $dept -= $l;
                        delete($dept[$i]); # faster than splice
                    }
                }
                while (@dept and not exists $dept[0]){ shift @dept }; ## c
    +lean out those which are easy
                #print time(), " dept is now $dept\n";
                #print time(), " will sleep for ", $dept / BYTES_PER_SECON
    +D,"\n" if $dept > SLICE;
            } while (($dept > SLICE) and sleep $dept / BYTES_PER_SECOND); 
    +  # sleep (one should suffice, but in case a sig came
                                                                          
    +  # (IO, ALRM are used)) until we've cleared the dept
            #print time(), " dept is now $dept, flushing a packet\n";
            
            my ($to,$p) = unpack(PACK_QUEUE, dequeue() );
            $dept += length($p);
            push @dept, pack(PACK_DEPT, time(), length($p) );
            #$total += length($p); used to compute ERROR
            #print time(), " sent one from queue, dept is now $dept, shoul
    +d take ", length($p) / BYTES_PER_SECOND, " seconds to deliver (queue 
    +left: $#queue)\n";
            send D, $p, 0, $to;
        
            !$qcnt ? fcntl D, F_SETFL, ((fcntl D, F_GETFL, 0)&!NOQUEUE) : 
    +redo ;    # unset async. checking here will skip checking
                                                                          
    +          # until(!queue), up to the time fcntl is called.
                                                                          
    +          # Then a double check is made to avoid a packet
                                                                          
    +          # getting stuck in the queue while others are
                                                                          
    +          # getting short circuited
            #print "fcntl is now noqueue ", ((fcntl D, F_GETFL, 0 & NOQUEU
    +E) ? "on" : "off"), "\n";
        }
        
        # use this code to determine ERROR
        #$end = time;
        #my $bps = ($total/($end-$start));
        # print "during high load we sent $total bytes in ", $end-$start, 
    +" seconds, which means ", $bps, " bytes per second.\n";
        # print "the ratio of actual rate versus cap is ", $bps/BYTES_PER_
    +SECOND, "\n";
        
        #print time(), " queue empty, returned to synchronious IO\n";
        
        # the queue is empty
    } redo }
    
    
    1; # Keep your mother happy.
    
    sub install_rules { ## the rules
        $_[0]->install(
            ### DEPENDANCIES
            Rule::Dependancy::Simple->new({ # basic (network unrelated) da
    +ta
                provides => ["basic"],
                evaluate => sub {
                    my $packet = shift;
                    my $basic = new Dependancy::Simple;
                    
                    $basic->set("size",length($packet));
                    
                    {basic => $basic};
                },
            }),
            
            Rule::Dependancy::Simple->new({ # ip packet data
                provides => ["ip"],
                evaluate => sub { {ip => NetPacket::IP->decode($_[0]) } }
            }),
            
            Rule::Dependancy::Simple->new({ # tcp packet data
                needs => ["ip"],
                provides => ["tcp"],
                evaluate => sub {
                    #print "providing tcp packet dependancy\n";
                    ##print "got packet: ", unpack("H*",$_[0]), "\n";
                    ##print "Available dependancies:\n\n", do { use Data::
    +Dumper; Dumper $_[1] },"\n";
                    
                    ($_[1]{ip}{proto} == IP_PROTO_TCP) ? {tcp => NetPacket
    +::TCP->decode($_[1]{ip}{data}) } : {} }
            }),
            
            Rule::Dependancy::Simple->new({ # udp packet data
                needs => ["ip"],
                provides => ["udp"],
                evaluate => sub { ($_[1]{ip}{proto} == IP_PROTO_UDP) ? {ud
    +p => NetPacket::UDP->decode($_[1]{ip}{data}) } : {} }
            }),
            
            Rule::Dependancy::Simple->new({ # icmp packet data
                needs => ["ip"],
                provides => ["icmp"],
                evaluate => sub { ($_[1]{ip}{proto} == IP_PROTO_ICMP) ? {i
    +cmp => NetPacket::ICMP->decode($_[1]{ip}{data}) } : {} }
            }),
            
            ### RULES
            Rule::Simple->new({ # handle Type of Service et cetera (delay 
    ++= 8, thoroughput += 5, reliability += 4, cost += 1, congestion += 2)
                needs => ["ip"],
                evaluate => sub { 0 },
            }),
    
            Rule::Simple->new({ # packet size
                needs => ["basic"],
                evaluate => sub {
                    #print "evaluating size based score adjustment\n";
                    length($_[1]{basic}->get("size")) ? (1.5 * log(length(
    +$_[1]{basic}->get("size")))) : 0 }
            }),
            
            Rule::Simple->new({ # tcp window size
                needs => ["tcp"],
                evaluate => sub {
                    #print "evaluating window size score adjustment\n";
                     $_[1]{tcp}{winsize} ? 0.1 * log($_[1]{tcp}{winsize}) 
    +: 0 }
            }),
            
            Rule::Simple->new({ # icmp conditional
                needs => ["icmp"],
                evaluate => sub {
                    #print "packet is icmp, -20\n";
                    -20 },
            }),
            
            
            Rule::Simple->new({ # udp conditional
                needs => ["udp"],
                evaluate => sub {
                    #print "packet is UDP, -6\n";
                     -6 },
            }),
            
            Rule::Simple->new({ # tcp flags
                needs => ["tcp"],
                evaluate => sub {
                    #print "evaluating tcp flags\n";
                    my $flags = $_[1]{tcp}{flags};
                    
                    my $ret = 0;
                    
                    # tcp messages with special information have varying d
    +egrees of additional importance
                    $ret -= 1   if $flags & FIN;
                    $ret -= 8   if $flags & SYN;
                    $ret -= 20  if $flags & RST; # attempt to help prevent
    + waste by pushing as fast as possible. They're pretty rare anyway
                    $ret -= 5   if $flags & PSH;
                    $ret -= 2   if $flags & ACK; # packets without acks ar
    +en't as urgent
                    $ret -= 20  if $flags & URG;
                #   $ret += 0   if $flags & ECE;
                #   $ret += 0   if $flags & CWR;
                    #print "final score: $ret\n";
                    $ret;
                }
            }),
            
            Rule::Simple->new({ # generic (udp, tcp) port handling
                wants => ["tcp","udp"], # we either have tcp, or tcp
                evaluate => sub {
                    #print "evaluating port rules\n";
                    my $prot = (exists $_[1]->{tcp}) ? $_[1]{tcp} : $_[1]{
    +udp};
                    
                    my $ret = 0;
                    
                    my $src = $prot->{src_port};
                    my $dst = $prot->{dest_port};
                    
                    #print "ports: dest=$dst, src=$src\n"; 
                    
                    SWITCH: { # source port
                        # unpriviliged ports
                        $src > 1024 and do {
                            $ret += 2;
                            
                            #print "source port is unpriviliged\n";
                            
                            $ret += 18, last if ($src >= 6881 and $src <= 
    +6888);    # bittorrent
                            $ret += 17, last if $src == 5501;             
    +      # hotline
                            $ret += 15, last if $src == 20;               
    +      # ftp data
                            
                            last;
                        };
                        
                        # important services
                        $src == 80  and $ret -= 1, last;    # http
                        $src == 443 and $ret -= 1, last;    # https
                        $src == 143 and $ret -= 4, last;    # imap
                        $src == 110 and $ret -= 4, last;    # pop3
                        $src == 25  and $ret -= 5, last;    # smtp
                        $src == 22  and $ret -= 7, last;    # ssh
                        $src == 21  and $ret -= 6, last;    # ftp control
                    }
                    
                    SWITCH: { # destination port
                        $dst > 1024 and do {
                            $ret += 3;
                            
                            #print "destination port is unpriviliged\n";
                            
                            $ret += 16, last if ($dst >= 6881 and $dst <= 
    +6888) and not ($src >= 6881 and $src <= 6888);
                            $ret += 15, last if $dst == 5501;
                            $ret += 14, last if $dst == 20;
                            
                            last;
                        };
                        
                        $dst == 80  and $ret -= 6, last;    # http
                        $dst == 443 and $ret -= 6, last;    # https
                        $dst == 143 and $ret -= 4, last;    # imap
                        $dst == 110 and $ret -= 4, last;    # pop3
                        $dst == 25  and $ret -= 2, last;    # smtp
                        $dst == 22  and $ret -= 10, last;   # ssh
                        $dst == 23  and $ret -= 10, last;   # telnet
                        $dst == 21  and $ret -= 6, last;    # ftp ctrl
                    }
                    
                    #print "port score: $ret\n";
                    
                    $ret;
                }
            }),
        )
    }
    
    package Rules; # API for joint abstraction - rules depend on common sh
    +ared data, and may be added and removed.
    
    # rules evaluate recursive, possibly asynchroniously in the future.
    # once a dependancy is solved it may not be altered, and all it's chil
    +dren may be computed on it with no locking - methods are supposed to 
    +return static or unrelated data.
    # a dependancy gets it's own 
    
    
    # dependancy is either or: (more complexity may be built by creating e
    +mpty dependnancy rules)
    # needs -> a strong dependancy list. every dependancy must be met (eva
    +luated as soon as all are met)
    # wants -> a weak dependnancy list, at least one must be met (evaluate
    +d as soon as one is met)
    
    # evaluate -> run the rule, and return either a hash of dependancy obj
    +ects, or a score modification
    
    # provides -> currently irrelevant. for hinting install in the future
    
    sub new {
        bless [],shift; # dependancy tree, inverse dependancy tree, rules 
    +pending parent, execution tree
    }
    
    sub install { # clear rules that will never have all their dependancie
    +s met, and then filter for duplicates
        my $self = shift;
        
        # filter here
        
        #print "installing score rules\n";
        
        push @$self,@_;
    }
    
    sub evaluate { # evaluate all of the rules and return the sum
        my $self = shift;
        my $packet = shift;
        #no warnings; # perl doesn't like me playing with closures
        
        my %offers;
        my %deferred;
        my @ruleq;
        
        my $score = 0;
        
        #print "evaluating entire ruleset\n";
        
        foreach my $rule (@$self){
            my $dep = [ 0, $rule ];
            
            # build dependancy counter
            if ($rule->has_deps){
                my @needs;
                if ($rule->strong_deps){
                    @needs = grep { not exists $offers{$_} } $rule->needs;
                    $dep->[0] = scalar @needs;
                } else {
                    $dep->[0] = 1;
                    @needs = grep { $dep->[0] and (exists $offers{$_} ? ((
    +$dep->[0] = 0),undef) : 1) } $rule->needs;
                    $dep->[0] or @needs = ();
                }
                #print "this rule needs (@needs)\n";
                foreach my $dependancy (@needs){
                    $deferred{$dependancy} = $dep;
                }
            }
            
            push @ruleq,try($packet,\$score,\%offers,\%deferred,$dep);
        }
        
        my $last = scalar @ruleq;
        while(@ruleq){ # finish the loop
            #print "attempting to evaluate remaining rules\n";
            push @ruleq, try($packet,\$score,\%offers,\%deferred,shift @ru
    +leq);
            
            (last == @ruleq) ? last : ($last = @ruleq); # break an infinit
    +e loop
        }
        
        #print "Final score is $score\n";
        return $score;
        
        sub try {
            my ($packet,$score,$offers,$deferred,$dep) = (@_);
            #print "trying to evaluate rule\n";
            if ($dep->[0] < 1){
                #print "all dependancies met\n";
                my $ret = $dep->[1]->evaluate($packet,$offers);
                if (ref $ret){
                    #print "rule introduced new offerings:";
                    foreach my $key (keys %{$ret}){
                        #print " $key,";
                        $offers->{$key} = $ret->{$key}; # install dependan
    +cies
                        
                        foreach my $dependant (@{$deferred->{$key}}){
                            $dependant->[0]--; # dependancy count goes dow
    +n by one
                        }
                    }
                    #print "\n";
                } else {
                    #print "rule adjusted score by $ret\n";
                    $$score += $ret;
                } # don't forget this is a closure
                
                return (); # we have nothing to requeue
            } else {
                #print "unmet dependancies\n";
                return $dep; # requeue the current one
            }
        }
    }
    
    ## base packages for rules
    
    package Rule::Simple; # a rule is something that fits in rules, and wo
    +rks via a certain API. a leaf in a dependancy tree
    
    sub new {
        my $pkg = shift;
        bless shift, $pkg;
    }
    sub has_deps { (exists $_[0]{needs} or exists $_[0]{wants}) ? 1 : unde
    +f };
    sub strong_deps { (exists $_[0]{needs}) ? 1 : undef };
    sub needs { (exists $_[0]{needs}) ? @{$_[0]{needs}} : @{$_[0]{wants}} 
    +}
    sub evaluate { goto &{shift->{evaluate}} }
    
    package Rule::Dependancy::Simple; # a dependancy rule is something ano
    +ther dependancy rule or plain rule needs. a node in a dependancy tree
    +.
    
    use base "Rule::Simple"; # a simple rule that also provides();
    sub provides { @{$_[0]{provides}} }
    
    package Dependancy::Simple; # a dependancy is something a dependancy r
    +ule creates - This is just a base class for dependancy objects to wor
    +k on. It contains plain values, and is basically a blessed hash
    
    sub new { bless {},shift }
    
    sub set { # set a value
        $_[0]{$_[1]} = $_[2];
    }
    
    sub get { # get a value
        $_[0]{$_[1]}
    }
    
    __END__
    
DOS Wrapper
1 direct reply — Read more / Contribute
by bl0rf
on Oct 04, 2003 at 20:24
    #!/usr/bin/perl -W
    
    # Copyright Jacob Filipp, 2003
    # This program is provided as is, you are free to use
    # it in any way as long as the copyright notice is
    # in the code
     
    # Yes dear monks, Quick-And-Dirty-Operating-System (DOS)
    # is still used. Here is a tiny shell wrapper in Perl,
    # to implement all the wonderful features that DOS lacks
    # ,like command aliasing. Although this tiny script is
    # meagre compared to your mathematical-script prowess
    # it is very flexible and someone might actually like
    # to use it ( from sheer curiosity, of course ).
    
    # The only fancy trick it has is the ability to launch
    # your browser when a URL is typed ( the first case in
    # the dispatch table. Interactive progs are run in a
    # separate window.
    
    use Strict;     # just for you monks, I never use it
    
    $SIG{ CHLD } = sub{ wait() };
    
    $browser_path  = 'C:\Program Files\Internet Explorer\iexplore';
    $prompt   = sub{ 'Sh-wrap>' };    # can be a routine...
    @kids = ();            # forked processes
    
    # dispatch table with regexes, used to execute commands
    # based on a shell command passed to it as an argument
    
    %dispatch = (
    
    '^(http://)?\S+\.(\w){3}.*$'        =>sub{
        my $kpid = fork();
        if( $kpid == 0 ){ exec("\"$browser_path\" $_[0]") and exit}
        else { push( @kids, $kpid ); sleep 1 }
    # sleep needed to make sure that child acts first
        },
    
    '^cd\s'        => sub
        { $_[0] =~ s!^cd\s!!; chdir($_[0]) },
    
    '^(exit|quit)$'    => sub{ kill( 9, @kids); exit },
    
    '^(ftp|telnet|edit|debug).*'    => sub { `start $_[0]` }
    # interactive progs in new window
    # will barf when running ftpd, telnetter, editors, debuggame etc...
    );
    
    WH: while(1)
    {
    
    print $prompt->();
    my $line = <>;
    chomp $line;
    
    foreach $regex ( keys %dispatch )
     {
       if( $line =~ m!$regex! )
       { $dispatch{ $regex }->($line); next WH }
       # permit only one match
     }
    
    print `$line`;
    
    }
    
Remove Duplicates from a mbox file
1 direct reply — Read more / Contribute
by coolmichael
on Sep 23, 2003 at 02:38
    #!/usr/bin/perl
    
    # Simple program to remove duplicate email messages
    # from an mbox file. This program only looks at the content
    # of the message for uniqueness, not entire message with the headers.
    # There is no file locking, use this program on a backup 
    # of your mbox file.
    # Enjoy.
    
    use strict;
    use warnings;
    use Digest::MD5 qw(md5_hex);
    
    #grab file names from the program parameters.
    #and do some error checking.
    my ($from, $to) = @_;
    die "usage: $0 from to" unless (defined $from && defined $to);
    my (%uniq, $msg);
    my ($head, $body);
    my $i = 0;
    
    $|++;
    
    open (my $fh, "<$from") || die "cannot open $from: $!";
    while(<$fh>) {
        #emails in mbox files always begin with ^From 
        #when /^From / is matched, process the previous message
        #then start on this message
        if(m/^From /) {
            next if ($msg eq "");
            #increment the counter for a status report
            $i++;
            #print a status report if necessary.
            #I like to do it this way
            print '.' if(($i % 50) == 0);
            print " $i\n" if(($i % 1000) == 0);
            #since evolution can give different headers on the same messag
    +e,
            #only hash the body of the message, and use that to compare to
    + other
            #emails. The entire message will be stored in the hash though.
            ($head, $body) = split /\n\n/, $msg;
            #standard perl technique for removing duplicates, using hashes
    + and 
            #md5 files.
            $uniq{md5_hex($body)} = $msg;
            
            #done processing the previous message, start the next message
            $msg = $_;
        } else {
            #current line didn't match /^From / so this line is part of th
    +e
            #middle of the current message. Just tack it on to the end.
            $msg .= $_;
        }
    }
    
    #print the results to a file.
    open (my $th, ">$to") || die "cannot open $to: $!";
    while(my ($k, $v) = each %uniq) {
        print $th $v;
    }
    
Solving electronics problems with Perl
3 direct replies — Read more / Contribute
by tsee
on Sep 07, 2003 at 09:48
    #!/usr/bin/perl
    use strict;
    use warnings;
    
    # Perl solving a physics / electrodynamics problem involving
    # symbolic mathematics, derivatives and complex numbers:
    
    use Math::Symbolic qw/:all/;
    use Math::Complex;
    
    # Given the following simple circuit:
    #
    #  ----|||||-----/\/\/\----       (R = resistor,
    # |      R          L      |       L = solenoid,
    # |                        |       U = alternating voltage)
    #  ---------O ~ O----------
    #            U(t)
    #
    # Question: What's the current in this circuit?
    #
    # We'll need some physics before letting the computer do the
    # math:
    # Applying Kirchhoff's rules, one quickly ends up with the
    # following differential equation for the current:
    #     (L * dI/dt) + (R * I)  =  U
    
    my $left  = parse_from_string('L * total_derivative(I(t), t) + R * I(t
    +)');
    my $right = parse_from_string('U(t)');
    
    <div class="readmore">
    # If we understand current and voltage to be complex functions,
    # we'll be able to derive. ("'" denoting complex here)
    #    I'(t) = I'_max * e^(i*omega*t)
    #    U'(t) = U_max  * e^(i*omega*t)
    # (Please note that omega is the frequency of the alternating voltage.
    # For example, the voltage from German outlets has a frequency of 50Hz
    +.)
    
    my $argument = parse_from_string('e^(i*omega*t)');
    my $current  = parse_from_string('I_max') * $argument;
    my $voltage  = parse_from_string('U_max') * $argument;
    
    # Putting it into the equation:
    $left->implement( I  => $current );
    $right->implement( U => $voltage );
    
    $left = $left->apply_derivatives()->simplify();
    
    # Now, we can solve the equation to get a complex function for
    # the current:
    
    $left  /= $argument;
    $right /= $argument;
    my $quotient = parse_from_string('R + i*omega*L');
    $left  /= $quotient;
    $right /= $quotient;
    
    # Now we have:
    #    $left    = $right
    #    I_max(t) = U_max / (R + i*omega*L)
    # But I_max(t) is still complex and so is the right-hand-side of the
    # equation!
    
    # Making the symbolic i a "literal" Math::Complex i
    $right->implement(
        e => Math::Symbolic::Constant->euler(),
        i => Math::Symbolic::Constant->new(i),    # Math::Complex magic
    );
    
    print <<'HERE';
    Sample of complex maximum current with the following values:
      U_max => 100
      R     => 10
      L     => 10
      omega => 1
    HERE
    
    print "Computed to: "
      . $right->value(
        U_max => 100,
        R     => 10,
        L     => 10,
        omega => 1,
      ),
      "\n\n";
    
    # Now, we're dealing with alternating current and voltage.
    # So let's make a generator that generates nice current
    # functions of time!
    #   I(t) = Re(I_max(t)) * cos(omega*t - phase);
    
    # Usage: generate_current(U_Max, R, L, omega, phase)
    sub generate_current {
        my $current = $right->new();    # cloning
    
        $current *= parse_from_string('cos(omega*t - phase)');
    
        $current->implement(
            U_max => $_[0],
            R     => $_[1],
            L     => $_[2],
            omega => $_[3],
            phase => $_[4],
        );
        $current = $current->simplify();
        return sub { Re( $current->value( t => $_[0] ) ) };
    }
    
    print "Sample current function with: 230V, 2Ohms, 0.1H, 50Hz, PI/4\n";
    my $current_of_time = generate_current( 230, 2, 0.1, 50, PI / 4 );
    
    print "The current at 0 seconds:   " . $current_of_time->(0) . "\n";
    print "The current at 0.1 seconds: " . $current_of_time->(0.1) . "\n";
    print "The current at 1 second:    " . $current_of_time->(1) . "\n";
    
    </div>
    
Symbolic mathematics in Perl
2 direct replies — Read more / Contribute
by tsee
on Aug 28, 2003 at 09:52
    # For some time now, symbolic calculation can be carried
    # out from within Perl: (warning: plug from module author)
    # 
    # If you find this interesting, check out the module on CPAN
    # and/or actively help with the development!
    
    use strict;
    use warnings;
    use Math::Symbolic qw/:all/;
    
    my $energy = parse_from_string(<<'HERE');
        kinetic(mass, velocity, time) +
        potential(mass, z, time)
    HERE
    
    $energy->implement(kinetic => '(1/2) * mass * velocity(time)^2');
    $energy->implement(potential => 'mass * g * z(t)');
    
    $energy->set_value(g => 9.81); # permanently
    
    print "Energy is: $energy\n";
    
    # Is how does the energy change with the height?
    my $derived = $energy->new('partial_derivative', $energy, 'z')
                         ->apply_derivatives()
                 ->simplify();
    
    print "Changes with the heigth as: $derived\n";
    
    # With whatever values you fancy:
    print "Putting in some sample values: ",
          $energy->value(mass => 20, velocity => 10, z => 5),
          "\n";
    
    # Too slow?
    $energy->implement(g => '9.81'); # To get rid of the variable
    
    my ($sub) = Math::Symbolic::Compiler->compile($energy);
    
    print "This was much faster: ",
          $sub->(20, 10, 5),  # vars ordered alphabetically
          "\n";
    
    
    # Output:
    # Energy is: (((1 / 2) * mass) * (velocity ^ 2)) + ((mass * g) * z)
    # Changes with the heigth as: mass * g
    # Putting in some sample values: 1981
    # This was much faster: 1981
    
Birthday List
2 direct replies — Read more / Contribute
by Drgan
on Aug 28, 2003 at 09:14
    #!/usr/bin/perl -w
    #####################################################################
    # This is a test program to start work on building up some real     #
    # skill with Perl. Also, must remember to refer to Perl as Perl and #
    # not PERL. Someone might get offended.                             #
    # The purpose of this program is to create and read a small         #
    # flat-file database of birthdays to remember. Boring but useful.   #
    # Please be kind to me, this is my first Perl application and I     #
    # was hoping to get some feedback. Maybe the community can tell me  #
    # If I'm starting out good? So many of these ideas are still new to #
    # me because I'm so used to PHP's style.                            #
    #####################################################################
    
    use strict;                                # Enforce legal variables.
    
    my ($choice);                            # The user's choice.
    my ($name);                                # Person's name
    my ($date);                                # Birthday
    my (@birthdays);                        # List of Birthdays.
    my ($key);
    
    while () {
        print "(L)ist or (N)ew or (M)odify birthday? "; chomp($choice = <S
    +TDIN>);
        if ($choice =~ /l/i) {
        # User picked List
            open (IN, "birthdays.db") || die "Failure: $!";
            while (<IN>) {
                print;
            } # Print it all to the screen
            close (IN);
        } elsif ($choice =~ /n/i) {
            open (OUT, ">>birthdays.db") || die"Failure: $!";
    
            print "Enter person's name: "; chomp ($name=<STDIN>);
            print "Enter person's birthday: "; chomp ($date = <STDIN>);
            print OUT "$name:$date\n";
    
            close (OUT);
        } elsif ($choice =~ /m/i) {
            open (IN, "birthdays.db");
            push @birthdays, $_ while (<IN>);
            close (IN);
            $key = 0;
            foreach (@birthdays) {
                print "$key: $birthdays[$key]";
                $key++;
            } # Store file information in memory.
            $key = "";
            print "Enter record to modify: "; chomp ($key = <STDIN>);
            print "(M)odify or (D)elete? "; chomp ($choice = <STDIN>);
            open (OUT, ">birthdays.db");
            $birthdays[$key] = "" if ($choice =~ /d/i);
            print OUT @birthdays;
            if ($choice =~ /m/i) {
                print "Enter person's name: "; chomp ($name=<STDIN>);
                print "Enter person's birthday: "; chomp ($date = <STDIN>)
    +;
                $birthdays[$key] = "$name:$date\n";
                print OUT @birthdays;
            } # put it all back in the file.
            close (OUT);
            @birthdays = (); # Clear that annoying array. It causes proble
    +ms if we don't.
        }
    }
    
Organize you MP3 backup
2 direct replies — Read more / Contribute
by rlb3
on Aug 02, 2003 at 14:58
    =head1 DESCRIPTION
    
    Hello Monks,
        I figure the only way I'm going to get better at perl is
     by writing code and getting comments on it, so here is a
     module to scratch a itch I had.
    
        I've got lots of Mp3s. More that one CDs worth anyway. 
    So I needed something to separate them into CD sized directories.
    So here is my latest offering.
    
    
    package Mp3::Backup;
    use strict;
                                                                          
    +                                                        
    BEGIN {
            use Exporter ();
            use vars qw ($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
            $VERSION     = 0.01;
            @ISA         = qw (Exporter);
            #Give a hoot don't pollute, do not export more than needed by 
    +default
            @EXPORT      = qw ();
            @EXPORT_OK   = qw ();
            %EXPORT_TAGS = ();
    }
                                                                          
    +                                                        
    use File::Find;
    use File::Copy;
    use Data::Dumper;
    
                                                                          
    +                                                        
    sub new {
            my $class = shift;
                                                                          
    +                                                        
            my $ref = {
                    MP3DIR       => shift,                 # The directory
    + to backup
                    BACKUPDIR    => shift,                 # Where to back
    +up the mp3s
                    MAXSIZE      => (shift) * 1024 * 1024, # Size in kilob
    +yes each disk should be
                    DEBUG        => shift || 0,            # Set debug sta
    +tus;
                    FILELIST     => {},                    # Hash of all m
    +p3s
            };
                                                                          
    +                                                        
            my $self = bless ($ref, ref ($class) || $class);
                                                                          
    +                                                        
            return ($self);
    }
    
    # The sub builds the hash of mp3s to be backed up
    sub buildFileList {
            my $class = shift;
                                                                          
    +                                                        
            find(
                    sub {
                                                                          
    +                                                        
                            return unless ($File::Find::name =~ /\.mp3$/);
    + # Only mp3s
                            $class->{FILELIST}{$_}{PATH} = $File::Find::na
    +me;
                            $class->{FILELIST}{$_}{SIZE} = -s $File::Find:
    +:name;
                    },
                    $class->{MP3DIR}
                                                                          
    +                                                        
            );
                                                                          
    +                                                        
            $class->_dump if ($class->{DEBUG} == 1); # Just to check what 
    +you are getting
                                                                          
    +                                                        
    }
                                                                          
    +                                                        
    # Private method
    sub _dump {
            my $class = shift;
            print Dumper $class->{FILELIST}; # Print to STDOUT the content
    +s of the hash
    }
    
    # Build backup
    sub fullBackup {
            my $class = shift;
            my $size  = 0;
            my $name  = 'Disc';
            my $count = 1;
            my $flag  = 1;
            my $dirname = '';
                                                                          
    +                                                        
            my $list = $class->{FILELIST};
            my $maxsize = $class->{MAXSIZE};
                                                                          
    +                                                        
                                                                          
    +                                                        
            die("This is no directory named $class->{BACKUPDIR}\n") unless
    + -d $class->{BACKUPDIR};  # Die if no directory
                                                                          
    +                                                        
            foreach ( sort keys %$list) {
                                                                          
    +                                                        
                    if ($flag) { # There has got to be a better way to do 
    +this that seting a flag
                            $dirname = "$class->{BACKUPDIR}/$name$count"; 
    +# Create new directory name
                            mkdir $dirname; # Create the directory
                            print 'Creating new dir: '.$dirname."\n" if $c
    +lass->{DEBUG}; # Be more verbose
                            $flag = 0;
                            open LIST, ">$dirname/index.txt" || die ("Cann
    +ot open file for writing: $!"); # Create index of Mp3s
                    }
                                                                          
    +                                                        
                    copy ($class->{FILELIST}{$_}{PATH},$dirname); # Copy f
    +ile to new directoy
                    $size += $class->{FILELIST}{$_}{SIZE}; # Add total kil
    +obyes in directory
                    print LIST $_."\n";
                                                                          
    +                                                        
                    if ($size >= $maxsize) { # Set up for new directory
                            $flag = 1;
                            $count++;
                            $size = 0;
                    close LIST;
                    }
                                                                          
    +                                                        
            }
    }
                                                                          
    +                                                        
    1; #this line is important and will help the module return a true valu
    +e
    __END__
    
    
Prettified Perl Inheritance
2 direct replies — Read more / Contribute
by Kageneko
on Jul 29, 2003 at 13:40
    # (Please move this node if it belongs in Snippets or something)
    #
    # This little program will print a prettified inheritance
    # tree for the given perl module.  Its usage is:
    # perl-inheritance [<options>] <module-name>
    # e.g.: perl-inheritance Class::DBI
    #
    # Available options are:
    # -I<path> : include <path> in @INC
    # -a : attempt to use all modules instead of just the root one
    # -i : ignore modules that can't be found
    #
    # Some example output:
    # perl-inheritance Class::DBI
    # Class::DBI (v0.93)
    # +---Class::DBI::__::Base (v-1, set by base.pm)
    #     +---Class::Data::Inheritable (v0.02)
    #     +---Class::Accessor (v0.18)
    #     +---Ima::DBI (v0.29)
    #         +---Class::WhiteHole (v0.04)
    #         +---DBI (v1.37)
    #         |   +---Exporter (v5.567)
    #         |   +---DynaLoader (v1.04)
    #         +---Class::Data::Inheritable (loaded by Class::DBI::__::Base
    +)
    #
    # perl-inheritance Net::FTP
    # Net::FTP (v2.71)
    # +---Exporter (v5.567)
    # +---Net::Cmd (v2.24)
    # |   +---Exporter (loaded by Net::FTP)
    # +---IO::Socket::INET (v1.26)
    #     +---IO::Socket (v1.27)
    #         +---IO::Handle (v1.21)
    #             +---Exporter (loaded by Net::FTP)
    
    #!/usr/local/bin/perl -w
    use warnings;
    use strict;
    no strict 'refs';
    
    my @ignore_list      = ();
    my $ignore_not_found = 0;
    my %already_loaded   = ();
    my $load_all         = 0;
    
    ARG: while (@ARGV) {
      SWITCH: {
        ($ARGV[0] =~ /\-I(.+)/o) && do {
          eval "use lib '$1';";
          shift @ARGV;
         last SWITCH;
        };
        ($ARGV[0] =~ /\-i$/o) && do {
          $ignore_not_found = 1;
          shift @ARGV;
         last SWITCH;
        };
        ($ARGV[0] =~ /\-a$/o) && do {
          $load_all = 1;
          shift @ARGV;
         last SWITCH;
        };
        ($ARGV[0] =~ /\-i=(.+)/o) && do {
          @ignore_list = split " ", $1;
          shift @ARGV;
         last SWITCH;
        };
       last ARG;
      } ## end SWITCH:
    } ## end while (@ARGV)
    
    if (!@ARGV) {
      print STDERR "Usage: $0 <perl modules>\n";
      exit 1;
    }
    
    foreach (@ARGV) {
      %already_loaded = ();
      ScanModule(undef, $_, 0);
    }
    
    sub ScanModule {
      my $parent  = shift;
      my $module  = shift;
      my $depth   = shift;
      my @total   = @_;
      my $ignored = 0;
      my $loaded  = 0;
    
      $loaded = 1 if (exists $already_loaded{$module});
    
      eval "use $module" if (!defined $parent || $load_all);
      if ($@ =~ /Can't locate .+ in \@INC/o) {
        if ($ignore_not_found
          || index("@ignore_list ", "$module ") != -1) {
          $ignored = 1;
          } else {
          die "Error using $module: $@\n";
        }
      } elsif ($@) {
        die "Error using $module: $@\n";
      }
    
      if ($depth > 1) {
        for (my $iter = 0; $iter < @total - 2; $iter += 2) {
          if ($total[$iter] < $total[$iter + 1]) {
            print "|   ";
          } else {
            print "    ";
          }
        } ## end for (my $iter = 0; $iter...
      } ## end if ($depth > 1)
    
      if ($depth > 0) {
        print "+---";
      }
    
      print $module;
      print " (ignored)" if ($ignored);
      if ($loaded) {
        print " (loaded by $already_loaded{$module})\n";
      } else {
        my $version = $module->VERSION();
        print " (v$version)" if $version;
        print "\n";
        my $isa   = "${module}::ISA";
        my $count = 1;
        my $total = @$isa;
    
        foreach (@$isa) {
          ScanModule($module, $_, $depth + 1, @total, $count, $total);
          $count++;
        }
        $already_loaded{$module} = $parent;
      } ## end else [ if ($loaded)
    } ## end sub ScanModule
    
Small chat server...
2 direct replies — Read more / Contribute
by rlb3
on Jul 27, 2003 at 08:21
    This is based on a python script I found out on the net.
    I have not writen a client but it works with unix telnet clients.
    
    chat.pl...
    
    #!/usr/bin/perl
    
    use IO::Socket;
    use IO::Select;
    
    use Userlist;
    
    # Fork off...
    $pid = fork();
    exit if ($pid);
    
    #Turn off buffering
    $|++;
    
    my $quit = 0;
    
    # Handle the control-c
    $SIG{INT} = sub {$quit++};
    
    my $listen = IO::Socket::INET->new(
        LocalPort => 8080,
        Listen    => 20,
        Proto     => 'tcp',
        Reuse     => 1,
        Timeout   => 60*60
    );
    
    $read = IO::Select->new();
    $read->add($listen);
    
    while (!$quit) {
        my @ready = $read->can_read;
        
        foreach $selected (@ready) {
            if ($selected == $listen) {
                my $conn = $listen->accept;
                $ip = $conn->peerhost;
    
                            # Create new object
                $user = Userlist->new($conn);
                            
                            # Get the user's name
                $name = $user->getName;
                $count = push(@users,$user);
                print $conn $count."-".$name."-".$ip."\n";
                $read->add($conn) if $conn;
            } else {
                            # Get input from who's ready
                $buffer = <$selected>;
                       
                            # Send message to all users
    $user->broadcast($buffer,$selected,\@users);
            }    
        }
    }
    
    
    Userlist.pm...
    
    package Userlist;
    
    sub new {
    
        $self = shift;
        $obj = {
            USER => shift,
            NAME => ''
        };
    
        return bless $obj,$self;
    }
    
    sub conn {
        $self = shift;
        return $self->{USER};
    }
    
    sub getName {
        $self = shift;
        $conn = $self->{USER};
    
        print $conn "Name: ";
        $name = <$conn>;
        $name =~ s/\s+$//;
    
        $self->{NAME} = $name;
        return $self->{NAME};
    }
    
    sub name {
        $self = shift;
        return $self->{NAME};
    }
    
    # I'm not really sure if this is the best place to make this
    # sub, but its the only way I can think of to get the name
    # of the user that sent the message.
    
    
    sub broadcast {
        $self = shift;
        $buffer = shift;
        $selected = shift;
        $users = shift;
        if ($buffer) {
            foreach $client (@$users) {
                $connection = $client->conn();
                $name = $self->{NAME} if ($connection == $selected);
                exit(0) if ($buffer =~ /quit/i);
                print $connection $name.": ".$buffer;
            }
        }
    }
    1;
    
    
    
Log In?
Username:
Password:

What's my password?
Create A New User
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others pondering the Monastery: (9)
As of 2015-07-02 05:02 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    The top three priorities of my open tasks are (in descending order of likelihood to be worked on) ...









    Results (27 votes), past polls