diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/URI/urn.pm')
-rw-r--r-- | Master/tlpkg/tlperl/lib/URI/urn.pm | 98 |
1 files changed, 0 insertions, 98 deletions
diff --git a/Master/tlpkg/tlperl/lib/URI/urn.pm b/Master/tlpkg/tlperl/lib/URI/urn.pm deleted file mode 100644 index 4c594f5b5da..00000000000 --- a/Master/tlpkg/tlperl/lib/URI/urn.pm +++ /dev/null @@ -1,98 +0,0 @@ -package URI::urn; # RFC 2141 - -use strict; -use warnings; - -use parent 'URI'; - -use Carp qw(carp); - -my %implementor; - -sub _init { - my $class = shift; - my $self = $class->SUPER::_init(@_); - my $nid = $self->nid; - - my $impclass = $implementor{$nid}; - return $impclass->_urn_init($self, $nid) if $impclass; - - $impclass = "URI::urn"; - if ($nid =~ /^[A-Za-z\d][A-Za-z\d\-]*\z/) { - my $id = $nid; - # make it a legal perl identifier - $id =~ s/-/_/g; - $id = "_$id" if $id =~ /^\d/; - - $impclass = "URI::urn::$id"; - no strict 'refs'; - unless (@{"${impclass}::ISA"}) { - # Try to load it - eval "require $impclass"; - die $@ if $@ && $@ !~ /Can\'t locate.*in \@INC/; - $impclass = "URI::urn" unless @{"${impclass}::ISA"}; - } - } - else { - carp("Illegal namespace identifier '$nid' for URN '$self'") if $^W; - } - $implementor{$nid} = $impclass; - - return $impclass->_urn_init($self, $nid); -} - -sub _urn_init { - my($class, $self, $nid) = @_; - bless $self, $class; -} - -sub _nid { - my $self = shift; - my $opaque = $self->opaque; - if (@_) { - my $v = $opaque; - my $new = shift; - $v =~ s/[^:]*/$new/; - $self->opaque($v); - # XXX possible rebless - } - $opaque =~ s/:.*//s; - return $opaque; -} - -sub nid { # namespace identifier - my $self = shift; - my $nid = $self->_nid(@_); - $nid = lc($nid) if defined($nid); - return $nid; -} - -sub nss { # namespace specific string - my $self = shift; - my $opaque = $self->opaque; - if (@_) { - my $v = $opaque; - my $new = shift; - if (defined $new) { - $v =~ s/(:|\z).*/:$new/; - } - else { - $v =~ s/:.*//s; - } - $self->opaque($v); - } - return undef unless $opaque =~ s/^[^:]*://; - return $opaque; -} - -sub canonical { - my $self = shift; - my $nid = $self->_nid; - my $new = $self->SUPER::canonical; - return $new if $nid !~ /[A-Z]/ || $nid =~ /%/; - $new = $new->clone if $new == $self; - $new->nid(lc($nid)); - return $new; -} - -1; |