lib/PublicInbox/URIimap.pm

   1 # Copyright (C) 2020 all contributors <meta@public-inbox.org>
   2 # License: AGPL-3.0+ <https://www.gnu.org/licenses/agpl-3.0.txt>
   3 # cf. RFC 5092, which the `URI' package doesn't support
   4 #
   5 # This depends only on the documented public API of the `URI' dist,
   6 # not on internal `_'-prefixed subclasses such as `URI::_server'
   7 #
   8 # <https://metacpan.org/pod/URI::imap> exists, but it's not in
   9 # common distros.
  10 #
  11 # RFC 2192 also describes ";TYPE=<list_type>"
  12 package PublicInbox::URIimap;
  13 use strict;
  14 use URI::Split qw(uri_split uri_join); # part of URI
  15 use URI::Escape qw(uri_unescape);
  16
  17 my %default_ports = (imap => 143, imaps => 993);
  18
  19 sub new {
  20         my ($class, $url) = @_;
  21         $url =~ m!\Aimaps?://! ? bless \$url, $class : undef;
  22 }
  23
  24 sub canonical {
  25         my ($self) = @_;
  26
  27         # no #frag in RFC 5092 from what I can tell
  28         my ($scheme, $auth, $path, $query, $_frag) = uri_split($$self);
  29         $path =~ s!\A/+!/!; # excessive leading slash
  30
  31         # lowercase the host portion
  32         $auth =~ s#\A(.*@)?(.*?)(?::([0-9]+))?\z#
  33                 my $ret = ($1//'').lc($2);
  34                 if (defined(my $port = $3)) {
  35                         if ($default_ports{lc($scheme)} != $port) {
  36                                 $ret .= ":$port";
  37                         }
  38                 }
  39                 $ret#ei;
  40
  41         ref($self)->new(uri_join(lc($scheme), $auth, $path, $query));
  42 }
  43
  44 sub host {
  45         my ($self) = @_;
  46         my (undef, $auth) = uri_split($$self);
  47         $auth =~ s!\A.*?@!!;
  48         $auth =~ s!:[0-9]+\z!!;
  49         $auth =~ s!\A\[(.*)\]\z!$1!; # IPv6
  50         uri_unescape($auth);
  51 }
  52
  53 # unescaped, may be used for globbing
  54 sub path {
  55         my ($self) = @_;
  56         my (undef, undef, $path) = uri_split($$self);
  57         $path =~ s!\A/+!!;
  58         $path =~ s/;.*\z//; # ;UIDVALIDITY=nz-number
  59         $path eq '' ? undef : $path;
  60 }
  61
  62 sub mailbox {
  63         my ($self) = @_;
  64         my $path = path($self);
  65         defined($path) ? uri_unescape($path) : undef;
  66 }
  67
  68 # TODO: UIDVALIDITY, search, and other params
  69
  70 sub port {
  71         my ($self) = @_;
  72         my ($scheme, $auth) = uri_split($$self);
  73         $auth =~ /:([0-9]+)\z/ ? $1 + 0 : $default_ports{lc($scheme)};
  74 }
  75
  76 sub authority {
  77         my ($self) = @_;
  78         my (undef, $auth) = uri_split($$self);
  79         $auth
  80 }
  81
  82 sub user {
  83         my ($self) = @_;
  84         my (undef, $auth) = uri_split($$self);
  85         $auth =~ s/@.*\z// or return undef; # drop host:port
  86         $auth =~ s/;.*\z//; # drop ;AUTH=...
  87         $auth =~ s/:.*\z//; # drop password
  88         uri_unescape($auth);
  89 }
  90
  91 sub password {
  92         my ($self) = @_;
  93         my (undef, $auth) = uri_split($$self);
  94         $auth =~ s/@.*\z// or return undef; # drop host:port
  95         $auth =~ s/;.*\z//; # drop ;AUTH=...
  96         $auth =~ s/\A[^:]+:// ? uri_unescape($auth) : undef; # drop ->user
  97 }
  98
  99 sub auth {
 100         my ($self) = @_;
 101         my (undef, $auth) = uri_split($$self);
 102         $auth =~ s/@.*\z//; # drop host:port
 103         $auth =~ /;AUTH=(.+)\z/i ? uri_unescape($1) : undef;
 104 }
 105
 106 sub scheme {
 107         my ($self) = @_;
 108         (uri_split($$self))[0];
 109 }
 110
 111 sub as_string { ${$_[0]} }
 112
 113 1;