package WWW::Contact::BG::Abv;
use Moose;
extends 'WWW::Contact::Base';
our $VERSION = '0.26';
sub get_contacts {
my ($self, $email, $password) = @_;
# reset
$self->errstr(undef);
my @contacts;
my $ua = $self->ua;
$self->debug("start get_contacts from abv");
# to form
# with_fields is used, 'cause username and password are not ids
$self->get('http://www.abv.bg/') || return;
$self->submit_form(
form_number => 1,
with_fields => {
username => $email,
password => $password,
},
) || return;
my $content = $ua->content();
if ($content =~ /login_help/) {
$self->errstr('Wrong Username or Password');
return;
}
my $base;
if ( $content =~ m/replace\("(.*)"\)/g ) {
my $fw = $1;
my $headers = $ua->head( $fw );
my $c = $headers->previous()->header( 'set-cookie' );
if ( $c =~ m/uhost=([a-zA-Z0-9]+\.abv.bg)/i ) {
$base = $1;
} else {
$self->errstr( 'Could not match base' );
return;
}
} else {
$self->errstr( 'Could not match address' );
return;
}
$self->debug('Login OK');
# FIXME: ssl connection is better
$ua->get( "http://$base/app/servlet/addrimpex?action=EXPORT&program=40" );
# The content is CSV file
$content = $ua->content();
while ( $content
# $1 = fname, $2=lname, $3 = "lname, fname', $4 = email
=~ /^(.*?)\,(.*?)\,\"(.*?\,.*?)\"\,.*?\,(.*?)\,\,{31}/mg
) {
next unless $4;
my $email = $4;
my $name = ( $1 or $2 ) ? "$1 $2" : $3;
push @contacts, {
name => $name,
email => $email,
};
}
return wantarray ? @contacts : \@contacts;
}
no Moose;
__PACKAGE__->meta->make_immutable;
1;
__END__
=head1 NAME
WWW::Contact::BG::Abv - Get contacts/addressbook from Abv.bg
=head1 SYNOPSIS
use WWW::Contact;
my $wc = WWW::Contact->new();
my @contacts = $wc->get_contacts('itsa@abv.bg', 'password');
my $errstr = $wc->errstr;
if ($errstr) {
die $errstr;
} else {
print Dumper(\@contacts);
}
=head1 DESCRIPTION
get contacts from Abv.bg, gbg.bg, gyuvectch.bg
=head1 SEE ALSO
L<WWW::Contact>, L<WWW::Mechanize>
=head1 AUTHOR
Dimitar Petrov, C<< <mitko at datamax.bg> >>
=head1 COPYRIGHT & LICENSE
Copyright 2009 Dimitar Petrov, all rights reserved.
This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
=cut