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

   1 package URI::news;  # draft-gilman-news-url-01
   2
   3 require URI::_server;
   4 @ISA=qw(URI::_server);
   5
   6 use strict;
   7 use URI::Escape qw(uri_unescape);
   8 use Carp ();
   9
  10 sub default_port { 119 }
  11
  12 #   newsURL      =  scheme ":" [ news-server ] [ refbygroup | message ]
  13 #   scheme       =  "news" | "snews" | "nntp"
  14 #   news-server  =  "//" server "/"
  15 #   refbygroup   = group [ "/" messageno [ "-" messageno ] ]
  16 #   message      = local-part "@" domain
  17
  18 sub _group
  19 {
  20     my $self = shift;
  21     my $old = $self->path;
  22     if (@_) {
  23         my($group,$from,$to) = @_;
  24         if ($group =~ /\@/) {
  25             $group =~ s/^<(.*)>$/$1/;  # "<" and ">" should not be part of it
  26         }
  27         $group =~ s,%,%25,g;
  28         $group =~ s,/,%2F,g;
  29         my $path = $group;
  30         if (defined $from) {
  31             $path .= "/$from";
  32             $path .= "-$to" if defined $to;
  33         }
  34         $self->path($path);
  35     }
  36
  37     $old =~ s,^/,,;
  38     if ($old !~ /\@/ && $old =~ s,/(.*),, && wantarray) {
  39         my $extra = $1;
  40         return (uri_unescape($old), split(/-/, $extra));
  41     }
  42     uri_unescape($old);
  43 }
  44
  45
  46 sub group
  47 {
  48     my $self = shift;
  49     if (@_) {
  50         Carp::croak("Group name can't contain '\@'") if $_[0] =~ /\@/;
  51     }
  52     my @old = $self->_group(@_);
  53     return if $old[0] =~ /\@/;
  54     wantarray ? @old : $old[0];
  55 }
  56
  57 sub message
  58 {
  59     my $self = shift;
  60     if (@_) {
  61         Carp::croak("Message must contain '\@'") unless $_[0] =~ /\@/;
  62     }
  63     my $old = $self->_group(@_);
  64     return unless $old =~ /\@/;
  65     return $old;
  66 }
  67
  68 1;