File Coverage

blib/lib/WWW/Facebook/FQL.pm

Criterion	Covered	Total	%
statement	64	109	58.7
branch	7	30	23.3
condition	2	9	22.2
subroutine	16	24	66.6
pod	7	10	70.0
total	96	182	52.7

package WWW::Facebook::FQL;

=head1 NAME

WWW::Facebook::FQL - Simple interface to Facebook's FQL query language

=head1 SYNOPSIS

  use WWW::Facebook::FQL;

  ## Connect and log in:
  my $fb = new WWW::Facebook::FQL key => $public_key, private => $private_key;
  $fb->login($email, $password);

  ## Get your own name and pic back:
  $fb->query("SELECT name, pic FROM user WHERE uid=$fb->{uid}");

  ## Get your friends' names and pics:
  $fb->query("SELECT name, pic FROM user WHERE uid IN "
           . "(SELECT uid2 FROM friend WHERE uid1 = $fb->{uid})");

  ## Get results in manageable form:
  use JSON::Syck; # or whatever...
  $fb->format = 'JSON';
  my $arrayref = JSON::Syck::Load $fb->query("...");

=head1 DESCRIPTION

WWW::Facebook::FQL aims to make it easy to perform Facebook Query
Language (FQL) queries from a Perl program, rather than to reflect the
whole PHP Facebook API.  For those comfortable with SQL, this may be a
more comfortable interface.  Results are currently returned in the raw
JSON or XML format, but more palatable options may be available in the
future.

=cut

use URI::Escape;
use WWW::Mechanize;
use Digest::MD5 qw(md5_hex);
require Exporter;
use strict;

use vars qw($VERSION @ISA @EXPORT_OK %EXPORT_TAGS);
$VERSION = '0.03';

@EXPORT_OK = qw(%FIELDS %IXFIELDS);
%EXPORT_TAGS = (all => \@EXPORT_OK);
@ISA = qw(Exporter);

use vars qw($rest %FIELDS %IXFIELDS);
$rest = 'http://api.facebook.com/restserver.php';

sub dprint
{
    my $self = shift;
    my $lev = shift;
    if ($lev <= $self->{verbose}) {
        print STDERR @_;
    }
}

sub _sig
{
    my $secret = shift;
    md5_hex uri_unescape(join '', sort(@_), $secret);
}

sub get
{
    my $self = shift;
    ($self->{mech} ||= new WWW::Mechanize)->get(@_);
}

sub _request_nofail
{
    my $self = shift;
    my $resp = $self->_request(@_);
    die "Request failed:\n", $resp->decoded_content unless $resp->is_success;
    $resp;
}

sub _request
{
    my ($self, $method, %o) = @_;
    $o{format} ||= $self->{format};
    $method = "facebook.$method";
    my @params = ("api_key=$self->{key}",
                  "method=$method",
                  'v=1.0',
                  $self->{session_key} ? ('session_key='.$self->{session_key},
                                      'call_id='.(++$self->{callid})) : (),
                  map { "$_=".uri_escape($o{$_}) } keys %o);
    my $sig = _sig($self->{secret}, @params);
    my $url = "$rest?".join '&', @params, "sig=$sig\n";
    $self->dprint(1, $url);
    my $resp = $self->get("$rest?".join '&', @params, "sig=$sig");
    if (!$resp->is_success) {
        $self->dprint(0, "Request '$url' failed.\n");
    }
    ## avoid decoding content unless printed
    if ($self->{verbose} > 2) {
        $self->dprint(2, "RESPONSE ", '=' x 50, "\n", $resp->decoded_content,
                      "\n", '=' x 70, "\n");
    }
    $resp;
}

sub _get_auth_token
{
    my ($self) = @_;
    $self->{secret} = $self->{private};
    my $resp = $self->_request_nofail('auth.createToken', format => 'JSON');
    $self->{auth_token} = eval $resp->decoded_content;
}

sub _get_session
{
    my $self = shift;
    my $resp;
    {
        local $rest = $rest;
        $rest =~ s/^http/https/;
        $resp = $self->_request_nofail('auth.getSession', format => 'XML',
                                       auth_token => $self->{auth_token});
    }
    local $_ = $resp->decoded_content;
    for my $word (qw(uid session_key expires secret)) {
        ($self->{$word}) = /<$word>(.*?)<\/$word>/;
    }
    $self->dprint(1, "Session expires at ",
                  scalar localtime($self->{expires}), "\n");
}

=head2 C<$fb = new WWW::Facebook::FQL key =E value, ...>

Create a new Facebook FQL session for user $EMAIL with password $PASS.
Keyword arguments include

=over 4

=item email -- the email address of your Facebook account.

=item pass -- your password.

=item verbose -- A number controlling debugging information.

=item key -- The public part of your API key.

You need to sign up for this on Facebook by joining the "Developers"
group and requesting an API key.

=item private -- The private part of your API key.

=item format -- Data return format, either 'XML' (the default) or 'JSON'.

=back

WWW::Facebook::FQL reads default values from the file $HOME/.fqlrc if
it exists.  It should contain the innards of an argument list, and
will be evaluated like C<@args = eval "($FILE_CONTENTS)">.  The
constructor will I prompt for any parameters; it is the calling
program's responsibility to get sensitive information from the user in
an appropriate way.

=cut

sub new
{
    my $class = shift;
    my @def = (format => 'XML', verbose => 0);
    if (-f "$ENV{HOME}/.fqlrc") {
        local $/;
        if (open IN, "$ENV{HOME}/.fqlrc") {
            my @tmp = eval '('..')';
            push @def, @tmp unless $@;
            close IN;
        }
    }
    my %o = (@def, @_);
    my $self = bless \%o, $class;
    return undef unless $self->_get_auth_token;
    $self
}

sub login
{
    my $self = shift;
    ($self->{email}, $self->{pass}) = @_ if @_;
    my $mech = $self->{mech};
    $mech->get("http://www.facebook.com/login.php?api_key=$self->{key}&v=1.0&auth_token=$self->{auth_token}&hide_checkbox=1&skipcookie=1");
    die "Can't access login form:\n", $mech->res->decoded_content
        unless $mech->success;

    my $resp = $mech->submit_form(with_fields => {
        email => $self->{email},
        pass => $self->{pass}
    });
    die "Login failed:\n", $resp->decoded_content
        unless $resp->is_success;
    $self->dprint(2, "Logged in as $self->{email}\n");
    ## XXX check response
    if ($mech->content =~ /Terms of Service/) {
        $mech->submit_form(form_name => 'confirm_grant_form');
        die "TOS failed:\n", $mech->res->decoded_content
            unless $mech->res->is_success;
        $self->dprint(2, "Agreed to terms of service.");
    }
    ## Get session key
    $self->_get_session;
    $self;
}

=head2 C<$fb-Elogout>

Log the current user out.

=cut

sub logout
{
    my $self = shift;
    $self->{mech}->get("http://www.facebook.com/logout.php?api_key=$self->{key}&v=1.0&auth_token=$self->{auth_token}&confirm=1");
    delete $self->{secret};
}

=head2 C<$result = $fb-Equery($QUERY)

Perform FQL query $QUERY, returning the result in format $FORMAT
(either XML or JSON, JSON by default).  FQL is a lot like SQL, but
with its own set of weird and privacy-related restrictions; for a
description, see
L.

=cut

sub query
{
    my ($self, $q) = @_;
    if (!$self->{secret} || $self->{private} eq $self->{secret}) {
        print STDERR "Must log in before querying.\n";
        return;
    }
    $self->_request('fql.query', query => $q)->decoded_content;
}

=head2 ACCESSORS

=over

=item C<$fb-Euid> (read-only)

=item C<$fb-Eemail> (read-only)

=item C<$fb-Everbose> (read-write)

=item C<$fb-Eformat> (read-write)

=back

=cut

BEGIN {
    no strict;
    for (qw(uid email)) {
        eval "sub $_\n{ shift->{$_} }";
    }
    for (qw(verbose format)) {
        eval "sub $_ :lvalue { shift->{$_} }";
    }
}

BEGIN {
%FIELDS = (
    user => [qw(uid* first_name last_name name* pic_small pic_big
    pic_square pic affiliations profile_update_time timezone religion
    birthday sex hometown_location meeting_sex meeting_for
    relationship_status significant_other_id political
    current_location activities interests is_app_user music tv movies
    books quotes about_me hs_info education_history work_history
    notes_count wall_count status has_added_app)],

    friend => [qw(uid1* uid2*)],

    group => [qw(gid* name nid pic_small pic_big pic description
    group_type group_subtype recent_news creator update_time office
    website venue)],

    group_member => [qw(uid* gid* positions)],

    event => [qw(eid* name tagline nid pic_small pic_big pic host
    description event_type event_subtype start_time end_time creator
    update_time location venue)],

    event_member => [qw(uid* eid* rsvp_status)],

    photo => [qw(pid* aid* owner src_small src_big src link caption
    created)],

    album => [qw(aid* cover_pid* owner* name created modified
    description location size)],

    photo_tag => [qw(pid* subject* xcoord ycoord)],
);

for (keys %FIELDS) {
    $IXFIELDS{$_} = [grep /\*$/, @{$FIELDS{$_}}];
    s/\*$// for @{$FIELDS{$_}};
}

} ## END BEGIN

1;
__END__