File Coverage

blib/lib/WWW/HatenaLogin.pm

Criterion	Covered	Total	%
statement	13	15	86.6
branch			n/a
condition			n/a
subroutine	5	5	100.0
pod			n/a
total	18	20	90.0

package WWW::HatenaLogin;

use strict;
use warnings;

use Carp;
use URI;
use WWW::Mechanize;

our $VERSION = '0.03';

my $login_uri  = 'https://www.hatena.ne.jp/login';
my $logout_uri = 'https://www.hatena.ne.jp/logout';

sub new {
    my($class, $args) = @_;
    croak sprintf 'usage: %s->new(hash ref)', __PACKAGE__ unless $args && ref($args) eq 'HASH';

    my $self = bless {
        cookie_domain => '.hatena.ne.jp',
        session_key   => 'rk',
        uri           => {
            login  => URI->new($login_uri),
            logout => URI->new($logout_uri),
        },
        login_form    => {
            username => 'name',
            password => 'password',
        },
    }, $class;
    $self->{$_} = delete $args->{$_} || '' for qw( username password mech );

    my $opt = delete $args->{mech_opt};
    $self->{mech} ||= WWW::Mechanize->new(
        $opt && ref $opt ? %{ $opt } : ()
    );

    if (delete $args->{labo}) {
        $self->{uri}->{login}->host('www.hatelabo.jp');
        $self->{uri}->{logout}->host('www.hatelabo.jp');
        $self->{login_form}->{username} = 'key';
        $self->{cookie_domain}          = '.hatelabo.jp';
        $self->{logout_check}  = sub { shift->{mech}->content !~ m!https://www.hatelabo.jp/login! };
    }
    if (delete $args->{com}) {
        $self->{uri}->{login}->host('www.hatena.com');
        $self->{uri}->{logout}->host('www.hatena.com');
        $self->{cookie_domain} = '.hatena.com';
    }

    my $nologin = delete $args->{nologin};

    $self->login unless $nologin || $self->is_loggedin;
    $self;
}

sub has_metalink {
    my $self = shift;
    my $link;
    ($link) = map { $_->url } $self->{mech}->find_link(tag => 'meta');
    !!$link;
}

sub is_loggedin {
    my $self = shift;
    $self->{mech}->get($self->login_uri);
    $self->has_metalink;
}

sub login_uri { shift->{uri}->{login} }

sub logout_uri { shift->{uri}->{logout} }

sub username {
    my $self = shift;
    $self->{username} = defined $_[0] ? $_[0] : $self->{username};
}

sub login {
    my($self, $args) = @_;

    if ($args) {
        if ($args->{username}) {
            $self->{username} = $args->{username};
        }
        if ($args->{password}) {
            $self->{password} = $args->{password};
        }
    }

    $self->{mech}->get($self->login_uri);
    $self->{mech}->submit_form(
        fields => {
            $self->{login_form}->{username} => $self->{username},
            $self->{login_form}->{password} => $self->{password},
        }
    );

    !!($self->session_id) ||
        croak 'Login failed. Please confirm your username/password';
}

sub logout {
    my $self = shift;
    $self->{mech}->get($self->logout_uri);
    $self->{logout_check} ? $self->{logout_check}->($self) : $self->has_metalink;
}

sub mech { shift->{mech} }

sub cookie_jar { shift->{mech}->cookie_jar }

sub session_id {
    my $self = shift;
    my $rk;

    $self->cookie_jar->scan(sub {
        my($version, $key, $val, $path, $domain, $port,
            $path_spec, $secure, $expires, $discard, $hash) = @_;
        return unless $key eq $self->{session_key} && $domain eq $self->{cookie_domain};
        return if $expires && $expires < time;
        $rk = $val;
    });
    $rk;
}

1;
__END__