Net::BobrDobr - module for using http://bobrdobr.ru.

Net-BobrDobr documentation Contained in the Net-BobrDobr distribution.

Index

Code Index:

NAME

Top

Net::BobrDobr - module for using http://bobrdobr.ru.

SYNOPSIS

Top

  use Net::BobrDobr;
  my $bd = new Net::BobrDobr (...);
  $bd->connect (...) or die $bd->error;
  my $ret = $bd->call (...);

DESCRIPTION

Top

This module intended for deplouing social bookmark network http://BobrDobr.ru. You can log in to site, retrieve bookmarks, add bokmarks and remove bookmarks (list of all available operations you can find at http://bobrdobr.ru/api.html).

METHODS

new()

Create new instance of this module. Parameters for this call:

'api' => $file

File with bobrdobr-api keys, in format

  api-key: <api application key>
  api-secret: <api secret key>
'api-key' => $api_key

Manually supplied bobrdobr api application key.

'api-secret' => $api_secret

Manually supplied bobrdobr api secret key.

'agent' => $agent

Agent name for client, may be omitted.

'timeout' => $timeout

Timeout, default is 60 secs.

File for saving authentification cookies.

Returns undef if unsuccess, and $self if success.

connect()

This method perform all authentification operations. It got only two parameters -- login and password:

  $bd->connect ($login,$password);

Returns undef if unsuccess, and $self if success.

call()

Main method for call bobrdobr-services. List of all available methods you can find in http://bobrdobr.ru/api.html.

First argument or this method is a name of bobrdobr operation, as a "test.echo", and rest -- hash of named parameters for this operations. E.g.:

  my $ret = $bd->call ("test.echo",'param1' => "one");

Return reference to hash from server, or empty if request fail.

Main field for return hash: $ret-{'stat'}>, it may be:"ok" if operation success, or "fail" in other case. Full description see in http://bobrdobr.ru/api.html.

plaincall()

It is same method as call, but return raw content from server (REST XML form).

SEE ALSO

Top

http://bobrdobr.ru/api.html, XML::Simple, LWP::UserAgent.

AUTHOR

Top

Artur Penttinen, <artur+perl@niif.spb.su>

COPYRIGHT AND LICENSE

Top

Copyright (C) 2008 by Artur Penttinen

This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself, either Perl version 5.10.0 or, at your option, any later version of Perl 5 you may have available.

Net-BobrDobr documentation Contained in the Net-BobrDobr distribution. 
package Net::BobrDobr;

## Project: BobrDobr.ru
## File     BobrDobr.pm
## Creator: Artur Penttinen <artur.penttinen@scandicom.fi>
## Creation date: <Friday 06-June-2008 08:58 || Artur Penttinen>
## Last modified: <Friday 06-June-2008 12:28 || Artur Penttinen>
##
## Copyright (C) 2008 Artur Penttinen
##
## $Id:$
##

use 5.006;
use strict;
use warnings;

use Digest::MD5 qw(md5_hex);
use LWP::UserAgent;
use URI::Escape;
use IO::File;
use XML::Simple;

our $VERSION = (qw$Revision: $)[1] || "0.01";

my $agent = "NetBobrDobr/$VERSION (perl-agent)";
my $authurl = "http://bobrdobr.ru/";
my $requrl = "http://bobrdobr.ru/services/rest/" .
    "?method=%s&api_key=%s&%s&api_sig=%s";
my %commonhdr = ( 'accept' => "text/html, text/plain, text/css, */*;q=0.01",
		  'accept-encoding' => "gzip, bzip2",
		  'accept-language' => "ru, en",
		  'pragma' => "no-cache",
		  'cache-control' => "no-cache",
		  'accept-charset' => "utf8, iso-8859-1;q=0.01," );
my $error;

sub new ($%) {
    my ($class,%opt) = @_;
    my $self = {};

    $self = read_file ($opt{'api'}) if (exists $opt{'api'});

    $self->{'.api-key'} = $opt{'api-key'}
	if (exists $opt{'api-key'});
    $self->{'.api-secret'} = $opt{'api-secret'}
	if (exists $opt{'api-secret'});
    $self->{'.debug'} = exists $opt{'debug'} && $opt{'debug'} ? 1 : 0;

    unless (exists ($self->{'.api-key'}) ||
	    exists ($self->{'.api-secret'})) {
	$error = "not supplied api-key or api-secret";
	# return;
    }

    $self->{'.ua'} = new LWP::UserAgent ('agent' => $opt{'agent'} || $agent,
					 'timeout' => $opt{'timeout'} || 60,
					 'cookie_jar' => $opt{'cookie'} || {});
    $self->{'.ua'}->env_proxy;
    return bless $self,$class;
}

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

    unless (defined ($login) || defined ($password)) {
	$error = "not supplied login or password";
	return;
    }

    $self->{'.ua'}->get ($authurl)->is_success or return;

    my $auth = { 'username' => $login,
		 'password' => $password,
		 'remember_user' => "on",
		 'next' => "/" };
    my $ret = $self->{'.ua'}->post ($authurl . "login/",
				     %commonhdr,
				     'referer' => $authurl,
				     'content' => $auth);

    if ($ret->is_success || $ret->is_redirect) {
	return $self;
    }
    else {
	$error = $ret->status_line;
	return;
    }
}

## Call BD-method
sub call ($$;%) {
    my ($self,$method,%args) = @_;

    my $secret = join "",$self->{'.api-secret'},"api_key",$self->{'.api-key'},
	map { $_ eq "method" ? "method$method" : "$_$args{$_}" }
	    sort "method",keys %args;
    my $md5secret = md5_hex ($secret);
    my $args = join "&",map { join "=",uri_escape ($_),uri_escape ($args{$_}) }
	keys %args;
    my $url = sprintf $requrl,$method,$self->{'.api-key'},$args,$md5secret;
    $url =~ s#&&+#&#g;

    return $url if ($self->{'.debug'});

    my $ret = $self->{'.ua'}->get ($url);

    if ($ret->is_success) {
	return XMLin ($ret->content);
    }
    else {
	$error = $ret->status_line;
	return;
    }
}

## Call BD-method, return plain answer
sub plaincall ($$;%) {
    my ($self,$method,%args) = @_;

    my $secret = join "",$self->{'.api-secret'},"api_key",$self->{'.api-key'},
	map { $_ eq "method" ? "method$method" : "$_$args{$_}" }
	    sort "method",keys %args;
    my $md5secret = md5_hex ($secret);
    my $args = join "&",map { join "=",uri_escape ($_),uri_escape ($args{$_}) }
	keys %args;
    my $url = sprintf $requrl,$method,$self->{'.api-key'},$args,$md5secret;
    $url =~ s#&&+#&#g;

    return $url if ($self->{'.debug'});

    my $ret = $self->{'.ua'}->get ($url);

    if ($ret->is_success) {
	return $ret->content;
    }
    else {
	$error = $ret->status_line;
	return;
    }
}

sub read_file ($) {
    my ($file) = @_;
    my %ret;

    my $io = new IO::File $file or return;
    while (<$io>) {
	chomp;
	my ($a,$b) = split ":\\s*",$_,2;
	$ret{".$a"} = $b if ($a eq "api-key" || $a eq "api-secret");
    }
    $io->close;

    return \%ret;
}

sub error ($) {
    return $error;
}

1;

__END__


### That's all, folks!