X-Git-Url: http://vcs.maemo.org/git/?a=blobdiff_plain;f=deb-src%2Flibwww-perl%2Flibwww-perl-5.813%2Ft%2Flocal%2Fprotosub.t;fp=deb-src%2Flibwww-perl%2Flibwww-perl-5.813%2Ft%2Flocal%2Fprotosub.t;h=0db95d7a27d5fc2b8386577a58ff079bbca6d5b6;hb=d615bbbf525d490a6803e161c1063da7ee8fb9bc;hp=0000000000000000000000000000000000000000;hpb=5638bd62c66215ffc4830630a7bfcfe5cdf331d7;p=pkg-perl

diff --git a/deb-src/libwww-perl/libwww-perl-5.813/t/local/protosub.t b/deb-src/libwww-perl/libwww-perl-5.813/t/local/protosub.t
new file mode 100644
index 0000000..0db95d7
--- /dev/null
+++ b/deb-src/libwww-perl/libwww-perl-5.813/t/local/protosub.t
@@ -0,0 +1,75 @@
+#!perl
+
+print "1..6\n";
+
+# This test tries to make a custom protocol implementation by
+# subclassing of LWP::Protocol.
+
+
+use LWP::UserAgent ();
+use LWP::Protocol ();
+
+LWP::Protocol::implementor(http => 'myhttp');
+
+$ua = LWP::UserAgent->new;
+$ua->proxy('ftp' => "http://www.sn.no/");
+
+$req = HTTP::Request->new(GET => 'ftp://foo/');
+$req->header(Cookie => "perl=cool");
+
+$res = $ua->request($req);
+
+print $res->as_string;
+
+print "not " unless $res->code == 200;
+print "ok 5\n";
+print "not " unless $res->content eq "Howdy\n";
+print "ok 6\n";
+exit;
+
+
+#----------------------------------
+package myhttp;
+
+BEGIN {
+   @ISA=qw(LWP::Protocol);
+}
+
+sub new
+{
+    my $class = shift;
+    print "CTOR: $class->new(@_)\n";
+    my($prot) = @_;
+    print "not " unless $prot eq "http";
+    print "ok 1\n";
+    my $self = $class->SUPER::new(@_);
+    for (keys %$self) {
+	my $v = $self->{$_};
+	$v = "<undef>" unless defined($v);
+	print "$_: $v\n";
+    }
+    $self;
+}
+
+sub request
+{
+    my $self = shift;
+    print "REQUEST: $self->request(",
+       join(",", (map defined($_)? $_ : "UNDEF", @_)), ")\n";
+
+    my($request, $proxy, $arg, $size, $timeout) = @_;
+    print $request->as_string;
+
+    print "not " unless $proxy eq "http://www.sn.no/";
+    print "ok 2\n";
+    print "not " unless $request->url eq "ftp://foo/";
+    print "ok 3\n";
+    print "not " unless $request->header("cookie") eq "perl=cool";
+    print "ok 4\n";
+
+    my $res = HTTP::Response->new(200 => "OK");
+    $res->content_type("text/plain");
+    $res->date(time);
+    $self->collect_once($arg, $res, "Howdy\n");
+    $res;
+}