vcs.maemo.org Git - dh-make-perl/blob - dev/arm/libwww-perl/libwww-perl-5.813/debian/libwww-perl/usr/share/perl5/LWP/Simple.pm

   1 package LWP::Simple;
   2
   3 use strict;
   4 use vars qw($ua %loop_check $FULL_LWP @EXPORT @EXPORT_OK $VERSION);
   5
   6 require Exporter;
   7
   8 @EXPORT = qw(get head getprint getstore mirror);
   9 @EXPORT_OK = qw($ua);
  10
  11 # I really hate this.  I was a bad idea to do it in the first place.
  12 # Wonder how to get rid of it???  (It even makes LWP::Simple 7% slower
  13 # for trivial tests)
  14 use HTTP::Status;
  15 push(@EXPORT, @HTTP::Status::EXPORT);
  16
  17 $VERSION = "5.810";
  18 $FULL_LWP++ if grep {lc($_) eq "http_proxy"} keys %ENV;
  19
  20
  21 sub import
  22 {
  23     my $pkg = shift;
  24     my $callpkg = caller;
  25     if (grep $_ eq '$ua', @_) {
  26         $FULL_LWP++;
  27         _init_ua();
  28     }
  29     Exporter::export($pkg, $callpkg, @_);
  30 }
  31
  32
  33 sub _init_ua
  34 {
  35     require LWP;
  36     require LWP::UserAgent;
  37     require HTTP::Status;
  38     require HTTP::Date;
  39     $ua = new LWP::UserAgent;  # we create a global UserAgent object
  40     my $ver = $LWP::VERSION = $LWP::VERSION;  # avoid warning
  41     $ua->agent("LWP::Simple/$LWP::VERSION");
  42     $ua->env_proxy;
  43 }
  44
  45
  46 sub get ($)
  47 {
  48     %loop_check = ();
  49     goto \&_get;
  50 }
  51
  52
  53 sub get_old ($)
  54 {
  55     my($url) = @_;
  56     _init_ua() unless $ua;
  57
  58     my $request = HTTP::Request->new(GET => $url);
  59     my $response = $ua->request($request);
  60
  61     return $response->content if $response->is_success;
  62     return undef;
  63 }
  64
  65
  66 sub head ($)
  67 {
  68     my($url) = @_;
  69     _init_ua() unless $ua;
  70
  71     my $request = HTTP::Request->new(HEAD => $url);
  72     my $response = $ua->request($request);
  73
  74     if ($response->is_success) {
  75         return $response unless wantarray;
  76         return (scalar $response->header('Content-Type'),
  77                 scalar $response->header('Content-Length'),
  78                 HTTP::Date::str2time($response->header('Last-Modified')),
  79                 HTTP::Date::str2time($response->header('Expires')),
  80                 scalar $response->header('Server'),
  81                );
  82     }
  83     return;
  84 }
  85
  86
  87 sub getprint ($)
  88 {
  89     my($url) = @_;
  90     _init_ua() unless $ua;
  91
  92     my $request = HTTP::Request->new(GET => $url);
  93     local($\) = ""; # ensure standard $OUTPUT_RECORD_SEPARATOR
  94     my $callback = sub { print $_[0] };
  95     if ($^O eq "MacOS") {
  96         $callback = sub { $_[0] =~ s/\015?\012/\n/g; print $_[0] }
  97     }
  98     my $response = $ua->request($request, $callback);
  99     unless ($response->is_success) {
 100         print STDERR $response->status_line, " <URL:$url>\n";
 101     }
 102     $response->code;
 103 }
 104
 105
 106 sub getstore ($$)
 107 {
 108     my($url, $file) = @_;
 109     _init_ua() unless $ua;
 110
 111     my $request = HTTP::Request->new(GET => $url);
 112     my $response = $ua->request($request, $file);
 113
 114     $response->code;
 115 }
 116
 117
 118 sub mirror ($$)
 119 {
 120     my($url, $file) = @_;
 121     _init_ua() unless $ua;
 122     my $response = $ua->mirror($url, $file);
 123     $response->code;
 124 }
 125
 126
 127 sub _get
 128 {
 129     my $url = shift;
 130     my $ret;
 131     if (!$FULL_LWP && $url =~ m,^http://([^/:\@]+)(?::(\d+))?(/\S*)?$,) {
 132         my $host = $1;
 133         my $port = $2 || 80;
 134         my $path = $3;
 135         $path = "/" unless defined($path);
 136         return _trivial_http_get($host, $port, $path);
 137     }
 138     else {
 139         _init_ua() unless $ua;
 140         if (@_ && $url !~ /^\w+:/) {
 141             # non-absolute redirect from &_trivial_http_get
 142             my($host, $port, $path) = @_;
 143             require URI;
 144             $url = URI->new_abs($url, "http://$host:$port$path");
 145         }
 146         my $request = HTTP::Request->new(GET => $url);
 147         my $response = $ua->request($request);
 148         return $response->is_success ? $response->content : undef;
 149     }
 150 }
 151
 152
 153 sub _trivial_http_get
 154 {
 155    my($host, $port, $path) = @_;
 156    #print "HOST=$host, PORT=$port, PATH=$path\n";
 157
 158    require IO::Socket;
 159    local($^W) = 0;
 160    my $sock = IO::Socket::INET->new(PeerAddr => $host,
 161                                     PeerPort => $port,
 162                                     Proto    => 'tcp',
 163                                     Timeout  => 60) || return undef;
 164    $sock->autoflush;
 165    my $netloc = $host;
 166    $netloc .= ":$port" if $port != 80;
 167    print $sock join("\015\012" =>
 168                     "GET $path HTTP/1.0",
 169                     "Host: $netloc",
 170                     "User-Agent: lwp-trivial/$VERSION",
 171                     "", "");
 172
 173    my $buf = "";
 174    my $n;
 175    1 while $n = sysread($sock, $buf, 8*1024, length($buf));
 176    return undef unless defined($n);
 177
 178    if ($buf =~ m,^HTTP/\d+\.\d+\s+(\d+)[^\012]*\012,) {
 179        my $code = $1;
 180        #print "CODE=$code\n$buf\n";
 181        if ($code =~ /^30[1237]/ && $buf =~ /\012Location:\s*(\S+)/i) {
 182            # redirect
 183            my $url = $1;
 184            return undef if $loop_check{$url}++;
 185            return _get($url, $host, $port, $path);
 186        }
 187        return undef unless $code =~ /^2/;
 188        $buf =~ s/.+?\015?\012\015?\012//s;  # zap header
 189    }
 190
 191    return $buf;
 192 }
 193
 194
 195 1;
 196
 197 __END__
 198
 199 =head1 NAME
 200
 201 LWP::Simple - simple procedural interface to LWP
 202
 203 =head1 SYNOPSIS
 204
 205  perl -MLWP::Simple -e 'getprint "http://www.sn.no"'
 206
 207  use LWP::Simple;
 208  $content = get("http://www.sn.no/");
 209  die "Couldn't get it!" unless defined $content;
 210
 211  if (mirror("http://www.sn.no/", "foo") == RC_NOT_MODIFIED) {
 212      ...
 213  }
 214
 215  if (is_success(getprint("http://www.sn.no/"))) {
 216      ...
 217  }
 218
 219 =head1 DESCRIPTION
 220
 221 This module is meant for people who want a simplified view of the
 222 libwww-perl library.  It should also be suitable for one-liners.  If
 223 you need more control or access to the header fields in the requests
 224 sent and responses received, then you should use the full object-oriented
 225 interface provided by the C<LWP::UserAgent> module.
 226
 227 The following functions are provided (and exported) by this module:
 228
 229 =over 3
 230
 231 =item get($url)
 232
 233 The get() function will fetch the document identified by the given URL
 234 and return it.  It returns C<undef> if it fails.  The $url argument can
 235 be either a simple string or a reference to a URI object.
 236
 237 You will not be able to examine the response code or response headers
 238 (like 'Content-Type') when you are accessing the web using this
 239 function.  If you need that information you should use the full OO
 240 interface (see L<LWP::UserAgent>).
 241
 242 =item head($url)
 243
 244 Get document headers. Returns the following 5 values if successful:
 245 ($content_type, $document_length, $modified_time, $expires, $server)
 246
 247 Returns an empty list if it fails.  In scalar context returns TRUE if
 248 successful.
 249
 250 =item getprint($url)
 251
 252 Get and print a document identified by a URL. The document is printed
 253 to the selected default filehandle for output (normally STDOUT) as
 254 data is received from the network.  If the request fails, then the
 255 status code and message are printed on STDERR.  The return value is
 256 the HTTP response code.
 257
 258 =item getstore($url, $file)
 259
 260 Gets a document identified by a URL and stores it in the file. The
 261 return value is the HTTP response code.
 262
 263 =item mirror($url, $file)
 264
 265 Get and store a document identified by a URL, using
 266 I<If-modified-since>, and checking the I<Content-Length>.  Returns
 267 the HTTP response code.
 268
 269 =back
 270
 271 This module also exports the HTTP::Status constants and procedures.
 272 You can use them when you check the response code from getprint(),
 273 getstore() or mirror().  The constants are:
 274
 275    RC_CONTINUE
 276    RC_SWITCHING_PROTOCOLS
 277    RC_OK
 278    RC_CREATED
 279    RC_ACCEPTED
 280    RC_NON_AUTHORITATIVE_INFORMATION
 281    RC_NO_CONTENT
 282    RC_RESET_CONTENT
 283    RC_PARTIAL_CONTENT
 284    RC_MULTIPLE_CHOICES
 285    RC_MOVED_PERMANENTLY
 286    RC_MOVED_TEMPORARILY
 287    RC_SEE_OTHER
 288    RC_NOT_MODIFIED
 289    RC_USE_PROXY
 290    RC_BAD_REQUEST
 291    RC_UNAUTHORIZED
 292    RC_PAYMENT_REQUIRED
 293    RC_FORBIDDEN
 294    RC_NOT_FOUND
 295    RC_METHOD_NOT_ALLOWED
 296    RC_NOT_ACCEPTABLE
 297    RC_PROXY_AUTHENTICATION_REQUIRED
 298    RC_REQUEST_TIMEOUT
 299    RC_CONFLICT
 300    RC_GONE
 301    RC_LENGTH_REQUIRED
 302    RC_PRECONDITION_FAILED
 303    RC_REQUEST_ENTITY_TOO_LARGE
 304    RC_REQUEST_URI_TOO_LARGE
 305    RC_UNSUPPORTED_MEDIA_TYPE
 306    RC_INTERNAL_SERVER_ERROR
 307    RC_NOT_IMPLEMENTED
 308    RC_BAD_GATEWAY
 309    RC_SERVICE_UNAVAILABLE
 310    RC_GATEWAY_TIMEOUT
 311    RC_HTTP_VERSION_NOT_SUPPORTED
 312
 313 The HTTP::Status classification functions are:
 314
 315 =over 3
 316
 317 =item is_success($rc)
 318
 319 True if response code indicated a successful request.
 320
 321 =item is_error($rc)
 322
 323 True if response code indicated that an error occurred.
 324
 325 =back
 326
 327 The module will also export the LWP::UserAgent object as C<$ua> if you
 328 ask for it explicitly.
 329
 330 The user agent created by this module will identify itself as
 331 "LWP::Simple/#.##" (where "#.##" is the libwww-perl version number)
 332 and will initialize its proxy defaults from the environment (by
 333 calling $ua->env_proxy).
 334
 335 =head1 CAVEAT
 336
 337 Note that if you are using both LWP::Simple and the very popular CGI.pm
 338 module, you may be importing a C<head> function from each module,
 339 producing a warning like "Prototype mismatch: sub main::head ($) vs
 340 none". Get around this problem by just not importing LWP::Simple's
 341 C<head> function, like so:
 342
 343         use LWP::Simple qw(!head);
 344         use CGI qw(:standard);  # then only CGI.pm defines a head()
 345
 346 Then if you do need LWP::Simple's C<head> function, you can just call
 347 it as C<LWP::Simple::head($url)>.
 348
 349 =head1 SEE ALSO
 350
 351 L<LWP>, L<lwpcook>, L<LWP::UserAgent>, L<HTTP::Status>, L<lwp-request>,
 352 L<lwp-mirror>