"Fossies" - the Fresh Open Source Software Archive

Member "install-tl-20200916/tlpkg/tlperl/site/lib/HTTP/Request.pm" (7 Mar 2020, 8949 Bytes) of package /windows/misc/install-tl.zip:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file.

    1 package HTTP::Request;
    2 
    3 use strict;
    4 use warnings;
    5 
    6 our $VERSION = '6.22';
    7 
    8 use base 'HTTP::Message';
    9 
   10 sub new
   11 {
   12     my($class, $method, $uri, $header, $content) = @_;
   13     my $self = $class->SUPER::new($header, $content);
   14     $self->method($method);
   15     $self->uri($uri);
   16     $self;
   17 }
   18 
   19 
   20 sub parse
   21 {
   22     my($class, $str) = @_;
   23     Carp::carp('Undefined argument to parse()') if $^W && ! defined $str;
   24     my $request_line;
   25     if (defined $str && $str =~ s/^(.*)\n//) {
   26     $request_line = $1;
   27     }
   28     else {
   29     $request_line = $str;
   30     $str = "";
   31     }
   32 
   33     my $self = $class->SUPER::parse($str);
   34     if (defined $request_line) {
   35         my($method, $uri, $protocol) = split(' ', $request_line);
   36         $self->method($method);
   37         $self->uri($uri) if defined($uri);
   38         $self->protocol($protocol) if $protocol;
   39     }
   40     $self;
   41 }
   42 
   43 
   44 sub clone
   45 {
   46     my $self = shift;
   47     my $clone = bless $self->SUPER::clone, ref($self);
   48     $clone->method($self->method);
   49     $clone->uri($self->uri);
   50     $clone;
   51 }
   52 
   53 
   54 sub method
   55 {
   56     shift->_elem('_method', @_);
   57 }
   58 
   59 
   60 sub uri
   61 {
   62     my $self = shift;
   63     my $old = $self->{'_uri'};
   64     if (@_) {
   65     my $uri = shift;
   66     if (!defined $uri) {
   67         # that's ok
   68     }
   69     elsif (ref $uri) {
   70         Carp::croak("A URI can't be a " . ref($uri) . " reference")
   71         if ref($uri) eq 'HASH' or ref($uri) eq 'ARRAY';
   72         Carp::croak("Can't use a " . ref($uri) . " object as a URI")
   73         unless $uri->can('scheme') && $uri->can('canonical');
   74         $uri = $uri->clone;
   75         unless ($HTTP::URI_CLASS eq "URI") {
   76         # Argh!! Hate this... old LWP legacy!
   77         eval { local $SIG{__DIE__}; $uri = $uri->abs; };
   78         die $@ if $@ && $@ !~ /Missing base argument/;
   79         }
   80     }
   81     else {
   82         $uri = $HTTP::URI_CLASS->new($uri);
   83     }
   84     $self->{'_uri'} = $uri;
   85         delete $self->{'_uri_canonical'};
   86     }
   87     $old;
   88 }
   89 
   90 *url = \&uri;  # legacy
   91 
   92 sub uri_canonical
   93 {
   94     my $self = shift;
   95 
   96     my $uri = $self->{_uri};
   97 
   98     if (defined (my $canon = $self->{_uri_canonical})) {
   99         # early bailout if these are the exact same string; try to use
  100         # the cheapest comparison method possible
  101         return $canon if $$canon eq $$uri;
  102     }
  103 
  104     # otherwise we need to refresh the memoized value
  105     $self->{_uri_canonical} = $uri->canonical;
  106 }
  107 
  108 
  109 sub accept_decodable
  110 {
  111     my $self = shift;
  112     $self->header("Accept-Encoding", scalar($self->decodable));
  113 }
  114 
  115 sub as_string
  116 {
  117     my $self = shift;
  118     my($eol) = @_;
  119     $eol = "\n" unless defined $eol;
  120 
  121     my $req_line = $self->method || "-";
  122     my $uri = $self->uri;
  123     $uri = (defined $uri) ? $uri->as_string : "-";
  124     $req_line .= " $uri";
  125     my $proto = $self->protocol;
  126     $req_line .= " $proto" if $proto;
  127 
  128     return join($eol, $req_line, $self->SUPER::as_string(@_));
  129 }
  130 
  131 sub dump
  132 {
  133     my $self = shift;
  134     my @pre = ($self->method || "-", $self->uri || "-");
  135     if (my $prot = $self->protocol) {
  136     push(@pre, $prot);
  137     }
  138 
  139     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.22
  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<HTTP::Request> 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<LWP::UserAgent> object.
  177 
  178 C<HTTP::Request> is a subclass of C<HTTP::Message> 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<HTTP::Request> 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<URI> object.  The optional $header argument should be a reference to
  193 an C<HTTP::Headers> 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<HTTP::Headers> via C<HTTP::Message>.  See L<HTTP::Headers> 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<Accept-Encoding> 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<HTTP::Message> base class.  See L<HTTP::Message> 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<Encode>
  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<LWP::UserAgent> 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<https://developers.google.com/drive/v3/web/batch> for example. Using the
  281 C<add_part> method from L<HTTP::Message> 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<HTTP::Headers>, L<HTTP::Message>, L<HTTP::Request::Common>,
  334 L<HTTP::Response>
  335 
  336 =head1 AUTHOR
  337 
  338 Gisle Aas <gisle@activestate.com>
  339 
  340 =head1 COPYRIGHT AND LICENSE
  341 
  342 This software is copyright (c) 1994-2017 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__
  350 
  351 
  352 #ABSTRACT: HTTP style request message