git.maemo.org Git - pkg-perl/blob - deb-src/liburi-perl/liburi-perl-1.35.dfsg.1/URI/urn.pm

   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;