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

Amortization Calculator (liverpole)

This is an amortization calculator I wrote using Perl/Tk.

You can use it to calculate, for example, the principal and interest payments you would have to make on a mortgage for a house.

The program has 3 basic sections: The upper left shows program variables, the upper right is a graph of the interest/principal paid over the life of the loan, and the bottom is the full payment schedule, which may be saved to disk.

Here is the program itself:

#!/usr/bin/perl -w##  Amortization (loan) calculation program##  060806 by liverpole################### Strict  ##################use strict;use warnings;####################### User-defined #######################my $title     = "Mortgage Calculator V4.0 (060806) liverpole";my $schedout  = "mortgage.txt";my @gcolors   = qw( red gold magenta );# Limiting valuesmy $min_years = 1;          # Minimum number of yearsmy $max_years = 100;        # Maximum number of yearsmy $min_rate  = 0.01;       # Minimum interest ratemy $max_rate  = 100.0;      # Maximum interest rate#################### Libraries ####################use FileHandle;use File::Basename;use Tk;use Tk::DialogBox;################## Globals ##################my ($loan, $rate, $period, $years, $npay, $extra, $newyear, $newpay);my ($o_loan, $o_rate, $o_period, $o_years, $o_npay);my ($o_extra, $o_newyear, $o_newpay);my ($payment, $total, $tot_paid, $tot_prin, $tot_int, $pct_int, $maxpay);my $payments = [ ];my @glist;my $use_defaults = 0;my $iam = basename($0);########################## Package textbox ##########################package textbox;our $AUTOLOAD;my $ptags = {    '-1' => 'debug',     '0' => 'default',     '1' => 'warning',     '2' => 'error',};my $plevels = {    '-1' => '[debug]',     '0' => ' [info]',     '1' => ' [warn]',     '2' => '[error]',};################################################################################  new():  textbox constructor.  Parameters are:##      $1 ... The textbox object#      $2 ... The parent window#      $3 ... The textbox width#      $4 ... The textbox height#      $5 ... The textbox color#      $6 ... The textbox default font#      $7 ... A flag which, if nonzero, disables the textbox#      $8 ... Scrollbar location (defaults to optional-south + optional-east)##  Return value:  The textbox object###############################################################################sub new {    my ($obj, $win, $width, $height, $bg, $font, $b_dis, $sb_loc) = @_;    $win or return;    my $mw = $win->toplevel();    $width  ||= 0;    $height ||= 0;    $bg     ||= 'white';    $font   ||= 0;    $b_dis  ||= 0;    $sb_loc ||= "osoe";    my $tbox = $win->Scrolled('Text', -bg => $bg, -scrollbars => $sb_loc);    $tbox->configure(-wrap => 'none', -takefocus => 0);    $width  && $tbox->configure(-width  => $width);    $height && $tbox->configure(-height => $height);    my $state = ($b_dis)? 'disabled': 'normal';    $tbox->configure(-state => $state);    $tbox->pack(-side => 'left', -expand => '1', -fill => 'both');    my $this = {        'mw'      => $mw,      # Toplevel window        'win'     => $win,     # Parent window        'widget'  => $tbox,    # The textbox widget        'font'    => $font,    # The textbox font        'bg'      => $bg,      # The textbox background color        'tags'    => { },      # The defined tags        'state'   => $state,   # The state (disabled or normal)    };    # Bless the object    bless $this, $obj;    # Create the default fonts    $this->create_tag('debug',   $font, 'grey',       'black');    $this->create_tag('default', $font, $bg,          'black');    $this->create_tag('error',   $font, 'red3',       'white');    $this->create_tag('warning', $font, 'sandybrown', 'black');    return $this;}################################################################################  DESTROY():  textbox destructor.  Parameters are:##      $1 ... The textbox object###############################################################################sub DESTROY {    my ($this) = @_;    my $tbox = $this->{'widget'};    $tbox and $tbox->packForget();}################################################################################  AUTOLOAD:  this simply calls the given subroutine on the underlying#  widget, and passes on the passed arguments.  For example, this lets you#  do the following:##        my $tb = new textbox($db, 80, 40, 'gray', 0, 1);#        $tb->configure(-state => 'normal');#        $tb->insert('end', 'Hello world!');#        $tb->configure(-state => 'disabled');#        $tb->yview('1.0');##     $1 ... The textbox object###############################################################################sub AUTOLOAD {    my ($this, @params) = @_;    my $name = $AUTOLOAD;    $name =~ s/.*:://;    $this->{'widget'}->$name(@params);};############################ Other subroutines ##############################  create_tag:  creates the given tag with a specified font, background#  color, and foreground color, for use with the textbox.  The tag is not#  created if it already exists for the object.  If a label is not given#  for the tag, a label is created out of the font, background and foreground#  color names.  Parameters are:##     $1 ... The textbox object#     $2 ... The label for the font#     $3 ... The name of the font (optional)#     $4 ... The background color (optional)#     $5 ... The foreground color (optional)#sub create_tag {    my ($this, $label, $font, $bg, $fg) = @_;    $label or $label = "${font}_${bg}_${fg}";    return if defined($this->{'tags'}->{$label});    $this->{'tags'}->{$label} = 1;    my $tbox = $this->{'widget'};    $font ||= $this->{'font'};    $bg   ||= 0;    $fg   ||= 0;    $font and $tbox->tagConfigure($label, -font       => $font);    $bg   and $tbox->tagConfigure($label, -background => $bg);    $fg   and $tbox->tagConfigure($label, -foreground => $fg);};##  out:  writes the given text to the text box.  Parameters are:##     $1 ... The textbox object#     $2 ... The text to write (or list of lines of text)#     $3 ... The tag to use (if different from the default)#     $4 ... The level if no tag given (-1=debug, 0=info, 1=warning, 2=error)#     $5 ... An EOL flag which, if nonzero, suppresses the end-of-line#     $6 ... An update flag which, if nonzero, suppresses the gui update.#sub out {    my ($this, $ptext, $tag, $level, $b_no_eol, $b_no_update) = @_;    $level       ||= 0;    $b_no_eol    ||= 0;    $b_no_update ||= 0;    (ref $ptext eq 'ARRAY') or $ptext = [ $ptext ];    if (!$tag) {        $tag = $ptags->{$level} || 'default';    }    my $tbox = $this->{'widget'};    $tbox->configure(-state => 'normal');    (@$ptext > 0) or return;    ($b_no_eol) and map { $tbox->insert('end', "$_",   $tag); } @$ptext;    ($b_no_eol)  or map { $tbox->insert('end', "$_\n", $tag); } @$ptext;    $tbox->configure(-state => $this->{'state'});    $tbox->yview('end');    $b_no_update or $this->{'mw'}->update();    return 0;};##  log:  similar to out(), except that the current time and level name are#  displayed as part of the message, and no tag is passed.##     $1 ... The textbox object#     $2 ... The text to write (or list of lines of text)#     $3 ... The tag to use (if different from the default)#     $4 ... The level if no tag given (-1=debug, 0=info, 1=warning, 2=error)#     $5 ... An EOL flag which, if nonzero, suppresses the end-of-line#     $6 ... An update flag which, if nonzero, suppresses the gui update.#sub log {    my ($this, $ptext, $level, $b_no_eol, $b_no_update) = @_;    my $ctime = localtime(time);    $ctime =~ s/\S+\s+(... .. \d+:\d+:\d+).+/$1/;    my $tag   = $ptags->{$level}   || 'default';    my $ltext = $plevels->{$level} || $plevels->{0};    my $p = [ ];    if (ref $ptext eq 'ARRAY') {        map { push @$p, "$ctime $_" } @$ptext;    } else {        $p = [ "$ctime $ltext  $ptext" ];    }    return $this->out($p, $tag, $level, $b_no_eol, $b_no_update);};##  get:  gets the text in the text box.  Parameters are:##     $1 ... The textbox object#sub get {    my ($this) = @_;    my $tbox = $this->{'widget'};    my $ptext = $tbox->get('1.0', 'end');    chomp $ptext;    return $ptext;};##  clear:  clears the text box.  Parameters are:##     $1 ... The textbox object#sub clear {    my ($this) = @_;    my $tbox = $this->{'widget'};    my $mw = $this->{'mw'};    $tbox->configure(-state => 'normal');    $tbox->delete('1.0', 'end');    $tbox->configure(-state => $this->{'state'});    $mw->update();};##  bind:  simply binds the given key to the textbox widget.  Parameters are:##     $1 ... The textbox object#     $2 ... The key to bind#     $3 ... The subroutine to invoke#sub bind {    my ($this, $key, $psub) = @_;    my $tbox = $this->{'widget'};    $tbox->bind($key, $psub);};# End of package "textbox"####################### Package help #######################package help;my $help = "    OVERVIEW    This program calculates an amortization schedule, based on the following    user-supplied variables:        (loan)   L = original loan amount        (rate)   R = yearly interest rate (as a percentage)        (period) P = periods per year (eg. 12 = monthly)        (years)  Y = number of years        (extra)  X = extra amount paid to reduce the mortgage    and the following program-calculated variables:        F = factor loan grows by each period = 1 + (R / P)        N = number of payments = Y * P        A = amount of periodic payment (see formula for 'A' below)        T = total amount paid = A * N        M = monthly interest paid        I = total amount of interest paid    The program also calculates how the number of periods can be altered,    depending on an extra amount X paid each period.    The basic formula for calculating A (the amount owed each period) is:        A = L(F^N)(F-1) / (F^N - 1)    The monthly interest M is:        M = L * (R / P)    (which is:  new_balance - previous_balance)    The total amount paid will be:        T = (A * N) + X * (N - S)    of which the total interest paid will be:        I = T - L    Try changing any of the values in the upper-left box of the application,    to see how they affect the entire payment schedule.  Set the desired    values for:        Loan Amount        Annual % interest rate        Period (12 = each month)        Base # of years        Base # of payments        Extra payment amount    and observe the corresponding changes to the values for:        Payment Amount        Total interest payments        Total principal payments        Total amount paid        Interest as % of total    You can change the 'Extra payment amount' to see how much earlier the    loan would be paid off when making additional payments each period (the    new values cannot be larger than the values of 'Base # of years' and    'Base # of payments', though).    To reset the program variables, type '^R' or press the button marked    'Reset Variables'.    To save the payment schedule to a file (eg. for printing), type '^S' or    press the button marked 'Save Schedule'.    To exit the program, type , or press the button marked 'Exit'.";##  new -- help constructor.  Parameters are:##      $1 ... The help object#      $2 ... The parent window#      $3 ... The button text (0 = no button)#      $4 ... The button color (0 = default)#      $5 ... The button pack style#      $6 ... The help message title#      $7 ... The help message text#      $8 ... The help message width (defaults to 40)#      $9 ... The help message height (defaults to 80)##  Return value:  The help object#sub new {    my ($obj, $win, $btext, $bcolor, $pack, $key, $title, $msg, $w, $h) = @_;    my $mw = $win->toplevel();    $w ||= 80;    $h ||= 40;    my $this = {        'mw'     => $mw,     # Toplevel window        'win'    => $win,    # Parent window        'key'    => $key,    # The accelerator key        'title'  => $title,  # The help title        'msg'    => $msg,    # The help message        'width'  => $w,      # The help message width        'height' => $h,      # The help message height    };    #    #  Create an anonymous subroutine to display the help dialog box.    #  Create a button to call the function if button text was supplied,    #  and create an accelerator key to call it if a key was supplied.    #    my $pfunc = sub { $this->give_help() };    $btext and &main::button($win, $btext, $bcolor, $pfunc, 0, $pack);    ($key =~ /^[fF]([0-9]+)$/) and $key = "";    $key and $mw->bind($key, $pfunc);    # Bless the object    bless $this, 'help';    return $this;}##  give_help:  displays the actual help message in a dialog box for#  the user to peruse.#sub give_help {    (@_ > 1) and shift;    # Throw away event, if triggered by a button    my ($this) = @_;    my $mw      = $this->{'mw'};    my $title   = $this->{'title'};    my $width   = $this->{'width'};    my $height  = $this->{'height'};    my $db = $mw->DialogBox(-title => $title, -buttons => [ "OK" ]);    my $tb = new textbox($db, $width, $height, 'gray', 0, 1);    $tb->configure(-state => 'normal');    $tb->insert('end', $this->{'msg'});    $tb->configure(-state => 'disabled');    $tb->yview('1.0');    $db->Show();    $mw->update();}# End of package "help"####################### Main program #######################package main;reset_values();gui_mode();###################### Subroutines ######################sub reset_values {    $o_loan    = $loan    = 100000;    $o_rate    = $rate    = 5.0;    $o_period  = $period  = 12;    $o_years   = $years   = 30;    $o_npay    = $npay    = $years * $period;    $o_extra   = $extra   = 0;    $o_newyear = $newyear = $years;    $o_newpay  = $newpay  = $npay;    find_payment();}sub summary {    my ($extra, $np, $P) = @_;    my $years = (0 == $P)? 0: ($np / $P);    printf "\nExtra payment[\$%.2f]:  Nperiods = %d  (%3.1f years)\n\n",        $extra, $np, $years;}sub calc_payment {    my ($L, $R, $P, $N) = @_;    my $F = 1 + ($R / 100.0 / $P);    my $A = $L * ($F ** $N) * ($F - 1) / ($F ** $N - 1);    my $result = sprintf "%.2f", $A;    return $result;}sub commas {    my ($val) = @_;    $val =~ s/,//g;    $val = sprintf "%.2f", $val;    $val =~ s/(?<=\d)(\d{3})(?=(,\d{3}|\.))/,$1/g;    return $val;}sub schedule_header {    my ($rate) = @_;    my $text = sprintf "Year ";    $text   .= sprintf "Period      ";    $text   .= sprintf "Starting     ";    $text   .= sprintf "+ %6.4f%%       ", $rate;    $text   .= sprintf "Payment         ";    $text   .= sprintf "Extra        ";    $text   .= sprintf "Ending       ";    $text   .= sprintf "Interest    ";    $text   .= sprintf "Total int";    return $text;}sub enforce_limits {    my ($pvar, $min, $max) = @_;    if ($$pvar < $min) {        $$pvar = $min;    } elsif ($$pvar > $max) {        $$pvar = $max;    }}sub schedule {    my ($out, $L, $R, $P, $N, $X) = @_;    my $F = 1 + ($R / 100.0 / $P);    my $start = $L;    my $b_is_fh = (ref($out) =~ /FileHandle/);    my $pout = sub {        my ($msg) = @_;        $b_is_fh and print $out "$msg\n";        $b_is_fh  or $out->out($msg);    };    if ($b_is_fh) {        my $shdr = schedule_header($R);        $pout->($shdr);    }    my ($i, $text);    my $fmt = "%4s %6d %13s %13s %13s %13s %13s %13s %13s\n";    my ($int, $A) = (0, 0);    $tot_int = 0;    $tot_paid = 0;    $payments = [ ];    for ($i = $maxpay = 0; $start > 0; $i++, $N--) {        my $nyear = int($i / $period);        my $extra = $X;        my $w_int = sprintf "%.2f", ($start * $F);        my $end = $w_int;        $int = $w_int - $start;        # Interest payment        $tot_int += $int;        (!$A || $extra <= 0) and $A = calc_payment($start, $R, $P, $N);        $end -= $extra;        ($end <= $A) and $A = $end;        $end -= $A;        $tot_paid += ($A + $extra);        # Save payment information        $payments->[$nyear]->[0] += $int;        $payments->[$nyear]->[1] += $A - $int;        $payments->[$nyear]->[2] += $extra;        my $totpay = $payments->[$nyear]->[0] +                     $payments->[$nyear]->[1] +                     $payments->[$nyear]->[2];        ($totpay > $maxpay) and $maxpay = $totpay;        $text .= sprintf $fmt,                    (0 == ($i % $P)? ($i / $P): " "), $i+1,                    commas($start), commas($w_int), commas($A),                    commas($extra), commas($end), commas($int),                    commas($tot_int);        $start = $end;    }    $pct_int = sprintf "%8.3f%%", (100.0 * $tot_int / $tot_paid);    $tot_prin = $tot_paid - $tot_int;    # Make these values 'pretty', as they aren't directly changed by the user    dollar_amount(\$tot_prin, 1);    dollar_amount(\$tot_paid, 1);    dollar_amount(\$tot_int,  1);    if ($out && 0 == ($i % $P)) {        $text .= sprintf "%4s %s\n", ($i / $P), ('-' x 3);    }    $pout->($text);    return $i;}sub configure_relief {    my ($widget, $rel) = @_;    if ($rel) {        ($rel eq 'n') and $rel = 'none';        ($rel eq 'f') and $rel = 'flat';        ($rel eq 'g') and $rel = 'groove';        ($rel eq 'r') and $rel = 'raised';        ($rel eq 'R') and $rel = 'ridge';        ($rel eq 's') and $rel = 'solid';        ($rel eq 'S') and $rel = 'sunken';        $widget->configure(-relief => $rel);    }}sub configure_packing {    my ($widget, $pack) = @_;    if ($pack =~ s/([<|>])//) {        my $just = $1;        if ($widget =~ /Entry/) {            ($just eq '<') and $widget->configure(-justify => 'left');            ($just eq '|') and $widget->configure(-justify => 'center');            ($just eq '>') and $widget->configure(-justify => 'right');        }    }    if ($pack) {        my $fill   = ($pack =~ /([bxyn])/)? $1: 'n';        my $expand = ($pack =~ /([01])/)?   $1: '0';        my $side   = ($pack =~ /([TBLR])/)? $1: 'top';        ($fill eq 'b') and $fill = 'both';        ($fill eq 'n') and $fill = 'none';        ($side eq 'T') and $side = 'top';        ($side eq 'B') and $side = 'bottom';        ($side eq 'L') and $side = 'left';        ($side eq 'R') and $side = 'right';        $widget->pack(-expand => $expand, -fill => $fill, -side => $side);    }    return $widget;}## frame:  Creates a Tk Frame widget##     $1 ... The parent window#     $2 ... The frame background color#     $3 ... The frame relief#     $4 ... The frame border width#     $5 ... The frame pack style, which may include the side (T=top,#            B=bottom, L=left, R=right), the fill flag (n=none, x, y,#            or b=both) and/or the expand flag (0 or 1).#sub frame {    my ($w, $bg, $rel, $bw, $pack) = @_;    $bg   ||= 0;    $rel  ||= 0;    $bw   ||= 5;    $pack ||= 'T';    my $f = $w->Frame(-borderwidth => $bw);    $bg and $f->configure(-bg => $bg);    configure_relief($f, $rel);    return configure_packing($f, $pack);}## button:  Creates a Tk Button widget##     $1 ... The parent window#     $2 ... The button text#     $3 ... The button background color#     $4 ... The associated command#     $5 ... The width of the button#     $6 ... Where/how to place the button.  If it contains one#            of [TBLR], packs it (top, bottom, left or right).#            If it contains the format "r,c", grids it at the#            given row, column.  If it contains 'd', disables the#            button.#     $7 ... An optional key to bind to this button from the main#            window.  If the key is in the format 'F[0-9]*', it#            is converted to the appropriate function key name.#sub button {    my ($win, $txt, $bg, $pcmd, $width, $where, $key) = @_;    $txt   ||= '';    $bg    ||= 'green';    $pcmd  ||= 0;    $width ||= 0;    $where ||= 0;    $key   ||= 0;    ($key =~ /^[fF]([0-9]+)$/) and $key = "";    ($key =~ /^esc(ape)?$/i)   and $key = "";    ($key =~ /^\^(.+)/)        and $key = "";    my $mw = $win->toplevel();    my $b = $win->Button(-text => $txt, -bg => $bg);    $pcmd  and $b->configure(-command => $pcmd);    $width and $b->configure(-width   => $width);    ($where =~ /d/) and $b->configure(-state   => 'disabled');    $key   and $mw->bind($key, sub { $b->invoke(); });    if ($where) {        my $anch   = ($where =~ s/([<|>])//)?  $1: 0;        ($anch eq '<') and $b->configure(-anchor => 'w');        ($anch eq '|') and $b->configure(-anchor => 'center');        ($anch eq '>') and $b->configure(-anchor => 'e');        if ($where =~ /(\d+),(\d+)/) {            my ($row, $col) = ($1, $2);            $b->grid(-row => $row, -col => $col);        } elsif ($where =~ /[TBLR]/) {            my $side = 'L';            ($where =~ /T/) and $side = 'top';            ($where =~ /B/) and $side = 'bottom';            ($where =~ /L/) and $side = 'left';            ($where =~ /R/) and $side = 'right';            $b->pack(-side => $side);        }    }    return $b;}## entry:  Creates a Tk Entry widget:##     $1 ... The parent window#     $2 ... The entry background color#     $3 ... The entry width#     $4 ... The entry relief#     $5 ... The associated scalar variable#     $6 ... Special flags.  If it contains 'd', disables the widget#            from input.  If it contains '*', hides text.#     $7 ... The entry pack style, which may include the justification#            (<=left, |=center, >=right), side (T=top, B=bottom, L=left,#            R=right), the fill flag (n=none, x, y, or b=both) and/or#            the expand flag (0 or 1).#     $8 ... Callback routine when text is entered in the Enter widget.#sub entry {    my ($w, $bg, $width, $rel, $pvar, $flags, $pack, $pcback) = @_;    $bg     ||= 'white';    $width  ||= 0;    $rel    ||= 0;    $pvar   ||= 0;    $flags  ||= 0;    $pack   ||= 0;    $pcback ||= 0;    my $e = $w->Entry();    $bg     and $e->configure(-bg      => $bg);    $width  and $e->configure(-width   => $width);    $pvar   and $e->configure(-textvar => $pvar);    if ($flags) {        ($flags =~ /d/)  and $e->configure(-state => 'disabled');        ($flags =~ /\*/) and $e->configure(-show  => '*');    }    configure_relief($e, $rel);    if ($pcback) {        # Allow '' and loss-of-focus to trigger this callback        $e->bind('', $pcback);        $e->bind('', $pcback);    }    return configure_packing($e, $pack);}## labent:  Creates a Tk Label/Entry widget:##     $1 ... The parent window#     $2 ... The label background color#     $3 ... The label width#     $4 ... The label relief#     $5 ... The text (or text variable) of the label#     $6 ... The entry background color#     $7 ... The entry width#     $8 ... Various flags, in which the following characters are valid:##               Flags     Meaning#                 d ..... The widget is disabled#                 * ..... The text appears as '*' (eg. for passwords)##             Anchors     Meaning#                 < ..... The widget is anchored left#                 | ..... The widget is anchored middle#                 > ..... The widget is anchored right##              Pack       Meaning#                 T ..... Pack the widget to the top#                 B ..... Pack the widget to the bottom#                 L ..... Pack the widget to the left#                 R ..... Pack the widget to the right##              Fill       Meaning#                 N ..... No fill#                 X ..... Fill in the X-direction#                 Y ..... Fill in the Y-direction#                 B ..... Fill in both the X and Y directions#                 0 ..... Do NOT expand#                 1 ..... Expand##     $9 ... Callback routine when text is entered in the Enter widget.#sub labent {    my ($w, $label, $bg1, $w1, $pvar, $bg2, $w2, $flags, $pvalid) = @_;    $label  ||= '';    $bg1    ||= 'gray';    $w1     ||= '10';    $pvar   ||= 0;    $bg2    ||= 'white';    $w2     ||= 10;    $flags  ||= 0;    $pvalid ||= 0;    my $lpack = 'Lb1';    my $epack = 'Lb1';    ($flags =~ /([<|>])/) and $epack .= $1;    my $fr_bg = $w->cget(-bg);    my $f = frame($w, $fr_bg, 'g', 3, 0);    my $l = label($f, $bg1, $w1, 0, $label, $lpack);    my $e = entry($f, $bg2, $w2, 0, $pvar,  $flags, $epack, $pvalid);    return [ $l, $e ];}## label:  Creates a Tk Label widget##     $1 ... The parent window#     $2 ... The label background color#     $3 ... The label width#     $4 ... The label relief#     $5 ... The text (or text variable) of the label#     $6 ... The entry pack style, which may include the anchor position#            (<=left, |=center, >=right), side (T=top, B=bottom, L=left,#            R=right), the fill flag (n=none, x, y, or b=both) and/or#            the expand flag (0 or 1).#sub label {    my ($w, $bg, $width, $rel, $pvar, $pack) = @_;    $bg    ||= 0;    $width ||= 0;    $rel   ||= 0;    $pvar  ||= 0;    $pack  ||= 0;    my $l = $w->Label();    $bg    and $l->configure(-bg    => $bg);    $width and $l->configure(-width => $width);    if ($pvar) {        if (ref $pvar eq '') {            $l->configure(-text => $pvar);        } else {            $l->configure(-textvar => $pvar);        }    }    configure_relief($l, $rel);    return configure_packing($l, $pack);}GUI: {    my $mw;    my $te;    my $tb = 0;    my $graph = 0;    my ($f1, $f2, $f3, $f4, $f5, $f6, $f7, $f8, $f9);    my ($le1, $le2, $le3, $le4, $le5, $le6, $le7);    my $bg1 = 'peachpuff';            # Label/Entry color    sub exit_gui {        $mw->exit;    }    sub make_float {        my ($pval) = @_;        $$pval =~ s/[^\d\.]//g;        $$pval =~ s/(\..*)\./$1/g;    }    sub dollar_amount {        my ($pval, $pretty) = @_;        $pretty ||= 0;        make_float($pval);        $$pval = sprintf "%.2f", $$pval;        $pretty and $$pval = '$' . commas($$pval);        return $$pval;    }    sub adjust_for_extra {        my ($np) = @_;        $o_newpay = $newpay = int($np);        $o_newyear = $newyear = sprintf "%.3f", ($newpay / $period);        show_graph();    }    sub find_payment {        $payment = calc_payment($loan, $rate, $period, $npay);        dollar_amount(\$payment, 1);        return unless $tb;        $tb->clear();        my $np = schedule($tb, $loan, $rate, $period, $npay, $extra);        adjust_for_extra($np);    }    sub do_principal {        return if ($loan eq $o_loan);        dollar_amount(\$loan);        find_payment();        $o_loan = $loan;    }    sub do_rate {        return if ($rate eq $o_rate);        enforce_limits(\$rate, $min_rate, $max_rate);        ($rate < 0.1) and $rate = 0.1;        make_float(\$rate);        find_payment();        create_schedule_header();        $o_rate = $rate;    }    sub do_period {        return if ($period eq $o_period);        make_float(\$period);        ($period < 1) and $period = 12;        $period = int($period);        find_payment();        $o_period = $period;    }    sub do_years {        return if ($years eq $o_years);        enforce_limits(\$years, $min_years, $max_years);        make_float(\$years);        $npay = int($years * $period);        do_npay();        $o_years = $years;    }    sub do_npay {        return if ($npay eq $o_npay);        $npay = int($npay);        $years = sprintf "%.3f", ($npay / $period);        find_payment();        $o_npay = $npay;    }    sub do_extra {        return if ($extra eq $o_extra);        dollar_amount(\$extra);        find_payment();        $o_extra = $extra;    }    sub clear_graph {        while (my $id = shift @glist) {            $graph->delete($id);        }    }    sub save_schedule {        my $dir = $ENV{'USERPROFILE'};        defined($dir) and $dir .= "\\Desktop";        $dir ||= ".";        my @opts = (            -title            => "Save Mortgage Information",            -defaultextension => 'txt',            -initialdir       => $dir,            -initialfile      => $schedout,        );        my $fname = $mw->getSaveFile(@opts);        $fname or return;        my $fh = new FileHandle;        open($fh, ">", $fname) or return;        schedule($fh, $loan, $rate, $period, $npay, $extra);        close $fh;    }    sub plot_points {        my ($x, $xinc, $y, $yext, $p) = @_;        my $x0 = $x;        my $x1 = $x + $xinc;        my $y0 = $y;        for (my $i = 0; $i < @$p; $i++) {            my $pay = $p->[$i] / $maxpay;            my $y1 = $y0 - ($pay * $yext);            my $bg = $gcolors[$i];            my $id = $graph->createRectangle($x0, $y0, $x1, $y1, -fill => $bg);            push @glist, $id;            $y0 = $y1;        }        return $x1;    }    sub show_graph {        return unless $graph;        # Clear the previous graph        clear_graph();        # Get the number of payments saved (and make sure it's more than 1)        my $n = @$payments;        return if ($n < 1);        # Get the absolute pixel width and height of the canvas        my $width = $graph->Width();        my $height = $graph->Height();        # Draw the graph        my ($xmargin, $ymargin) = (5, 5);        my $xinc = ($width - 2 * $xmargin) / $n;        my $yext = ($height - 2 * $ymargin);        my $x = $xmargin;        my $y = $height - $ymargin;        for (my $i = 0; $i < @$payments; $i++) {            $x = plot_points($x, $xinc, $y, $yext, $payments->[$i]);        }    }    sub create_schedule_header {        my $shdr = schedule_header($rate);        $te and $te->packForget();        $te = $f8->Text(-height => 1);        $te->pack(-expand => 0, -fill => 'x');        $te->insert('end', "$shdr");        $te->configure(-state => 'disabled', -takefocus => 0);    }    sub gui_mode {        $mw = new MainWindow(-title => $title);        $mw->fontCreate('vals', -family => 'arial', -size => 12);        my $top = frame($mw, 0, 0, 0, 'Tb1');        $f1 = frame($top, 'pink', 'g', 0, 'x0');        button($f1, "Exit (Esc)", 0, \&exit_gui, 0, 'R', 'esc');        new help($f1, 'Help (F1)', 0, 'L', '', 'Program Help', $help);        button($f1, 'Reset Variables (^R)', 0, \&reset_values,  0, 'L', '^R');        button($f1, "Save Schedule (^S)",   0, \&save_schedule, 0, 'L', '^S');        $f2 = frame($top,      0, 'g', 0, 'Tx0');        $f3 = frame($f2,  'cyan',  0,  0, 'Ln0');    # Variables frame        $f4 = frame($f2,       0, 'g', 0, 'Lb1');    # Graph frame        $f5 = frame($top, 'cyan', 'g', 0, 'Tb1');    # Schedule frame        my $labents = [            [ 'Loan Amount',              \$loan,     'T>',   \&do_principal ],            [ 'Annual % interest rate',   \$rate,     'T>',   \&do_rate ],            [ 'Period (eg. 12=monthly)',  \$period,   'T>',   \&do_period ],            [ 'Base # of years',          \$years,    'T>',   \&do_years ],            [ 'Base # of payments ',      \$npay,     'T>',   \&do_npay  ],            [ 'Extra payment amount',     \$extra,    'T>',   \&do_extra ],            [ 'Payment Amount',           \$payment,  'T>d',  0 ],            [ 'Total interest payments',  \$tot_int,  'T>d',  0 ],            [ 'Total principal payments', \$tot_prin, 'T>d',  0 ],            [ 'Total amount paid',        \$tot_paid, 'T>d',  0 ],            [ 'Interest as % of total',   \$pct_int,  'T>d',  0 ],        ];        foreach my $p (@$labents) {            my $p = labent($f3, $p->[0], $bg1, 24, $p->[1],                            0, 12, $p->[2], $p->[3]);            $p->[1]->configure(-font => 'vals');        }        # Graph frame        $f6 = frame($f4, 0, 'g', 0, 'Tx0');        $f7 = frame($f4, 0, 'g', 0, 'Tb1');        label($f6, 'white',     0, 'g', '            Key              ', 'L');        label($f6, $gcolors[0], 0, 'g', '     Interest payments       ', 'L');        label($f6, $gcolors[1], 0, 'g', '   Basic principal payments  ', 'L');        label($f6, $gcolors[2], 0, 'g', '   Extra principal payments  ', 'L');        $graph = $f7->Canvas(-bg => 'gray');        $graph->pack(-expand => 1, -fill => 'both');        $f7->bind('', \&show_graph);        # Schedule frame        $f8 = frame($f5,  'gold',  0,  0, 'Tx0');        $f9 = frame($f5,  'gold',  0,  0, 'Tb1');        create_schedule_header();        $tb = new textbox($f9, 115, 16, 0, 0, 0, "e");        $mw->after(100, \&find_payment);        MainLoop;    }}

s''(q.S:$/9=(T1';s;(..)(..);$..=substr+crypt($1,$2),2,3;eg;print$..$/

RFC: LaTeX::Table (lima1)

Well, it is not really cool, but useful (at least it was for me :-p)

Download

The SYNOPSIS demonstrates the main functionality:

        use LaTeX::Table;         my $data = [               [ 'Lisa',   '0', '0' ],               [ 'Marge',  '0', '1' ],               [ 'Wiggum', '0', '5' ],               [ 'Otto',   '1', '3' ],               [ 'Homer',  '2', '6' ],               [ 'Barney', '8', '16' ],         ];         my $header               = [ [ 'Name', 'Beers:2|c|' ], [ '', 'before 4pm', 'after 4pm' ] ];         my $table = LaTeX::Table->new(               {                  filename    => 'counter.tex',                  caption     => 'Number of beers before and after 4pm.',                  maincaption => 'Beer Counter',                  label       => 'table_beercounter',                  theme       => 'Houston',                  tablepos    => 'htb',               }         );         $table->generate( $header, $data )

It supports multipage tables (e.g. for appendices) and some predefined good looking table themes.Some feedback is highly appreciated before putting it on CPAN.

2006-08-04 Retitled by [Arunbear], as per Monastery [id://341118|guidelines]
Original title: 'LaTeX::Table'

New Graphing Module (aplonis)

There is one important instance where GD::Graph::lines does not suffice. That is the case where you require two Y axes (left & right) with more than two data curves to trace.

So I have cobbled together a module (my first ever OO) which covers that instance where GD::Graph::lines is lacking. May it serve as a tide-over until the day (month?, year?) when GD::Graph::lines shall be repaired.

This is a self-actualizing demo of the module, part of a utility I'm working on to graph strain gage rosette data. It generates fake data, saves it to a file, reads it back in, adds some calcualted-result channels, graphs it both in GD as *.png and in PostScript as an *.eps file

That's right, the output is PostScript. So you'll need a viewer (gv on UNIX, GSView on Win32) to view it. Running the file also calls up whichever of those is appropriate for your OS to display the graph.

It only does line graphs but does them quite prettily...except for the example given...which is deliberately hideous to show off user options for colors, fonts, etc. (I'm not really color-blind.)

Graphing Module Demo

There isn't any real Perl magic here, though. It's PostScript which performs all the tricks. I dredged up an old standalone PostScript graphing program which I'd written way back in 1992, tidied it a bit, broke it into pieces and married those pieces to Perl to make this happen.

You can choose any web safe color for back- and fore-grounds, lines, etc. You can choose any of the 35 fonts. And it auto-reconciles the Y1 and Y2 axes for best resolution of the data traces. That is to say, for each axis, at least one trace will course nearly the whole vertical area.

Its one big flaw is that no single data trace may number more than 65,535 data points. This is due to PostScript's internal addressing limitation...which I have yet to creatively overcome. At some point later on, after I've tinkered with it a bit more, I'll put in in CPAN. For now it's embeded in the demo script.

Gan Uesli Starling
Kalamazoo MI USA

(Apache::Session) Detect a Failure to Save Session (Mr. Muskrat)

You're using Apache::Session and sometimes the data doesn't stay saved when you think it should (like mentioned in [id://435977]). Chances are it's a closure that is to blame.

Just add the DESTROY method to your derived class and it will spew a warning anytime it detects this happening. (YMMV of course.)

package Apache::Session::Derived::Class;use strict;our $VERSION = '1.00';our @ISA     = qw(Apache::Session);use Apache::Session;...sub populate {    my $self = shift;    ...    return $self;}sub DESTROY {    my $self = shift;    local $@;    eval {        $self->save;    };    if ( $@ ) {        my $error = $@;        my $msg = q{Can't call method ".*?" on an undefined value at }            . q{.*?/Apache/Session\.pm line \d+ during global destruction.};        if ( $error =~ m/$msg/ ) {          warn "Unable to save session changes! (Closure around session?)\n";        } else {          warn $error;        }    }    $self->release_all_locks;}1;

I would like to thank [diotalevi] for pointing out the need for localizing $@.

Stealth Raven Shield launcher - Switching DNS server under Win32 (GrandFather)

A number of us indulge in a little mayhem during lunchtime at work in the form of running around with guns shooting each other. Or at least, we play Raven Shield. To avoid network issues we turn off DNS and have to remember to turn it back on after we have beaten each other to a pulp, or worse. If we dont PerlMonks doesnt work any more :(

A workmate wrote the code below and I added to it slightly. It changes the DNS server address to the local machine, launches Raven Shield, then restores the DNS server when Raven Shield exits. Enjoy.

use strict;use warnings;# change these to work with your machine.my $interface_name = "Local Area Connection";my $RSPath         = 'C:\games~~\Red Storm Entertainment\RavenShield';# Get current IPmy $config = `ipconfig`;$config =~ /IP Address[. :]+([\d.]*)/;my $myIP = $1;munt();show();launch();unmunt();show();sub launch{print `$RSPath/system/RavenShield.exe`;}sub munt{print `netsh interface ip set dns "$interface_name" static $myIP`;}sub unmunt{print `netsh interface ip set dns "$interface_name" dhcp`;}sub show{print `netsh interface ip show dns`;}

DWIM is Perl's answer to Gödel

Giving birth with perl (jasonk)

So my wife and I are expecting our first baby. Today in fact, although it looks as though she will be a bit late.

I got tired of trying to figure out which button did what on the little digital watch we were trying to use to time contractions, so I threw this together. There is obviously room for improvement (or even golfing), but something tells me that I should be doing something else right about now...

#!/usr/bin/perl -wuse strict;use warnings;my $last = time;while( <> ) {    my $time = time;    my $interval = $time - $last;    print localtime($time)." ($interval)";    $last = $time;}

We're not surrounded, we're in a target-rich environment!

downloader (fighting with missing urls) (sh1tn)

use strict;use warnings;use WWW::Mechanize;use LWP::Simple;use Data::Dumper;use Time::HiRes qw( usleep tv_interval gettimeofday );$|++;my $url  = shift || die "no url given!\n";my $ext  = shift || 'mp3'; #die "no file extention given!\n";my $mech = WWW::Mechanize->new(agent=>"Mozilla/5.0");my $ua   = LWP::UserAgent->new;$mech->get($url);$ua->timeout(5);my $links = $mech->links;no warnings;for my $link ( @{$links} ) {        my $url  = $link->url_abs;        my $res  = $ua->head($url);        my $http_res   = HTTP::Response->new($res);        my $abs_name   = $http_res ->{'_rc'}->{'_previous'}->{'_headers'}->{'location'};        my ($rel_name) = $abs_name =~ /.+\/(.+)$/;        my $local_name = $rel_name;        if( $rel_name =~ /\Q$ext\E$/i ){                $rel_name =~ s/\%\d+/ /g;                $rel_name =~ s/(.{35}).+/$1.../;                print(pack('A45', "[$rel_name]"), "  is being downloaded ... ");                my $s_time = q{};                my $e_time = q{};                my $flag = [];                for( 1..5 ){                        local $SIG{ALRM} = sub { die("timeout") };                        eval {                           alarm(2);                           $flag = [head($abs_name)];                           alarm(0);                        };                        next if $@ =~ m|timeout|;                        last if $@ !~ m|timeout|;                }                if( $flag->[0] ){                        $s_time = [gettimeofday];                        getstore($abs_name, $local_name);                        $e_time = tv_interval ($s_time, [gettimeofday]);                }                $e_time =  $e_time ? $e_time . " seconds" : 'less than 1/100 second';                print "timeout failure in $e_time seconds :(\n" and next if $@;                print "done in $e_time\n";        }}

Update: for example - download.pl 'http://10.10.0.100/show_file.php?id=F-S26-10410041' mp3 # or jpeg, or whatever

Closures are Easy in Perl (ruoso)

My today's CUFP won't have any code, just a huge Thanks to Perl for supporting closures.

Today I was dealing with some C code, this code was using dlopen to get some shared object and call some function to it. I couldn't change the API, but needed the called function of some specific plugin to behave differently according to some data I have only when getting the pointer to that function. I thought: well, a simple closure will solve the problem, but no... C doesn't support closures...

Fortunally, some guys at ##C at freenode helped me and pointed me to ffcaland I could find a way to solve my problem. But I'm still surprised by the fact this library is almost never used. Searching for reverse depends on the Debian archive, gnustep and gnustep libraries are the only packages to link against this library...

This made me think closure *is* a Cool Use For Perl...

daniel

Decisiveness for Gamers (Panda)

When all questions of space, time, matter and the nature of being have been resolved, only one question remains-"What game shall we play?"

The Perlmatic Automated Game Picker provides the ultimate gaming experience and for once there are no options to worry about.

This newly improved edition will pick a game for you to play based on your mood. So until PAGP 3.0 comes out, Have FUN!

use warnings;use strict;{my @HappyGamesAndThings = ("nfs", "nfsII", "With the PerlMonks", "Morrowind", "TES Constructor Set");my @SadGamesAndThings = qw(RedFactionII CCG RavenShield AGG);print "How has your day been? (Answer 'good or 'bad').\n";my $mood = ;chomp $mood;if ("bad" eq lc ($mood))   {   my $randgame = $SadGamesAndThings [rand (@SadGamesAndThings)];   print "You should play:";   print $randgame;   }if ("good" eq lc ($mood))   {   my $randgame = $HappyGamesAndThings [rand (@HappyGamesAndThings)];   print "You should play: ";   print $randgame;   }   if (lc ($mood) ne "bad" and lc ($mood) ne "good")   {   print "Error, please re-type answer. \n";   redo   }}exit;

Please feel free to substitute your own games, use this wisely, and you will never have to make a decision again, well, almost.

Perl test - Make sure all perl files will compile (skx)

I've had this code in one of my projects for a while, but after reading [id://506585] and point 2 in particular "Everything has an automated test that, at the bare minimum, verifies that it will compile." I figured it was worth sharing.

The code is designed to be dropped into a test/ directory which "make test" will then run.

#!/usr/bin/perl -w##  Test that every perl file we have passes the syntax check.## Steve# --# $Id: perl-syntax.t,v 1.2 2006/06/13 13:26:00 steve Exp $use strict;use File::Find;use Test::More qw( no_plan );##  Find all the files beneath the current directory,# and call 'checkFile' with the name.#find( { wanted => \&checkFile, no_chdir => 1 }, '.' );##  Check a file.##  If this is a perl file then call "perl -c $name", otherwise# return#sub checkFile{    # The file.    my $file = $File::Find::name;    # We don't care about directories    return if ( ! -f $file );    # `modules.sh` is a false positive.    return if ( $file =~ /modules.sh$/ );    # See if it is a perl file.    my $isPerl = 0;    # Read the file.    open( INPUT, "<", $file );    foreach my $line (  )    {        if ( ( $line =~ /\/usr\/bin\/perl/ ) ||             ( $line =~ /\/usr\/local\/bin\/perl/ ) )        {            $isPerl = 1;        }    }    close( INPUT );    #    #  Return if it wasn't a perl file.    #    return if ( ! $isPerl );    #    #  Now run 'perl -c $file' to see if we pass the syntax    # check    #    my $retval = system( "perl -c $file 2>/dev/null >/dev/null" );    is( $retval, 0, "Perl file passes our syntax check: $file" );}

Steve
--

Google Earth Monks - Part II (The Code) (McDarren)

Greetings!

This is the "final" (..heh) version of the code that's used to generate the Google Earth KMZ files referred to in [id://558846]. It's presented here partly for posterity, and partly to elicit some feedback and (hopefully) some suggestions for improvement.

For some background, read the [id://558846|original thread], or visit the "googlemonks" [http://mcdarren.perlmonk.org/googlemonks/|homepage].

Note: I've posted the code here in CUFP (rather than in the original thread) after seeking advice in the CB.

Edit: s/illicit/elicit/ (thanks, [GrandFather])

#!/usr/bin/perl -w## pmgoogle.pl# Generates compressed KMZ (Google Earth) files# with placemarks for Perlmonks monks# See: earth.google.com## Darren - July 2006use strict;use XML::Simple;use LWP::UserAgent;use Storable;use Time::HiRes qw( time );my $start = time();say("$0 started at ", scalar localtime($start));# Where everything livesmy $monkfile = '/home/mcdarren/scripts/monks.store';my $kmlfile = '/home/mcdarren/temp.kml';my $www_dir = '/home/mcdarren/var/www/googlemonks';my $palette_url = 'http://mcdarren.perlmonk.org/googlemonks/img/monk-palette.png';my $monks;  # hashref$|++;# Uncomment this for testing# Avoids re-fetching the data#if (! -f $monkfile) {    # Fetch and parse the XML from tinymicros    $monks = get_monk_data();    store $monks, $monkfile;#}$monks = retrieve($monkfile)    or die "Could not retrieve $monkfile:$!\n";# A pretty lousy attempt at abstraction :/my %types = (    by_level    => {        desc        => 'By Level',        outfile     => 'perlmonks_by_level.kmz',        },    by_name     => {        desc        => 'By Monk',        outfile     => 'perlmonks_by_monk.kmz',        });my @levels = qw(    Initiate Novice Acolyte Sexton    Beadle Scribe Monk Pilgrim    Friar Hermit Chaplain Deacon    Curate Priest Vicar Parson    Prior Monsignor Abbot Canon    Chancellor Bishop Archbishop Cardinal    Sage Saint Apostle Pope    );# Create a reference to a LoL,# which represents xy offsets to each of the# icons on the palette image# The palette consists of 28 icons in a 7x4 gridmy $xy_data = get_xy();my @t = time();print "Writing and compressing output files...";for (keys %types) {    open OUT, ">", $kmlfile        or die "Could not open $kmlfile:$!\n";    my $kml = build_kml($monks, $_);    print OUT $kml;    close OUT;    write_zip($kmlfile, "$www_dir/$types{$_}{outfile}");}$t[1] = time();say("done (", formatted_time_diff(@t), " secs)");my $end = time();say("Total run time ", formatted_time_diff($start, $end), " secs");say("Total monks: ", scalar keys %{$monks->{monk}});exit;##################################### End of main - subs below####################################sub say {    # Perl Hacks #86    print @_, "\n";}sub formatted_time_diff {    return sprintf("%.2f", $_[1]-$_[0])}sub by_level {    return $monks->{monk}{$b}{level} <=> $monks->{monk}{$a}{level}    || lc($a) cmp lc($b);}sub by_name {    return lc($a) cmp lc($b);}sub write_zip {    my ($infile, $outfile) = @_;    use Archive::Zip qw( :ERROR_CODES :CONSTANTS );    my $zip = Archive::Zip->new();    my $member = $zip->addFile($infile);    return undef unless $zip->writeToFileNamed($outfile) == AZ_OK;}sub build_kml {    # This whole subroutine is pretty fugly    # I really wanted to do it without an if/elsif,    # but I couldn't figure out how    my $ref = shift;    my $type = shift;    my $kml = qq(                        Perl Monks - $types{$type}{desc}        1);    if ($type eq 'by_level') {        my $level = 28;        $kml .= qq(Level $level - Pope0\n);        for my $id (sort by_level keys %{$ref->{monk}}) {            my $mlevel = $ref->{monk}{$id}{level};            if ($mlevel < $level) {                $level = $mlevel;                my $level_name = $levels[$level-1];                $kml .= qq(Level $level - $level_name0\n);            }            $kml .= mk_placemark($id,$mlevel);        }        $kml .= q();    }    elsif ($type eq 'by_name') {        my @monks = sort by_name keys %{$ref->{monk}};        my $nummonks = scalar @monks;        my $mpf = 39; # monks-per-folder        my $start = 0;        while ($start < $nummonks) {            my $first = lc(substr($monks[$start],0,2));            my $last = defined $monks[$start+$mpf]                     ? lc(substr($monks[$start+$mpf],0,2))                     : lc(substr($monks[-1],0,2));            $kml .= qq(Monks $first-$last0\n);            MONK:            for my $cnt ($start .. $start+$mpf) {                last MONK if !$monks[$cnt];                my $monk = $monks[$cnt];                my $mlevel = $ref->{monk}{$monk}{level};                $kml .= mk_placemark($monk,$mlevel);            }            $start += ($mpf + 1);            $kml .= q();        }    }    $kml .= q();    return $kml;}sub mk_placemark {    my $id = shift;    my $mlevel = shift;    my $p;    $p = qq(                                Experience: $monks->{monk}{$id}{xp}
            Writeups: $monks->{monk}{$id}{writeups}
            User Since: $monks->{monk}{$id}{since}
            http://www.perlmonks.org/?node_id=$monks->{monk}{$id}{id}            ]]>                        $id                    $monks->{monk}{$id}{location}{longitude}            $monks->{monk}{$id}{location}{latitude}            0            10000            0            0                                    $monks->{monk}{$id}{location}{longitude},$monks->{monk}{$id}{location}{latitude},0                );    return $p;}sub get_xy {    # This returns an AoA, which represents xy-offsets    # to each of the monk level icons on the image palette    my @xy;    for my $y (qw(96 64 32 0)) {        for my $x (qw(0 32 64 96 128 160 192)) {            push @xy, [ $x, $y ];        }    }    return \@xy;}sub get_monk_data {    my $monk_url = 'http://tinymicros.com/pm/monks.xml';    my @t = time();    print "Fetching data....";    my $ua = LWP::UserAgent->new();    my $req = HTTP::Request->new(GET=>"$monk_url");    my $result = $ua->request($req);    return 0 if !$result->is_success;    my $content = $result->content;    $t[1] = time();    say("done (", formatted_time_diff(@t), " secs)");    print "Parsing XML....";    my $monks = XMLin($content, Cache => 'storable');    $t[2] = time();    say("done (", formatted_time_diff(@t[1,2]), " secs)");    return $monks;}

Cheers,
Darren :)

Image combinations (jimt)

I wrote this up a few years ago, figure I might as well share it on here. It will create a PNG which contains all of the possible image combinations for the given set of parameters. So you specify a 2x3 pixel image with 5 possible colors (or whatever) and you'll get a huge image output the other end that contains all the variations.

The fun thing about image generation in this manner is that you can theoretically generate photographs of anything this way, if you had sufficient time and horsepower. Of course, a 10x10 pixel image with 10 colors has one googol possible combinations, so it quickly becomes intractable.

I have a more thorough write up here: http://www.jimandkoka.com/

#!/usr/bin/perl# Copyright and (c) 2002, 2003 Jim Thomason. jim@jimandkoka.com# http://www.jimandkoka.com# distributed under the artistic license or something## Note that this software requires the GD module, available from CPAN# http://search.cpan.org/## Usage - ./imagemaker.pl width height colors ?countonly? > some.png## width is the image width# height is the image height# colors is the number of possible colors allowed in the image# countonly is an optional param. If passed, the program will just #   print out a count of the number of combinations and then quit.#use strict;use warnings;use GD;our $VERSION = 2.00;#snag our command line argumentsmy $w  = shift @ARGV or die 'Cannot run w/o width';my $h  = shift @ARGV or die 'Cannot run w/o height';my $c  = shift @ARGV or die 'Cannot run w/o colors';my $s  = shift @ARGV || 1;my $countonly = shift @ARGV || 0;die "Cannot support more than 7 colors" if $c > 7 && ! $countonly;#find out the number of pixel combinationsmy $combos =  $c  ** ($w * $h);#find out the unscaled area of each image setmy $unscaled_each_area = $w * $h;#find out the area of each image set, taking the scaling into accountmy $each_area = $unscaled_each_area * $s * $s;#calculate how many we'd like to display per line.my $perline = int sqrt $combos;#round up if it's not an even number.$perline += 1 unless $perline ** 2 == $combos;# calculate the actual width and height of the image we're going # to generate. Each image will take up $w * $s pixels width + # $s pixels padding to its right but, the last image doesn't # require padding, so we subtract off its padding amount## ditto for the heightmy $width  = $perline * ($w * $s + $s) - $s;my $height  = $perline * ($h * $s + $s) - $s;#display some numbersprint STDERR "for a $w x $h image @ $c colors, "  . "there are $combos combinations\n";#and bow out if we're just countingexit if $countonly;#warn them about how big this thing is gonna getprint STDERR "your output will be $width x $height\n";#create our new imagemy $im = new GD::Image($width,$height);# allocate some colors## This is silly, we need to allocate red first, so we get that as # the background for our image. Bleh.my $red    = $im->colorAllocate(255,0,0);my $green  = $im->colorAllocate(0,255,0);my $blue  = $im->colorAllocate(0,0,255);my $cyan  = $im->colorAllocate(0,255,255);my $magenta  = $im->colorAllocate(255,0,255);my $yellow  = $im->colorAllocate(0,255,255);my $black  = $im->colorAllocate(0,0,0);my $white  = $im->colorAllocate(255,255,255);# this is the order we want to use the colorsmy @colors= ($white, $black, $green, $blue, $cyan, $magenta, $yellow);#our padding starts at 0.my $xpad = 0;my $ypad = 0;# and we're off to the races.## It's pretty easy. iterate through all the numbers from# 0 to the number of combinations we have. At each number,# convert it from base 10 to the number base of the number# of colors we have. So a B/W image is 2 colors is base 2.# a black, white, and green image is 3 colors, is base 3# and so on.## With each base(x) number, each digit corresponds to a color# value in our colors array. So use that color value to fill# in the pixel at the appropriate square.for (my $num = 0; $num < $combos; $num++) {  # convert to the appropriate number base  my @num = basemaster($num, 10, $c);    # now, if we have fewer digits in the new base than we'll have  # pixels in the image, zero pad the number until we reach the  # appropriate size.  if (@num < $unscaled_each_area) {    @num = ((0) x ($unscaled_each_area - @num), @num);  };  {    #keep track of which pixel we're on.    my $pix    = 0;    #we'll start drawing this image at the appropriate xpad    # and ypad values    my $x    = $xpad;    my $y    = $ypad;        #as long as we have pixels left to draw...    while ($pix < $unscaled_each_area) {            #grab our next color      my $col = $colors[$num[$pix] || 0];            #increment our pixel count      # (yeah, I could've done the inc up in that last line,      # but I didn't want it to get lost in the muck)      $pix++;      # and draw our pixel, scaled appropriately.      # GD is a little silly, the arguments are the upper left      # coordinates of the upper left pixel and the upper left      # coordinates of the lower right pixel. So, to actually      # set the lower right pixel to where we want, we need to back      # up by one pixel to get it positioned properly      $im->filledRectangle($x, $y, $x + $s - 1, $y + $s - 1, $col);            # slide our y coordinate over by the scale value      $y += $s;            # okay, if $pix % $h == 0, then we're at the end of the row, so       # we'll need to drop to the next row by incrementing the xpad,      # and go back to the first column by resetting the ypad.      unless ($pix % $h) {        $xpad += $s;        $x = $xpad;        $y = $ypad;      };      };  };  # okay, we've now finished drawing out the individual image, so  # we're going to move onto the next in the sequence. So we're going  # to slide our xpadding over by $s pixels to be  # ready to start the next one. FYI, this is starting the image to  # the right of the one just drawn  $xpad += $s;    # the one exception is if we've reached the perline limit. In that  # case, we're at the end of the row, so we'll reset our xpad back  # to zero and increment our ypad instead by the appropriate amount  unless (($num + 1) % $perline) {    $ypad += $h * $s + $s;    $xpad = 0;  };};#be nice and binmode it. Stupid dos.binmode STDOUT;#printprint $im->png;exit;  #and we're done!# basemaster takes 3 arguments.# the number you're converting, the base you're converting from, and# the base you're converting to# Always returns an array of numbers in order, higher digits in the# front, lower at the back.# # so basemaster(13, 10, 2) returns (1, 1, 0, 1)sub basemaster {  my $num    = shift || return 0;  my $from  = shift;  my $to    = shift;  # we allow it to accept a comma delimited number to allow for higher  # bases  my @num = reverse $num =~ /,/ ? split(/,/, $num) : split(//, $num);    # starting power is 0  my $pow = 0;  # and we don't know it in base10  my $base10 = undef;  # if we're converting from base ten, then do it.  if ($from != 10) {    foreach my $digit (@num){      die "Invalid number -- $digit >= $from" if $digit >= $from;      $base10 += $digit * $from ** $pow++;    };  }  # otherwise, we have a base 10 number, so there's no work to do.  else {    $base10 = $num;  };    #reset our power to 1  $pow = 1;  # and find the highest power of the number in the base we're  # converting to  $pow++ while $to ** $pow <= $base10;  #we'll return our array here.  my @return = ();  #convert to the new base  while ($pow >= 0){    push @return, int ($base10 / $to ** $pow);    $base10 %= $to ** $pow--;  };    #trash leading zeroes  shift @return while $return[0] == 0;  #and we are done.  return @return;};

Google Checkout? (qbxk)

Well, I notice the new Google Checkout has now just plunked onto the scene, and their [http://code.google.com/apis/checkout/samplecode.html|code samples] page has a conspicuous absence of perl. The [http://code.google.com/apis/checkout/developer/index.html|developer docs] appear to be quite thorough, seems like it's just a bunch of http POSTs using a well structured XML schema. CPAN turns up missing the Google::Checkout module, so I may get to it, but the project I'd need it for is starting some months from now...

Off the top of my head, you'd want the full CRUD interface for the whole object model they defined, I think, a la

   my $cart = Google::Checkout::Cart;   $cart->add_item(        name => 'Bill',       description => 'a pal',       price => 'priceless', quantity => 2   );   $cart->post(       merchant_auth_encoded =>                 q[MTIzNDU2Nzg5MDpIc1lYRm9aZkhBcXlMY0NSWWVIOHFR]   );

but personally, I'd (probably) never use that, instead opting for the magical "hash to google checkout" function (..Google::Checkout::from_hash(%args) ? )

maybe it's not too bad of an idea to implement that function as a wrapper to XML::Simple with the right config, and running the result against google's schema for verification? Then doing the post as per google 's spec.
Anyhow, sorry I've got no code, I'm probably not qualified to write such an "industrial strength" module yet (don't make mistakes with banking code!), but I'd like to help if any were interested in leading the way. Or at least hear about your progress. Thanks!

Edit: g0n - removed readmore tags

It's not what you look like, when you're doin' what youre doin'.
It's what youre doin' when youre doin' what you look like youre doin'!
- Charles Wright & the Watts 103rd Street Rhythm Band, Express yourself

Measuring MySQL resources consumption on Linux (gmax)

This script finds how much a MySQL process is using on a Linux box. It can be used, with slight modification, to measure any other threading process. Just find a way of passing a PID to the script.

For a detailed explanation of what this script does, you can read this article.

#!/usr/bin/perluse strict;                       use warnings;                     use English qw( -no_match_vars ); use Getopt::Long;                 use Data::Dumper;                our $VERSION = q{1.0};$ENV{ 'PATH' } = '~/bin:' . $ENV{ 'PATH' };my $DEBUG = $ENV{ 'DEBUG' } || 0;## The program options, for command line processing#my %parse_options = (    output_format   => {             value => 'plain',             parse => 'f|format=s',             so    => 1,             help  => [                         'The output format. {plain|perl} (Default: plain)'                      ],        },    mysql_user      => {             value =>  undef,             parse =>  'u|user=s',             so    =>  2,             help  => [                         'The user name used with mysql client. (Default: none)'                      ],        },    mysql_password  => {             value =>  undef,             parse =>  'p|password=s',             so    =>  3,             help  => [                         'The password used with mysql client. (Default: none)'                      ],        },    mysql_client    => {             value =>  'mysql',             parse =>  'm|mysql=s',             so    =>  4,             help  => [                         'The mysql client. You may add options after the file name (default: "mysql")'                      ],        },    print_pstree    => {             value =>  0,             parse =>  'pstree',             so    =>  5,             help  => [                         'Print a Process tree after the normal output. (Default: No)'                      ],        },    help      => {             value =>  0,             parse =>  'help',             so    =>  6,             help  => [                         'Display this help'                      ],        },);my %options = map { $_ , $parse_options{$_}{'value'}}  keys %parse_options;GetOptions (    map { $parse_options{ $_ }{ 'parse' }, \$options{ $_ } }        grep { $parse_options{ $_ }{ 'parse' }}        keys %parse_options) or get_help( q{!} );get_help() if $options{'help'};## Check if we are running under Linux.# This method of collecting performance data does not# work under other operating systems#unless ($OSNAME =~ /linux/i) {    die "This program can only work with a GNU/Linux OS\n";}## The client used to connect to the database server.# You can add appropriate username and password with# the options -u and -p, unless you have a .my.cnf# file in your home directory#my $MYSQL_CLIENT = sprintf "%s %s %s",        $options{ 'mysql_client' },        $options{ 'mysql_user' } ? " -u $options{ 'mysql_user' } " : q{},        $options{ 'mysql_password' } ? " -p$options{ 'mysql_password' } " : q{};## Get the hostname, so your information will be tagged# to the appropriate host, if you collect this data from# several servers.#my $hostname = get_from_shell(q{ hostname });## Check if mysqld is running#get_from_shell(q{ pgrep mysqld }, 1)    or die "mysqld is not running\n";## Get the PID file name#my $pid_info = get_from_shell(        qq($MYSQL_CLIENT -N -e 'show variables like "pid_file"') );$pid_info or die "unable to get mysqld pid file\n";my ($pid_file) =  $pid_info =~ m/            ^          # start of string            \s*        # blanks (if any)            \w+        # skip the first word            \s*        # ignore any spaces            (\S+)      # get a chunk of non-blanks (the file name)            /x;## Get mysqld PID#my ($mysqld_pid) =  file_slurp( $pid_file );unless ($mysqld_pid        and ( $mysqld_pid =~ m/                ^     # start of string                \d+   # all numeric                $     # end of string                /x ) ){    die "could not get a valid PID\n";}my $statinfo = get_pid_stats($mysqld_pid);## Get the user (ID and name) under which mysqld is running#my $UID =  $statinfo->{ 'Uid' };my $USER = getpwuid( $UID );## Recursively search for mysqld_safe PID.# This loop stops when either a process named mysqlmanager, or mysqld_safe,# or safe_mysqld is found (MySQL 3.23 uses a different name)# or a parent with PID 1 is found (this should account for a starting# script with a non-standard name)# You may get you an incorrect result if you started mysqld manually# from the command line.#while ( !(          ($statinfo->{ 'PPid' } == 1)        # parent is /sbin/init          or ( $statinfo->{ 'Name' } =~ /                    ^               # start of string                    (?:             # name is one of the following                    safe_mysqld     # ... the standard name                    | mysqld_safe   # ... or the old name                    | mysqlmanager  # ... or the new manager                    )               # end of group                    $               # end of string                    /x) )){    $statinfo = get_pid_stats($statinfo->{ 'PPid' });}my $mysqldsafe_pid = $statinfo->{ 'Pid' };my %INFO = (        hostname    => $hostname,        mysqld_pid  => $mysqld_pid,        pid_file    => $pid_file,        user        => { name => $USER, UID => $UID },        mysqld_safe => $mysqldsafe_pid,);## Get information about CPU and memory usage# for the mysqld process#my $process_list = get_from_shell ( "ps -o pcpu,pmem,vsz,rss,dsiz $mysqld_pid" );## Get the CPU load for all the processes under mysqld_safe# and calculate the average#my $pstree = `pstree -p $mysqldsafe_pid`;my $total_cpu_load = 0;my $active_pid_num = 0;my @pids = $pstree =~ m/\( (\d+) \)/xg;my $pid_num = @pids;my $plist = get_from_shell( "ps -o pcpu @pids", 1);## Get the load for each PID#while ( $plist =~ /^\s* (\d+\.\d+)/gmx) {    $total_cpu_load += $1;    $active_pid_num++;}## calculate the average, avoiding any division by zero traps#my $avg_cpu_load = $total_cpu_load ? $total_cpu_load / $active_pid_num : 0 ;## Extract process details#if ( $process_list =~ m/        \s* (\d+\.\d+) # percentage cpu        \s+ (\d+\.\d+) # percentage memory        \s+ (\d+)      # virtual memory size        \s+ (\d+)      # resident set size        \s+ (\d+)      # data size        /x){    $INFO{ 'mysql_load' } = {        avg_perc_cpu    => $avg_cpu_load,        perc_memory     => $2,        vmem_size       => $3,        res_set_size    => $4,        data_size       => $5,        pids            => $pid_num,        active_pids     => $active_pid_num,    };}## Get the global server load info#my ($server_load) = file_slurp( '/proc/loadavg' );if ( $server_load =~ m/        \s* (\d+\.\d+) # cpu load average last  5 minutes        \s+ (\d+\.\d+) # cpu load average last 10 minutes        \s+ (\d+\.\d+) # cpu load average last 15 minutes        /x ){    $INFO{ 'server_load' } = {        cpu5    => $1,        cpu10   => $2,        cpu15   => $3,    };}## Get the number of open files for the mysqld process.# Notice that you won't be able to access this list as# a normal user if mysqld_safe was launched by root.#my @file_descriptors = glob "/proc/$mysqld_pid/fd/*";$INFO{ 'open_files' } = scalar @file_descriptors;if ($options{ 'output_format' } eq 'perl') {    perl_output( \%INFO );}elsif ($options{ 'output_format' } eq 'plain') {    plain_output(\%INFO);}else {    die "unrecognized output format ($options{ 'output_format' })\n";}if ($options{ 'print_pstree' }) {    print "\n", $pstree;}## subs follow### the plain text report#sub plain_output {    my ($info) = @_;    my $template = <<'END_PLAIN';    hostname         : %10s    mysql_pid        : %10d    pid_file         : %s    mysqld_safe      : %10d    open_files       : %10d    user    ----        name         : %10s        UID          : %10d    mysql_load    ----------        avg_perc_cpu : %10.2f        perc_memory  : %10.2f        vmem_size    : %10d        res_set_size : %10d        data_size    : %10d        pids         : %10d        active_pids  : %10d    server_load    -----------        cpu5         : %10.2f        cpu10        : %10.2f        cpu15        : %10.2fEND_PLAIN    print credits(), "\n";    printf $template,        @$info{qw( hostname mysqld_pid pid_file mysqld_safe open_files ) },        $info->{ 'user' }{ 'name' },        $info->{ 'user' }{ 'UID' },        $info->{ 'mysql_load' }{ 'avg_perc_cpu' },        $info->{ 'mysql_load' }{ 'perc_memory' },        $info->{ 'mysql_load' }{ 'vmem_size' },        $info->{ 'mysql_load' }{ 'res_set_size' },        $info->{ 'mysql_load' }{ 'data_size' },        $info->{ 'mysql_load' }{ 'pids' },        $info->{ 'mysql_load' }{ 'active_pids' },        $info->{ 'server_load' }{ 'cpu5' },        $info->{ 'server_load' }{ 'cpu10' },        $info->{ 'server_load' }{ 'cpu15' };}## the report in Perl format.# Useful for loading it from another program, or to# pipe it (see help for examples)#sub perl_output {    my ($info) = @_;    print Data::Dumper->Dump( [ $info ], ['INFO'] );}## reads the file /proc/PID/status# and returns a hash with its values#sub get_pid_stats {    my ($pid) = @_;    my %stat_info;    my @pid_status = file_slurp ( "/proc/$pid/status" );    for my $line (@pid_status) {        my ($key, $value) = $line =~ m/                    ^       # start of string                    (\w+)   # first word                    :       # a colon                    \s+     # skip any blanks                    (\S+)   # the first chunk of non-blank characters                    /x ;        next unless $key;        $stat_info{$key} = $value;    }    return \%stat_info;}## reads a file and returns an array# (one element for each line)#sub file_slurp {    my ($filename) = @_;    print "reading $filename\n" if $DEBUG;    $filename        or die "can't open a empty filename\n";    open my $FD, q{<}, $filename        or die "can't open $filename ($ERRNO)\n";    my @contents = <$FD>;    chomp @contents;    close $FD;    return @contents;}## executes a shell command# and returns its output#sub get_from_shell {    my ($cmd, $ignore_error) = @_;    my $result;    print "executing $cmd\n" if $DEBUG >= 1;    $result = qx{$cmd} ;    if ( $CHILD_ERROR and ! $ignore_error ) {        warn "'$cmd' returned error $CHILD_ERROR.\n";    }    chomp $result;    print "$result\n" if $DEBUG >= 2;    return $result;}## Help for this program#sub get_help {    my ($msg) = @_;    my $HELP_MSG = q{};    for my $op (                sort { $parse_options{$a}{ 'so' } <=> $parse_options{$b}{ 'so' } }                grep { $parse_options{$_}{ 'parse' }}  keys %parse_options )    {        my $param =  $parse_options{$op}{ 'parse' };        my $param_str = q{    };        my ($short, $long ) = $param =~ / (?: (\w) \| )? (\S+) /x;        if ($short) {            $param_str .= q{-} . $short . q{ };        }        $long =~ s/ = s \@? / = name/x;        $long =~ s/ = i / = number/x;        $param_str .= q{--} . $long;        $param_str .= (q{ } x (40 - length($param_str)) );        my $text_items = $parse_options{$op}{ 'help' };        for my $titem (@{$text_items}) {            $HELP_MSG .= $param_str . $titem . "\n";            $param_str = q{ } x 40;        }        if (@{$text_items} > 1) {            $HELP_MSG .= "\n";        }        # $HELP_MSG .= "\n";    }    if ($msg) {        warn "[***] $msg\n\n";    }    print credits(),"\n",        "syntax: $PROGRAM_NAME [options] \n",        $HELP_MSG;    print "\n    You may get output in other formats, by piping the 'perl' output\n",          "    for example: \n    ",          $PROGRAM_NAME,          q{ -f perl | perl -MYAML -0ne 'eval $_; print Dump $INFO'},          "\n",          "    or: \n    ",          $PROGRAM_NAME,          q{ -f perl | perl -MXML::Simple -0ne 'eval $_; print XMLout $INFO, AttrIndent=>1'},          "\n\n";    if ($msg) {        exit 1;    }    else {        exit 0;    }}## Who made it#sub credits {    my $CREDITS =          qq(    The MySQL Resource Locator,  version $VERSION\n)        . qq(    (C) 2006 Giuseppe Maxia, Stardata s.r.l.\n);    return $CREDITS;}

 _  _ _  _  (_|| | |(_|>< _|

perror.pl (Hue-Bond)

At work I learned about a tool called perror, that showed the literal string corresponding to a numeric UNIX error. So if you get a message from a program that says "errno 13", you can run perror to easily translate that into "Permission denied". When I went to install it at home, I found out that it's in Debian package mysql-server (!). So I made my own version:

foreach (grep /^\d+$/, @ARGV) {  $! = $_;  print "$_: $!";}

Which can be turned into a oneliner:

$ perl -le'print "$_: ", $! = $_ foreach grep /^\d+$/, @ARGV' 13 20   ## It even respects your locale settings13: Permiso denegado20: No es un directorio

--
David Serrano

quotes from the great master (sh1tn)

# random Larry Wall quote# quotes can be taken from:# http://www.perl.com/CPAN/misc/lwall-quotes.txt.gz# Sun Jul  2 15:25:40use File::Slurp;$_      = read_file(q{lwall-quotes.txt});$quote  = [];push @$quote, $2 while /(\%\%)(.+?)\1/gs;print $quote->[rand(@$quote)], $/

web_diff.pl (ciderpunx)

Its a simple script to diff the text on web pages.

Someone used the phrase somewhere on the perlmonks site which made me think it'd be a handy thing to have - thanks to them.

#!/usr/bin/perl -wuse strict;use LWP::Simple;use Text::Diff;use HTML::Strip;require 5.008_000;my $STORE="/home/charlie/diffs";die ("Usage: $0 ") unless ($#ARGV==0);my $url=$ARGV[0];# 'nice' URLmy $n_url=$url;$n_url=~s/^http:\/\///;$n_url=~s/\//_/g;my $store_as = (-e "$STORE/$n_url" )        ? "$STORE/$n_url.new"        : "$STORE/$n_url";if (is_success(getstore($url,$store_as)))  {        unless ($store_as eq "$STORE/$url") {                my $diff = diff $store_as, "$STORE/$n_url";                print $diff . "\n";                rename $store_as, "$STORE/$n_url";        }}else {  warn "Storing $store_as failed. Life sucks."  }__END__=head1 NAMEweb_diff.pl  =head2 VERSION0.1=head1 SYNOPSISdiff text from a page retrieved off interweb and page stored locally=head1 DESCRIPTIONRetrieve a pageIf we have a previously stored local copy,        compare retrieved and local page        If they are not identical                strip html from them                do a diffIf we have no locally stored page, store retrieved page locally=head2 OPTIONS=over=item  CThis isn't sanitized in properly, this code is not for use by peopleyou don't trust implicitly :-)=back=head1 REQUIREMENTS=over=item Perl >= 5.8.0 (not tested on earlier versions)=item HTML::Strip=item Text::Diff=item LWP::Simple=back=head1 COPYRIGHT AND LICENCE               Copyright (C)2006  Charlie Harvey This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA. Also available on line: http://www.gnu.org/copyleft/gpl.html=head1 SEE ALSO=cut

--
charlieharvey.org.uk

Regex Tool (Yunus)

Hi everyone!New tool to build Perl-compatible Regex (mine actually)http://www.geocities.com/unouse_80/app/builder.htmlI would like to have some comments/feedback.TQ

Play and win the word morph game with the help of Perl :) (Ieronim)

There is a popular word game caled "[lucky://Word Morph]". In this game you need to go from one word to another by modifying one letter in each word to form a new word. for example (head to foot):

HEADbeadbeatboatbootFOOT

One of my English-speaking friends told me about this game. As my English is quite bad, I could not play this game fairly; but i wrote a perl script to solve the problem :)

This command-line tool finds a shortest way from one word to another using the given dictionary. I used the 2of12 dictonary from the 12Dicts project ([href://http://wordlist.sourceforge.net]), but any newline-character-delimited wordlist of any language can be used.

I don't know how 'cool' is this usage, but i mean that it is quite interesting :)

It is of course not ideal, so I am open for any suggestions :)

#!/usr/bin/perluse warnings;use strict;my $dict  = '2of12.txt';die < The program finds a way from one word to other, like this:% transform.pl love shitlove-lose-lost-loot-soot-shot-shitHELPmy $left  =  shift(@ARGV) || 'love';my $right =  shift(@ARGV) || 'shit';for ($left, $right) {    $_ = lc;    tr/A-Za-z//cd;}die "the length of given words is not equal!\n" if length($left) != length $right;open DICT, $dict or die "Cannot open dictionary $dict: $!";my @words;while () {    chomp;    push @words, $_ if length == length $left;}eval {    my @ways = ([transform($left, $right, \@words)], [reverse transform($right, $left, \@words)]);    if (@{$ways[0]} != @{$ways[1]}) {        printway( @{$ways[0]} > @{$ways[1]} ? $ways[0] : $ways[1] );    }    elsif (grep {$ways[0]->[$_] ne $ways[1]->[$_]} (0..(scalar(@{$ways[0]}) - 1) )) {        printway($ways[0]);        printway($ways[1]);    }    else {printway($ways[0])}    1;} or print $@;sub transform {    my $left = shift;    my $right = shift;    my @words = @{+shift};    my (@left, %left, @right, %right);      # @left and @right- arrays containing word relation trees: ([foo], [0, foe], [0, fou], [0, 1, fie] ...)                                            # %left and %right - indices containing word offsets in arrays @left and @right    $left[0] = [$left];    $right[0] = [$right];    my $leftstart  = 0;    my $rightstart = 0;    my @way;    my (%leftstarts, %rightstarts);    SEARCH:     for (;;) {        my @left_ids = $leftstart..$#left;                              # choose array of indices of new words        $leftstart = $#left;        die "Cannot solve! Bad word '$left' :(\n" if $leftstarts{$leftstart}++ >2;  # finish search if the way could not be found        for my $id (@left_ids) {                                        # come through all new words            my @prefix   = @{$left[$id]};            my @patterns = wordpattern(pop @prefix);                    # build patterns to find related words: foo -> (/^.oo$/,/^f.o$/, /^fo.$/)            push @prefix, $id;            foreach my $word (@words) {                next if $left{$word};                                   # skip words which are already in the tree                if (scalar grep {$word =~ /$_/} @patterns) {            # if matched...                     push @left, [@prefix, $word];                    $left{$word} = $#left;                              # add new word to array and index                    #print join " ", @{$left[-1]}, "\n"; #debugging                    if ( defined(my $r_id = $right{$word}) ) {          # and check if the word appears in right index. if yes...                        my @end = reverse(print_rel($r_id, \@right));                        shift @end;                        @way = (print_rel($#left, \@left), @end);       # build the way between the words                        last SEARCH;                                    # and finish the search                    }                 }            }        }        my @right_ids = $rightstart..$#right;                           # all the same :) the tree is build from both ends to speed up the process        $rightstart = $#right;        die "Cannot solve! Bad word '$right' :(\n" if $rightstarts{$rightstart}++ > 2;        for my $id (@right_ids) {      # build right relational table            my @prefix   = @{$right[$id]};            my @patterns = wordpattern(pop @prefix);            push @prefix, $id;            foreach my $word (@words) {                next if $right{$word};                if (scalar grep {$word =~ /$_/} @patterns) {                    push @right, [@prefix, $word];                    $right{$word} = $#right;                    # print join " ", @{$right[-1]}, "\n"; #debugging                    if ( defined(my $l_id = $left{$word}) ) {                        my @end = reverse print_rel($#right, \@right);                        shift @end;                        @way = (print_rel($l_id, \@left), @end);                        last SEARCH;                    }                 }            }        }    }    return @way;}sub wordpattern {    my $word = shift;    my @patterns;    for my $i (0..(length($word)-1)) {        substr((my $pat = $word), $i, 1) = '.';        push @patterns, qr/^$pat$/;    }    return @patterns;}sub print_rel {    my $id = shift;    my $ary = shift;    my @line;    my @rel = @{$ary->[$id]};    push @line, (pop @rel);    foreach my $ref_id (reverse @rel) {        unshift @line, $ary->[$ref_id]->[-1];    }    return wantarray ? @line : join "\n", @line, "";}sub printway {    my @way = @{+shift};    print join "-", @way;    print "\n";}

String eval is cool (DrHyde)

Recently on one of my mailing lists, someone wanted some code to translate CIDR-style ip.add.re.ss/bits descriptions into the more traditional network address and netmask pairs. Another list member posted some perl code which was basically 30 lines of C but with extra $ signs sprinkled throughout. My version was (stripped of data validity checking etc) this:

my ($addr, $bits, $network, $mask) = split("/", $cidr);$network = $network * 256 + $_ foreach(split(/\./, $addr);$mask = eval '0b'.('1' x $bits).('0' x (32 - $bits));print int2ip($network & $mask)."\t".int2ip($mask)."\n";

(the int2ip function was the same as that the original poster had used, so I don't bother reproducing it here)

The string eval - abhorred by many - meant I could avoid several lines of fairly opaque bit-banging and I think it's *very* clear what that line does, and it also makes it obvious how netmasks are related to the /bits in CIDR notation.

Sudoku Solver, and web interface. (JediWizard)

While I was bored the other day, I decided to see if I could come up with a way to programatically solve sudoku puzzles in perl. I have a sudoku game on my palm, and I wanted a program that could solve puzzles at all four difficulty levels. Although I was able to solve puzzles at the first three difficulty setting with little trouble, the "expert" level puzzle forced me to use an algorithm with which I am not satisfied. Below you will find my code.

Comments welcome.

If you know a better algorithm to relace my poorly named "level4" logic, I'd love to hear about it.

#!/usr/local/bin/perl -wuse strict;use CGI qw(:standard);print header();print "\n\nSudoku Solver\n";print "\nSudoku Solver
\n";my(%ParamHash) = ();foreach my $param (param()){$ParamHash{$param} = param($param);}if(exists($ParamHash{action}) && $ParamHash{action} eq 'solve'){my $board = Sudoku::Board->new();foreach my $sq (grep(/^sq/, keys %ParamHash)){next if($ParamHash{$sq} < 1);$sq=~m/(\d+)/;my $sqn = $1;print STDERR "$sqn $ParamHash{$sq}\n";$board->get_square($sqn)->assign_value($ParamHash{$sq});}&level1($board);print STDERR "Level 1 logic complete\n";if(! $board->is_solved){    print STDERR "Begining level 2 logic\n";    &level2($board);    &level1($board);}if(! $board->is_solved){    &level3($board);    &level2($board);    &level1($board);}if(! $board->is_solved){    &level4($board);    &level3($board);    &level2($board);    &level1($board);}# Display Puzzle print "\n";my $sqn = 0;for(my $r=1; $r<10; $r++){print "\n";for(my $i = 1; $i<10; $i++){my $sq = $board->get_square($sqn);print "";if(exists($sq->{value})){print $sq->{value};}else{print " ";}print "
\n";$sqn++;}print "
\n";}print "
\n";}else{print "\n";print <function incrimentSquare(field, square){var val = field.value;val++;if(val == 10){val = 0;square.innerHTML='';}else{square.innerHTML = val;}field.value = val;}EOFprint "\n";my $sqid=0;print "\n";for(my $r=1; $r<10; $r++){print "\n";for(my $i = 1; $i<10; $i++){print "";print "";print "
\n";$sqid++;}print "
\n";}print "
\n";print "\n";print "\n";print "\n";}print "\n\n\n";sub level1{    my $board = shift;    my $action = 1;    while($action){        $action = 0;        foreach my $offset (0 .. 80){            my $sq = $board->get_square($offset);            next if($sq->{value});            my(@ava) = $sq->available_values();            if(scalar(@ava) == 1){                $sq->assign_value($ava[0]);                $action++            }        }    }}sub level2{    my $board = shift;    my $action = 1;    INFI: while($action){        $action = 0;        my(@units) = ($board->get_rows, $board->get_columns, $board->get_cubes);        UNI: foreach my $unit (sort({$a->available_values <=> $b->available_values} @units)){            my(%ava) = $unit->get_squares_by_number();            my(@one) = grep({ scalar(@{ $ava{$_} }) == 1 } keys %ava);            if(scalar(@one)){                $action++;                foreach my $val (@one){                    if(! $ava{$val}[0]->assign_value($val)){                        print STDERR "Warning Assign Value Failed!\n";                    }                }                &level1($board);                last INFI if($board->is_solved());                next INFI;            }        }    }}sub level3{    my $board = shift;    my(@squares) = grep({scalar($_->available_values) < 3} $board->get_all_squares());    my(%table, %groups);    foreach my $sq (@squares){        push @{ $table{ join(';', $sq->available_values) } }, $sq;    }    foreach my $combo (grep({scalar(@{ $table{$_} }) > 1} keys %table)){        COMBO: for(my $si=0; $si<$#{ $table{$combo} }; $si++){            for(0 .. 2){                if($table{$combo}[$si]{groups}[$_] == $table{$combo}[($si+1)]{groups}[$_]){                    push @{ $groups{$combo} }, $table{$combo}[$si]{groups}[$_];                    last COMBO;                }            }        }    }    foreach my $cm (keys %groups){        my($num1, $num2) = split(/;/, $cm);        foreach my $gr (@{ $groups{$cm} }){            foreach my $sq ($gr->get_members()){                my(@left) = grep({$_ != $num1 && $_ != $num2} $sq->available_values);                if(scalar(@left) == 1){                    $sq->assign_value($left[0]);                }            }        }    }}sub level4{    my $board = shift;    my(@units) = sort({$a->available_values <=> $b->available_values} ($board->get_rows, $board->get_columns, $board->get_cubes));        foreach my $unit (@units){        foreach my $sq (grep({! exists($_->{value}) } $unit->get_members)){            my(@values) = $sq->available_values();            my(@groups) = @{ $sq->{groups} };            foreach my $val (@values){                my $gcc = 0;                GROUP: foreach my $gr (@groups){                    my(%vbn) = $gr->get_squares_by_number();                    foreach my $osq (grep({$_ != $sq} @{$vbn{$val}})){                        if(scalar($osq->available_values) < 3){                            $gcc++;                            next GROUP;                        }                    }                    foreach my $v (keys %vbn){                        next if($v == $val);                        next if(scalar(grep({$_ != $sq} @{ $vbn{$v} })) > 1);                        $gcc++;                        next GROUP;                    }                }                if($gcc == 3){                    $sq->assign_value($val);                    return 1;                }            }        }    }    return 0;}package Sudoku::Square;sub new{    my $proto = shift;    my(@groups) = @_;    $proto = ref($proto) || $proto;        my $self = { groups => \@groups };        foreach (@{ $self->{groups} }){        $_->add_square($self);    }        return bless $self, $proto;}sub available_values{    my $self = shift;    if($self->{value}){        return $self->{value};    }        my(%values);    foreach my $gr (@{ $self->{groups} }){        foreach ($gr->available_values()){            $values{$_}++;            #print STDERR "$_ == $values{$_}\n";        }    }    #print STDERR join(", ", grep({$values{$_} == 3 } keys %values))."\n\n";    return grep({$values{$_} == 3 } keys %values);}sub assign_value{    my $self = shift;    my ($value) = @_;    my @assigned = ();    foreach my $gr (@{ $self->{groups} }){        if($gr->take_value($value)){            push @assigned, $gr;        }else{            foreach (@assigned){                $_->relinquish_value($value);            }            return 0;        }    }        $self->{value} = $value;        return 1;}package Sudoku::Group;sub new{    my $proto = shift;    $proto = ref($proto) || $proto;    my $self = {};    my(%values);    @values{ 1 .. 9 } = (1 .. 9);    $self->{Values} = \%values;        return bless $self, $proto;}sub add_square{    my $self = shift;    push @{ $self->{squares} }, shift;    return 1;}sub get_square{    my $self = shift;    return $self->{squares}[ $_[0] ];}sub take_value{    my $self = shift;    my($value) = @_;        if(exists($self->{Values}{$value})){        delete($self->{Values}{$value});        return 1;    }else{        return 0;    }    return 0;}sub available_values{    my $self = shift;    return keys %{ $self->{Values} };}sub relinquish_value{    my $self = shift;    my($value) = @_;    $self->{Values}{$value} = $value;        return 1;}sub get_squares_by_number{    my $self = shift;    my(%ava);    foreach my $sq ($self->get_members()){        next if($sq->{value});        foreach my $val ($sq->available_values){            push @{ $ava{$val} }, $sq;        }    }    return %ava;}sub get_members{    my $self = shift;    return @{ $self->{squares} };}package Sudoku::Board;sub new{    my $proto = shift;    $proto = ref($proto) || $proto;    my $self = {};    $self->{Rows}    = [new Sudoku::Group, new Sudoku::Group, new Sudoku::Group, new Sudoku::Group, new Sudoku::Group, new Sudoku::Group, new Sudoku::Group, new Sudoku::Group, new Sudoku::Group];    $self->{Columns} = [new Sudoku::Group, new Sudoku::Group, new Sudoku::Group, new Sudoku::Group, new Sudoku::Group, new Sudoku::Group, new Sudoku::Group, new Sudoku::Group, new Sudoku::Group];    $self->{Cubes}   = [new Sudoku::Group, new Sudoku::Group, new Sudoku::Group, new Sudoku::Group, new Sudoku::Group, new Sudoku::Group, new Sudoku::Group, new Sudoku::Group, new Sudoku::Group];        for(my $cu=0; $cu < 9; $cu++){        my $cube = $self->{Cubes}[$cu];        my $col_off = (($cu % 3) * 3);        my $row_off = (int($cu/3) * 3);        for(my $r = 0; $r < 3; $r++){            my $row = $self->{Rows}[($r + $row_off)];            for(my $c = 0; $c < 3; $c++){                my $sq = Sudoku::Square->new($row, $self->{Columns}[($c + $col_off)], $cube);            }        }    }        return bless $self, $proto;}sub get_square{    my $self = shift;    my($sq_num) = @_;    return $self->{Rows}[(int($sq_num/9))]->get_square(($sq_num % 9));}sub get_all_squares{    my $self = shift;    return map({ $_->get_members } $self->get_rows);}sub get_rows{    my $self = shift;    return @{ $self->{Rows} };}sub get_columns{    my $self = shift;    return @{ $self->{Columns} };}sub get_cubes{    my $self = shift;    return @{ $self->{Cubes} };}sub is_solved{    my $self = shift;        foreach my $row (@{ $self->{Rows} }){        if(scalar($row->available_values) > 1){            return 0;        }    }    return 1;}

The web interface is fairly easy to use. It was tested with Firefox on windows. Please forgive the distortionsd when the window is scaled.

Caveat: If only given a few squares as a starting point, it will hang. For best results, give it a puzzle with only one possible solution.

They say that time changes things, but you actually have to change them yourself.

—Andy Warhol

MoveCeiling (bpoag)

Wrote a script at work today, one that will monitor a filesystem in AIX, and increase it's size if it begins to run out of room...Added alot of neat little trick to it, including email notification. Here's the goods:

#!/usr/bin/perl## MoveCeiling v0.2 written 061206:1122 by BJP## MoveCeiling will watch and automatically increase the size of an AIX filesystem# given user-specified parameters.## Usage: moveceiling       # Example: moveceiling 500 /tmp 64 3200 5 foo@bar.com# English: Keep 500MB free in /tmp. If you have to add space, add it in 64MB chunks. Preserve 3200MB in the volume group.#          Remind me every 5 times you have to increase space, and send that reminder to foo@bar.com#use Mail::Sendmail;$ceilingSize=$ARGV[0];$targetFS=$ARGV[1];$incrementSize=$ARGV[2];$sleepTime=$ARGV[3];$preserveAmount=$ARGV[4];$notifyCounter=$ARGV[5];$mailRecipient=$ARGV[6];$mailSender=$ENV{"USER"}."\@"."localhost";if ($#ARGV!=6){        showUsage();        exit();}spinUpRoutine();mainRoutine();spinDownRoutine();sub showUsage(){        print "\n MoveCeiling's job is to watch a filesystem, and increase it's size if the\n";        print " amount of free space in that filesystem falls below threshold. MoveCeiling\n";        print " is much smarter than it used to be, but you should still use it with caution. \n";        print "\n";        print "      Usage: moveceiling       \n";        print "    Example: moveceiling 500 /tmp 64 30 5 foo\@bar.com\n";        print " In English: Every 30 seconds, check to see if /tmp has at least 500MB free. \n";        print "             If it sinks below 500MB, add another 64MB. For every 5 times I \n";        print "             add more space, i'll send a status message to foo\@bar.com.\n";        print "\n\n";        exit();}sub spinUpRoutine(){        print "\nMoveCeiling: I will make sure $targetFS has at least $ceilingSize MB free.";        print "\nMoveCeiling: If I have to increase it's size, I will do so in $incrementSize MB increments.";        print "\nMoveCeiling: Every $notifyCounter times I do so, i'll drop a note to $mailRecipient.";        print "\nMoveCeiling: I'll stop adding storage if the volume group has less than $preserveAmount MB remaining.";        print "\nMoveCeiling: Starting up..\n";        ## Check to see if the filesystem actually exists...        @dfContents=split(/\s+/,`df -m | grep " $targetFS\$"`);        if(length($targetFS)==length($dfContents[6]))        {                print "MoveCeiling: Examining $dfContents[6]..\n";        }        else        {                print "MoveCeiling: Uh-oh.. Can't find the filesystem you specified ($targetFS)..!  Exiting.\n\n";                exit();        }        ## So far so good. Pull up the VG info for this filesystem..        $dfContents[0]=~/\/dev\//;        $targetLV=$';        @lslvContents=split(/\s+/,`lslv $targetLV|head -n1` );        $targetVG=$lslvContents[5];        print "MoveCeiling: $targetFS belongs to logical volume $targetLV inside $targetVG.\n";        @lsvgDump=split(/\s+/,`lsvg -L $targetVG | head -n4 | tail -n1`);        $lsvgDump[6]=~/\(/;        $targetVGSpaceRemaining=$';        print "MoveCeiling: $targetVG has $targetVGSpaceRemaining MB remaining, of which $preserveAmount MB will be preserved.\n\n";}sub mainRoutine(){        while(true)        {                @dfContents=split(/\s+/,`df -m | grep " $targetFS\$"`);                chomp($dateString=`date`);                print "MoveCeiling: $dfContents[2] MB remaining in $targetFS as of $dateString.\n";                @lsvgDump=split(/\s+/,`lsvg -L $targetVG | head -n4 | tail -n1`);                $lsvgDump[6]=~/\(/;                $targetVGSpaceRemaining=$';                if($dfContents[2] < $ceilingSize) # Tricky logic time..                {                        if($targetVGSpaceRemaining >= ($preserveAmount+$incrementSize))                        {                                print "MoveCeiling: Less than $ceilingSize MB remaining! Adding $incrementSize MB to $targetFS..\n";                                system("echo `date` -- MoveCeiling: Less than $ceilingSize MB remaining! Adding $incrementSize MB to $targetFS.. >>/tmp/moveceiling.log");                                `chfs -a size=+"$incrementSize"M $targetFS`;                                $incrementCounter++;                                if($incrementCounter==$notifyCounter)                                {                                        sendNotification();                                        $incrementCounter=0;                                }                        }                        else                        {                                system("echo `date` -- MoveCeiling: Preserve limit reached. Committing suicide. $targetFS last seen with $dfContents[2] MB free, $targetVGSpaceRemaiing MB remaining in $targetVG.  >>/tmp/moveceiling.log");                                print "MoveCeiling: Increasing $targetFS by $incrementSize MB would eat into the preserved area! \n";                                print "MoveCeiling: Preparing suicide note to $mailRecipient..\n";                                sendSuicideNote();                                print "MoveCeiling: My hands are tied! I'm sorry!\n";                                spinDownRoutine();                                exit();                        }                }               else                {                        print "MoveCeiling: More than $ceilingSize MB remaining..No increase needed.\n";                }                print "MoveCeiling: $targetVGSpaceRemaining MB remaining in $targetVG. Sleeping for $sleepTime seconds..\n\n";                sleep($sleepTime);        }}sub sendSuicideNote(){        %mail=( To => $mailRecipient,                From => $mailSender,                Subject => "MoveCeiling Suicide Notice",                Message => "Preserve limit reached -- Data loss may be imminent. $targetFS last seen with $dfContents[2] MB free, $targetVGSpaceRemaining MB remaining in $targetVG. );                sendmail(%mail);        print "MoveCeiling: Suicide note sent.\n";}sub sendNotification(){        print "MoveCeiling: Sending a friendly reminder to $mailRecipient..\n";        %mail=( To => $mailRecipient,                From => $mailSender,                Subject => "MoveCeiling Update",                Message => "$targetFS still growing. Now at $dfContents[2] MB in size with $targetVGSpaceRemaining MB remaining in $targetVG." );                sendmail(%mail);        print "MoveCeiling: Mail sent.\n";}sub spinDownRoutine(){        print "MoveCeiling: Spinning down..\n\n";}

startup scripts under Slackware (sh1tn)

It's because I get crazy when I have to type one milion times per day cd /etc/rc.d/--bla--bla-- or just execute the startup script with the absolute path which is even more exhaustive.

### daemon - lists and starts scripts from /etc/rc.d### may be useful under Slackwareuse strict;my $rc_dir = q|/etc/rc.d|;my @coms   = grep {-f && -x} glob "$rc_dir/*";my %coms;my $com;@coms =        grep{/.{2,}/}        map {s|.+/rc\.(.+?)\W*$|$1| and $_}@coms;$" = $/ and die "@coms", $/ unless @ARGV;$com = shift;@coms{@coms} = ();exists $coms{$com} or die qx{"$rc_dir/rc.$com"},$/;print for qx{"$rc_dir/rc.$com" "@ARGV"};

__END__
#cp daemon.pl /usr/bin/daemon; chmod +x !$
#daemon sshd start (or restart or whatever args /etc/rc.d/rc.sshd script takes)

pass command line parameters (sombhotla)

hi,i call a perl script passing some parameters to the script one of which being a another script name which also needs parameters.but when i pass the parameters to script which is to be called from the main script, the main script shows me some warnings.ex:perl a.pl -a 1 -b b.pl -a 2 -b 2 -c 1where the second a and b parameters are for the script b.pl and not a.pl, where as c is parameter to a.pl.Is there a way so that i can tell perl to take all this as single parameter.thanks for any help in advance

Perl and multimedia (tbone1)

I didn't do this myself, but a guy put a Mac Mini in his Prius to use as a multimedia center and used Perl to run the touch-screen for the thing. (To drive the multimedia center, not the car.) Now this is a cool use of Perl! Maybe not as cool as doing this in Danica Patrick's Indy car, but cool nonetheless.

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

Translate military paygrades to rank salutations (girarde)

This is a module that simplifies translating US Military Paygrades (E-1, W-3, O-4) into the proper salutation for that rank, given the internet domain of the service of interest (af, army, navy, usmc, uscg). For generating mail in response to a form, it beats remembering. It has some historical notes as well.

package Paygrades;require Exporter;our @ISA        = qw(Exporter);our @EXPORT     = qw(paygrade);our @EXPORT_OK  = qw(%navy %army %af %usmc);=historical notesSome of the paygrades listed below are no longer in use, the statutoryauthority for them having expired upon the death of GENA Bradley,others representing special conferrals on extraordinary commanders,and one established to ensure the seniority of George Washington toall United States military personnel, forever.  Additionally, theUnited States Air Force no longer has Warrant Officers.The first officer promoted to Fleet Admiral was Leahy, who wasPresident Roosevelt's Chief of Staff.  He was joined by Ernest King(Chief of Naval Operations), Chester Nimitz (CinC, Pacific OceanAreas) and William Halsey (COM7THFLT).The first officer promoted to General of the Army was George Marshall(Chief of Staff of the Army) joined by Douglas MacArthur (CinC,Southwest Pacific), Dwight Eisenhower (Supreme Commander, AlliedForces Europe) and Omar Bradley (US Army Europe).The only General of the Air Force to date was Harold 'Hap' Arnold,Chief of Staff, Army Air Forces.Admiral of the Navy was conferred on George Dewey for the victory atManila Bay in the Spanish American War.General of the Armies was conferred on John 'Blackjack' Pershing forhis command of the American Expeditionary Force during World War I. Itis said that George Marshall was very apprehensive about beingpromoted to five stars, for fear of offending him.George Washington is sui generis, and the perpetual General of theArmies of the United States of America.=cut%navy = (   'E-1'     => 'Seaman',            'E-2'     => 'Seaman',            'E-3'     => 'Seaman',            'E-4'     => 'Petty Officer',            'E-5'     => 'Petty Officer',            'E-6'     => 'Petty Officer',            'E-7'     => 'Chief',            'E-8'     => 'Senior Chief',            'E-9'     => 'Master Chief',            'W-1'     => 'Warrant Officer',            'W-2'     => 'Chief Warrant Officer',            'W-3'     => 'Chief Warrant Officer',            'W-4'     => 'Chief Warrant Officer',            'W-5'     => 'Chief Warrant Officer',            'O-1'     => 'Ensign',            'O-2'     => 'Lieutenant (j.g.)',            'O-3'     => 'Lieutenant',            'O-4'     => 'Lieutenant Commander',            'O-5'     => 'Commander',            'O-6'     => 'Captain',            'O-7'     => 'Admiral',            'O-8'     => 'Admiral',            'O-9'     => 'Admiral',            'O-10'    => 'Admiral',            'O-11'    => 'Fleet Admiral',            'O-12'    => 'Admiral of the Navy');%usmc = (   'E-1'     => 'Private',            'E-2'     => 'PFC',            'E-3'     => 'Lance Corporal',            'E-4'     => 'Corporal',            'E-5'     => 'Sergeant',            'E-6'     => 'Staff Sergeant',            'E-7'     => 'Gunny',            'E-8'     => 'Master Sergeant',            'E-9'     => 'Master Guns',            'W-1'     => 'Gunner',            'W-2'     => 'Gunner',            'W-3'     => 'Gunner',            'W-4'     => 'Gunner',            'W-5'     => 'Gunner',            'O-1'     => 'Lieutenant',            'O-2'     => 'Lieutenant',            'O-3'     => 'Captain',            'O-4'     => 'Major',            'O-5'     => 'Lieutenant Colonel',            'O-6'     => 'Colonel',            'O-7'     => 'General',            'O-8'     => 'General',            'O-9'     => 'General',            'O-10'    => 'General');%army = (   'E-1'     => 'Private',            'E-2'     => 'Private',            'E-3'     => 'PFC',            'E-4'     => 'Corporal',            'E-5'     => 'Sergeant',            'E-6'     => 'Staff Sergeant',            'E-7'     => 'Sergeant',            'E-8'     => 'Master Sergeant',            'E-9'     => 'Sergeant Major',            'W-1'     => 'Chief',            'W-2'     => 'Chief',            'W-3'     => 'Chief',            'W-4'     => 'Chief',            'W-5'     => 'Chief',            'O-1'     => 'Lieutenant',            'O-2'     => 'Lieutenant',            'O-3'     => 'Captain',            'O-4'     => 'Major',            'O-5'     => 'Lieutenant Colonel',            'O-6'     => 'Colonel',            'O-7'     => 'General',            'O-8'     => 'General',            'O-9'     => 'General',            'O-10'    => 'General',            'O-11'    => 'General of the Army',            'O-12'    => 'General of the Armies',            'O-13'    => 'General of the Armies of the United States of America');%usaf = (   'E-1'     => 'Airman',            'E-2'     => 'Airman',            'E-3'     => 'Senior Airman',            'E-4'     => 'Sergeant',            'E-5'     => 'Staff Sergeant',            'E-6'     => 'Tech Sergeant',            'E-7'     => 'Master Sergeant',            'E-8'     => 'Senior Master Sergeant',            'E-9'     => 'Chief Master Sergeant',            'W-1'     => '',            'W-2'     => '',            'W-3'     => '',            'W-4'     => '',            'W-5'     => '',            'O-1'     => 'Lieutenant',            'O-2'     => 'Lieutenant',            'O-3'     => 'Captain',            'O-4'     => 'Major',            'O-5'     => 'Lieutenant Colonel',            'O-6'     => 'Colonel',            'O-7'     => 'General',            'O-8'     => 'General',            'O-9'     => 'General',            'O-10'    => 'General',            'O-11'    => 'General of the Air Force');sub paygrade {my ($title, $domain) = @_;my $paygrade;unless ($title =~ /(^W)|(^O)|(^E)/) {    return $title;#    print $title;}$domain = uc($domain);if ($domain =~ /NAVY/) {    $paygrade =  $navy{$title};}elsif ($domain =~ /USCG/) {    $paygrade =  $navy{$title};}elsif ($domain =~ /USMC/) {    $paygrade =  $usmc{$title};}elsif ($domain =~ /AF\.MIL/) {    $paygrade =  $usaf{$title};}elsif ($domain =~ /ARMY/) {    $paygrade =  $army{$title};}else {    $paygrade =  "$army{$title}/$navy{$title}";}#print $paygrade;return $paygrade;}

2006-06-02 [id://340870|Retitled] by [planetscape], as per Monastery [id://341118|guidelines] ( keep:0 edit:10 reap:1 )
Original title: 'Paygrades'

#perl.br calc - A Perl Shell (ruoso)

Using a trick by [node://fglock], and with the help of the guys at #perl.br (at freenode.org), here is the #perl.br calc, which I now use in place of bc...

Obviously, you'll see it's just a Perl Shell that have some calculator shortcuts, so, you can do whatever you want with it...

#!/usr/bin/perluse strict;use warnings;use Term::ReadLine;my $name = '#perl.br calc';print $name.$/;my $term = Term::ReadLine->new($name);$term->Features()->{'autohistory'} = 1;my $prompt = "> ";my $OUT = $term->OUT || \*STDOUT;my $___eval_str___;my $M = 0;my $scale = 2;sub ler {        my $a = $term->readline($prompt);        unless (defined $a) {                print $/;                exit(0);        }        return $a;}sub substituir {        my $a = shift;        $a =~ s/^(.+)(\*\*)$/\$M $2 $1/;        $a =~ s/^(.+)(\+|\-|\*|\/)$/\$M $2 $1/;        $a =~ s/\;\s*$//;        if ($a =~ /^\s*do {\s*$/) {                my $block = '';                my $count = 1;                while (defined($_=$term->readline(' '.('.'x$count).' '))) {                        while ($_ =~ m/\{/g) {                                $count++;                        }                        while ($_ =~ m/\}/g) {                                $count--;                        }                        last if $count < 1;                        $block .= $_;                }                $a = 'do {'.$block.'}';        }        return $a;}sub falar {        my $a = shift;        if ($@) {                print "! ".$@;        } else {                if (defined $a && $a =~ /^[\d\.]$/) {                        $M=sprintf("%.".$scale."f",$a);                } elsif ($a) {                        $M=$a;                }                print $OUT "= ".$M.$/ if defined $M;        }}sub doit {        $___eval_str___ = 'eval("   falar(".substituir(ler()).");   $___eval_str___;");if($@){   print "! ".$@;   eval($___eval_str___)}';        eval $___eval_str___;}doit();

daniel

Football World Cup Group Stage Predictor. (perlmoth)

With less than two weeks before the Football World Cup kicks off, the office sweep has appeared. I wrote the following script to help me with the group stage predictions. It makes its predictions based on the FIFA rankings:

#!/usr/bin/perluse strict;use warnings;# The following statistics are from# http://www.fifa.com/en/mens/statistics/index/0,2548,All-May-2006,00.htmlmy %FIFA_points =  ("Brazil"              => 827,   "Czech Republic"      => 772,   "Holland"             => 768,   "Mexico"              => 758,   "Spain"               => 756,   "USA"                 => 756,   "Portugal"            => 750,   "France"              => 749,   "Argentina"           => 746,   "England"             => 741,   "Italy"               => 728,   "Sweden"              => 709,   "Japan"               => 705,   "Germany"             => 696,   "Tunisia"             => 693,   "Iran"                => 686,   "Croatia"             => 686,   "Costa Rica"          => 683,   "Poland"              => 677,   "South Korea"         => 677,   "Ivory Coast"         => 669,   "Paraguay"            => 653,   "Saudi Arabia"        => 651,   "Switzerland"         => 648,   "Ecuador"             => 631,   "Australia"           => 612,   "Serbia & Montenegro" => 610,   "Ukraine"             => 609,   "Trinidad & Tobago"   => 604,   "Ghana"               => 600,   "Angola"              => 581,   "Togo"                => 569  );my %groups = (A => ["Germany",     "Costa Rica",     "Poland",              "Ecuador"],  B => ["England",     "Paraguay",       "Trinidad & Tobago",   "Sweden"],  C => ["Argentina",   "Ivory Coast",    "Serbia & Montenegro", "Holland"],  D => ["Mexico",      "Iran",           "Angola",              "Portugal"],  E => ["USA",         "Czech Republic", "Italy",               "Ghana"],  F => ["Australia",   "Japan",          "Brazil",              "Croatia"],  G => ["South Korea", "Togo",           "France",              "Switzerland"],  H => ["Spain",       "Ukraine",        "Tunisia",             "Saudi Arabia"] );my @combinations = ([0, 1], [2, 3], [0, 2], [3, 1], [3, 0], [1, 2]);for ("A" .. "H") {  print STDERR "\nGroup $_:\n";  my $group = $groups{$_};  foreach (@combinations) {    my $a = $group->[$_->[0]];    my $b = $group->[$_->[1]];    my $home_advantage = $FIFA_points{$a} - $FIFA_points{$b};    my $score = get_score($home_advantage);    print STDERR "$a vs $b ($score)\n";  }}sub get_score {  my ($points_diff) = @_;  my $score = 0;  my $other = 0;  if (abs $points_diff <= 30) {    $score = 0;  }  elsif (abs $points_diff <= 80) {    $score = 1;  }  elsif (abs $points_diff <= 130) {    $score = 2;  }  elsif (abs $points_diff <= 200) {    $score = 3;  }  else {    $score = 4;  }  my $random_factor = rand;  if ($random_factor > 0.9) {    $score += 2;    $other += 2;  }  elsif ($random_factor <= 0.9 and $random_factor > 0.75) {    $score += 1;    $other += 1;  }  if ($points_diff == abs $points_diff) {    return "${score}-${other}";  }  else {    return "${other}-${score}";  }}

Any comments or suggested improvements would be gratefully received.

Show mbox files with unread mail messages in them (skx)

A simple script which will process all the mbox files beneath a given directory root and show those which contain unread mail.

#!/usr/bin/perl -w=head1 NAMEunread-mail - Display mbox files which contain unread messages.=head1 SYNOPSIS  unread-mail [options]  Help Options:   --help     Show this scripts help information.   --manual   Read this scripts manual.   --version  Show the version number and exit.   --verbose  Show verbose information useful for debugging problems.  General Options:   --dir      Specify the root mail directory to search beneath   --recent   Only process mbox files modified in the most recent N days.   --exclude  Comma-seperated list of mbox files to exclude from processing.=cut=head1 AUTHOR Steve -- http://www.steve.org.uk/ $Id: unread-mail,v 1.6 2006/05/28 21:50:13 steve Exp $=cut=head1 LICENSECopyright (c) 2005 by Steve Kemp.  All rights reserved.This module is free software;you can redistribute it and/or modify it underthe same terms as Perl itself.The LICENSE file contains the full text of the license.=cutuse strict;use File::Find;use Getopt::Long;use Mail::MboxParser;use Pod::Usage;##  Global options#my %CONFIG;##  Defaults##  Mail directory$CONFIG{'maildir'} = $ENV{'HOME'} . "/mail" if ( -d $ENV{'HOME'} . "/mail" );$CONFIG{'maildir'} = $ENV{'HOME'} . "/Mail" if ( -d $ENV{'HOME'} . "/Mail" );##  Exclusion list$CONFIG{'exclude'} = "backup,build,logs,sent,pyzor,spam";##  Number of days.$CONFIG{'time'} = 2;##  Verbosity$CONFIG{'verbose'} = 0;##  Parse the arguments.#parseCommandLineArguments();##  Show unread mail#findUnreadMail( $CONFIG{'maildir'} );##  Finished#exit;=head2 parseCommandLineArguments  Process the command line arguments.=cutsub parseCommandLineArguments{    my $HELP= 0;    my $MANUAL= 0;    my $VERSION= 0;    #  Parse options.    #    GetOptions(       "dir=s",        \$CONFIG{'maildir'},       "exclude=s",    \$CONFIG{'exclude'},       "recent=s",     \$CONFIG{'time'},       "help",         \$HELP,       "manual",       \$MANUAL,       "version",      \$VERSION,       "verbose",      \$CONFIG{'verbose'}      );    pod2usage(1) if $HELP;    pod2usage(-verbose => 2 ) if $MANUAL;    if ( $VERSION )    {my $REVISION      = '$Revision: 1.6 $';if ( $REVISION =~ /1.([0-9.]+) / ){    $REVISION = $1;}print "unread-mail CVS: $REVISION\n";exit;    }    if ( $CONFIG{'verbose'} )    {print "Configuration:\n";foreach my $key ( sort keys( %CONFIG ) ){    print $key . " => '" . $CONFIG{$key} . "'\n";}    }}=head2 wanted  Called as a result of the File::Find module.  Process every given file beneath the $CONFIG{'maildir'} root directory and look for unread mail.  Mailboxes contained in the $CONFIG{'exclude'} setting are ignored.=cutsub wanted{    my $file = $File::Find::name;    #    # We only care about files.    #    return if ( -d $file );    #    # Skip some mailboxes.    #    foreach my $exclude ( split( /,/, $CONFIG{'exclude'} ) )    {if ( $file =~ /$exclude/i ){    $CONFIG{'verbose'} && print "Excluded mail file: $file\n";    return;}    }    #    #  Skip files if they've not been modified too recently.    #    my $time = -M $file;    if ( defined( $time ) )     {if ( $time > $CONFIG{'time'} ){    $CONFIG{'verbose'} && print "Mail file not modified recently: $file\n";    return;}    }    else    {        $CONFIG{'verbose'} && print "Failed to stat: $file - $!\n";return;    }    my $parseropts = {      enable_cache    => 1,      enable_grep     => 1,      cache_file_name => '/tmp/mail-cache',     };    my $mb = Mail::MboxParser->new( $file,    decode     => 'NONE',    parseropts => $parseropts );    my $count = 0;    for my $msg ($mb->get_messages)    {my $status = $msg->header->{status};if ( !defined( $status ) ){    $count += 1;}    }    if ( $CONFIG{'verbose'} )    {print "$file ($count)\n";    }    else    {print "$file ($count)\n" if ($count > 1 );    }}=head2 findUnreadMail  Look for files and directories beneath the maildir root and call 'wanted' on them.=cutsub findUnreadMail{    my $dir = $CONFIG{'maildir'};    die "$CONFIG{'maildir'} doesn't exist" unless ( -d $CONFIG{'maildir'} );    $CONFIG{'verbose'} && print "Staring search for unread mail in: $dir\n";    #    #  Do the searching.    #    find( { wanted => \&wanted, no_chdir => 1 }, $dir );    $CONFIG{'verbose'} && print "Finished search for unread mail in: $dir\n";}

Steve
--

Patchy pattern using a cellular automaton (ambrus)

This one-liner draws a patchy pattern using a simple game-of-life-like cellular automaton. You can see the pattern evolving.

If you use a larger terminal window, the pattern is larger as well, but the program gets slower. In general, this program isn't written with speed in mind, it could be made much faster.

perl -we '($H,$W)=`stty size`=~/^(\d+) (\d+)/?($1-1,$2):(24,80);$w=$W+20;@a = map { rand() < 1/3 } 0 .. ($H+20)*$w; print "\e[H\e[J"; for (0 .. 30) { print "\e[H"; for (0 .. 1) { @a = map { $c = $_; $s = 0; $s += $a[($c + $_) % @a] for -$w-1, -$w, -$w+1, -1, 1, $w-1, $w, $w+1; $s < 3 } 0 .. @a - 1; } for $y (10 .. $H + 9) { for $x (10 .. $W + 9) { print $a[$y*$w + $x] ? "#" : " "; } print "\n"; } }'

Create and edit new scripts (johngg)

To save myself some typing I have written a small script to make the creation of new Perl scripts simpler. I called it newscript (it does what it says on the tin) and you run it with an argument of the script name you want to create. It checks that the file does not already exist then creates a new file with execute permissions and places

#!/usr/bin/perl#use strict;use warnings;

at the top so I have no excuse for not using strict and warnings. It then asks the user if they would like to start editing the new file; the script sets up a timeout for the user to answer so that it doesn't sit there waiting forever. The editor I prefer to use is nedit but you could substitute your favourite in $editor. If your preference is something like vi then you could start an xterm with vi as it's command to run. This is rather *nix-centric but that's mostly what I use. Here's the script. I hope that it is of interest.

#!/usr/bin/perl#use strict;use warnings;# Get modules, set autoflush on STDOUT.#use IO::File;use Term::ReadKey;STDOUT->autoflush(1);# Get name of script we want to create, die if it already# exists.#my $newfile = shift or   die "Usage: newscript \n";die "newscript: $newfile already exists\n" if   -e $newfile or -l $newfile;# Make new IO::File handle to create script file with execute# permissions, die on failure.#my $scriptFH = IO::File->new($newfile,   O_WRONLY|O_CREAT|O_TRUNC, 0755);die "newscript: open: $!\n" unless $scriptFH;# Set up hash-bang line and strictures for top of script, write# them to the new file and then close.#my $hashBang =   "#!/usr/bin/perl\n#\n\nuse strict;\nuse warnings;\n\n";$scriptFH->print($hashBang);$scriptFH->close();# Set up editor command, prompts asking user if they want to# edit the new script, and a time-out value of five seconds.#my $editor = "/usr/local/bin/nedit";our $prompt1 = "Start editing $newfile? (";our $prompt2 = ") (y/n) : ";our $timeOut = 5;# Set up subroutine reference that will be used as the handler# for $SIG{ALRM}.#our $rcCountdown = sub{    # If there is still time left, print prompt (decrementing    # time-out value) and set alarm for one second.    #    if($timeOut)    {        print "\r", $prompt1, $timeOut --, $prompt2;alarm(1);    }    # Time is up, restore read mode and die.    #    else    {        ReadMode(0);die "Timed out\n"    }};# Install handler, call handler for the first time to prompt# and set alarm.#$SIG{ALRM} = $rcCountdown;$rcCountdown->();# Set read mode to raw and await a key press.#ReadMode(4);my $resp = ReadKey(0);# If we got here we got a key press, reset read mode, unset# alarm and print a newline to move off prompt.#ReadMode(0);alarm(0);print "\n";# If key pressed was 'y' then start the editor in the# background via exec, new editor window will appear and# shell will prompt for next command.#if($resp =~ /^y$/i){    exec "$editor $newfile &" or       die "Couldn't invoke $editor: $!\n";}# User doesn't want to edit so just exit.#exit;

Cheers,

JohnGG

Parse and Summarise Big Brother logs (McDarren)

At my workplace we use Big Brother for Network Monitoring. We have dispensed with the default BB web interface and replaced it with a home-grown Perl/CGI interface...

This is good because:

It is more suited to our specific needs. That is, we've added lots of funky CGI options to allow sorting/filtering/etc.
It is more "real-time". The default BB interface is basically a static HTML page, which is re-generated every 5 minutes. Whereas our CGI interface is generated every time the page is loaded.

However, the 2nd point above is a double-edged sword. Because with around 15 tests running on 500-odd hosts - that's around 7500 files that must be parsed every time the page is loaded. And when there are 15-20 users constantly hitting the page - things start to get a bit bogged down.

So as a compromise, I decided to write a separate script that would parse all of the BB logs, and summarise them into a single file. And then modify the CGI script so that instead of reading all 7500 logs, it just reads the single summary file.

The summarising script is invoked via crond every minute, and takes less than a second to run. The script is shown below. There is nothing particularly clever about it, but in our case it has proved quite effective. So I thought it may be useful for others.

#!/usr/bin/perl -w# parse_bblogs.pl# Darren - 15th Feb 2006## Simple script to parse and summarise Big Brother logs# Would generally be invoked via crond# Will produce a summary of all logs found in $logs_dir#  and write to $outfile in the following format:##  hostname:test:status:duration#use strict;use Fcntl qw(:DEFAULT :flock);use Readonly;use Log::Trivial;################################### Adjust the following to suit# regex to match the filename format of the bb logsReadonly my $LOGFILE_MATCH => qr/-\d\./;my $logs_dir = qw( /home/bb/bbvar/logs );my $outfile = qw( /home/bb/bb/www/bbstatus.current );my $debug = 0;################################### Should be no need to change anything below here# Create a new logfile each daychomp(my $today = `date +%Y-%m-%d`);my $logfile = qq(/var/log/bb/$0-$today);my $logger = Log::Trivial->new(        log_file => "$logfile",        log_mode => "single"        );opendir(DIR, $logs_dir)   or die "Cannot opendir $logs_dir:$!";my @files = grep { /$LOGFILE_MATCH/ && -f "$logs_dir/$_" } readdir DIR;closedir DIR;# Need an exclusive lock on the output file# (Assuming of course, that everybody else is playing by the rules :)sysopen(OUT, $outfile, O_WRONLY | O_CREAT)   or die "Cannot open $outfile for writing:$!\n";flock(OUT, LOCK_EX)   or die "Cannot get a lock on $outfile:$!\n";truncate(OUT, 0)   or die "Cannot truncate $outfile:$!\n";FILE:for my $file (@files) {    debug("Processing $file") if $debug;    # Because the logs are automagically created by BB,    # we can be quite strict about the format we expect to see    # ie: hostname.test    my ($host, $test) = split(/\./, $file, 2)        or $logger->write("WARNING: Skipping unrecognised logfile: $file")        and next FILE;    open BBLOG, "<", "$logs_dir/$file"        or $logger->write("ERROR: I could not open $file: $!")        and next FILE;    chomp(my @lines = );    # The test status should ALWAYS be the first "word" on the first line    # And the status duration should ALWAYS be contained on the 2nd last line    debug($lines[0], $lines[-2]) if $debug;    my ($status) = ($lines[0] =~ /^([a-z]+)/);    my ($dur) = ($lines[-2] =~ /Status unchanged in (.*)$/);    if (!defined $status && !defined $dur) {        $logger->write("WARNING: Skipping malformed logfile: $file");        next FILE;    }    close BBLOG;    # If we get to here, all is good and so we write to the output file    print OUT "$host:$test:$status:$dur\n";}close OUT;sub debug {    $logger->write("DEBUG: $_") for @_;}

As always, any pointers for improving the script, making it more efficient, less brain-dead, etc. are most welcome.

Cheers,
Darren :)

winamp lyrics script (rush3k)

Started learning Perl two weeks ago .. this is my first script .. it reads current song playing on Winamp and displays lyrics from the azlyrics website on the DOS terminal.However its dependent on httpq installation ... is there a way I can get the current song playing information from Windows?

use strict;use Winamp::Control;use WWW::Mechanize;use warnings;my $agent = Winamp::Control -> new (host => '127.0.0.1', port => '4800', passwd => 'pass');my $playing = $agent->getcurrenttitle();my $artistsong = $agent->getcurrenttitle();   $artistsong =~ s/\d.*?\s//s;my $firstletter = $artistsong;   $firstletter = substr($artistsong,0,1);my $artistname = $artistsong;   $artistname =~ s/ -.*//s;   $artistname =~ tr/a-z/A-Z/;   my $songtitle = $artistsong;   $songtitle =~ s/.*- //s;   my $lyrics = WWW::Mechanize -> new (autocheck => 1);   $lyrics -> get('http://www.azlyrics.com/');   $lyrics -> follow_link(text => $firstletter, n => 1);   $lyrics -> follow_link(text => $artistname, n => 1);   $lyrics -> follow_link(text => $songtitle, n => 1);my $content1 = $lyrics -> content(format => "text");   print "$artistname";print "$songtitle \n";print $content1;

Redirecting output across Oracle DB link (jeremyh)

To be used in conjunction with Grant McLean's Sprog::PrintProxy

Sends output for a given file handle to Oracle's utl_file.put()

You invoke it like this:

use DBI;use Sprog::PrintProxy;use DBPrinter;my $dbh = DBI->connect("dbi:Oracle:", "uid", "passwd")           or die "$!:  Can't connect to DB";my $fh = Sprog::PrintProxy->new( DBPrinter->new($dbh, "/some/directory", "outfile.txt", "dblinkname") );

Now all output to $fh will end up in /some/directory/outfile.txt on the server where dblinkname runs. You can also simply output to a directory seen by the DB from your DBI connection by leaving out the dblinkname parameter. Can't think of a reason this would be useful, but there might be.

Note: Oracle requires that utl_file output directories be declared in init.ora, and the directory in the utl_file call must be "spelled" exactly the same as the directory listed in init.ora.

here's the code

# ============================================================================#  DBPrinter##  Intercepts output to tie()'ed filehandle and writes it to Oracle#  UTL_FILE.FILE_TYPE filehandle.  Allows perl output to be redirected#  from one server to another over a DB link.  Max length per write (line)#  is 2000 chars.##  Jeremy Hickerson, 4/13/2006# ============================================================================package DBPrinter;use strict;use DBI;# ============================================================================#                           Package level vars# ============================================================================my (%glb_prepared_sql, $sth_pls_write_DBfh, $DBH, $DB_fh, $Filedir, $Filename,    $DB_linkname);# Constantsmy $SQL_CHAR             = 1;my $SQL_NUMERIC          = 2;my $SQL_DECIMAL          = 3;my $SQL_INTEGER          = 4;my $SQL_SMALLINT         = 5;my $SQL_FLOAT            = 6;my $SQL_REAL             = 7;my $SQL_DOUBLE           = 8;my $SQL_DATE             = 9;my $SQL_TIME            = 10;my $SQL_TIMESTAMP       = 11;my $SQL_VARCHAR         = 12;my $SQL_LONGVARCHAR     = -1;my $SQL_BINARY          = -2;my $SQL_VARBINARY       = -3;my $SQL_LONGVARBINARY   = -4;my $SQL_BIGINT          = -5;my $SQL_TINYINT         = -6;my $SQL_BIT             = -7;my $SQL_WCHAR           = -8;my $SQL_WVARCHAR        = -9;my $SQL_WLONGVARCHAR   = -10;# ============================================================================#                             Constructor# ============================================================================sub new {    my ($class, $self);    ($class, $DBH, $Filedir, $Filename, $DB_linkname) = @_;    if ($DB_linkname) { $DB_linkname = "\@$DB_linkname" }    else { $DB_linkname = "" }    open_DBfh();    $self = { };    bless($self, $class);    return $self;}# ============================================================================#                              Methods# ============================================================================sub print {    my ($class, $data) = @_;    # from Oracle's utl_file package:    #    # FILE_TYPE - File handle    #     # TYPE file_type IS RECORD (id BINARY_INTEGER);    # we can populate/save id field of outfile with a bind var    # for performance we will only prepare repeated sql once    if (exists $glb_prepared_sql{"sth_pls_write_DBfh"} ) {    $sth_pls_write_DBfh = $glb_prepared_sql{"sth_pls_write_DBfh"};    }    else {    $sth_pls_write_DBfh = $DBH->prepare( qq{    DECLARE        outfile          sys.UTL_FILE.FILE_TYPE$DB_linkname;    BEGIN        outfile.id := :DB_fh;        sys.utl_file.put$DB_linkname(outfile, :data);    END; } );    $sth_pls_write_DBfh->bind_param_inout(":DB_fh", \$DB_fh, $SQL_BINARY);    $glb_prepared_sql{"sth_pls_write_DBfh"} = $sth_pls_write_DBfh;    }    $sth_pls_write_DBfh->bind_param_inout(":data", \$data, $SQL_VARCHAR);    $sth_pls_write_DBfh->execute();}sub open_DBfh {    my $sth_pls_open_DBfh = $DBH->prepare( qq{DECLARE    outfile              sys.UTL_FILE.FILE_TYPE$DB_linkname;    MAX_LINESIZE         integer := 2000;BEGIN    outfile := sys.utl_file.fopen$DB_linkname(:Filedir, :Filename, 'w', MAX_LINESIZE);    :DB_fh  := outfile.id;END; } );$sth_pls_open_DBfh->bind_param_inout(":DB_fh",    \$DB_fh,    $SQL_BINARY);$sth_pls_open_DBfh->bind_param_inout(":Filename", \$Filename, $SQL_VARCHAR);$sth_pls_open_DBfh->bind_param_inout(":Filedir",  \$Filedir,  $SQL_VARCHAR);$sth_pls_open_DBfh->execute();}sub close_DBfh {    my $sth_pls_close_DBfh = $DBH->prepare( qq{DECLARE    outfile              sys.UTL_FILE.FILE_TYPE$DB_linkname;BEGIN    outfile.id := :DB_fh;    sys.utl_file.fclose$DB_linkname(outfile);END; } );    $sth_pls_close_DBfh->bind_param_inout(":DB_fh",    \$DB_fh,    $SQL_BINARY);    $sth_pls_close_DBfh->execute();}# ============================================================================#                                 Destructor# ============================================================================sub DESTROY {    %glb_prepared_sql = ();    close_DBfh();}1;

PerlMonks Editor (GrandFather)

This is the first cut of a PerlMonks offline wysiwyg editor. It may be used to wysiwig edit material for posting on PerlMonks and generates the common HTML and PerlMonks special tags used in PerlMonks node markup.

The code uses Tk and should be reasonably cross platform.

This first cut is missing a lot of functionality but is being posted to garner initial reactions and make it available to the curious (I'm off on holiday for a few days and won't be able to work on it for another week).

Important missing stuff includes - no readmore handling, save/open partially implemented (and disabled), keyboard accelerators not working (and disabled), much markup not hooked up.

use strict;use warnings;use diagnostics;use Tk;#use Tk::TextUndo;use Tk::Balloon;use Tk::Clipboard;use Tk::FBox;use Clone qw(clone);=head TodoProvide file open and saveManage B, F, I, P, R and U flagsTranslate entities (note U flag)Handle accelerator keysSupport snippet text (with formatting)Disallow relinkCheckmarks for menushandle tableshook up keysAdd Edit menu to access find and replace etc=cutuse constant kParaSpace => 4;my $currentFile = '';my %tagTypes;       # Style tag datamy %formatFonts;    # Fonts used in style tags. Keyed by tagmy %bindings;       # Key, menu and toolbar bindings. Tag is valuemy %menuItems;      # Child menu widgets keyed by menu label pathmy %entities =      # Entities we need to use outside code blocks    (    '&', '&',    '<', '<',    '>', '>',    '[', '[',    ']', ']',    );my @stdFlags = (    'B', # Block level element    'C', # Clear all or specified tags: C or Ctag (note lower case)    'F', # Format tag (inline element)    'I', # Item in a list. Implies B    'L', # Link    'P', # Applies to whole paragraph    'R', # Readmore text    'S', # Single spaced text    'U', # Untranslated - don't translate entities    'X', # Exclude all or specified tags: X or Xtag (note lower case)    );while () {    # Load the default configuration stuff    chomp;    next if ! length;    last if /^#key /;    next if /^#/;        my ($tag, $htmlTag, $name, $flagsField, @options) = split /\s*,\s*/;    (print "Missing entries in tag line ($.): $_"), next if ! defined $flagsField;    # pull out flags and handle X and C special case flags    my %flags;    @flags{@stdFlags} = (0) x @stdFlags; # Preset flags off    $flags{'C'} = {};    $flags{'X'} = {};    for (split /(?=[A-Z][a-z]*)/, $flagsField) {        my ($flag, $value) = split /(?<=[A-Z])/, $_;                print "Unhandled flag '$flag' used\n" if ! exists $flags{$flag};        if (-1 != index 'XC', $flag) {            $flags{$flag}{$value || 'ALL'} = 1;            $flags{'C'}{$value || 'ALL'} = 1 if $flag eq 'X'; # X implies C        } else {            $flags{$flag} = $value || 1;            $flags{'B'} = $value || 1 if $flag eq 'I';        }    }    #Fix up options    my $optionStr = join ', ', @options;    my %optionHash;        while ($optionStr =~ /\G,?\s*((?:(?!=>).)*)=>\s*(\[[^\]]*\]|[^,]*),?\s*/g) {        my ($option, $value) = ($1, $2);                trim (\$option, \$value);                if ($value =~ s/\[|\]//g) {            # Nested options. Turn them into a hash            my @options = split ',', $value;            my %optionHash;                        for (@options) {                my ($suboption, $subvalue) = split /\s*=>\s*/;                                last if ! defined $subvalue;                trim (\$suboption, \$subvalue);                $optionHash{$suboption} = $subvalue;            }                        $value = \%optionHash;        }                $optionHash{$option} = $value;    }        $tagTypes{$tag} = [$htmlTag, $name, \%flags, \%optionHash];}while () {    # Load key binding information    next if /^#/;    chomp;    next if ! length;        my ($tag, $key, $menuItem, $toolbarItem, $rightClickItem) = split /\s*,\s*/;    (print "Missing tag in binding line ($.): $_"), next if ! defined $tag;    $bindings{$tag} = [$key, $menuItem, $toolbarItem, $rightClickItem];}my $mw = MainWindow->new (-title => "PerlMonks node editor");my $text = $mw->Scrolled    ('Text', -font => 'normal', -wrap => 'word', -scrollbars => 'e',);my $status = $mw->Label(-width => 60, -relief => "sunken", -bd => 1, -anchor => 'w');my $balloon = $mw->Balloon(-statusbar => $status);my $msg = '';my $balloonCharIndex = '';my $balloonLastIndex = '';$status->pack(-side => "bottom", -fill => "both", -padx => 2, -pady => 1);#$balloon->attach#    (#    $text, -msg => \$msg,#    -balloonposition => 'mouse',  # Not really used since the postcommand returns the real position.#    -postcommand => \&balloonPostCommand,#    -motioncommand => \&balloonMotionCommand,#    );my $menuBar = $mw->Menu (-type => 'menubar');$mw->configure(-menu => $menuBar);$text->pack (-expand => 'yes', -fill => 'both');# Build file menu$menuItems{'~File'} = $menuBar->cascade(-label => '~File', -tearoff => 0);$menuItems{'~File'}->command (-label => '~Render', -command => \&fileRender);#$menuItems{'~File'}->command (-label => '~Open...', -command => \&fileOpen);#$menuItems{'~File'}->command (-label => '~Save', -command => \&fileSave);#$menuItems{'~File'}->command (-label => 'Save ~As...', -command => \&fileSaveAs);$menuItems{'~File'}->command (-label => 'E~xit', -command => \&fileExit);# Build menus and bind keysfor my $tag (keys %bindings) {    my $menuPath = $bindings{$tag}[1];    next if ! defined $menuPath;    my ($top, $item) = split '/', $menuPath;        next if ! defined $item;    if (! defined $menuItems{$top}) {        $menuItems{$top} = $menuBar->cascade(-label => $top, -tearoff => 0);    }        my $newItem = $menuItems{$top}->command        (-label => $item, -command => [\&doCommand, $tag]);        if (defined $bindings{$tag}[0]) {        #Set up accelerator bindings                #my $key = $bindings{$tag}[0];        #        #$mw->bind ("<$key>" => [\&keyCommand, $tag]);        #        #$key =~ s/^Control/ctrl/;        #$newItem->configure (-accelerator => $key);    }}$menuItems{'~Help'} = $menuBar->cascade(-label => '~Help', -tearoff => 0);$menuItems{'~Help'}->command (-label => '~PerlMonks Editor Help', -command => \&help);$menuItems{'~Help'}->command (-label => '~About', -command => \&about);# A couple of phantom paragraph spacing tags to ease calculating paragraph spacing$text->tagConfigure("!para_start", -spacing1 => 0, -spacing3 => -(kParaSpace));$text->tagConfigure("!para_end", -spacing1 => -(kParaSpace), -spacing3 => 0);$text->insert ('end', "Some text to play with.\n", '!para');$text->insert ('end', "Some more text to play with. Some more text to play with.\n", '!para');#$mw->bind ("<$key>" => [\&keyCommand, $tag]);MainLoop ();sub balloonPostCommand {    return 0 if ! length $balloonCharIndex;        my %balloonCharTags;    my  $charIndex = $text->index ("$balloonCharIndex +1 char");        @balloonCharTags{$text->tagNames()} = ($balloonCharIndex);        # If no tags under mouse don't post the balloon.    return 0 if ! %balloonCharTags;        if (exists $balloonCharTags{name}) {        my ($start, $end) = $text->tagPrevrange ('name', $balloonCharIndex);        my $name = $text->get($start, $end);                $name =~ s/\|.*//;        $msg = "link to [${name}]'s home node";    } elsif (exists $balloonCharTags{node}) {        my ($start, $end) = $text->tagPrevrange ('node', $balloonCharIndex);        my $node = $text->get($start, $end);                $node =~ s/\|.*//;        $msg = "link to node id $node";        $msg .= ' (badly formed - digits only allowed)' if $node !~ /^\d+$/;    } else {        return 0;    }        my @p = $text->bbox($balloonCharIndex);    my $x = $text->rootx + $p[0] + $p[2] - 4;    my $y = $text->rooty + $p[1] + $p[3] + 2;    print "-$x,$y-\n";    return "$x,$y";}sub balloonMotionCommand {    my $x = $text->pointerx - $text->rootx;    my $y = $text->pointery - $text->rooty;        $balloonCharIndex = $text->index ("\@$x,$y");    # If the same char don't cancel the balloon.    return 0 if $balloonLastIndex eq $balloonCharIndex;        # New char under mouse - cancel it so a new balloon will be posted.    $balloonLastIndex = $balloonCharIndex;    print ">$balloonLastIndex<\n";    return 1;}sub fileRender {    $text->clipboardClear ();    $text->clipboardAppend (render ());}sub fileOpen {    $currentFile = $text->FBox(-type => 'open', -filter => '*.PMEdit')->Show;        open inFile, '<', $currentFile or        $text->messageBox            (            -title => 'Save failed', -icon => 'error',            -type => 'Ok',            -message => "Unable to open '$currentFile' - $!"            );    my ($html, $name, $mode, $params);               while () {        my ($type, $index, $item) = /(\S+)\s(\S+)\s(.*)/;                if ($type =~ /^tago(?:n|ff)$/) {            next if $item =~ /^_/;            ($html, $name, $mode, $params) = @{$tagTypes{$item}};        }        if ($type eq '-tagon') {            print outFile "-tagon $item $index\n";        } elsif ($type eq '-tagoff') {            print outFile "-tagoff $item $index\n";        } elsif ($type eq '-text') {            print outFile "-text $item\n";        } else {            print "Token type $type at $index not handled.\n";        }    }        close inFile;}sub fileSave {    if (defined $currentFile and length $currentFile) {        doSave ($currentFile);    } else {        fileSaveAs ();    }}sub fileSaveAs {    my $filename = $text->FBox(-type => 'save', -filter => '*.PMEdit')->Show;    doSave ($filename);}sub doSave {    my $filename = shift;        return if ! defined $filename or ! length $filename;        open outFile, '>', $filename or        $text->messageBox            (            -title => 'Save failed', -icon => 'error',            -type => 'Ok',            -message => "Unable to create '$filename' - $!"            );    my @dumpText = $text->dump ('-tag', '-text', 'start', 'end');    my ($html, $name, $mode, $params);        while (@dumpText) {        my ($type, $item, $index) = splice @dumpText, 0, 3;                my $segEnd = exists $dumpText[2] ? $dumpText[2] : 'end';        if ($type =~ /^tago(?:n|ff)$/) {            next if $item =~ /^_/;            ($html, $name, $mode, $params) = @{$tagTypes{$item}};        }        if ($type eq 'tagon') {            print outFile "-tagon $index $item\n";        } elsif ($type eq 'tagoff') {            print outFile "-tagoff $index $item\n";        } elsif ($type eq 'text') {            print outFile "-text - $item\n";        } else {            print "Token type $type at $index not handled.\n";        }    }        close outFile;    $currentFile = $filename;}sub fileExit {    exit 1;}sub render {    my $result;    my $paragraph;    my $inCode = 0;    my @dumpText = $text->dump ('-tag', '-text', '1.0', 'end');    my ($html, $name, $mode, $params);        while (@dumpText) {        my ($type, $item, $index) = splice @dumpText, 0, 3;                next if $item =~ m'^(?:sel|para)';                my $segEnd = exists $dumpText[2] ? $dumpText[2] : 'end';        if ($type =~ /^tago(?:n|ff)$/) {            next if $item =~ /^(?:_|!)/;            ($html, $name, $mode, $params) = @{$tagTypes{$item}};        }                    if ($type eq 'tagon') {            if ($mode->{'L'}) {                my ($linkCode) = $html =~ /^\S*\s*(.*)/;                $paragraph .= "[$linkCode";                next;            }            $inCode = 1 if $item eq 'code';            $paragraph .= "<$tagTypes{$item}[0]>";        } elsif ($type eq 'tagoff') {            if ($mode->{'L'}) {                $paragraph .= ']';                next;            }                        $paragraph .= "";            if ($item eq 'code') {                $inCode = 0;            } else {            }        } elsif ($type eq 'text') {            $paragraph .= $item;            if ($paragraph =~ /\n/) {                if ($inCode) {                    $result .= $paragraph;                } else {                    $paragraph =~ tr/\n//d;                    if ($paragraph eq '

') { $result .= $paragraph; $paragraph = ''; } $result .= "

$paragraph

\n"; } $paragraph = ''; } } else { print "Token type $type at $index not handled.\n"; } } $result =~ s|

|
|g; return $result;}sub keyCommand { &doCommand ();}sub doCommand { my %newTag = (tag => shift); my @selections = $text->tagRanges('sel'); @newTag{'name', 'html', 'flags', 'params'} = @{$tagTypes{$newTag{tag}}}; do { if (@selections) { my %tags; @tags{$text->tagNames($selections[0])} = (); # Preset current tags $newTag{isOn} = ! exists $tags{$newTag{tag}}; # Complement new tag's curr state $tags{$newTag{tag}} ||= $newTag{isOn}; @newTag{'start', 'end'} = splice @selections, 0, 2; } else { my %activeTags; @activeTags{$text->tagNames('insert')} = (); return if ! exists $activeTags{$newTag{tag}}; @newTag{'start', 'end'} = $text->tagPrevrange ($newTag{tag}, 'insert'); $newTag{isOn} = 0; } return if ! defined $newTag{end}; my $msg = $newTag{flags}{L} ? manageLink (%newTag) : updateTextTags (%newTag); if (length $msg) { $status->configure (-text => $msg); return; } } while (@selections);}sub updateTextTags { my %newTag = @_; my @dumpText = $text->dump ('-tag', '-text', $newTag{start}, $newTag{end}); my @activeTags = $text->tagNames($newTag{start}); my %tags; @tags{@activeTags} = (1) x @activeTags; # Preset current tags $tags{$newTag{tag}} = $newTag{isOn}; TOKEN: while (@dumpText) { my ($type, $item, $index) = splice @dumpText, 0, 3; my $segEnd = exists $dumpText[2] ? $dumpText[2] : $newTag{end}; if ($type eq 'tagon') { $tags{$item} = 1 if $item ne $newTag{tag}; } elsif ($type eq 'tagoff') { $tags{$item} = 0 if $item ne $newTag{tag}; } elsif ($type eq 'text') { my @tagList = grep {! /^_|^sel$/ && $tags{$_}} keys %tags; my @removeList = grep {! $tags{$_} || /^_/} keys %tags; # Bail if current tags preclude new tag for (@tagList) { next if ! exists $tagTypes{$_} or $newTag{tag} eq $_; my ($Ihtml, $Iname, $Iflags, $Iparams) = @{$tagTypes{$_}}; # Check for existing tag that precludes all new tags if ($Iflags->{'X'}{'ALL'}) { next TOKEN } # Check for existing tag that precludes $newTag if ($Iflags->{'X'}{$newTag{tag}}) { next TOKEN; } } if ($newTag{isOn}) { if ($newTag{flags}->{'C'}{'ALL'}) { # Strip all other tags push @removeList, @tagList; } elsif (%{$newTag{flags}->{'C'}}) { # Clear specific tags push @removeList, keys %{$newTag{flags}->{'C'}}; } push @tagList, $newTag{tag}; } $text->tagRemove ($_, $index, $segEnd) for @removeList; @tagList = buildTag (@tagList); $text->tagAdd ($_, $index, $segEnd) for @tagList; fixParaSpacing ($index); } else { print "Token type $type at $index not handled.\n"; } } return '';}sub manageLink { my %newTag = @_; my @activeTags = $text->tagNames($newTag{start}); my %tags; if (! $newTag{isOn}) { # Remove the link $text->tagRemove ($newTag{tag}, $newTag{start}, $newTag{end}); updateTextTags (%newTag); return ''; } @tags{@activeTags} = (1) x @activeTags; # Preset current tags for (keys %tags) { next if ! exists $tagTypes{$_}; return 1 if $newTag{tag} eq $_ and $newTag{isOn}; # Link already my ($Ihtml, $Iname, $Iflags, $Iparams) = @{$tagTypes{$_}}; return "Can't link inside $Iname" if $Iflags->{'X'}{'ALL'}; return "Can't link inside $Iname" if $Iflags->{'X'}{'link'}; } return 'Links must not span line ends.' if int ($newTag{start}) != int ($newTag{end}); # Get the link text my $orgLinkText = $text->get($newTag{start}, $newTag{end}); my ($linkStr, $textStr) = $orgLinkText =~ /^([~|]*\|?)(.*)/; my $indexStr = "$newTag{start} +" . length ($linkStr) . 'chars'; my $linkEnd = $text->index ($indexStr); my %linkTag = %{clone (\%newTag)}; my %textTag = %{clone (\%newTag)}; $linkTag{end} = $linkEnd; $textTag{start} = $linkEnd; updateTextTags (%linkTag); updateTextTags (%textTag); return '';}sub buildTag { my %tags; @tags{@_} = (); my @tagList = sort keys %tags; my $newFormatTag = '_' . join '_', @tagList; my %options; my %fontParams; for (@tagList) { next if ! exists $tagTypes{$_} || ! ref $tagTypes{$_}; my ($html, $name, $mode, $params) = @{$tagTypes{$_}}; next if ! ref $params; for my $type (keys %$params) { if ($type =~ /-font/) { for my $subType (keys %{$params->{$type}}) { $fontParams{$subType} = $params->{$type}{$subType}; } } else { $options{$type} = $params->{$type}; } } } $options{-font} = buildFont (%fontParams) if %fontParams; $text->tagConfigure ($newFormatTag, %options); push @tagList, $newFormatTag; return @tagList;}sub buildFont { my %options = @_; my $fontName = ''; $fontName .= "$_|$options{$_}," for sort keys %options; $fontName =~ tr/-+/mp/; $fontName =~ tr/a-zA-Z0-9/mp_/c; $mw->fontCreate($fontName, %options) if ! $formatFonts{$fontName}++; return $fontName;}sub fixParaSpacing { my $lastLine = ($text->index ('end') =~ /(\d+)/)[0]; my $lastTailSpace = -(kParaSpace); my @paraTags; push @paraTags, "!para_$_" for (1..$lastLine); $text->tagDelete (@paraTags); # Clear current spacing tags for my $line (1..$lastLine) { my $headSpace = kParaSpace; my $tailSpace = kParaSpace; my @activeTags = $text->tagNames("$line.0"); # Note that this is currently broken if the first character happens to be a # part of a single spaced style applied to a partial line for (@activeTags) { next if ! exists $tagTypes{$_} || ! ref $tagTypes{$_}; my ($html, $name, $mode, $params) = @{$tagTypes{$_}}; next if ! ref $params; for my $type (keys %$params) { $headSpace = $params->{$type} if $headSpace && $type =~ /-spacing1/; $tailSpace = $params->{$type} if $tailSpace && $type =~ /-spacing3/; } } if ($lastTailSpace == -(kParaSpace)) { $headSpace = 0; } elsif ($lastTailSpace == 0 && $headSpace > 0) { $headSpace += kParaSpace; } elsif ($lastTailSpace > 0 && $headSpace == 0) { $headSpace += kParaSpace; } $text->tagConfigure("!para_$line", -spacing1 => $headSpace, -spacing3 => $tailSpace); $text->tagAdd ("!para_$line", "$line.0"); $text->tagRaise ("!para_$line"); $lastTailSpace = $tailSpace; }}sub trim { for (@_) { $$_ =~ s/^\s+//; $$_ =~ s/\s+$//; }}sub help { my $msg = <messageBox ( -icon => 'info', -message => $msg, -title => 'PerlMonks Editor Help', -type => 'Ok', );}sub about { my $msg = <messageBox ( -icon => 'info', -message => $msg, -title => 'About PerlMonks Editor', -type => 'Ok', );}__DATA__#tag style definitions#tag name,HTML tag, UI text, flags, modifiers as key value pairsbig,big,Big font,F,-font => [-size => 16]bold,b,Bold,F,-font => [-weight => bold]center,center,Centered text,P,code,code,Code block,BFXCU,-spacing1 => 0,-spacing3 => 0,-background => #e0e0ff,-font => [-family => courier, -weight => bold]cpan,link id://,CPAN link,L, -background => #c0c0c0, -foreground => #40e040,dd,dd,Definition Description,B,del,del,Deleted Text,F,dl,dl,Definition List,B,-lmargin1 => 20m, -lmargin2 => 20m, -rmargin => 20mdt,dt,Definition Term,B,-lmargin1 => 10m, -lmargin2 => 10m, -rmargin => 10m, -font => [-weight => bold]emphasis,em,Emphasis,F,-font => [-weight => bold]h3,h3,Header level 3,B,-font => [-size => 24], -background => #c0c0c0,-spacing1 => 14h4,h4,Header level 4,B,-font => [-size => 24], -background => #8080c0,-spacing1 => 10h5,h5,Header level 5,B,-font => [-size => 16], -background => #c0c0c0,-spacing1 => 10h6,h6,Header level 6,B,-font => [-size => 16], -background => #8080c0,-spacing1 => 8hrule,hr,Horizontal rule,BX,inserted,ins,ins,BF, -background => #ffffc0,italic,i,Italic,F,-font => [-slant => italic]item,li,List item,I,olist,ol,Ordered list,B,-lmargin1 => 20m, -lmargin2 => 20m, -rmargin => 20mquote,blockquote,Quoted block,P,-lmargin1 => 15m,-lmargin2 => 15m,-rmargin => 15mreadmore,readmore,Read more block,BR,-background => #a0b7cesmall,small,small,F,-font => [-size => 8]spoiler,spoiler,Spoiler,F, -background => #000000, -foreground => #404040,strike,strike,Strike Out,F,-overstrike => onstrong,strong,Strong emphasis,F,sub,sub,Sub script,FCsuper,-offset => -2p,-font => [-size => 8]super,sup,Super script,FCsub,-offset => 4p,-font => [-size => 8]teletype,Teletype text,tt,F,-font => [-family => courier], -background => #FFFFc0ulist,ul,Unordered list,B,-lmargin1 => 20m, -lmargin2 => 20m, -rmargin => 20munderline,u,Underline,F,[-underline => on]],#links - still tag style definitionsacronym,link acronym://,Acronym link,L, -background => #f0f0f0, -foreground => #0060c0,cpan,link cpan://,Cpan link,L, -background => #f0f0f0, -foreground => #00a0a0,dict,link dict://,Dictionary link,L, -background => #f0f0f0, -foreground => #00a0a0,dist,link dist://,CPAN Distro link,L, -background => #f0f0f0, -foreground => #00a0a0,doc,link doc://,perldoc link,L, -background => #f0f0f0, -foreground => #00a0a0,ftp,link ftp://,Ftp link,L, -background => #f0f0f0, -foreground => #00a0a0,google,link google://,Google link,L, -background => #f0f0f0, -foreground => #00a0a0,href,link href://,Href link,L, -background => #f0f0f0, -foreground => #00a0a0,http,link http://,Http link,L, -background => #f0f0f0, -foreground => #00a0a0,https,link https://,Https link,L, -background => #f0f0f0, -foreground => #00a0a0,id,link id://,Node id link,L, -background => #f0f0f0, -foreground => #00a0a0,isbn,link isbn://,Isbn link,L, -background => #f0f0f0, -foreground => #00a0a0,jargon,link jargon://,Jargon link,L, -background => #f0f0f0, -foreground => #00a0a0,kobes,link kobes://,Kobes link,L, -background => #f0f0f0, -foreground => #00a0a0,lj,link lj://,Live journal link,L, -background => #f0f0f0, -foreground => #00a0a0,lucky,link lucky://,Google lucky link,L, -background => #f0f0f0, -foreground => #00a0a0,mod,link mod://,Mod link,L, -background => #f0f0f0, -foreground => #00a0a0,module,link module://,Module link,L, -background => #f0f0f0, -foreground => #00a0a0,name,link,Node name link,L, -background => #f0f0f0, -foreground => #0060c0,pad,link pad://,Scratchpad link,L, -background => #f0f0f0, -foreground => #00a0a0,perldoc,link perldoc://,Perldoc link,L, -background => #f0f0f0, -foreground => #00a0a0,pmdev,link pmdev://,Pmdev link,L, -background => #f0f0f0, -foreground => #00a0a0,wp,link wp://,Wp link,L, -background => #f0f0f0, -foreground => #00a0a0,#key bindings, menu items and tool bar items#tag,key,menu item,toolbar item,right click itembig,Control 2,Format/Big,,Bigbold,Control Shift b,Format/Bold,,Bolditalic,Control i,Format/Italic,,Italicstrike,Control s,Format/Strike out,,Strike outsub,Control u,Format/Subscript,,Subscriptsuper,Control s,Format/Superscript,,Superscriptcode,Control c,Format/Code,,Codeid,,Links/Node,,Node id linkname,,Links/Name,,Name link

DWIM is Perl's answer to Gödel