Beefy Boxes and Bandwidth Generously Provided by pair Networks
Your skill will accomplish
what the force of many cannot
 
PerlMonks  

Comment on

( #3333=superdoc: print w/ replies, xml ) Need Help??
mini-cb60-fetch.pl
#!/usr/bin/perl #mini-cb60-fetch.pl use strict; use warnings; use vars qw/$VERSION/; use XML::Simple; use File::Path; use LWP::UserAgent; use HTTP::Cookies; use Getopt::Long; use HTTP::Request::Common qw(POST); use Data::Dumper; # This is free Software. # Released under the same terms as Perl. # Copyright Yves (demerphq) 2006 $VERSION=0.02; my $ua = LWP::UserAgent->new(); $ua->timeout(10); $ua->agent("Mini-CB60 $VERSION "); $ua->env_proxy; $|++; my ( $verbose, $lastid, $sleeptime )= (1, 0, 0); my $site_url= 'http://perlmonks.org/index.pl'; my $ticker_url= $site_url.'?node_id=207304;xmlstyle=modern'; (my $dir= $0) =~ s![^\\\/]+$!messages/!; my ($user,$pass)= ('',''); GetOptions( 'msgdir=s' => \$dir, 'verbose=i' => \$verbose, 'sleeptime=i' => \$sleeptime, 'lastid=i' => \$lastid, 'user=s' => \$user, 'pass=s' => \$pass, ) or die <<EOFUSAGE; mini-cb60-fetch.pl --msgdir=PATH --verbose=INT --sleeptime=SECS --user=USER --pass=PASS --sleeptime of 0 means a single fetch only. Otherwise never halts. Defaults to --sleeptime of 0 seconds, and ./messages for --msgdir. EOFUSAGE if ($sleeptime && $sleeptime < 60) { warn "Theres no need to fetch more often than every 60 seconds!\n" +; } if ( $user && $pass ) { my $req = POST $site_url, [ op => 'login', node_id=> 109, # login user => $user, passwd => $pass, ticker =>'yes', displaytype=>'xml', xmlstyle=>'flat', ]; my $jar=HTTP::Cookies->new(file => "$0.cookies", autosave => 1); $ua->cookie_jar($jar); my $response=$ua->request($req); die "Failed to login\n",$response->as_string if ! $response->is_success; my $xml=XMLin( $response->content ); if (!$xml->{loggedin} || $xml->{loggedin}{username} ne $user ) { die "Failed to login." } print "Logged in as $_->{username} ($_->{user_id})\n" for $xml->{loggedin}; } elsif ( $user || $pass ) { die "Must have both a username and a password to log in\n"; } # cleanup the path for win32 users, just for aesthetic reasons $dir =~ s![\\\/]+!\\!g if $^O=~/Win32/; if ( ! -d $dir ) { mkpath $dir or die "Failed to create '$dir'"; } if ($verbose) { print "Base Url: '$site_url'\n"; print "Message directory is: '$dir'\n" } chdir $dir or die "Failed to chdir to '$dir':$!"; while ( 1 ) { # first we delete any old messages my $threshold= sprintf "%08x-%08x.msg",time() - 3600, 0; print "Threshold file is $threshold\n" if $verbose>1; my @files=sort glob "*.msg"; foreach my $f (@files) { print "Found $f\n" if $verbose>1; next if $f ge $threshold; print "Unlinking $f\n" if $verbose; unlink $f or warn "Failed to unlink '$f':$!"; } # and try to autodetect where we left off if this is the first run if ( ! $lastid && @files && -e $files[-1] ) { my ($t,$id)=split/[-.]/,$files[-1]; $lastid= hex($id) if $lastid < hex($id); } # and now we do the fetch my $url= $ticker_url; $url .= ";fromid=$lastid" if $lastid; print "Fetching from id $lastid\n" if $verbose>1; my $response= $ua->get($url); if (!$response->is_success) { print "Fetch '$url' failed!\n"; next; } # and now we process the results my $xml= XMLin( $response->content, ForceArray=>['message'] ); print Dumper($xml) if $verbose>2; my $msgs= $xml->{message}||[]; my $count= $xml->{info}{count}; $lastid= $xml->{info}{lastid} if $count; print "Got $count messages -- Last id: $lastid\n" if $verbose; next unless $count && $msgs && @$msgs; # each message is written as its own file. foreach my $msg (@$msgs) { my ($id,$epoch)= @{$msg}{qw(message_id createdepoch)}; my $authlink= sprintf '<a href="?node_id=%d">%s</a></i>', $msg->{author_user},$msg->{author}; (my $text= $msg->{parsed})=~s{^/me(\s+.+)?$}{<i>$authlink$1</i +>}; my $file= sprintf "%08x-%08x.msg",$epoch,$id; next if -e $file; open my $fh,">",$file or die "Failed to open '$file' for writing:$!"; print "writing $file\n" if $verbose; print $fh "0\n"; # version print $fh join "\n", "<dt>$authlink&nbsp; &nbsp; <small>$msg->{createdgmtime} + GMT</small></dt>", "<dd>$text</dd>", ""; close $fh; } } continue { exit(0) if $sleeptime <= 0; # exit out if this is a single pass print "sleeping for $sleeptime seconds....\n" if $verbose>1; sleep $sleeptime; }

mini-cb60-render.pl
#!/usr/bin/perl #mini-cb60-render.pl # This is free Software. # Released under the same terms as Perl. # Copyright Yves (demerphq) 2006 use strict; use warnings; use CGI (); use Getopt::Long; use vars qw/$VERSION/; $VERSION= 0.02; ############### SET THESE AS APPROPRIATE ###################### my $SITE_DOMAIN= "mini-cb60.flux8.com"; my $SITE_PATH= "/"; my $PM_HOST_USERNAME= "demerphq"; my $PM_HOST_USERID= 108447; ############### OR SET FROM COMMANDLINE ####################### $CGI::POST_MAX= 1024; # no need for more than 1k. $CGI::DISABLE_UPLOADS = 1; # no uploads my $do_header= $ENV{REQUEST_METHOD} ? 1 : 0; # Default based on if run + from shell my $q= CGI->new(); my @cookies; sub get_user_param { my ( $name, @legal )= @_; my %screen= map { lc($_) => $_ } @legal; my $cval= $screen{lc($q->cookie($name))}; my $pval= $screen{lc($q->param($name))}; my $ret= $pval || $cval || $legal[0]; if ($do_header && ($ret ne $legal[0] || ($cval && $cval ne $ret))) + { push @cookies, $q->cookie( -name => $name, -value => $ret, -expires => '+10y', $SITE_PATH ? (-path => $SITE_PATH) : (), $SITE_DOMAIN ? (-domain => $SITE_DOMAIN) : (), ); } return $ret; } (my $dir= $0) =~ s![^\\\/]+$!messages/!; GetOptions( 'msgdir=s' => \$dir, 'header!' => \$do_header, 'domain=s' => sub { $q->param(@_) }, 'site_domain' => \$SITE_DOMAIN, 'site_path' => \$SITE_PATH, 'hoster=s' => \$PM_HOST_USERNAME, 'hosterid=i' => \$PM_HOST_USERID, 'reverse!' => sub { $q->param(@_) }, ) or die <<EOFUSAGE; mini-cb60-render.pl --msgdir=PATH --[no]header --domain=(org|com|net) --hoster=MONKNAME --hosterid=MONKID EOFUSAGE my @domains=qw(org com net); my $domain= get_user_param('domain',@domains); my $order= get_user_param('order',qw(desc asc)); chdir $dir; print $do_header ? $q->header(@cookies ? ( -cookie => \@cookies ) : ()) : "", $q->start_html( -title=> 'Perlmonks Mini-CB60', -xbase=> "http://perlmonks.$domain/index.pl", -meta=> { 'keywords'=>"Perlmonks Mini-CB60",}, -head=>$q->Link({ -rel=>'icon', -href=>"/favicon.ico"} ), -style=> { -code => "dt { background-color:#ddd }" }, ), $q->center( $q->h1( $q->a( { href => '?node_id=131' }, "Perlmonks") . " " . $q->a( { href => "http://$SITE_DOMAIN$SITE_PATH" }, "Mini-CB60") ) ), $q->start_dl(); my $threshold= sprintf "%08x-%08x.msg",time() - 3600, 0; my @files=sort glob "*.msg"; @files=reverse @files if $order eq 'desc'; foreach my $file (@files) { if ($file lt $threshold) { unlink $file; next; } open my $fh,"<",$file or die "Failed to read '$file' :$!"; chomp(my $version=<$fh>); if ( $version == 0 ) { print <$fh>; } else { die "Error '$file' is of an unknown version: '$version'"; } } my $hostspec=""; if ( $PM_HOST_USERNAME ) { $hostspec.= "<br/>Hosted by:" . ( $PM_HOST_USERID ? $q->a( { href => "?node_id=$PM_HOST_USERID" }, $PM_HOST_USERNAME ) : $PM_HOST_USERNAME ) } my @form=!$do_header ? () : ( $q->hr, $q->start_center, $q->start_form(-action=>"http://$SITE_DOMAIN"), "Preferred Domain for Perlmonks: ", $q->radio_group( -name=>'domain', -values=>\@domains, -default=>$domain, -force=>1, ), $q->br, "Order messages: ", $q->radio_group( -name=>'order', -values=>['desc','asc'], -default=>$order, -force=>1, -labels=>{ asc => 'Oldest First', desc => 'Newest First'} ), $q->br, $q->submit(-name=>'stumbit', -value=>'Update Preferences'), $q->endform(), $q->end_center, ); print $q->end_dl(), @form, $q->hr, $q->p( { align => 'right' }, $q->small( $q->a({href=>'?node_id=531067'},"Version $VERSION") . "<br/>Coding By " . $q->a({ href => '?node_id=108447' },'demerphq') . $hostspec ) ), $q->end_html(), "\n";

In reply to CB60 by demerphq

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 pondering the Monastery: (7)
    As of 2014-09-02 20:51 GMT
    Sections?
    Information?
    Find Nodes?
    Leftovers?
      Voting Booth?

      My favorite cookbook is:










      Results (29 votes), past polls