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])/&$1/g;
$cb_xml =~ s/<([^CIm?\/])/<$1/g;
$cb_xml =~ s/<\/([^CIm?])/<\/$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);
|