File Coverage

blib/lib/LWP/Protocol/virtual.pm
Criterion Covered Total %
statement 21 25 84.0
branch n/a
condition n/a
subroutine 7 8 87.5
pod 1 1 100.0
total 29 34 85.2


line stmt bran cond sub pod time code
1             # vim: ts=4 sw=4
2             package LWP::Protocol::virtual;
3              
4 1     1   1036 use warnings;
  1         1  
  1         24  
5 1     1   4 use strict;
  1         1  
  1         38  
6              
7             =head1 NAME
8              
9             LWP::Protocol::virtual - Protocol to locate resources on groups of sites
10              
11             =head1 VERSION
12              
13             Version 0.02
14              
15             =cut
16              
17             our $VERSION = '0.02';
18 1     1   689 use LWP::Protocol;
  1         23439  
  1         32  
19 1     1   9 use HTTP::Status qw( RC_BAD_REQUEST RC_FOUND );
  1         2  
  1         189  
20 1     1   6 use Carp qw(confess);
  1         2  
  1         46  
21 1     1   991 use Data::Dumper;
  1         7416  
  1         71  
22 1     1   8 use strict;
  1         3  
  1         132  
23              
24             our (@ISA) = qw(LWP::Protocol);
25              
26              
27             =head1 SYNOPSIS
28              
29             #
30             ## From shell, not perl.
31             cpan URI::virtual
32             echo 'CPAN http://cpan.mirror.com/pub/CPAN' > ~/.lwp_virt
33             GET virtual://CPAN/some/path/some-path-1.0.tgz > some-path-1.0.tgz
34             perl -MCPAN -e '
35             my $CPAN = CPAN->new();
36             CPAN::Config->load($CPAN);
37             $CPAN::Config->{urllist} = [ qw(virtual://CPAN/) ];
38             CPAN::Config->commit("MyConfig.pm");
39             '
40             ## Move MyConfig to somewhere CPAN will find it.
41              
42              
43             =head1 FUNCTIONS
44              
45             =head2 request
46              
47             This processes a request, by calling $uri->resolve on the URI object
48             (which one would suspect is an instalnce of URI::virtual, and therefore
49             supports it) and returning a redirect to the uri returned. Any URI
50             subclass which satisfies the conditions:
51              
52             $uri->can("resolve")->()->isa("URI")
53             ref $uri->can("path") eq 'CODE'
54              
55             will be acceptable. How you would tell LWP to use this Protocol
56             for another scheme is anybody's guess.
57            
58             see URI::virtual.
59              
60             =cut
61              
62             sub request {
63 0     0 1   my ($self, $req, $res) = (shift,shift);
64 0           $res = HTTP::Response->new(RC_FOUND);
65 0           $res->header("Location" => $req->uri()->resolve());
66 0           return $res;
67             };
68             1;
69              
70             =head1 AUTHOR
71              
72             Rich Paul, C<< >>
73             Mail to this address bounces, but you'll think of something.
74             It's a poor man's Turing Test.
75              
76             =head1 BUGS
77              
78             Please report any bugs or feature requests to
79             C, or through the web interface at
80             L.
81             I will be notified, and then you'll automatically be notified of progress on
82             your bug as I make changes.
83              
84             =head1 ACKNOWLEDGEMENTS
85              
86             The guys who wrote LWP. Nice job!
87              
88             =head1 COPYRIGHT & LICENSE
89              
90             Copyright 2005 Rich Paul, All Rights Reserved.
91              
92             This program is free software; you can redistribute it and/or modify it
93             under the same terms as Perl itself.
94              
95             =cut
96              
97             1; # End of LWP::Protocol::virtual