lib/PublicInbox/URIimap.pm

   1 # Copyright (C) 2020-2021 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 appears
   9 # unmaintained, isn't in common distros, nor does it support
  10 # ';FOO=BAR' parameters such as UIDVALIDITY
  11 #
  12 # RFC 2192 also describes ";TYPE=<list_type>"
  13 package PublicInbox::URIimap;
  14 use strict;
  15 use URI::Split qw(uri_split uri_join); # part of URI
  16 use URI::Escape qw(uri_unescape);
  17 use overload '""' => \&as_string;
  18
  19 my %default_ports = (imap => 143, imaps => 993);
  20
  21 sub new {
  22         my ($class, $url) = @_;
  23         $url =~ m!\Aimaps?://! ? bless \$url, $class : undef;
  24 }
  25
  26 sub canonical {
  27         my ($self) = @_;
  28
  29         # no #frag in RFC 5092 from what I can tell
  30         my ($scheme, $auth, $path, $query, $_frag) = uri_split($$self);
  31         $path =~ s!\A/+!/!; # excessive leading slash
  32
  33         # upper-case uidvalidity= and uid= parameter names
  34         $path =~ s/;([^=]+)=([^;]*)/;\U$1\E=$2/g;
  35
  36         # lowercase the host portion
  37         $auth =~ s#\A(.*@)?(.*?)(?::([0-9]+))?\z#
  38                 my $ret = ($1//'').lc($2);
  39                 if (defined(my $port = $3)) {
  40                         if ($default_ports{lc($scheme)} != $port) {
  41                                 $ret .= ":$port";
  42                         }
  43                 }
  44                 $ret#ei;
  45
  46         ref($self)->new(uri_join(lc($scheme), $auth, $path, $query));
  47 }
  48
  49 sub host {
  50         my ($self) = @_;
  51         my (undef, $auth) = uri_split($$self);
  52         $auth =~ s!\A.*?@!!;
  53         $auth =~ s!:[0-9]+\z!!;
  54         $auth =~ s!\A\[(.*)\]\z!$1!; # IPv6
  55         uri_unescape($auth);
  56 }
  57
  58 # unescaped, may be used for globbing
  59 sub path {
  60         my ($self) = @_;
  61         my (undef, undef, $path) = uri_split($$self);
  62         $path =~ s!\A/+!!;
  63         $path =~ s![/;].*\z!!; # [;UIDVALIDITY=nz-number]/;UID=nz-number
  64         $path eq '' ? undef : $path;
  65 }
  66
  67 sub mailbox {
  68         my ($self) = @_;
  69         my $path = path($self);
  70         defined($path) ? uri_unescape($path) : undef;
  71 }
  72
  73 sub uidvalidity { # read/write
  74         my ($self, $val) = @_;
  75         my ($scheme, $auth, $path, $query, $frag) = uri_split($$self);
  76         if (defined $val) {
  77                 if ($path =~ s!;UIDVALIDITY=[^;/]*\b!;UIDVALIDITY=$val!i or
  78                                 $path =~ s!/;!;UIDVALIDITY=$val/;!i) {
  79                         # s// already changed it
  80                 } else { # both s// failed, so just append
  81                         $path .= ";UIDVALIDITY=$val";
  82                 }
  83                 $$self = uri_join($scheme, $auth, $path, $query, $frag);
  84         }
  85         $path =~ s!\A/+!!;
  86         $path =~ m!\A[^;/]+;UIDVALIDITY=([1-9][0-9]*)\b!i ? ($1 + 0) : undef;
  87 }
  88
  89 sub iuid {
  90         my ($self, $val) = @_;
  91         my ($scheme, $auth, $path, $query, $frag) = uri_split($$self);
  92         if (defined $val) {
  93                 if ($path =~ s!/;UID=[^;/]*\b!/;UID=$val!i) {
  94                         # s// already changed it
  95                 } else { # both s// failed, so just append
  96                         $path .= ";UID=$val";
  97                 }
  98                 $$self = uri_join($scheme, $auth, $path, $query);
  99         }
 100         $path =~ m!\A/[^/;]+(?:;UIDVALIDITY=[^;/]+)?/;UID=([1-9][0-9]*)\b!i ?
 101                 ($1 + 0) : undef;
 102 }
 103
 104 sub port {
 105         my ($self) = @_;
 106         my ($scheme, $auth) = uri_split($$self);
 107         $auth =~ /:([0-9]+)\z/ ? $1 + 0 : $default_ports{lc($scheme)};
 108 }
 109
 110 sub authority {
 111         my ($self) = @_;
 112         my (undef, $auth) = uri_split($$self);
 113         $auth
 114 }
 115
 116 sub user {
 117         my ($self) = @_;
 118         my (undef, $auth) = uri_split($$self);
 119         $auth =~ s/@.*\z// or return undef; # drop host:port
 120         $auth =~ s/;.*\z//; # drop ;AUTH=...
 121         $auth =~ s/:.*\z//; # drop password
 122         uri_unescape($auth);
 123 }
 124
 125 sub password {
 126         my ($self) = @_;
 127         my (undef, $auth) = uri_split($$self);
 128         $auth =~ s/@.*\z// or return undef; # drop host:port
 129         $auth =~ s/;.*\z//; # drop ;AUTH=...
 130         $auth =~ s/\A[^:]+:// ? uri_unescape($auth) : undef; # drop ->user
 131 }
 132
 133 sub auth {
 134         my ($self) = @_;
 135         my (undef, $auth) = uri_split($$self);
 136         $auth =~ s/@.*\z//; # drop host:port
 137         $auth =~ /;AUTH=(.+)\z/i ? uri_unescape($1) : undef;
 138 }
 139
 140 sub scheme {
 141         my ($self) = @_;
 142         (uri_split($$self))[0];
 143 }
 144
 145 sub as_string { ${$_[0]} }
 146
 147 1;