Add scp, ftps, ftpes, irc, ircs schemes

dist.ini

@@ -90,9 +90,13 @@ skip = URI::_idna
 skip = URI::_login
 skip = URI::_ldap
 skip = URI::file::QNX
+skip = URI::ftpes
+skip = URI::ftps
+skip = URI::irc
 skip = URI::nntp
 skip = URI::urn::isbn
 skip = URI::urn::oid
+skip = URI::scp
 skip = URI::sftp
 trustme = URI => qr/^(?:STORABLE_freeze|STORABLE_thaw|TO_JSON|implementor)$/
 trustme = URI::Escape => qr/^(?:escape_char)$/
@@ -110,7 +114,7 @@ trustme = URI::file::Mac => qr/^(?:dir|file)$/
 trustme = URI::file::OS2 => qr/^(?:file)$/
 trustme = URI::file::Unix => qr/^(?:file)$/
 trustme = URI::file::Win32 => qr/^(?:file|fix_path)$/
-trustme = URI::ftp => qr/^(?:password|user)$/
+trustme = URI::ftp => qr/^(?:password|user|encrypt_mode)$/
 trustme = URI::gopher => qr/^(?:gopher_type|gtype|search|selector|string)$/
 trustme = URI::ldapi => qr/^(?:un_path)$/
 trustme = URI::mailto => qr/^(?:headers|to)$/

lib/URI.pm

@@ -970,6 +970,9 @@ C<URI> objects belonging to the ftp scheme support the common,
 generic and server methods. In addition, they provide two methods for
 accessing the userinfo sub-components: $uri->user and $uri->password.
 
+It also supports accessing to the encryption mode ($uri->encrypt_mode),
+which has its own defaults for I<ftps> and I<ftpes> URI schemes.
+
 =item B<gopher>:
 
 The I<gopher> URI scheme is specified in
@@ -1020,6 +1023,15 @@ The scheme is used to reference ICAP servers through SSL
 connections. Its syntax is the same as icap, including the same
 default port.
 
+=item B<irc>:
+
+The I<irc> URI scheme is specified in L<draft-butcher-irc-url-04|https://datatracker.ietf.org/doc/html/draft-butcher-irc-url-04>.
+The scheme is used to reference IRC servers and their resources.
+
+C<URI> objects belonging to the irc or ircs scheme support login
+methods, and the following IRC-specific ones: $uri->entity,
+$uri->flags, $uri->options.
+
 =item B<ldap>:
 
 The I<ldap> URI scheme is specified in RFC 2255. LDAP is the

lib/URI/ftp.pm

@@ -9,6 +9,8 @@ use parent qw(URI::_server URI::_userpass);
 
 sub default_port { 21 }
 
+sub encrypt_mode { undef }
+
 sub path { shift->path_query(@_) } # XXX
 
 sub _user { shift->SUPER::user(@_); }

lib/URI/ftpes.pm

@@ -0,0 +1,14 @@
+package URI::ftpes;
+
+use strict;
+use warnings;
+
+our $VERSION = '5.29';
+
+use parent 'URI::ftp';
+
+sub secure { 1 }
+
+sub encrypt_mode { 'explicit' }
+
+1;

lib/URI/ftps.pm

@@ -0,0 +1,16 @@
+package URI::ftps;
+
+use strict;
+use warnings;
+
+our $VERSION = '5.29';
+
+use parent 'URI::ftp';
+
+sub default_port { 990 }
+
+sub secure { 1 }
+
+sub encrypt_mode { 'implicit' }
+
+1;

lib/URI/irc.pm

@@ -0,0 +1,142 @@
+package URI::irc; # draft-butcher-irc-url-04
+
+use strict;
+use warnings;
+
+our $VERSION = '5.29';
+
+use parent 'URI::_login';
+
+use overload (
+ '""' => sub { $_[0]->as_string },
+ '==' => sub { URI::_obj_eq(@_) },
+ '!=' => sub { !URI::_obj_eq(@_) },
+ fallback => 1,
+);
+
+sub default_port { 6667 }
+
+# ircURL = ircURI "://" location "/" [ entity ] [ flags ] [ options ]
+# ircURI = "irc" / "ircs"
+# location = [ authinfo "@" ] hostport
+# authinfo = [ username ] [ ":" password ]
+# username = *( escaped / unreserved )
+# password = *( escaped / unreserved ) [ ";" passtype ]
+# passtype = *( escaped / unreserved )
+# entity = [ "#" ] *( escaped / unreserved )
+# flags = ( [ "," enttype ] [ "," hosttype ] )
+# /= ( [ "," hosttype ] [ "," enttype ] )
+# enttype = "," ( "isuser" / "ischannel" )
+# hosttype = "," ( "isserver" / "isnetwork" )
+# options = "?" option *( "&" option )
+# option = optname [ "=" optvalue ]
+# optname = *( ALPHA / "-" )
+# optvalue = optparam *( "," optparam )
+# optparam = *( escaped / unreserved )
+
+# XXX: Technically, passtype is part of the protocol, but is rarely used and
+# not defined in the RFC beyond the URL ABNF.
+
+# Starting the entity with /# is okay per spec, but it needs to be encoded to
+# %23 for the URL::_generic::path operations to parse correctly.
+sub _init {
+ my $class = shift;
+ my $self = $class->SUPER::_init(@_);
+ $$self =~ s|^((?:[^:/?\#]+:)?(?://[^/?\#]*)?)/\#|$1/%23|s;
+ $self;
+}
+
+# Return the /# form, since this is most common for channel names.
+sub path {
+ my $self = shift;
+ my ($new) = @_;
+ $new =~ s|^/\#|/%23| if (@_ && defined $new);
+ my $val = $self->SUPER::path(@_ ? $new : ());
+ $val =~ s|^/%23|/\#|;
+ $val;
+}
+sub path_query {
+ my $self = shift;
+ my ($new) = @_;
+ $new =~ s|^/\#|/%23| if (@_ && defined $new);
+ my $val = $self->SUPER::path_query(@_ ? $new : ());
+ $val =~ s|^/%23|/\#|;
+ $val;
+}
+sub as_string {
+ my $self = shift;
+ my $val = $self->SUPER::as_string;
+ $val =~ s|^((?:[^:/?\#]+:)?(?://[^/?\#]*)?)/%23|$1/\#|s;
+ $val;
+}
+
+sub entity {
+ my $self = shift;
+
+ my $path = $self->path;
+ $path =~ s|^/||;
+ my ($entity, @flags) = split /,/, $path;
+
+ if (@_) {
+ my $new = shift;
+ $new = '' unless defined $new;
+ $self->path( '/'.join(',', $new, @flags) );
+ }
+
+ return unless length $entity;
+ $entity;
+}
+
+sub flags {
+ my $self = shift;
+
+ my $path = $self->path;
+ $path =~ s|^/||;
+ my ($entity, @flags) = split /,/, $path;
+
+ if (@_) {
+ $self->path( '/'.join(',', $entity, @_) );
+ }
+
+ @flags;
+}
+
+sub options { shift->query_form(@_) }
+
+sub canonical {
+ my $self = shift;
+ my $other = $self->SUPER::canonical;
+
+ # Clean up the flags
+ my $path = $other->path;
+ $path =~ s|^/||;
+ my ($entity, @flags) = split /,/, $path;
+
+ my @clean =
+ map { $_ eq 'isnick' ? 'isuser' : $_ } # convert isnick->isuser
+ map { lc }
+ # NOTE: Allow flags from draft-mirashi-url-irc-01 as well
+ grep { /^(?:is(?:user|channel|server|network|nick)|need(?:pass|key))$/i }
+ @flags
+ ;
+
+ # Only allow the first type of each category, per the Butcher draft
+ my ($enttype) = grep { /^is(?:user|channel)$/ } @clean;
+ my ($hosttype) = grep { /^is(?:server|network)$/ } @clean;
+ my @others = grep { /^need(?:pass|key)$/ } @clean;
+
+ my @new = (
+ $enttype ? $enttype : (),
+ $hosttype ? $hosttype : (),
+ @others,
+ );
+
+ unless (join(',', @new) eq join(',', @flags)) {
+ $other = $other->clone if $other == $self;
+ $other->path( '/'.join(',', $entity, @new) );
+ }
+
+ $other;
+}
+
+1;

lib/URI/ircs.pm

@@ -0,0 +1,14 @@
+package URI::ircs;
+
+use strict;
+use warnings;
+
+our $VERSION = '5.29';
+
+use parent 'URI::irc';
+
+sub default_port { 994 }
+
+sub secure { 1 }
+
+1;

lib/URI/scp.pm

@@ -0,0 +1,10 @@
+package URI::scp;
+
+use strict;
+use warnings;
+
+our $VERSION = '5.29';
+
+use parent 'URI::ssh';
+
+1;

t/ftp.t

@@ -1,7 +1,7 @@
 use strict;
 use warnings;
 
-use Test::More tests => 13;
+use Test::More tests => 23;
 
 use URI ();
 my $uri;
@@ -14,6 +14,10 @@ is($uri->host, "ftp.example.com");
 
 is($uri->port, 21);
 
+is($uri->secure, 0);
+
+is($uri->encrypt_mode, undef);
+
 is($uri->user, "anonymous");
 
 is($uri->password, 'anonymous@');
@@ -31,10 +35,31 @@ $uri->password("secret");
 is($uri, "ftp://gisle%40aas.no:secret\@ftp.example.com/path");
 
 $uri = URI->new("ftp://gisle\@aas.no:secret\@ftp.example.com/path");
+
 is($uri, "ftp://gisle\@aas.no:secret\@ftp.example.com/path");
 
 is($uri->userinfo, "gisle\@aas.no:secret");
 
 is($uri->user, "gisle\@aas.no");
 
 is($uri->password, "secret");
+
+$uri = URI->new("ftps://ftp.example.com/path");
+
+is($uri->scheme, "ftps");
+
+is($uri->port, 990);
+
+is($uri->secure, 1);
+
+is($uri->encrypt_mode, 'implicit');
+
+$uri = URI->new("ftpes://ftp.example.com/path");
+
+is($uri->scheme, "ftpes");
+
+is($uri->port, 21);
+
+is($uri->secure, 1);
+
+is($uri->encrypt_mode, 'explicit');

t/irc.t

@@ -0,0 +1,43 @@
+use strict;
+use warnings;
+
+use Test::More tests => 12;
+
+use URI ();
+my $uri;
+
+$uri = URI->new("irc://PerlUser\@irc.perl.org:6669/#libwww-perl,ischannel,isnetwork?key=bazqux");
+
+is($uri, "irc://PerlUser\@irc.perl.org:6669/#libwww-perl,ischannel,isnetwork?key=bazqux");
+
+is($uri->port, 6669);
+
+# add a password
+$uri->password('foobar');
+is($uri->userinfo, "PerlUser:foobar");
+
+my @opts = $uri->options;
+is_deeply(\@opts, [qw< key bazqux >]);
+
+$uri->options(foo => "bar", bar => "baz");
+is($uri->query, "foo=bar&bar=baz");
+
+is($uri->host, "irc.perl.org");
+
+is($uri->path, "/#libwww-perl,ischannel,isnetwork");
+
+# add a bunch of flags to clean up
+$uri->path("/SineSwiper,isnick,isnetwork,isserver,needpass,needkey");
+$uri = $uri->canonical;
+
+is($uri->path, "/SineSwiper,isuser,isnetwork,needpass,needkey");
+
+# ports and secure-ness
+is($uri->secure, 0);
+
+$uri->port(undef);
+is($uri->port, 6667);
+
+$uri->scheme("ircs");
+is($uri->port, 994);
+is($uri->secure, 1);