Commit | Line | Data |
3fea05b9 |
1 | package URI::urn; # RFC 2141 |
2 | |
3 | require URI; |
4 | @ISA=qw(URI); |
5 | |
6 | use strict; |
7 | use Carp qw(carp); |
8 | |
9 | use vars qw(%implementor); |
10 | |
11 | sub _init { |
12 | my $class = shift; |
13 | my $self = $class->SUPER::_init(@_); |
14 | my $nid = $self->nid; |
15 | |
16 | my $impclass = $implementor{$nid}; |
17 | return $impclass->_urn_init($self, $nid) if $impclass; |
18 | |
19 | $impclass = "URI::urn"; |
20 | if ($nid =~ /^[A-Za-z\d][A-Za-z\d\-]*\z/) { |
21 | my $id = $nid; |
22 | # make it a legal perl identifier |
23 | $id =~ s/-/_/g; |
24 | $id = "_$id" if $id =~ /^\d/; |
25 | |
26 | $impclass = "URI::urn::$id"; |
27 | no strict 'refs'; |
28 | unless (@{"${impclass}::ISA"}) { |
29 | # Try to load it |
30 | eval "require $impclass"; |
31 | die $@ if $@ && $@ !~ /Can\'t locate.*in \@INC/; |
32 | $impclass = "URI::urn" unless @{"${impclass}::ISA"}; |
33 | } |
34 | } |
35 | else { |
36 | carp("Illegal namespace identifier '$nid' for URN '$self'") if $^W; |
37 | } |
38 | $implementor{$nid} = $impclass; |
39 | |
40 | return $impclass->_urn_init($self, $nid); |
41 | } |
42 | |
43 | sub _urn_init { |
44 | my($class, $self, $nid) = @_; |
45 | bless $self, $class; |
46 | } |
47 | |
48 | sub _nid { |
49 | my $self = shift; |
50 | my $opaque = $self->opaque; |
51 | if (@_) { |
52 | my $v = $opaque; |
53 | my $new = shift; |
54 | $v =~ s/[^:]*/$new/; |
55 | $self->opaque($v); |
56 | # XXX possible rebless |
57 | } |
58 | $opaque =~ s/:.*//s; |
59 | return $opaque; |
60 | } |
61 | |
62 | sub nid { # namespace identifier |
63 | my $self = shift; |
64 | my $nid = $self->_nid(@_); |
65 | $nid = lc($nid) if defined($nid); |
66 | return $nid; |
67 | } |
68 | |
69 | sub nss { # namespace specific string |
70 | my $self = shift; |
71 | my $opaque = $self->opaque; |
72 | if (@_) { |
73 | my $v = $opaque; |
74 | my $new = shift; |
75 | if (defined $new) { |
76 | $v =~ s/(:|\z).*/:$new/; |
77 | } |
78 | else { |
79 | $v =~ s/:.*//s; |
80 | } |
81 | $self->opaque($v); |
82 | } |
83 | return undef unless $opaque =~ s/^[^:]*://; |
84 | return $opaque; |
85 | } |
86 | |
87 | sub canonical { |
88 | my $self = shift; |
89 | my $nid = $self->_nid; |
90 | my $new = $self->SUPER::canonical; |
91 | return $new if $nid !~ /[A-Z]/ || $nid =~ /%/; |
92 | $new = $new->clone if $new == $self; |
93 | $new->nid(lc($nid)); |
94 | return $new; |
95 | } |
96 | |
97 | 1; |