scratchpad
atcroft
<p>2015-03-11
<p>For [Lady_Aleena]:
<code>
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;
}
}
</code>
Output:
<code>
$ 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
</code>
<hr>
<p>2014-12-10
<p>Command-line example of using [cpan://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.)
<code>
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 ) ]
);
'</code>
<hr>
<p>2014-02-26
<p>git notes
<blockquote>
<p>Git Cheat Sheet (command-line)
<p>(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'.)
<p>To clone a repository:
<code>git clone ssh://user@githost/git/foo
cd foo
#Work to files in the repository</code>
<p>To view commit messages
<code>git log</code>
<p>View commit messages about a single file (second version will also follow through renames; third version will follow through copies and moves as well).
<code>git log file.txt
git log --follow file.txt
git log --follow -C -M file.txt</code>
<p>Other interesting log commands
<code>git log --graph
git log --graph --oneline
git log --graph --pretty=format':%C(yellow)%h%Cblue%d%Creset %s %C(white) %an, %ar%Creset'</code>
<p>Add files
<code>git add new-file-2.pl new-file-3.pl new-file-4.pl</code>
<p>View the status of files
<code>git status</code>
<p>Examine the differences between files in repository and those in the working directory
<code>git diff</code>
<p>Commit files (with message on command line)
<code>git commit -m "new-file-2.pl, new-file-3.pl, new-file-4.pl: Initial commit to version control."</code>
<p>Change a file's name
<code>git mv new-file-2.pl new-file.pl
git commit -m "new-file.pl: Rename file from new-file-2.pl."</code>
<p>Remove file from git, but leave in directory
<code>git rm --cached new-file-3.pl
git commit -m "new-file-3.pl: Remove file from Git repository (but leave in directory)."</code>
<p>Remove file from git (and directory!)
<code>git rm new-file-4.pl
git commit -m "new-file-4.pl: Remove file from Git repository."</code>
<p>Pull updates from the master branch of the bar repository
<code>git pull ssh://user@githost/git/bar/ master</code>
<p>List branches
<code>git branch</code>
<p>Create a branch from master called develop to work in, and switch to it
<code>git checkout -b develop master</code>
<p>Change back to master branch
<code>git checkout master</code>
<p>Merge changes from develop branch back into master branch
<code>git merge --no-ff develop</code>
<p>Delete a branch
<code>git branch -d develop</code>
<p>Amend previous commit to changing author information (example: when logged in as foo user)
<code>git commit --amend --author 'John Doe <jdoe@example.com>'</code>
<p>(bash specific) Temporarily change the author and committer values logged for a commit (opening $EDITOR to enter a commit message)
<p>(For instance, to make sure the right person receives credit for a particular set of changes.)
<code>GIT_COMMITTER_NAME="User 2" GIT_COMMITTER_EMAIL="user2@example.com" GIT_AUTHOR_NAME="User 1" GIT_AUTHOR_EMAIL="user1@example.com" git commit</code>
<p>Push changes to repository on githost
<code>git push ssh://user@githost/git/bar</code>
<!-- <p>On baz, in tsch, to set the EDITOR value used when committing
<code>setenv EDITOR /bin/vi</code> -->
<p>To set your name and email address in your account (please DO NOT do this in the foo account)
<code>git config --global user.name "John Doe"
git config --global user.email 'jdoe@example.com'</code>
<p>To set your default editor when editing comments/commits
<code>git config --global core.editor vi</code>
<p>To set your default diff tool
<code>git config --global merge.tool vimdiff</code>
<p>To see your current settings
<code>git config --list</code>
<p>To see which commits (and committers) made changes to each line of a file
<code>git blame some-file.pl</code>
<p>Optionally, between lines 100 and 200
<code>git blame -L 100,200 some-file.pl</code>
<p>Optionally, within the 51 lines after line 100 (inclusive)
<code>git blame -L 100,+51 some-file.pl</code>
<p>Creating and applying patch files
<p>To create patch files from a specific commit (example: commit starting db2b258)
<code>git format-patch -M -C -b -w -n --no-attach db2b268</code>
<p>To apply patch files to a repository (example: path from commit b50788b)
<code>git format-patch -1 b50788b</code>
<p>Move patch file to other repository
<p>Apply but not commit the patch
<p>('git apply' will apply a patch, but will not commit it)
<code>git apply 0001-First-pass-at-rake-task.patch</code>
<p>'git am' will apply a patch and commit it.
<code>git am 0001-First-pass-at-rake-task.patch</code>
<p>Merge the commit
<code>git merge b50788b</code>
<p>Ignore specific files or directories
<p>To ignore specific files or directories, add them to .gitconfig at the same directory level as the project's .git directory.
</blockquote>
<hr>
<p>05 Jan 2012
<p>Is the following a valid way of sub-classing (if that's a term) an object?
<p>Object A:
<code>
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;
</code>
<p>Object B:
<code>
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;
</code>
<p>Base object:
<code>
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;
</code>
<p>Sample code using object:
<code>
#!/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};
</code>
<hr>
<p>23 Feb 2011
<p>Sample code for a [rir|fellow monk] who was looking for a way to colorize differences within lines of a data file.
<code>
#!/usr/bin/perl
use strict;
use warnings;
use Getopt::Long;
$| = 1;
my @filename;
my %color = ( same => q{#000000}, file1 => q{#FF0000}, file2 => q{#0000FF}, );
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}, $color->{ ( $state ? q{file1} : q{same} ) }, $e1;
$out2 .= sprintf qq{</font><font color="%s">%s}, $color->{ ( $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; parameter 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 differing
portions. Written in #RRGGBB format. (default values are #000000,
#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
}
</code>
<hr>
<p>21 Apr 2007
<p>Sample code for a [freakingwildchild|fellow monk], in hopes it helps with the problem they were working on.
<code>
#!/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};
}
}
</code>
<hr>
<p>18 Mar 2007
<p>Sample code for a [zyx|fellow monk] in hopes of handling an XML config to a structure that had a unique "compound" key.
<code>
#!/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)]);
</code>
<hr>
<p>09 Dec 2006
<p>Sample code for a [kumarashishgupta|fellow monk] handling various cmd-line inputs with [cpan://Getopt::Long].
<code>
#!/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;
}
</code>
<hr>
<p>09 Dec 2006
<p>Testing results when looking at a problem for a [kumarashishgupta|fellow monk]. (Reference: [http://search.cpan.org/~jv/Getopt-Long-2.35/lib/Getopt/Long.pm#Options_with_multiple_values|Options with multiple values])
<p>Test script:
<code>
#!/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};
</code>
<p>Results:
<code>
$ 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}"
</code>
<p>(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.)
<hr>
<p>09 Nov 2006
<p>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.)
<code>
#!/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 for append: $!\n});
close(DF);
}
my $dbh = DBI->connect( qq{dbi:SQLite:dbname=$datafile}, q{}, q{}, { AutoCommit => 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 XML 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 0x%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]{author}, $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__
</code>
<hr>
<p>14 May 2006
<p>Sample code for an offline discussion with a fellow monk.
<ul>Files:
<li>w-test.pl - test program
<li>Exam/ATC.pm - module one object type comes from
<li>Test/AC1.pm - module other object type comes from
<li>My/Wrapper.pm - module containing "wrapper" object
</ul>
<p>w-test.pl :
<readmore>
<code>
#!/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';
}
</code>
</readmore>
<p>Exam/ATC.pm :
<readmore>
<code>
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;
</code>
</readmore>
<p>Test/AC1.pm :
<readmore>
<code>
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;
</code>
</readmore>
<p>My/Wrapper.pm :
<readmore>
<code>
#
# 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 methods.\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 methods.\n");
}
}
1;
</code>
</readmore>
<hr>
<code>
# vim:set expandtab shiftwidth=4 softtabstop=2 tabstop=4:
</code>
<hr>
<p>28 Jan 2006
<p>A look at some code for a fellow monk
<code>
print join(", ",
map{ q{<a href="link.pl?=} . $_ . q{" target="_blank" onclick="var winHandle = window.open('', '', 'width=400,height=200'); return(false);">} . $_ . q{</a>} } @array
);
</code>
<hr>
<p>25 Aug 2005
<p>Snippet of code to help out a fellow monk
<code>
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";
}
}
}
</code>
<hr>
<p>19-20 Jun 2005
<p>Sample code used to retrieve all messages from [Message Inbox] (stripped of username/passwords/etc)
<code>
#!/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 retrievals
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;op=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);
</code>