Add smtp scheme

dist.ini

@@ -86,6 +86,7 @@ xt_mode = 1
 
 [Test::Pod::Coverage::Configurable]
 skip = URI::IRI
+skip = URI::_emailauth
 skip = URI::_foreign
 skip = URI::_idna
 skip = URI::_login
@@ -120,7 +121,6 @@ trustme = URI::gopher => qr/^(?:gopher_type|gtype|search|selector|string)$/
 trustme = URI::ldapi => qr/^(?:un_path)$/
 trustme = URI::mailto => qr/^(?:headers|to)$/
 trustme = URI::news => qr/^(?:group|message)$/
-trustme = URI::pop => qr/^(?:auth|user)$/
 trustme = URI::sip => qr/^(?:params|params_form)$/
 trustme = URI::urn => qr/^(?:nid|nss)$/
 
@@ -129,6 +129,7 @@ wordlist = Pod::Wordlist
 spell_cmd = aspell list
 stopword = Berners
 stopword = CRS
+stopword = earhart
 stopword = etype
 stopword = evalue
 stopword = IDNA

lib/URI.pm

@@ -28,7 +28,7 @@ our $schemes_without_host_part_re = 'data|ldapi|urn|sqlite|sqlite3';
 
 # These schemes can have an IPv6+ authority part:
 #     file, ftp, gopher, http, https, ldap, ldaps, mms, news, nntp, nntps, pop, rlogin, rtsp, rtspu, rsync, sip, sips, snews,
-#     telnet, tn3270, ssh, sftp
+#     smtp, telnet, tn3270, ssh, sftp
 #     (all DB URIs, i.e. cassandra, couch, couchdb, etc.), except 'sqlite:', 'sqlite3:'. Others?
 #MAINT: URI has no test coverage for DB schemes
 #MAINT: decoupling - perhaps let each class decide itself by defining a member function 'scheme_has_authority_part()'?
@@ -976,7 +976,7 @@ which has its own defaults for I<ftps> and I<ftpes> URI schemes.
 =item B<gopher>:
 
 The I<gopher> URI scheme is specified in
-<draft-murali-url-gopher-1996-12-04> and will hopefully be available
+C<draft-murali-url-gopher-1996-12-04> and will hopefully be available
 as a RFC 2396 based specification.
 
 C<URI> objects belonging to the gopher scheme support the common,
@@ -1112,8 +1112,8 @@ The I<pop> URI scheme is specified in RFC 2384. The scheme is used to
 reference a POP3 mailbox.
 
 C<URI> objects belonging to the pop scheme support the common, generic
-and server methods.  In addition, they provide two methods to access the
-userinfo components: $uri->user and $uri->auth
+and server methods, as well as two email authorization methods:
+C<user> and C<auth>.
 
 =item B<rlogin>:
 
@@ -1160,6 +1160,15 @@ generic and server methods. In addition, they provide methods to
 access the userinfo sub-components ($uri->user and $uri->password)
 as well as $uri->authdomain and $uri->sharename methods.
 
+=item B<smtp>:
+
+The I<smtp> URI scheme is specified in L<draft-earhart-url-smtp-00|https://datatracker.ietf.org/doc/html/draft-earhart-url-smtp-00>.
+The scheme is used to reference a SMTP server.
+
+C<URI> objects belonging to the smtp scheme support the common, generic
+and server methods, as well as two email authorization methods:
+C<user> and C<auth>.
+
 =item B<snews>:
 
 See I<news> scheme.  Its syntax is the same as news, but the default

lib/URI/_emailauth.pm

@@ -0,0 +1,70 @@
+package URI::_emailauth;
+
+use strict;
+use warnings;
+
+our $VERSION = '5.33';
+
+use parent 'URI::_server';
+
+use URI::Escape qw(uri_unescape);
+
+# Common user/auth code used in email URL schemes, such as POP, SMTP, IMAP.
+# <scheme>://<user>;auth=<auth>@<host>:<port>
+
+sub user
+{
+    my $self = shift;
+    my $old = $self->userinfo;
+
+    if (@_) {
+	my $new_info = $old;
+	$new_info = "" unless defined $new_info;
+	$new_info =~ s/^[^;]*//;
+
+	my $new = shift;
+	if (!defined($new) && !length($new_info)) {
+	    $self->userinfo(undef);
+	} else {
+	    $new = "" unless defined $new;
+	    $new =~ s/%/%25/g;
+	    $new =~ s/;/%3B/g;
+	    $self->userinfo("$new$new_info");
+	}
+    }
+
+    return undef unless defined $old;
+    $old =~ s/;.*//;
+    return uri_unescape($old);
+}
+
+sub auth
+{
+    my $self = shift;
+    my $old = $self->userinfo;
+
+    if (@_) {
+	my $new = $old;
+	$new = "" unless defined $new;
+	$new =~ s/(^[^;]*)//;
+	my $user = $1;
+	$new =~ s/;auth=[^;]*//i;
+
+
+	my $auth = shift;
+	if (defined $auth) {
+	    $auth =~ s/%/%25/g;
+	    $auth =~ s/;/%3B/g;
+	    $new = ";AUTH=$auth$new";
+	}
+	$self->userinfo("$user$new");
+
+    }
+
+    return undef unless defined $old;
+    $old =~ s/^[^;]*//;
+    return uri_unescape($1) if $old =~ /;auth=(.*)/i;
+    return;
+}
+
+1;

lib/URI/pop.pm

@@ -5,67 +5,12 @@ use warnings;
 
 our $VERSION = '5.33';
 
-use parent 'URI::_server';
+use parent 'URI::_emailauth';
 
 use URI::Escape qw(uri_unescape);
 
 sub default_port { 110 }
 
 #pop://<user>;auth=<auth>@<host>:<port>
 
-sub user
-{
-    my $self = shift;
-    my $old = $self->userinfo;
-
-    if (@_) {
-	my $new_info = $old;
-	$new_info = "" unless defined $new_info;
-	$new_info =~ s/^[^;]*//;
-
-	my $new = shift;
-	if (!defined($new) && !length($new_info)) {
-	    $self->userinfo(undef);
-	} else {
-	    $new = "" unless defined $new;
-	    $new =~ s/%/%25/g;
-	    $new =~ s/;/%3B/g;
-	    $self->userinfo("$new$new_info");
-	}
-    }
-
-    return undef unless defined $old;
-    $old =~ s/;.*//;
-    return uri_unescape($old);
-}
-
-sub auth
-{
-    my $self = shift;
-    my $old = $self->userinfo;
-
-    if (@_) {
-	my $new = $old;
-	$new = "" unless defined $new;
-	$new =~ s/(^[^;]*)//;
-	my $user = $1;
-	$new =~ s/;auth=[^;]*//i;
-
-
-	my $auth = shift;
-	if (defined $auth) {
-	    $auth =~ s/%/%25/g;
-	    $auth =~ s/;/%3B/g;
-	    $new = ";AUTH=$auth$new";
-	}
-	$self->userinfo("$user$new");
-
-    }
-
-    return undef unless defined $old;
-    $old =~ s/^[^;]*//;
-    return uri_unescape($1) if $old =~ /;auth=(.*)/i;
-    return;
-}
-
 1;

lib/URI/smtp.pm

@@ -0,0 +1,16 @@
+package URI::smtp;   # draft-earhart-url-smtp-00
+
+use strict;
+use warnings;
+
+our $VERSION = '5.33';
+
+use parent 'URI::_emailauth';
+
+use URI::Escape qw(uri_unescape);
+
+sub default_port { 25 }
+
+#smtp://<user>;auth=<auth>@<host>:<port>
+
+1;

t/smtp.t

@@ -0,0 +1,42 @@
+use strict;
+use warnings;
+
+use Test::More tests => 8;
+
+use URI ();
+
+my $u = URI->new('smtp://[email protected]');
+
+ok($u->user eq "foobar" &&
+   !defined($u->auth) &&
+   $u->host eq "smtp.example.com" &&
+   $u->port == 25 &&
+   $u eq 'smtp://[email protected]');
+
+$u->auth("+XOAUTH2");
+ok($u->auth eq "+XOAUTH2" &&
+   $u eq 'smtp://foobar;[email protected]');
+
+$u->user("bizz");
+ok($u->user eq "bizz" &&
+   $u eq 'smtp://bizz;[email protected]');
+
+$u->port(4000);
+is($u, 'smtp://bizz;[email protected]:4000');
+
+$u = URI->new("smtp:");
+$u->host("smtp.example.com");
+$u->user("foobar");
+$u->auth("*");
+is($u, 'smtp://foobar;AUTH=*@smtp.example.com');
+
+$u->auth(undef);
+is($u, 'smtp://[email protected]');
+
+$u->user(undef);
+is($u, 'smtp://smtp.example.com');
+
+# Try some funny characters too
+$u->user('sn☃wm@n');
+ok($u->user eq 'sn☃wm@n' &&
+   $u eq 'smtp://sn%E2%98%83wm%[email protected]');