Beefy Boxes and Bandwidth Generously Provided by pair Networks
good chemistry is complicated,
and a little bit messy -LW
 
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 cooling their heels in the Monastery: (7)
As of 2014-12-28 06:06 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    Is guessing a good strategy for surviving in the IT business?





    Results (178 votes), past polls