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