1package URI::urn; # RFC 2141 2 3require URI; 4@ISA=qw(URI); 5 6use strict; 7use Carp qw(carp); 8 9use vars qw(%implementor); 10 11sub _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 43sub _urn_init { 44 my($class, $self, $nid) = @_; 45 bless $self, $class; 46} 47 48sub _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 62sub nid { # namespace identifier 63 my $self = shift; 64 my $nid = $self->_nid(@_); 65 $nid = lc($nid) if defined($nid); 66 return $nid; 67} 68 69sub 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 87sub 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 971; 98