Beefy Boxes and Bandwidth Generously Provided by pair Networks
P is for Practical

Comment on

( #3333=superdoc: print w/replies, xml ) Need Help??
package Mail::Client::Yahoo; #***** Interface *****# sub login; sub logout; sub folder_list; sub select_folder; sub folder_size; sub folder_count; sub message_list; sub message_size; sub message_head; sub message_body; sub message; sub move_message; sub delete_message; sub send_message; sub empty_trash; #***** Implementation *****# use WWW::Mechanize; use HTML::TableExtract; use Mail::Header; use Mail::Internet; our $VERSION = 1.0; our %URLs = ( login => '', slogin => '', logout => 'Logout', folders => 'Folders', box => 'ShowFolder?sort=date&order=up&box=%s', msghead => 'ShowLetter?bodyPart=HEADER&box=%s&MsgId=%s', msgbody => 'ShowLetter?bodyPart=TEXT&box=%s&MsgId=%s', message => 'ShowLetter?box=%s&MsgId=%s', movemsg => 'ShowLetter?MOV=1&.crumb=%s&box=%s&destBox=%s&MsgId=%s', delmsg => 'ShowLetter?DEL=%A0Delete%A0&box=%s&MsgId=%s', sendmsg => 'Compose', ); our %Patterns = ( login_form => 'login_form', user_field => 'login', pass_field => 'passwd', move_form => 'showLetter', crumb_field => '.crumb', delete_form => 'showLetter', delete_field => 'DEL', send_form => 'Compose', to_field => 'To', cc_field => 'Cc', bcc_field => 'Bcc', subject_field => 'Subj', body_field => 'Body', html_field => 'Format', html_value => 'html', save_field => 'SaveCopy', save_value => 'yes', attach_field => 'ATT', attach_value => '1', send_button => 'SEND', send_error => qr/class="errmsg"/i, attach_form => 'Attachments', first_field => 'userFile0', second_field => 'userFile1', third_field => 'userFile2', attach_button => 'UPL', aconfirm_form => 'Compose', folder_link => qr/\/ShowFolder\?.*\bbox=((?:%40B%40)?([^&]+))/, folder_size => qr/(\d+[MKB])/i, folder_unread => qr/(\S+)/, message_link => qr/\/ShowLetter\?.*\bMsgId=([^&]+)/, message_size => qr/(\d+[MKB])/i, first_link => qr/^First$/, next_link => qr/^Next$/, empty_link => qr/^Empty$/, bad_user => qr/This Yahoo! ID does not exist/i, bad_pass => qr/invalid password/i, folder_stats => { 'name' => 'Name', 'count' => 'Messages', 'unread' => 'Unread', 'size' => 'Size', }, message_stats => { 'from' => 'Sender', 'link' => 'Subject', 'date' => 'Date', 'size' => 'Size', }, ); sub DESTROY { my $self = shift; $self->logout(); } sub error { my $self = shift; $self->{error}->(@_); } sub login { my $class = shift; my $self = bless {}, $class; my %args = @_; $self->{error} = sub { my $msg = $self->{mech}->res->message; $msg = shift()."\n" if $msg =~ /^OK/; ($args{error} || sub { die @_ })->( "$self->{phase} failed on $self->{step}: $msg" ); }; my $mech = $self->{mech} = Mail::Client::Yahoo::Mechanize->new( autocheck => 1, onerror => $self->{error}, onwarn => $self->{error}, ); $self->{phase} = 'Login'; $self->{step} = 'Front Page Retrieval'; $mech->get($args{secure} ? $URLs{slogin} : $URLs{login}); $self->{step} = 'Login Submission'; $mech->submit_form( form_name => $Patterns{login_form}, fields => { $Patterns{user_field} => $args{username}, $Patterns{pass_field} => $args{password}, }, ); $self->{step} = 'Redirection'; while(my $redir = $mech->res->header('Location')) { $mech->get($redir); } if ( $mech->content =~ m#window.location.replace\("([^"]*?)"# ) { $mech->get($1); } $self->{step} = 'Login'; if($mech->content =~ $Patterns{bad_user}) { $self->error("Invalid username"); } elsif($mech->content =~ $Patterns{bad_pass}) { $self->error("Invalid password"); } $self->{connected} = 1; return $self; } sub logout { my $self = shift; return unless $self->{connected}; $self->{phase} = 'Logout'; $self->{step} = 'Logout Submission'; $self->{mech}->get($URLs{logout}); undef $self->{mech}; %$self = (); return $self; } sub _fetch_folder_stats { my $self = shift; $self->{step} = 'Folder Stats Retrieval'; $self->{mech}->get($URLs{folders}); my @stats = keys %{$Patterns{folder_stats}}; my @cols = @{$Patterns{folder_stats}}{@stats}; my $te = new HTML::TableExtract(headers => [@cols], keep_html => 1); $te->parse($self->{mech}->content); foreach my $row ($te->rows) { my %stats; @stats{@stats} = @$row; next unless $stats{name} =~ $Patterns{folder_link}; $stats{box} = $1; $stats{name} = $2; $stats{size} = $1 if $stats{size} =~ $Patterns{folder_size}; $stats{unread} = $1 if $stats{unread} =~ $Patterns{folder_unread}; %{$self->{folder_list}{$stats{name}}} = %stats; } } sub folder_list { my $self = shift; $self->{phase} = 'Folder List'; $self->_fetch_folder_stats() unless exists $self->{folder_list}; return keys %{$self->{folder_list}}; } sub select_folder { my $self = shift; my $name = shift; return if $name eq $self->{current_folder}; $self->{phase} = 'Select Folder'; $self->_fetch_folder_stats() unless exists $self->{folder_list}; $self->{step} = 'Folder Existance'; $self->error("Folder `$name' does not exist") unless exists $self->{folder_list}{$name}; $self->{current_folder} = $name; delete $self->{message_list}; delete $self->{message_stats}; return $self->{folder_list}{$name}{size}; } sub folder_size { my $self = shift; my $box = shift() || $self->{current_folder}; $self->{phase} = 'Folder Size'; $self->_fetch_folder_stats() unless exists $self->{folder_list}; return $self->{folder_list}{$box}{size}; } sub folder_count { my $self = shift; my $box = shift() || $self->{current_folder}; $self->{phase} = 'Folder Count'; $self->_fetch_folder_stats() unless exists $self->{folder_list}; return $self->{folder_list}{$box}{count}; } sub _fetch_message_list { my $self = shift; $self->{step} = 'Message List Retrieval'; $self->error('No folder selected') unless defined $self->{current_fo +lder}; # Read the folder, and make sure we're on the first page $self->{mech}->get(sprintf $URLs{box}, $self->{current_folder}); $self->{mech}->follow_link(text_regex => $Patterns{first_link}); do { my @stats = keys %{$Patterns{message_stats}}; my @cols = @{$Patterns{message_stats}}{@stats}; my $te = new HTML::TableExtract(headers => [@cols], keep_html => 1 +); $te->parse($self->{mech}->content); foreach my $row ($te->rows) { my %stats; @stats{@stats} = @$row; next unless $stats{link} =~ $Patterns{message_link}; $stats{msgid} = $1; $stats{size} = $1 if $stats{size} =~ $Patterns{message_size}; push @{$self->{message_list}}, $stats{msgid}; %{$self->{message_stats}{$stats{msgid}}} = %stats; } } while($self->{mech}->follow_link(text_regex => $Patterns{next_link +})); } sub _id_or_index { my $self = shift; my $i = shift; $self->_fetch_message_list() unless exists $self->{message_list}; return $i if exists $self->{message_stats}{$i}; return $self->{message_list}[$i] if 0 <= $i && $i < @{$self->{messag +e_list}}; $self->error("Invalid message id: $i"); } sub message_list { my $self = shift; $self->{phase} = 'Message List'; $self->_fetch_message_list() unless exists $self->{message_list}; return @{$self->{message_list}}; } sub message_size { my $self = shift; $self->{phase} = 'Message Size'; $self->{step} = 'Message Size'; my $msgid = $self->_id_or_index(shift); return $self->{message_stats}{$msgid}{size}; } sub message_head { my $self = shift; $self->{phase} = 'Message Headers'; $self->{step} = 'Header Retrieval'; my $msgid = $self->_id_or_index(shift); $self->{mech}->get(sprintf $URLs{msghead}, $self->{current_folder}, +$msgid); return Mail::Header->new([split /(?<=\n)/, $self->{mech}->content]); } sub message_body { my $self = shift; $self->{phase} = 'Message Body'; $self->{step} = 'Body Retrieval'; my $msgid = $self->_id_or_index(shift); $self->{mech}->get(sprintf $URLs{msgbody}, $self->{current_folder}, +$msgid); return Mail::Internet->new( Body => [split /(?<=\n)/, $self->{mech}->content], ); } sub message { my $self = shift; $self->{phase} = 'Message'; $self->{step} = 'Message Retrieval'; my $msgid = $self->_id_or_index(shift); return Mail::Internet->new( Header => $self->message_head($msgid), Body => $self->message_body($msgid)->body, ); } sub move_message { my $self = shift; $self->{phase} = 'Move Message'; $self->{step} = 'Input Validation'; my $msgid = $self->_id_or_index(shift); my $dest = shift; $self->error("Invalid folder") unless exists $self->{folder_list}{$dest}; $self->{step} = 'Message Selection'; $self->{mech}->get(sprintf $URLs{message}, $self->{current_folder}, +$msgid); # Would that I could just submit the 'Move to folder' form, # but alas, HTML::Form (and by extension WWW::Mechanize) # doesn't allow a SELECT to take on a value not in the OPTION # list. It doesn't even provide a way to override it. Crappy. :( # So, instead, I must extract the crumb and fetch manually. $self->{step} = 'Move Submission'; $self->{mech}->form_name($Patterns{move_form}); my $crumb = $self->{mech}->current_form->value($Patterns{crumb_field +}); $self->{mech}->get( sprintf $URLs{movemsg}, $crumb, $self->{current_folder}, $dest, $m +sgid ); } sub delete_message { my $self = shift; $self->{phase} = 'Delete Message'; $self->{step} = 'Input Validation'; my $msgid = $self->_id_or_index(shift); $self->{step} = 'Message Selection'; $self->{mech}->get(sprintf $URLs{message}, $self->{current_folder}, +$msgid); $self->{step} = 'Delete Submission'; $self->{mech}->submit_form( form_name => $Patterns{delete_form}, button => $Patterns{delete_field}, ); } sub send_message { my $self = shift; my %args = @_; my $mech = $self->{mech}; $self->{phase} = 'Send Message'; $self->{step} = 'Input Validation'; $self->error('No recipient specified') unless exists $args{to}; $self->error('No subject specified') unless exists $args{subject}; $self->error('No body specified') unless exists $args{body}; $self->{step} = 'Form Retrieval'; $mech->get($URLs{sendmsg}); if($args{attach}) { $self->{step} = 'Attach Files'; $mech->submit_form( form_name => $Patterns{send_form}, fields => { $Patterns{attach_field} => $Patterns{attach_value}, }, ); $mech->submit_form( form_name => $Patterns{attach_form}, fields => { @$args{attach} >= 0 ? ($Patterns{first_field} => $args{attach +}[0]) :(), @$args{attach} >= 1 ? ($Patterns{second_field} => $args{attach +}[1]) :(), @$args{attach} >= 2 ? ($Patterns{third_field} => $args{attach +}[2]) :(), }, button => $Patterns{attach_button}, ); $mech->submit_form( form_name => $Patterns{aconfirm_form}, ) } # HTML::Form doesn't allow you to set the value of certain inputs to # something other than the values supplied by the webpage. Nor does # it provide a way to add new values to that list. However, some # websites use JavaScript to set the inputs to new values, and we # need to emulate that. Thus, we have to manually add the value to # the list of possible values, and then select it. $mech->form_name($Patterns{send_form}); if($args{html}) { my $cb = $mech->current_form()->find_input($Patterns{html_field}, +undef, 0); push @{$cb->{menu}}, $Patterns{html_value}; $cb->value($Patterns{html_value}); } $mech->submit_form( form_name => $Patterns{send_form}, fields => { (exists $args{to} ? ($Patterns{to_field} => $args{to}) + :()), (exists $args{cc} ? ($Patterns{cc_field} => $args{cc}) + :()), (exists $args{bcc} ? ($Patterns{bcc_field} => $args{bcc} +) :()), (exists $args{subject} ? ($Patterns{subject_field} => $args{subj +ect}):()), (exists $args{body} ? ($Patterns{body_field} => $args{body +}) :()), ( exists $args{save} ? ( $Patterns{save_field} => $args{save} ? $Patterns{save_value} + : undef, ) : () ), }, button => $Patterns{send_button}, ); if($mech->response->as_string() =~ $Patterns{send_error}) { $self->error('Error sending message'); } } sub empty_trash { my $self = shift; $self->{phase} = 'Empty Trash'; $self->{step} = 'Folder List Retrieval'; $self->{mech}->get($URLs{folders}); $self->{step} = 'Empty Submission'; $self->{mech}->follow_link(text_regex => $Patterns{empty_link}); } #***** WWW::Mechanize Subclass *****# package Mail::Client::Yahoo::Mechanize; use base 'WWW::Mechanize'; # We subclass WWW::Mechanize to try to catch error messages from Yahoo sub get { my $self = shift; my $resp = $self->SUPER::get(@_); # This might be a little fragile. Not too much, though. if( $self->content =~ /<!--\s*start error\s*-->/ && $self->content =~ /<!--\s*end error\s*-->/ && $self->content =~ /<!--\s*error code:\s+((?:\w+\s?)+)\s+-->/ ) { $self->die("Yahoo error: $1"); } return $resp; } =head1 NAME Mail::Client::Yahoo =head1 SYNOPSIS use Mail::Client::Yahoo; $y = Mail::Client::Yahoo->login( username => 'bob', password => 'secret', secure => 1, # for the paranoid and patient ); $y->select_folder('Inbox'); $m = $y->message(0); # is equivalent to... @ids = $y->message_list(); $y->message($id[0]); $y->delete_message(0); $y->logout(); =head1 DESCRIPTION This module allows you to access your web-based Yahoo Mail account programatically. Similar in function to L<Mail::Webmail::Yahoo>, this module is more geared towards manipulation of individual messages, rather than simple bulk download. This module is also probably more reliable than L<Mail::Webmail::Yahoo>, as well. =head1 METHODS =head2 login( %options ) Creates a new Mail::Client::Yahoo object, and logs in to the Yahoo Mail server. You must include the C<username> and C<password> options. (The username and password is sent over a secure HTTPS connection.) You may also include an C<error> option, which should be a reference to a subroutine to be called if there is an error. The default handler simply dies. You may also include a C<secure> option, which should be either 0 or 1. If C<secure> is 1, the session uses a secure HTTPS connection, instead of a standard HTTP connection (the default). Note that the secure connection will be slower, and the username and password are always sent over HTTPS, regardless of the value of C<secure>. =head2 logout( ) Log out, and disconnect from the server. =head2 folder_list( ) Returns a list of the names of all available folders. =head2 select_folder( $name ) Selects the current working folder. This must be done before any of the message methods may be used. =head2 folder_size( $name ) Returns the size of a folder, as give by Yahoo. This size will usually be a string ending in `K', which gives the number of kilobytes in the message. This is not an exact size. =head2 folder_count( $name ) Returns the number of messages in a folder. =head2 message_list( ) Returns an array containing the message-id's of all the messages in the current folder. =head2 message_size( $msgid_or_index ) Returns the size of the message, as given in the folder listing. As with the folder size, it is not exact, and will most likely be a number followed by a `K' or `M', indicating kilobytes and megabytes, respectively. Note: The parameter passed may either be a message-id, such as returned from the L<message_list( )> function, or the index of a message in that list. =head2 message_head( $msgid_or_index ) Returns a L<Mail::Header> object containing the headers of the message +. =head2 message_body( $msgid_or_index ) Returns a L<Mail::Internet> object containing the body of the message. Note that the returned object contains B<only> the body of the message; the headers are left empty. This is the complete (possibly MIME-encoded) message body, including any attachments. =head2 message( $msgid_or_index ) Returns a L<Mail::Internet> object containing both the headers and body of the message. This is the complete message, including any attachments. =head2 move_message( $msgid_or_index, $folder_name ) Moves a message from the current folder to another folder. =head2 delete_message( $msgid_or_index ) Moves a message from the current folder to the special Trash folder. Note that the Trash folder is not emptied automatically (though it may be purged by Yahoo at random times). =head2 send_message( %options ) Sends a message via the Yahoo website. You must specify a primary recipient via C<to>, a C<subject>, and a C<body>. You may also specify additional recipients via C<cc> and C<bcc>, a boolean indicating whether to save the message in your Sent folder via C<save>, and a boolean indicating whether the body contains HTML formatting via C<html>. Additionally, you can specify an array reference via C<attach> containing a list of up to three file names to upload as attachments. =head2 empty_trash( ) Removes all messages from the Trash folder. These messages are permanently lost. =head1 SEE ALSO L<Mail::Header>, L<Mail::Internet>, L<WWW::Mechanize>, L<HTML::TableEx +tract> =head1 AUTHOR Copyright 2004, Cory Johns. This module is free software; you can redistribute and/or modify it under the same terms as Perl itself. Address bug reports and comments to: Cory Johns E<lt>L<>E<gt> =cut

In reply to Mail::Client::Yahoo by bbfu

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?

    What's my password?
    Create A New User
    and all is quiet...

    How do I use this? | Other CB clients
    Other Users?
    Others surveying the Monastery: (10)
    As of 2017-03-23 15:07 GMT
    Find Nodes?
      Voting Booth?
      Should Pluto Get Its Planethood Back?

      Results (288 votes). Check out past polls.