Beefy Boxes and Bandwidth Generously Provided by pair Networks
Perl-Sensitive Sunglasses
 
PerlMonks  

atcroft's scratchpad

by atcroft (Monsignor)
on Jun 01, 2004 at 16:21 UTC ( #358181=scratchpad: print w/ replies, xml ) Need Help??

2014-12-10

Command-line example of using YAML to write data structure to/read data structure from file. (Yes, I know the aren't in different seasons-that was just as an example.)

perl -Mstrict -Mwarnings -MData::Dumper -MYAML -le ' my @episode = ( q{The Librarians} => { q{1} => [ q{And the Crown of King Arthur}, q{And the Sword in the Stone}, q{And the Horns of a Dilemma}, q{And Santa"s Midnight Run}, ], q{2} => [ q{And the Apple of Discord}, q{And the Fables of Doom}, q{And the Rule of Three}, ], q{3} => [ q{And the Heart of Darkness}, q{And the City of Light}, q{And the Loom of Fate}, ], }, ); YAML::DumpFile( q{test.yml}, \@episode, ); my @stories = YAML::LoadFile( q{test.yml} ); print Data::Dumper->Dump( [ \@episode, \@stories, ], [ qw( *episode *stories ) ] ); '

2014-05-22

Chemical elements (1-118) as hash

my %element = ( 'by_name' => { 'Actinium' => 'Ac', 'Aluminium' => 'Al', 'Americium' => 'Am', 'Antimony' => 'Sb', 'Argon' => 'Ar', 'Arsenic' => 'As', 'Astatine' => 'At', 'Barium' => 'Ba', 'Berkelium' => 'Bk', 'Beryllium' => 'Be', 'Bismuth' => 'Bi', 'Bohrium' => 'Bh', 'Boron' => 'B', 'Bromine' => 'Br', 'Cadmium' => 'Cd', 'Caesium' => 'Cs', 'Calcium' => 'Ca', 'Californium' => 'Cf', 'Carbon' => 'C', 'Cerium' => 'Ce', 'Chlorine' => 'Cl', 'Chromium' => 'Cr', 'Cobalt' => 'Co', 'Copernicium' => 'Cn', 'Copper' => 'Cu', 'Curium' => 'Cm', 'Darmstadtium' => 'Ds', 'Dubnium' => 'Db', 'Dysprosium' => 'Dy', 'Einsteinium' => 'Es', 'Erbium' => 'Er', 'Europium' => 'Eu', 'Fermium' => 'Fm', 'Flerovium' => 'Fl', 'Flourine' => 'F', 'Francium' => 'Fr', 'Gadolinium' => 'Gd', 'Gallium' => 'Ga', 'Germanium' => 'Ge', 'Gold' => 'Au', 'Hafnium' => 'Hf', 'Hassium' => 'Hs', 'Helium' => 'He', 'Holmium' => 'Ho', 'Hydrogen' => 'H', 'Indium' => 'In', 'Iodine' => 'I', 'Iridium' => 'Ir', 'Iron' => 'Fe', 'Krypton' => 'Kr', 'Lanthanum' => 'La', 'Lead' => 'Pb', 'Lithium' => 'Li', 'Livermorium' => 'Lv', 'Lutetium' => 'Lu', 'Magnesium' => 'Mg', 'Manganese' => 'Mn', 'Meitnerium' => 'Mt', 'Mendelevium' => 'Md', 'Mercury' => 'Hg', 'Molybdenum' => 'Mo', 'Neodymium' => 'Nd', 'Neon' => 'Ne', 'Neptunium' => 'Np', 'Nickel' => 'Ni', 'Niobium' => 'Nb', 'Nitrogen' => 'N', 'Nobelium' => 'No', 'Osmium' => 'Os', 'Oxygen' => 'O', 'Palladium' => 'Pd', 'Phosphorous' => 'P', 'Platinum' => 'Pt', 'Plutonium' => 'Pu', 'Polonium' => 'Po', 'Potassium' => 'K', 'Praseodymium' => 'Pr', 'Promethium' => 'Pm', 'Protactinium' => 'Pa', 'Radium' => 'Ra', 'Radon' => 'Rn', 'Rhenium' => 'Re', 'Rhodium' => 'Rh', 'Roentgenium' => 'Rg', 'Rubidium' => 'Rb', 'Ruthenium' => 'Ru', 'Rutherfordium' => 'Rf', 'Samarium' => 'Sm', 'Scandium' => 'Sc', 'Seaborgium' => 'Sg', 'Selenium' => 'Se', 'Silicon' => 'Si', 'Silver' => 'Ag', 'Sodium' => 'Na', 'Strontium' => 'Sr', 'Sulfur' => 'S', 'Tantalum' => 'Ta', 'Technetium' => 'Tc', 'Tellurium' => 'Te', 'Terbium' => 'Tb', 'Thallium' => 'Tl', 'Thorium' => 'Th', 'Thulium' => 'Tm', 'Tin' => 'Sn', 'Titanium' => 'Ti', 'Tungsten' => 'W', 'Ununoctium' => 'Uuo', 'Ununpentium' => 'Uup', 'Ununseptium' => 'Uus', 'Ununtrium' => 'Uut', 'Uranium' => 'U', 'Vanadium' => 'V', 'Xenon' => 'Xe', 'Ytterbium' => 'Yb', 'Yttrium' => 'Y', 'Zinc' => 'Zn', 'Zircronium' => 'Zr', 'lawrencium' => 'Lr' }, 'by_symbol' => { 'Ac' => 'Actinium', 'Ag' => 'Silver', 'Al' => 'Aluminium', 'Am' => 'Americium', 'Ar' => 'Argon', 'As' => 'Arsenic', 'At' => 'Astatine', 'Au' => 'Gold', 'B' => 'Boron', 'Ba' => 'Barium', 'Be' => 'Beryllium', 'Bh' => 'Bohrium', 'Bi' => 'Bismuth', 'Bk' => 'Berkelium', 'Br' => 'Bromine', 'C' => 'Carbon', 'Ca' => 'Calcium', 'Cd' => 'Cadmium', 'Ce' => 'Cerium', 'Cf' => 'Californium', 'Cl' => 'Chlorine', 'Cm' => 'Curium', 'Cn' => 'Copernicium', 'Co' => 'Cobalt', 'Cr' => 'Chromium', 'Cs' => 'Caesium', 'Cu' => 'Copper', 'Db' => 'Dubnium', 'Ds' => 'Darmstadtium', 'Dy' => 'Dysprosium', 'Er' => 'Erbium', 'Es' => 'Einsteinium', 'Eu' => 'Europium', 'F' => 'Flourine', 'Fe' => 'Iron', 'Fl' => 'Flerovium', 'Fm' => 'Fermium', 'Fr' => 'Francium', 'Ga' => 'Gallium', 'Gd' => 'Gadolinium', 'Ge' => 'Germanium', 'H' => 'Hydrogen', 'He' => 'Helium', 'Hf' => 'Hafnium', 'Hg' => 'Mercury', 'Ho' => 'Holmium', 'Hs' => 'Hassium', 'I' => 'Iodine', 'In' => 'Indium', 'Ir' => 'Iridium', 'K' => 'Potassium', 'Kr' => 'Krypton', 'La' => 'Lanthanum', 'Li' => 'Lithium', 'Lr' => 'lawrencium', 'Lu' => 'Lutetium', 'Lv' => 'Livermorium', 'Md' => 'Mendelevium', 'Mg' => 'Magnesium', 'Mn' => 'Manganese', 'Mo' => 'Molybdenum', 'Mt' => 'Meitnerium', 'N' => 'Nitrogen', 'Na' => 'Sodium', 'Nb' => 'Niobium', 'Nd' => 'Neodymium', 'Ne' => 'Neon', 'Ni' => 'Nickel', 'No' => 'Nobelium', 'Np' => 'Neptunium', 'O' => 'Oxygen', 'Os' => 'Osmium', 'P' => 'Phosphorous', 'Pa' => 'Protactinium', 'Pb' => 'Lead', 'Pd' => 'Palladium', 'Pm' => 'Promethium', 'Po' => 'Polonium', 'Pr' => 'Praseodymium', 'Pt' => 'Platinum', 'Pu' => 'Plutonium', 'Ra' => 'Radium', 'Rb' => 'Rubidium', 'Re' => 'Rhenium', 'Rf' => 'Rutherfordium', 'Rg' => 'Roentgenium', 'Rh' => 'Rhodium', 'Rn' => 'Radon', 'Ru' => 'Ruthenium', 'S' => 'Sulfur', 'Sb' => 'Antimony', 'Sc' => 'Scandium', 'Se' => 'Selenium', 'Sg' => 'Seaborgium', 'Si' => 'Silicon', 'Sm' => 'Samarium', 'Sn' => 'Tin', 'Sr' => 'Strontium', 'Ta' => 'Tantalum', 'Tb' => 'Terbium', 'Tc' => 'Technetium', 'Te' => 'Tellurium', 'Th' => 'Thorium', 'Ti' => 'Titanium', 'Tl' => 'Thallium', 'Tm' => 'Thulium', 'U' => 'Uranium', 'Uuo' => 'Ununoctium', 'Uup' => 'Ununpentium', 'Uus' => 'Ununseptium', 'Uut' => 'Ununtrium', 'V' => 'Vanadium', 'W' => 'Tungsten', 'Xe' => 'Xenon', 'Y' => 'Yttrium', 'Yb' => 'Ytterbium', 'Zn' => 'Zinc', 'Zr' => 'Zircronium' } );

2014-02-26

git notes

Git Cheat Sheet (command-line)

(The examples below are fairly common examples of commands used with git. For these examples, the bare Git repository is located on the host githost, and accessible via ssh by an account called 'user'.)

To clone a repository:

git clone ssh://user@githost/git/foo cd foo #Work to files in the repository

To view commit messages git log

View commit messages about a single file (second version will also follow through renames; third version will follow through copies and moves as well).

git log file.txt git log --follow file.txt git log --follow -C -M file.txt

Other interesting log commands

git log --graph git log --graph --oneline git log --graph --pretty=format':%C(yellow)%h%Cblue%d%Creset %s %C(whi +te) %an, %ar%Creset'

Add files git add new-file-2.pl new-file-3.pl new-file-4.pl

View the status of files git status

Examine the differences between files in repository and those in the working directory git diff

Commit files (with message on command line) git commit -m "new-file-2.pl, new-file-3.pl, new-file-4.pl: Initial commit to version control."

Change a file's name

git mv new-file-2.pl new-file.pl git commit -m "new-file.pl: Rename file from new-file-2.pl."

Remove file from git, but leave in directory

git rm --cached new-file-3.pl git commit -m "new-file-3.pl: Remove file from Git repository (but lea +ve in directory)."

Remove file from git (and directory!)

git rm new-file-4.pl git commit -m "new-file-4.pl: Remove file from Git repository."

Pull updates from the master branch of the bar repository git pull ssh://user@githost/git/bar/ master

List branches git branch

Create a branch from master called develop to work in, and switch to it git checkout -b develop master

Change back to master branch git checkout master

Merge changes from develop branch back into master branch git merge --no-ff develop

Delete a branch git branch -d develop

Amend previous commit to changing author information (example: when logged in as foo user) git commit --amend --author 'John Doe <jdoe@example.com>'

(bash specific) Temporarily change the author and committer values logged for a commit (opening $EDITOR to enter a commit message)

(For instance, to make sure the right person receives credit for a particular set of changes.) GIT_COMMITTER_NAME="User 2" GIT_COMMITTER_EMAIL="user2@example.com" GIT_AUTHOR_NAME="User 1" GIT_AUTHOR_EMAIL="user1@example.com" git commit

Push changes to repository on githost git push ssh://user@githost/git/bar

To set your name and email address in your account (please DO NOT do this in the foo account)

git config --global user.name "John Doe" git config --global user.email 'jdoe@example.com'

To set your default editor when editing comments/commits git config --global core.editor vi

To set your default diff tool git config --global merge.tool vimdiff

To see your current settings git config --list

To see which commits (and committers) made changes to each line of a file git blame some-file.pl

Optionally, between lines 100 and 200 git blame -L 100,200 some-file.pl

Optionally, within the 51 lines after line 100 (inclusive) git blame -L 100,+51 some-file.pl

Creating and applying patch files

To create patch files from a specific commit (example: commit starting db2b258) git format-patch -M -C -b -w -n --no-attach db2b268

To apply patch files to a repository (example: path from commit b50788b) git format-patch -1 b50788b

Move patch file to other repository

Apply but not commit the patch

('git apply' will apply a patch, but will not commit it) git apply 0001-First-pass-at-rake-task.patch

'git am' will apply a patch and commit it. git am 0001-First-pass-at-rake-task.patch

Merge the commit git merge b50788b

Ignore specific files or directories

To ignore specific files or directories, add them to .gitconfig at the same directory level as the project's .git directory.

2013-10-28

#!/usr/bin/perl # http://www.thinkgeek.com/product/59e0/ use strict; use warnings; use vars qw( %clock ); use Data::Dumper; use Tk; use Tk::ProgressBar; $| = 1; srand(); $Data::Dumper::Sortkeys = 1; $clock{setting}{time_mode} = 0; $clock{setting}{hour_mode} = 0; $clock{setting}{brightness} = 2; $clock{setting}{cheat_mode} = 1; $clock{setting}{color}{0} = q{#008}; $clock{setting}{color}{1} = q{#00C}; $clock{setting}{color}{2} = q{#00F}; $clock{setting}{time} = q{00:00:00}; $clock{setting}{day_second} = 0; $clock{main} = new MainWindow; $clock{display} = $clock{main}->Frame() ->grid( -column => 0, -columnspan => 4, -row => 0, ); $clock{display}{canvas} = $clock{display}->Canvas( -height => 240, -width => 320, ) ->grid( -column => 0, -columnspan => 4, -row => 0, ); $clock{display}{label} = $clock{display}->Label( -textvariable => \$clock{setting}{time}, -state => q{normal}, )->grid( -column => 0, -columnspan => 2, -row => 1, ); $clock{display}{label2} = $clock{display}->Label( -textvariable => \$clock{setting}{day_second}, -state => q{normal}, )->grid( -column => 2, -columnspan => 2, -row => 1, ); $clock{display}{progress_bar} = $clock{display}->ProgressBar( -width => 20, -length => 320, -anchor => q{w}, -from => 0, -to => 86400, -blocks => 24, -colors => [ 0, 'blue', 21600, 'green', 43200, 'yellow', 64800, 'red', ], -variable => \$clock{setting}{day_second}, )->grid( -column => 0, -columnspan => 4, -row => 2, ); { my $active = q{#3333FF}; my $disabled = q{#000099}; my $border = q{#000066}; my $empty = q{#000000}; $clock{display}{canvas}{bg} = $clock{display}{canvas} ->createRectangle( 0, 0, 320, 240, -fill => q{#000000}, ); foreach my $column ( 0 .. 5 ) { foreach my $row ( 0 .. 3 ) { my $id; $clock{display}{canvas}{bulb}{$row}{$column} = $id = $clock{display}{canvas}->createOval( 10 + 50 * $column, 10 + 50 * $row, 10 + 45 + 50 * $column, 10 + 45 + 50 * $row, -outline => $border, -activefill => $clock{setting}{color} { $clock{setting}{brightness} }, -state => q{disabled}, ); } } } $clock{control} = $clock{main}->Frame() ->grid( -column => 0, -columnspan => 4, -row => 6, ); $clock{control}->Label( -text => q{Binary mode:} ) ->grid( -column => 0, -columnspan => 2, -row => 0, ); $clock{control}->Radiobutton( -text => q{BCD}, -value => 0, -variable => \$clock{setting}{time_mode}, )->grid( -column => 2, -row => 0, ); $clock{control}->Radiobutton( -text => q{"True"}, -value => 1, -variable => \$clock{setting}{time_mode}, )->grid( -column => 3, -row => 0, ); $clock{control}->Label( -text => q{Hour mode:} ) ->grid( -column => 0, -columnspan => 2, -row => 1, ); $clock{control}->Radiobutton( -text => q{24h}, -value => 0, -variable => \$clock{setting}{hour_mode}, )->grid( -column => 2, -row => 1, ); $clock{control}->Radiobutton( -text => q{12h}, -value => 1, -variable => \$clock{setting}{hour_mode}, )->grid( -column => 3, -row => 1, ); $clock{control}->Label( -text => q{Brightness:} ) ->grid( -column => 0, -row => 2, ); $clock{control}->Radiobutton( -text => q{low}, -value => 0, -variable => \$clock{setting}{brightness}, )->grid( -column => 1, -row => 2, ); $clock{control}->Radiobutton( -text => q{medium}, -value => 1, -variable => \$clock{setting}{brightness}, )->grid( -column => 2, -row => 2, ); $clock{control}->Radiobutton( -text => q{high}, -value => 2, -variable => \$clock{setting}{brightness}, )->grid( -column => 3, -row => 2, ); if (0) { $clock{control}->Label( -text => q{Cheat mode:} ) ->grid( -column => 0, -columnspan => 2, -row => 3, ); $clock{control}->Radiobutton( -text => q{Off}, -value => 0, -variable => \$clock{setting}{cheat_mode}, )->grid( -column => 2, -row => 3, ); $clock{control}->Radiobutton( -text => q{On}, -value => 1, -variable => \$clock{setting}{cheat_mode}, )->grid( -column => 3, -row => 3, ); } $clock{repeat} = $clock{display}{canvas}->repeat( 500, \&check_up ); MainLoop; sub check_up { &check_brightness; &check_time; } sub check_brightness { foreach my $column ( 0 .. 5 ) { foreach my $row ( 0 .. 3 ) { $clock{display}{canvas}->itemconfigure( $clock{display}{canvas}{bulb}{$row}{$column}, -disabledfill => $clock{setting}{color} { $clock{setting}{brightness} }, ); } } } sub check_time { &clear_time; if ( $clock{setting}{time_mode} ) { &check_time_true; } else { &check_time_bcd; } } sub get_hms { $clock{setting}{day_second} = time % 86400; my ( $sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst ) = localtime; $mon++; $year += 1900; $clock{setting}{time} = substr( scalar localtime, 11, 8 ); $clock{setting}{day_second} = ( ( $hour * 60 ) + $min ) * 60 + $sec; $hour %= 12 if ( $clock{setting}{hour_mode} ); return ( $hour, $min, $sec, 0 ); } sub clear_time { foreach my $column ( 0 .. 5 ) { foreach my $row ( 0 .. 3 ) { $clock{display}{canvas}->itemconfigure( $clock{display}{canvas}{bulb}{$row}{$column}, -state => q{normal}, ); } } } sub check_time_bcd { my $tstr; { my @ts = map { my $s = sprintf q{%#04B}, $_; $s =~ s/^0B//; substr( q{0000} . $s, -4 ); } split //, join( '', map { sprintf q{%02d}, $_; } get_hms() ); foreach my $column ( 0 .. 5 ) { foreach my $row ( 0 .. 3 ) { if ( substr( $ts[$column], $row, 1 ) eq q{0} ) { $clock{display}{canvas}->itemconfigure( $clock{display}{canvas}{bulb}{$row} {$column}, -state => q{normal}, ); } else { $clock{display}{canvas}->itemconfigure( $clock{display}{canvas}{bulb}{$row} {$column}, -state => q{disabled}, ); } } } } } sub check_time_true { my $tstr; { my @ts = map { my $s = sprintf q{%#06B}, $_; $s =~ s/^0B//; substr( q{000000} . $s, -6 ); } get_hms(); foreach my $column ( 0 .. 5 ) { foreach my $row ( 0 .. 3 ) { if ( substr( $ts[$row], $column, 1 ) eq q{0} ) { $clock{display}{canvas}->itemconfigure( $clock{display}{canvas}{bulb} { $row + 1 }{$column}, -state => q{normal} ); } else { $clock{display}{canvas}->itemconfigure( $clock{display}{canvas}{bulb} { $row + 1 }{$column}, -state => q{disabled} ); } } } } } __END__

05 Jan 2012

Is the following a valid way of sub-classing (if that's a term) an object?

Object A:

package Letter_A; use strict; use warnings; our @ISA = qw( Letter ); sub new { my $class = shift; my %_hash = ( my_type => $class, letter => q{A}, ); bless \%_hash, $class; } 1;

Object B:

package Letter_B; use strict; use warnings; our @ISA = qw( Letter ); sub new { my $class = shift; my %_hash = ( my_type => $class, letter => q{B}, ); bless \%_hash, $class; } 1;

Base object:

package Letter; use strict; use warnings; sub new { my $class = shift; my %_hash; if ( scalar @_ and $_[0] eq q{A} ) { require Letter_A; my $s = Letter_A->new(); return bless $s, $class; } if ( scalar @_ and $_[0] eq q{B} ) { require Letter_B; my $s = Letter_B->new(); return bless $s, $class; } # } else { %_hash = ( my_type => $class, letter => q{}, ); bless \%_hash, $class; # } } sub identify { my $self = shift; print q{I am a '} . $self->{my_type} . q{'} . qq{\n}; } 1;

Sample code using object:

#!/usr/bin/perl use strict; use warnings; use lib q{.}; use Data::Dumper; use Letter; my $s = Letter->new(q{B}); $s->identify; print Data::Dumper->Dump( [ \$s ], [qw( *s )] ), qq{\n};

23 Feb 2011

Sample code for a fellow monk who was looking for a way to colorize differences within lines of a data file.

#!/usr/bin/perl use strict; use warnings; use Getopt::Long; $| = 1; my @filename; my %color = ( same => q{#000000}, file1 => q{#FF0000}, file2 => q{#000 +0FF}, ); my $outfile = $0 . q{.html}; if ( scalar( grep( /^-/, @ARGV ) ) ) { my @local_color; GetOptions( 'filename:s' => \@filename, 'outputfile:s' => \$outfile, 'color:s' => \@local_color, 'help' => \&help, ); @filename = split( /,/, join( ',', @filename ) ); while ( scalar @filename > 2 ) { pop @filename; } @local_color = split( /,/, join( ',', @local_color ) ); if ( scalar @local_color >= 3 ) { $color{same} = $local_color[0]; $color{file1} = $local_color[1]; $color{file2} = $local_color[2]; } if ( scalar @filename < 2 ) { warn qq{Too few input files listed!\n}; &help; } } else { &help; } # # Actual code here # open my $INF1, $filename[0] or die $!; open my $INF2, $filename[1] or die $!; open my $OUTF, q{>}, $outfile or die $!; write_header( $OUTF, \@filename, $outfile, \%color ); my $i = 0; process_files( $INF1, $INF2, $OUTF, \$i, \@filename, \%color ); process_files( $INF1, $INF2, $OUTF, \$i, \@filename, \%color ); process_remaining_file( $INF1, $OUTF, 0, \$i, \@filename, \%color ); close $INF1; process_remaining_file( $INF2, $OUTF, 1, \$i, \@filename, \%color ); close $INF2; write_footer($OUTF); close $OUTF; sub process_files { my ( $INF1, $INF2, $OUTF, $linecount, $fn, $color ) = @_; while ( defined $INF1 and defined $INF2 ) { my @p1; my @p2; my $l1 = <$INF1>; last unless defined $l1; chomp $l1; @p1 = split //, $l1; my $l2 = <$INF2>; last unless defined $l2; chomp $l2; @p2 = split //, $l2; $$linecount++; my $out1 = sprintf q{<font color="%s">%06d: }, $color->{same}, + $$linecount; my $out2 = sprintf q{<font color="%s">%06d: }, $color->{same}, + $$linecount; my $state = 0; while ( scalar @p1 and scalar @p2 ) { my $e1 = shift @p1; my $e2 = shift @p2; if ( ( ( ord $e1 == ord $e2 ) and ( !$state ) ) or ( ( ord + $e1 != ord $e2 ) and ($state) ) ) { $out1 .= $e1; $out2 .= $e2; } else { $state = !$state; $out1 .= sprintf qq{</font><font color="%s">%s}, $colo +r->{ ( $state ? q{file1} : q{same} ) }, $e1; $out2 .= sprintf qq{</font><font color="%s">%s}, $colo +r->{ ( $state ? q{file2} : q{same} ) }, $e2; } } if ( scalar @p1 ) { if ($state) { $out1 .= sprintf qq{%s</font>}, join( q{}, @p1 ); } else { $out1 .= sprintf qq{</font><font color="%s">%s</font>} +, $color->{file1}, join( q{}, @p1 ); } } elsif ( scalar @p2 ) { if ($state) { $out2 .= sprintf qq{%s</font>}, join( q{}, @p2 ); } else { $out2 .= sprintf qq{</font><font color="%s">%s</font>} +, $color->{file2}, join( q{}, @p2 ); } } $out1 .= qq{</font>\n}; $out2 .= qq{</font>\n}; print $OUTF $out1, $out2, qq{\n}; } } sub process_remaining_file { my ( $inhandle, $outhandle, $file_id, $linecount, $fn, $color ) = +@_; while ( defined $inhandle ) { my $line = <$inhandle>; last unless defined $line; $$linecount++; chomp $line; my $out1; my $out2; if ($file_id) { $out1 = sprintf qq{%06d: -%s closed-\n}, $$linecount, $fn- +>[0]; $out2 = sprintf qq{%06d: <font color="%s">%s</font>\n}, $$ +linecount, $color->{file2}, $line; } else { $out2 = sprintf qq{%06d: -%s closed-\n}, $$linecount, $fn- +>[1]; $out1 = sprintf qq{%06d: <font color="%s">%s</font>\n}, $$ +linecount, $color->{file1}, $line; } print $outhandle $out1, $out2, qq{\n}; } } sub help { printf <<HELPTEXT, $0, $0; %s -filename file1,file2 [-color #same,#file1,#file2] [-outputfile outfile] [-help] -filename file1,file2 - files to process (only the first 2 will be processed; parame +ter may appear twice or names may be comma-separated -outputfile outfile - file HTML output is written to (default value is %s.html) -color #same,#file1,#file2 - colors used for output of portions of line that match and di +ffering portions. Written in #RRGGBB format. (default values are #0000 +00, #FF0000, and #0000FF). -help - display this help text HELPTEXT exit; } sub write_header { my ( $OUTF, $filename, $outfilename, $color ) = @_; print $OUTF <<HEADER <html> <head> </head> <body> <p>Output filename: $outfilename</p> <table> <tr> <td>File</td> <td>Color</td> </tr> <tr> <td><font color="$color{same}">$color{same}</font></td> <td>Matching</td> </tr> <tr> <td><font color="$color{file1}">$color{file1}</font></td> <td>$filename->[0]</td> </tr> <tr> <td><font color="$color{file2}">$color{file2}</font></td> <td>$filename->[1]</td> </tr> </table> <hr /> <pre> HEADER } sub write_footer { my ($OUTF) = @_; print $OUTF <<FOOTER; </pre> </body> </html> FOOTER }

21 Apr 2007

Sample code for a fellow monk, in hopes it helps with the problem they were working on.

#!/usr/bin/perl -lw use strict; use Data::Dumper; my $h = { info => { a => 1, b => 2, }, q{info (1)} => { a => 3, c => 4, d => 5, }, q{test (1)} => { e => 5, f => { g => 6, h => 7, }, }, }; test($h); print Data::Dumper->Dump([\$h], [qw(*h)]); sub test { my $self = $_[0]; my @k = grep { /\s+\(1\)$/; } keys %{$self}; foreach my $t (@k) { my $s = $t; $s =~ s/\s+\(1\)$//; if (exists $self->{$s}) { foreach my $i ( keys %{$self->{$t}} ) { if (exists($self->{$s}->{$i})) { if (ref($self->{$s}->{$i}) ne q{ARRAY}) { my $tmp = $self->{$s}->{$i}; delete $self->{$s}->{$i}; push @{$self->{$s}->{$i}, $tmp; } push @{$self->{$s}->{$i}}, $self->{$t}->{$i}; } else { $self->{$s}->{$i} = $self->{$t}->{$i}; } } } else { $self->{$s} = $self->{$t}; } delete $self->{$t}; } }

18 Mar 2007

Sample code for a fellow monk in hopes of handling an XML config to a structure that had a unique "compound" key.

#!/usr/bin/perl -l use strict; use warnings; use Data::Dumper; use XML::Simple; my $bla = XMLin("primary.xml", ForceArray => [ qw(package) ], KeyAttr => [ ], ); foreach my $i (0 .. $#{$bla->{package}}) { # The combination of fields name, epoch, # version, release and arch are (unique). $bla->{temp}{sprintf("%s-%s-%s-%s-%s", $bla->{package}[$i]{name}, $bla->{package}[$i]{version}{ver}, $bla->{package}[$i]{version}{rel}, $bla->{package}[$i]{version}{epoch}, $bla->{package}[$i]{arch}, )} = $bla->{package}[$i]; } ($bla->{package}, $bla->{temp}) = ($bla->{temp}, $bla->{package}); delete($bla->{temp}); print Data::Dumper->Dump( [\$bla], [qw(*bla)]);

09 Dec 2006

Sample code for a fellow monk handling various cmd-line inputs with Getopt::Long.

#!/usr/bin/perl -w use strict; use Getopt::Long; use Data::Dumper; $| = 1; my (@foo); my ($bar); my $baz = 0; my $bop = 0; my $quux; if ( scalar( grep( /^-/, @ARGV ) ) ) { GetOptions( 'foo:s' => \@foo, 'bar:s' => \$bar, 'baz+' => \$baz, 'gazonk+' => sub { $bop = !$bop; $bop += 0; }, 'quux' => sub { $quux = scalar localtime; }, 'help' => \&help, ); @foo = split( /,/, join( ',', @foo ) ); print Data::Dumper->Dump( [ \@foo, \$bar, \$baz, \$bop, \$quux ], [qw(*foo *bar *baz *bop *quux)] ), qq{\n}; if ( !$baz ) { if ( !scalar(@foo) ) { &help; } if ( ( !defined($bar) ) or ( !length($bar) ) ) { &help; } } } else { &help; } sub help { printf <<HELPTEXT, $0, ( 'alice[,bob,eve]', 'xyzzy' ) x 2; %s [-foo %s] [-bar %s] [-baz] [-gazonk] [-quux] [-help] -foo %s - one or more options, either comma-separated or the option listed more than once -bar %s - another option -baz - a flag -gazonk - another flag, trying to flip on/off -quux - option which results in a subroutine being called -help - display this help text HELPTEXT exit; }

09 Dec 2006

Testing results when looking at a problem for a fellow monk. (Reference: Options with multiple values)

Test script:

#!/usr/bin/perl -w use strict; use Getopt::Long qw(:config debug); my @coor; my @color; GetOptions( 'coordinates=f{2}' => \@coor, 'rgbcolor=i{3}' => \@color ); print qq{Coordinates:\n} . join( qq{\n\t}, @coor ), qq{\n}, qq{RGBcolor:\n} . join( qq{\n\t}, @color ), qq{\n};

Results:

$ perl gol-test.pl --coordinates 52.2 16.4 --rgbcolor 255 255 149 Getopt::Long 2.34 ($Revision: 2.68 $) called from package "main". ARGV: (--coordinates 52.2 16.4 --rgbcolor 255 255 149) autoabbrev=1,bundling=0,getopt_compat=1,gnu_compat=0,order=1, ignorecase=1,requested_version=0,passthrough=0,genprefix="(--|-|\+)" +. Error in option spec: "coordinates=f{2}" Error in option spec: "rgbcolor=i{3}"

(Note to self: If you're testing something that's listed as an experimental feature, make sure you have the version of the module that implements it.)


09 Nov 2006

Sample code for a fellow monk, of how to create a SQLite db from scratch. (Taken from a personal project for backing up PM private messages.)

#!/usr/bin/perl -w use strict; use DBI; use DBD::SQLite; use Data::Dumper; use Getopt::Long; use LWP::Simple; use XML::Simple; $| = 1; print $DBD::SQLite::VERSION, qq{\n}; print $DBD::SQLite::sqlite_version, qq{\n}; my $datafile = $0 . q{.sqlite}; if ( scalar grep( /^-/, @ARGV ) ) { GetOptions( "help|?" => sub { &help($datafile) }, "datafile=s" => \$datafile, ); } if ( !-e $datafile ) { open( DF, q{>>} . $datafile ) or die(qq{Couldn't open $datafile fo +r append: $!\n}); close(DF); } my $dbh = DBI->connect( qq{dbi:SQLite:dbname=$datafile}, q{}, q{}, { A +utoCommit => 0 } ); test_table_existance($dbh); # my $cb_xml_url = q{http://www.perlmonks.org/index.pl?node_id=207304} +; my $cb_xml_url = q{358181.pl.1132118668.xml}; foreach my $cb_xml_url (@ARGV) { next unless ( -f $cb_xml_url ); print $cb_xml_url, qq{\n}; # Setup my $xs = new XML::Simple; my $cb_xml; open( DF, $cb_xml_url ) or die($!); { my @temp = <DF>; chomp @temp; $cb_xml = join( qq{\n}, @temp ); $cb_xml =~ s/&([^a])/&amp;$1/g; $cb_xml =~ s/<([^CIm?\/])/&lt;$1/g; $cb_xml =~ s/<\/([^CIm?])/&lt;\/$1/g; } # my $cb_xml = get($cb_xml_url) or die(qq{Could not retrieve CB XM +L ticker: $!\n}); if ( $cb_xml =~ m/[\x00-\x08\x0b-\x0c\x0e-\x1f]/ ) { my @parts = split( //, $cb_xml ); foreach my $c ( 0 .. $#parts ) { if ( $parts[$c] =~ m/[\x00-\x08\x0b-\x0c\x0e-\x1f]/ ) { $parts[$c] = sprintf( '<!-- XML disallowed character 0 +x%x detected -->', ord( $parts[$c] ) ); } } $cb_xml = join( '', @parts ); } my $ref = $xs->XMLin( $cb_xml, ForceArray => [q{message}] ) or die +(qq{Could not parse CB XML: $!\n}); # print Data::Dumper->Dump( [ \$ref ], [qw(*ref)] ), "\n"; my $ior_updateinfo = q{ INSERT OR REPLACE INTO updateinfo ( updateinfo_id, archived, foruser, foruser_id, gentimeGMT, hard_limit, max_recs, min_poll_seconds, since_id, site, sitename, style, content ) VALUES ( NULL, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ? ); }; my $iorus = $dbh->prepare($ior_updateinfo); my $iorur = $iorus->execute( $ref->{INFO}{archived}, $ref->{INFO}{foruser}, $ref +->{INFO}{foruser_id}, $ref->{INFO}{gentimeGMT}, $ref->{INFO}{hard_limit}, $ref +->{INFO}{max_recs}, $ref->{INFO}{min_poll_seconds}, $ref->{INFO}{since_id}, $ref +->{INFO}{site}, $ref->{INFO}{sitename}, $ref->{INFO}{style}, $ref +->{INFO}{content}, ) or die( $dbh->errstr ); my $ior_message = q{ INSERT OR REPLACE INTO message ( message_id, author, status, time, user_id, content ) VALUES ( ?, ?, ?, ?, ?, ? ); }; my $iorms = $dbh->prepare($ior_message); foreach my $i ( 0 .. $#{ $ref->{message} } ) { my $iormr = $iorms->execute( $ref->{message}[$i]{message_id}, $ref->{message}[$i]{autho +r}, $ref->{message}[$i]{status}, $ref->{message}[$i]{q{time}}, $ref->{message}[$i]{user_ +id}, $ref->{message}[$i]{content}, ) or die( $dbh->errstr ); } $dbh->commit; } $dbh->disconnect; do_maintainance($datafile); # # Subroutines # sub help { my ($datafile) = @_; printf <<HELP_TEXT, $datafile; Usage: $0 [-help| -?] [-datafile filename] -help | -? - display this help message and exit. -datafile filename - name of SQLite database file to use (created if does not exist, default: %s). HELP_TEXT exit(0); } sub do_maintainance { my ($datafile) = @_; my @maintainence_query = ( q{ VACUUM updateinfo; }, q{ VACUUM message; }, ); foreach my $i ( 0 .. $#maintainence_query ) { my $maintenance = $maintainence_query[$i]; my $pre_fs = ( stat($datafile) )[7]; my $pre_time = time; $dbh = DBI->connect( qq{dbi:SQLite:dbname=$datafile}, q{}, q{} + ); $dbh->do($maintenance); $dbh->disconnect; my $post_time = time; my $post_fs = ( stat($datafile) )[7]; if ( $pre_fs != $post_fs ) { printf qq{Vacuuming of database table %d lead to a change of +%d bytes in size (from %d to %d bytes, in %d seconds)\n}, $i, ( $post_fs - $pre_fs ), $pre_fs, $post_fs, ( $post +_time - $pre_time ); } } } sub test_table_existance { { my ($dbh) = @_; my $tables_query = q{ SELECT COUNT(name) FROM ( SELECT * FROM sqlite_master UNION ALL SELECT * FROM sqlite_temp_master ) WHERE type='table'; }; my $tqs = $dbh->prepare($tables_query); my $tqr = $tqs->execute; my @row_tqr = $tqs->fetchrow_array; $tqs->finish; if ( !$row_tqr[0] ) { my @creation_query = ( q{ CREATE TABLE updateinfo ( updateinfo_id INTEGER, archived TEXT, foruser TEXT, foruser_id INTEGER, gentimeGMT TEXT, hard_limit INTEGER, max_recs INTEGER, min_poll_seconds INTEGER, since_id INTEGER, site TEXT, sitename TEXT, style TEXT, content TEXT, UNIQUE(gentimeGMT, updateinfo_id) ); }, q{ CREATE TABLE message ( message_id INTEGER, author TEXT, status TEXT, time INTEGER, user_id INTEGER, content TEXT, UNIQUE(message_id) ); }, q{ CREATE INDEX ui_idx ON updateinfo ( updateinfo_id ); }, q{ CREATE INDEX m_idx ON message ( message_id ); }, q{ CREATE INDEX m_idx_2 ON message ( author, status, user +_id, time, content ); }, ); foreach my $i ( 0 .. $#creation_query ) { my $cr = $dbh->do( $creation_query[$i] ); } $dbh->commit; } } } __END__

14 May 2006

Sample code for an offline discussion with a fellow monk.

    Files:
  • w-test.pl - test program
  • Exam/ATC.pm - module one object type comes from
  • Test/AC1.pm - module other object type comes from
  • My/Wrapper.pm - module containing "wrapper" object

w-test.pl :

#!/usr/bin/perl use strict; use warnings; use Data::Dumper; use Exam::ATC; use Test::AC1; use My::Wrapper; my @possible_methods = qw( get_a get_b get_ set_ get_value set_value get set wrapper_get +wrapper_set ); my $wrapper = My::Wrapper->new(); my $something = Exam::ATC->new(qw(a b c d)); $wrapper->set_original_object($something); $wrapper->set('a'); print Dumper($wrapper); print "the value of [c] is [", $wrapper->get('c'), "]\n"; foreach my $method (@possible_methods) { printf "the object %s $method\n", $wrapper->can($method) ? 'can' : 'cannot'; } my $object = Test::AC1->new(qw(a b c d)); $wrapper->set_original_object($object); $wrapper->set('c'); print Dumper($wrapper); print "the value of [a] is [", $wrapper->get('a'), "]\n"; foreach my $method (@possible_methods) { printf "the object %s $method\n", $wrapper->can($method) ? 'can' : 'cannot'; }

Exam/ATC.pm :

use strict; use warnings; package Exam::ATC; sub new { my $class = shift; my %attribs = @_; my $href = {}; $href->{var1} = 'this is set in new'; foreach my $key ( keys %attribs ) { $href->{$key} = $attribs{$key}; } my $obj = bless( $href, $class ); return $obj; } sub get_value { my ( $self, $k ) = @_; $k ||= q{a}; return $self->{$k}; } sub set_value { my ( $self, $k, $v ) = @_; if ( defined($v) ) { $self->{$k} = $v; } else { delete( $self->{$k} ); } } 1;

Test/AC1.pm :

use strict; use warnings; package Test::AC1; sub new { my $class = shift; my %attribs = @_; my $href = {}; $href->{var1} = 'this is set in new'; foreach my $key ( keys %attribs ) { $href->{$key} = $attribs{$key}; } my $obj = bless( $href, $class ); return $obj; } sub get_ { my ( $self, $k ) = @_; $k ||= q{a}; return $self->{$k}; } sub set_ { my ( $self, $k, $v ) = @_; if ( defined($v) ) { $self->{$k} = $v; } else { delete( $self->{$k} ); } } 1;

My/Wrapper.pm :

# # My/Wrapper.pm # use strict; use warnings; package My::Wrapper; sub new { my $class = shift; my $self = bless {}, $class; if (@_) { $self->{orig_obj} = $_[0]; } return $self; } sub wrapper_get { my $self = shift; my ($k) = @_; $k ||= q{orig_obj}; return $self->{$k}; } sub wrapper_set { my $self = shift; my ( $k, $v ) = @_; if ( defined($v) ) { $self->{$k} = $v; } else { delete( $self->{$k} ); } } sub get_original_object { my $self = shift; # return $self->{orig_obj}; return $self->wrapper_get('orig_obj'); } sub set_original_object { my $self = shift; # $self->{orig_obj} = $_[0]; $self->wrapper_set( 'orig_obj', $_[0] ); } # Test::AC1 - get_, set_ # Exam::ATC - get_value, set_value sub get { my $self = shift; my $wrapped_obj = $self->get_original_object; if ( $wrapped_obj->can('get_') ) { return $wrapped_obj->get_(@_); } elsif ( $wrapped_obj->can('get_value') ) { return $wrapped_obj->get_value(@_); } else { warn("Wrapped object supports neither get_ nor get_value metho +ds.\n"); } } sub set { my $self = shift; my $wrapped_obj = $self->get_original_object; if ( $wrapped_obj->can('set_') ) { return $wrapped_obj->set_(@_); } elsif ( $wrapped_obj->can('set_value') ) { return $wrapped_obj->set_value(@_); } else { warn("Wrapped object supports neither set_ nor set_value metho +ds.\n"); } } 1;

08 Mar 2006

An attempt to help a fellow monk solve a problem.

#!/usr/bin/perl -w # vim:set expandtab shiftwidth=4 softtabstop=2 tabstop=4: use strict; use Data::Dumper; use XML::LibXML; use XML::LibXSLT; use XML::XPath; my $xml_results = q{<tr> <td>Floor</td> <td><a href="http://www.example.com/path/to/files/filename1.pld" targe +t=_blank>Floor 1</a><a href="http://www.example.com/path/to/files/fil +ename2.pdf" target=_blank><img src=./images/icon_pdf.gif width=18 hei +ght=12 border=0 alt='Adobe Acrobat PDF File'></a> (PDF)<br></td> <td >Local Time (24 hr)</td> <td><p><script language="JavaScript"> Ser +verClock(); </script><noscript>Wed 21:58:50 </noscript></p></td> </tr> }; # # Since there was a comment that there was no control over the source +HTML.... # (and yes, I know it probably only works with the sample data).... # $xml_results =~ s/(=)([^\"\'\s\>]+)/$1"$2"/gis; $xml_results =~ s/(\<br)(\>)/$1\/$2/gis; $xml_results =~ s/(\<img[^\>]+)(>)/$1\/$2/gis; =pod # # For reference-the expressions worked with this # $xml_results = q{<tr> <td>Floor</td> <td><a href="http://www.example.com/path/to/files/filename1.pld" targe +t=_blank>Floor 1</a><a href="http://www.example.com/path/to/files/fil +ename2.pdf" target=_blank><img src=./images/icon_pdf.gif width=18 hei +ght=12 border=0 alt='Adobe Acrobat PDF File'></a> (PDF)<br></td> <td >Local Time (24 hr)</td> <td><p><script language="JavaScript"> Ser +verClock(); </script><noscript>Wed 21:58:50 </noscript></p></td> </tr> }; =cut # # No user-editable data below this point. # $| = 1; # Initialize the parser and XSLT processor my $parser = XML::LibXML->new(); my $xslt = XML::LibXSLT->new(); my $source_doc = $parser->parse_string($xml_results); # Initialize the XPath processor my $xp = XML::XPath->new( xml => $xml_results ); my ($stylesheet); { my $stylesheetdata = q{ <xsl:stylesheet version="1.0" xmlns:xsl="http://www.w3.org/1999/XSL/Tr +ansform"> <xsl:output method="html" encoding="iso-8859-1" indent="no"/> <xsl:template match="/"> <xsl:value-of select="//tr/td[preceding-sibling::td/text()='Local +Time (24 hr)' and position()=4]/p/noscript/text()"/> </xsl:template> </xsl:stylesheet> }; my $style_data = $parser->parse_string($stylesheetdata); $stylesheet = $xslt->parse_stylesheet($style_data); } my $result = $stylesheet->transform($source_doc); print $stylesheet->output_string($result);

02 Feb 2006

An attempt at finding the longest substring that appears twice in a larger string.

#!/usr/bin/perl -w use strict; my ($str); open(DF, q{43.txt}) or die(qq{Can't open 43.txt for input: $!\n"}); { my @string = <DF>; chomp(@string); $str = join('', @string); } close(DF); foreach my $to_consider (reverse(1..length($str) - 2)) { foreach my $start_at (0..length($str) - $to_consider - 1) { my $str1 = substr($str, $start_at, $to_consider); foreach my $against (1..length($str) - $to_consider) { if (substr($str, $start_at + $against, $to_consider) eq $str) { printf qq{Found at %d and %d, of length %d\n}, $start_at, $start_at + $against, $to_consider; exit; } } } }

28 Jan 2006

A look at some code for a fellow monk

print join(", ", map{ q{<a href="link.pl?=} . $_ . q{" target="_blank" onclick="var w +inHandle = window.open('', '', 'width=400,height=200'); return(false) +;">} . $_ . q{</a>} } @array );

17 Nov 2005

Attempt at converting lyrics to perl poetry (not intended to run).... (Original lyrics at http://www.lyricsfreak.com/v/vince-gill/144500.html)

# Title: Go Rest High on that Mountain # Artist: Vince Gill # Lyrics: http://www.lyricsfreak.com/v/vince-gill/144500.html # I know your $life{on_earth} = 'troubled'; { your $pain = 1; } your $afraid = 0; open(DEVIL); $known{rain} = 1; chorus(); our %cries = ( day => 'you left us', number => many ); %we = ( location => 'gathered round your grave', reason => 'to grieve' ); my ($wish); while ($angels{hear} == ( your $voice = 'sweet')) { $angels{faces}->display; } chorus() foreach ( 0 .. 1 ); sub chorus { goto REST_HIGH_ON_THAT_MOUNTAIN; REST_HIGH_ON_THAT_MOUNTAIN: your $work{on_earth} = 'done'; goto HEAVEN; HEAVEN: $you->shouting('love for the Father and the Son'); }

(Backstory: The song was used in a funeral service recently for someone I knew. A few days later, I picked up a CD which, unknown to me at the time, contained the song.)


25 Aug 2005

Snippet of code to help out a fellow monk

for my $host (keys %hosts) { for my $servicename ( @{$hosts{$host}} ) { for my $protocol (keys %{$services{$servicename}}) { my $portnumber = $services{$servicename}{$protocol}; print "$host $servicename $protocol $portnumber\n"; } } }

19-20 Jun 2005

Sample code used to retrieve all messages from Message Inbox (stripped of username/passwords/etc)

#!/usr/bin/perl use strict; use warnings; use Data::Dumper; use Festival::Client; use File::Spec; use HTTP::Cookies; use HTTP::Request::Common qw{POST}; use LWP; use XML::Simple; $| = 1; # Information for Festival server to connect to # (undef as port value to use default port) my %festival_server = ( host => q{localhost}, port => undef, ); # The following values are in seconds. # $delay - approximate delay between Message Inbox XML Ticker retrieva +ls my $delay = 90; # $seen - holds message id of last message seen my $seen = 0; # Setup my $username = '(your username here)'; my $password = '(your password here)'; my $xs = new XML::Simple; my $cookie_jar = File::Spec->catfile( File::Spec->tmpdir(), join ( q{.}, ( File::Spec->splitpath($0) )[2] ) . q{.cj} ); my $pm_server = q{www.perlmonks.com}; my $pm_port = 80; my $pm_base = q{http://} . $pm_server . ( $pm_port != 80 ? q{:} . $pm_port : '' ) . q{/}; my $li_xml_url = $pm_base . q{/index.pl?node_id=109;displaytype=xml;xmlstyle=flat;nofields=1;o +p=login;ticker=1;user=} . $username . q{;passwd=} . $password; my $last_mi = 0; my $max_recs = 20; my $mi_xml_url = sprintf( q{%sindex.pl?node_id=%d;archived=%s;xmlstyle=%s;max_recs=%d;since_id=% +%d}, $pm_base, 15848, q{both}, q{default}, $max_recs ); my ($fs); my ($browser); my ($ref); my ($combined_mi); # Attempt to log in $browser = LWP::UserAgent->new; $browser->cookie_jar( HTTP::Cookies->new( file => $cookie_jar, autosave => 1 ) ); my $li_xml = $browser->get($li_xml_url) or die ( scalar localtime() . q{: } . qq{Could not log into the site: $!\n} ); $ref = $xs->XMLin( $li_xml->content, ForceArray => [q{loggedin}] ) or die ( scalar localtime() . q{: } . qq{Could not parse information regarding login to site XML: $! +\n} ); # Do not proceed if we did not successfully log in die ( scalar localtime() . q{: } . qq{Could not log into PM: $!\n} ) unless ( exists( $ref->{loggedin} ) ); my $count = 10_000 ; # There should NEVER be more than this number messages, at worst while ($count) { my $mi_xml = $browser->get( sprintf( $mi_xml_url, $last_mi ) ) or warn( scalar localtime() . q{: } . qq{Could not retrieve Message Inbox XML ticker: $!\n} ); $ref = $xs->XMLin( $mi_xml->content, ForceArray => [q{message}] ) or die ( scalar localtime() . q{: } . qq{Could not parse Message Inbox XML: $!\n} ); if ( !exists( $combined_mi->{INFO} ) ) { $combined_mi->{INFO} = $ref->{INFO}; } $delay = $ref->{INFO}->{min_poll_seconds}; print qq{Delay: $delay\n}; # Check to see if there are message entries last unless ( exists( $ref->{message} ) ); foreach my $message ( @{ $ref->{message} } ) { push ( @{ $combined_mi->{message} }, $message ); if ( $message->{message_id} > $seen ) { $seen = $message->{message_id}; printf( "%s-%s-%s %s:%s:%s - %s: %s\n", substr( $message->{time}, 0, 4 ), substr( $message->{time}, 4, 2 ), substr( $message->{time}, 6, 2 ), substr( $message->{time}, 8, 2 ), substr( $message->{time}, 10, 2 ), substr( $message->{time}, 12, 2 ), $message->{author}, $message->{content} ); $last_mi = $message->{message_id} if ( $message->{message_id} > $last_mi ); } } print scalar localtime(), q{: }, qq{Asked for $max_recs, retrieved }, scalar @{ $ref->{message} }, qq{\n}; last if ( scalar @{ $ref->{message} } != $max_recs ); print qq{Last message id: $last_mi\n}; print qq{Sleeping for $delay seconds...\n}; sleep($delay); } my ($OUTF); open( $OUTF, q{>} . $0 . q{.3.out} ) or die (qq{$! \n}); $xs->XMLout( $combined_mi, ( AttrIndent => 1, KeepRoot => 1, NoEscape => 1, OutputFile => $OUTF, RootName => q{CHATTER}, XMLDecl => 1 ) ); close($OUTF);

04 Apr 2005

Sample ~/.cpan/CPAN/MyConfig.pm, as an example for a fellow monk:

$CPAN::Config = { 'build_cache' => q[10], 'build_dir' => qq[$ENV{HOME}/.cpan/build], 'cache_metadata' => q[1], 'cpan_home' => qq[$ENV{HOME}/.cpan], 'ftp' => q[/usr/bin/ftp], 'ftp_proxy' => q[], 'getcwd' => q[cwd], 'gpg' => q[/usr/bin/gpg], 'gzip' => q[/bin/gzip], 'histfile' => qq[$ENV{HOME}/.cpan/histfile], 'histsize' => q[100], 'http_proxy' => q[], 'inactivity_timeout' => q[0], 'index_expire' => q[1], 'inhibit_startup_message' => q[0], 'keep_source_where' => qq[$ENV{HOME}/.cpan/sources], 'lynx' => q[/usr/bin/lynx], 'make' => q[/usr/bin/make], 'make_arg' => q[], 'make_install_arg' => q[], 'makepl_arg' => q[], 'ncftpget' => q[/usr/bin/ncftpget], 'no_proxy' => q[], 'pager' => q[/usr/bin/less], 'prerequisites_policy' => q[ask], 'scan_cache' => q[atstart], 'shell' => q[/bin/bash], 'tar' => q[/bin/tar], 'term_is_latin' => q[1], 'unzip' => q[/usr/bin/unzip], 'urllist' => [q[file://$ENV{HOME}/reference/cpan/], q[http://cpan.pa +ir.com/], q[http://cpan.belfry.net/], q[http://cpan.mirrors.nks.net/] +, q[http://www.perl.com/CPAN/]], 'wget' => q[/usr/bin/wget], }; 1; __END__

14 Mar 2005

Proposed title: Re^8: Smart match in p5

Proposed node content: (Posted content of node now in node 439427, Re^8: Smart match in p5 )


02 Jan 2005

#!/usr/bin/perl -w use strict; use Tk; my %options = ( grid => 0 ); my (%objects); my $mw = MainWindow->new; # $objects{button}{exit} = $mw->Button( -text => 'Exit', -command => s +ub { exit } )->pack( -side => 'bottom', -fill => 'x' ); $objects{button}{exit} = $mw->Button( -text => 'Exit', -command => sub { exit } ) ->grid( -row => 5, -column => 0, -columnspan => 10, -sticky => 'nsew +' ); my $frame = $objects{frame}{c1} = $mw->Frame( -background => 'blue', -borderwidth => 1, -label => 'con +trol', -relief => 'groove' ); $objects{label}{i1} = $frame->Label( -anchor => 'w', -text => 'I-1' )- +>grid( -row => 0, -column => 0 ); # $objects{label}{i2} = $frame->Label( -text => 'I-2' )->grid( -row => + 2, -column => 0 ); # $objects{label}{i3} = $frame->Label( -text => 'I-3' )->grid( -row + => 0, -column => 2 ); # $objects{label}{i4} = $frame->Label( -text => 'I-4' )->grid( -row +=> 2, -column => 2 ); $objects{frame}{c1}->grid( -row => 0, -column => 0, -rowspan => 4, -co +lumnspan => 10, -sticky => 'nsew' ); MainLoop;

29 Oct 2004

An attempt to help a fellow monk with a problem.

#!/usr/bin/perl use strict; use warnings; use File::Find; my $base = '/var/www/noc/calendarsPostCalendars'; my $s1 = 'POSTCALENDARN'; my $s2 = 'POSTCALENDARS'; my $s3 = 'postcalendarn_'; my $s4 = 'postcalendars_'; my $s5 = 'PostCalendarn'; my $s6 = 'PostCalendars'; find(\&wanted, $base); sub wanted { if ((-f $File::Find::name) && ($File::Find::name !~ m/\.bak/)) { my $file = $File::Find::name; my $file_old = $file . '.bak'; rename($file, $file_old); open(IN, $file_old) or die($!); open(OUT, '>' . $file) or die($!); while (<IN>) { s/$s1/$s2/; s/$s3/$s4/; s/$s5/$s6/; print OUT $_; } close(OUT); close(IN); } }

26 Oct 2004

WTH?!?!?!? Why does the following not seem to work?

Output:

$ perl test.6.pl Content-seen: 1 Content:

Code:

#!/usr/bin/perl -w use strict; use vars qw(@files); use Data::Dumper; use File::Find; use File::Glob qw(:glob); use Pod::Simple; no warnings 'File::Find'; # per suggestion of the docs for File::Find $| = 1; my (@searchpath); foreach my $i ( 0 .. $#INC ) { push( @searchpath, File::Glob::bsd_glob( $INC[$i], GLOB_TILDE | GLOB_ERR ) ); } find( { wanted => \&wanted, no_chdir => 1 }, @searchpath ); sub wanted { if ( $File::Find::name =~ m/Find\.pm$/ ) { push( @files, $File::Find::name ); } } my ($content); open( DF, $files[0] ) or die("Can't open $files[0] for input: $!\n"); { local ( $/ = undef ); $content = <DF>; } close(DF); my $podcontent = ''; my $parser = Pod::Simple->new(); $parser->output_string( \$podcontent ); $parser->parse_string_document($content); print "Content-seen:\n", $parser->content_seen, "\n"; print "Content:\n", $podcontent, "\n"; # print Data::Dumper->Dump( [ \$parser, \$content, \$podcontent ], # [qw(*parser *content *podcontent)] ), "\n";

22 Oct 2004

Why does not behave? An attempt at writing a module for handling base operations for the Tower of Hanoi problem. (Adapted from code on pages 103-4, _Object_Oriented_Perl_ by Dr. Damian Conway.)

The new constructor does not seem to take the default values from $_class_defaults.</code> <code> package Tower; use strict; use Data::Dumper; { my $_class_defaults = { _count_disks => 3, _count_pegs => 5, _display_move => 1, _display_tower => 1, _movecount => 0, _tower => {}, _tower_keys => (), }; sub _class_defaults { $_class_defaults; } sub _class_defaults_keys { map { s/^_//; $_ } keys %$_class_defaults; } sub _initialize { my ($self) = @_; @{ $self->{_tower_keys} } = ( 'A' .. chr( ord('A') + $self->{_count_pegs} ) ); foreach ( @{ $self->{_tower_keys} } ) { @{ $self->{_tower}{$_} } = (); } $self->_add_to_tower( reverse( 1 .. $self->{_count_pegs} ) ); } sub _remove_from_tower { my $self = shift; my $tower_name = shift; return pop @{ $self->{_tower}{$tower_name} }; } sub _add_to_tower { my $self = shift; my $tower_name = shift; push @{ $self->{_tower}{$tower_name} }, @_; } } sub on_tower { my $self = shift; my $tower = shift; return scalar @{ $self->{_tower}{$tower} }; } sub tower_top { my $self = shift; my $tower = shift; if ( scalar( @{ $self->{_tower}{$tower} } ) ) { return $self->{_tower}{$tower} $#{ $self->{_tower}{$tower} } ; } else { return undef; } } sub tower_keys { my $self = shift; @{ $self->{_tower_keys} }; } sub move_count { my $self = shift; $self->{_movecount}; } sub move { my $self = shift; my ( $from, $to ) = @_; if ( scalar( @{ $self->{_tower}{$from} } ) ) { my $piece = $self->_remove_from_tower($from); $self->_add_to_tower( $to, $piece ); $self->{_move_count}++; $self->_display_move( $piece, $from, $to ); $self->_display_tower; } else { warn("WARNING: $from contains no disks\n"); } } sub new {

Log In?
Username:
Password:

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

How do I use this? | Other CB clients
Other Users?
Others meditating upon the Monastery: (8)
As of 2014-12-26 08:43 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

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





    Results (168 votes), past polls