Beefy Boxes and Bandwidth Generously Provided by pair Networks
Perl: the Markov chain saw
 
PerlMonks  

atcroft's scratchpad

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

2015-03-11

For Lady_Aleena:

use strict; use warnings FATAL => qw( all ); use Data::Dumper; $| = 1; $Data::Dumper::Deepcopy = 1; $Data::Dumper::Sortkeys = 1; local $\ = "\n"; my @laundry_loads = ( 'cottons', 'cold water items', 'sheets', 'uniforms', 'clothing of the day' ); my @laundry_tasks = ( 'wash', 'dry', 'fold' ); sub wash { my ( $load, $loads ) = @_; } sub dry { my ( $load, $loads ) = @_; } sub fold { my ( $load, $loads ) = @_; } my @progress = ( undef, undef, undef, ); my %task; foreach my $i ( 0 .. $#laundry_tasks ) { $task{ $laundry_tasks[$i] } = $i; } while ( my $load = shift @laundry_loads or scalar keys %task ) { print ""; foreach my $current_task ( reverse @laundry_tasks ) { if ( not scalar @laundry_loads and not(defined $task{$current_task} and defined $progress[ $task{$current_task} ] ) ) { delete $task{$current_task}; next; } if ( defined $progress[ $task{$current_task} ] ) { my $current_load = $progress[ $task{$current_task} ]; my $activity = qq{$current_task $current_load}; print $activity; if ( $current_task eq q{wash} and defined $progress[ $task{$current_task} ] ) { } if ( $current_task eq q{dry} and defined $progress[ $task{$current_task} ] ) { } if ( $current_task eq q{fold} and defined $progress[ $task{$current_task} ] ) { if ( $current_load =~ /sheets|uniforms|clothing of the day/ ) { my $new_load = $current_load eq 'sheets' ? 'laundry' : $current_load; print "put away $new_load"; } if ( $current_load eq 'sheets' ) { print 'vacuum the house'; print 'make the bed'; } if ( $current_load eq 'uniforms' ) { print 'take showers'; } pop @progress; } } } if ( defined $load ) { unshift @progress, $load; } else { unshift @progress, undef; } }
Output:
$ perl la-2.pl 2>&1 wash cottons dry cottons wash cold water items fold cottons dry cold water items wash sheets fold cold water items dry sheets wash uniforms fold sheets put away laundry vacuum the house make the bed dry uniforms wash clothing of the day fold uniforms put away uniforms take showers dry clothing of the day fold clothing of the day put away clothing of the day

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-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.


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;

# vim:set expandtab shiftwidth=4 softtabstop=2 tabstop=4:

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 );

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);
Log In?
Username:
Password:

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

How do I use this?Last hourOther CB clients
Other Users?
Others imbibing at the Monastery: (4)
As of 2024-03-29 08:53 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found