Beefy Boxes and Bandwidth Generously Provided by pair Networks
Perl: the Markov chain saw
 
PerlMonks  

comment on

( #3333=superdoc: print w/replies, xml ) Need Help??
#!/home/josh/perl5.8.3/bin/perl use strict; use warnings; use Mail::Internet (); use MIME::Parser (); use WWW::Mechanize (); use Archive::Zip (); use File::Spec (); use File::Slurp (); use IO::Handle (); use Image::Magick::Thumbnail (); use File::MMagic (); use Mail::Sendmail (); use vars qw( $PERLMONKS $PM_BROWSER $PIXELS $SENDTO $SENDFROM); use Data::Dumper 'Dumper'; $PERLMONKS = 'http://perlmonks.org'; $PIXELS = 500; exit main( ); sub main { my $fh = slurp_to_string( \*STDIN ); my ( $username, $password, $sendfrom, $sendto ) = match_pm_user( $fh, [ <DATA> ] ); my $nm = get_sprint_image( $fh ); if ( $sendfrom ne $SENDFROM ) { die "$sendfrom ne $SENDFROM"; } if ( $sendto ne $SENDTO ) { die "$sendto ne $SENDTO"; } resize_image( $nm ); authenticate_to_perlmonks( username => $username, password => $password ) or die "Couldn't authenticate ($username, $password)"; upload_image_to_perlmonks( username => $username, filename => $nm ) or die "Couldn't upload image ($username, $nm)"; announce_image( $username ); 0; } sub announce_image { $PM_BROWSER->get( "$PERLMONKS/?node=ad_and_talk;displaytype=raw" ) +; $PM_BROWSER->field( 'message', "/me just uploaded a new monkpic" ) +; $PM_BROWSER->submit; } sub resize_image { my $name = shift; my $img = Image::Magick->new; $img->Read( $name ); my ($thumb, $x, $y ) = Image::Magick::Thumbnail::create( $img, $PI +XELS ); $thumb->Write( $name ); 0; } sub match_pm_user { my $fh = shift; my @users = @{ shift() }; my $user = quotemeta mail_from( $fh ); split ' ', ( grep s/^$user\s+//i, @users )[0] } sub mail_from { my $fh = shift; $fh->seek( 0, Fcntl::SEEK_SET ); my $from = Mail::Internet->new( $fh )->head->header_hashref->{'Fro +m'}[0]; $from =~ s/\s+//g; $from; } sub slurp_to_string { my $fh = shift; local $/; local $,; local $;; my $str; open my $ofh, "+>:raw", \ $str or die $!; $ofh->print( <$fh> ); $ofh->seek( 0, Fcntl::SEEK_SET ); $ofh; } sub authenticate_to_perlmonks { my %p = @_; $PM_BROWSER = WWW::Mechanize->new; $PM_BROWSER->get( $PERLMONKS ); $PM_BROWSER->form_name( 'login' ); $PM_BROWSER->set_fields( user => $p{'username'}, passwd => $p{'password'} ); $PM_BROWSER->submit->content; !! $PM_BROWSER->find_link( text_regex => qr/log.+?out/ ); } sub upload_image_to_perlmonks { my %p = @_; my $magic = File::MMagic->new->checktype_filename( $p{'filename'} +); $PM_BROWSER->get( "$PERLMONKS/?node=$p{'username'};displaytype=edi +t" ); $PM_BROWSER->form_number( 2 ); my $widget = $PM_BROWSER->current_form->find_input( 'imgsrc_file' +); $widget->file( $p{'filename'} ); $widget->filename( $p{'filename'} ); $widget->headers( 'Content-Type' => $magic ); $PM_BROWSER->click->content =~ /Received \d+ bytes/; } sub get_sprint_image { my $fh = shift; my $zfile = Archive::Zip::tempFile( File::Spec->tmpdir ); my $ifile = Archive::Zip::tempFile( File::Spec->tmpdir ); File::Slurp::write_file( $zfile, { binmode => 1, buf_ref => get_sprint_zip( $fh ) } ); my $zip = Archive::Zip->new( $zfile ); my $magic = File::MMagic->new; my $ok; for my $name ( $zip->memberNames ) { $zip->extractMember( $name, $ifile ); my $type = $magic->checktype_filename( $ifile ); if ( $type =~ /^image\/(?:png|gif|jpeg)/ ) { $ok = 1; last; } } unlink $zfile or die $!; $ok ? $ifile : (); } sub get_sprint_zip { my $fh = shift; my $browser = WWW::Mechanize->new; # Get the URL from the text portion of the email. my $url = ( ${get_text_from_email( $fh )} =~ m((\Qhttp://pictures.sprintpcs.com/\E\S+)) )[0]; my $page = $browser->get( $url ); # Get the next URL from inside the JavaScript $url = unpack "N/a*", ( sort { $b cmp $a } map pack( "N/a*", $_), $page->content =~ m((\Qhttp://pictures.sprintpcs.com/\E[^\'\"]+) +)g )[0]; $browser->get( $url ); # Authenticate that the $page = $browser->follow_link( url_regex => qr/comment/ ); $url = unpack "N/a*", ( sort { $b cmp $a } map pack( "N/a*", $_), $page->content =~ m((\Qhttp://pictures.sprintpcs.com/\E[^\'\"]+) +)g )[0]; $page = $browser->get( $url ); $SENDTO = ( map +( /\bvalue\s*=\s*([\'\"])(.+?)\1/ && $2 ), grep /\bname\s*=\s*([\'\"]).+?\1/ && $& =~ /\bemail\b/, $page->content =~ m(<input[^>]+)g )[0]; $SENDFROM = ( $page->content =~ m/addGuest\("(.+?)"/g )[0]; $SENDFROM =~ s/\|$//; $browser->back; $browser->back; # Now hit the javascript:download() action which is really just # a document.listForm.submit(); This returns a .ZIP file containin +g # a higher resolution picture image. $page = $browser->submit_form( form_name => 'listForm' ); my $zip_file = \ $page->content; } sub get_text_from_email { my $fh = shift; $fh->seek( 0, Fcntl::SEEK_SET ); my $p = MIME::Parser->new; $p->output_to_core(1); my $e = $p->parse( $fh ); \ join( '', map $_->stringify_body, grep $_->mime_type =~ m(text/plain), $e->parts ); } # One line per user, each field is separated by white space. # 1: the address to be matched against From: from the email # 2: URI encoded perlmonks.org username # 3: URI encoded perlmonks.org password # 4: the address to validate on the web page - typically the same as # +1 # 5: the address the message is expected to have been sent to __DATA__ from@foo.bar username password from@foo.bar script@foo.bar

In reply to SprintPCS camera phone to Perlmonks Monkpics by diotalevi

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!
  • Titles consisting of a single word are discouraged, and in most cases are disallowed outright.
  • 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
  • You may need to use entities for some characters, as follows. (Exception: Within code tags, you can put the characters literally.)
            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 lurking in the Monastery: (2)
    As of 2021-04-18 06:43 GMT
    Sections?
    Information?
    Find Nodes?
    Leftovers?
      Voting Booth?

      No recent polls found

      Notices?