Beefy Boxes and Bandwidth Generously Provided by pair Networks
Do you know where your variables are?
 
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 examining the Monastery: (11)
As of 2015-07-06 06:12 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    The top three priorities of my open tasks are (in descending order of likelihood to be worked on) ...









    Results (70 votes), past polls