cufp

review a show (teamster_jr)

It's been a very long time since i posted - my new job allows me significantly less obfu time :).
Here's a quick something:

My friends and I are off to see a kung fu demonstration by a bunch of shaolin monks on sunday. One of my friends can't make it and said:

"I can't do this weekend, so I expect a 1000-word review first thing on Monday."So I knocked this up:

@d = map { rand > .9 ? "kick" : rand > .8 ? "jump" : "punch" } 0 .. 1000;for (    "leap through burning hoop",    "lie on bed of spikes",    "smash block over head"  ){    @a = split / /;    splice( @d, rand($#d), 1 + $#a, @a );}open(FH, ">kung_fu_review.html");print FH "@d";close(FH);

an instant (not entirely serious :)) 1000 word review (in the file kung_fu_review.html) of what i'm sure will be an amazing spectacle (if they keep to my script).
Alex

Update: it seems my review was spot on :)

Sports Conference Rankings, Colley Matrix Style (Zaxo)

It's (US) football season now, and arguments over Strength of Schedule and the iniquity of zebras are heard across the land.

This is [http://www.colleyrankings.com|Matthew Colley's] elegant method of calculating a probability-like ranking from the results of contests. I won't go into the mathematical details or properties of the method - there is a paper at Colley's site which gives that.

Colley uses this method to rank all Division-1A teams as part of the "computer" segment of the all-important BCS ratings. It is distinguished by its simplicity and lack of mystery tweaks.

The magnificent [cpan://PDL] module is ideal for carrying out these calculations. Here, I've applied them to intra-conference games only, to get a current conference ranking. The data is hard-coded in this simple version, with enough information in comments to let you replace it with your own favorite conference's results. It is more flexible and convenient to get the data by a database query or by web scraping.

#!/usr/bin/perl    # -*-EPerl-*-use PDL;my @becteams = (    'Pittsburgh',    'Louisville',    'Rutgers',    'West Virginia',    'South Florida',    'Connecticut',    'Syracuse',    'Cincinnati');# $C is the Colley Matrix. It depends only on the schedule# of games already played. Rows and columns are indexed in# the same order, by teams. The diagonal elements are the# number of games played plus two. Off-diagonals are zero # for no game yet played for the indexed teams, or minus one# for a game played. It contains nothing about the result of# the games. It's obviously a symmetric matrix.my $C = pdl([   # UP UL RU WV SF CT SU UC    [ 5, 0,-1, 0, 0, 0,-1,-1], # Pittsburgh    [ 0, 4, 0, 0, 0, 0,-1,-1], # Louisville    [-1, 0, 4, 0,-1, 0, 0, 0], # Rutgers    [ 0, 0, 0, 4, 0,-1,-1, 0], # West Virginia    [ 0, 0,-1, 0, 5,-1, 0,-1], # South Florida    [ 0, 0, 0,-1,-1, 4, 0, 0], # Connecticut    [-1,-1, 0,-1, 0, 0, 5, 0], # Syracuse    [-1,-1, 0, 0,-1, 0, 0, 5]  # Cincinnati]);# $wl is a column vector containing win and loss information.# For each team in the same order as $C is indexed, the value# is numerically 1 + (wins - losses)/2.my $wl = pdl([[ 3/2],[ 2 ],[ 2 ],[ 2 ],[ 1/2],[ 0 ],[-1/2],[ 1/2]]);#              Pitt   UL    Rut   WVU    USF  UConn   SU    Cincymy $c = $C->inv;my $r = $c x $wl;my %rating;@rating{@becteams} = list $r;{    my $ct = 1;    for (sort {$rating{$b}<=>$rating{$a}} keys %rating) {        my $out = pack 'A4 A20 A6', $ct++, $_, sprintf '%5.4f', $rating{$_};        print $out, $/;    }}__END__1   Rutgers             0.74432   Louisville          0.67793   West Virginia       0.63394   Pittsburgh          0.59125   Cincinnati          0.43106   South Florida       0.38617   Syracuse            0.28068   Connecticut         0.2550

Congratulations to Rutgers, their higher rating for the same record as Louisville and West Virginia comes from having beaten tougher teams so far. In the Big East everybody plays everybody, so that advantage will level off by the end of the season. A conference which is too large to allow all-pairs play admits more interesting use of this method.

After Compline,
Zaxo

What are YOUR friends listening to? (ailivac)

Last month I decided to jump on the last.fm (aka audioscrobbler) bandwagon. For those not in the know, this is a service where your music player program (using a special plugin) sends real-time updates about what music you're playing to a website, where they are entered into a database awaiting all sorts of statistical analysis you never thought possible (or at least not worth anybody's time). These range from simple things like a list of tracks you listened to recently, to weekly and monthly charts of your favorite artists and locating "neighbors" from among the other users who like the same things you do. And, as you would expect from a social-type website, you can establish friendships with other users.

Most of this information is available through web pages and also XML/RSS web services ready to be consumed by news aggregators or any other programs that people (like me) think up. One of the simplest web services lets you download an RSS feed with the last 10 tracks that any user played. Great, I can use Liferea to see what songs I've just listened to. This is of course sort of useless since by the time Quod Libet sends the song name to last.fm and Liferea pulls a fresh copy of the RSS, I'm probably onto another song already. More interesting is the fact that I can monitor one of my friend's listining habits in near real-time. But still, a single user isn't very interesting...

Another web service allows you to download an XML list of a user's friends. Combining this information with the feeds for individual users' recent tracks would actually provide some interesting information, but unfortunately they don't have a web service for this. HTTP requests, XML parsing, data sorting... Perl to the rescue! So I wrote the following script (it doesn't actually use the aforementioned RSS feeds, but an XML service that I figured would be easier to parse) to find out who my friends are, find out what they've been listening to, and write the results in text, RSS, or Data::Dumper format.

#!/usr/bin/perluse strict;use warnings;use XML::Parser;use Getopt::Lucid qw/:all/;use LWP::Simple;use Data::Dumper;use Heap::Simple;use POSIX qw/strftime/;my @friends;sub fparse_start {    my $expat = shift;    my $elt = shift;    if ($elt eq 'user')    {        my %attr = @_;        push @friends, $attr{username};    }}my @tracks;my $insertpoint = -1;sub tparse_start {    my $expat = shift;    my $elt = shift;    my %attr = @_;    if ($elt eq 'track')    {        push @tracks, [];    } elsif ($elt eq 'artist')    {        $insertpoint = 0;    } elsif ($elt eq 'name')    {        $insertpoint = 1;    } elsif ($elt eq 'url')    {        $insertpoint = 2;    } elsif ($elt eq 'date')    {        $tracks[$#tracks]->[3] = $attr{uts};        $insertpoint = 4;    }}sub tparse_char {    my $expat = shift;    my $string = shift;    if ($insertpoint > -1)    {        $tracks[$#tracks]->[$insertpoint] = $string;        $insertpoint = -1;    }}my @opts = (            Param('user|u')->required,            Param('mode|m')->default('text')           );my $opt = Getopt::Lucid->getopt( \@opts );my $user = $opt->get_user();my $mode = $opt->get_mode();my $xp = new XML::Parser(Handlers => {Start => \&fparse_start});my $content = get("http://ws.audioscrobbler.com/1.0/user/${user}/friends.xml");if ($content){    $xp->parse($content);    my $alltracks = new Heap::Simple(elements => [Array => 4],                                     order => '>');    foreach my $fr(@friends)    {        my $content = get("http://ws.audioscrobbler.com/1.0/user/${fr}/recenttracks.xml");        if ($content)        {            my $xp = new XML::Parser(Handlers => {                                                  Start => \&tparse_start,                                                  Char => \&tparse_char                                                 });            $xp->parse($content);            foreach my $t(@tracks)            {                $alltracks->insert([ $fr, @$t ]);            }            @tracks = ();        } else        {            print "error getting tracks for $fr\n";        }    }    if ($mode eq 'dump')    {        for (1..$alltracks->count())        {            my $tr = $alltracks->extract_top();            print Dumper(\$tr);        }    } elsif ($mode eq 'text')    {        for (1..$alltracks->count())        {            my $tr = $alltracks->extract_top();            print "User: $tr->[0]\n";            print "Track: $tr->[1] - $tr->[2]\nDate: $tr->[5]\n";        }    } elsif ($mode eq 'rss')    {        print "\n";        print "\n";        print "\n";        print "en\n";        print "", scalar localtime, "\n";        print "10\n";        print "${user}'s Friends' Recent Tracks\n";        for (1..$alltracks->count())        {            print "\n";            my $tr = $alltracks->extract_top();            my $title = "$tr->[0] - $tr->[1] - $tr->[2]";            my $date = strftime '%a, %d %b %Y %H:%M:%S %z', localtime $tr->[4];            print "$title\n";            print "$tr->[3]\n";            print "$date\n";            print "\n";        }        print "\n";        print "\n";    } else    {        print "Undefined output mode $mode\n";    }} else{    die "Badness!";}

Natural Doc - Create fancy documentation for your Perl code. (Ace128)

Hey!

I just had to post about this little tool since it's so cool and I was looking for such for ages, and if it wasnt for pure chance, I wouldnt have found it and I would have tried to do my own version wasting time. So, to avoid others do the same "misstake", I post about it here.

Besides, its also MADE in Perl! How cool is that? :)

What am I talking about? Well, [http://www.naturaldocs.org]

So, I can just do:

# Function: myFunc## Arguments:#  1. - This object.#  2. - Path to file.sub myFunc {  my ($self, $path) = @_;}

Runing the tool on this you get some really fancy documentation. (Check out [http://www.naturaldocs.org/documenting.html])

Well, thanks for your time and hope you like it.

/ Ace

Efficiently selecting a random, weighted element (jimt)

This problem was originally presented to me by a co-worker as such,

I have a set of 100 files, and I want to randomly choose 5 of them. However, I want to weight the selection of each file based upon the number of words in the file. More words == greater chance it will be randomly selected. The files could contain between 100 - 3,000 words. What's a good way to do this?

First of all, the approach I'm going to detail here is specific to this example, but can easily be adapted to any random selection of weighted values. It should scale very easily to very large data sets (number of files, in this case), with very large weighting information (number of words, in this case). This post is mostly pseudo-code and explanation, not a functional piece of code. This solution has probably been created by other people before.

Okay, for sake of example, we're going to start off with 5 files.

my @files = qw(file_a.txt file_b.txt file_c.txt file_d.txt file_e.txt);

And we want to randomly choose 2 of the files. But, we want to weight our selections based off of the number of words in the file. More words in a file == more likely the file will be chosen.

Your first thought might be to build an array of all of the words in all of the files, then pick a random index, and determine which file the word is in. Note - you would need to pre-cache which word at which index is associate with which file. For example, the word "the" could appear at file_a.txt or file_b.txt. So you can't just randomly choose index 3, see "the" there, and know which file it's in. You have to know that index 3 => the => file_a.txt.

This is the first optimization. The words don't matter, only which file they're in. So instead of storing the word at each point, you can just store the file name. At this point, you'll need to be able to count the number of words in each file to get your weighting information. This is left as an exercise to the reader - use your favorite word counting widget. For example's sake, we'll say you end up with this structure:

my %words_in_files = ('file_a.txt'=> 10,'file_b.txt'=> 1,'file_c.txt'=> 3,'file_d.txt'=> 5,'file_e.txt'=> 10);

Now you can build up an array where the first 10 elements are "file_a.txt", the next one is "file_b.txt" and so on. For simplicity's sake, we'll display each file as its trailing letter ("file_a.txt" becomes "a"). This way, we can see our data:

aaaaaaaaaabcccdddddeeeeeeeeee

This approach is fully functional, but doesn't scale well. In our original problem, we had 100 files, with up to 3,000 words each. This is potentially a 300,000 element array, and it's just gonna get bigger if you add more files or words within the files. Don't get me wrong - perl can do it, but there's a better way.

The key is to realize that most of the information in that array is redundant. We're storing "a" 10 times. Do we really need to? Instead, we'll build a different data structure. In this structure, we'll store the file name, and the index at which the file begins. Externally, we'll also store a count of the total number of words. We end up with a structure along these lines:

my @indexes_of_files = (# terminology: index 0 == "file offset, index 1 == "file name"[ qw( 0  file_a.txt ) ],[ qw( 10 file_b.txt ) ],[ qw( 11 file_c.txt ) ],[ qw( 14 file_d.txt ) ],[ qw( 19 file_e.txt ) ],);my $total_number_of_words = 29;

Feel free to use hashrefs instead of arrayrefs, they may be easier to work with. I used arrayrefs here for simplicity of code display in the example. Note that the order of the files in this data structure is arbitrary. Whatever order the files are assigned in this array is irrelevant, so long as their file offsets change as appropriate.

We now have a much more compact data structure. Our algorithm is easy - generate a random integer between 0 and $total_number_of_words - 1 (0..28, in this case). Let's say that we generated "15".

Next, you need to search through the @indexes_of_files array to find the greatest file offset that's less than our generated number. Since the file information is in sorted order, a binary search can zip through the data in no time. Implementing the binary search (or whatever) algorithm is another exercise left to the reader.

However you find your data, you'll discover that you're looking at array element 4, which has file offset 14, corresponding to "file_d.txt". Note that if you count off 15 ticks into the "aaaa...b...cc..." array drawn out above, you'll also reach a "d", corresponding to file_d.txt.

You have now successfully chosen your first file, so you need to set up for subsequent ones. This is a 3 step op. One is easy, one is expensive, and one is tedious. First, the easy step.

Subtract from $total_number_of_words the length of the file you just chosen. In this case, file_d.txt has a length of 5 words, so $total_number_of_words becomes 24. You can re-calculate this length now using the the index of the element you were at and the index of the next element, you can cache it into the data structure, you can look up in the hash created earlier. Dealer's choice. But you need the length.

The "expensive" operation is simply to splice out the element at index [4].

Finally, for all elements >= the one you've removed ([4]), subtract from their file offset the length of the file just removed (5, in this case). You'll end up with this data structure when you're done:

my @indexes_of_files = (# terminology: index 0 == "file offset, index 1 == "file name"[ qw( 0  file_a.txt ) ],[ qw( 10 file_b.txt ) ],[ qw( 11 file_c.txt ) ],# THIS FILE WAS REMOVED [ qw( 14 file_d.txt ) ],[ qw( 14 file_e.txt ) ], #this file offset was 19, is now 14.);my $total_number_of_words = 24;#previously 29

And blam-o, you're set up to choose your next file, it's as if file_d.txt never existed, and you can repeat ad infinitum until you've selected enough files out.

Considerations

With tremendously long lists of data (for this example, say thousands or millions of files), you need to do a splice on a large array, and then run through all higher elements to do a subtraction. You're just iterating over an array and doing a subtraction on an integer, but it's still O(n). There may be fancier ways to do this w/o splicing or changing offsets, but I was unable to come up with an elegant one. They all seemed fragile and complicated relative to just decrementing the indexes. YMMV.
This can be applied to any set of data that you need to randomly select a value from based on a weighting value.
For smaller data sets, it may be simpler to just use the "aaa...b...cc..." approach of an array that lists all the file names. But it doesn't scale as well.
There may be something that does this efficiently already on CPAN.

A CGI whiteboard in Perl (OfficeLinebacker)

Greetings, esteemed monks!

I just want to share with the community a project of which I am particularly proud, not so much because of its complexity (though I did have to learn a little DBI, SQLite, and Postgres to do it), but because of the success with which it has met since I wrote it. It was originally conceived as an electronic whiteboard for communication in an emergency situation, where people could put up notes for to inform others in the organization of their status. Anyway my Division Director (boss' boss' boss' boss) liked it so much it's now a whiteboard for everyday use. I've also gotten two feature requests, one of which I plan to try to implement today. I will post the program in a follow-up to this post so I don't have to do readmore tags or take up lots of vertical space.

_________________________________________________________________________________

I like computer programming because it's like Legos for the mind.

New family addition (tbone1)

My wife (better known as She Who Must Be Obeyed) and I decided to expand our family, as can be seen here. We had trouble picking a name for her, though. I thought of "Cato June" because 1) we're Colts fans, 2) he lays some wicked tackles, and 3) when we were at the humane society, she put a from-behind tackle on our older son that had to be seen to be believed. (His nose was thoroughly licked in the process.) After trying about a dozen names, none of which really worked, we settled on Perl. Well, of course. The best part is, it was my wife's idea (ah, geek love!) and we can always say that we wanted a name that none of our friends or family (or their pets) have. Which, if you haven't done it, is not as easy as it sounds.

Anyway, she is an absolute sweetie and has won our hearts completely, and I cannot think of a better use of perl than naming you family dog.

--
tbone1, YAPS (Yet Another Perl Schlub)
And remember, if he succeeds, so what.
- Chick McGee

XML Navigator (ruoso)

Well, editing XMLs in the text itself is a boring task. Mentally visualizing it is quite hard sometimes. So i wanted to write a node-centric XML Viewer/Editor which would allow me to make a better visualization of semi-structured XMLs.

I decided to craft something in Gtk2 and ended with the following code...

This is the start for what the editor will looks like, and the good news is that you can use the navigator as a widget in any application, as it's a Perl/Glib Object. It works nice for complex XMLs, but I think it would suffer with big XMLs as, for some reason I can't explain, I choosed to use XML::DOM.

Well, the first snippet is the module that implements the widget XMLNavigator. The second snippet is a program that uses it.

The way you can use it is: 1) click on a node to put it into the center. 2) for children of the center node, you can use the mouse scroll to navigate through them. Have fun.

The Module:

package XMLNavigator;use strict;use warnings;use Gtk2;use XML::DOM;use POSIX qw(ceil);use constant DEFAULT_COLLAPSED_BOX_WIDTH => 75;use constant DEFAULT_COLLAPSED_BOX_HEIGHT => 45;use constant DEFAULT_FULL_BOX_HEIGHT => 155;use constant DEFAULT_FULL_BOX_WIDTH => 160;use constant DEFAULT_INSETS => 40;use constant RETICENCIAS_WIDTH => 15;use constant RETICENCIAS_HEIGHT => 5;use Glib::Object::Subclass  'Gtk2::DrawingArea',  signals =>  {   model_changed =>   {    method => 'do_model_changed',    flags => [qw/run-first/],    return_type => undef,    param_types => []   }  },  properties =>  [   Glib::ParamSpec->scalar   ('domdocument',    'domdocument',    'Object containing the DOM Document',    [qw/readable writable/]),   Glib::ParamSpec->int   ('collapsed_box_width',    'collapsed_box_width',    'Width of the collapsed box',    0,    500,    DEFAULT_COLLAPSED_BOX_WIDTH,    [qw/readable writable/]),   Glib::ParamSpec->int   ('collapsed_box_height',    'collapsed_box_height',    'Height of the collapsed box',    0,    500,    DEFAULT_COLLAPSED_BOX_HEIGHT,    [qw/readable writable/]),   Glib::ParamSpec->int   ('full_box_height',    'full_box_height',    'Height of the full box',    0,    500,    DEFAULT_FULL_BOX_HEIGHT,    [qw/readable writable/]),   Glib::ParamSpec->int   ('full_box_width',    'full_box_width',    'Width of the full box',    0,    500,    DEFAULT_FULL_BOX_WIDTH,    [qw/readable writable/]),   Glib::ParamSpec->int   ('insets',    'insets',    'Insets between boxes',    0,    500,    DEFAULT_FULL_BOX_WIDTH,    [qw/readable writable/]),   Glib::ParamSpec->int   ('max_hori_distance',    'max_hori_distance',    'Maximum Horizontal Distance',    0,    500,    3,    [qw/readable writable/]),   Glib::ParamSpec->int   ('max_vert_distance',    'max_vert_distance',    'Maximum Vertical Distance',    0,    500,    3,    [qw/readable writable/])  ];sub INIT_INSTANCE {        my $self = shift;        $self->{domdocument} = undef;        $self->{matrix} = {};        $self->{collapsed_box_height} = DEFAULT_COLLAPSED_BOX_HEIGHT;        $self->{collapsed_box_width} = DEFAULT_COLLAPSED_BOX_WIDTH;        $self->{full_box_width} = DEFAULT_FULL_BOX_WIDTH;        $self->{full_box_height} = DEFAULT_FULL_BOX_HEIGHT;        $self->{max_vert_distance} = 3;        $self->{max_hori_distance} = 3;        $self->{insets} = DEFAULT_INSETS;        $self->signal_connect(button_press_event => \&button_press_event);        $self->signal_connect(expose_event => \&expose_event);        $self->signal_connect(configure_event => \&configure_event);        $self->signal_connect(size_request => \&do_size_request);        $self->signal_connect(scroll_event => \&scroll_event);        $self->set_events          ([qw(exposure-mask               leave-notify-mask               button-press-mask               button-release-mask               scroll-mask)]);}sub GET_PROPERTY {        my ($self,$pspec) = @_;        if ($pspec->get_name eq 'collapsed_box_height') {                return $self->{collapsed_box_height};        } elsif ($pspec->get_name eq 'collapsed_box_width') {                return $self->{collapsed_box_width};        } elsif ($pspec->get_name eq 'full_box_height') {                return $self->{full_box_height};        } elsif ($pspec->get_name eq 'full_box_width') {                return $self->{full_box_width};        } elsif ($pspec->get_name eq 'insets') {                return $self->{insets};        } elsif ($pspec->get_name eq 'domdocument') {                return $self->{domdocument};        } elsif ($pspec->get_name eq 'matrix') {                return $self->{matrix};        } elsif ($pspec->get_name eq 'max_hori_distance') {                return $self->{max_hori_distance};        } elsif ($pspec->get_name eq 'max_vert_distance') {                return $self->{max_vert_distance};        }}sub SET_PROPERTY {        my ($self,$pspec,$newval) = @_;        if ($pspec->get_name eq 'collapsed_box_height') {                return $self->{collapsed_box_height} = $newval;        } elsif ($pspec->get_name eq 'collapsed_box_width') {                return $self->{collapsed_box_width} = $newval;        } elsif ($pspec->get_name eq 'full_box_height') {                return $self->{full_box_height} = $newval;        } elsif ($pspec->get_name eq 'full_box_width') {                return $self->{full_box_width} = $newval;        } elsif ($pspec->get_name eq 'insets') {                return $self->{insets} = $newval;        } elsif ($pspec->get_name eq 'domdocument') {                $self->{domdocument} = $newval;                $self->{matrix} = {};                $self->plan_matrix();                $self->queue_draw();        } elsif ($pspec->get_name eq 'matrix') {                $self->{matrix} = $newval;                $self->plan_matrix();                $self->queue_draw();        } elsif ($pspec->get_name eq 'max_hori_distance') {                return $self->{max_hori_distance} = $newval;        } elsif ($pspec->get_name eq 'max_vert_distance') {                return $self->{max_vert_distance} = $newval;        }}sub do_model_changed {}sub plan_matrix {        my $self = shift;        my $max_hori_distance = $self->{max_hori_distance};        my $max_vert_distance = $self->{max_vert_distance};        my $xmlthink_center = $self->{matrix}{0}{0};        my %center_on_row = ();        foreach my $key (keys %{$self->{matrix}}) {                $center_on_row{$key} = $self->{matrix}{$key}{0};        }        $self->{matrix} = {};        if (not defined $self->{domdocument}) {                return;        }        my $xmlthink_root = $self->{domdocument}->getDocumentElement();        if (not defined $xmlthink_root) {                return;        }        if (not defined $xmlthink_center) {                $xmlthink_center = $xmlthink_root;        }        #print "0,0 = $xmlthink_center\n";        $self->{matrix}{0}{0} = $xmlthink_center;      HORIZONTAL_BW:        for my $hori_distance (1..$max_hori_distance+1) {                $hori_distance *= -1;                my $elem = $self->{matrix}{$hori_distance + 1}{0};                my $other = $elem->getParentNode();                if ($other && $other != $self->{domdocument}) {                        #print "$hori_distance,0 = $other\n";                        $self->{matrix}{$hori_distance}{0} = $other;                } else {                        last HORIZONTAL_BW;                }                for my $sign_v (-1,1) {                      VERTICAL_BW:                        for my $vert_distance (1..$max_vert_distance) {                                $vert_distance *= $sign_v;                                my $other = $self->{matrix}{$hori_distance + 1}{$vert_distance - $sign_v};                                my $brot = $sign_v<0?$other->getPreviousSibling():$other->getNextSibling();                                while (defined $brot && $brot->getNodeType() != XML::DOM::ELEMENT_NODE) {                                        $brot = $sign_v<0?$brot->getPreviousSibling():$brot->getNextSibling();                                }                                if ($brot) {                                        #print "".($hori_distance+1).",$vert_distance = $brot\n";                                        $self->{matrix}{$hori_distance + 1}{$vert_distance} = $brot;                                        my @list = grep { $_->getNodeType() == XML::DOM::ELEMENT_NODE } $brot->getChildNodes();                                        if ($#list >= 0) {                                                my $la = $hori_distance+1.0001;                                                $la =~ s/,/./g;                                                #print "$la,$vert_distance = undef\n";                                                $self->{matrix}{$la}{$vert_distance} = undef                                        }                                } else {                                        last VERTICAL_BW;                                }                                if ($hori_distance == -1) {                                        if (abs($vert_distance) == $max_vert_distance -1) {                                                my $obrot = $sign_v<0?$other->getPreviousSibling():$other->getNextSibling();                                                if ($obrot) {                                                        #print "".($hori_distance+1).",".($vert_distance + $sign_v)." = undef\n";                                                        $self->{matrix}{$hori_distance + 1}{$vert_distance + $sign_v} = undef;                                                }                                                last VERTICAL_BW;                                        }                                } else {                                        if (abs($vert_distance) == $max_vert_distance) {                                                my $obrot = $sign_v<0?$other->getPreviousSibling():$other->getNextSibling();                                                if ($obrot) {                                                        #print "".($hori_distance+1).",".($vert_distance + $sign_v)." = undef\n";                                                        $self->{matrix}{$hori_distance + 1}{$vert_distance + $sign_v} = undef;                                                }                                        }                                }                        }                }                if (abs($hori_distance) == $max_hori_distance + 1) {                        my $obrot = $other->getParentNode();                        #print "$hori_distance,0 = undef\n";                        $self->{matrix}{$hori_distance}{0} = undef;                }        }      HORIZONTAL_FW:        for my $hori_distance (1..$max_hori_distance) {                my $elem = $self->{matrix}{$hori_distance - 1}{0};                last HORIZONTAL_FW unless defined $elem;                my @list = grep { $_->getNodeType() == XML::DOM::ELEMENT_NODE } $elem->getChildNodes();                last HORIZONTAL_FW unless $#list >= 0;                if (not $center_on_row{$hori_distance}) {                        $center_on_row{$hori_distance} = $list[ceil($#list/2)];                }                my $obj = $center_on_row{$hori_distance};                #print "$hori_distance,0 = $obj\n";                $self->{matrix}{$hori_distance}{0} = $obj;                for my $sign_v (-1,1) {                      VERTICAL_FW:                        for my $vert_distance (1..$max_vert_distance) {                                $vert_distance *= $sign_v;                                my $other = $self->{matrix}{$hori_distance}{$vert_distance - $sign_v};                                my $brot = $sign_v<0?$other->getPreviousSibling():$other->getNextSibling();                                while (defined $brot && $brot->getNodeType() != XML::DOM::ELEMENT_NODE) {                                        $brot = $sign_v<0?$brot->getPreviousSibling():$brot->getNextSibling();                                }                                if ($brot) {                                        #print "".($hori_distance).",$vert_distance = $brot\n";                                        $self->{matrix}{$hori_distance}{$vert_distance} = $brot;                                        if (grep { $_->getNodeType() == XML::DOM::ELEMENT_NODE } $brot->getChildNodes()) {                                                my $la = $hori_distance+0.0001;                                                $la =~ s/,/./g;                                                #print "".($la).",$vert_distance = undef\n";                                                $self->{matrix}{$la}{$vert_distance} = undef                                        }                                } else {                                        last VERTICAL_FW;                                }                                if (abs($vert_distance) == $max_vert_distance) {                                        my $obrot = $sign_v<0?$other->getPreviousSibling():$other->getNextSibling();                                        if ($obrot) {                                                #print "".($hori_distance).",".($vert_distance+$sign_v)." = $brot\n";                                                $self->{matrix}{$hori_distance}{$vert_distance + $sign_v} = undef;                                        }                                }                        }                }                if (abs($hori_distance) == $max_hori_distance) {                        my @list = grep { $_->getNodeType() == XML::DOM::ELEMENT_NODE } $elem->getChildNodes();                        if ($#list >= 0) {                                #print "".($hori_distance+1).",0 = undef\n";                                $self->{matrix}{$hori_distance+1}{0} = undef;                        }                }        }        $self->drawit_all();}sub do_size_request {        my ($self, $requisition) = @_;        $requisition->width ($self->{full_box_width});        $requisition->height ($self->{full_box_height});}sub configure_event {        my $self = shift;        my $event = shift;        $self->{pixmap} = Gtk2::Gdk::Pixmap->new          ($self->window,           $self->allocation->width,           $self->allocation->height,           -1); # same depth as window        $self->{max_vert_distance} = int((($self->allocation->height/2)-($self->{full_box_height}/2)-($self->{insets}/2))/($self->{collapsed_box_height}+$self->{insets})) || 1;        $self->{max_hori_distance} = int((($self->allocation->width/2)-($self->{full_box_width}/2)-($self->{insets}/2))/($self->{collapsed_box_width}+$self->{insets})) || 1;        $self->plan_matrix();}sub expose_event {        my $self = shift;        my $event = shift;        $self->window->draw_drawable          ($self->style->fg_gc($self->state),           $self->{pixmap},           $event->area->x, $event->area->y,           $event->area->x, $event->area->y,           $event->area->width, $event->area->height);}sub drawit_all {        my $self = shift;        return unless $self->{pixmap};        $self->drawit_in(0,0,$self->allocation->width(),$self->allocation->height());}sub drawit_in {        my $self = shift;        my ($x,$y,$w,$h) = @_;        my $gc = $self->style->fg_gc($self->state);        $gc->set_clip_rectangle(Gtk2::Gdk::Rectangle->new($x, $y, $w, $h));        $gc->set_rgb_fg_color(Gtk2::Gdk::Color->new(255*257,255*257,255*257));        $self->{pixmap}->draw_rectangle($gc,1,0,0,$w,$h);        $gc->set_rgb_fg_color(Gtk2::Gdk::Color->new(0,0,0));        $self->draw_data($self->{pixmap},$gc);        $gc->set_clip_rectangle(undef);        $self->queue_draw();}sub draw_data {        my $self = shift;        my $area = shift;        my $gc = shift;        my $max_hori_distance = $self->{max_hori_distance};        my $max_vert_distance = $self->{max_vert_distance};        my $xmlthink_doc = $self->{domdocument};        return unless $xmlthink_doc;        my $xmlthink_root = $xmlthink_doc->getDocumentElement();        my $xmlthink_center = $self->{matrix}{0}{0};        if (not defined $xmlthink_center) {                $self->plan_matrix();                $xmlthink_center = $self->{matrix}{0}{0};                return unless $xmlthink_center;        }        my $canvas_width = $self->allocation->width;        my $canvas_height = $self->allocation->height;        my $center_x = int($canvas_width/2);        my $center_y = int($canvas_height/2);        my $fullb_w = $self->{full_box_width};        my $fullb_h = $self->{full_box_height};        my $collb_w = $self->{collapsed_box_width};        my $collb_h = $self->{collapsed_box_height};        my $insets  = $self->{insets};        $self->draw_center_element($area,$gc);        if ($xmlthink_root != $xmlthink_center) {                $self->draw_line_to_parent($area,$gc,$center_x - int($insets/2) - int($fullb_w/2) + 1,$center_y - int($insets/2));        }        for my $hori (sort {$a <=> $b} keys %{$self->{matrix}}) {                for my $vert (sort {$a <=> $b} keys %{$self->{matrix}{$hori}}) {                        next if ($hori == 0 && $vert == 0);                        my $obj = $self->{matrix}{$hori}{$vert};                        my $abs_distance_x = (abs($hori) * ($collb_w + $insets));                        my $abs_distance_y = (abs($vert) * ($collb_h + $insets));                        $abs_distance_x += int(($fullb_w - $collb_w)/2);                        if (abs($hori)<0.1) {                                # Center Column !!                                $abs_distance_y += int(($fullb_h - $collb_h)/2);                        }                        my $distance_x = $abs_distance_x * ($hori>=1?1:-1);                        my $distance_y = $abs_distance_y * ($vert==0?0:$vert>0?1:-1);                        my $box_center_x = $center_x + $distance_x;                        my $box_center_y = $center_y + $distance_y;                        my $x = $box_center_x - (int($collb_w/2)+int($insets/2));                        my $y = $box_center_y - (int($collb_h/2)+int($insets/2));                        if (exists $self->{matrix}{$hori - 1} && int($hori)==$hori) {                                $self->draw_line_to_parent($area,$gc,$x,int($y+$collb_h/2));                        }                        if ($obj) {                                $self->draw_collapsed_element($area,$gc,$obj,$x,$y);                        } else {                                if (int($hori)!=$hori) {                                        # side reticencia                                        $x = $box_center_x + (int($collb_w/2)-int($insets/2));                                        $y = $box_center_y - (int($collb_h/2)+int($insets/2));                                        $self->draw_reticencia($area,$gc,$x+2,$y);                                } else {                                        # element reticencia                                        $x = $box_center_x - (int($collb_w / 2)+int($insets/2));                                        $y = $box_center_y - (int(RETICENCIAS_HEIGHT / 2)+int($insets/2));                                        $self->draw_reticencia($area,$gc,$x,$y);                                }                        }                }        }        $self->queue_draw();}sub draw_center_element {        my $draw = shift;        my $self = $draw;        my $area = shift;        my $gc = shift;        my $canvas_width = $draw->allocation->width;        my $canvas_height = $draw->allocation->height;        my $pangoc = $draw->get_pango_context();        my $fontdesc = Gtk2::Pango::FontDescription->from_string("Sans 10");        my $xmlthink_center = $draw->{matrix}{0}{0};        my $center_x = int($canvas_width/2);        my $center_y = int($canvas_height/2);        my $fullb_w = $self->{full_box_width};        my $fullb_h = $self->{full_box_height};        my $insets = $self->{insets};        my $x = $center_x - int($fullb_w/2) - int($insets/2);        my $y = $center_y - int($fullb_h/2) - int($insets/2);        # BIG RECTANGLE        $area->draw_rectangle($gc,0,$x,$y,$fullb_w,$fullb_h);        # TAG        my $tag_rect = Gtk2::Gdk::Rectangle->new($x+2,$y+2,$fullb_w-4,20);        $area->draw_rectangle($gc,0,$tag_rect->x,$tag_rect->y,$tag_rect->width,$tag_rect->height);        $draw->draw_text($gc,$xmlthink_center->getTagName(),$tag_rect->x+2,$tag_rect->y+2,$tag_rect->width-4,$tag_rect->height-4);        # ATTRIBUTES        my $attr_rect = Gtk2::Gdk::Rectangle->new($x+2,$y+24,$fullb_w-4,int(($fullb_h-32)/2));        $area->draw_rectangle($gc,0,$attr_rect->x,$attr_rect->y,$attr_rect->width,$attr_rect->height);        $draw->draw_text($gc,$draw->make_text_from_attributes($xmlthink_center,"\n"),$attr_rect->x+2,$attr_rect->y+2,$attr_rect->width-4,$attr_rect->height-4);        # CDATA        my $cdata_rect = Gtk2::Gdk::Rectangle->new($x+2,$y+24+int(($fullb_h-32)/2)+2,$fullb_w-4,int(($fullb_h-23)/2));        $area->draw_rectangle($gc,0,$cdata_rect->x,$cdata_rect->y,$cdata_rect->width,$cdata_rect->height);        $draw->draw_text($gc,$draw->make_text_from_cdata($xmlthink_center),$cdata_rect->x+2,$cdata_rect->y+2,$cdata_rect->width-4,$cdata_rect->height-4);}sub make_text_from_attributes {        my $draw = shift;        my $element = shift;        my $sep = shift;        my $str = '';        my $nmap = $element->getAttributes();        for my $i (0..($nmap->getLength() - 1)) {                my $node = $nmap->item($i);                $str .= $node->getNodeName()."=".$node->getNodeValue().$sep;        }        chop($str);        return $str;}sub make_text_from_cdata {        my $draw = shift;        my $element = shift;        my $str = '';        for my $child ($element->getChildNodes()) {                if ($child->getNodeType() != XML::DOM::ELEMENT_NODE &&                    $child->getNodeType() != XML::DOM::ATTRIBUTE_NODE) {                        my $o = $child->getNodeValue();                        $o =~ s/^\s*//;                        $o =~ s/\s*$//;                        $str .= $o."\n" if $o;                }        }        return $str;}sub draw_reticencia {        my $draw = shift;        my $area = shift;        my $gc = shift;        my $x = shift;        my $y = shift;        $area->draw_arc($gc,0,$x,$y,(RETICENCIAS_WIDTH / 3),RETICENCIAS_HEIGHT,90*64,180*64);        $area->draw_arc($gc,0,$x +(2*RETICENCIAS_WIDTH / 3) - 1,$y,(RETICENCIAS_WIDTH / 3),RETICENCIAS_HEIGHT,270*64,180*64);        $area->draw_line($gc,$x+(2*RETICENCIAS_WIDTH/6),$y+(RETICENCIAS_HEIGHT/2),$x+(4*RETICENCIAS_WIDTH/6),$y+(RETICENCIAS_HEIGHT/2));        $area->draw_line($gc,$x+(RETICENCIAS_WIDTH/2),$y,$x+(RETICENCIAS_WIDTH/2),$y+(RETICENCIAS_HEIGHT));}sub draw_collapsed_element {        my $draw = shift;        my $area = shift;        my $gc = shift;        my $element = shift;        my $x = shift;        my $y = shift;        my $collb_w = $draw->{collapsed_box_width};        my $collb_h = $draw->{collapsed_box_height};        my $tag = $element->getTagName();        my $attr = $draw->make_text_from_attributes($element,",");        my $cdata = $draw->make_text_from_cdata($element);        $draw->{pixmap}->draw_rectangle($gc,0,$x,$y,$collb_w,$collb_h);        $draw->draw_text($gc,$tag,$x+2,$y,$collb_w-4,int($collb_h/3));        $draw->draw_text($gc,$attr,$x+2,$y+int($collb_h/3),$collb_w-4,int($collb_h/3));        $draw->draw_text($gc,$cdata,$x+2,$y+2*int($collb_h/3),$collb_w-4,int($collb_h/3));}sub draw_text {        my $draw = shift;        my $gc = shift;        my $text = shift;        my $x = shift;        my $y = shift;        my $w = shift;        my $h = shift;        my $pangoc = $draw->get_pango_context();        my $fontdesc = Gtk2::Pango::FontDescription->from_string("Sans 10");        my $rect = Gtk2::Gdk::Rectangle->new($x,$y,$w,$h);        my $layout = Gtk2::Pango::Layout->new($pangoc);        my $clipped = Gtk2::Gdk::GC->new($draw->{pixmap});        $clipped->set_clip_rectangle($rect);        $layout->set_font_description($fontdesc);        $layout->set_text($text);        $draw->{pixmap}->draw_layout($clipped,$x,$y,$layout);}sub draw_line_to_parent {        my $draw = shift;        my $self = $draw;        my $area = shift;        my $gc = shift;        my $x = shift;        my $y = shift;        my $canvas_width = $draw->allocation->width;        my $canvas_height = $draw->allocation->height;        $area->draw_line($gc,$x,$y,$x-int($draw->{insets}/2),$y);        $area->draw_line($gc,$x-int($draw->{insets}/2),$y,$x-int($draw->{insets}/2),int($canvas_height/2)-int($draw->{insets}/2));        $area->draw_line($gc,$x-int($draw->{insets}/2),int($canvas_height/2)-int($draw->{insets}/2),$x-$self->{insets},int($canvas_height/2)-int($draw->{insets}/2));}sub scroll_event {        my $self = shift;        my $event = shift;        my $x = $event->x;        my $y = $event->y;        my $dir = $event->direction;        my ($col,$row) = $self->x_y_to_col_row($x,$y);        if ($col > 0) {                my $other = $dir eq 'up'?-1:1;                if (exists $self->{matrix}{$col}{$other} && $self->{matrix}{$col}{$other}) {                        $self->{matrix}{$col}{0} = $self->{matrix}{$col}{$other};                        while (exists $self->{matrix}{$col + 1}) {                                delete $self->{matrix}{$col + 1};                                $col++;                        }                        $self->plan_matrix();                }        }}sub element_on_col_row {        my $self = shift;        my ($col,$row) = @_;        return $self->{matrix}{$col}{$row};}sub x_y_to_col_row {        my $self = shift;        my $x = shift;        my $y = shift;        my ($col,$row);        my $canvas_width = $self->allocation->width;        my $canvas_height = $self->allocation->height;        my $center_x = int($canvas_width/2);        my $center_y = int($canvas_height/2);        my $fullb_w = $self->{full_box_width};        my $fullb_h = $self->{full_box_height};        my $collb_w = $self->{collapsed_box_width};        my $collb_h = $self->{collapsed_box_height};        my $insets  = $self->{insets};        if ($x > ($center_x + int($fullb_w/2))) {                my $rel_x = $x - ($center_x + int($fullb_w/2));                $col = int($rel_x/($collb_w+$insets)) + 1;                my $rel_y = $y - $center_y;                $row = ceil($rel_y/($collb_h+$insets))+0;        } elsif ($x < ($center_x - int($fullb_w/2))) {                my $rel_x = $x - ($center_x - int($fullb_w/2));                $col = int($rel_x/($collb_w+$insets)) - 1;                my $rel_y = $y - $center_y;                $row = ceil($rel_y/($collb_h+$insets));        } else {                $col = 0;                if ($y > ($center_y + int($fullb_h/2))) {                        my $rel_y = $y - ($center_y + int($fullb_h/2));                        $row = int($rel_y/($collb_h+$insets)) + 1;                } elsif ($y < ($center_y - int($fullb_h/2))) {                        my $rel_y = $y - ($center_y - int($fullb_h/2) - int($insets/2));                        $row = int($rel_y/($collb_h+$insets)) - 1;                }        }        return ($col,$row);}sub button_press_event {        my $draw = shift;        my $event = shift;        my $x = $event->x;        my $y = $event->y;        my $button = $event->button;        my ($col,$row) = $draw->x_y_to_col_row($x,$y);        $draw->click_col_row($button,$col,$row);}sub click_col_row {        my $self = shift;        my $button = shift;        my $col = shift || 0;        my $row = shift || 0;        if (exists $self->{matrix}{$col}{$row} and $self->{matrix}{$col}{$row}) {                my $obj = $self->{matrix}{$col}{$row};                if ($button == 1) {                        $self->{matrix} = {};                        $self->{matrix}{0}{0} = $obj;                        $self->plan_matrix();                }        }}1;

Trial Program:

#!/usr/bin/perluse strict;use warnings;use XML::DOM;use Gtk2 qw(-init);use XMLNavigator;my $mainwindow = Gtk2::Window->new("toplevel");my $hbox = Gtk2::HBox->new();my $parser = XML::DOM::Parser->new();my $nav = XMLNavigator->new(domdocument => $parser->parsefile($ARGV[0]));$hbox->add($nav);$mainwindow->add($hbox);$mainwindow->show_all();Gtk2->main();

daniel

Manipulating a Window (HarmB)

There are so many modules around, but is there a module to read-back information of a particular window? And to press buttons in that window, as well as to fill-in fields in that window? The window not being a HTML page, or other online-service, but a regular application window, e.g WORD, or Notepad or Calculator(for Microsoft Windows).I cannot imagine there is not such a module, but apparantly I cannot find it. Who can help?

Manipulating a Window (HarmB)

ssh chain (shmem)

My work involves logging into remote machines via ssh, possibly over multiple hops to do random tasks.

Tired of typing

ssh -p 3334 shmem@gateway -L1025:host.example.com:22

and for the next hop, in another shell,

ssh -p 1025 admin@localhost -L1026:192.168.123.2:975 -R993:localhost:1993

then in yet another shell

ssh -p 1026 wrxd15@localhost -L1027:192.168.254.2:22

and so on, I cranked out the following, which lets me say

ssc shmem@gateway:3334 admin@host.example.com wrxd15@192.168.123.2:975,-R993:localhost:1993 root@192.168.254.2

which does the chaining. I only have to type in the hops in order, and presto - I have a shell open at the endpoint. Aliasing a chain is much easier this way. Secure Shells are invoked with -f -N except the last.

#!/usr/bin/perl -w# $Id: ssc,v 0.0 2006/09/26 09:17:18 shmem Exp $use strict;use Getopt::Std;my %o;getopts('p:',\%o);$o{'p'} ||= 1025; # default port range startdie "ssh chain - usage: ssc [-p] user\@host1[:sshport][,arg,arg,...] \\\n"   ."                            user\@host1[:sshport][,arg,arg,...] \\\n"   ."                            ...\n"   ."where -p is of the forwarded ports range's start (default: $o{p})\n"   unless @ARGV;# sshost chain to port 22while (@ARGV) {    my ($host,@args) = split/,/,shift;    my ($port,$nexthop,$silent,$nextport);    $port = $nextport = $nexthop = $silent = '';    $host =~ s/:(\d+)// && ($port="-p $1");    if(@ARGV) {        my ($c,@args) = split/,/,$ARGV[0];        my ($u,$host)    = split /\@/,$c;        $host =~ s/:(\d+)// && ($nextport=$1);        $nexthop = "-L$o{p}:$host:". ($nextport ? $nextport : 22);        $ARGV[0] = "$u\@localhost:$o{p}";        $ARGV[0] .= ','. join(',',@args);        $o{'p'}++;        $silent = '-f -N';    }    if(@ARGV) {        print  "ssh $silent $port $host $nexthop @args\n";        system "ssh $silent $port $host $nexthop @args";    } else {        print "ssh $silent $port $host $nexthop @args\n";        exec  "ssh $silent $port $host $nexthop @args";    }}

Comments, critique and improvements welcome.

--shmem

_($_=" "x(1<<5)."?\n".q·/)Oo.  G°\        /                              /\_¯/(q    /----------------------------  \__(m.====·.(_("always off the crowd"))."·");sub _{s./.($e="'Itrs `mnsgdq Gdbj O`qkdq")=~y/"-y/#-z/;$e.e && print}

Parsing attributes in one line using map (ruoso)

After writing this code, I realized many people may have just not realized this is possible, so I think posting it here would make people think more about it.

I was writing a simple script wich would receive a attr=value,attr2=value2 string and automatically I wrote:

my %attrs = map { split /=/ } split /,/, $attr;

Well, the trick is that map doesn't have to return the same number of elements of the list it receives. If you returns a list inside a map, the resulting list will have more elements than the input list.

This sounds very intuitive to me, but maybe it's not for others...

daniel

Get your Daily Tao Te Ching fix (radiantmatrix)

I'm a big fan of the Tao te Ching, and after finding a free version (called [http://acc6.its.brooklyn.cuny.edu/~phalsall/texts/taote-v4.html|GNL]), I decided to write a tool that would give me a new chapter each day I ran it, in order, and start over when I reached the end.

I personally use this in a cron job to change my /etc/motd message.

When run for the first time with either the --daily or --chapter parameters, it will retrieve a copy of the GNL from the web, parse it into its chapters (saving the license to 'license.txt'), and store a YAML cache of that work. If you're running from behind a proxy, you can use some other proxy-enabled tool to save the GNL from the link in the first paragraph to a file named 'taote-v4.html' -- when put in the exec directory, the app will prefer that local copy.

--today causes the program to print the next chapter of the TTC if it's not the same day as the last time it was run.

--chapter lets you get a specific chapter (see usage for details)

To clean up and start fresh, use the --reset parameter.

Run without parameters or with '--usage', '--help', '-h', or '-?' for a usage message.

Depends on CPAN modules [dist://YAML-Syck] (fast libsyck) or [dist://YAML] (slower, pure-perl), and [dist://HTML-TokeParser-Simple] (for parsing the HTML version of GNL). The last dependency is only needed for parsing the HTML document -- it is not needed once tao.yaml exists.

#!/usr/local/bin/perluse strict;use warnings;BEGIN {  # Try to load YAML::Syck (faster, preferred), fall back to YAML otherwise  # thanks to PerlMonks' shmem for pointing out potential YAML::Syck trouble  eval {     require YAML::Syck;    YAML::Syck->import( qw[LoadFile DumpFile] );  };  if ($@) {    # fall back to YAML    require YAML;    YAML->import( qw[LoadFile DumpFile] );  }}use Getopt::Long;# how do we want to operate?usage() unless @ARGV;GetOptions(  'help|usage|?|h' => \&usage,  'reset'          => sub { for (<*.yaml>) { unlink while -f } },  'today'          => \&daily_tao,  'chapter'        => \&my_tao,  'license'        => sub { print join('',); exit; },);#========================================================================# load_tao - loads or regenerates cache of tao chapters, returns as listsub load_tao {  if ( -f 'tao.yaml') {    # load chapters from disk cache, if we have them    return @{ LoadFile('tao.yaml') };  }  else {    # otherwise, get them from the web and build the cache    return @{ get_web_tao() };  }}#========================================================================# daily_tao - shows a new dao chapter if the date has advanced by at#             least one day since the last run.  Uses 'day.yaml' for#             cache.sub daily_tao {  my @chapter = load_tao();  my $day_index = 0;  my $time = time;  my $now = $time;    # load last run info, if any.  if ( -f 'day.yaml' ) {     ($day_index, $time) = @{ LoadFile('day.yaml') }  }    my @now  = localtime($now);  my @last = localtime($time);  if ( $last[7] != $now[7] || $last[5] != $now[5]) {    # it's not the same day as last we ran    $day_index++;    if ($day_index > $#chapter) { $day_index = 0 } # roll over    $time = $now; # we will record the *current* time  }    printf "%s: %s\n%s", @{ $chapter[$day_index] };  DumpFile('day.yaml', [ $day_index, $time ]);}#========================================================================# my_tao - shows the chapter specified on the command line ($ARGV[0])#          with no parameter, shows the first chapter#          with a numeric parameter, shows chap. for that record number#          with a paramter ending in '.', shows record with that chap. id#          Dies if there's an invalid chap. id or spec.sub my_tao {  my @chapter = load_tao();  my $chapter = (@ARGV ? shift @ARGV : 0);    if ($chapter =~ /\./) {    # this is a chapter spec    my $chindex = 0;    for (0..$#chapter) {      $chindex = $_;      last if "$chapter[$_][0]." eq $chapter;    }        die "$chapter is not a valid chapter spec\n"      if "$chapter[$chindex][0]." ne $chapter;        $chapter = $chindex;  }  elsif ($chapter =~ /\D/) {    # doesn't look like a spec, but isn't just a number - invalid    die "'$chapter' is neither a valid spec nor a valid numeric id\n";  }  die "The last record is no.$#chapter, but you asked for no.$chapter\n"    if $chapter > $#chapter;  printf "%s: %s\n%s", @{$chapter[$chapter]};}#========================================================================# get_web_tao - retrieves the "GNL" tao te ching from the web and #               creates the disk cache of the chapters in 'tao.yaml'#               if a local file 'taote-v4.html' exists, will use that#               instead of fetching from the websub get_web_tao {  require HTML::TokeParser::Simple;    my $p = HTML::TokeParser::Simple->new( -f 'taote-v4.html'     ?(file => 'taote-v4.html')    :(url => 'http://acc6.its.brooklyn.cuny.edu/~phalsall/texts/taote-v4.html')  );    # skip notices and such, but record them to license.txt  my $LIC;  while (my $token = $p->get_token) {    last if $token->is_end_tag('h2');    if ($token->is_start_tag('pre')) {      # start of license text and copyright notice      open $LIC, '>license.txt' or die ("Can't write license.txt: $!");    }    elsif ($token->is_end_tag('pre')) {      # end of license text and copyright notice      close $LIC; undef $LIC;    }    elsif ($token->is_text && defined $LIC) {      # body text for license and copyright      print $LIC $token->as_is;    }  }    # add chapters to data struct in form [id, title, text]  my @chapter;  while (my $token = $p->get_token)  {    next unless $token->is_start_tag('h3'); #title start    (my $title = $p->peek(1)) =~ s{^(.+?)\.\s}{}g;    my $num = $1;    my $text = '';        #finish end of title    while ($token = $p->get_token) { last if $token->is_end_tag('h3') }        #grab text *as* text    while ($token = $p->get_token) {      last if $p->peek =~ //i;      next if $token->is_tag;      $text.=$token->as_is;    }        push @chapter, [ $num, $title, $text ];  }    DumpFile('tao.yaml', \@chapter);  return \@chapter;}#========================================================================# usage - prints a nice usage message and exits the appsub usage {  print <Updates:
2004-09-22 : [shmem] noted that [cpan://YAML::Syck] might be problematic for some.  Updated code to prefer YAML::Syck, but fall back on [dist://YAML] if Syck is not installed.
<–radiant.matrix–>
A collection of thoughts and links from the minds of geeks
The Code that can be seen is not the true Code
I haven't found a problem yet that can't be solved by a well-placed [http://en.wikipedia.org/wiki/Trebuchet|trebuchet]

A little introducation to piratical Perl me hearties (GrandFather)

use Acme::Lingua::Pirate::Perl;use warnings; Arrrr!use strict; Yo ho ho!Shiver me timbers!Ahoy ("Avast there me maties");Splice the mainbrace!sub Ahoy {    the doubloons = plunder the booty;    yell the doubloons;    cast off}

DWIM is Perl's answer to Gödel

Mirror a local directory to an FTP server (davis)

This is disgusting, but it's a just a quick-n-dirty hack to upload a directory structure to a remote FTP server where the FTP server would only allow one "put" command per login session. Yes, really. Obviously there was no ssh access otherwise I would have used rsync/scp -r. Oh well.

#!/usr/bin/perl use warnings;use strict;use Net::FTP;use File::Basename;my $startdir = "somewhere";my $ftphost  = "somehost";my $ftpuser  = "someuser";my $ftppass  = "somepass";upload_dir($startdir);sub upload_dir {    my $dir = shift;    foreach my $entry (<$dir/*>) {            upload_dir($entry) if(-d $entry);            my $ftp =  Net::FTP->new($ftphost)                or die "Can't connect to $ftphost: $@";            $ftp->login($ftpuser, $ftppass)                or die "Can't login ", $ftp->message;            my $dirname = dirname $entry;            $ftp->mkdir($dirname, 1);            $ftp->cwd($dirname);            $ftp->put($entry);            $ftp->quit;    }}

davis

Kids, you tried your hardest, and you failed miserably. The lesson is: Never try.

Webcam Auto-Screensaver (ailivac)

This core of this program takes an set of three images, two references and one test, and classifies the test image as more similar to reference A or reference B. It then uses a loop to poll for new images (from an HTTP server) in real time and run commands when the images changes between the two states. A fun application of this is to monitor a webcam and turn the screensaver on and off depending on whether or not you're sitting in front of your computer.First, a module to summarize an image. This samples pixels at regular intervals and stores the values in an array or arrays:

# ImgSum.pmpackage ImgSum;use strict;use warnings;use Image::Magick;sub summary {    my ($imgf, $res) = @_;    my $img = new Image::Magick;    $img->Read($imgf);    my ($w, $h) = $img->Get(qw/rows columns/);    my @sum;    my $i = 0;    for (my $y = 0; $y < $h; $y += $res)    {        for (my $x = 0; $x < $w; $x += $res)        {            my $px = $img->Get("pixel[$x,$y]");            my $rgb = [split/,/, $px];            $sum[$i++] = $rgb;        }    }    return \@sum;}1;

Next, a script to summarize an image file and store it for later use:

#!/usr/bin/perl# sum.pluse strict;use warnings;use ImgSum;use Data::Dumper;use Storable;my ($img, $res, $out) = @ARGV;# $res is the sampling resolutionmy $sum = ImgSum::summary($img, $res);store($sum, $out);

The next module takes two image summaries and calculates the average difference between them. It's an incredibly simple algorithm that has numerous shortcomings, but it works in simple situations.

# SumDif.pmpackage SumDiff;use strict;use warnings;use Data::Dumper;sub mean {    my $tt = 0;    my $s = 0;    while (defined($_ = shift))    {        $tt += $_;        $s++;    }    return $tt/$s;}sub diffmap {    my ($s1, $s2) = @_;    my @diff;    foreach my $i(0..$#$s1)    {        my $c1 = $s1->[$i];        my $c2 = $s2->[$i];        my @d = map { abs($c2->[$_] - $c1->[$_]) } (0..$#$c1);        $diff[$i] = mean(@d);    }    return \@diff;}sub diffavg {    return mean(@{diffmap(@_)});}1;

Finally, watch.pl downloads images and compares them with two references and runs a command whenever the current image changes from being more like one reference to being more like the other. You can use a program like spook to serve images captured from a webcam.

#!/usr/bin/perl# watch.pluse strict;use warnings;use ImgSum;use LWP::Simple;use SumDiff;use Storable;my @refs = map {retrieve($_)} ('sum-r0.dat', 'sum-r1.dat');sub min {    my $mni = 0;    for my $i(0..$#_)    {        if ($_[$i] < $_[$mni])        {            $mni = $i        }    }    return $mni;}sub getclass {    my $test = shift;    my @diffs;    for my $i(0..$#refs)    {        my $diff = SumDiff::diffavg($refs[$i], $test);        $diffs[$i] = $diff;        print "Difference to $i: $diff\n";    }    return min(@diffs);}my $lc = 1;while (sleep 2){    my $stat = getstore('http://localhost:45005/webcam.jpg', 'current.jpg');    print "HTTP status: $stat\n";    my $sum = ImgSum::summary('current.jpg', 4);    my $cl = getclass($sum);    print "Likely class: $cl\n";    if ($lc != $cl)    {        system('xscreensaver-command ' .               ($cl?'-deactivate':'-activate'));        $lc = $cl;    }}

To use it:

( take a picture of the empty room, save it as ref0.jpg )$ ./sum.pl ref0.jpg 4 sum-r0.dat( take a picture of yourself, call it ref1.jpg )$ ./sum.pl ref1.jpg 4 sum-r1.dat$ ./watch.pl

Now walk in front of and away from the camera slowly and your screensaver will turn on and off.

List based language (gmol)

Some time ago, I came to the monastery gates and received some much needed help in writing a list based mini language.Ikegami was very kind in helping me out (references [id://548582] and [id://564482]), Ive made a few simple changes that make this grammar behave the way I need. Basically you can do assignment and evaluation. Evaluation interpolates and autoflattens lists and variables using dot products (default composition and *) cross products (**) duplication (%) and replication (%%), and spits out interpolations that are new line delimited.Here is an example input:

hellohello{1,2}{a,b}{1,2}{a,b}**{1,2}temp->somestringsomeotherstring->{a,b}$temp$()$someotherstring${a,b}%{1,2}{a,b}%%{1,2}

and the output:

hellohello1hello2a1b2a1a2b1b2asomestring()bsomestring()ababaabb

Some of the design choices that were made relate to the application that I am doing using the SMILES language. FWIW I can define sets of reactions (and combinatorial libraries) nicely by specifying them in this language. Here is an example of a set of reactions

amines->{CN(C),{C,c}N(H)}thiols->{{C,c}S}alcohols->{cO}sulfonamides->{{C,c}S(=O)(=O)N(H)}nSynthons->{$amines$,$thiols$,$alcohols$,$sulfonamides$}lGroups->{Cl,Br,I}eSynthons->{C(=O){C,c}}reactants->{ $nSynthons$(H).}**{$lGroups$**$eSynthons$ }products->{ $nSynthons$**{$eSynthons$%$lGroups$} }$reactants$>>$products$

and the output:

CN(C)(H).ClC(=O)C>>CN(C)C(=O)CCN(C)(H).ClC(=O)c>>CN(C)C(=O)cCN(C)(H).BrC(=O)C>>CN(C)C(=O)CCN(C)(H).BrC(=O)c>>CN(C)C(=O)cCN(C)(H).IC(=O)C>>CN(C)C(=O)CCN(C)(H).IC(=O)c>>CN(C)C(=O)cCN(H)(H).ClC(=O)C>>CN(H)C(=O)CCN(H)(H).ClC(=O)c>>CN(H)C(=O)cCN(H)(H).BrC(=O)C>>CN(H)C(=O)CCN(H)(H).BrC(=O)c>>CN(H)C(=O)cCN(H)(H).IC(=O)C>>CN(H)C(=O)CCN(H)(H).IC(=O)c>>CN(H)C(=O)ccN(H)(H).ClC(=O)C>>cN(H)C(=O)CcN(H)(H).ClC(=O)c>>cN(H)C(=O)ccN(H)(H).BrC(=O)C>>cN(H)C(=O)CcN(H)(H).BrC(=O)c>>cN(H)C(=O)ccN(H)(H).IC(=O)C>>cN(H)C(=O)CcN(H)(H).IC(=O)c>>cN(H)C(=O)cCS(H).ClC(=O)C>>CSC(=O)CCS(H).ClC(=O)c>>CSC(=O)cCS(H).BrC(=O)C>>CSC(=O)CCS(H).BrC(=O)c>>CSC(=O)cCS(H).IC(=O)C>>CSC(=O)CCS(H).IC(=O)c>>CSC(=O)ccS(H).ClC(=O)C>>cSC(=O)CcS(H).ClC(=O)c>>cSC(=O)ccS(H).BrC(=O)C>>cSC(=O)CcS(H).BrC(=O)c>>cSC(=O)ccS(H).IC(=O)C>>cSC(=O)CcS(H).IC(=O)c>>cSC(=O)ccO(H).ClC(=O)C>>cOC(=O)CcO(H).ClC(=O)c>>cOC(=O)ccO(H).BrC(=O)C>>cOC(=O)CcO(H).BrC(=O)c>>cOC(=O)ccO(H).IC(=O)C>>cOC(=O)CcO(H).IC(=O)c>>cOC(=O)cCS(=O)(=O)N(H)(H).ClC(=O)C>>CS(=O)(=O)N(H)C(=O)CCS(=O)(=O)N(H)(H).ClC(=O)c>>CS(=O)(=O)N(H)C(=O)cCS(=O)(=O)N(H)(H).BrC(=O)C>>CS(=O)(=O)N(H)C(=O)CCS(=O)(=O)N(H)(H).BrC(=O)c>>CS(=O)(=O)N(H)C(=O)cCS(=O)(=O)N(H)(H).IC(=O)C>>CS(=O)(=O)N(H)C(=O)CCS(=O)(=O)N(H)(H).IC(=O)c>>CS(=O)(=O)N(H)C(=O)ccS(=O)(=O)N(H)(H).ClC(=O)C>>cS(=O)(=O)N(H)C(=O)CcS(=O)(=O)N(H)(H).ClC(=O)c>>cS(=O)(=O)N(H)C(=O)ccS(=O)(=O)N(H)(H).BrC(=O)C>>cS(=O)(=O)N(H)C(=O)CcS(=O)(=O)N(H)(H).BrC(=O)c>>cS(=O)(=O)N(H)C(=O)ccS(=O)(=O)N(H)(H).IC(=O)C>>cS(=O)(=O)N(H)C(=O)CcS(=O)(=O)N(H)(H).IC(=O)c>>cS(=O)(=O)N(H)C(=O)c

This is the recdescent meat:

#!/usr/bin/perl# make_grammar.pl: Creates Grammar.pmuse strict;use warnings;use Parse::RecDescent ();my $grammar = <<'__END_OF_GRAMMAR__';   {      use strict;      use warnings;      use List::Util qw( sum );    my %variables=();      sub replicate {   my ($l, $r) = @_;      my $lt = $l->[0];   my $rt = $r->[0];   die("Type error\n") if $lt ne 'list';   die("Type error\n") if $rt ne 'list';   my $ld = $l->[1];   my $rd = $r->[1];      my @replicated;   my $value;      foreach (@{$ld})   {    $value=$_;     foreach(0..$#$rd){push @replicated, $value;}   }   return [list => \@replicated];  }  sub duplicate {   my ($l, $r) = @_;      my $lt = $l->[0];   my $rt = $r->[0];   die("Type error\n") if $lt ne 'list';   die("Type error\n") if $rt ne 'list';   my $ld = $l->[1];   my $rd = $r->[1];      my @duplicated;         foreach(0..$#$rd){push @duplicated, @{$ld};}       return [list => \@duplicated];  }     sub cross_prod {         my ($l, $r) = @_; my ($i, $j)=('','');         my $lt = $l->[0];         my $rt = $r->[0];         die("Type error\n") if $lt ne 'list';         die("Type error\n") if $rt ne 'list';         my $ld = $l->[1];         my $rd = $r->[1]; return [ list => [map { $i=$_; map { $j=$_;  $ld->[$i].$rd->[$j]} 0..$#$rd} 0..$#$ld]];      }      sub dot_prod {         my ($l, $r) = @_;  my $l_is_string = $l->[0] eq 'string'; my $r_is_string = $r->[0] eq 'string'; my $l_is_list   = $l->[0] eq 'list'; my $r_is_list   = $r->[0] eq 'list'; my ($ld, $rd) = ($l->[1], $r->[1]);          if ($l_is_string && $r_is_string) { return [ string => $ld.$rd ];         }         if ($l_is_list && $r_is_list) {die("Size error\n") if @$ld != @$rd;            return [ list => [ map { $ld->[$_].$rd->[$_] } 0..$#$rd ] ];         }         if ($l_is_string && $r_is_list) {    return [ list => [ map { $ld.$_ } @$rd ] ]; }  if ($l_is_list && $r_is_string) {    return [ list => [ map { $_.$rd } @$ld ] ]; }      }   }      parse:    assignment EOF   | expr EOF {  if($item[1]->[0] eq 'list')  {   map {print $_."\n";} @{$item[1]->[1]};  }    if($item[1]->[0] eq 'string')  {print $item[1]->[1]."\n";}    $return = $item[1]; }      assignment: /\w+/ '->'  expr {$variables{$item[1]}=$item[4];}    expr   : term expr_[ $item[1] ]   expr_  : '%%'    term expr_[ replicate($arg[0], $item[3]) ]|'%'    term expr_[ duplicate($arg[0], $item[3]) ]|'**'   term expr_[ cross_prod($arg[0], $item[3]) ]            |'*'    term expr_[ dot_prod   ($arg[0], $item[3]) ]            | term       expr_[ dot_prod   ($arg[0], $item[1]) ]            | { $arg[0] }   term   : '{'  mbody '}'                {  my @to_flatten = @{$item[3]};  my @flattened=();  my ($i, $j)=('','');    foreach (@to_flatten)  {   $i=$_;   if($i->[0] eq 'list')   {    push @flattened, @{$_->[1]};next;   }   push @flattened, $i->[1];  }    $return = [list => \@flattened]; }  | VARIABLE | STRING     mbody  :    # Tokens   VARIABLE:  '$'  /\w+/ '$' { $return = $variables{$item[3]}; }   STRING : /[^\{\}\,\*\$\%]+/ { $return = [ string => $item[1]]; }   EOF    : /\Z/__END_OF_GRAMMAR__Parse::RecDescent->Precompile($grammar, 'Grammar')   or die("Bad grammar\n");

and what you want to run it

#!/usr/bin/perl# test.pluse strict;use warnings;use Grammar      qw( );my $parser = Grammar->new();while(<>){ chomp; my $rv = eval { $parser->parse($_) }; my $e = $@;  if ($e) {      $rv = "$_ = $e";      $rv =~ s/\n\z//;   } elsif (!defined($rv)) {      $rv = "$_ = Bad Expression";   } }exit;

Any comments/advice appreciated. Thanks again Ikegami.

Easily parallelize program execution (bennymack)

This is a script that uses POE to run a series of tasks in parallel. It's "easy" because the code to run the tasks is simply defined as subroutines and executed. One in the parent, one in the children. Behold!

package PoeSubs;use strict;use warnings; use Data::Dumper;use POE qw(Wheel::Run Filter::Reference);# sub run_tasks#{{{sub run_tasks {    my( %ARGS )            = @_;    my( $debug )           = $ARGS{debug};    my( $handle_task_sub ) = delete $ARGS{handle_task_sub};    my( $start_tasks )     = get_start_tasks( %ARGS );    no warnings 'redefine';    local *POE::Kernel::_warn = sub {} if not $debug;       POE::Session->create (        inline_states => {            _start      => $start_tasks,            next_task   => $start_tasks,            task_result => sub { $handle_task_sub->( $_[ARG0] ); },            task_done   => \&PoeSubs::handle_task_done,            task_debug  => \&PoeSubs::handle_task_stderr,        }    );        # Run until there are no more tasks.    POE::Kernel->run();    my( $reduce_sub ) = delete $ARGS{reduce_sub};    if( 'CODE' eq ref $reduce_sub ) {        &$reduce_sub;    }}#}}}# sub get_start_tasks#{{{sub get_start_tasks {    my( %ARGS ) = @_;    my( $debug )                = $ARGS{debug};    my( @tasks )                = @{ $ARGS{tasks} };    my( $max_concurrent_tasks ) = $ARGS{max_concurrent_tasks} || 1;    my( $run_task_sub )         = $ARGS{run_task_sub};    return sub {        my $heap = $_[HEAP];        while ( keys( %{ $heap->{task} } ) < $max_concurrent_tasks ) {            my $next_task = shift @tasks;            last unless defined $next_task;                        print "Starting task for $next_task...\n" if $debug;                        my $task = POE::Wheel::Run->new (#               Program => sub { $run_task_sub->( $next_task ) },                Program => sub { get_program_sub( $run_task_sub )->( $next_task ) },                StdoutFilter => POE::Filter::Reference->new(),                StdoutEvent  => "task_result",                StderrEvent  => "task_debug",                CloseEvent   => "task_done",            );                        $heap->{task}->{ $task->ID } = $task;        }    };}#}}}# sub get_program_sub#{{{sub get_program_sub {    my( $run_task_sub ) = @_;    return sub {        my( $task )   = @_;# warn '$task = ', $task;        my( $filter ) = POE::Filter::Reference->new();        my( $task_output ) = $run_task_sub->( $task );# warn Dumper( $task_output );        my $output = $filter->put( [ $task_output ] );        print @$output;    };}#}}}# sub handle_task_stderr#{{{# Catch and display information from the child's STDERR.  This was# useful for debugging since the child's warnings and errors were not# being displayed otherwise.sub handle_task_stderr {    my $stderr = $_[ARG0];#   print "Debug: $stderr\n";    warn "handle_task_stderr: $stderr\n";}#}}}# sub handle_task_done#{{{# The task is done.  Delete the child wheel, and try to start a new# task to take its place.sub handle_task_done {    my ( $kernel, $heap, $task_id ) = @_[ KERNEL, HEAP, ARG0 ];    delete $heap->{task}->{$task_id};    $kernel->yield("next_task");}#}}}1;__END__

And the test script.

#!/usr/bin/perluse strict;use warnings;use Data::Dumper;use PoeSubs;use constant MAX_CONCURRENT_TASKS => 100;# use constant TASKS                => qw( 4 10 3 7 );my( $run_task_sub, $handle_task_sub, $reduce_sub ) = get_subs();# for( 1..20 ) {    PoeSubs::run_tasks(#       debug                => 1,        tasks                => [ 1..100 ],        max_concurrent_tasks => MAX_CONCURRENT_TASKS,        run_task_sub         => $run_task_sub,        handle_task_sub      => $handle_task_sub,        reduce_sub           => $reduce_sub,    );# }exit 0;sub get_subs {# Gets the task as the first argument# Should return a reference of some type    my( $run_task_sub ) = sub {        my( $task )   = @_;        my( $sleep ) = int( rand 4 ) + 1;        sleep( $sleep );        return { task => $task, sleep => $sleep, message => sprintf( '[Task %s: slept %s seconds]', $task, $sleep ) };    };# Gets the reference returned by run_task as the first argument    my( $totals ) = 0;    my( $handle_task_sub ) = sub {        my( $result ) = @_;        $totals += $result->{sleep};        printf( "{Task: %s, Got message: %s}\n", $result->{task}, $result->{message} );    };# Prints out the totals    my( $reduce_sub ) = sub {        print '$totals = ', $totals, "\n";    };    return( $run_task_sub, $handle_task_sub, $reduce_sub );}

I'm just looking to get some feedback. Is it idiotic? Is it cool? Is it a CPAN module already?

I tend to like the way that all you need to do is define a few subs and let er rip. I'm a big fan of easy interfaces.

Thank you, that is all.

Wootoff monitor (zigdon)

Silly little script to keep track of the currently running Wootoff ([http://www.woot.com]):

#!/usr/bin/perl #===============================================================================##         FILE:  wootoff.pl##        USAGE:  ./wootoff.pl ##  DESCRIPTION:  Monitor woot.com and alert when there are changes##      OPTIONS:  ---# REQUIREMENTS:  ---#         BUGS:  ---#        NOTES:  ---#       AUTHOR:  Zigdon#      VERSION:  1.0#      CREATED:  08/17/2006 09:54:43 AM EDT#     REVISION:  $Id: wootoff.pl 70 2006-08-17 22:30:27Z dan $#===============================================================================use strict;use LWP::Simple;use HTML::TreeBuilder;use Date::Manip;my $URL = "http://www.woot.com";my $oldtitle;my ($woottime, $eta);$|++;my $idle = 0;while (1) {  my ($title, $price, $percent) = &update;  if ($title ne $oldtitle) {      my $now = scalar localtime;      exec("xmessage '$now - NEW WOOT!\n$title\n$price' 2>/dev/null") unless fork;      print "\n", UnixDate(ParseDate("now"), '%H:%M:%S'), " - NEW WOOT!\n";      $woottime = time;      $oldtitle = $title;  }  $eta = ParseDateDelta(int((time - $woottime) / (100 - $percent) * 100)) if $percent < 99;  my $etatext;  if ($eta) {      my $delta = DateCalc("now", "epoch $woottime");      $eta = DateCalc($delta, $eta);      $etatext = Delta_Format($eta, 0, '%mhm, %svs');      $eta = DateCalc("now", $eta);      $eta = UnixDate($eta, '%H:%M:%S');  } else {      $eta = "N/A";  }  print UnixDate(ParseDate("now"), '%H:%M:%S'), " - $title - $price ($percent\% eta: $etatext $eta)\r";  if ($idle++ > 600) {      print "\n";      $idle = 0;  }  sleep 30;}sub update {    my $html;    until ($html = get $URL) {         warn "Can't retrieve $URL!";         sleep 5;    }    my $tree = HTML::TreeBuilder->new_from_content($html) or die "Can't parse html!";    my $title = $tree->look_down(_tag => "h3", id => "ctl00_ContentPlaceHolder_TitleHeader")->as_text;    my $price = $tree->look_down(_tag => "span", id => "PriceSpan")->as_text;    my $percent = $tree->look_down(_tag => "div", class => "bar")->attr_get_i("style");    ($percent) = ($percent =~ /(\d+)/);    return ($title, $price, $percent);}

-- [zigdon]

[FreeBSD] Look out your (network) peephole. (starbolin)

Looks out your network stack to see what's working and what's not.

I wrote this when my cat unplugged the router for the Nth time. (He likes to chew the little rubber boots on the premium patch cords.) I use this script so I don't have to type the usual mantra: ifconfig, netstat -rn, ping localhost, ping default, dig nameserver, etc.... I also have found it very usefull when The Commander yells over "Hon, why isn't Pogo working?" I just run this one script and yell back "It's not on our end."

I tried to make it robust and have inteligent error messages but here is more work to be done. Still, it's very useable nevertheless. I haven't spent much time on it lately so I thought I'd post it before it became completely dust covered.The output looks like this:

1 interfaces down:        plip03 interfaces up:        rl0        fxp0        lo0Checking localnet:        127.0.0.1      working.Checking "localhost"                     working.Checking interface rl0:   10.0.0.1       working.Checking interface fxp0:  192.168.1.11   working.2 external interfaces found.Checking Default route:   192.168.1.10   working.Checking default router:  192.168.0.1    working.Checking DNS host:        dns1.xxx.xxx.net. working.Checking DNS host:        dns1.xxx.xxx.net. working.

Bugs:

Addresses for localhost, and router are hard coded.

Not portable.

No pod.

Would be nice to be able to specify your router from the command line.

Not portable.

#!/usr/bin/perl -w## peek.pl - walk up the IP stack looking for problems.## 6/7/06 betuse strict;# Definitionsmy $localnet="127.0.0.1";       # Should get this from "hosts" file.my $router = "192.168.0.1";      # Your DSL gateway here.## Files we need.my $resolv = "/etc/resolv.conf";        # To get the nameservers from.my $hosts = "/etc/hosts";               # To get "localhost" from.## Commandsmy $short_ping = "ping -t1 -c1 -n ";my $dig_cmd = "dig";my $dig_options = "+short +tries=1 +time=2";my $config_cmd = "ifconfig";my $status_cmd = "netstat -rn";## Hold found routes.my  @net;my $token; my $host;## Subroutines#sub check_interface  {          # ( -d|-u , "message" )        my $option = shift @_;        my $message = shift @_;        my $ifs=`                $config_cmd $option |                perl -lne '\$\\=" "; print \$1 if m/^([a-z]+[0-9])[:]/'        `;        my @ifs=split / /, $ifs;        print scalar @ifs, $message;        print "\t$_\n" foreach @ifs;        return @ifs}sub ping_host {        my $host = shift @_;        `$short_ping $host`;        print '', ($?==0)?'working.':'***FAILED***', "\n";}# Abnomal exit point.  Used for network errors. Use "die" for program errors.sub bail {      # Tell the user we can't continue.        print shift @_;        print "\nCan't continue tests.\n";        exit 1;}## main - program starts here#`uname` =~ /FreeBSD/ or die "Program is for FreeBSD";# Find any interfaces marked "down"check_interface( "-d", " interfaces down:\n" );# Find any interfaces marked "up"my @ifs = check_interface( "-u", " interfaces up:\n" );# Check localhost directprintf "%-26s%-15s", "Checking localnet:", $localnet;ping_host ( $localnet );# Check local host via lookupprintf "%-41s", 'Checking "localhost" ';ping_host( "localhost" );# Find address of remaining interfaces.# Check itmy $count=0;foreach my $ifs (@ifs) {        do {                @net = grep m/inet /,  split /\n/, `$config_cmd $ifs`;                if ( scalar @net != 1 ) {                        print "$ifs: No inet record found.\n"; next };                if ($net[0] =~ m/([0-9]+[.][0-9]+[.][0-9]+[.][0-9]+)/) {                        printf "%-26s%-15s",                                "Checking interface $ifs:", $1;                        `$short_ping $1`;                        if ($?==0) {                                $count++;                                print "working.\n";                        } else {                                print "***FAILED***\n";                        }                }        } unless ( $ifs eq "lo0" );}if($count == 0) { bail  "No external interfaces!!!" };print "$count external interface", ($count==1)?'':'s', " found.\n";# Find default route and check@net = grep m/default/,  split  '\n', `$status_cmd`;if ( scalar @net == 0 ) { bail "No default route!" };if ( scalar @net >= 2 ) { bail "Multiple default routes!" };# Could be on different subnets??($token, $host) = split ' ', $net[0];           #awk compatible pattern.printf "%-26s%-15s", "Checking Default route:", $host;ping_host ( $host );# Ping routerprintf "%-26s%-15s",  "Checking default router:", $router;ping_host ( $router );#       Could we maybe use TTL to resolve next hop? So we don't hardcode it.#               Otherwice we have to get it from the router.#               "ping -m3  $DNS" works, but would break if ??.#       lookup DNS in /etc/resolv.conf#               Check DNS#-e $resolv or die "Resolv.conf file ***missing ***";open FH, $resolv or die "Open $resolv failed: $!";while () {        next if ( length $_ < 10 );        ($token, $host) = split ' ';            #awk compatible pattern.        if ( $token eq "nameserver" ) {                printf "%-26s", "Checking DNS host:";                `$dig_cmd \@$host -x $host $dig_options` =~ m/([\w]|[.])+/;                if ($?==0 ) {                        print "$& working.\n";                } else {                        print "$host ***FAILED***!\n";                }        }}close FH;# Normal program termination.exit 0;__END__

s//----->\t/;$~="JAPH";s//\r<$~~/;{s|~$~-|-~$~|||s|-$~~|$~~-|||s,<$~~,<~$~,,s,~$~>,$~~>,,$|=1,select$,,$,,$,,1e-1;print;redo}

Managing BitTorrent traffic (rinceWind)

I've recently set up some torrents on my home Linux PC, mainly for Debian and Knoppix distros. I'm quite into the idea of using my spare bandwidth to seed torrents for others, but I find that this chews up my upload potential to the detrement of other things I'm doing.

I'm using the shell to background a number of btdownloadgui processes - these each provide a visual indication of the status of a given torrent. I could click "close" on all of the GUIs whenever I want to use my bandwidth for something else. But, I've found a neater solution.

There's a pair of signals: SIGSTOP and SIGCONT that can be used to suspend and resume processes. On i386 Debian, these signals are 19 and 18 respectively; see "man 7 signal" for the list of signal numbers that apply to your platform.

The shell (bash in this case) doesn't easily provide lists of PIDs. If there's exactly one process running a given command, you can use %string as a job specifier to find the PID, provided it is a child process of your current shell. As an alternative, here is some perl that will give you a list of matching PIDs to STDOUT:

#!/usr/bin/perl# findpidsuse strict;use warnings;use Unix::PID;use Getopt::Long;my $cmd = '';GetOptions(    'command=s' => \$cmd,    );my $pobj = Unix::PID->new;print join(' ',$pobj->get_pidof($cmd)),"\n";

Now, I can easily suspend and resume all my torrent processes, voila:

ivor@orinoco:~$ kill -19 `findpids --command btdownloadgui`ivor@orinoco:~$ jobs[1]   Stopped                 nice btdownloadgui --saveas ${fil%.torrent} $torrent  (wd: ~)[2]+  Stopped                 nice btdownloadgui --saveas ${fil%.torrent} $torrent  (wd: ~)[3]   Stopped                 nice btdownloadgui --saveas ${fil%.torrent} $torrent  (wd: ~)[5]   Stopped                 nice btdownloadgui --saveas ${fil%.torrent} $torrent  (wd: ~)[6]   Stopped                 nice btdownloadgui --saveas ${fil%.torrent} $torrent  (wd: ~)[7]   Stopped                 nice btdownloadgui --saveas ${fil%.torrent} $torrent  (wd: ~)[8]   Stopped                 nice btdownloadgui --saveas ${fil%.torrent} $torrent  (wd: ~)[9]-  Stopped                 nice btdownloadgui --saveas ${fil%.torrent} $torrent  (wd: ~)

The torrents die down and I get to use the bandwidth. Then, when I've finished:

ivor@orinoco:~$ kill -18 `findpids --command btdownloadgui`

and the lights start flickering on my router again.

--

Oh Lord, wont you burn me a Knoppix CD ?
My friends all rate Windows, I must disagree.
Your powers of persuasion will set them all free,
So oh Lord, wont you burn me a Knoppix CD ?
(Missquoting Janis Joplin)

Inernet daemon watchdog (sh1tn)

# `inet` is the ip, default gw and dns settings
# upon lost connection this daemon renew the settings

#!/usr/bin/perluse strict;use POSIX qw(setsid);use Net::Ping;{ fork and exit; setsid }my $router = q{default gw ip};my $net    = Net::Ping->new;sleep 5, $net->ping($router, 1) or `inet` while 1

Dynamic GAIM Info (frew)

So for a long time I had the current song from XMMS in my GAIM info, but I switched to amaroK and I needed to do something else. So I got the AutoProfile Plugin and it can run any program and use the output from that. I suggest setting up the program as a cron job and having AutoProfile reading from a file as that won't cause it to take a long time if you want perl to do something that takes a while. Anyway, after browsing around on CPAN through the Acme namespace a bit, I came up with this simple and fun info message:

#!/usr/bin/perluse strict;#use Acme::Terror::UK;use Acme::Terror;use DCOP;my $t = Acme::Terror->new();#my $s = Acme::Terror::UK->new();my $dcop = DCOP->new();#my $uLevel = $s->fetch();my $level = $t->fetch();my $current_song = $dcop->run( 'amarok player nowPlaying' );if ($dcop->run('amarok player status') == 1) {    $current_song = "$current_song [paused]";}if ($current_song) {    print "I am currently listening to: $current_song\n";}print "Stay informed!  The current terrorist threat level in the US is: $level\n";#print "Also: The current terrorist threat level in the UK is: $uLevel\n";

The UK stuff is commented out because the server seems to be down. Probably because of the recent unfortunate events in that area. Either way, I hope someone finds this cool and useful. I certainly dig it!

Note: Because getting the terror level seems to be taking a while I had this delegated to a cron job. ~~I can't figure out how to get the information from amaroK via cron, supposedly because of user permission issues. If anyone figures out a way, let me know.~~Update: I figured out what my problem was with getting the music via cron. The DCOP module uses kde-config to locate the dcop binary, but if kde-config is not in your path, it will just choke. I added a PATH variable to my cron and that fixed everything. Now hopefully you will all have the current song in your gaim info as well!

Very light weight GPS position (GrandFather)

The following code reads data from a serial port connected GPS receiver generating NMEA GGA sentences and shows the current time and location.

Note that this is not a full NMEA sentence parser and it doesn't show a continuously updated time and position. It was written in a hurry to facilitate observing a lunar graze occultation.

use strict;use warnings;use Tk;my $fh;my $mw = MainWindow->new;$mw->withdraw;if (! open $fh, '<', "COM4:") {    $mw->messageBox (        -message => 'GPS unit not available',        -title => 'Time and location', -type => 'Ok',        -icon => 'info',        );    exit;}my $location;while (<$fh>) {    next if ! /^\$GPGGA,/;    chomp;        my ($hour, $min, $sec, $latDeg, $latMin, $latHemi, $longDeg, $longMin, $longHem) =        /(\d\d)(\d\d)(\d\d),(\d\d)([\d.]+),(\S),(\d\d)([\d.]+),(\S),/;    next if ! defined ($longHem);        $latMin = toMS ($latMin);    $longMin = toMS ($longMin);    $location = sprintf "%s", "$hour:$min:$sec, $latDeg $latMin$latHemi, $longDeg $longMin$longHem";    last;}$mw->messageBox (    -message => $location, -title => 'Time and location', -type => 'Ok'    );sub toMS {    my $x = shift;    my $min = int ($x);    $x = ($x - $min) * 60;    return sprintf "%d %.2f", $min, $x;}

DWIM is Perl's answer to Gödel

C comment stripping preprocessor (GrandFather)

In the process of trying to emulate the C pre-processor I had major trouble trying to handle C style /* ... */ comments. There are two issues that cause particular grief - comments can span lines and, at least for some compilers, comments can be nested (and are in the code I need to handle).

An additional gotcha is that things that look like comments in strings need to be retained.

The code below parses an input string and generates an output string comprising the original text sans C style comments. Note that it leaves C++ single line comments however - but they are easily dealt with in the second pass.

use strict;use warnings;use Parse::RecDescent;my $decommendedText = '';sub concat ($) {$decommendedText .= $_[0]; 1;}my $decomment = <<'GRAMMAR';file : block(s)block   : string            {::concat ($item{string}); 1}        | m{((?!/\*|"|').)+}s            {::concat ($item[-1]); 1}        | comment            {::concat ($item{comment}); 1;}            string  : /"([^"]|\\")*"/            {$return = $item[-1] . ($text =~ /^\n/ ? "\n" : ''); 1;}        | /'([^']|\\')*'/            {$return = $item[-1] . ($text =~ /^\n/ ? "\n" : ''); 1;}        comment : '/*' commentBlock '*/'            {$return = $text =~ /^\n/ ? "\n" : ''; 1;}commentBlock   :  m{((?! \*/ | /\* ).)*}sx comment m{((?! \*/ | /\* ).)*}sx            {$return = "\n"; 1;}        | m{((?! \*/ | /\* ).)+}sx            {$return = ''; 1;}GRAMMARmy $parse = new Parse::RecDescent ($decomment);my $input = <<'DATA';#include "StdAfx.h" // Tail comment#include "Utility\perftime.h"#pragma hdrstop/* Comment before MACRO *//* Comment /* and nested comment */ lines */#define MACRO 10\              + 3 // Multi line macro with comment#define __DEBUG /* comment */ 1#define STRING 'This is a string' /* comment */#define COMMENT "/* comment in \"a\" string */"// c++ comment line/* Comment at start for a number of lines *//* multi-line comment/* nested */block */// cpp blockchar PerfTimer::Buf[64];DATA$parse->file($input) or die "Parse failed\n";print $decommendedText;

Prints:

#include "StdAfx.h"// Tail comment#include "Utility\perftime.h"#pragma hdrstop#define MACRO 10\              + 3 // Multi line macro with comment#define __DEBUG 1#define STRING 'This is a string'#define COMMENT "/* comment in \"a\" string */"// c++ comment line// cpp blockchar PerfTimer::Buf[64];

DWIM is Perl's answer to Gödel