File Coverage

blib/lib/WWW/Facebook/API.pm

Criterion	Covered	Total	%
statement	756	804	94.0
branch	192	272	70.5
condition	29	60	48.3
subroutine	175	180	97.2
pod	126	128	98.4
total	1278	1444	88.5

#########################################################################
# ex: set ts=8 sw=4 et
#########################################################################
package WWW::Facebook::API;

use warnings;
use strict;
use Carp;

use version; our $VERSION = qv('0.4.18');

use LWP::UserAgent;
use Time::HiRes qw(time);
use Digest::MD5 qw(md5_hex);
use Encode qw(encode_utf8 is_utf8);
use CGI;
use CGI::Util qw(escape);

use WWW::Facebook::API::Exception;

our @namespaces = qw(
    Admin           Application     Auth
    Canvas          Comments        Connect
    Data            Events          FBML
    Feed            FQL             Friends
    Groups          Intl            Links
    LiveMessage     Message         Notes
    Notifications   Pages           Permissions
    Photos          Profile         SMS
    Status          Stream          Users
    Video
);

for (@namespaces) {
    my $package = __PACKAGE__ . "::$_";
    my $name    = "\L$_";
    ## no critic
    my $namespace = eval qq(
        use $package;

        sub $name {
            my \$self = shift;
            unless ( \$self->{'_$name'} ) {
                \$self->{'_$name'} = $package->new( base => \$self );
            }
            return \$self->{'_$name'};
        }

        package $package;
        sub base { return shift->{'base'}; };
        sub new {
            my ( \$class, \%args ) = \@_;
            my \$self = bless \\\%args, \$class;

            delete \$self->{\$_} for grep { !/base/xms } keys %{\$self};
            \$self->\$_ for keys %{\$self};

            return \$self;
        };
        1;

    );
    croak "Cannot create namespace $name: $@\n" if not $namespace;
}

our %attributes = (
    parse        => 1,
    format       => 'JSON',
    debug        => 0,
    throw_errors => 1,
    api_version  => '1.0',
    apps_uri     => 'http://apps.facebook.com/',
    server_uri   => 'http://api.facebook.com/restserver.php',
    (   map { $_ => q{} }
            qw(
            api_key             secret      desktop
            last_call_success   last_error  skipcookie
            popup               next        session_key
            session_expires     session_uid callback
            app_path            ua          query
            config              app_id      call_as_apikey
            )
    ),
);

for ( keys %attributes ) {
    ## no critic
    my $attribute = eval qq(
        sub $_ {
            my \$self = shift;
            return \$self->{$_} = shift if defined \$_[0];
            return \$self->{$_} if defined \$self->{$_};
            return \$self->{$_} = '$attributes{$_}';
        }
        1;
    );
    croak "Cannot create attribute $_: $@\n" if not $attribute;
}

sub _set_from_outside {
    my $self = shift;

    my $app_path = '_' . ( $self->{'app_path'} || $self->app_path );
    $app_path =~ tr/a-z/A-Z/;
    $app_path =~ tr/A-Za-z0-9_/_/c;

    my %ENV_VARS = qw(
        WFA_API_KEY     api_key
        WFA_SECRET      secret
        WFA_DESKTOP     desktop
        WFA_SESSION_KEY session_key
    );

    $self->_set_from_file( $app_path, %ENV_VARS ) if $self->{'config'};
    $self->_set_from_env( $app_path, %ENV_VARS );

    return;
}

sub _set_from_file {
    my $self     = shift;
    my $app_path = shift;
    my %ENV_VARS = @_;

    open my $config, '<', $self->{'config'}    ## no critic
        or croak "Cannot open $self->{'config'}";

    while (<$config>) {
        carp "Config line: $_" if $self->{'debug'};
        chomp;
        my ( $key, $val ) = split m/=/xms, $_, 2;
        next if !$key;
        carp "Key/Val pair: $key -> $val" if $self->{'debug'};
        for ( $key, $val ) {
            s/\A\s+//xms;
            s/\s+\Z//xms;
        }
        $ENV{$key} ||= $val;
    }

    close $config or croak "Cannot close $self->{'config'}";

    return;
}

sub _set_from_env {
    my $self     = shift;
    my $app_path = shift;
    my %ENV_VARS = @_;

    for ( keys %ENV_VARS ) {
        if ( exists $ENV{ $_ . $app_path } ) {
            $self->{ $ENV_VARS{$_} } ||= $ENV{ $_ . $app_path };
        }
        elsif ( exists $ENV{$_} ) {
            $self->{ $ENV_VARS{$_} } ||= $ENV{$_};
        }
    }

    return;
}

sub new {
    my ( $self, %args ) = @_;
    my $class = ref $self || $self;
    $self = bless \%args, $class;
    $self->_set_from_outside();    # set api_key etc. if needed

    $self->{'ua'} ||=
        LWP::UserAgent->new( agent => "Perl-WWW-Facebook-API/$VERSION" );
    my $is_attribute = join q{|}, keys %attributes;
    delete $self->{$_} for grep { !/^ $is_attribute $/xms } keys %{$self};

    # set up default namespaces
    $self->$_($self) for map {"\L$_"} @namespaces;

    # set up default attributes
    $self->$_ for keys %attributes;

    return $self;
}

sub log_string {
    my ( $self, $params, $response ) = @_;
    my $string = "\nparams = \n";

    $string .= "\t$_:$params->{$_}\n" for sort keys %{$params};
    $string .= "response =\n$response\n";

    return $string;
}

sub call_success {
    my $self = shift;
    $self->last_call_success(shift) if @_;
    $self->last_error(shift)        if @_;
    return [ $self->last_call_success, $self->last_error ];
}

sub call {
    my ( $self, $method, %args ) = @_;
    my ( $response, $params, $sig, $raw_data, $filename );
    $self->call_success(1);

    if ( $self->call_as_apikey ) {
         $args{'call_as_apikey'} = $self->call_as_apikey;
    }

    ( $params, $raw_data, $filename ) =
        $self->_format_and_check_params( $method, %args );
    $sig = $self->generate_sig(
        params => $params,
        secret => delete $params->{'secret'},
    );

    $response = $self->_post_request( $params, $sig, $raw_data, $filename );

    carp $self->log_string( $params, $response ) if $self->debug;
    if ( $self->_has_error_response($response) ) {
        if ( $self->throw_errors ) {
            warn WWW::Facebook::API::Exception->new(
                $method, $params, $response
            );
        }
    }

    return $self->_reformat_response( $params, $response );
}

sub generate_sig {
    my ( $self, %args ) = @_;
    my %params = %{ $args{'params'} };
    return md5_hex( ( map {"$_=$params{$_}"} sort keys %params ),
        $args{'secret'} );
}

sub verify_sig {
    my ( $self, %args ) = @_;
    return $args{'sig'} eq $self->generate_sig(
        params => $args{'params'},
        secret => $args{'secret'} || $self->secret,
    );
}

sub session {
    my ( $self, %args ) = @_;
    $self->{"session_$_"} = $args{$_} for keys %args;
    return;
}

sub redirect {
    my $self = shift;
    my $url  = shift;
    $self->query(shift);

    if ( $self->canvas->in_fb_canvas ) {
        return qq{};
    }
    elsif ($url =~ m{^https?://([^/]*\.)?facebook\.com(:\d+)?}ixms
        && $self->session_uid )
    {
        return join q{},
            map {"$_\n"}
            '' </td>
</tr>

<tr>
<td  class="h" >
<a name="265">265</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s">             . qq{top.location.href = "$url"} </td>
</tr>

<tr>
<td  class="h" >
<a name="266">266</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s">             . '';
    }

    print CGI->new->redirect(
        $self->get_app_url( next => $self->get_login_url ) );
    return 1;
}

sub require_add   { return shift->require( 'add',   @_ ); }
sub require_frame { return shift->require( 'frame', @_ ); }
sub require_login { return shift->require( 'login', @_ ); }

sub require {    ## no critic
    my $self = shift;
    my $what = shift;
    $self->query(shift);

    if ( $what eq 'login' ) {
        unshift @_, qw( canvas ) if $self->canvas->in_frame;
    }
    if ( $what eq 'frame' ) {
        return if $self->canvas->in_frame;
        unshift @_, qw( canvas );
        $what = 'login';
    }

    my $user = $self->canvas->get_fb_params->{'user'};
    if ( $what eq 'add' ) {
        if ( !$self->canvas->get_fb_params->{'added'} ) {
            $user = undef;
        }
    }
    return if $user;

    return $self->redirect( $self->get_url( $what, @_ ) );
}

sub get_facebook_url { return shift->get_url( 'facebook', @_ ); }
sub get_add_url      { return shift->get_url( 'add',      @_ ); }
sub get_infinite_session_url { return shift->get_url('infinite_session'); }
sub get_login_url            { return shift->get_url( 'login', @_ ); }
sub get_app_url              { return shift->get_url( 'app', @_ ); }

sub get_url {
    my $self = shift;
    my $type = shift;

    if ( $type eq 'facebook' ) {
        my $site = shift || 'www';
        return "http://$site.facebook.com";
    }

    if ( $type eq 'app' ) {
        return $self->apps_uri . $self->app_path . q{/};
    }

    if ( $type eq 'custom' ) {
        return (shift) . $self->_add_url_params(@_);
    }

    return $self->get_url('facebook')
        . (
          $type eq 'add'              ? '/add.php'
        : $type eq 'infinite_session' ? '/code_gen.php'
        : $type eq 'login'            ? '/login.php'
        : q{}
        ) . $self->_add_url_params(@_);
}

sub unescape_string {
    my $self   = shift;
    my $string = shift;
    $string =~ s/(?
    return $string;
}

sub _add_url_params {
    my $self   = shift;
    my $params = q{?api_key=} . $self->api_key . q{&v=1.0};
    if (@_) {
        if ( @_ % 2 ) {

            # Odd number of elelemts, so didn't pass in canvas => 1
            $params .= q{&canvas} if grep { $_ eq 'canvas' } @_;  ## no critic
            @_ = grep { $_ ne 'canvas' } @_;
        }
        my %params = @_;
        $params .= q{&canvas} if delete $params{'canvas'};

        for ( sort keys %params ) {
            next if not defined $params{$_};
            $params{$_} = escape( $params{$_} ) if $_ eq 'next';
            $params .= "&$_=$params{$_}";
        }
    }
    return $params;
}

sub _parser {
    my $parser = JSON::Any->new;

    $parser->handler->allow_nonref;
    return $parser;
}

sub _parse {
    my ( $self, $response ) = @_;

    # Some shortcuts
    return q{} if $response =~ /\A"?"?\Z/xms;
    return 1   if $response =~ /\A"?true"?\Z/xms;
    return 0   if $response =~ /\A"?false"?\Z/xms;

    my $parser;
    eval { $parser = _parser(); 1; } or do {

        # Only load JSON::Any if we haven't already.  Lets the developers
        # pick their choice of JSON modules (JSON::DWIW, for example)
        ## no critic
        eval q{use JSON::Any};
        croak "Unable to load JSON module for parsing:$@\n" if $@;
        $parser = _parser();
    };
    carp 'JSON::Any is parsing with ' . $parser->handlerType if $self->debug;

    return $parser->decode($response);
}

sub _check_values_of {
    my ( $self, $params ) = @_;

    if ( $self->desktop ) {
        $params->{'call_id'} = time if $self->desktop;
    }

    if ( $params->{'method'} !~ m/^auth/xms ) {
        $params->{'session_key'} ||= $self->session_key;
        if ( !$params->{'callback'} && $self->callback ) {
            $params->{'callback'} = $self->callback;
        }
    }

    $params->{'method'} = "facebook.$params->{'method'}";
    $params->{'v'} ||= $self->api_version;

    $params->{$_} ||= $self->$_ for qw(api_key format);
    return;
}

sub _format_and_check_params {
    my ( $self, $method, %args ) = @_;

    my $params = delete $args{'params'} || {};
    $params->{$_} = $args{$_} for keys %args;
    $params->{'secret'} ||= $self->secret;
    $params->{'method'} ||= $method;

    $self->_check_values_of($params);

    # reformat arrays and add each param to digest
    for ( keys %{$params} ) {
        if ( ref $params->{$_} eq 'ARRAY' ) {
            $params->{$_} = join q{,}, @{ $params->{$_} };
        }

        if ( is_utf8( $params->{$_} ) ) {
            $params->{$_} = encode_utf8( $params->{$_} );
        }
    }

    croak '_format_and_check_params must be called in list context!'
        if !wantarray;

    return ( $params, delete $params->{'data'}, delete $params->{'filename'} );
}

sub _has_error_response {
    my $self     = shift;
    my $response = shift;

    # The different type of error responses
    my $json = q{ \{ "error_code" \D+ (\d+) .* "error_msg" [^"]+ "([^"]+)" };
    my $xml  = q{  (\d+) .*  ([^<]+)};

    for ( $json, $xml ) {
        if ( $response =~ m/$_/xms ) {
            $self->call_success( 0, "$1: $2" );
            return 1;
        }
    }

    return;
}

sub _reformat_response {
    my ( $self, $params, $response ) = @_;

    # get actual response when web app
    if ( $params->{'callback'} ) {
        $response =~ s/^$params->{'callback'} [^(]* [(](.+) [)];$/$1/xms;
    }
    undef $params;

    # ... and unescape it if it's not going to be parsed
    if ( !$self->desktop && !$self->parse ) {
        $response = $self->unescape_string($response);
    }

    if ( $self->parse && $self->format eq 'XML' ) {
        $self->parse(0);
        carp q{format is XML: setting parse to 0} if $self->debug;
    }
    return $response if !$self->parse;

    $response = $self->_parse($response);
    return if $self->_is_empty_response($response);
    return $response;
}

sub _is_empty_response {
    my ( $self, $response ) = @_;

    return 1 if ref $response eq 'HASH'  && !keys %{$response};
    return 1 if ref $response eq 'ARRAY' && @{$response} == 0;
    return;
}

sub _post_request {
    my ( $self, $params, $sig, $raw_data, $filename ) = @_;

    my $post_params = [ map { $_ => $params->{$_} } sort keys %{$params} ];
    push @{$post_params}, 'sig' => $sig;

    if ($raw_data) {
        push @{$post_params}, data => [
            undef, ( $filename || 'filename'),
            'Content-Type' => 'application/octet-stream',
            'Content'      => $raw_data,
        ];
    }
    return $self->ua->post(
        $self->server_uri,
        'Content_type' => 'form-data',
        'Content'      => $post_params,
    )->content;
}

1;    # Magic true value required at end of module
__END__