vcs.maemo.org Git - pkg-perl/blob - deb-src/liburi-perl/liburi-perl-1.35.dfsg.1/URI/pop.pm

   1 package URI::pop;   # RFC 2384
   2
   3 require URI::_server;
   4 @ISA=qw(URI::_server);
   5
   6 use strict;
   7 use URI::Escape qw(uri_unescape);
   8
   9 sub default_port { 110 }
  10
  11 #pop://<user>;auth=<auth>@<host>:<port>
  12
  13 sub user
  14 {
  15     my $self = shift;
  16     my $old = $self->userinfo;
  17
  18     if (@_) {
  19         my $new_info = $old;
  20         $new_info = "" unless defined $new_info;
  21         $new_info =~ s/^[^;]*//;
  22
  23         my $new = shift;
  24         if (!defined($new) && !length($new_info)) {
  25             $self->userinfo(undef);
  26         } else {
  27             $new = "" unless defined $new;
  28             $new =~ s/%/%25/g;
  29             $new =~ s/;/%3B/g;
  30             $self->userinfo("$new$new_info");
  31         }
  32     }
  33
  34     return unless defined $old;
  35     $old =~ s/;.*//;
  36     return uri_unescape($old);
  37 }
  38
  39 sub auth
  40 {
  41     my $self = shift;
  42     my $old = $self->userinfo;
  43
  44     if (@_) {
  45         my $new = $old;
  46         $new = "" unless defined $new;
  47         $new =~ s/(^[^;]*)//;
  48         my $user = $1;
  49         $new =~ s/;auth=[^;]*//i;
  50
  51
  52         my $auth = shift;
  53         if (defined $auth) {
  54             $auth =~ s/%/%25/g;
  55             $auth =~ s/;/%3B/g;
  56             $new = ";AUTH=$auth$new";
  57         }
  58         $self->userinfo("$user$new");
  59
  60     }
  61
  62     return unless defined $old;
  63     $old =~ s/^[^;]*//;
  64     return uri_unescape($1) if $old =~ /;auth=(.*)/i;
  65     return;
  66 }
  67
  68 1;