File Coverage

blib/lib/HTTP/Request.pm
Criterion Covered Total %
statement 69 73 94.5
branch 32 36 88.8
condition 18 21 85.7
subroutine 12 12 100.0
pod 8 9 88.8
total 139 151 92.0


line stmt bran cond sub pod time code
1             package HTTP::Request;
2              
3 8     8   142902 use strict;
  8         30  
  8         255  
4 8     8   39 use warnings;
  8         14  
  8         364  
5              
6             our $VERSION = '6.45';
7              
8 8     8   2648 use parent 'HTTP::Message';
  8         1913  
  8         45  
9              
10             sub new
11             {
12 43     43 1 9854 my($class, $method, $uri, $header, $content) = @_;
13 43         173 my $self = $class->SUPER::new($header, $content);
14 43         127 $self->method($method);
15 43         106 $self->uri($uri);
16 41         120 $self;
17             }
18              
19              
20             sub parse
21             {
22 7     7 1 521 my($class, $str) = @_;
23 7 100 100     152 Carp::carp('Undefined argument to parse()') if $^W && ! defined $str;
24 7         16 my $request_line;
25 7 100 100     64 if (defined $str && $str =~ s/^(.*)\n//) {
26 3         13 $request_line = $1;
27             }
28             else {
29 4         8 $request_line = $str;
30 4         5 $str = "";
31             }
32              
33 7         40 my $self = $class->SUPER::parse($str);
34 7 100       23 if (defined $request_line) {
35 5         23 my($method, $uri, $protocol) = split(' ', $request_line);
36 5         24 $self->method($method);
37 5 100       20 $self->uri($uri) if defined($uri);
38 5 100       28 $self->protocol($protocol) if $protocol;
39             }
40 7         31 $self;
41             }
42              
43              
44             sub clone
45             {
46 1     1 1 2 my $self = shift;
47 1         6 my $clone = bless $self->SUPER::clone, ref($self);
48 1         4 $clone->method($self->method);
49 1         4 $clone->uri($self->uri);
50 1         3 $clone;
51             }
52              
53              
54             sub method
55             {
56 99     99 1 4093 shift->_elem('_method', @_);
57             }
58              
59              
60             sub uri
61             {
62 97     97 1 1350 my $self = shift;
63 97         172 my $old = $self->{'_uri'};
64 97 100       212 if (@_) {
65 52         82 my $uri = shift;
66 52 100       146 if (!defined $uri) {
    100          
67             # that's ok
68             }
69             elsif (ref $uri) {
70 8 100 100     195 Carp::croak("A URI can't be a " . ref($uri) . " reference")
71             if ref($uri) eq 'HASH' or ref($uri) eq 'ARRAY';
72 6 100 100     391 Carp::croak("Can't use a " . ref($uri) . " object as a URI")
73             unless $uri->can('scheme') && $uri->can('canonical');
74 4         58 $uri = $uri->clone;
75 4 50       103 unless ($HTTP::URI_CLASS eq "URI") {
76             # Argh!! Hate this... old LWP legacy!
77 0         0 eval { local $SIG{__DIE__}; $uri = $uri->abs; };
  0         0  
  0         0  
78 0 0 0     0 die $@ if $@ && $@ !~ /Missing base argument/;
79             }
80             }
81             else {
82 42         180 $uri = $HTTP::URI_CLASS->new($uri);
83             }
84 48         56850 $self->{'_uri'} = $uri;
85 48         101 delete $self->{'_uri_canonical'};
86             }
87 93         322 $old;
88             }
89              
90             *url = \&uri; # legacy
91              
92             sub uri_canonical
93             {
94 13     13 0 1585 my $self = shift;
95              
96 13         23 my $uri = $self->{_uri};
97              
98 13 100       38 if (defined (my $canon = $self->{_uri_canonical})) {
99             # early bailout if these are the exact same string;
100             # rely on stringification of the URI objects
101 9 50       46 return $canon if $canon eq $uri;
102             }
103              
104             # otherwise we need to refresh the memoized value
105 4         19 $self->{_uri_canonical} = $uri->canonical;
106             }
107              
108              
109             sub accept_decodable
110             {
111 1     1 1 6 my $self = shift;
112 1         12 $self->header("Accept-Encoding", scalar($self->decodable));
113             }
114              
115             sub as_string
116             {
117 15     15 1 66 my $self = shift;
118 15         27 my($eol) = @_;
119 15 100       42 $eol = "\n" unless defined $eol;
120              
121 15   100     34 my $req_line = $self->method || "-";
122 15         39 my $uri = $self->uri;
123 15 100       90 $uri = (defined $uri) ? $uri->as_string : "-";
124 15         288 $req_line .= " $uri";
125 15         47 my $proto = $self->protocol;
126 15 100       34 $req_line .= " $proto" if $proto;
127              
128 15         57 return join($eol, $req_line, $self->SUPER::as_string(@_));
129             }
130              
131             sub dump
132             {
133 3     3 1 7 my $self = shift;
134 3   100     9 my @pre = ($self->method || "-", $self->uri || "-");
      100        
135 3 100       22 if (my $prot = $self->protocol) {
136 1         2 push(@pre, $prot);
137             }
138              
139 3         13 return $self->SUPER::dump(
140             preheader => join(" ", @pre),
141             @_,
142             );
143             }
144              
145              
146             1;
147              
148             =pod
149              
150             =encoding UTF-8
151              
152             =head1 NAME
153              
154             HTTP::Request - HTTP style request message
155              
156             =head1 VERSION
157              
158             version 6.45
159              
160             =head1 SYNOPSIS
161              
162             require HTTP::Request;
163             $request = HTTP::Request->new(GET => 'http://www.example.com/');
164              
165             and usually used like this:
166              
167             $ua = LWP::UserAgent->new;
168             $response = $ua->request($request);
169              
170             =head1 DESCRIPTION
171              
172             C is a class encapsulating HTTP style requests,
173             consisting of a request line, some headers, and a content body. Note
174             that the LWP library uses HTTP style requests even for non-HTTP
175             protocols. Instances of this class are usually passed to the
176             request() method of an C object.
177              
178             C is a subclass of C and therefore
179             inherits its methods. The following additional methods are available:
180              
181             =over 4
182              
183             =item $r = HTTP::Request->new( $method, $uri )
184              
185             =item $r = HTTP::Request->new( $method, $uri, $header )
186              
187             =item $r = HTTP::Request->new( $method, $uri, $header, $content )
188              
189             Constructs a new C object describing a request on the
190             object $uri using method $method. The $method argument must be a
191             string. The $uri argument can be either a string, or a reference to a
192             C object. The optional $header argument should be a reference to
193             an C object or a plain array reference of key/value
194             pairs. The optional $content argument should be a string of bytes.
195              
196             =item $r = HTTP::Request->parse( $str )
197              
198             This constructs a new request object by parsing the given string.
199              
200             =item $r->method
201              
202             =item $r->method( $val )
203              
204             This is used to get/set the method attribute. The method should be a
205             short string like "GET", "HEAD", "PUT", "PATCH" or "POST".
206              
207             =item $r->uri
208              
209             =item $r->uri( $val )
210              
211             This is used to get/set the uri attribute. The $val can be a
212             reference to a URI object or a plain string. If a string is given,
213             then it should be parsable as an absolute URI.
214              
215             =item $r->header( $field )
216              
217             =item $r->header( $field => $value )
218              
219             This is used to get/set header values and it is inherited from
220             C via C. See L for
221             details and other similar methods that can be used to access the
222             headers.
223              
224             =item $r->accept_decodable
225              
226             This will set the C header to the list of encodings
227             that decoded_content() can decode.
228              
229             =item $r->content
230              
231             =item $r->content( $bytes )
232              
233             This is used to get/set the content and it is inherited from the
234             C base class. See L for details and
235             other methods that can be used to access the content.
236              
237             Note that the content should be a string of bytes. Strings in perl
238             can contain characters outside the range of a byte. The C
239             module can be used to turn such strings into a string of bytes.
240              
241             =item $r->as_string
242              
243             =item $r->as_string( $eol )
244              
245             Method returning a textual representation of the request.
246              
247             =back
248              
249             =head1 EXAMPLES
250              
251             Creating requests to be sent with L or others can be easy. Here
252             are a few examples.
253              
254             =head2 Simple POST
255              
256             Here, we'll create a simple POST request that could be used to send JSON data
257             to an endpoint.
258              
259             #!/usr/bin/env perl
260              
261             use strict;
262             use warnings;
263              
264             use HTTP::Request ();
265             use JSON::MaybeXS qw(encode_json);
266              
267             my $url = 'https://www.example.com/api/user/123';
268             my $header = ['Content-Type' => 'application/json; charset=UTF-8'];
269             my $data = {foo => 'bar', baz => 'quux'};
270             my $encoded_data = encode_json($data);
271              
272             my $r = HTTP::Request->new('POST', $url, $header, $encoded_data);
273             # at this point, we could send it via LWP::UserAgent
274             # my $ua = LWP::UserAgent->new();
275             # my $res = $ua->request($r);
276              
277             =head2 Batch POST Request
278              
279             Some services, like Google, allow multiple requests to be sent in one batch.
280             L for example. Using the
281             C method from L makes this simple.
282              
283             #!/usr/bin/env perl
284              
285             use strict;
286             use warnings;
287              
288             use HTTP::Request ();
289             use JSON::MaybeXS qw(encode_json);
290              
291             my $auth_token = 'auth_token';
292             my $batch_url = 'https://www.googleapis.com/batch';
293             my $url = 'https://www.googleapis.com/drive/v3/files/fileId/permissions?fields=id';
294             my $url_no_email = 'https://www.googleapis.com/drive/v3/files/fileId/permissions?fields=id&sendNotificationEmail=false';
295              
296             # generate a JSON post request for one of the batch entries
297             my $req1 = build_json_request($url, {
298             emailAddress => 'example@appsrocks.com',
299             role => "writer",
300             type => "user",
301             });
302              
303             # generate a JSON post request for one of the batch entries
304             my $req2 = build_json_request($url_no_email, {
305             domain => "appsrocks.com",
306             role => "reader",
307             type => "domain",
308             });
309              
310             # generate a multipart request to send all of the other requests
311             my $r = HTTP::Request->new('POST', $batch_url, [
312             'Accept-Encoding' => 'gzip',
313             # if we don't provide a boundary here, HTTP::Message will generate
314             # one for us. We could use UUID::uuid() here if we wanted.
315             'Content-Type' => 'multipart/mixed; boundary=END_OF_PART'
316             ]);
317              
318             # add the two POST requests to the main request
319             $r->add_part($req1, $req2);
320             # at this point, we could send it via LWP::UserAgent
321             # my $ua = LWP::UserAgent->new();
322             # my $res = $ua->request($r);
323             exit();
324              
325             sub build_json_request {
326             my ($url, $href) = @_;
327             my $header = ['Authorization' => "Bearer $auth_token", 'Content-Type' => 'application/json; charset=UTF-8'];
328             return HTTP::Request->new('POST', $url, $header, encode_json($href));
329             }
330              
331             =head1 SEE ALSO
332              
333             L, L, L,
334             L
335              
336             =head1 AUTHOR
337              
338             Gisle Aas
339              
340             =head1 COPYRIGHT AND LICENSE
341              
342             This software is copyright (c) 1994 by Gisle Aas.
343              
344             This is free software; you can redistribute it and/or modify it under
345             the same terms as the Perl 5 programming language system itself.
346              
347             =cut
348              
349             __END__