File Coverage

lib/LJ/GetCookieSession.pm

Criterion	Covered	Total	%
statement	12	49	24.4
branch	0	12	0.0
condition	0	3	0.0
subroutine	4	7	57.1
pod	1	1	100.0
total	17	72	23.6

package LJ::GetCookieSession;

use warnings;
use strict;
use vars qw($VERSION);

use WWW::Mechanize;
require Digest::MD5;


our $VERSION = '0.01';

=pod

=head1 NAME

 LJ::GetCookieSession - A perl module to log into livejournal services

=head1 VERSION

Version 0.01

=head1 SYNOPSIS

C is an C module which is used to generate value of cookie parameter
named 'ljsession', which can be used in future requests to lj services.

Request mode sessiongenerate (see L) is used.

  use LJ::GetSessionCookie;

  my $ljsession = LJ::GetCookieSession->generate({user=> ..., pass=>...});

L

=head1 EXAMPLE

The following simple shows how to use the module to get all comments from LiveJournal.

	use WWW::Mechanize;
	use LJ::GetCookieSession;

	my $mech = WWW::Mechanize->new(
		agent      => '[e-mail]',
		cookie_jar => { "ljsession" => "" }
	);

	 my $ljsession = LJ::GetCookieSession->generate({user=> ..., pass=>...});

	die "failed to log into lj: ljsession failed\n" unless ( defined $ljsession );

	$mech->add_header ('X-LJ-Auth' => "cookie");
	$mech->add_header ('Cookie' => "ljsession=$ljsession");

	$mech->get("http://livejournal.com/export_comments.bml?get=comment_body");

    return undef unless ($mech->res->is_success);

	my $xml_comments = $mech->content();

=head1 LICENSE AND COPYRIGHT

Copyright 2011 Anastasiya Deeva, Studio Creograf L, L

This program is free software; you can redistribute it and/or modify it
under the terms of either: the GNU General Public License as published
by the Free Software Foundation; or the Artistic License.

See http://dev.perl.org/licenses/ for more information.

=head1 AVAILABLE METHODS

=head2 LJ::GetSessionCookie::generate()

C is a routine which generates value of cookie 'ljsession' for LiveJournal.

=over 4

=item user

The username who owns the journal;
this option is B.

=item pass

The password of the C;
this option is B.

=item server

URL of remote site to login.

=back

=cut

sub generate {
	my $self = shift;
	my $pars = {
		"server"=>"http://livejournal.com",
		%{$_[0]}
	};
	$pars->{"server"}="http://".$pars->{'server'} unless($pars->{'server'} =~ /^http/);

	die "user and password are required for login" unless($pars->{'user'} and $pars->{'pass'});

	my $mech = WWW::Mechanize->new( agent => '[e-mail]', );

	my $r =
	  $mech->post( $pars->{"server"} . "/interface/flat", { "mode" => "getchallenge" } );
	my $response = $self->_flatresponse( $mech->content() );

	die "challenge not recieved" unless $response->{'challenge'};

	$r = $mech->post(
		$pars->{"server"} . "/interface/flat",
		{
			"mode"           => "sessiongenerate",
			"user"           => $pars->{"user"},
			"auth_method"    => "challenge",
			"auth_challenge" => $response->{'challenge'},
			"auth_response" =>
			  $self->_calcchallenge( $response->{'challenge'}, $pars->{"pass"} )
		}
	);

	$response = $self->_flatresponse( $mech->content() );

	die "auth failed".$mech->content() unless $response->{'ljsession'};

    return undef unless defined $response->{'ljsession'};
	return $response->{'ljsession'};
}

# Define reference from new to generate
#*new="";
#*new=\&generate;

# generates challenge response
sub _calcchallenge {
	my $self = shift;
	my ( $challenge, $password ) = @_;

	my $md5_1=Digest::MD5->new;
    $md5_1->add($password);
    $password=$md5_1->hexdigest;

	my $md5 = Digest::MD5->new;
	$md5->add($challenge);
	$md5->add($password);
	return $md5->hexdigest;
}

# parses response of http://www.livejournal.com/interface/flat
sub _flatresponse {
	my $self     = shift;
	my $response = shift;
	my $r        = {};
	my @ar       = split( /\n/, $response );

	my $index = 0;
	foreach my $name (@ar) {
		$name =~ s/\n//g;
		if ( length($name) > 0 ) {
			my $value = $ar[ $index + 1 ];
			$value =~ s/\n//g;
			$r->{$name} = $value;
			$ar[ $index + 1 ] = "";
		}
		$index++;
	}
	return $r;
}

=head1 BUGS

Please report any bugs or feature requests to C, or through
the web interface at L.  I will be notified, and then you'll
automatically be notified of progress on your bug as I make changes.




=head1 SUPPORT

You can find documentation for this module with the perldoc command.

    perldoc LJ::GetSessionCookie


You can also look for information at:

=over 4

=item * RT: CPAN's request tracker

L

=item * AnnoCPAN: Annotated CPAN documentation

L

=item * CPAN Ratings

L

=item * Search CPAN

L

=back

=cut
1;