Last change
on this file since 27174 was 27174, checked in by davidb, 11 years ago |
Perl modules from CPAN that are used in supporting activate.pl, but not part of the Perl core. Only PMs included.
|
File size:
1.4 KB
|
Line | |
---|
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;
|
---|
Note:
See
TracBrowser
for help on using the repository browser.