package WWW::Contact::Yahoo; use Moose; extends 'WWW::Contact::Base'; our $VERSION = '0.16'; our $AUTHORITY = 'cpan:FAYLAND'; has '+ua_class' => ( default => 'WWW::Mechanize::GZip' ); sub get_contacts { my ($self, $email, $password) = @_; # reset $self->errstr(undef); my @contacts; my $ua = $self->ua; $self->debug("start get_contacts from Yahoo!"); # to form $self->get('https://login.yahoo.com/config/login_verify2?&.src=ym') || return; $self->submit_form( form_name => 'login_form', fields => { login => $email, passwd => $password, }, ) || return; my $content = $ua->content(); if ($content =~ /=[\'\"]yregertxt/) { $self->errstr('Wrong Username or Password'); return; } $self->debug('Login OK'); $self->get('http://address.mail.yahoo.com/') || return; $ua->follow_link( url_regex => qr/import_export/i ); $ua->form_number(0); # the last form $self->submit_form( button => 'submit[action_export_yahoo]', ); $content = $ua->content(); my $i; while ( $content =~ /^\"(.*?)\"\,\".*?\"\,\"(.*?)\"\,\".*?\"\,\"(.*?)\"\,\".*?\"\,\".*?\"\,\"(.*?)\"/mg ) { $i++; next if ( $i == 1 ); # skip the first line. next unless ( $3 or $4 ); my $email = $3 || $4 . '@yahoo.com'; my $name = ( $1 or $2 ) ? "$1 $2" : $4; push @contacts, { name => $name, email => $email, };; } return wantarray ? @contacts : \@contacts; } no Moose; __PACKAGE__->meta->make_immutable; 1; __END__ =head1 NAME WWW::Contact::Yahoo - Get contacts/addressbook from Yahoo! Mail =head1 SYNOPSIS use WWW::Contact; my $wc = WWW::Contact->new(); my @contacts = $wc->get_contacts('itsa@yahoo.com', 'password'); my $errstr = $wc->errstr; if ($errstr) { die $errstr; } else { print Dumper(\@contacts); } =head1 DESCRIPTION get addressbook from Yahoo! Mail. extends L<WWW::Contact::Base> =head1 SEE ALSO L<WWW::Contact>, L<WWW::Mechanize::GZip> =head1 AUTHOR Fayland Lam, C<< <fayland at gmail.com> >> =head1 COPYRIGHT & LICENSE Copyright 2008 Fayland Lam, all rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut