git.maemo.org Git - pkg-perl/blob - deb-src/libwww-perl/libwww-perl-5.813/bin/lwp-request

   1 #!/usr/bin/perl -w
   2
   3 # Simple user agent using LWP library.
   4
   5 =head1 NAME
   6
   7 lwp-request, GET, POST, HEAD - 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 -d
 120
 121 Do B<not> print the content of the response.
 122
 123 =item -o <format>
 124
 125 Process HTML content in various ways before printing it.  If the
 126 content type of the response is not HTML, then this option has no
 127 effect.  The legal format values are; I<text>, I<ps>, I<links>,
 128 I<html> and I<dump>.
 129
 130 If you specify the I<text> format then the HTML will be formatted as
 131 plain latin1 text.  If you specify the I<ps> format then it will be
 132 formatted as Postscript.
 133
 134 The I<links> format will output all links found in the HTML document.
 135 Relative links will be expanded to absolute ones.
 136
 137 The I<html> format will reformat the HTML code and the I<dump> format
 138 will just dump the HTML syntax tree.
 139
 140 Note that the C<HTML-Tree> distribution needs to be installed for this
 141 option to work.  In addition the C<HTML-Format> distribution needs to
 142 be installed for I<-o text> or I<-o ps> to work.
 143
 144 =item -v
 145
 146 Print the version number of the program and quit.
 147
 148 =item -h
 149
 150 Print usage message and quit.
 151
 152 =item -x
 153
 154 Extra debugging output.
 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 $progname = $0;
 184 $progname =~ s,.*[\\/],,;  # use basename only
 185 $progname =~ s/\.\w*$//;   # strip extension, if any
 186
 187 $VERSION = "5.810";
 188
 189
 190 require LWP;
 191 require LWP::Debug;
 192
 193 use URI;
 194 use URI::Heuristic qw(uf_uri);
 195
 196 use HTTP::Status qw(status_message);
 197 use HTTP::Date qw(time2str str2time);
 198
 199
 200 # This table lists the methods that are allowed.  It should really be
 201 # a superset for all methods supported for every scheme that may be
 202 # supported by the library.  Currently it might be a bit too HTTP
 203 # specific.  You might use the -f option to force a method through.
 204 #
 205 # "" = No content in request, "C" = Needs content in request
 206 #
 207 %allowed_methods = (
 208     GET        => "",
 209     HEAD       => "",
 210     POST       => "C",
 211     PUT        => "C",
 212     DELETE     => "",
 213     TRACE      => "",
 214     OPTIONS    => "",
 215 );
 216
 217
 218 # We make our own specialization of LWP::UserAgent that asks for
 219 # user/password if document is protected.
 220 {
 221     package RequestAgent;
 222     @ISA = qw(LWP::UserAgent);
 223
 224     sub new
 225     {
 226         my $self = LWP::UserAgent::new(@_);
 227         $self->agent("lwp-request/$main::VERSION");
 228         $self;
 229     }
 230
 231     sub get_basic_credentials
 232     {
 233         my($self, $realm, $uri) = @_;
 234         if ($main::options{'C'}) {
 235             return split(':', $main::options{'C'}, 2);
 236         }
 237         elsif (-t) {
 238             my $netloc = $uri->host_port;
 239             print "Enter username for $realm at $netloc: ";
 240             my $user = <STDIN>;
 241             chomp($user);
 242             return (undef, undef) unless length $user;
 243             print "Password: ";
 244             system("stty -echo");
 245             my $password = <STDIN>;
 246             system("stty echo");
 247             print "\n";  # because we disabled echo
 248             chomp($password);
 249             return ($user, $password);
 250         }
 251         else {
 252             return (undef, undef)
 253         }
 254     }
 255 }
 256
 257 $method = uc(lc($progname) eq "lwp-request" ? "GET" : $progname);
 258
 259 # Parse command line
 260 use Getopt::Long;
 261
 262 my @getopt_args = (
 263     'a', # content i/o in text(ascii) mode
 264     'm=s', # set method
 265     'f', # make request even if method is not in %allowed_methods
 266     'b=s', # base url
 267     't=s', # timeout
 268     'i=s', # if-modified-since
 269     'c=s', # content type for POST
 270     'C=s', # credentials for basic authorization
 271     'H=s@', # extra headers, form "Header: value string"
 272     #
 273     'u', # display method, URL and headers of request
 274     'U', # display request headers also
 275     's', # display status code
 276     'S', # display whole chain of status codes
 277     'e', # display response headers (default for HEAD)
 278     'd', # don't display content
 279     #
 280     'h', # print usage
 281     'v', # print version
 282     #
 283     'x', # extra debugging info
 284     'p=s', # proxy URL
 285     'P', # don't load proxy setting from environment
 286     #
 287     'o=s', # output format
 288 );
 289
 290 Getopt::Long::config("noignorecase", "bundling");
 291 unless (GetOptions(\%options, @getopt_args)) {
 292     usage();
 293 }
 294 if ($options{'v'}) {
 295     require LWP;
 296     my $DISTNAME = 'libwww-perl-' . LWP::Version();
 297     die <<"EOT";
 298 This is lwp-request version $VERSION ($DISTNAME)
 299
 300 Copyright 1995-1999, Gisle Aas.
 301
 302 This program is free software; you can redistribute it and/or
 303 modify it under the same terms as Perl itself.
 304 EOT
 305 }
 306
 307 usage() if $options{'h'} || !@ARGV;
 308
 309 LWP::Debug::level('+') if $options{'x'};
 310
 311 # Create the user agent object
 312 $ua = RequestAgent->new;
 313
 314 # Load proxy settings from *_proxy environment variables.
 315 $ua->env_proxy unless $options{'P'};
 316
 317 $method = uc($options{'m'}) if defined $options{'m'};
 318
 319 if ($options{'f'}) {
 320     if ($options{'c'}) {
 321         $allowed_methods{$method} = "C";  # force content
 322     }
 323     else {
 324         $allowed_methods{$method} = "";
 325     }
 326 }
 327 elsif (!defined $allowed_methods{$method}) {
 328     die "$progname: $method is not an allowed method\n";
 329 }
 330
 331 if ($method eq "HEAD") {
 332     $options{'s'} = 1;
 333     $options{'e'} = 1 unless $options{'d'};
 334     $options{'d'} = 1;
 335 }
 336
 337 if (defined $options{'t'}) {
 338     $options{'t'} =~ /^(\d+)([smh])?/;
 339     die "$progname: Illegal timeout value!\n" unless defined $1;
 340     $timeout = $1;
 341     if (defined $2) {
 342         $timeout *= 60   if $2 eq "m";
 343         $timeout *= 3600 if $2 eq "h";
 344     }
 345     $ua->timeout($timeout);
 346 }
 347
 348 if (defined $options{'i'}) {
 349     if (-e $options{'i'}) {
 350         $time = (stat _)[9];
 351     }
 352     else {
 353         $time = str2time($options{'i'});
 354         die "$progname: Illegal time syntax for -i option\n"
 355             unless defined $time;
 356     }
 357     $options{'i'} = time2str($time);
 358 }
 359
 360 $content = undef;
 361 if ($allowed_methods{$method} eq "C") {
 362     # This request needs some content
 363     unless (defined $options{'c'}) {
 364         # set default content type
 365         $options{'c'} = ($method eq "POST") ?
 366               "application/x-www-form-urlencoded"
 367             : "text/plain";
 368     }
 369     else {
 370         die "$progname: Illegal Content-type format\n"
 371             unless $options{'c'} =~ m,^[\w\-]+/[\w\-.+]+(?:\s*;.*)?$,
 372     }
 373     print "Please enter content ($options{'c'}) to be ${method}ed:\n"
 374         if -t;
 375     binmode STDIN unless -t or $options{'a'};
 376     $content = join("", <STDIN>);
 377 }
 378 else {
 379     die "$progname: Can't set Content-type for $method requests\n"
 380         if defined $options{'c'};
 381 }
 382
 383 # Set up a request.  We will use the same request object for all URLs.
 384 $request = HTTP::Request->new($method);
 385 $request->header('If-Modified-Since', $options{'i'}) if defined $options{'i'};
 386 for my $user_header (@{ $options{'H'} || [] }) {
 387     my ($header_name, $header_value) = split /:\s*/, $user_header, 2;
 388     $request->header($header_name, $header_value);
 389     $ua->agent($header_value) if lc($header_name) eq "user-agent"; # Ugh!
 390 }
 391 #$request->header('Accept', '*/*');
 392 if ($options{'c'}) { # will always be set for request that wants content
 393     $request->header('Content-Type', $options{'c'});
 394     $request->header('Content-Length', length $content);  # Not really needed
 395     $request->content($content);
 396 }
 397
 398 $errors = 0;
 399
 400 # Ok, now we perform the requests, one URL at a time
 401 while ($url = shift) {
 402     # Create the URL object, but protect us against bad URLs
 403     eval {
 404         if ($url =~ /^\w+:/ || $options{'b'}) {  # is there any scheme specification
 405             $url = URI->new($url, $options{'b'});
 406             $url = $url->abs($options{'b'}) if $options{'b'};
 407         }
 408         else {
 409             $url = uf_uri($url);
 410         }
 411     };
 412     if ($@) {
 413         $@ =~ s/ at .* line \d+.*//;
 414         print STDERR $@;
 415         $errors++;
 416         next;
 417     }
 418
 419     $ua->proxy($url->scheme, $options{'p'}) if $options{'p'};
 420
 421     # Send the request and get a response back from the server
 422     $request->url($url);
 423     $response = $ua->request($request);
 424
 425     if ($options{'u'} || $options{'U'}) {
 426         my $url = $response->request->url->as_string;
 427         print "$method $url\n";
 428         print $response->request->headers_as_string, "\n" if $options{'U'};
 429     }
 430
 431     if ($options{'S'}) {
 432         printResponseChain($response);
 433     }
 434     elsif ($options{'s'}) {
 435         print $response->status_line, "\n";
 436     }
 437
 438     if ($options{'e'}) {
 439         # Display headers
 440         print $response->headers_as_string;
 441         print "\n";  # separate headers and content
 442     }
 443
 444     unless ($options{'d'}) {
 445         if ($options{'o'} &&
 446             $response->content_type eq 'text/html') {
 447             eval {
 448                 require HTML::Parse;
 449             };
 450             if ($@) {
 451                 if ($@ =~ m,^Can't locate HTML/Parse.pm in \@INC,) {
 452                     die "The HTML-Tree distribution need to be installed for the -o option to be used.\n";
 453                 }
 454                 else {
 455                     die $@;
 456                 }
 457             }
 458             my $html = HTML::Parse::parse_html($response->content);
 459             {
 460                 $options{'o'} eq 'ps' && do {
 461                     require HTML::FormatPS;
 462                     my $f = HTML::FormatPS->new;
 463                     print $f->format($html);
 464                     last;
 465                 };
 466                 $options{'o'} eq 'text' && do {
 467                     require HTML::FormatText;
 468                     my $f = HTML::FormatText->new;
 469                     print $f->format($html);
 470                     last;
 471                 };
 472                 $options{'o'} eq 'html' && do {
 473                     print $html->as_HTML;
 474                     last;
 475                 };
 476                 $options{'o'} eq 'links' && do {
 477                     my $base = $response->base;
 478                     $base = $options{'b'} if $options{'b'};
 479                     for ( @{ $html->extract_links } ) {
 480                         my($link, $elem) = @$_;
 481                         my $tag = uc $elem->tag;
 482                         $link = URI->new($link)->abs($base)->as_string;
 483                         print "$tag\t$link\n";
 484                     }
 485                     last;
 486                 };
 487                 $options{'o'} eq 'dump' && do {
 488                     $html->dump;
 489                     last;
 490                 };
 491                 # It is bad to not notice this before now :-(
 492                 die "Illegal -o option value ($options{'o'})\n";
 493             }
 494         }
 495         else {
 496             binmode STDOUT unless $options{'a'};
 497             print $response->content;
 498         }
 499     }
 500
 501     $errors++ unless $response->is_success;
 502 }
 503
 504 exit $errors;
 505
 506
 507 sub printResponseChain
 508 {
 509     my($response) = @_;
 510     return unless defined $response;
 511     printResponseChain($response->previous);
 512     my $method = $response->request->method;
 513     my $url = $response->request->url->as_string;
 514     my $code = $response->code;
 515     print "$method $url --> ", $response->status_line, "\n";
 516 }
 517
 518
 519 sub usage
 520 {
 521     die <<"EOT";
 522 Usage: $progname [-options] <url>...
 523     -m <method>   use method for the request (default is '$method')
 524     -f            make request even if $progname believes method is illegal
 525     -b <base>     Use the specified URL as base
 526     -t <timeout>  Set timeout value
 527     -i <time>     Set the If-Modified-Since header on the request
 528     -c <conttype> use this content-type for POST, PUT, CHECKIN
 529     -a            Use text mode for content I/O
 530     -p <proxyurl> use this as a proxy
 531     -P            don't load proxy settings from environment
 532     -H <header>   send this HTTP header (you can specify several)
 533     -C <username>:<password>
 534                   provide credentials for basic authentication
 535
 536     -u            Display method and URL before any response
 537     -U            Display request headers (implies -u)
 538     -s            Display response status code
 539     -S            Display response status chain
 540     -e            Display response headers
 541     -d            Do not display content
 542     -o <format>   Process HTML content in various ways
 543
 544     -v            Show program version
 545     -h            Print this message
 546
 547     -x            Extra debugging output
 548 EOT
 549 }