← Back to branch summary

~ubuntu-branches/ubuntu/edgy/libwww-perl/edgy

« back to all changes in this revision

Viewing changes to lib/HTTP/Headers/Util.pm

  • Committer: Bazaar Package Importer
  • Author(s): Jay Bonci
  • Date: 2005-02-13 18:45:32 UTC
  • mfrom: (2.1.2 hoary)
  • Revision ID: james.westby@ubuntu.com-20050213184532-67qvopi4wre3010u
Tags: 5.803-4
http://bugs.debian.org/294597
http://bugs.debian.org/294595
* Make GET/POST/HEAD symlinks (Closes: #294597)
* lwp-requests now honors -b when dumping links (Closes: #294595)
  - Thanks to giuseppe bonacci for the patch
* Moved symlinks to a libwww-perl.links file

Show diffs side-by-side

added added

removed removed

Lines of Context:
lib/HTTP/Headers/Util.pm
3
3
use strict;
4
4
use vars qw($VERSION @ISA @EXPORT_OK);
5
5
 
6
 
$VERSION = sprintf("%d.%02d", q$Revision: 1.9 $ =~ /(\d+)\.(\d+)/);
 
6
$VERSION = sprintf("%d.%02d", q$Revision: 1.13 $ =~ /(\d+)\.(\d+)/);
7
7
 
8
8
require Exporter;
9
9
@ISA=qw(Exporter);
10
10
 
11
11
@EXPORT_OK=qw(split_header_words join_header_words);
12
12
 
 
13
 
 
14
 
 
15
sub split_header_words
 
16
{
 
17
    my(@val) = @_;
 
18
    my @res;
 
19
    for (@val) {
 
20
        my @cur;
 
21
        while (length) {
 
22
            if (s/^\s*(=*[^\s=;,]+)//) {  # 'token' or parameter 'attribute'
 
23
                push(@cur, $1);
 
24
                # a quoted value
 
25
                if (s/^\s*=\s*\"([^\"\\]*(?:\\.[^\"\\]*)*)\"//) {
 
26
                    my $val = $1;
 
27
                    $val =~ s/\\(.)/$1/g;
 
28
                    push(@cur, $val);
 
29
                # some unquoted value
 
30
                }
 
31
                elsif (s/^\s*=\s*([^;,\s]*)//) {
 
32
                    my $val = $1;
 
33
                    $val =~ s/\s+$//;
 
34
                    push(@cur, $val);
 
35
                # no value, a lone token
 
36
                }
 
37
                else {
 
38
                    push(@cur, undef);
 
39
                }
 
40
            }
 
41
            elsif (s/^\s*,//) {
 
42
                push(@res, [@cur]) if @cur;
 
43
                @cur = ();
 
44
            }
 
45
            elsif (s/^\s*;// || s/^\s+//) {
 
46
                # continue
 
47
            }
 
48
            else {
 
49
                die "This should not happen: '$_'";
 
50
            }
 
51
        }
 
52
        push(@res, \@cur) if @cur;
 
53
    }
 
54
    @res;
 
55
}
 
56
 
 
57
 
 
58
sub join_header_words
 
59
{
 
60
    @_ = ([@_]) if @_ && !ref($_[0]);
 
61
    my @res;
 
62
    for (@_) {
 
63
        my @cur = @$_;
 
64
        my @attr;
 
65
        while (@cur) {
 
66
            my $k = shift @cur;
 
67
            my $v = shift @cur;
 
68
            if (defined $v) {
 
69
                if ($v =~ /[\x00-\x20()<>@,;:\\\"\/\[\]?={}\x7F-\xFF]/ || !length($v)) {
 
70
                    $v =~ s/([\"\\])/\\$1/g;  # escape " and \
 
71
                    $k .= qq(="$v");
 
72
                }
 
73
                else {
 
74
                    # token
 
75
                    $k .= "=$v";
 
76
                }
 
77
            }
 
78
            push(@attr, $k);
 
79
        }
 
80
        push(@res, join("; ", @attr)) if @attr;
 
81
    }
 
82
    join(", ", @res);
 
83
}
 
84
 
 
85
 
 
86
1;
 
87
 
 
88
__END__
 
89
 
13
90
=head1 NAME
14
91
 
15
92
HTTP::Headers::Util - Header value parsing utility functions
70
147
 
71
148
This is easier to describe with some examples:
72
149
 
73
 
   split_header_words('foo="bar"; port="80,81"; discard, bar=baz')
74
 
   split_header_words('text/html; charset="iso-8859-1");
75
 
   split_header_words('Basic realm="\"foo\\bar\""');
 
150
   split_header_words('foo="bar"; port="80,81"; discard, bar=baz');
 
151
   split_header_words('text/html; charset="iso-8859-1"');
 
152
   split_header_words('Basic realm="\\"foo\\\\bar\\""');
76
153
 
77
154
will return
78
155
 
79
156
   [foo=>'bar', port=>'80,81', discard=> undef], [bar=>'baz' ]
80
157
   ['text/html' => undef, charset => 'iso-8859-1']
81
 
   [Basic => undef, realm => '"foo\bar"']
82
 
 
83
 
=cut
84
 
 
85
 
 
86
 
sub split_header_words
87
 
{
88
 
    my(@val) = @_;
89
 
    my @res;
90
 
    for (@val) {
91
 
        my @cur;
92
 
        while (length) {
93
 
            if (s/^\s*(=*[^\s=;,]+)//) {  # 'token' or parameter 'attribute'
94
 
                push(@cur, $1);
95
 
                # a quoted value
96
 
                if (s/^\s*=\s*\"([^\"\\]*(?:\\.[^\"\\]*)*)\"//) {
97
 
                    my $val = $1;
98
 
                    $val =~ s/\\(.)/$1/g;
99
 
                    push(@cur, $val);
100
 
                # some unquoted value
101
 
                } elsif (s/^\s*=\s*([^;,\s]*)//) {
102
 
                    my $val = $1;
103
 
                    $val =~ s/\s+$//;
104
 
                    push(@cur, $val);
105
 
                # no value, a lone token
106
 
                } else {
107
 
                    push(@cur, undef);
108
 
                }
109
 
            } elsif (s/^\s*,//) {
110
 
                push(@res, [@cur]) if @cur;
111
 
                @cur = ();
112
 
            } elsif (s/^\s*;// || s/^\s+//) {
113
 
                # continue
114
 
            } else {
115
 
                die "This should not happen: '$_'";
116
 
            }
117
 
        }
118
 
        push(@res, \@cur) if @cur;
119
 
    }
120
 
    @res;
121
 
}
122
 
 
 
158
   [Basic => undef, realm => "\"foo\\bar\""]
123
159
 
124
160
=item join_header_words( @arrays )
125
161
 
137
173
 
138
174
   text/plain; charset="iso-8859/1"
139
175
 
140
 
=cut
141
 
 
142
 
sub join_header_words
143
 
{
144
 
    @_ = ([@_]) if @_ && !ref($_[0]);
145
 
    my @res;
146
 
    for (@_) {
147
 
        my @cur = @$_;
148
 
        my @attr;
149
 
        while (@cur) {
150
 
            my $k = shift @cur;
151
 
            my $v = shift @cur;
152
 
            if (defined $v) {
153
 
                if ($v =~ /^\w+$/) {
154
 
                    $k .= "=$v";
155
 
                } else {
156
 
                    $v =~ s/([\"\\])/\\$1/g;  # escape " and \
157
 
                    $k .= qq(="$v");
158
 
                }
159
 
            }
160
 
            push(@attr, $k);
161
 
        }
162
 
        push(@res, join("; ", @attr)) if @attr;
163
 
    }
164
 
    join(", ", @res);
165
 
}
166
 
 
167
 
1;
168
 
 
169
 
__END__
170
 
 
171
176
=back
172
177
 
173
178
=head1 COPYRIGHT
177
182
This library is free software; you can redistribute it and/or
178
183
modify it under the same terms as Perl itself.
179
184
 
180
 
=cut