diff --git a/dist.ini b/dist.ini index 89ce8bc..c572bd5 100644 --- a/dist.ini +++ b/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 diff --git a/lib/URI.pm b/lib/URI.pm index 0c76701..2bcd682 100644 --- a/lib/URI.pm +++ b/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 and I URI schemes. =item B: The I URI scheme is specified in - and will hopefully be available +C and will hopefully be available as a RFC 2396 based specification. C objects belonging to the gopher scheme support the common, @@ -1112,8 +1112,8 @@ The I URI scheme is specified in RFC 2384. The scheme is used to reference a POP3 mailbox. C 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 and C. =item B: @@ -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: + +The I URI scheme is specified in L. +The scheme is used to reference a SMTP server. + +C objects belonging to the smtp scheme support the common, generic +and server methods, as well as two email authorization methods: +C and C. + =item B: See I scheme. Its syntax is the same as news, but the default diff --git a/lib/URI/_emailauth.pm b/lib/URI/_emailauth.pm new file mode 100644 index 0000000..cec153d --- /dev/null +++ b/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. +# ://;auth=@: + +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; diff --git a/lib/URI/pop.pm b/lib/URI/pop.pm index 5a448b3..fa8fc8c 100644 --- a/lib/URI/pop.pm +++ b/lib/URI/pop.pm @@ -5,7 +5,7 @@ use warnings; our $VERSION = '5.33'; -use parent 'URI::_server'; +use parent 'URI::_emailauth'; use URI::Escape qw(uri_unescape); @@ -13,59 +13,4 @@ sub default_port { 110 } #pop://;auth=@: -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; diff --git a/lib/URI/smtp.pm b/lib/URI/smtp.pm new file mode 100644 index 0000000..8509354 --- /dev/null +++ b/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://;auth=@: + +1; diff --git a/t/smtp.t b/t/smtp.t new file mode 100644 index 0000000..879c1de --- /dev/null +++ b/t/smtp.t @@ -0,0 +1,42 @@ +use strict; +use warnings; + +use Test::More tests => 8; + +use URI (); + +my $u = URI->new('smtp://foobar@smtp.example.com'); + +ok($u->user eq "foobar" && + !defined($u->auth) && + $u->host eq "smtp.example.com" && + $u->port == 25 && + $u eq 'smtp://foobar@smtp.example.com'); + +$u->auth("+XOAUTH2"); +ok($u->auth eq "+XOAUTH2" && + $u eq 'smtp://foobar;AUTH=+XOAUTH2@smtp.example.com'); + +$u->user("bizz"); +ok($u->user eq "bizz" && + $u eq 'smtp://bizz;AUTH=+XOAUTH2@smtp.example.com'); + +$u->port(4000); +is($u, 'smtp://bizz;AUTH=+XOAUTH2@smtp.example.com: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://foobar@smtp.example.com'); + +$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%40n@smtp.example.com');