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

   1 package URI::mailto;  # RFC 2368
   2
   3 require URI;
   4 require URI::_query;
   5 @ISA=qw(URI URI::_query);
   6
   7 use strict;
   8
   9 sub to
  10 {
  11     my $self = shift;
  12     my @old = $self->headers;
  13     if (@_) {
  14         my @new = @old;
  15         # get rid of any other to: fields
  16         for (my $i = 0; $i < @new; $i += 2) {
  17             if (lc($new[$i]) eq "to") {
  18                 splice(@new, $i, 2);
  19                 redo;
  20             }
  21         }
  22
  23         my $to = shift;
  24         $to = "" unless defined $to;
  25         unshift(@new, "to" => $to);
  26         $self->headers(@new);
  27     }
  28     return unless defined wantarray;
  29
  30     my @to;
  31     while (@old) {
  32         my $h = shift @old;
  33         my $v = shift @old;
  34         push(@to, $v) if lc($h) eq "to";
  35     }
  36     join(",", @to);
  37 }
  38
  39
  40 sub headers
  41 {
  42     my $self = shift;
  43
  44     # The trick is to just treat everything as the query string...
  45     my $opaque = "to=" . $self->opaque;
  46     $opaque =~ s/\?/&/;
  47
  48     if (@_) {
  49         my @new = @_;
  50
  51         # strip out any "to" fields
  52         my @to;
  53         for (my $i=0; $i < @new; $i += 2) {
  54             if (lc($new[$i]) eq "to") {
  55                 push(@to, (splice(@new, $i, 2))[1]);  # remove header
  56                 redo;
  57             }
  58         }
  59
  60         my $new = join(",",@to);
  61         $new =~ s/%/%25/g;
  62         $new =~ s/\?/%3F/g;
  63         $self->opaque($new);
  64         $self->query_form(@new) if @new;
  65     }
  66     return unless defined wantarray;
  67
  68     # I am lazy today...
  69     URI->new("mailto:?$opaque")->query_form;
  70 }
  71
  72 1;