Beefy Boxes and Bandwidth Generously Provided by pair Networks Frank
Keep It Simple, Stupid
 
PerlMonks  

atcroft's scratchpad

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

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>

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 { my ( $caller, %arg ) = @_; my $class = ref($caller); my $defaults = $class ? $caller : $caller->_class_defaults(); $class ||= $caller; my $self = bless {}, $class; foreach my $attribute ( $class->_class_defaults_keys ) { $self->{"_$attribute"} = ( exists $arg{"_$attribute"} ? $arg{" +_$attribute"} : $defaults->{"_$attribute"} ); } $self->_initialize; return ($self); } sub DESTROY { my ($self) = @_; foreach ( @{ $self->{_tower_keys} } ) { @{ $self->{_tower}{$_} } = (); delete( $self->{_tower}{$_} ); } delete( $self->{_tower} ); @{ $self->{_tower_keys} } = (); } sub display_tower { my $self = shift; if ( $self->{_display_tower} ) { foreach my $t ( @{ $self->{_tower_keys} } ) { printf( "%s: %s\n", $t, ( defined( $self->{_tower}{$t} ) and scalar( @{ $self->{_tower}{$t} } ) ? join( ' + ', @{ $self->{_tower}{$t} } ) : ' ' ) ); } } } sub display_move { my $self = shift; my ( $piece, $from, $to ) = @_; if ( $self->{_display_move} ) { printf( "%s: %s => %s\n", $piece, $from, $to ); } }

24 Sep 2004

Proposed title: Suggestions for nodes to use to test CSS

Proposed node content:

(Posted content of node now in node 393403, Suggestions for nodes to use to test CSS )


10 Sep 2004

Potential answer to I've got a hash of hashes how do i get my values out, that handles multilevel data containing only scalars, arrays, or hashes: (Posting, code, and sample run are now in node 390153, Answer: I've got a hash of hashes how do i get my values out )


01-02 Jul 2004

Not sure where this could/should go, but is an attempt at a JAPH using Term::ANSIScreen. Not really an obfu, and didn't know if anyone would care, but here it is. (Posting and code are now in node 371396, JAPH attempt using Term::ANSIScreen )


29 May 2004

#!/usr/bin/perl -w use strict; use vars qw($ft @filelist @typelist @spinner $bigscape $scale $index); use File::Find; use File::Glob qw(:glob); use File::Type; use GD; use Image::GD::Thumbnail; use Image::Size; use Tk; use Tk::JPEG; use Tk::PNG; use Tk::TIFF; use Tk::Thumbnail; use Tk::Stderr; $| = 1; my @spinner = ( '|', '/', '-', '\\' ); my $bigscale = 10_000; my $scale = 100; my $index = 0; my (@directories_to_search); foreach my $dir ( ( scalar(@ARGV) > 0 ? @ARGV : '.' ) ) { push( @directories_to_search, bsd_glob( $dir, GLOB_TILDE | GLOB_ERR ) ); } print join( "\n", @directories_to_search ), "\n\n"; $ft = File::Type->new(); find( { wanted => \&wanted, follow_skip => 2, no_chdir => 1 }, @directories_to_search ); print "\n"; my (%images); { my @templist = sort { $a cmp $b } @filelist; @filelist = @templist; } foreach ( 0 .. $#filelist ) { next unless ( length($_) ); my ( $x, $y ) = imgsize( $filelist[$_] ); printf "[%4d, %4d] %30s %s\n", $x, $y, $typelist[$_], $filelist[$_]; } my $mw = MainWindow->new(); my $stderrw = MainWindow->new->InitStderr; $mw->title($0); { my (@imagelist); foreach ( 0 .. $#filelist ) { print $filelist[$_], "\n"; my $temp = $mw->Photo( -file => $filelist[$_] ); push( @imagelist, $temp ); } eval { my $thumb = $mw->Thumbnail( -images => [@imagelist], -ilabels => 1 )->pack; }; warn($@) if ($@); } MainLoop; sub wanted { &spinner; return unless ( -R $File::Find::dir ); return unless ( defined($File::Find::name) ); return unless ( -f $File::Find::name ); return unless ( -R $File::Find::name ); my ($type_from_file); eval { $type_from_file = $ft->checktype_filename($File::Find::name); printf "Unknown type: %s\n", $File::Find::name unless ( defined($type_from_file) ); }; return unless ( defined($type_from_file) ); if ( $type_from_file =~ m/image/ ) { push( @filelist, $File::Find::name ); push( @typelist, $type_from_file ); } } sub spinner { print $spinner[ ( $index++ / $scale ) % 4 ], "\b"; print '.' unless ( $index % $bigscale ); }

(< 27 May 2004)

An *UNTESTED* attempt to add a method to add data to a CGI::Persistent object that is not in the inherited CGI.pm query string. Assumes user has already handled converting the value to be stored into some form of string, and that user will handle the conversion back as well.

package CGI::Persistent::Nonquery; require CGI::Persistent; require Data::Dumper; use base CGI::Persistent; use strict; use vars qw(@ISA $VERSION); ( $VERSION ) = '$Revision: 0.01 $' =~ /(\d+\.\d+)/; sub add_data { my ( $self, $name, $value ) = @_; my $fn = $self->param( '.id' ); my $po = new Persistence::Object::Simple __Fn => $fn; $self->param( -name => $name, -values => $po->{$name} ) unless $name eq "__Fn"; $po->{$name} = $value; $po->commit (); return $self; } "True Value";

(< 27 May 2004)

# # $nonetwork, $nogateway, and $nobroadcast sent as 0 if to be # displayed in list, 1 if to be removed # (gateway assumed at start of block) # sub print_inblock { my ($block, $cidr, $nonetwork, $nogateway, $nobroadcast) = @_; my $machines = 2**(32 - $cidr); my $lip = unpack("N", pack("C4", split(/\D/, $block, 4))); for (my $i = ($nonetwork + $nogateway); $i < ($machines - $nobroadcast); $i++) { my $result = $lip + $i; print(join('.', unpack("C4", pack("N", $res))), "\n"); } } # # Sample call (10.0.32.0/20, do not display network, gateway, # or broadcast address in listing) # &print_inblock("10.0.32.0", 20, 1, 1, 1);

(< 27 May 2004)

Code sample attempting to help a fellow monk parse an RSS feed from Yahoo:

use strict; use warnings; use Data::Dumper; use Date::Manip; use LWP::Simple; use XML::Simple; # Needed on some platforms, such as Microsoft Windows &Date_Init("TZ=CST6CDT"); # Set timeframe to display entries for (-1 day apparently goes back to + midnight today) my ($truncdate, $tderr); my $dateback = "-1 day"; $truncdate = DateCalc("today", $dateback, \$tderr); my $xs = new XML::Simple; # my $feedfile = 'science'; # my $ref = $xs->XMLin($feedfile); my $feedurl = 'http://rss.news.yahoo.com/rss/science'; my $feedline = get($feedurl) or die("Couldn't open feed: $!\n"); my $ref = $xs->XMLin($feedline); foreach my $item (@{$ref->{'channel'}->{'item'}}) { my $itemDate = ParseDate($item->{'pubDate'}); if (Date_Cmp($itemDate, $truncdate) > 0) { foreach (qw(title link pubDate description)) { $item->{$_} =~ s/[\r\n]+/ /g; print uc($_), "\n", $item->{$_}, "\n"; } print "\n"; } } # print Data::Dumper->Dump([\$ref], [qw(*ref)]), "\n";
Sample output:
TITLE
Swiss Adventurer Plans Solar-Powered Flight (Reuters)
LINK
http://us.rd.yahoo.com/dailynews/rss/753/*http://story.news.yahoo.com/news?tmpl=story2&u=/nm/20031129/sc_nm/switzerland_flight_dc
PUBDATE
Sat, 29 Nov 2003 18:18:33 GMT
DESCRIPTION
Reuters - Swiss adventurer Bertrand Piccard, the first man to pilot a balloon around the world non-stop, has announced plans to circle the planet in a specially built solar-powered aircraft.


(< 27 May 2004)

*UNTESTED* diff of possible patch to Devel::Tinderclient to check if cvs update is needed
(original was renamed tinderclient.pl.original, result of 'diff -u tinderbox.pl.original tinderbox.pl')

--- tinderbox.pl.original Mon Sep 22 11:22:53 2003 +++ tinderbox.pl Mon Sep 22 11:41:43 2003 @@ -77,6 +77,11 @@ if ($Tinderconfig::cvs) { Log($log,"about to cvs checkout $Tinderconfig::cvsmodule:\n"); + system("cvs -z3 diff $Tinderconfig::cvsmodule > /dev/null"); + if ($? == 0) { + Log($log,"No diff detected against current cvs.\n\n"); + return(undef); + } Log($log,`cvs -z3 co $Tinderconfig::cvsmodule 2>&1`); # do the chec +kout Log($log,"cvs checkout complete\n\n"); } @@ -193,4 +198,4 @@ exit(); } exec("$0"); -exit(); \ No newline at end of file +exit();

(< 27 May 2004)

sub inblock-cidr { my ($block, $cidr, $target) = @_; my $result = 1; my $machinebits = (32 - $cidr); my $lip1 = unpack("N", pack("c4", split(/\D/, $block, 4))); my $lip2 = unpack("N", pack("c4", split(/\D/, $target, 4))); $result = 0 if (($lip1 >> $machinebits) != ($lip2 >> $machinebits)); return($result); } sub inblock-mask { my ($block, $mask, $target) = @_; my $result = 1; my $machinebits = unpack("N", pack("c4", split(/\D/, $mask, 4))); my $lip1 = unpack("N", pack("c4", split(/\D/, $block, 4))); my $lip2 = unpack("N", pack("c4", split(/\D/, $target, 4))); $result = 0 if (($lip1 & $machinebits) != ($lip2 & $machinebits)); return($result); } &inblock-cidr('10.0.0.0', 8, '10.13.23.42'); &inblock-mask('10.0.0.0', '255.0.0.0', '10.13.23.42');

(< 27 May 2004)

<!-- Re: What's the biggest piece of work you've done alone with Perl?

Not so large code-wise, but definitely large in importance to my job. In a period of less than 45 days between August and the first week of October of last year, I wrote the core to a distributed replacement for the provisioning system for the company I work for.

The system contains components for doing provisioning into systems that connectivity and services for customers, that use a generic stub and their own custom (to their application) functions loaded at run time, each of which look for new items to provision in a database table, then may connect to a remote server to add the appropriate provisioning data, or directly or over an SSH connection call a helper application for provisioning the item (depending on the system involved).

Partial list of main items used:

  • Strategies:
    • Generic stub that loads and calls routines specific to the item being provisioned
    • Provisioning events themselves generally use of external "helper" applications, allowing for concurrent development, and eliminating wait for testing of all components if development of one helper application fell behind
    • Error checking, error checking, and... oh, did I mention error checking?
  • Techniques
    • Locking mechanisms that prevent multiple copies from running, in case provisioning for one item took longer than expected
    • eval() and other methods for loading components at run-time
    • Allowed for multiple methods of handing off to external helpers, including bi-directional pipes, system() calls, and remote connections, either direct to services or via SSH connections
  • Modules:
  • Brands of caffeine:
    • Coffee, tea, and other forms of caffeinated drinks-as long as it had caffeine, it helped
Biggest mistake(s)
  • Having to learn several major technologies during the development of the project, such as LDAP
  • Failing to manage the stress (and effects) of such a project until it was done (failure to meet the deadline would have had considerable impact on the company for which I work).

Developed in-house in under 45 days, it replaced a well-known commercial Java-based solution that (as I understand it) cost several hundred thousand dollars and took over a year to be deployed (and still had issues). It has since proven itself to be both quicker and more stable.

My thanks to a number of people, including

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 romping around the Monastery: (11)
As of 2014-04-18 12:31 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    April first is:







    Results (466 votes), past polls