/lib/BitRest.pm
Perl | 444 lines | 314 code | 121 blank | 9 comment | 45 complexity | 4b04e819282e63626340f64590cd15a7 MD5 | raw file
- 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.