File Coverage

blib/lib/WWW/FBX/API.pm
Criterion Covered Total %
statement 41 62 66.1
branch 1 14 7.1
condition 0 3 0.0
subroutine 11 117 9.4
pod 0 3 0.0
total 53 199 26.6


line stmt bran cond sub pod time code
1             package WWW::FBX::API;
2 24     24   13832 use 5.014001;
  24         58  
3 24     24   508 use Moose();
  24         317293  
  24         387  
4 24     24   655 use Carp::Clan qw/^(?:WWW::FBX|Moose|Class::MOP)/;
  24         1607  
  24         149  
5 24     24   4089 use Moose::Exporter;
  24         39  
  24         132  
6 24     24   1077 use URI::Escape;
  24         1410  
  24         1105  
7              
8 24     24   604 use namespace::autoclean;
  24         6696  
  24         117  
9              
10             Moose::Exporter->setup_import_methods(
11             with_caller => [ qw/api_url fbx_api_method/ ],
12             );
13              
14             my $_api_url;
15              
16 0     0 0 0 sub api_url { $_api_url = $_[1]; }
17              
18             sub fbx_api_method {
19 2370     2370 0 1082990 my $caller = shift;
20 2370         2413 my $name = shift;
21 2370         6433 my %options = (
22             @_,
23             );
24 2370         1912 my $args;
25              
26             #Remove trailing _
27 2370         3401 $name =~ s/_$//;
28              
29 2370         5732 my $class = Moose::Meta::Class->initialize($caller);
30              
31 2370         24538 my ($arg_names, $all_args) = @options{qw/required params/};
32              
33             my $code = sub {
34 0     0   0 my $self = shift;
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
        0      
35 0 0       0 my $args = ref $_[-1] eq 'HASH' ? { %{pop @_} } : {};
  0         0  
36              
37 0 0       0 croak sprintf "$name expected %d args", scalar @$all_args if @_ > @$all_args;
38              
39             # promote positional args to named args
40 0         0 for ( my $i = 0; @_; ++$i ) {
41 0         0 my $param = $all_args->[$i];
42             croak "duplicate param $param: both positional and named"
43 0 0       0 if exists $args->{$param};
44              
45 0         0 $args->{$param} = shift;
46             }
47              
48 0         0 for my $arg (keys %$args) {
49 0 0       0 unless ( grep { $_ eq $arg } @$all_args ) {
  0         0  
50 0         0 die "Unknown argument $arg for $name\n" , "Description:$options{description}" ,
51             "Params:", join(",",@$all_args), "\nRequired:", join(",", @$arg_names), "\n" ;
52             }
53             }
54              
55 0         0 for my $req (@$arg_names) {
56 0 0 0     0 unless ( grep { $_ eq $req } keys %$args or !defined ($args->{req}) ) {
  0         0  
57 0         0 die "Missing required param $req for $name\n", "Description:$options{description}" ,
58             "Params:", join(",",@$all_args), "\nRequired:", join(",", @$arg_names), "\n" ;
59             }
60             }
61 0         0 my $path = $options{path};
62 0 0       0 $path .= delete $args->{suff} if exists $args->{suff};
63              
64 0         0 my $uri = URI->new( $self->base_url . "$_api_url/$path");
65              
66             return $self->_json_request(
67             $options{method},
68             $uri,
69             $args,
70             $options{content_type}
71 0         0 );
72 2370         11225 };
73             #Add method with name and Class::MOP::Method
74 2370         7400 $class->add_method(
75             $name,
76             WWW::FBX::Meta::Method->new(
77             name => $name,
78             package_name => $caller,
79             body => $code,
80             %options,
81             ),
82             );
83              
84             }
85              
86             package WWW::FBX::Meta::Method;
87 24     24   12253 use Moose;
  24         26  
  24         125  
88 24     24   98194 use Carp::Clan qw/^(?:WWW::FBX|Moose|Class::MOP)/;
  24         32  
  24         83  
89             extends 'Moose::Meta::Method';
90              
91 24     24   3429 use namespace::autoclean;
  24         28  
  24         83  
92              
93             has description => ( isa => 'Str', is => 'ro', required => 1 );
94             has path => ( isa => 'Str', is => 'ro', required => 1 );
95             has method => ( isa => 'Str', is => 'ro', default => 'GET' );
96             has params => ( isa => 'ArrayRef[Str]', is => 'ro', default => sub { [] } );
97             has required => ( isa => 'ArrayRef[Str]', is => 'ro', default => sub { [] } );
98             has returns => ( isa => 'Str', is => 'ro', predicate => 'has_returns' );
99             has content_type => ( isa => 'Str', is => 'ro', default => '' );
100             has suff => ( isa => 'Str', is => 'ro', default => '' );
101              
102             #Build hash where keys are attribute names
103             my %valid_attribute_names = map { $_->init_arg => 1 }
104             __PACKAGE__->meta->get_all_attributes;
105              
106             sub new {
107 2370     2370 0 2009 my $class = shift;
108 2370         6527 my %args = @_;
109              
110             #Stack arguments that are not expected attributes
111 2370         4953 my @invalid_attributes = grep { !$valid_attribute_names{$_} } keys %args;
  19029         18967  
112 2370 50       5041 croak "unexpected argument(s): @invalid_attributes" if @invalid_attributes;
113              
114             #Create method
115 2370         6136 $class->SUPER::wrap(@_);
116             }
117              
118             1;
119             __END__
120              
121             =encoding utf-8
122              
123             =head1 NAME
124              
125             WWW::FBX::API - Freebox API sugar
126              
127             =head1 SYNOPSIS
128              
129             use WWW::FBX::API;
130              
131             =head1 DESCRIPTION
132              
133             WWW::FBX::API is API sugar
134              
135             =head1 LICENSE
136              
137             Copyright (C) Laurent Kislaire.
138              
139             This library is free software; you can redistribute it and/or modify
140             it under the same terms as Perl itself.
141              
142             =head1 AUTHOR
143              
144             Laurent Kislaire E<lt>teebeenator@gmail.comE<gt>
145              
146             =cut
147