home *** CD-ROM | disk | FTP | other *** search
/ Chip 2000 May / Chip_2000-05_cd1.bin / zkuste / Perl / ActivePerl-5.6.0.613.msi / 䆊䌷䈹䈙䏵-䞅䞆䞀㡆䞃䄦䠥 / _8aaf8301eb55ba165a09f610213fb3be < prev    next >
Encoding:
Text File  |  2000-03-15  |  1.5 KB  |  69 lines
  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;
  69.