LWPng patch to work with URI
Blair Zajac (bzajac@geostaff.com)
Thu, 08 Apr 1999 13:34:56 -0700
This is a multi-part message in MIME format.
--------------CDB2EEA0E0C7ACBFE9A7C699
Content-Type: text/plain; charset=us-ascii
Content-Transfer-Encoding: 7bit
Hello Gisle,
Recently I've been using the LWPng library on a new install of
Perl 5.005_03 that only has the following extra HTML related
modules installed using CPAN:
Font::AFM
MIME::Base64
HTML::Parser
URI
LWP
HTML::TreeBuilder
File::CounterFile
LWP::SecureSocket
LWP::Version
When I tried to use my WebFS::FileCopy routines they were failing.
To fix the problem, I've patched LWPng to use the URI module instead
of URL. While this patch may not have picked up all the changes
needed for LWPng, I was successfully able to run make test on LWPng
and WebFS::FileCopy fine without any problems.
One question: in URI::_generic.pm the following line appears:
*epath = \&path;
and in URI::URL.pm the following routine appears:
sub epath
{
my $path = shift->SUPER::path(@_);
$path =~ s/;.*//;
$path;
}
While they are almost identical, they are different. Shouldn't just
one be kept and the other discarded?
Blair
--------------CDB2EEA0E0C7ACBFE9A7C699
Content-Type: text/plain; charset=us-ascii;
name="LWPng-patch"
Content-Transfer-Encoding: 7bit
Content-Disposition: inline;
filename="LWPng-patch"
diff -rc ../LWPng-alpha-0.23/bot/db.pl ./bot/db.pl
*** ../LWPng-alpha-0.23/bot/db.pl Thu Apr 23 04:11:27 1998
--- ./bot/db.pl Thu Apr 8 11:24:51 1999
***************
*** 1,6 ****
-
use Mysql;
! use URI::URL;
use strict;
use vars qw($dbh);
--- 1,5 ----
use Mysql;
! use URI;
use strict;
use vars qw($dbh);
***************
*** 10,22 ****
sub new_link
{
my($uri, $ref_id, $type) = @_;
! $uri = URI::URL->new($uri) unless ref($uri);
my $scheme = $uri->scheme || die "Not absolute URI";
my $host = $uri->host;
$scheme = $dbh->quote(lc($scheme));
$host = $dbh->quote(lc($host));
my $port = $uri->port || 0;
! my $abs_path = $dbh->quote($uri->full_path);
my $server_id;
my $sth = $dbh->query("select id from server where scheme = $scheme and host=$host and port = $port") or die $dbh->errmsg;
--- 9,21 ----
sub new_link
{
my($uri, $ref_id, $type) = @_;
! $uri = URI->new($uri) unless ref($uri);
my $scheme = $uri->scheme || die "Not absolute URI";
my $host = $uri->host;
$scheme = $dbh->quote(lc($scheme));
$host = $dbh->quote(lc($host));
my $port = $uri->port || 0;
! my $abs_path = $dbh->quote($uri->canonical->path_query);
my $server_id;
my $sth = $dbh->query("select id from server where scheme = $scheme and host=$host and port = $port") or die $dbh->errmsg;
diff -rc ../LWPng-alpha-0.23/bot/ngbot ./bot/ngbot
*** ../LWPng-alpha-0.23/bot/ngbot Thu Apr 23 04:35:18 1998
--- ./bot/ngbot Mon Apr 5 14:48:38 1999
***************
*** 25,31 ****
use LWP::MainLoop qw(run one_event empty);
use HTML::LinkExtor ();
! use URI::URL qw(url);
use MD5 ();
require 'db.pl';
--- 25,31 ----
use LWP::MainLoop qw(run one_event empty);
use HTML::LinkExtor ();
! use URI;
use MD5 ();
require 'db.pl';
***************
*** 45,51 ****
$sth = $dbh->query($sql) or die $dbh->errmess;
while (my($id, $scheme,$host,$port,$abs_path) = $sth->fetchrow) {
! my $url = URI::URL->new("$scheme:$abs_path");
$url->host($host) if $host;
$url->port($port) if $port;
my $method = visit_ok($url);
--- 45,51 ----
$sth = $dbh->query($sql) or die $dbh->errmess;
while (my($id, $scheme,$host,$port,$abs_path) = $sth->fetchrow) {
! my $url = URI->new("$scheme:$abs_path");
$url->host($host) if $host;
$url->port($port) if $port;
my $method = visit_ok($url);
diff -rc ../LWPng-alpha-0.23/lib/LWP/Authen/digest.pm ./lib/LWP/Authen/digest.pm
*** ../LWPng-alpha-0.23/lib/LWP/Authen/digest.pm Mon Apr 6 09:49:29 1998
--- ./lib/LWP/Authen/digest.pm Thu Apr 8 11:25:22 1999
***************
*** 61,67 ****
$qop = "auth";
}
! my $uri = $req->url->full_path;
my $nonce = $self->{nonce}; $nonce = "" unless defined $nonce;
my $nc = sprintf "%08x", ++$self->{nonce_count};
my $cnonce = sprintf "%x", rand(0xFFFFFF)+1; # +1 ensures always TRUE
--- 61,67 ----
$qop = "auth";
}
! my $uri = $req->url->canonical->path_query;
my $nonce = $self->{nonce}; $nonce = "" unless defined $nonce;
my $nc = sprintf "%08x", ++$self->{nonce_count};
my $cnonce = sprintf "%x", rand(0xFFFFFF)+1; # +1 ensures always TRUE
diff -rc ../LWPng-alpha-0.23/lib/LWP/Conn/FILE.pm ./lib/LWP/Conn/FILE.pm
*** ../LWPng-alpha-0.23/lib/LWP/Conn/FILE.pm Sun Jul 5 15:14:40 1998
--- ./lib/LWP/Conn/FILE.pm Mon Apr 5 15:01:26 1999
***************
*** 34,40 ****
}
my $method = uc($req->method);
! my $path = $url->local_path;
if ($method eq "HEAD" || $method eq "GET") {
get($req, $path, $method eq "GET");
--- 34,40 ----
}
my $method = uc($req->method);
! my $path = $url->file;
if ($method eq "HEAD" || $method eq "GET") {
get($req, $path, $method eq "GET");
diff -rc ../LWPng-alpha-0.23/lib/LWP/Conn/HTTP.pm ./lib/LWP/Conn/HTTP.pm
*** ../LWPng-alpha-0.23/lib/LWP/Conn/HTTP.pm Sun Jul 5 15:20:52 1998
--- ./lib/LWP/Conn/HTTP.pm Thu Apr 8 11:29:55 1999
***************
*** 76,85 ****
print STDERR "$self: New-Request $req\n" if $DEBUG;
my @rlines;
my $method = $req->method || "GET";
! my $uri = $req->proxy ? $req->url->as_string : $req->url->full_path;
my $proto = $req->protocol || "HTTP/1.1";
push(@rlines, "$method $uri $proto");
! $req->header("Host" => $req->url->netloc); # always override
my @conn_header;
*$self->{'lwp_req_count'}++;
--- 76,85 ----
print STDERR "$self: New-Request $req\n" if $DEBUG;
my @rlines;
my $method = $req->method || "GET";
! my $uri = $req->proxy ? $req->url->as_string : $req->url->canonical->path_query;
my $proto = $req->protocol || "HTTP/1.1";
push(@rlines, "$method $uri $proto");
! $req->header("Host" => $req->url->authority); # always override
my @conn_header;
*$self->{'lwp_req_count'}++;
diff -rc ../LWPng-alpha-0.23/lib/LWP/Redirect.pm ./lib/LWP/Redirect.pm
*** ../LWPng-alpha-0.23/lib/LWP/Redirect.pm Sun Jul 5 15:14:24 1998
--- ./lib/LWP/Redirect.pm Mon Apr 5 14:56:30 1999
***************
*** 17,23 ****
$method ne "HEAD" &&
!$req->redirect_ok($res);
my $loc = $res->header('Location') || return;
! $loc = (URI::URL->new($loc, $res->base))->abs(undef,1);
if ($code == 305) { # RC_USE_PROXY
$new->proxy($loc);
--- 17,23 ----
$method ne "HEAD" &&
!$req->redirect_ok($res);
my $loc = $res->header('Location') || return;
! $loc = URI::WithBase->new($loc, $res->base);
if ($code == 305) { # RC_USE_PROXY
$new->proxy($loc);
diff -rc ../LWPng-alpha-0.23/lib/LWP/Request.pm ./lib/LWP/Request.pm
*** ../LWPng-alpha-0.23/lib/LWP/Request.pm Sun Jul 5 15:16:53 1998
--- ./lib/LWP/Request.pm Mon Apr 5 14:56:46 1999
***************
*** 8,14 ****
require LWP::Hooks;
@ISA=qw(HTTP::Request LWP::Hooks);
! require URI::URL;
sub new2 # alternative ctor that sets up some handlers
{
--- 8,14 ----
require LWP::Hooks;
@ISA=qw(HTTP::Request LWP::Hooks);
! require URI;
sub new2 # alternative ctor that sets up some handlers
{
diff -rc ../LWPng-alpha-0.23/lib/LWP/Server.pm ./lib/LWP/Server.pm
*** ../LWPng-alpha-0.23/lib/LWP/Server.pm Sun Jul 5 15:14:24 1998
--- ./lib/LWP/Server.pm Mon Apr 5 16:18:35 1999
***************
*** 161,167 ****
return;
}
}
!
my $conn;
eval {
$conn = $conn_class->new($self->conn_param);
--- 161,167 ----
return;
}
}
!
my $conn;
eval {
$conn = $conn_class->new($self->conn_param);
diff -rc ../LWPng-alpha-0.23/lib/LWP/Sink.pm ./lib/LWP/Sink.pm
*** ../LWPng-alpha-0.23/lib/LWP/Sink.pm Sun Jul 5 15:14:24 1998
--- ./lib/LWP/Sink.pm Mon Apr 5 14:57:01 1999
***************
*** 85,91 ****
Perhaps I<LWP::Sink> should provide an interface to load sink
subclasses on demand and return references to them. Similar to how
! URI::URL works.
=head1 COPYRIGHT
--- 85,91 ----
Perhaps I<LWP::Sink> should provide an interface to load sink
subclasses on demand and return references to them. Similar to how
! URI works.
=head1 COPYRIGHT
diff -rc ../LWPng-alpha-0.23/lib/LWP/UA.pm ./lib/LWP/UA.pm
*** ../LWPng-alpha-0.23/lib/LWP/UA.pm Sun Jul 5 15:20:11 1998
--- ./lib/LWP/UA.pm Thu Apr 8 11:30:38 1999
***************
*** 90,115 ****
sub find_server
{
my($self, $url) = @_;
! $url = URI::URL->new($url) unless ref $url;
return undef unless $url;
my $proto = $url->scheme || return undef;
my $host = $url->host;
! my($port, $netloc);
# Handle some special cases where $host can't be trusted
$host = undef if $proto eq "file" || $proto eq "mailto";
if ($host) {
$port = $url->port;
! $netloc = $port ? "$proto://$host:$port" : "$proto://host";
} else {
! $netloc = "$proto:";
}
! my $server = $self->{ua_servers}{$netloc};
unless ($server) {
! $server = $self->{ua_servers}{$netloc} =
LWP::Server->new($self, $proto, $host, $port);
}
}
--- 90,115 ----
sub find_server
{
my($self, $url) = @_;
! $url = URI->new($url) unless ref $url;
return undef unless $url;
my $proto = $url->scheme || return undef;
my $host = $url->host;
! my($port, $authority);
# Handle some special cases where $host can't be trusted
$host = undef if $proto eq "file" || $proto eq "mailto";
if ($host) {
$port = $url->port;
! $authority = $port ? "$proto://$host:$port" : "$proto://host";
} else {
! $authority = "$proto:";
}
! my $server = $self->{ua_servers}{$authority};
unless ($server) {
! $server = $self->{ua_servers}{$authority} =
LWP::Server->new($self, $proto, $host, $port);
}
}
diff -rc ../LWPng-alpha-0.23/lib/URI/Attr.pm ./lib/URI/Attr.pm
*** ../LWPng-alpha-0.23/lib/URI/Attr.pm Thu Apr 23 02:49:27 1998
--- ./lib/URI/Attr.pm Mon Apr 5 15:46:12 1999
***************
*** 1,7 ****
package URI::Attr; # $Id: Attr.pm,v 1.6 1998/04/23 09:49:27 aas Exp $
- use URI::URL ();
use strict;
use vars qw($VERSION);
$VERSION = sprintf("%d.%02d", q$Revision: 1.6 $ =~ /(\d+)\.(\d+)/);
--- 1,7 ----
package URI::Attr; # $Id: Attr.pm,v 1.6 1998/04/23 09:49:27 aas Exp $
use strict;
+ use URI;
use vars qw($VERSION);
$VERSION = sprintf("%d.%02d", q$Revision: 1.6 $ =~ /(\d+)\.(\d+)/);
***************
*** 25,34 ****
}
! sub _attr # this method should probably be implemented by URI::URL itself
{
my($self, $url) = @_;
! $url = URI::URL->new($url) unless ref($url);
my @attr;
my $scheme = $url->scheme;
--- 25,34 ----
}
! sub _attr # this method should probably be implemented by URI itself
{
my($self, $url) = @_;
! $url = URI->new($url) unless ref($url);
my @attr;
my $scheme = $url->scheme;
***************
*** 53,59 ****
push(@attr, [DOMAIN => $1]) while $h =~ s/(\.[^.]+)$//;
}
push(@attr, [HOST => $h]);
! push(@attr, [SERVER => $url->port]);
}
my $p = $url->epath;
$p =~ s,^/,,;
--- 53,61 ----
push(@attr, [DOMAIN => $1]) while $h =~ s/(\.[^.]+)$//;
}
push(@attr, [HOST => $h]);
! if (UNIVERSAL::isa($url, 'URI::_server')) {
! push(@attr, [SERVER => $url->port]);
! }
}
my $p = $url->epath;
$p =~ s,^/,,;
***************
*** 276,282 ****
=head1 SEE ALSO
! L<URI::URL>
=head1 COPYRIGHT
--- 278,284 ----
=head1 SEE ALSO
! L<URI>
=head1 COPYRIGHT
diff -rc ../LWPng-alpha-0.23/testd/authd ./testd/authd
*** ../LWPng-alpha-0.23/testd/authd Fri Apr 3 01:40:00 1998
--- ./testd/authd Thu Apr 8 11:27:19 1999
***************
*** 71,77 ****
$pass="x";
$err++;
}
! if ($auth{uri} ne $req->url->full_path) {
print "wrong URI attribute returned.\n";
$err++;
}
--- 71,77 ----
$pass="x";
$err++;
}
! if ($auth{uri} ne $req->url->canonical->path_query) {
print "wrong URI attribute returned.\n";
$err++;
}
--------------CDB2EEA0E0C7ACBFE9A7C699
Content-Type: text/x-vcard; charset=us-ascii;
name="bzajac.vcf"
Content-Transfer-Encoding: 7bit
Content-Description: Card for Blair Zajac
Content-Disposition: attachment;
filename="bzajac.vcf"
begin:vcard
n:Zajac;Blair
tel;fax:310-827-8177
tel;work:310-827-3700 x1703
x-mozilla-html:FALSE
url:www.geocities.com
org:GeoCities
adr:;;4499 Glencoe Avenue;Marina del Rey;CA;90292;
version:2.1
email;internet:bzajac@geostaff.com
title:IT Analyst
x-mozilla-cpt:;-3232
fn:Dr. Blair Zajac
end:vcard
--------------CDB2EEA0E0C7ACBFE9A7C699--