File Coverage

blib/lib/Net/STF/Client.pm
Criterion Covered Total %
statement 52 127 40.9
branch 4 40 10.0
condition 3 17 17.6
subroutine 15 19 78.9
pod 5 7 71.4
total 79 210 37.6


line stmt bran cond sub pod time code
1             package Net::STF::Client;
2 1     1   1034 use strict;
  1         2  
  1         40  
3 1     1   549 use Net::STF::Bucket;
  1         3  
  1         32  
4 1     1   677 use Net::STF::Object;
  1         2  
  1         28  
5 1     1   7 use Carp ();
  1         2  
  1         15  
6 1     1   1033 use Furl::HTTP;
  1         41421  
  1         57  
7 1     1   14383 use HTTP::Status ();
  1         15654  
  1         49  
8 1     1   1570 use MIME::Base64 ();
  1         2486  
  1         29  
9 1     1   9 use Scalar::Util ();
  1         3  
  1         16  
10 1     1   5 use URI ();
  1         2  
  1         30  
11             use Class::Accessor::Lite
12 1         192 rw => [ qw(
13             furl
14             agent_name
15             repl_count
16             url
17             error
18             username
19             password
20             ) ]
21 1     1   6 ;
  1         1  
22              
23             our $VERSION = '1.01';
24              
25             sub new {
26 1     1 1 1805 my $class = shift;
27              
28             # Grr, allow hashrefs
29 1 50 33     9 if (@_ == 1 && ref $_[0] eq 'HASH') {
30 0         0 @_ = %{$_[0]};
  0         0  
31             }
32              
33             # Only exists to provide back compat with non-published version.
34             # You shouldn't be using this
35 1 0 33     8 if ( @_ == 2 && ! ref $_[0] && ref $_[1] eq 'HASH' ) {
      33        
36             # Net::STF style
37 0         0 @_ = ( url => $_[0], %{$_[1]} );
  0         0  
38             }
39              
40 1         10 my $self = bless {
41             agent_name => join( '/', $class, $VERSION ),
42             repl_count => 3,
43             @_
44             }, $class;
45              
46 1 50       6 if (! $self->furl ) {
47 1         18 $self->furl(Furl::HTTP->new( agent => $self->agent_name ));
48             }
49              
50 1         141 return $self;
51             }
52              
53             sub _url_is_object {
54             # Make sure the URL contains more than one level in its path.
55             # Otherwise, you may end up getting stuff like
56             # DELETE http://stf.example.com/foo/
57             # instead of
58             # DELETE http://stf.example.com/foo/bar
59             # The former deletes the BUCKET, whereas the latter deletes the object.
60              
61             # XXX regex copied from URI.pm
62              
63 14     14   113 my (undef, undef, $path) =
64             $_[0] =~ m|(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?|;
65 14 50       74 if ($path =~ m{^/+[^/]+(?:/+[\./]*)?$}) {
66 14         3690 Carp::croak("Invalid object URL given -> $_[0]");
67             }
68 0         0 1;
69             }
70              
71             sub _qualify_url {
72 14     14   27 my ($self, $url) = @_;
73              
74 14         112 my $prefix = $self->url;
75 14 50       289 if (! $prefix) {
76 14         32 return $url;
77             }
78              
79 0         0 return URI->new($url)->abs($prefix)->canonical;
80             }
81              
82             sub get_object {
83 0     0 1 0 my ($self, $url, $opts) = @_;
84              
85 0         0 $self->error(undef);
86              
87 0         0 $url = $self->_qualify_url($url);
88              
89 0         0 my %furlopts = (
90             method => 'GET',
91             url => $url,
92             );
93 0         0 my @res = $self->send_request( \%furlopts, $opts );
94 0 0       0 if ( ! HTTP::Status::is_success( $res[1] ) ) {
95 0         0 $self->error( $res[2] );
96 0         0 return;
97             }
98 0         0 return Net::STF::Object->new(
99             url => $url,
100             content => $res[4]
101             );
102             }
103              
104             sub send_request {
105 0     0 0 0 my ($self, $furlopts, $opts) = @_;
106              
107 0   0     0 $furlopts->{headers} ||= [];
108              
109 0         0 my ($username, $password) = ( $self->username, $self->password );
110 0 0 0     0 if (defined $username && defined $password ) {
111 0         0 push @{ $furlopts->{headers} },
  0         0  
112             ( 'Authorization' => "Basic " . MIME::Base64::encode("$username:$password", "") );
113             }
114              
115 0 0       0 if ( $opts->{headers} ) {
116 0         0 push @{$furlopts->{headers}}, @{$opts->{headers}};
  0         0  
  0         0  
117             }
118 0         0 foreach my $key ( qw(write_file write_code) ) {
119 0 0       0 if (my $value = $opts->{$key}) {
120 0         0 $furlopts->{$key} = $value;
121             }
122             }
123 0         0 return $self->furl->request( %$furlopts );
124             }
125              
126             sub put_object {
127 7     7 1 15800 my ($self, $url, $content, $opts) = @_;
128              
129 7         26 $self->error(undef);
130              
131 7         78 $url = $self->_qualify_url($url);
132 7         18 _url_is_object($url);
133              
134 0 0       0 if (! defined $content ) {
135 0         0 Carp::croak( "No content provided" );
136             }
137              
138 0 0       0 if ( ref $content eq 'SCALAR' ) {
    0          
139             # raw string passed
140 0         0 $content = $$content;
141             } elsif ( Scalar::Util::openhandle( $content ) ) {
142             # make sure we're at the beginning of the file
143 0         0 seek $content, 0, 0;
144             } else {
145             # assume it's a file.
146 0 0       0 open my $fh, '<', $content
147             or die "Failed to open file $content: $!";
148 0         0 $content = $fh;
149 0         0 seek $content, 0, 0;
150             }
151              
152 0         0 my @hdrs;
153 0   0     0 push @hdrs,
154             ("X-STF-Replication-Count", ($opts->{repl_count} || $self->repl_count));
155 0 0       0 if (my $consistency = $opts->{consistency}) {
156 0         0 push @hdrs, "X-STF-Consistency", $consistency;
157             }
158              
159              
160 0         0 my %furlopts = (
161             method => 'PUT',
162             url => $url,
163             headers => \@hdrs,
164             content => $content,
165             );
166 0         0 my @res = $self->send_request( \%furlopts, $opts );
167 0 0       0 if (! HTTP::Status::is_success($res[1])) {
168 0         0 $self->error( $res[2] );
169 0         0 return;
170             }
171              
172             # if you don't want a result, then we don't create an object
173 0 0       0 return if !defined wantarray;
174              
175 0         0 return Net::STF::Object->new(
176             url => $url,
177             # content => $res[4]
178             );
179             }
180              
181             sub delete_object {
182 7     7 1 12082 my ($self, $url, $opts) = @_;
183              
184 7         30 $self->error(undef);
185              
186 7         54 $url = $self->_qualify_url($url);
187 7         18 _url_is_object($url);
188              
189 0           my %furlopts = (
190             method => 'DELETE',
191             url => $url,
192             );
193 0           my @res = $self->send_request( \%furlopts, $opts );
194 0 0         if ( ! HTTP::Status::is_success( $res[1] ) ) {
195 0           $self->error( $res[2] );
196 0           return;
197             }
198 0           return 1;
199             }
200              
201             sub create_bucket {
202 0     0 0   my ($self, $url, $opts) = @_;
203              
204 0           $self->error(undef);
205              
206 0           $url = $self->_qualify_url($url);
207              
208 0           my %furlopts = (
209             method => 'PUT',
210             url => $url,
211             headers => [
212             'Content-Length' => 0,
213             ],
214             );
215 0           my @res = $self->send_request( \%furlopts, $opts );
216 0 0         if (! HTTP::Status::is_success( $res[1] ) ) {
217 0           $self->error( $res[2] );
218 0           return;
219             }
220              
221 0           return Net::STF::Bucket->new(
222             client => $self,
223             name => ( URI->new($url)->path =~ m{^/([^/]+)} )[0],
224             );
225             }
226              
227             sub delete_bucket {
228 0     0 1   my ($self, $url, $opts) = @_;
229              
230 0           $self->error(undef);
231              
232 0           my @hdrs;
233 0 0         if ( $opts->{recursive} ) {
234 0           push @hdrs, "X-STF-Recursive-Delete" => "true";
235             }
236              
237 0           $url = $self->_qualify_url($url);
238              
239 0           my %furlopts = (
240             method => 'DELETE',
241             headers => \@hdrs,
242             url => $url,
243             );
244              
245 0           my @res = $self->send_request( \%furlopts, $opts );
246 0 0         if (! HTTP::Status::is_success( $res[1] ) ) {
247 0           $self->error( $res[2] );
248 0           return;
249             }
250              
251 0           return 1;
252             }
253              
254             1;
255              
256             __END__