Beefy Boxes and Bandwidth Generously Provided by pair Networks
go ahead... be a heretic
 
PerlMonks  

Comment on

( #3333=superdoc: print w/ replies, xml ) Need Help??
#!/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

In reply to xml_pimp by crazyinsomniac

Title:
Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post; it's "PerlMonks-approved HTML":



  • Posts are HTML formatted. Put <p> </p> tags around your paragraphs. Put <code> </code> tags around your code and data!
  • Read Where should I post X? if you're not absolutely sure you're posting in the right place.
  • Please read these before you post! —
  • Posts may use any of the Perl Monks Approved HTML tags:
    a, abbr, b, big, blockquote, br, caption, center, col, colgroup, dd, del, div, dl, dt, em, font, h1, h2, h3, h4, h5, h6, hr, i, ins, li, ol, p, pre, readmore, small, span, spoiler, strike, strong, sub, sup, table, tbody, td, tfoot, th, thead, tr, tt, u, ul, wbr
  • Outside of code tags, you may need to use entities for some characters:
            For:     Use:
    & &amp;
    < &lt;
    > &gt;
    [ &#91;
    ] &#93;
  • Link using PerlMonks shortcuts! What shortcuts can I use for linking?
  • See Writeup Formatting Tips and other pages linked from there for more info.
  • Log In?
    Username:
    Password:

    What's my password?
    Create A New User
    Chatterbox?
    and the web crawler heard nothing...

    How do I use this? | Other CB clients
    Other Users?
    Others surveying the Monastery: (7)
    As of 2014-08-23 06:11 GMT
    Sections?
    Information?
    Find Nodes?
    Leftovers?
      Voting Booth?

      The best computer themed movie is:











      Results (172 votes), past polls