WWW::Plurk - Unoffical plurk.com API

    use WWW::Plurk;
    my $plurk = WWW::Plurk->new;
    $plurk->login( 'username', 'password' );
    my $msg = $plurk->add_plurk( content => 'Hello, World' );

    # Create and login
    my $plurk = WWW::Plurk->new( 'user', 'pass' );

    # Create then login afterwards
    my $plurk = WWW::Plurk->new;
    $plurk->login( 'user', 'pass' );

    my $plurk = WWW::Plurk->new;
    $plurk->login( 'user', 'pass' );

    if ( $plurk->is_logged_in ) {
        $plurk->add_plurk( content => 'w00t!' );
    }

    my @friends = $plurk->friends_for( $uid );

    my @friends = $plurk->friends;

    my @friends = $plurk->friends_for( $self->uid );

    $plurk->add_plurk(
        content => 'Hello, World'
    );

  asks feels gives has hates is likes loves 
  says shares thinks wants was will wishes

    my $msg = $plurk->add_plurk(
        content => 'Hi chums',
        limited_to => [ $plurk->friends ]
    );

    my @plurks = $plurk->plurks;

    my @responses = $plurk->responses_for( $msg->plurk_id );

    my $responce = $plurk->respond_to_plurk(
        $plurk_id,
        content => 'Nice!'
    );

    * Redistributions of source code must retain the above copyright
      notice, this list of conditions and the following disclaimer.
    * Redistributions in binary form must reproduce the above copyright
      notice, this list of conditions and the following disclaimer in
      the documentation and/or other materials provided with the
      distribution.
    * Neither the name Message Systems, Inc. nor the names of its
      contributors may be used to endorse or promote products derived
      from this software without specific prior written permission.

package WWW::Plurk;

use warnings;
use strict;

use Carp;
use DateTime::Format::Mail;
use HTML::Tiny;
use HTTP::Cookies;
use JSON;
use Data::Dumper;
use LWP::UserAgent;
use Time::Piece;
use WWW::Plurk::Friend;
use WWW::Plurk::Message;

our $VERSION = '0.02';

# Default API URIs

use constant MAX_MESSAGE_LENGTH => 140;

my $BASE_DEFAULT = 'http://www.plurk.com';

my %PATH_DEFAULT = (
    accept_friend     => '/Notifications/allow',
    add_plurk         => '/TimeLine/addPlurk',
    add_response      => '/Responses/add',
    deny_friend       => '/Notifications/deny',
    get_completion    => '/Users/getCompletion',
    get_friends       => '/Users/getFriends',
    get_plurks        => '/TimeLine/getPlurks',
    get_responses     => '/Responses/get2',
    get_unread_plurks => '/TimeLine/getUnreadPlurks',
    home              => undef,
    login             => '/Users/login?redirect_page=main',
    notifications     => '/Notifications',
);

BEGIN {
    my @ATTR = qw(
      _base_uri
      info
      state
      trace
    );

    my @INFO = qw(
      display_name
      full_name
      gender
      has_profile_image
      id
      is_channel
      karma
      location
      nick_name
      page_title
      relationship
      star_reward
      uid
    );

    for my $attr ( @ATTR ) {
        no strict 'refs';
        *{$attr} = sub {
            my $self = shift;
            return $self->{$attr} unless @_;
            return $self->{$attr} = shift;
        };
    }

    for my $info ( @INFO ) {
        no strict 'refs';
        *{$info} = sub {
            my $self = shift;
            # Info attributes only available when logged in
            $self->_logged_in;
            return $self->info->{$info};
        };
    }
}

sub new {
    my $class = shift;
    my $self  = bless {
        _base_uri => $BASE_DEFAULT,
        path      => {%PATH_DEFAULT},
        state     => 'init',
        trace     => $ENV{PLURK_TRACE} ? 1 : 0,
    }, $class;

    if ( @_ ) {
        croak "Need two arguments (user, pass) if any are supplied"
          unless @_ == 2;
        $self->login( @_ );
    }

    return $self;
}

sub _make_ua {
    my $self = shift;
    my $ua   = LWP::UserAgent->new;
    $ua->agent( join ' ', __PACKAGE__, $VERSION );
    $ua->cookie_jar( HTTP::Cookies->new );
    return $ua;
}

sub _ua {
    my $self = shift;
    return $self->{_ua} ||= $self->_make_ua;
}

sub _trace {
    my ( $self, @msgs ) = @_;
    if ( $self->trace ) {
        print STDERR "$_\n" for @msgs;
    }
}

sub _raw_post {
    my ( $self, $uri, $params ) = @_;
    $self->_trace(
        POST => $uri,
        Data::Dumper->Dump( [$params], [qw($params)] )
    );
    my $resp = $self->_ua->post( $uri, $params );
    $self->_trace( $resp->status_line );
    return $resp;
}

sub _raw_get {
    my ( $self, $uri ) = @_;
    $self->_trace( GET => $uri );
    my $resp = $self->_ua->get( $uri );
    $self->_trace( $resp->status_line );
    return $resp;
}

sub _cookies { shift->_ua->cookie_jar }

sub _post {
    my ( $self, $service, $params ) = @_;
    my $resp
      = $self->_raw_post( $self->_uri_for( $service ), $params || {} );
    croak $resp->status_line
      unless $resp->is_success
          or $resp->is_redirect;
    return $resp;
}

sub _json_post {
    my $self = shift;
    return $self->_decode_json( $self->_post( @_ )->content );
}

sub _get {
    my ( $self, $service, $params ) = @_;
    my $resp
      = $self->_raw_get( $self->_uri_for( $service, $params || {} ) );
    croak $resp->status_line
      unless $resp->is_success
          or $resp->is_redirect;
    return $resp;
}

sub _json_get {
    my $self = shift;
    return $self->_decode_json( $self->_get( @_ )->content );
}

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

    my $resp = $self->_post(
        login => {
            nick_name => $name,
            password  => $pass,
        }
    );

    my $ok = 0;
    $self->_cookies->scan( sub { $ok++ if $_[1] eq 'plurkcookie' } );
    croak "Login for $name failed, no cookie returned"
      unless $ok;

    $self->_path_for( home => $resp->header( 'Location' )
          || "/user/$name" );

    $self->_parse_user_home;
    $self->state( 'login' );
}

sub _parse_time {
    my ( $self, $time ) = @_;
    return DateTime::Format::Mail->parse_datetime( $time )->epoch;
}

# This is a bit of a bodge. Plurk doesn't return pure JSON; instead it
# returns JavaScript that's nearly JSON apart from the fact that
# timestamps are specified as 'new Date("...")'. So we need to hoist
# those out of the text and replace them with the corresponding epoch
# timestamp.
#
# Theoretically we could just do a search and replace. Because the Date
# constructor contains a quoted string there's no danger of false
# positives when someone happens to post a message that contains
# matching text - because in that case the nested quotes would be
# backslashed and the regex wouldn't match.
#
# Of course that didn't occur to me until /after/ I'd written the code
# to pull all the string literals out of the text before replacing the
# Date constructors...
#
# I'll leave that code in place because it's useful to have lying around
# in case some future version of this routine has to handle embedded JS
# that could collide with the contents of string literals.

sub _decode_json {
    my ( $self, $json ) = @_;

    my %strings    = ();
    my $next_token = 1;

    my $tok = sub {
        my $str = shift;
        my $key = sprintf '#%d#', $next_token++;
        $strings{$key} = $str;
        return qq{"$key"};
    };

    # Stash string literals to avoid false positives
    $json =~ s{ " ( (?: \\. | [^\\"]+ )* ) " }{ $tok->( $1 ) }xeg;

    # Plurk actually returns JS rather than JSON.
    $json =~ s{ new \s+ Date \s* \( \s* " (\#\d+\#) " \s* \) }
                { $self->_parse_time( $strings{$1} ) }xeg;

    # Replace string literals
    $json =~ s{ " (\#\d+\#) " }{ qq{"$strings{$1}"} }xeg;

    # Now we have JSON
    return decode_json $json;
}

sub _parse_user_home {
    my $self = shift;
    my $resp = $self->_get( 'home' );
    if ( $resp->content =~ /^\s*var\s+GLOBAL\s*=\s*(.+)$/m ) {
        my $global = $self->_decode_json( $1 );
        $self->info(
            $global->{session_user}
              or croak "No session_user data found"
        );
    }
    else {
        croak "Can't find GLOBAL data on user page";
    }
}

sub is_logged_in { shift->state eq 'login' }

sub _logged_in {
    my $self = shift;
    croak "Please login first"
      unless $self->is_logged_in;
}

sub friends_for {
    my $self = shift;
    my $for = $self->_uid_cast( shift || $self );
    $self->_logged_in;
    my $friends
      = $self->_json_get( get_completion => { user_id => $for } );
    return map { WWW::Plurk::Friend->new( $self, $_, $friends->{$_} ) }
      keys %$friends;
}

sub friends {
    my $self = shift;
    return $self->friends_for( $self );
}

sub _is_user {
    my ( $self, $obj ) = @_;
    return UNIVERSAL::can( $obj, 'can' ) && $obj->can( 'uid' );
}

sub _uid_cast {
    my ( $self, $obj ) = @_;
    return $self->_is_user( $obj ) ? $obj->uid : $obj;
}

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

    croak "Needs a number of key => value pairs"
      if @args & 1;
    my %args = @args;

    my $content = delete $args{content} || croak "Must have content";
    my $lang    = delete $args{lang}    || 'en';
    my $qualifier = delete $args{qualifier} || ':';

    my @extras = $cb->( \%args );

    if ( my @unknown = sort keys %args ) {
        croak "Unknown parameter(s): ", join ',', @unknown;
    }

    if ( length $content > MAX_MESSAGE_LENGTH ) {
        croak 'Plurks are limited to '
          . MAX_MESSAGE_LENGTH
          . ' characters';
    }

    return ( $content, $lang, $qualifier, @extras );
}

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

    my ( $content, $lang, $qualifier, $no_comments, @limit )
      = $self->_msg_common(
        sub {
            my $args        = shift;
            my $no_comments = delete $args->{no_comments};
            my @limit       = @{ delete $args->{limit} || [] };
            return ( $no_comments, @limit );
        },
        @args
      );

    my $reply = $self->_json_post(
        add_plurk => {
            posted      => localtime()->datetime,
            qualifier   => $qualifier,
            content     => $content,
            lang        => $lang,
            uid         => $self->uid,
            no_comments => ( $no_comments ? 1 : 0 ),
            @limit
            ? ( limited_to => '['
                  . join( ',', map { $self->_uid_cast( $_ ) } @limit )
                  . ']' )
            : (),
        }
    );

    if ( my $error = $reply->{error} ) {
        croak "Error posting: $error";
    }

    return WWW::Plurk::Message->new( $self, $reply->{plurk} );
}

sub plurks {
    my ( $self, @args ) = @_;
    croak "Needs a number of key => value pairs"
      if @args & 1;
    my %args = @args;

    my $uid = $self->_uid_cast( delete $args{uid} || $self );

    my $date_from   = delete $args{date_from};
    my $date_offset = delete $args{date_offset};

    if ( my @extra = sort keys %args ) {
        croak "Unknown parameter(s): ", join ',', @extra;
    }

    my $reply = $self->_json_post(
        get_plurks => {
            user_id => $uid,
            defined $date_from
            ? ( from_date => gmtime( $date_from )->datetime )
            : (),
            defined $date_offset
            ? ( offset => gmtime( $date_offset )->datetime )
            : (),
        }
    );

    return
      map { WWW::Plurk::Message->new( $self, $_ ) } @{ $reply || [] };
}

sub unread_plurks {
    my $self = shift;
    my $reply = $self->_json_post( get_unread_plurks => {} );
    return
      map { WWW::Plurk::Message->new( $self, $_ ) } @{ $reply || [] };
}

# Plurk returns an empty array rather than an empty hash if there
# are no elements. D'you think it's written in PHP? :)
#
# (That's not a dig at PHP, but since arrays and hashes are the same
# thing in PHP I assume the JSON encoder can't tell what an empty
# hash/array is)

sub _want_hash {
    my ( $self, $hash, @keys ) = @_;
    # Replace empty arrays with empty hashes at the top level of a hash.
    for my $key ( @keys ) {
        $hash->{$key} = {}
          if !exists $hash->{$key}
              || ( 'ARRAY' eq ref $hash->{$key}
                  && @{ $hash->{$key} } == 0 );
    }
}

sub responses_for {
    my ( $self, $plurk_id ) = @_;

    my $reply
      = $self->_json_post( get_responses => { plurk_id => $plurk_id } );

    $self->_want_hash( $reply, 'friends' );

    my %friends = map {
        $_ =>
          WWW::Plurk::Friend->new( $self, $_, $reply->{friends}{$_} )
    } keys %{ $reply->{friends} };

    return map {
        WWW::Plurk::Message->new( $self, $_, $friends{ $_->{user_id} } )
    } @{ $reply->{responses} || [] };
}

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

    my ( $content, $lang, $qualifier )
      = $self->_msg_common( sub { () }, @args );

    my $reply = $self->_json_post(
        add_response => {
            posted    => localtime()->datetime,
            qualifier => $qualifier,
            content   => $content,
            lang      => $lang,
            p_uid     => $self->uid,
            plurk_id  => $plurk_id,
            uid       => $self->uid,
        }
    );

    if ( my $error = $reply->{error} ) {
        croak "Error posting: $error";
    }

    return WWW::Plurk::Message->new( $self, $reply->{object} );
}

sub _path_for {
    my ( $self, $service ) = ( shift, shift );
    croak "Unknown service $service"
      unless exists $PATH_DEFAULT{$service};
    return $self->{path}{$service} unless @_;
    return $self->{path}{$service} = shift;
}

sub _uri_for {
    my ( $self, $service ) = ( shift, shift );
    my $uri = $self->_base_uri . $self->_path_for( $service );
    return $uri unless @_;
    my $params = shift;
    return join '?', $uri, HTML::Tiny->new->query_encode( $params );
}

1;
__END__