Add the original source packages to maemo, source lenny

[dh-make-perl] / dev / i386 / libwww-perl / libwww-perl-5.813 / t / local / protosub.t

diff --git a/dev/i386/libwww-perl/libwww-perl-5.813/t/local/protosub.t b/dev/i386/libwww-perl/libwww-perl-5.813/t/local/protosub.t
new file mode 100644 (file)
index 0000000..0db95d7
--- /dev/null
+++ b/dev/i386/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;
+}