/lib/BitRest.pm

package BitRest;
# vim: set ft=perl et ts=4 sw=4:

=head1 NAME

BitRest - Bitbucket REST resources in Perl objects

=head1 VERSION

Version 0.43

=cut

our $VERSION = '0.43';

=head1 SYNOPSIS

    use BitRest;

    $cmd = BitRest->alias($cmd);

    BitRest->resource($res_name);

    my $res = BitRest->new($res_name);
    $res->id($id);
    $res->repo($repo);
    $res->color($color);
    $res->request($cmd, $user, $pass);

=head1 DESCRIPTION

B<BitRest> is a Perl module for convinient interface to Bitbucket REST APIs.

Implemented resources:

=over 4

=item * B<Issues> (L<BitRest::Issue>)

=back

This module is used in B<bit-rest> script.
Run C<bit-rest -M> to see its manual.

=cut

use strict;
use warnings;
use feature 'switch';
use Getopt::Long qw(:config no_ignore_case);
use URI::Escape 'uri_escape';
use WWW::Curl::Easy;
use JSON 'decode_json';
use Pod::Find 'pod_where';
use Pod::Usage;
use Data::Dumper;

# Variables

our $API_URL = 'https://api.bitbucket.org/1.0/';

# implicit specification of the implemented resources
our @RESOURCE = qw(issue);

# aliases for commands
our %ALIAS = (
    get    => 'get',
    list   => 'get',
    view   => 'get',
    add    => 'add',
    new    => 'add',
    put    => 'put',
    update => 'put',
    del    => 'del',
    delete => 'del'
);

# error message
our $errstr = '';

####  Subroutines

sub url_encode {
    my ( $p, $s ) = ( shift, '' );
    while ( my ( $k, $v ) = each(%$p) ) {
        if ( ref $v eq 'ARRAY' ) {
            $s .= uri_escape($k) . '=' . uri_escape($_) . '&' for @$v;
        }
        else {
            $s .= uri_escape($k) . '=' . uri_escape($v) . '&';
        }
    }
    return $s && substr $s, 0, -1;
}

=head1 METHODS

=over 4

=item B<BitRest>->B<new>(I<resource_name>)

Initialize the specified resource object and return its blessed reference.
If there are errors return B<undef>.

=cut

sub new {
    my ( $class, $res ) = @_;
    if ( !( $res ~~ @RESOURCE ) ) {
        $errstr = "Resource '$res' is not implemented!";
        return undef;
    }
    $class .= "::\u$res";
    eval "require $class";
    if ($@) {
        $errstr = "Class '$class' cannot be loaded!\n$@";
        return undef;
    }
    return eval $class . "->new";
}

=item B<BitRest>->B<init>()

Initialization of the resource object.
Used only by successors in their B<new> method.

    sub new {
        my $class = shift;
        my $self = $class->SUPER::init;
        # initialize $self fields
        return bless $self, $class;
    }

=cut

sub init {
    return bless {
        ACTIONS   => [],
        OPTIONS   => [],
        LINK      => '',
        REPO      => '',
        ID        => 0,
        COLOR     => 'auto',
        FMT_SHORT => '',
        FMT_LONG  => ''
    }, shift;
}

=item B<BitRest>->B<help>(I<resource_name>)

Display POD for the specified BitRest resource module.

=cut

sub help {
    my ( $class, $res ) = @_;
    $res && $res ~~ @RESOURCE or return;
    $class .= "::\u$res";
    my $f = pod_where( { -inc => 1, -verbose => 0 }, $class );
    pod2usage( -exitval => 0, -verbose => 3, -input => $f ) if $f;
}

=item B<request>(I<command>, I<options>, I<owner>, I<user>, I<password>)

Main method of the BitRest object which makes request
to the Bitbucket server using the REST API.

=over 4

=item I<command>

Command to apply to the resource(s).

=item I<options>

Reference to a hash with command line options.

=item I<owner>

User who owns the repository.

=item I<user> and I<password>

User name and password for authentication.

=back

Return value is the I<HTTP status code> if succeed.

Prior to using this method the caller should set B<REPO> and B<ID> fields
using corresponding methods.

=cut

sub request {
    my ( $self, $cmd, $opt, $owner, $user, $pass ) = @_;
    my $curl = WWW::Curl::Easy->new;
    my ( $json, $head, $r );

	$r = ref $self->{OPTIONS};
    GetOptions( $opt, (
		$r eq 'ARRAY' ? @{ $self->{OPTIONS} } : (
		$r eq 'HASH'  ? %{ $self->{OPTIONS} } : () )));
    $self->options($opt) if $self->can('options');
    my $url  = $self->url($owner) || return undef;
    my $data = url_encode($opt);

    # prepare CURL
    given ($cmd) {
        when ('get') {
            $curl->setopt( CURLOPT_HTTPGET,   1 );
            $curl->setopt( CURLOPT_WRITEDATA, \$json );
            $url .= "?$data" if $data;
        }
        when ('add') {
            $curl->setopt( CURLOPT_POST,          1 );
            $curl->setopt( CURLOPT_POSTFIELDS,    $data );
            $curl->setopt( CURLOPT_POSTFIELDSIZE, length $data );
        }
        when ('put') {
            if ( !$self->{ID} ) {
                $errstr = "Cannot update entry without id!";
                return undef;
            }
            $curl->setopt( CURLOPT_UPLOAD,     1 );
            $curl->setopt( CURLOPT_READDATA,   $data );
            $curl->setopt( CURLOPT_INFILESIZE, length $data );
        }
        when ('del') {
            if ( !$self->{ID} ) {
                $errstr = "Cannot delete entry without id!";
                return undef;
            }
            $curl->setopt( CURLOPT_CUSTOMREQUEST, 'DELETE' );
        }
    }

    # Send request and get response
    $curl->setopt( CURLOPT_URL,         $url );
    $curl->setopt( CURLOPT_USERNAME,    $user ) if $user;
    $curl->setopt( CURLOPT_PASSWORD,    $pass ) if $pass;
    $curl->setopt( CURLOPT_WRITEHEADER, \$head );
    if ( $r = $curl->perform ) {
        $errstr = "curl $r: " . $curl->strerror($r) . "\n" . $curl->errbuf;
        return undef;
    }

    $r = $curl->getinfo(CURLINFO_RESPONSE_CODE);
    $errstr = ( split /\n/, $head )[0] =~ s/^[^\s]+\s//r;
    $r >= 200 && $r < 300 or return undef;
    $self->print( decode_json $json) if $cmd eq 'get';
    return $r;
}

=item B<errstr>

Return B<errstr> - error message set if any error occurs in this module.

Also error message can be retrieved from B<$BitRest::errstr> variable.

=cut

sub errstr {
    return $errstr;
}

=item B<resource>([I<res_name>])

Check whether the resource I<res_name> is implemented
or return a list of the implemented resources if no parameters given.

=cut

sub resource {
    my $class = shift;
    return shift ~~ @RESOURCE if @_;
    return @RESOURCE;
}

=item B<alias>([I<command>])

Check whether the I<command> is an alias
or return a hash with aliases if no parameters given.

=cut

sub alias {
    my ( $class, $cmd ) = @_;
    return $ALIAS{$cmd} if defined $cmd;
    return %ALIAS;
}

=item B<color>([I<color>])

Set the B<COLOR> field to I<color> (can be B<auto>, B<always>, or B<never>)
or check whether the coloring should be used if no parameters given.

=cut

sub color {
    my $self = shift;
    $self->{COLOR} = shift if @_;
    return ( $self->{COLOR} eq 'always'
        || ( $self->{COLOR} eq 'auto' && -t STDOUT ) ? 1 : 0 );
}

=item B<id>([I<id>])

Set the B<ID> field to I<id> (can be string or integer)
or return current resource id if no parameters given.

=cut

sub id {
    my $self = shift;
    $self->{ID} = shift if @_;
    return $self->{ID};
}

=item B<repo>([I<repo_slug>])

Set the B<REPO> field to I<repo_slug> or return current repo slug
if no parameters given.

=cut

sub repo {
    my $self = shift;
    $self->{REPO} = shift if @_;
    return $self->{REPO};
}

=item B<url>(I<user_name>)

Make URL for HTTP REST request. Used internally.

=cut

sub url {
    my ( $self, $user ) = @_;
    my ( $url, $id ) = ( $self->{LINK}, $self->{ID} );
    if($url ~~ /%r/ && !$self->{REPO}){
        $errstr = "Repository name was not specified";
        return undef;
    }
    $url =~ s|%r|$self->{REPO}|g;
    $url =~ s|%u|$user|g;
    $id = $id ? "$id/" : "";
    $url =~ s|%i|$id|g;
    return $API_URL . $url;
}

=item B<print>(I<data>, I<resource_name>)

Print resource or list of resources.
I<data> is a reference to a hash with REST resource data. 
I<resource_name> is the name of the resource to print.

Used by successors in B<print> method:

    sub print {
        my($self, $data) = @_;
        $self->SUPER::print($data, 'resource_name');
    }

=cut

sub print {
    my ( $self, $data, $res ) = @_;
    if ( $self->{ID} ) {
        $self->format($self->{FMT_LONG}, $data)
    }
    else {
        $self->format($self->{FMT_SHORT}, $_) for @{ $data->{$res} }
    }
}

=item B<format>(I<format>, I<data>)

Print resource I<data> formatted using I<format> string.

=cut

sub format {
    no warnings;
    my ( $self, $fmt, $data ) = @_;
    my @arg;
    my $pat = qr/(%[-+0# ]?(?:[0-9]+)?(?:\.[0-9]+)?)([A-Za-z]{1,2})/o;
    $fmt =~ s/$pat/$self->fmt_choice($1, $2, \@arg, $data)/ge;
    printf $fmt . "\n", @arg;
}

sub fmt_choice {
    return 0;
}

=item B<colored>(I<string>, I<color_codes>)

Return I<string> surrounded by specified I<color codes>
if B<color> returns B<TRUE>.

=cut

sub colored {
    my ( $self, $s, $c ) = @_;
    return ( $self->color && $c ? "\e[${c}m$s\e[0m" : $s );
}

1;

__END__

=back

=head1 SEE ALSO

L<bit-rest>, BitRest::*

=head1 SOURCE

The source code repository for BitRest can be found at
L<https://bitbucket.org/vvp/bit-rest>.

=head1 BUGS

See the repository issue tracker at
L<https://bitbucket.org/vvp/bit-rest/issues>
to report and view bugs.

=head1 AUTHOR

vvp <vvp.psu[at]gmail.com>

=head1 LICENSE AND COPYRIGHT

Copyright (c) 2012 vvp (vvp.psu[at]gmail.com).
All rights reserved.

This module is free software; you can redstribute it and/or modify it under
the same terms as Perl itself. See L<perlartistic>.  This module is
distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY;
without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
PARTICULAR PURPOSE.