File Coverage

blib/lib/URI/cpan.pm
Criterion Covered Total %
statement 44 44 100.0
branch 3 6 50.0
condition n/a
subroutine 12 12 100.0
pod n/a
total 59 62 95.1


line stmt bran cond sub pod time code
1 1     1   78401 use strict;
  1         12  
  1         31  
2 1     1   5 use warnings;
  1         2  
  1         42  
3              
4             package URI::cpan 1.008;
5             # ABSTRACT: URLs that refer to things on the CPAN
6              
7 1     1   460 use parent qw(URI::_generic);
  1         308  
  1         6  
8              
9             #pod =head1 SYNOPSIS
10             #pod
11             #pod use URI::cpan;
12             #pod
13             #pod my $uri = URI->new('cpan:///distfile/RJBS/URI-cpan-1.000.tar.gz');
14             #pod
15             #pod $uri->author; # => RJBS
16             #pod $uri->dist_name; # => URI-cpan
17             #pod $uri->dist_version; # => 1.000
18             #pod
19             #pod Other forms of cpan: URI include:
20             #pod
21             #pod cpan:///author/RJBS
22             #pod
23             #pod Reserved for likely future use are:
24             #pod
25             #pod cpan:///dist
26             #pod cpan:///module
27             #pod cpan:///package
28             #pod
29             #pod =cut
30              
31 1     1   5381 use Carp ();
  1         3  
  1         20  
32 1     1   410 use URI::cpan::author;
  1         2  
  1         34  
33 1     1   409 use URI::cpan::dist;
  1         3  
  1         32  
34 1     1   402 use URI::cpan::distfile;
  1         3  
  1         35  
35 1     1   395 use URI::cpan::module;
  1         3  
  1         30  
36 1     1   386 use URI::cpan::package;
  1         2  
  1         29  
37 1     1   6 use URI::cpan::dist;
  1         2  
  1         251  
38              
39             my %type_class = (
40             author => 'URI::cpan::author',
41             distfile => 'URI::cpan::distfile',
42              
43             # These will be uncommented when we figure out what the heck to do with them.
44             # -- rjbs, 2009-03-30
45             #
46             # dist => 'URI::cpan::dist',
47             # package => 'URI::cpan::package',
48             # module => 'URI::cpan::module',
49             );
50              
51             sub _init {
52 4     4   1836 my $self = shift->SUPER::_init(@_);
53 4         115 my $class = ref($self);
54              
55 4 50       15 Carp::croak "invalid cpan URI: non-empty query string not supported"
56             if $self->query;
57              
58 4 50       98 Carp::croak "invalid cpan URI: non-empty fragment string not supported"
59             if $self->fragment;
60              
61 4         40 my (undef, @path_parts) = split m{/}, $self->path;
62 4         58 my $type = $path_parts[0];
63              
64             Carp::croak "invalid cpan URI: do not understand path " . $self->path
65 4 50       14 unless my $new_class = $type_class{ $type };
66              
67 4         9 bless $self => $new_class;
68              
69 4         14 $self->validate;
70              
71 4         14 return $self;
72             }
73              
74             sub _p_rel {
75 12     12   22 my ($self) = @_;
76 12         32 my $path = $self->path;
77 12         280 $path =~ s{^/\w+/}{};
78 12         57 return $path;
79             }
80              
81             #pod =head1 WARNINGS
82             #pod
83             #pod URI objects are difficult to subclass, so I have not (yet?) taken the time to
84             #pod remove mutability from the objects. This means that you can probably alter a
85             #pod URI::cpan object into a state where it is no longer valid.
86             #pod
87             #pod Please don't change the contents of these objects after construction.
88             #pod
89             #pod =head1 SEE ALSO
90             #pod
91             #pod L and L
92             #pod
93             #pod =head1 THANKS
94             #pod
95             #pod This code is derived from code written at Pobox.com by Hans Dieter Pearcey.
96             #pod Dieter helped thrash out this new implementation, too.
97             #pod
98             #pod =cut
99              
100             1;
101              
102             __END__