cvs commit: modperl-2.0/Apache-Test/lib/Apache TestRequest.pm

[dougm]

dougm       01/07/15 17:04:32

  Modified:    Apache-Test/lib/Apache TestRequest.pm
  Log:
  allow $Apache::TestRequest::scheme to be configured for lwp shortcuts
  trick Net::NNTP->new into calling a fixup so we can override the
  default nntp port
  
  Revision  Changes    Path
  1.6       +29 -2     modperl-2.0/Apache-Test/lib/Apache/TestRequest.pm
  
  Index: TestRequest.pm
  ===================================================================
  RCS file: /home/cvs/modperl-2.0/Apache-Test/lib/Apache/TestRequest.pm,v
  retrieving revision 1.5
  retrieving revision 1.6
  diff -u -r1.5 -r1.6
  --- TestRequest.pm    2001/05/08 05:07:11     1.5
  +++ TestRequest.pm    2001/07/16 00:04:32     1.6
  @@ -28,7 +28,7 @@
   my $Config;
   
   sub hostport {
  -    my $config = shift;
  +    my $config = shift || test_config();
       my $hostport = $config->{hostport};
   
       if (my $module = $Apache::TestRequest::Module) {
  @@ -44,7 +44,8 @@
       return $url if $url =~ m,^(\w+):/,;
       $url = "/$url" unless $url =~ m,^/,;
       my $hostport = hostport($Config);
  -    return "http://$hostport$url";;
  +    my $scheme = $Apache::TestRequest::Scheme || 'http';
  +    return "$scheme://$hostport$url";
   }
   
   my %wanted_args = map {$_, 1} qw(username password realm content filename);
  @@ -256,6 +257,32 @@
   sub to_string {
       my $obj = shift;
       ref($obj) ? $obj->as_string : $obj;
  +}
  +
  +#want news: urls to work with the LWP shortcuts
  +#but cant find a clean way to override the default nntp port
  +#by brute force we trick Net::NTTP into calling FixupNNTP::new
  +#instead of IO::Socket::INET::new, we fixup the args then forward
  +#to IO::Socket::INET::new
  +
  +if (eval { require Net::NNTP }) {
  +    my $new;
  +
  +    for (@Net::NNTP::ISA) {
  +        last if $new = $_->can('new');
  +    }
  +
  +    unshift @Net::NNTP::ISA, 'FixupNNTP';
  +
  +    *FixupNNTP::new = sub {
  +        my $class = shift;
  +        my $args = {@_};
  +        my($host, $port) = split ':',
  +          Apache::TestRequest::hostport();
  +        $args->{PeerPort} = $port;
  +        $args->{PeerAddr} = $host;
  +        return $new->($class, %$args);
  +    }
   }
   
   1;