1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
|
package URI::URL::news;
require URI::URL;
@ISA = qw(URI::URL);
use URI::Escape;
sub new {
my($class, $init, $base) = @_;
my $self = bless { }, $class;
$self->{'scheme'} = lc($1) if $init =~ s/^\s*([\w\+\.\-]+)://;
$self->groupart(uri_unescape($init));
$self->base($base) if $base;
$self;
}
sub groupart {
my $self = shift;
my $old = $self->{'path'};
if (@_) {
my $p = shift;
if (defined $p && $p =~ /\@/) {
# it is an message id
$p =~ s/^<(.*)>$/$1/; # "<" and ">" should not be part of it
}
$self->{'path'} = $p;
}
$old;
}
*path = \&groupart;
sub article {
my $self = shift;
Carp::croak("Illegal article id name (does not contain '\@')")
if @_ && $_[0] !~ /\@/;
my $old = $self->groupart(@_);
return undef if $old !~ /\@/;
$old;
}
sub group {
my $self = shift;
Carp::croak("Illegal group name (contains '\@')")
if @_ && $_[0] =~ /\@/;
my $old = $self->groupart(@_);
return undef if $old =~ /\@/;
$old;
}
sub crack
{
my $self = shift;
('news', # scheme
undef, # user
undef, # passwd
undef, # host
undef, # port
$self->{'path'}, # path
undef, # params
undef, # query
undef # fragment
)
}
sub as_string {
my $self = shift;
my $scheme = $self->{'scheme'} || "news";
"$scheme:" . uri_escape($self->{'path'});
}
1;
|
