#!/usr/bin/perl -w
use strict;
=head1 NAME
xml_pimp
=head1 DESCRIPTION
xml_pimp.pl - You heard of statswhore?
You heard (x)luke_repwalker?
Well dis da pimp!
=head2 What? You I<didn't> hear of luke_repwalker I<or> statswhore?
Well xml_pimp is a I<perl> script, that will grab some I<xml tickers>
from the perlmonks website, and keep track of your xp changes
(that is, of course, I<if> you have a perlmonks account).
xp related activities are generally referred to as xp-whorin'
=head2 SO I<HOW> IS IT DIFFERENT?
It differs from the above in one fundamental way:
it keeps track of all changes.
It's differs very little from statswhore in functionality,
but provides no mail or database support like (x)luke_repwalker.
Where the forementioned overwrite the master I<snapshot> file
upon each run, da pimp generates a I<differential> snapshot,
comprising of the differences between the previous and current
snapshots, and appends it to the snapshot file.
The actual I<snapshot> consists of C<Data::Dumper> generated output,
ready for C<eval>.
The more you know, the more you know (I<originally:> the more you wann
+a know).
=head1 SYNOPSIS
$> perl xml_pimp -[options] >IamOnDosSoImRedirectingInCaseItsAlot.txt
$> perl xml_pimp.pl -f (this should be the default, but its not ;)
$> perl xml_pimp.pl -h12
$> perl xml_pimp.pl -u username -f
$> perl xml_pimp.pl -f -uuser -p pass (WARNING **see SECURITY for det
+ails)
=head1 OPTIONS
-f fetch a new snapshot, compare w/current status
-? help
-h Display current INFO
-help Display full pod
-h1 Display node history
-h2 Display INFO history
-u username (if you don't supply -p as well, you'll be prompted)
-p password (WARNING **see SECURITY for more info)
current INFO status at always included at the end
INFO are stats like level, xp, xp2next level, etc.
=head1 SECURITY
It is B<reccomended> that you manually set C<$user> and C<$pass>.
The two variables are located around line 80.
Why? -- because
C<perl xml_pimp.pl -u user -p pass> is considered B<I<insecure>>.
Especially on unix/linux systems that come armed with C<ps> (most are)
+.
However, I do use Term::ReadKey to read in the password, so the
C<-p> option is optional
Also, since the I<snapshots> are Data::Dumper output, and are being
C<eval>'ed, you should make sure you don't C<chmod> the data file
(F<.yourusername.xml_pimp.dat>),
as the pimp will automatically C<chmod> it to 0600 on systems that
support permissions (currently, on everything but Win9x).
=cut
############# set your username and password here
my $user = '';# you should really set these, less typing
my $pass = ''; # well at least the username
# not so superficial settings follow, so please "Back the *bleep* up!
+"
######################################################################
+##########
=head1 SUPPORT (and REQUIREMENTS)
It'll run on anything that can run the following modules:
C<Xml::Parser;>
C<LWP::Simple;>
C<Getopt::Std;>
C<Data::Dumper;>
C<Term::ReadKey> (only if you use the C<-u> switch, in which case you
will be prompted for a password, unless you use C<-p> as well)
No phone support yet, just /msg me ;)
=cut
use XML::Parser; # Fo' parsering'em XML
use LWP::Simple; # Fo' fetching'em tickers
use Getopt::Std; # Fo' fetchin'em switchees
use Data::Dumper; # Fo' keepin'em tax, I meens whorin' r
+ecords ;)
$Data::Dumper::Indent = 0;# No pretty printing ;#(
$Data::Dumper::Quotekeys = 0;# No pretty qutoing 'a'=>a,'9'=>9
# don't change this between snapshots
+as it *is*
# reflected in the XML and your datafi
+le
my $root = 'http://perlmonks.org';
my $nodefile; # the great snapshots file
my $nodesurl = '&node_id=32704';
my $xpurl = '&node_id=16046';
my(%O,%old_user,%new_user); # don't need these in the symbol table
&getopts('f?h:u:p:', \%O); # Fetch them switches boy! Time for a
+whoopin'!
&help unless(%O); # This you can change to &_fetch
# Ain't I clever
if( (exists $O{'?'}) or ((exists $O{h}) && (defined $O{h}) && ($O{h}=~
+ /\D/)) )
{
&help($O{h} || '');
}
else
{
my ($argv_user,$argv_pass);
if(exists $O{'u'})
{
&help("dodn't work that way")unless(defined $O{'u'});
$argv_user = $O{'u'};
if(exists $O{'p'} and defined $O{'p'})
{
$argv_pass = $O{'p'};
}
else
{
local $| = 1; # unbuffer
print "Password: "; # We prompt for the password
$argv_pass = eval
{
require Term::ReadKey;
Term::ReadKey::ReadMode('noecho');
return Term::ReadKey::ReadLine(0);
};
die "\nYou need to install Term::Readkey\n" if($@);
print "\r Thank you";
sleep 1;
print "\r", ' ' x 30, "\n";
chomp($argv_pass); # set the pass
}
&help("Error: *missing* user and/or pass")
unless($argv_user and $argv_pass);
}
$pass = $argv_pass || $pass ;
$user = $argv_user || $user;
$nodefile = sprintf(".%s.xml_pimp.datF", $user || 0);
## the login line
$_ = 'op=login&user='.$user.'&passwd='.$pass.'&';
$nodesurl = $root.'/index.pl?'.$_.$nodesurl;
$xpurl = $root.'/index.pl?'.$_.$xpurl;
# odd looking logic follows
if(exists $O{'f'})
{
my $superuser = &load_SUPERUSER($nodefile);
# load_SUPERUSER will return a hashref
# if the $nodefile is empty or doesn't exist
# the hash will be empty as well, but no matter
my $new_user = &fetch_xml($nodesurl,$xpurl);
# &fetch_xml will die if LWP::Simple::get fails
$new_user->{INFO}->{timestamp} = &_timestamp;
my $diffhash;
if(%{$superuser})
{
$diffhash = &_gen_diff_hash($superuser,$new_user);
# the differential hash will contain the differences
# between $superuser and $new_user
}
else
{ # in case $superuser is empty (first run)
$diffhash = $new_user;
}
&_append_diff($diffhash, $nodefile) if(%{$diffhash});
&print_DIFF($diffhash,$superuser) if(%{$diffhash});
&print_INFO($new_user->{INFO},$superuser->{INFO});
}
elsif(exists $O{'h'})
{
&print_HISTORY($nodefile);
# will read the datafile, and build an array of differential has
+hes
# it'll build a $superuser, and print out reports based on %O
}
else{ print "{*yawn*}~[cpod] \n"; }
print " At the beep, GMT time will be: ", &_timestamp, "\n";
&_whirleygig; # the signature always goes last
}
do exit;#now. Please.
######################################################################
+##########
# - \ | / ~ - \ | / ~ - \ | / ~ - \ | / ~ - \ | / ~ s u b l a n d ###
+##########
=head1 FUNCTIONS (more than you I<ever> wanted to know)
The pod is good, but the code is also full of B<C<#comments>>.
=head2 C<help($O{h}||0);>
Prints synopsis (along with C<@_>) or
full pod depending on C<$O{h}> (your input, in particular C<-help>) an
+d exits;
=cut
sub help
{
if(@_ and ($_[0]=~ m/elp$/is) )
{
print `perldoc $0`;
}
else
{
print <<' HELP_0';
-f fetch a new snapshot, compare w/current status
-? print this help
-help print the pod
-h1 Display node history w/current INFO status at the end
-h2 Display node and INFO history w/current INFO status at the e
+nd
HELP_0
(print "\n",join "\n",@_,"\n") if(@_);
}
exit;
}
########### YOU CAN'T HAVE ANY PUDDIN', UNTIL YOU EAT YOUR MEAT ######
+##########
######################################################################
+##########
## Thank you id://62782 ####,
# The XML::Parser Handlers
sub _xml_start # beginning tag
{
my ($expat, # the object who invoked the sub
$name, # what to do
%attributes) = @_; # wood for the chipper(what the fu'?
my $t_user = $expat->{current_user_ref};
# I added {current_user_ref} to my expat o
+bject
# cause It's tidy-er
if($name eq 'NODE')
{
my $id = $attributes{id};
my $tim = $attributes{createtime};
my $rep = $attributes{reputation};
# mark the marker is an array ref
# it's stored in the object so it can be
# accessed between the handlers, without additional variables
$expat->{mark} = $t_user->{$id} = [$rep,$tim];
my $t_hash = $t_user->{'INFO'};
$t_hash->{'nodes'} += 1; # the number of nodes
$t_hash->{'nodesxp'} += $rep; # their summed xp
my $minxp = $t_hash->{'minxp'};
my $maxxp = $t_hash->{'maxxp'};
($t_hash->{'minxp'} = $rep ) if( $minxp > $rep );
($t_hash->{'maxxp'} = $rep ) if( $maxxp < $rep );
}
elsif($name eq 'INFO') # here 'cause its hit once(2ice now that I
+fetch 2pgs
{
# since I initialize info before, I can't do this anymore
# $t_user->{'INFO'} = \%attributes;
# this could've worked, but kinda ugly (and inefficient):
# %{$t_user->{'INFO'}} = (%{$t_user->{'INFO'}}, %attributes);
# and another option was map (retarded option imho)
my $t_hash = $t_user->{'INFO'};
foreach my $key (keys %attributes)
{
$t_hash->{$key} = $attributes{$key};
}
}
elsif($name eq 'XP') # here 'cause its hit once (diff. node [id://
+16046])
{
my $t_hash = $t_user->{'INFO'};
$t_hash->{'level'} = $attributes{level};
$t_hash->{'xp'} = $attributes{xp};
$t_hash->{'xp2nextlevel'} = $attributes{xp2nextlevel};
$t_hash->{'votesleft'} = $attributes{votesleft};
}
}
sub _xml_char # more like text (tag encapsulated stuff)
{
my ($expat, $not_markup) = @_;
if(exists $expat->{mark} and defined $expat->{mark})
{
# this generally be the stuff in between N
+ODE tags
# also referred to as the node title
$expat->{mark}->[2] .= $not_markup;
# i .= append because XML::Parser may make
+s multiple
# calls to this handler, as it does limit
+the
# chunks it reads in (thanx mirod)
}
}
sub _xml_def{}
# mostly space, with some tabs and newlines sprinkled about the north
+west area
sub _xml_end # it's an *end* (closing) tag
{
my ($expat, $name) = @_;
undef($expat->{mark}); # after the tag close, we wait for the nex
+t one
}
=head2 C<fetch_xml($nodesurl, $xpurl)>
Uses C<LWP::Simple::get> to fetch C<$nodesurl> and then C<$xpurl>
and processes each using C<XML::Parser>.
Dies if LWP fails to fetch the raw xml (mainly 32704).
'user nodes info xml generator'(32704) will return a few chars of
whitespace (\r\n) upon authentication failure, but
the 'XP XML Ticker'(16046) will always return at
least 'Rendered by the'...
=cut
sub fetch_xml # ($nodesurl, $xpurl
{
my ($nodesurl,$xpurl) = @_;
&help("&fetch_xml takes two params")unless($nodesurl and $xpurl);
# why redundancy, dudn't hurt much
my $raw_xml = get($nodesurl);
die "LWP::Simple::get ate it on $nodesurl ($!)" unless(length $raw
+_xml > 4);
# self documenting code is goood, but comments can't hurt
my $newusersnapshot = {};
# have to initialize, and too "complicated" to do insider the hand
+lers
$newusersnapshot->{INFO}={};
$newusersnapshot->{INFO}->{maxxp} = 0;
$newusersnapshot->{INFO}->{minxp} = 0;
$newusersnapshot->{INFO}->{nodes} = 0;
$newusersnapshot->{INFO}->{nodesxp} = 0;
my $xml_parser = new XML::Parser(
Handlers => {
Start => \&_xml_start,
End => \&_xml_end,
Char => \&_xml_char,
Default => \&_xml_def,
}
);
$xml_parser->{current_user_ref} = $newusersnapshot;
$xml_parser->parse($raw_xml); # parse the xml, and fill {curent
+_user_ref}
undef($raw_xml); # kinda redundant, but i like red
+undancy
$raw_xml = get($xpurl); # we wanna know the real xp bits
+too
die "LWP::Simple::get ate it on $xpurl ($!)" unless($raw_xml);
$xml_parser->parse($raw_xml); # as well as level stuff and vote
+s
undef($xml_parser); # paranoia
return($newusersnapshot);
}
=head2 C<load_SUPERUSER($nodefile)>
Reads the file, and builds a superuser.
Checks permissions (if not on win9x) and dies if they're not C<0600>.
=cut
sub load_SUPERUSER # goes to %O for guidance
{
my $nodefile = shift;
my $fileco = ''; # file contents (we .=append to it)
my %superuser; # our up-to-date snapshot hash
# the file must exist and have a non-zero size
return(\%superuser) unless(-e $nodefile and -s $nodefile);
open(FH, "<".$nodefile) or die ("where is ($nodefile)? $!");
if(sprintf('%04o',(stat $nodefile)[2] & 07777) ne '0600')
{
die("Security has been compromised, $nodefile is not chmod-ed
+0600!\n")
unless($^O =~ /Win32/);
}
die("can't seek on $nodefile ($!)") unless( seek(FH,0,0) );
# seek to the beginning of file
while(<FH>)
{
# y///c is shorter than length
# length '2001-01-11 04:25:18' == 20
if(y///c == 20 and /^(\d){4}-(\d){2}\-(\d){2} (\d){2}:(\d){2}:
+(\d){2}$/)
{
$_ = eval $fileco if(defined $fileco);
# $_ should now be a hashref
if(defined $_)
{
if(%superuser)
{
# update superuser with more current data
&_update_snapshot_hash(\%superuser,$_);
}
else
{
# initialize %superuser if it's empty, and move on
%superuser = %{ $_ };
# why, cause the initial snapshot doesn't look
# like the differential ones
# why, I don't know, but this will be remedied
}
}
undef $_; # like a good boy
undef $fileco;
}
else
{
$fileco.=$_;
}
}
close(FH);
return \%superuser;
}
=head2 C<print_HISTORY($nodefile)>
Reads C<$nodefile>(dies if it can't), and loads into memory an array
of hashes (C<@snapshots>), building a C<%superuser> hash at the same t
+ime.
Prints history based on the -h L<switch|/"options"> (see L</"examples"
+>)
=cut
sub print_HISTORY # goes to %O for guidance
{
my $nodefile = shift;
my $fileco = ''; # file contents (we .=append to it)
my $snapix = 0; # snapshot counter
my @snapshots; # differential snapshots array (hashref ho
+lder)
open(FH, "<".$nodefile) or die ("where is ($nodefile)? $!");
die("can't seek on $nodefile ($!)") unless( seek(FH,0,0) );
# seek to the beginning of file
while(<FH>)
{
# y///c is shorter than length
# length '2001-01-11 04:25:18' == 20
if(y///c == 20 && /^(\d){4}-(\d){2}\-(\d){2} (\d){2}:(\d){2}:(
+\d){2}$/ )
{
$_ = eval $fileco if(defined $fileco);
# $_ is now a hashref (should be)
if( (defined $_) and (ref $_ eq 'HASH') ) # and we make su
+re it is
{
push(@snapshots,\%{$_});
}
undef $_; # like a good boy
undef $fileco;
$snapix++;
}
else
{
$fileco .= $_; # append (as if I didn't know)
}
}
close(FH);
print "That was a total of $snapix snapshots\n";
my %superuser = %{ shift @snapshots } if(@snapshots); # in case it
+'s empty
# the first hashref is the original snapshot
# all subsequent hashrefs are differential snapshots
# and only they contain the hashkeys
# changed
# deleted
# new
# which all in turn hold respective node hashref
my %history;
my $ts = $superuser{INFO}->{timestamp};
my $fer = $history{INFO};
$fer->{minxp} = [$superuser{INFO}->{minxp},$ts];
$fer->{votesleft} = [$superuser{INFO}->{votesleft},$ts];
$fer->{nodesxp} = [$superuser{INFO}->{nodesxp},$ts];
$fer->{xp} = [$superuser{INFO}->{xp},$ts];
$fer->{level} = [$superuser{INFO}->{level},$ts];
$fer->{xp2nextlevel} = [$superuser{INFO}->{xp2nextlevel},$ts];
$fer->{nodes} = [$superuser{INFO}->{nodes},$ts];
$fer->{sitename} = [$superuser{INFO}->{sitename},$ts];
$fer->{maxxp} = [$superuser{INFO}->{maxxp},$ts];
$fer->{foruser} = [$superuser{INFO}->{foruser},$ts];
# where actual history is recorded
# $history{node}=[value,ts]
my %changed;
for my $snap (@snapshots) # get each snapshot hashref
{
my $ts = $snap->{INFO}->{timestamp};
for my $diff (keys %{$snap}) ###### NEW ALT DEL INFO
{
for my $node (keys %{$snap->{$diff}})
{
if($diff eq 'INFO') # cause of the structure of %super
+user
{
unless ( exists $history{INFO}->{$node} )
{# unless the initial snapshot doesn't exist
if(exists $superuser{INFO}->{$node} )
{
push( @{$history{INFO}->{$node}},
[$superuser{INFO}->{$node},
$superuser{INFO}->{timestamp},
])
unless($node eq 'timestamp');
# we don't want a report of when you took
+a snapshot
}
}
push(@{ $history{INFO}->{$node}},
[$snap->{INFO}->{$node},$ts])
unless($node eq 'timestamp');
# we don't want a report of when you took a s
+napshot
$superuser{INFO}->{$node} = $snap->{INFO}->{$n
+ode};
}
else
{ # if the array is empty, push the initial snapshot
# onto history. This'd occur before the initial
# snapshot (superuser) is changed
unless ( exists $history{$node} )
{# unless the initial snapshot doesn't exist
if ( exists $superuser{$node} )
{
push( @{$history{$node}},
[ $superuser{$node}->[0],
$superuser{INFO}->{timestamp}
])
unless($node eq 'timestamp');
# we don't want a report of when you took
+a snapshot
}
}
push( @{$history{$node}},
[ $snap->{$diff}->{$node}->[0],
$ts
]
);
$superuser{$node} = $snap->{$diff}->{$node};
$changed{$node} = $node;
}
} # endof for my $node
} # endof #### NEW ALT DEL INFO
} # endof for my $snap
my $INFO = delete $history{INFO}; # since we print if -h2
# $history{'62207'} = [ ['25', '2001-07-02 07:12:09' ] ];
# and print the node history, if you passed -h1
if(defined $O{h} and ($O{h} =~ /1/) )
{
for my $nodee (sort keys %history)
{
printf("\n%80.80s\n",'-' x 80);
@_ = @{ $superuser{$nodee} };
printf("%6.6s|%4.4s|%19.19s|%s\n",
'nodeid','xp','~v~ create time ~v~','title');
printf("%6.6s|%4.4s|%19.19s|%s\n\n", $nodee,@_);
printf("%11.11s|%19.19s|\n",'','~v~ change time ~v~');
@_ = @{ $history{$nodee} };
for $_ (@_) # oh my god, you're using $_ again
{
printf("%11.11s|%19.19s|\n", @{ $_ });
}
}
}
# and print the INFO history, if you passed -h2
if(defined $O{h} and ($O{h} =~ /2/) )
{
for my $key (sort keys %{$INFO} )
{
printf("\n%80.80s\n",'-' x 80);
printf "%10.10s\n%22.22s <|> %s\n\n",
$key,
$superuser{INFO}->{$key},
$superuser{INFO}->{timestamp};
@_ = @{ $INFO->{$key} };
for $_ (@_)
{
printf("%22.22s <|> %s\n", @{ $_ });
}
}
printf("\n%80.80s\n",'-' x 80);
}
print_INFO($superuser{INFO});
}
=head2 C<print_DIFF(\%DIFF, \%SUPERUSER)>
Prints out a nicely formatted list of freshly fetched node reputation
+changes.
It indicates the changes using B<old E<gt> new> notation.
(L</"_gen_diff_hash(\%compare_me,\%to_me)">)
=cut
sub print_DIFF
{
my ($diff, $old_user)= @_;
for my $KEY('NEW','DEL','ALT') # bad news last
{
next unless(exists $diff->{$KEY});
printf("%10.10s: %u\n",$KEY, scalar keys %{$diff->{$KEY}});
for my $node (keys %{$diff->{$KEY}} )
{
if($KEY eq 'ALT')
{
printf("%6.6s|%4.4s >%4.4s|%19.19s|%s\n",
$node,
$old_user->{$node}->[0],
@{ $diff->{$KEY}->{$node} } );
}
else
{
printf("%6.6s|%4.4s|%19.19s|%s\n",$node,
@{ $diff->{$KEY}->{$
+node} } );
}
}
}
}
=head2 C<print_INFO(\%INFO,[\%OLD_INFO])>
Takes a reference to %INFO and prints it out nicelly formatted
If you pass the optional second argument, if any of the
INFO elements changed (any of them), you'll see something like:
... <|> old > new
=cut
sub print_INFO
{
my $inf = shift;
my $ol = shift;
$inf->{nAvgXp} = sprintf("%3.2f", $inf->{nodesxp} / $inf->{nodes}
+)
if(exists $inf->{nodes} and $inf->{nodes});
# to prevent illegal division by zero
print (' ' x 24, "^\n");
for my $key (sort keys %{$inf} )
{
if(defined $ol and exists $ol->{$key} and $ol->{$key} ne $inf-
+>{$key})
{
printf("%22.22s <|> %s > %s\n",$key, $ol->{$key}, $inf->{$
+key});
}
else
{
printf("%22.22s <|> %s\n",$key, $inf->{$key});
}
}
print (' ' x 24, "V\n");
}
=head2 C<_append_dif(\%differences, $nodefile)>
Appends to C<$nodefile> the C<Data::Dumper> generated representation o
+f
C<%differences> (as generated by L</"_gen_diff_hash(\%compare_me,\%to_
+me)">)
=cut
sub _append_diff
{
my ($hashref,$nodefile)=@_;
&help("Error in: &_append_diff") unless($hashref and $nodefile);
open(OUTFH, "+>>".$nodefile) or die ("where is ($nodefile)? $!");
{
if(sprintf('%04o',(stat $nodefile)[2] & 07777) ne '0600')
{
chmod('0600', $nodefile) # only you, should be able to rw
unless($^O =~ /Win32/);
# in win9x chmod 0600 would write protect the file
}
$_ = Dumper($hashref);
substr($_,1,4,'_');
print OUTFH "\n", $_, "\n";
print OUTFH $hashref->{INFO}->{timestamp}, "\n";
}
close(OUTFH);
}
=head2 C<_gen_diff_hash(\%compare_me,\%to_me)>
Takes two hashrefs (C<$superuser> and C<$new_user>), compares the firs
+t to the second,
and generates a hash like the one below. Returns a hashref (C<$diffha
+sh>).
# hash looks like
{ INFO => { xp => 0, timestamp => 'yyyy-mm-dd hh:mm:ss'},
NEW => { '00001' =>[0,'yyyy-mm-dd hh:mm:ss','title']},
ALT => { '00004' =>[0,'yyyy-mm-dd hh:mm:ss','title']},
DEL => { '00002' =>[0,'yyyy-mm-dd hh:mm:ss','title']},
};
=cut
sub _gen_diff_hash
{
my ($old,$new) = @_;
# $old is a hashref we are comparing to(superuser)
# $new is a hashref containing the "update" (the new superuser)
# $new must be defined (cause LWP would've ate it otherwise)
my $diff = {};
# here go the differences
for my $key (keys %{$old})
{
unless( exists $new->{$key} )
{
$diff->{DEL}->{$key} = $old->{$key};
}
}
my $old_info = delete $old->{INFO}; # since we take care of it in
+the
my $new_info = delete $new->{INFO}; # following loop
my $tempt_timestamp = delete $new_info->{timestamp};
## the timestamp is the only value guaranteed to change
## so we remove it (it'll be put back into $new_info after loop
## however, at the end, if %{$diff}, we add it
for my $key (keys %{$new_info})
{
if( exists $old_info->{$key} and defined $old_info->{$key})
{
if($old_info->{$key} ne $new_info->{$key})
{
$diff->{INFO}->{$key} = $new_info->{$key};
}
}
else
{
$diff->{INFO}->{$key} = $new_info->{$key};
}
}
$new_info->{timestamp} = $tempt_timestamp;
# find all the NEW and ALT-ered nodes
for my $key ( keys(%{$new}) )
{
if(exists $old->{$key})
{
if( $new->{$key}->[0] != $old->{$key}->[0] )
{
$diff->{ALT}->{$key} = $new->{$key};
}
}
else
{
$diff->{NEW}->{$key} = $new->{$key}
}
}
$old->{INFO} = $old_info; # it's a good idea to restore these
$new->{INFO} = $new_info; # ;-)
$diff->{INFO}->{timestamp} = $tempt_timestamp if(%{$diff});
return $diff;
}
=head2 C<_update_snapshot_hash(\%update_me, \%with_me)>
Updates the "current" snapshot hash (C<$superuser>)
with the results from L</"_gen_diff_hash(\%compare_me,\%to_me)">.
Called only from L</"load_SUPERUSER($nodefile)">
=cut
sub _update_snapshot_hash
{
my ($u,$new) = @_;
# $u is a hashref being updated (superuser - the final and master sn
+apshot)
# $new is a hashref containing the "update" (the differential snapsh
+ot)
for my $DIFF (keys %{$new}) # NEW || CHANGED || DELETED || INFO
{
for my $key (keys %{$new->{$DIFF}}) # nodeid || INFO->{key}
{
if($DIFF eq 'INFO') # just update the INFO
{
$u->{'INFO'}->{$key} = $new->{$DIFF}->{$key};
}
elsif($DIFF eq 'NEW' or $DIFF eq 'ALT' )
{
$u->{$key} = $new->{$DIFF}->{$key}; #just add or updat
+e
}
elsif($DIFF eq 'DEL') # ;-O a node has been reaped ;{
{
delete $u->{$key};
}
}
}
}
=head2 C<_timestamp>
Returns a perlmonks compatible GMT timestamp (C<yyyy-mm-dd hh:mm:ss>)
=cut
sub _timestamp # current gmtime
{
@_ = (gmtime(time))[5,4,3,2,1,0];
# gimme a slice of that list
$_[0]+=1900; # hey hey, y 2 k
$_[1]+=1; # 0..11 ne 'true month'
return sprintf("%04u-%02u-%02u %02u:%02u:%02u", @_);
}
=head2 C<_whirleygig>
The xml_pimps *whirleygig* signature (printed to STDERR)
=cut
sub _whirleygig
{
my $c;
for $_ (0..69)
{
$c = '|' if(($_ % 4) == 1); #|
$c = '/' if(($_ % 4) == 2); #/
$c = '-' if(($_ % 4) == 3); #-
$c = '\\' if(($_ % 4) == 0); #\
print STDERR ("\r",' 'x$_,"$c xml pimp");
select(undef,undef,undef,0.04); # sleep
}
print STDERR ("\r",' 'x 70,"~ xml pimp\n");
}
__END__
# screen shots #;-^)
=head1 EXAMPLES
Some of the values have been altered to protect the innocent.
>perl xml_pimp.pl -f
ALT: 1
96732| 138 > 139|2001-07-10 06:32:23|The Perl Compiler (turning perl
+scripts in
to binary executables)
^
foruser <|> crazyinsomniac
level <|> 10
maxxp <|> 141
minxp <|> -3
nAvgXp <|> 10.13
nodes <|> 180
nodesxp <|> 1824
site <|> http://perlmonks.org
sitename <|> Perl Monks
timestamp <|> 2001-07-18 05:10:43
votesleft <|> 8
xp <|> 3090
xp2nextlevel <|> 0
V
At the beep, GMT time will be: 2001-07-18 05:10:44
+~ xml pimp
>perl xml_pimp.pl -h
That was a total of 152 snapshots
^
foruser <|> crazyinsomniac
level <|> 10
maxxp <|> 141
minxp <|> -3
nAvgXp <|> 10.13
nodes <|> 180
nodesxp <|> 1824
site <|> http://perlmonks.org
sitename <|> Perl Monks
timestamp <|> 2001-07-18 05:10:43
votesleft <|> 8
xp <|> 3090
xp2nextlevel <|> 0
V
At the beep, GMT time will be: 2001-07-18 06:26:02
+~ xml pimp
>perl xml_pimp.pl -h1
That was a total of 153 snapshots
nodeid| xp|~v~ create time ~v~|title
79263| 0|2001-05-09 21:37:03|(crazyinsomniac:caution) Re: Perl Sun
+Shine
|~v~ change time ~v~|
0|2001-07-01 06:01:50|
0|2001-07-01 06:01:50|
---------------------------------------------------------------------
+----------
nodeid| xp|~v~ create time ~v~|title
82200| 0|2001-05-22 10:29:00|ShaBANG!!!
|~v~ change time ~v~|
0|2001-06-29 09:59:13|
0|2001-06-29 09:59:13|
0|2001-07-01 06:01:50|
---------------------------------------------------------------------
+----------
nodeid| xp|~v~ create time ~v~|title
96732| 0|2001-07-14 13:16:54|(crazyinsomniac) Re: 'o' modifier cla
+rification
needed
|~v~ change time ~v~|
0|2001-07-14 13:33:12|
0|2001-07-14 14:33:05|
0|2001-07-14 14:44:13|
0|2001-07-14 15:36:48|
0|2001-07-14 16:16:17|
0|2001-07-15 10:59:37|
0|2001-07-16 02:55:59|
0|2001-07-16 09:12:14|
0|2001-07-16 20:02:05|
^
foruser <|> crazyinsomniac
level <|> 10
maxxp <|> 141
minxp <|> -3
nAvgXp <|> 10.13
nodes <|> 180
nodesxp <|> 1824
site <|> http://perlmonks.org
sitename <|> Perl Monks
timestamp <|> 2001-07-18 06:31:46
votesleft <|> 5
xp <|> 3092
xp2nextlevel <|> 0
V
At the beep, GMT time will be: 2001-07-18 06:38:57
+~ xml pimp
=head1 BET YOU WANNA KNOW...
=head2 WHY ARE I<ALL> MY PROGRAMS SO WELL COMMENTED
Well because I cannot C<sleep> sometimes, and I helps me
remember what the code is supposed to C<do {}>
=head2 HOW DO YOU MAKE HTML POD?
Be careful, this is a highly sophistimacated do-whackey.
C<pod2html --backlink "_top" --title "xml_pimp">
C< --infile xml_pimp.pl --outfile xml_pimp.html>
=head2 HOW DO YOU MAKE THOSE COOL I<NUMBERED> CODE LISTINGS?
For you Win32 guys: C<perl -pe "printf'%4.4s: ',$."> F<xml_pimp.pl>
E<gt>F<xml_pimp.listing.txt>
For you *ix guys: C<perl -pe 'printf"%4.4s: ",$.'> F<xml_pimp.pl>
E<gt>F<xml_pimp.listing.txt>
=head2 HOW MANY FILES DOES THIS THING MAKE?
One, just one ([epoptai])
=head2 THAT'S GREAT CRAZY, BUT WHAT ABOUT...
+ yes, Morse::Fancy and Morse::Sound are coming, keep your pants on
(not for my sake though ;-)
+ yes, the HTML::Parser and HTML::TokeParser tutorials are coming
=head1 LICENSE
This software is distributed under the GNU General Public License.
To obtain a copy of the license visit http://www.gnu.org/
or write/fax/phone/email the Free Software Foundation at:
Free Software Foundation Voice: +1-617-542-5942
59 Temple Place - Suite 330 Fax: +1-617-542-2652
Boston, MA 02111-1307, USA gnu@gnu.org
=cut
|
