← Index
NYTProf Performance Profile   « block view • line view • sub view »
For ddd2.pl
  Run on Tue May 25 16:52:24 2010
Reported on Tue May 25 16:56:46 2010

File /project/perl/lib/HTTP/Request/Common.pm
Statements Executed 2784
Statement Execution Time 42.7ms
Subroutines — ordered by exclusive time
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
4611128.1ms323msHTTP::Request::Common::::_simple_reqHTTP::Request::Common::_simple_req
4611111.6ms335msHTTP::Request::Common::::GETHTTP::Request::Common::GET
11219µs19µsHTTP::Request::Common::::CORE:matchHTTP::Request::Common::CORE:match (opcode)
0000s0sHTTP::Request::Common::::BEGINHTTP::Request::Common::BEGIN
0000s0sHTTP::Request::Common::::HEADHTTP::Request::Common::HEAD
0000s0sHTTP::Request::Common::::POSTHTTP::Request::Common::POST
0000s0sHTTP::Request::Common::::PUTHTTP::Request::Common::PUT
0000s0sHTTP::Request::Common::::__ANON__[:247]HTTP::Request::Common::__ANON__[:247]
0000s0sHTTP::Request::Common::::boundaryHTTP::Request::Common::boundary
0000s0sHTTP::Request::Common::::form_dataHTTP::Request::Common::form_data
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments		 Time
on line		 Calls Time
in subs		 Code
1# $Id: Common.pm,v 1.26 2004/11/15 14:52:37 gisle Exp $
2#
3package HTTP::Request::Common;
4
53103µs125µsuse strict;
# spent 25µs making 1 call to strict::import
63178µs1377µsuse vars qw(@EXPORT @EXPORT_OK $VERSION $DYNAMIC_FILE_UPLOAD);
# spent 377µs making 1 call to vars::import
7
816µs$DYNAMIC_FILE_UPLOAD ||= 0; # make it defined (don't know why)
9
1016µsrequire Exporter;
1119µs*import = \&Exporter::import;
12110µs@EXPORT =qw(GET HEAD PUT POST);
1315µs@EXPORT_OK = qw($DYNAMIC_FILE_UPLOAD);
14
1515µsrequire HTTP::Request;
1632.79msuse Carp();
17
18154µs119µs$VERSION = sprintf("%d.%02d", q$Revision: 1.26 $ =~ /(\d+)\.(\d+)/);
# spent 19µs making 1 call to HTTP::Request::Common::CORE:match
19
2015µsmy $CRLF = "\015\012"; # "\r\n" is not portable
21
2246111.2ms461323ms
# spent 335ms (11.6+323) within HTTP::Request::Common::GET which was called 461 times, avg 726µs/call: # 461 times (11.6ms+323ms) by LWP::UserAgent::get at line 419 of LWP/UserAgent.pm, avg 726µs/call
sub GET { _simple_req('GET', @_); }
# spent 323ms making 461 calls to HTTP::Request::Common::_simple_req, avg 701µs/call
23sub HEAD { _simple_req('HEAD', @_); }
24sub PUT { _simple_req('PUT' , @_); }
25
26sub POST
27{
28 my $url = shift;
29 my $req = HTTP::Request->new(POST => $url);
30 my $content;
31 $content = shift if @_ and ref $_[0];
32 my($k, $v);
33 while (($k,$v) = splice(@_, 0, 2)) {
34 if (lc($k) eq 'content') {
35 $content = $v;
36 }
37 else {
38 $req->push_header($k, $v);
39 }
40 }
41 my $ct = $req->header('Content-Type');
42 unless ($ct) {
43 $ct = 'application/x-www-form-urlencoded';
44 }
45 elsif ($ct eq 'form-data') {
46 $ct = 'multipart/form-data';
47 }
48
49 if (ref $content) {
50 if ($ct =~ m,^multipart/form-data\s*(;|$),i) {
51 require HTTP::Headers::Util;
52 my @v = HTTP::Headers::Util::split_header_words($ct);
53 Carp::carp("Multiple Content-Type headers") if @v > 1;
54 @v = @{$v[0]};
55
56 my $boundary;
57 my $boundary_index;
58 for (my @tmp = @v; @tmp;) {
59 my($k, $v) = splice(@tmp, 0, 2);
60 if (lc($k) eq "boundary") {
61 $boundary = $v;
62 $boundary_index = @v - @tmp - 1;
63 last;
64 }
65 }
66
67 ($content, $boundary) = form_data($content, $boundary, $req);
68
69 if ($boundary_index) {
70 $v[$boundary_index] = $boundary;
71 }
72 else {
73 push(@v, boundary => $boundary);
74 }
75
76 $ct = HTTP::Headers::Util::join_header_words(@v);
77 }
78 else {
79 # We use a temporary URI object to format
80 # the application/x-www-form-urlencoded content.
81 require URI;
82 my $url = URI->new('http:');
83 $url->query_form(ref($content) eq "HASH" ? %$content : @$content);
84 $content = $url->query;
85 }
86 }
87
88 $req->header('Content-Type' => $ct); # might be redundant
89 if (defined($content)) {
90 $req->header('Content-Length' =>
91 length($content)) unless ref($content);
92 $req->content($content);
93 }
94 else {
95 $req->header('Content-Length' => 0);
96 }
97 $req;
98}
99
100
101sub _simple_req
102
# spent 323ms (28.1+295) within HTTP::Request::Common::_simple_req which was called 461 times, avg 701µs/call: # 461 times (28.1ms+295ms) by HTTP::Request::Common::GET at line 22, avg 701µs/call
{
103230528.2ms my($method, $url) = splice(@_, 0, 2);
104 my $req = HTTP::Request->new($method => $url);
# spent 295ms making 461 calls to HTTP::Request::new, avg 640µs/call
105 my($k, $v);
106 while (($k,$v) = splice(@_, 0, 2)) {
107 if (lc($k) eq 'content') {
108 $req->add_content($v);
109 }
110 else {
111 $req->push_header($k, $v);
112 }
113 }
114 $req;
115}
116
117
118sub form_data # RFC1867
119{
120 my($data, $boundary, $req) = @_;
121 my @data = ref($data) eq "HASH" ? %$data : @$data; # copy
122 my $fhparts;
123 my @parts;
124 my($k,$v);
125 while (($k,$v) = splice(@data, 0, 2)) {
126 if (!ref($v)) {
127 $k =~ s/([\\\"])/\\$1/g; # escape quotes and backslashes
128 push(@parts,
129 qq(Content-Disposition: form-data; name="$k"$CRLF$CRLF$v));
130 }
131 else {
132 my($file, $usename, @headers) = @$v;
133 unless (defined $usename) {
134 $usename = $file;
135 $usename =~ s,.*/,, if defined($usename);
136 }
137 my $disp = qq(form-data; name="$k");
138 $disp .= qq(; filename="$usename") if $usename;
139 my $content = "";
140 my $h = HTTP::Headers->new(@headers);
141 if ($file) {
142 require Symbol;
143 my $fh = Symbol::gensym();
144 open($fh, $file) or Carp::croak("Can't open file $file: $!");
145 binmode($fh);
146 if ($DYNAMIC_FILE_UPLOAD) {
147 # will read file later
148 $content = $fh;
149 }
150 else {
151 local($/) = undef; # slurp files
152 $content = <$fh>;
153 close($fh);
154 }
155 unless ($h->header("Content-Type")) {
156 require LWP::MediaTypes;
157 LWP::MediaTypes::guess_media_type($file, $h);
158 }
159 }
160 if ($h->header("Content-Disposition")) {
161 # just to get it sorted first
162 $disp = $h->header("Content-Disposition");
163 $h->remove_header("Content-Disposition");
164 }
165 if ($h->header("Content")) {
166 $content = $h->header("Content");
167 $h->remove_header("Content");
168 }
169 my $head = join($CRLF, "Content-Disposition: $disp",
170 $h->as_string($CRLF),
171 "");
172 if (ref $content) {
173 push(@parts, [$head, $content]);
174 $fhparts++;
175 }
176 else {
177 push(@parts, $head . $content);
178 }
179 }
180 }
181 return ("", "none") unless @parts;
182
183 my $content;
184 if ($fhparts) {
185 $boundary = boundary(10) # hopefully enough randomness
186 unless $boundary;
187
188 # add the boundaries to the @parts array
189 for (1..@parts-1) {
190 splice(@parts, $_*2-1, 0, "$CRLF--$boundary$CRLF");
191 }
192 unshift(@parts, "--$boundary$CRLF");
193 push(@parts, "$CRLF--$boundary--$CRLF");
194
195 # See if we can generate Content-Length header
196 my $length = 0;
197 for (@parts) {
198 if (ref $_) {
199 my ($head, $f) = @$_;
200 my $file_size;
201 unless ( -f $f && ($file_size = -s _) ) {
202 # The file is either a dynamic file like /dev/audio
203 # or perhaps a file in the /proc file system where
204 # stat may return a 0 size even though reading it
205 # will produce data. So we cannot make
206 # a Content-Length header.
207 undef $length;
208 last;
209 }
210 $length += $file_size + length $head;
211 }
212 else {
213 $length += length;
214 }
215 }
216 $length && $req->header('Content-Length' => $length);
217
218 # set up a closure that will return content piecemeal
219 $content = sub {
220 for (;;) {
221 unless (@parts) {
222 defined $length && $length != 0 &&
223 Carp::croak "length of data sent did not match calculated Content-Length header. Probably because uploaded file changed in size during transfer.";
224 return;
225 }
226 my $p = shift @parts;
227 unless (ref $p) {
228 $p .= shift @parts while @parts && !ref($parts[0]);
229 defined $length && ($length -= length $p);
230 return $p;
231 }
232 my($buf, $fh) = @$p;
233 my $buflength = length $buf;
234 my $n = read($fh, $buf, 2048, $buflength);
235 if ($n) {
236 $buflength += $n;
237 unshift(@parts, ["", $fh]);
238 }
239 else {
240 close($fh);
241 }
242 if ($buflength) {
243 defined $length && ($length -= $buflength);
244 return $buf
245 }
246 }
247 };
248
249 }
250 else {
251 $boundary = boundary() unless $boundary;
252
253 my $bno = 0;
254 CHECK_BOUNDARY:
255 {
256 for (@parts) {
257 if (index($_, $boundary) >= 0) {
258 # must have a better boundary
259 $boundary = boundary(++$bno);
260 redo CHECK_BOUNDARY;
261 }
262 }
263 last;
264 }
265 $content = "--$boundary$CRLF" .
266 join("$CRLF--$boundary$CRLF", @parts) .
267 "$CRLF--$boundary--$CRLF";
268 }
269
270 wantarray ? ($content, $boundary) : $content;
271}
272
273
274sub boundary
275{
276 my $size = shift || return "xYzZY";
277 require MIME::Base64;
278 my $b = MIME::Base64::encode(join("", map chr(rand(256)), 1..$size*3), "");
279 $b =~ s/[\W]/X/g; # ensure alnum only
280 $b;
281}
282
283125µs1;
284
285__END__
286
287=head1 NAME
288
289HTTP::Request::Common - Construct common HTTP::Request objects
290
291=head1 SYNOPSIS
292
293 use HTTP::Request::Common;
294 $ua = LWP::UserAgent->new;
295 $ua->request(GET 'http://www.sn.no/');
296 $ua->request(POST 'http://somewhere/foo', [foo => bar, bar => foo]);
297
298=head1 DESCRIPTION
299
300This module provide functions that return newly created C<HTTP::Request>
301objects. These functions are usually more convenient to use than the
302standard C<HTTP::Request> constructor for the most common requests. The
303following functions are provided:
304
305=over 4
306
307=item GET $url
308
309=item GET $url, Header => Value,...
310
311The GET() function returns an C<HTTP::Request> object initialized with
312the "GET" method and the specified URL. It is roughly equivalent to the
313following call
314
315 HTTP::Request->new(
316 GET => $url,
317 HTTP::Headers->new(Header => Value,...),
318 )
319
320but is less cluttered. What is different is that a header named
321C<Content> will initialize the content part of the request instead of
322setting a header field. Note that GET requests should normally not
323have a content, so this hack makes more sense for the PUT() and POST()
324functions described below.
325
326The get(...) method of C<LWP::UserAgent> exists as a shortcut for
327$ua->request(GET ...).
328
329=item HEAD $url
330
331=item HEAD $url, Header => Value,...
332
333Like GET() but the method in the request is "HEAD".
334
335The head(...) method of "LWP::UserAgent" exists as a shortcut for
336$ua->request(HEAD ...).
337
338=item PUT $url
339
340=item PUT $url, Header => Value,...
341
342=item PUT $url, Header => Value,..., Content => $content
343
344Like GET() but the method in the request is "PUT".
345
346=item POST $url
347
348=item POST $url, Header => Value,...
349
350=item POST $url, $form_ref, Header => Value,...
351
352=item POST $url, Header => Value,..., Content => $form_ref
353
354This works mostly like GET() with "POST" as the method, but this function
355also takes a second optional array or hash reference parameter
356($form_ref). This argument can be used to pass key/value pairs for
357the form content. By default we will initialize a request using the
358C<application/x-www-form-urlencoded> content type. This means that
359you can emulate a HTML E<lt>form> POSTing like this:
360
361 POST 'http://www.perl.org/survey.cgi',
362 [ name => 'Gisle Aas',
363 email => 'gisle@aas.no',
364 gender => 'M',
365 born => '1964',
366 perc => '3%',
367 ];
368
369This will create a HTTP::Request object that looks like this:
370
371 POST http://www.perl.org/survey.cgi
372 Content-Length: 66
373 Content-Type: application/x-www-form-urlencoded
374
375 name=Gisle%20Aas&email=gisle%40aas.no&gender=M&born=1964&perc=3%25
376
377Multivalued form fields can be specified by either repeating the field
378name or by passing the value as an array reference.
379
380The POST method also supports the C<multipart/form-data> content used
381for I<Form-based File Upload> as specified in RFC 1867. You trigger
382this content format by specifying a content type of C<'form-data'> as
383one of the request headers. If one of the values in the $form_ref is
384an array reference, then it is treated as a file part specification
385with the following interpretation:
386
387 [ $file, $filename, Header => Value... ]
388 [ undef, $filename, Header => Value,..., Content => $content ]
389
390The first value in the array ($file) is the name of a file to open.
391This file will be read and its content placed in the request. The
392routine will croak if the file can't be opened. Use an C<undef> as
393$file value if you want to specify the content directly with a
394C<Content> header. The $filename is the filename to report in the
395request. If this value is undefined, then the basename of the $file
396will be used. You can specify an empty string as $filename if you
397want to suppress sending the filename when you provide a $file value.
398
399If a $file is provided by no C<Content-Type> header, then C<Content-Type>
400and C<Content-Encoding> will be filled in automatically with the values
401returned by LWP::MediaTypes::guess_media_type()
402
403Sending my F<~/.profile> to the survey used as example above can be
404achieved by this:
405
406 POST 'http://www.perl.org/survey.cgi',
407 Content_Type => 'form-data',
408 Content => [ name => 'Gisle Aas',
409 email => 'gisle@aas.no',
410 gender => 'M',
411 born => '1964',
412 init => ["$ENV{HOME}/.profile"],
413 ]
414
415This will create a HTTP::Request object that almost looks this (the
416boundary and the content of your F<~/.profile> is likely to be
417different):
418
419 POST http://www.perl.org/survey.cgi
420 Content-Length: 388
421 Content-Type: multipart/form-data; boundary="6G+f"
422
423 --6G+f
424 Content-Disposition: form-data; name="name"
425
426 Gisle Aas
427 --6G+f
428 Content-Disposition: form-data; name="email"
429
430 gisle@aas.no
431 --6G+f
432 Content-Disposition: form-data; name="gender"
433
434 M
435 --6G+f
436 Content-Disposition: form-data; name="born"
437
438 1964
439 --6G+f
440 Content-Disposition: form-data; name="init"; filename=".profile"
441 Content-Type: text/plain
442
443 PATH=/local/perl/bin:$PATH
444 export PATH
445
446 --6G+f--
447
448If you set the $DYNAMIC_FILE_UPLOAD variable (exportable) to some TRUE
449value, then you get back a request object with a subroutine closure as
450the content attribute. This subroutine will read the content of any
451files on demand and return it in suitable chunks. This allow you to
452upload arbitrary big files without using lots of memory. You can even
453upload infinite files like F</dev/audio> if you wish; however, if
454the file is not a plain file, there will be no Content-Length header
455defined for the request. Not all servers (or server
456applications) like this. Also, if the file(s) change in size between
457the time the Content-Length is calculated and the time that the last
458chunk is delivered, the subroutine will C<Croak>.
459
460The post(...) method of "LWP::UserAgent" exists as a shortcut for
461$ua->request(POST ...).
462
463=back
464
465=head1 SEE ALSO
466
467L<HTTP::Request>, L<LWP::UserAgent>
468
469
470=head1 COPYRIGHT
471
472Copyright 1997-2004, Gisle Aas
473
474This library is free software; you can redistribute it and/or
475modify it under the same terms as Perl itself.
476
477=cut
478
# spent 19µs within HTTP::Request::Common::CORE:match which was called # once (19µs+0s) by LWP::UserAgent::get at line 18 of HTTP/Request/Common.pm
sub HTTP::Request::Common::CORE:match; # xsub
Report produced by the NYTProf 3.11 Perl profiler, developed by Tim Bunce and Adam Kaplan.