Beefy Boxes and Bandwidth Generously Provided by pair Networks
The stupid question is the question not asked
 
PerlMonks  

xml_pimp

by crazyinsomniac (Prior)
on Jul 19, 2001 at 13:20 UTC ( #98013=sourcecode: print w/ replies, xml ) Need Help??

Category: PerlMonks.org Related Scripts
Author/Contact Info just /tell crazyinsomniac or mail him at perlmonk.org
Description:

xml_pimp.pl - You heard of statswhore? You heard (x)luke_repwalker? Well dis da pimp!

For more information, read the pod below, or an html version at http://crazyinsomniac.perlmonk.org/perl/xml_pimp/ along with pictures ;-)(that's clemburg on there)

Like always, no comments are welcome(now that's what I call sarcasm ;-))

updates:
July 20, 2001 - minor cosmetic changes;
July 21, 2001 - updated some pod (a blah... got by me)
July 27, 2001 - changed sort keys to sort {$a<=>$b> keys(print_HISTORY for -h1)
September 26, 2001 - added &ticker=yes (details: New ticker login for PM XML clients)
Sun Jan 13 21:11:13 2002 GMT - fixed serious bug nobody told me about, which I was unaware of due to my testing environment. I guess the good thing is i'm the only one using this ;)(or I lost the original posted version which worked)

#!/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


Comment on xml_pimp
Download Code

Back to Code Catacombs

Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: sourcecode [id://98013]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others about the Monastery: (7)
As of 2014-08-21 22:26 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    The best computer themed movie is:











    Results (144 votes), past polls