"Fossies" - the Fresh Open Source Software Archive

Member "libwww-perl-6.43/bin/lwp-request" (26 Nov 2019, 16200 Bytes) of package /linux/www/libwww-perl-6.43.tar.gz:


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 #!/usr/bin/perl
    2 
    3 # Simple user agent using LWP library.
    4 
    5 =head1 NAME
    6 
    7 lwp-request - Simple command line user agent
    8 
    9 =head1 SYNOPSIS
   10 
   11 B<lwp-request> [B<-afPuUsSedvhx>] [B<-m> I<method>] [B<-b> I<base URL>] [B<-t> I<timeout>]
   12             [B<-i> I<if-modified-since>] [B<-c> I<content-type>]
   13             [B<-C> I<credentials>] [B<-p> I<proxy-url>] [B<-o> I<format>] I<url>...
   14 
   15 =head1 DESCRIPTION
   16 
   17 This program can be used to send requests to WWW servers and your
   18 local file system. The request content for POST and PUT
   19 methods is read from stdin.  The content of the response is printed on
   20 stdout.  Error messages are printed on stderr.  The program returns a
   21 status value indicating the number of URLs that failed.
   22 
   23 The options are:
   24 
   25 =over 4
   26 
   27 =item -m <method>
   28 
   29 Set which method to use for the request.  If this option is not used,
   30 then the method is derived from the name of the program.
   31 
   32 =item -f
   33 
   34 Force request through, even if the program believes that the method is
   35 illegal.  The server might reject the request eventually.
   36 
   37 =item -b <uri>
   38 
   39 This URI will be used as the base URI for resolving all relative URIs
   40 given as argument.
   41 
   42 =item -t <timeout>
   43 
   44 Set the timeout value for the requests.  The timeout is the amount of
   45 time that the program will wait for a response from the remote server
   46 before it fails.  The default unit for the timeout value is seconds.
   47 You might append "m" or "h" to the timeout value to make it minutes or
   48 hours, respectively.  The default timeout is '3m', i.e. 3 minutes.
   49 
   50 =item -i <time>
   51 
   52 Set the If-Modified-Since header in the request. If I<time> is the
   53 name of a file, use the modification timestamp for this file. If
   54 I<time> is not a file, it is parsed as a literal date. Take a look at
   55 L<HTTP::Date> for recognized formats.
   56 
   57 =item -c <content-type>
   58 
   59 Set the Content-Type for the request.  This option is only allowed for
   60 requests that take a content, i.e. POST and PUT.  You can
   61 force methods to take content by using the C<-f> option together with
   62 C<-c>.  The default Content-Type for POST is
   63 C<application/x-www-form-urlencoded>.  The default Content-type for
   64 the others is C<text/plain>.
   65 
   66 =item -p <proxy-url>
   67 
   68 Set the proxy to be used for the requests.  The program also loads
   69 proxy settings from the environment.  You can disable this with the
   70 C<-P> option.
   71 
   72 =item -P
   73 
   74 Don't load proxy settings from environment.
   75 
   76 =item -H <header>
   77 
   78 Send this HTTP header with each request. You can specify several, e.g.:
   79 
   80     lwp-request \
   81     -H 'Referer: http://other.url/' \
   82     -H 'Host: somehost' \
   83     http://this.url/
   84 
   85 =item -C <username>:<password>
   86 
   87 Provide credentials for documents that are protected by Basic
   88 Authentication.  If the document is protected and you did not specify
   89 the username and password with this option, then you will be prompted
   90 to provide these values.
   91 
   92 =back
   93 
   94 The following options controls what is displayed by the program:
   95 
   96 =over 4
   97 
   98 =item -u
   99 
  100 Print request method and absolute URL as requests are made.
  101 
  102 =item -U
  103 
  104 Print request headers in addition to request method and absolute URL.
  105 
  106 =item -s
  107 
  108 Print response status code.  This option is always on for HEAD requests.
  109 
  110 =item -S
  111 
  112 Print response status chain. This shows redirect and authorization
  113 requests that are handled by the library.
  114 
  115 =item -e
  116 
  117 Print response headers.  This option is always on for HEAD requests.
  118 
  119 =item -E
  120 
  121 Print response status chain with full response headers.
  122 
  123 =item -d
  124 
  125 Do B<not> print the content of the response.
  126 
  127 =item -o <format>
  128 
  129 Process HTML content in various ways before printing it.  If the
  130 content type of the response is not HTML, then this option has no
  131 effect.  The legal format values are; C<text>, C<ps>, C<links>,
  132 C<html> and C<dump>.
  133 
  134 If you specify the C<text> format then the HTML will be formatted as
  135 plain C<latin1> text.  If you specify the C<ps> format then it will be
  136 formatted as Postscript.
  137 
  138 The C<links> format will output all links found in the HTML document.
  139 Relative links will be expanded to absolute ones.
  140 
  141 The C<html> format will reformat the HTML code and the C<dump> format
  142 will just dump the HTML syntax tree.
  143 
  144 Note that the C<HTML-Tree> distribution needs to be installed for this
  145 option to work.  In addition the C<HTML-Format> distribution needs to
  146 be installed for C<-o text> or C<-o ps> to work.
  147 
  148 =item -v
  149 
  150 Print the version number of the program and quit.
  151 
  152 =item -h
  153 
  154 Print usage message and quit.
  155 
  156 =item -a
  157 
  158 Set text(ascii) mode for content input and output.  If this option is not
  159 used, content input and output is done in binary mode.
  160 
  161 =back
  162 
  163 Because this program is implemented using the LWP library, it will
  164 only support the protocols that LWP supports.
  165 
  166 =head1 SEE ALSO
  167 
  168 L<lwp-mirror>, L<LWP>
  169 
  170 =head1 COPYRIGHT
  171 
  172 Copyright 1995-1999 Gisle Aas.
  173 
  174 This library is free software; you can redistribute it and/or
  175 modify it under the same terms as Perl itself.
  176 
  177 =head1 AUTHOR
  178 
  179 Gisle Aas <gisle@aas.no>
  180 
  181 =cut
  182 
  183 use strict;
  184 use warnings;
  185 
  186 my $progname = $0;
  187 $progname =~ s,.*[\\/],,;    # use basename only
  188 $progname =~ s/\.\w*$//;     # strip extension, if any
  189 
  190 require LWP;
  191 
  192 use URI;
  193 use URI::Heuristic qw(uf_uri);
  194 use Encode;
  195 use Encode::Locale;
  196 
  197 use HTTP::Status qw(status_message);
  198 use HTTP::Date qw(time2str str2time);
  199 
  200 
  201 # This table lists the methods that are allowed.  It should really be
  202 # a superset for all methods supported for every scheme that may be
  203 # supported by the library.  Currently it might be a bit too HTTP
  204 # specific.  You might use the -f option to force a method through.
  205 #
  206 # "" = No content in request, "C" = Needs content in request
  207 #
  208 my %allowed_methods = (
  209     GET     => "",
  210     HEAD    => "",
  211     POST    => "C",
  212     PUT     => "C",
  213     DELETE  => "",
  214     TRACE   => "",
  215     OPTIONS => "",
  216 );
  217 
  218 my %options;
  219 
  220 # We make our own specialization of LWP::UserAgent that asks for
  221 # user/password if document is protected.
  222 {
  223 
  224     package     # hide from PAUSE, $VERSION updaters
  225         RequestAgent;
  226 
  227     use strict;
  228     use warnings;
  229     use base qw(LWP::UserAgent);
  230 
  231     sub new {
  232         my $self = LWP::UserAgent::new(@_);
  233         $self->agent("lwp-request/$LWP::VERSION ");
  234         $self;
  235     }
  236 
  237     sub get_basic_credentials {
  238         my ($self, $realm, $uri) = @_;
  239         if ($options{'C'}) {
  240             return split(':', $options{'C'}, 2);
  241         }
  242         elsif (-t) {
  243             my $netloc = $uri->host_port;
  244             print STDERR "Enter username for $realm at $netloc: ";
  245             my $user = <STDIN>;
  246             chomp($user);
  247             return (undef, undef) unless length $user;
  248             print STDERR "Password: ";
  249             system("stty -echo");
  250             my $password = <STDIN>;
  251             system("stty echo");
  252             print STDERR "\n";    # because we disabled echo
  253             chomp($password);
  254             return ($user, $password);
  255         }
  256         else {
  257             return (undef, undef);
  258         }
  259     }
  260 }
  261 
  262 my $method = uc(lc($progname) eq "lwp-request" ? "GET" : $progname);
  263 
  264 # Parse command line
  265 use Getopt::Long;
  266 my @getopt_args = (
  267     'a',       # content i/o in text(ascii) mode
  268     'm=s',     # set method
  269     'f',       # make request even if method is not in %allowed_methods
  270     'b=s',     # base url
  271     't=s',     # timeout
  272     'i=s',     # if-modified-since
  273     'c=s',     # content type for POST
  274     'C=s',     # credentials for basic authorization
  275     'H=s@',    # extra headers, form "Header: value string"
  276                #
  277     'u',       # display method and URL of request
  278     'U',       # display request headers also
  279     's',       # display status code
  280     'S',       # display whole chain of status codes
  281     'e',       # display response headers (default for HEAD)
  282     'E',       # display whole chain of headers
  283     'd',       # don't display content
  284                #
  285     'h',       # print usage
  286     'v',       # print version
  287                #
  288     'p=s',     # proxy URL
  289     'P',       # don't load proxy setting from environment
  290                #
  291     'o=s',     # output format
  292 );
  293 
  294 Getopt::Long::config("noignorecase", "bundling");
  295 unless (GetOptions(\%options, @getopt_args)) {
  296     usage();
  297 }
  298 if ($options{'v'}) {
  299     require LWP;
  300     my $DISTNAME = 'libwww-perl-' . $LWP::VERSION;
  301     die <<"EOT";
  302 This is lwp-request version $LWP::VERSION ($DISTNAME)
  303 
  304 Copyright 1995-1999, Gisle Aas.
  305 
  306 This program is free software; you can redistribute it and/or
  307 modify it under the same terms as Perl itself.
  308 EOT
  309 }
  310 
  311 usage() if $options{'h'} || !@ARGV;
  312 
  313 # Create the user agent object
  314 my $ua = RequestAgent->new;
  315 
  316 # Load proxy settings from *_proxy environment variables.
  317 $ua->env_proxy unless $options{'P'};
  318 
  319 $method = uc($options{'m'}) if defined $options{'m'};
  320 
  321 if ($options{'f'}) {
  322     if ($options{'c'}) {
  323         $allowed_methods{$method} = "C";    # force content
  324     }
  325     else {
  326         $allowed_methods{$method} = "";
  327     }
  328 }
  329 elsif (!defined $allowed_methods{$method}) {
  330     die "$progname: $method is not an allowed method\n";
  331 }
  332 
  333 if ($options{'S'} || $options{'E'}) {
  334     $options{'U'} = 1 if $options{'E'};
  335     $options{'E'} = 1 if $options{'e'};
  336     $options{'S'} = 1;
  337     $options{'s'} = 1;
  338     $options{'u'} = 1;
  339 }
  340 
  341 if ($method eq "HEAD") {
  342     $options{'s'} = 1;
  343     $options{'e'} = 1 unless $options{'d'};
  344     $options{'d'} = 1;
  345 }
  346 
  347 $options{'u'} = 1 if $options{'U'};
  348 $options{'s'} = 1 if $options{'e'};
  349 
  350 if (defined $options{'t'}) {
  351     $options{'t'} =~ /^(\d+)([smh])?/;
  352     die "$progname: Illegal timeout value!\n" unless defined $1;
  353     my $timeout = $1;
  354     if (defined $2) {
  355         $timeout *= 60   if $2 eq "m";
  356         $timeout *= 3600 if $2 eq "h";
  357     }
  358     $ua->timeout($timeout);
  359 }
  360 
  361 if (defined $options{'i'}) {
  362     my $time;
  363     if (-e $options{'i'}) {
  364         $time = (stat _)[9];
  365     }
  366     else {
  367         $time = str2time($options{'i'});
  368         die "$progname: Illegal time syntax for -i option\n"
  369             unless defined $time;
  370     }
  371     $options{'i'} = time2str($time);
  372 }
  373 
  374 my $content;
  375 my $user_ct;
  376 if ($allowed_methods{$method} eq "C") {
  377 
  378     # This request needs some content
  379     unless (defined $options{'c'}) {
  380 
  381         # set default content type
  382         $options{'c'}
  383             = ($method eq "POST")
  384             ? "application/x-www-form-urlencoded"
  385             : "text/plain";
  386     }
  387     else {
  388         die "$progname: Illegal Content-type format\n"
  389             unless $options{'c'} =~ m,^[\w\-]+/[\w\-.+]+(?:\s*;.*)?$,;
  390         $user_ct++;
  391     }
  392     print STDERR "Please enter content ($options{'c'}) to be ${method}ed:\n"
  393         if -t;
  394     binmode STDIN unless -t or $options{'a'};
  395     $content = join("", <STDIN>);
  396 }
  397 else {
  398     die "$progname: Can't set Content-type for $method requests\n"
  399         if defined $options{'c'};
  400 }
  401 
  402 # Set up a request.  We will use the same request object for all URLs.
  403 my $request = HTTP::Request->new($method);
  404 $request->header('If-Modified-Since', $options{'i'}) if defined $options{'i'};
  405 for my $user_header (@{$options{'H'} || []}) {
  406     my ($header_name, $header_value) = split /\s*:\s*/, $user_header, 2;
  407     $header_name =~ s/^\s+//;
  408     if (lc($header_name) eq "user-agent") {
  409         $header_value .= $ua->agent if $header_value =~ /\s\z/;
  410         $ua->agent($header_value);
  411     }
  412     else {
  413         $request->push_header($header_name, $header_value);
  414     }
  415 }
  416 
  417 #$request->header('Accept', '*/*');
  418 if ($options{'c'}) {    # will always be set for request that wants content
  419     my $header = ($user_ct ? 'header' : 'init_header');
  420     $request->$header('Content-Type', $options{'c'});
  421     $request->header('Content-Length', length $content);    # Not really needed
  422     $request->content($content);
  423 }
  424 
  425 my $errors = 0;
  426 
  427 sub show {
  428     my $r    = shift;
  429     my $last = shift;
  430     print $method, " ", $r->request->uri->as_string, "\n" if $options{'u'};
  431     print $r->request->headers_as_string, "\n" if $options{'U'};
  432     print $r->status_line, "\n" if $options{'s'};
  433     print $r->headers_as_string, "\n" if $options{'E'} or $last;
  434 }
  435 
  436 # Ok, now we perform the requests, one URL at a time
  437 while (my $url = shift) {
  438 
  439     # Create the URL object, but protect us against bad URLs
  440     eval {
  441         if ($url =~ /^\w+:/ || $options{'b'})
  442         {    # is there any scheme specification
  443             $url = URI->new(decode(locale => $url),
  444                 decode(locale => $options{'b'}));
  445             $url = $url->abs(decode(locale => $options{'b'})) if $options{'b'};
  446         }
  447         else {
  448             $url = uf_uri($url);
  449         }
  450     };
  451     if ($@) {
  452         $@ =~ s/ at .* line \d+.*//;
  453         print STDERR $@;
  454         $errors++;
  455         next;
  456     }
  457 
  458     $ua->proxy($url->scheme, decode(locale => $options{'p'})) if $options{'p'};
  459 
  460     # Send the request and get a response back from the server
  461     $request->uri($url);
  462     my $response = $ua->request($request);
  463 
  464     if ($options{'S'}) {
  465         for my $r ($response->redirects) {
  466             show($r);
  467         }
  468     }
  469     show($response, $options{'e'});
  470 
  471     unless ($options{'d'}) {
  472         if ($options{'o'} && $response->content_type eq 'text/html') {
  473             eval { require HTML::Parse; };
  474             if ($@) {
  475                 if ($@ =~ m,^Can't locate HTML/Parse.pm in \@INC,) {
  476                     die
  477                         "The HTML-Tree distribution need to be installed for the -o option to be used.\n";
  478                 }
  479                 else {
  480                     die $@;
  481                 }
  482             }
  483             my $html = HTML::Parse::parse_html($response->content);
  484             {
  485                 $options{'o'} eq 'ps' && do {
  486                     require HTML::FormatPS;
  487                     my $f = HTML::FormatPS->new;
  488                     print $f->format($html);
  489                     last;
  490                 };
  491                 $options{'o'} eq 'text' && do {
  492                     require HTML::FormatText;
  493                     my $f = HTML::FormatText->new;
  494                     print $f->format($html);
  495                     last;
  496                 };
  497                 $options{'o'} eq 'html' && do {
  498                     print $html->as_HTML;
  499                     last;
  500                 };
  501                 $options{'o'} eq 'links' && do {
  502                     my $base = $response->base;
  503                     $base = $options{'b'} if $options{'b'};
  504                     for (@{$html->extract_links}) {
  505                         my ($link, $elem) = @$_;
  506                         my $tag = uc $elem->tag;
  507                         $link = URI->new($link)->abs($base)->as_string;
  508                         print "$tag\t$link\n";
  509                     }
  510                     last;
  511                 };
  512                 $options{'o'} eq 'dump' && do {
  513                     $html->dump;
  514                     last;
  515                 };
  516 
  517                 # It is bad to not notice this before now :-(
  518                 die "Illegal -o option value ($options{'o'})\n";
  519             }
  520         }
  521         else {
  522             binmode STDOUT unless $options{'a'};
  523             print $response->content;
  524         }
  525     }
  526 
  527     $errors++ unless $response->is_success;
  528 }
  529 
  530 exit $errors;
  531 
  532 
  533 sub usage {
  534     die <<"EOT";
  535 Usage: $progname [-options] <url>...
  536     -m <method>   use method for the request (default is '$method')
  537     -f            make request even if $progname believes method is illegal
  538     -b <base>     Use the specified URL as base
  539     -t <timeout>  Set timeout value
  540     -i <time>     Set the If-Modified-Since header on the request
  541     -c <conttype> use this content-type for POST, PUT, CHECKIN
  542     -a            Use text mode for content I/O
  543     -p <proxyurl> use this as a proxy
  544     -P            don't load proxy settings from environment
  545     -H <header>   send this HTTP header (you can specify several)
  546     -C <username>:<password>
  547                   provide credentials for basic authentication
  548 
  549     -u            Display method and URL before any response
  550     -U            Display request headers (implies -u)
  551     -s            Display response status code
  552     -S            Display response status chain (implies -u)
  553     -e            Display response headers (implies -s)
  554     -E            Display whole chain of headers (implies -S and -U)
  555     -d            Do not display content
  556     -o <format>   Process HTML content in various ways
  557 
  558     -v            Show program version
  559     -h            Print this message
  560 EOT
  561 }