Skip to content

Commit 67bc5db

Browse files
SineSwiperoalders
SineSwiper
authored and
oalders
committed
Add irc/ircs schemes
1 parent e938052 commit 67bc5db

File tree

3 files changed

+193
-0
lines changed

3 files changed

+193
-0
lines changed

‎lib/URI/irc.pm

Lines changed: 140 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,140 @@
1+
package URI::irc; # draft-butcher-irc-url-04
2+
3+
require URI::_login;
4+
@ISA=qw(URI::_login);
5+
6+
use strict;
7+
8+
use overload (
9+
'""' => sub { $_[0]->as_string },
10+
'==' => sub { URI::_obj_eq(@_) },
11+
'!=' => sub { !URI::_obj_eq(@_) },
12+
fallback => 1,
13+
);
14+
15+
sub default_port { 6667 }
16+
17+
# ircURL = ircURI "://" location "/" [ entity ] [ flags ] [ options ]
18+
# ircURI = "irc" / "ircs"
19+
# location = [ authinfo "@" ] hostport
20+
# authinfo = [ username ] [ ":" password ]
21+
# username = *( escaped / unreserved )
22+
# password = *( escaped / unreserved ) [ ";" passtype ]
23+
# passtype = *( escaped / unreserved )
24+
# entity = [ "#" ] *( escaped / unreserved )
25+
# flags = ( [ "," enttype ] [ "," hosttype ] )
26+
# /= ( [ "," hosttype ] [ "," enttype ] )
27+
# enttype = "," ( "isuser" / "ischannel" )
28+
# hosttype = "," ( "isserver" / "isnetwork" )
29+
# options = "?" option *( "&" option )
30+
# option = optname [ "=" optvalue ]
31+
# optname = *( ALPHA / "-" )
32+
# optvalue = optparam *( "," optparam )
33+
# optparam = *( escaped / unreserved )
34+
35+
# XXX: Technically, passtype is part of the protocol, but is rarely used and
36+
# not defined in the RFC beyond the URL ABNF.
37+
38+
# Starting the entity with /# is okay per spec, but it needs to be encoded to
39+
# %23 for the URL::_generic::path operations to parse correctly.
40+
sub _init {
41+
my $class = shift;
42+
my $self = $class->SUPER::_init(@_);
43+
$$self =~ s|^((?:[^:/?\#]+:)?(?://[^/?\#]*)?)/\#|$1/%23|s;
44+
$self;
45+
}
46+
47+
# Return the /# form, since this is most common for channel names.
48+
sub path {
49+
my $self = shift;
50+
my ($new) = @_;
51+
$new =~ s|^/\#|/%23| if (@_ && defined $new);
52+
my $val = $self->SUPER::path(@_ ? $new : ());
53+
$val =~ s|^/%23|/\#|;
54+
$val;
55+
}
56+
sub path_query {
57+
my $self = shift;
58+
my ($new) = @_;
59+
$new =~ s|^/\#|/%23| if (@_ && defined $new);
60+
my $val = $self->SUPER::path_query(@_ ? $new : ());
61+
$val =~ s|^/%23|/\#|;
62+
$val;
63+
}
64+
sub as_string {
65+
my $self = shift;
66+
my $val = $self->SUPER::as_string;
67+
$val =~ s|^((?:[^:/?\#]+:)?(?://[^/?\#]*)?)/%23|$1/\#|s;
68+
$val;
69+
}
70+
71+
sub entity {
72+
my $self = shift;
73+
74+
my $path = $self->path;
75+
$path =~ s|^/||;
76+
my ($entity, @flags) = split /,/, $path;
77+
78+
if (@_) {
79+
my $new = shift;
80+
$new = '' unless defined $new;
81+
$self->path( '/'.join(',', $new, @flags) );
82+
}
83+
84+
return unless length $entity;
85+
$entity;
86+
}
87+
88+
sub flags {
89+
my $self = shift;
90+
91+
my $path = $self->path;
92+
$path =~ s|^/||;
93+
my ($entity, @flags) = split /,/, $path;
94+
95+
if (@_) {
96+
$self->path( '/'.join(',', $entity, @_) );
97+
}
98+
99+
@flags;
100+
}
101+
102+
sub options { shift->query_form(@_) }
103+
104+
sub canonical {
105+
my $self = shift;
106+
my $other = $self->SUPER::canonical;
107+
108+
# Clean up the flags
109+
my $path = $other->path;
110+
$path =~ s|^/||;
111+
my ($entity, @flags) = split /,/, $path;
112+
113+
my @clean =
114+
map { $_ eq 'isnick' ? 'isuser' : $_ } # convert isnick->isuser
115+
map { lc }
116+
# NOTE: Allow flags from draft-mirashi-url-irc-01 as well
117+
grep { /^(?:is(?:user|channel|server|network|nick)|need(?:pass|key))$/i }
118+
@flags
119+
;
120+
121+
# Only allow the first type of each category, per the Butcher draft
122+
my ($enttype) = grep { /^is(?:user|channel)$/ } @clean;
123+
my ($hosttype) = grep { /^is(?:server|network)$/ } @clean;
124+
my @others = grep { /^need(?:pass|key)$/ } @clean;
125+
126+
my @new = (
127+
$enttype ? $enttype : (),
128+
$hosttype ? $hosttype : (),
129+
@others,
130+
);
131+
132+
unless (join(',', @new) eq join(',', @flags)) {
133+
$other = $other->clone if $other == $self;
134+
$other->path( '/'.join(',', $entity, @new) );
135+
}
136+
137+
$other;
138+
}
139+
140+
1;

‎lib/URI/ircs.pm

Lines changed: 10 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,10 @@
1+
package URI::ircs;
2+
3+
require URI::irc;
4+
@ISA=qw(URI::irc);
5+
6+
sub default_port { 994 }
7+
8+
sub secure { 1 }
9+
10+
1;

‎t/irc.t

Lines changed: 43 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,43 @@
1+
use strict;
2+
use warnings;
3+
4+
use Test::More tests => 12;
5+
6+
use URI ();
7+
my $uri;
8+
9+
$uri = URI->new("irc://PerlUser\@irc.perl.org:6669/#libwww-perl,ischannel,isnetwork?key=bazqux");
10+
11+
is($uri, "irc://PerlUser\@irc.perl.org:6669/#libwww-perl,ischannel,isnetwork?key=bazqux");
12+
13+
is($uri->port, 6669);
14+
15+
# add a password
16+
$uri->password('foobar');
17+
is($uri->userinfo, "PerlUser:foobar");
18+
19+
my @opts = $uri->options;
20+
is_deeply(\@opts, [qw< key bazqux >]);
21+
22+
$uri->options(foo => "bar", bar => "baz");
23+
is($uri->query, "foo=bar&bar=baz");
24+
25+
is($uri->host, "irc.perl.org");
26+
27+
is($uri->path, "/#libwww-perl,ischannel,isnetwork");
28+
29+
# add a bunch of flags to clean up
30+
$uri->path("/SineSwiper,isnick,isnetwork,isserver,needpass,needkey");
31+
$uri = $uri->canonical;
32+
33+
is($uri->path, "/SineSwiper,isuser,isnetwork,needpass,needkey");
34+
35+
# ports and secure-ness
36+
is($uri->secure, 0);
37+
38+
$uri->port(undef);
39+
is($uri->port, 6667);
40+
41+
$uri->scheme("ircs");
42+
is($uri->port, 994);
43+
is($uri->secure, 1);

0 commit comments

Comments
 (0)