File Coverage

blib/lib/URI/crid.pm
Criterion Covered Total %
statement 32 32 100.0
branch 8 12 66.6
condition 2 4 50.0
subroutine 5 5 100.0
pod 2 2 100.0
total 49 55 89.0


line stmt bran cond sub pod time code
1             package URI::crid;
2              
3             require URI;
4             our @ISA=qw(URI);
5              
6 2     2   51024 use warnings;
  2         5  
  2         61  
7 2     2   17 use strict;
  2         3  
  2         67  
8 2     2   1582 use URI::Escape qw(uri_unescape);
  2         2921  
  2         1188  
9              
10             =head1 NAME
11              
12             URI::crid - URI scheme as defined in RFC 4078
13              
14             =head1 VERSION
15              
16             Version 0.01
17              
18             =cut
19              
20             our $VERSION = '0.01';
21              
22             =head1 SYNOPSIS
23              
24             Allows you to break down and/or build up URIs of the scheme CRID (as used
25             by the TV-Anytime standard to uniquely identify television and radio
26             programmes.
27              
28             use URI;
29              
30             my $doctor_who = URI->new("crid://bbc.co.uk/b0074fly");
31             print "authority: " . $doctor_who->authority . $/;
32             print "data: " . $doctor_who->data . $/;
33             ...
34              
35             =head1 METHODS
36              
37             =head2 authority [AUTHORITY]
38              
39             Returns (or sets) the organisation which owns this crid. This usually
40             corresponds to the organisation's domain name.
41              
42             =cut
43              
44             sub authority
45             {
46 2     2 1 1541 my $self = shift;
47 2         12 my $old = $self->opaque;
48 2 100       73 if (@_) {
49 1         6 my $data = ($old =~ m|//[^/]+/(.*)$|)[0];
50 1         3 my $new = shift;
51 1 50       4 $new = "" unless defined $new;
52 1         6 $self->opaque("//$new/$data");
53 1         100 return $new;
54             }
55 1   50     9 $old = ($old =~ m|^//([^/]+)/?|)[0] || '';
56 1 50       6 return undef unless defined $old;
57 1         7 return uri_unescape($old);
58             }
59              
60             =head2 data [DATA]
61              
62             Returns (or sets) the unique identifier that this crid applies to.
63             The author of a crid may decide for themselves what form this data
64             takes, to best suit the application.
65              
66             =cut
67              
68             sub data
69             {
70 2     2 1 428 my $self = shift;
71 2         7 my $old = $self->opaque;
72 2 100       28 if (@_) {
73 1         2 my $tmp = $old;
74 1 50       4 $tmp = "/" unless defined $tmp;
75 1   50     10 my $authority = ($old =~ m|^//([^/]+)/?|)[0] || '';
76 1         2 my $new = shift;
77 1 50       5 $new = "" unless defined $new;
78 1         6 $self->opaque("//$authority/$new");
79 1         26 return $new;
80             }
81 1         7 $old = ($old =~ m|//[^/]+/(.*)$|)[0];
82 1         4 return uri_unescape($old);
83             }
84              
85             1;
86              
87             =head1 AUTHOR
88              
89             Ali Craigmile, C<< >>
90              
91             =head1 BUGS
92              
93             Please report any bugs or feature requests to C, or through
94             the web interface at L. I will be notified, and then you'll
95             automatically be notified of progress on your bug as I make changes.
96              
97              
98              
99              
100             =head1 SUPPORT
101              
102             You can find documentation for this module with the perldoc command.
103              
104             perldoc URI::crid
105              
106              
107             You can also look for information at:
108              
109             =over 4
110              
111             =item * RT: CPAN's request tracker
112              
113             L
114              
115             =item * AnnoCPAN: Annotated CPAN documentation
116              
117             L
118              
119             =item * CPAN Ratings
120              
121             L
122              
123             =item * Search CPAN
124              
125             L
126              
127             =back
128              
129              
130             =head1 ACKNOWLEDGEMENTS
131              
132             Gisle Aas C<< gaas@cpan.org >> for writing the base class URI.
133              
134             =head1 COPYRIGHT & LICENSE
135              
136             Copyright 2007 Ali Craigmile, all rights reserved.
137              
138             This program is free software; you can redistribute it and/or modify it
139             under the same terms as Perl itself.
140              
141              
142             =cut
143              
144             1; # End of URI::crid