Last change
on this file since 31689 was 27174, checked in by davidb, 11 years ago |
Perl modules from CPAN that are used in supporting activate.pl, but not part of the Perl core. Only PMs included.
|
File size:
1.2 KB
|
Line | |
---|
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;
|
---|
Note:
See
TracBrowser
for help on using the repository browser.