1 |
wakaba |
1.1 |
|
2 |
|
|
=head1 NAME
|
3 |
|
|
|
4 |
wakaba |
1.14 |
Message::Field::Structured --- A Perl Module for Internet
|
5 |
|
|
Message Structured Header Field Bodies
|
6 |
wakaba |
1.1 |
|
7 |
|
|
=cut
|
8 |
|
|
|
9 |
|
|
package Message::Field::Structured;
|
10 |
|
|
use strict;
|
11 |
wakaba |
1.11 |
use vars qw(%DEFAULT $VERSION);
|
12 |
wakaba |
1.18 |
$VERSION=do{my @r=(q$Revision: 1.17 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
|
13 |
wakaba |
1.3 |
require Message::Util;
|
14 |
wakaba |
1.5 |
use overload '""' => sub { $_[0]->stringify },
|
15 |
|
|
'.=' => sub { $_[0]->value_append ($_[1]) },
|
16 |
wakaba |
1.14 |
#'eq' => sub { $_[0]->{field_body} eq $_[1] },
|
17 |
|
|
#'ne' => sub { $_[0]->{field_body} ne $_[1] },
|
18 |
wakaba |
1.5 |
fallback => 1;
|
19 |
wakaba |
1.1 |
|
20 |
wakaba |
1.5 |
=head1 CONSTRUCTORS
|
21 |
wakaba |
1.1 |
|
22 |
wakaba |
1.5 |
The following methods construct new C<Message::Field::Structured> objects:
|
23 |
wakaba |
1.1 |
|
24 |
wakaba |
1.5 |
=over 4
|
25 |
wakaba |
1.1 |
|
26 |
wakaba |
1.5 |
=cut
|
27 |
wakaba |
1.1 |
|
28 |
wakaba |
1.5 |
## Initialize of this class -- called by constructors
|
29 |
wakaba |
1.11 |
%DEFAULT = (
|
30 |
wakaba |
1.9 |
_ARRAY_NAME => '',
|
31 |
wakaba |
1.11 |
_ARRAY_VALTYPE => '*default',
|
32 |
wakaba |
1.9 |
_HASH_NAME => '',
|
33 |
wakaba |
1.14 |
_METHODS => [qw|as_plain_string value_append|],
|
34 |
wakaba |
1.11 |
_MEMBERS => [qw|field_body|],
|
35 |
wakaba |
1.14 |
_VALTYPE_DEFAULT => '*default',
|
36 |
wakaba |
1.10 |
by => 'index', ## (Reserved for method level option)
|
37 |
wakaba |
1.9 |
dont_croak => 0, ## Don't die unless very very fatal error
|
38 |
|
|
encoding_after_encode => '*default',
|
39 |
|
|
encoding_before_decode => '*default',
|
40 |
|
|
field_param_name => '',
|
41 |
|
|
field_name => 'x-structured',
|
42 |
wakaba |
1.14 |
#field_ns => '',
|
43 |
wakaba |
1.9 |
format => 'mail-rfc2822',
|
44 |
wakaba |
1.16 |
## MIME charset name of '*default' charset
|
45 |
|
|
header_default_charset => 'iso-2022-int-1',
|
46 |
|
|
header_default_charset_input => 'iso-2022-int-1',
|
47 |
wakaba |
1.9 |
hook_encode_string => #sub {shift; (value => shift, @_)},
|
48 |
|
|
\&Message::Util::encode_header_string,
|
49 |
|
|
hook_decode_string => #sub {shift; (value => shift, @_)},
|
50 |
|
|
\&Message::Util::decode_header_string,
|
51 |
|
|
#name ## Reserved for method level option
|
52 |
|
|
#parse ## Reserved for method level option
|
53 |
|
|
parse_all => 0,
|
54 |
|
|
prepend => 0, ## (Reserved for method level option)
|
55 |
|
|
value_type => {'*default' => [':none:']},
|
56 |
wakaba |
1.11 |
);
|
57 |
|
|
sub _init ($;%) {
|
58 |
|
|
my $self = shift;
|
59 |
|
|
my %options = @_;
|
60 |
|
|
$self->{option} = Message::Util::make_clone (\%DEFAULT);
|
61 |
wakaba |
1.5 |
$self->{field_body} = '';
|
62 |
|
|
|
63 |
|
|
for my $name (keys %options) {
|
64 |
|
|
if (substr ($name, 0, 1) eq '-') {
|
65 |
|
|
$self->{option}->{substr ($name, 1)} = $options{$name};
|
66 |
|
|
} elsif (lc $name eq 'body') {
|
67 |
|
|
$self->{field_body} = $options{$name};
|
68 |
|
|
}
|
69 |
|
|
}
|
70 |
wakaba |
1.13 |
$self->{comment} = [];
|
71 |
wakaba |
1.5 |
}
|
72 |
wakaba |
1.3 |
|
73 |
wakaba |
1.5 |
=item Message::Field::Structured->new ([%options])
|
74 |
wakaba |
1.1 |
|
75 |
wakaba |
1.5 |
Constructs a new C<Message::Field::Structured> object. You might pass some
|
76 |
|
|
options as parameters to the constructor.
|
77 |
wakaba |
1.1 |
|
78 |
|
|
=cut
|
79 |
|
|
|
80 |
wakaba |
1.2 |
sub new ($;%) {
|
81 |
wakaba |
1.3 |
my $class = shift;
|
82 |
wakaba |
1.5 |
my $self = bless {}, $class;
|
83 |
|
|
$self->_init (@_);
|
84 |
wakaba |
1.3 |
$self;
|
85 |
wakaba |
1.1 |
}
|
86 |
|
|
|
87 |
wakaba |
1.5 |
=item Message::Field::Structured->parse ($field-body, [%options])
|
88 |
wakaba |
1.1 |
|
89 |
wakaba |
1.5 |
Constructs a new C<Message::Field::Structured> object with
|
90 |
|
|
given field body. You might pass some options as parameters to the constructor.
|
91 |
wakaba |
1.1 |
|
92 |
|
|
=cut
|
93 |
|
|
|
94 |
wakaba |
1.2 |
sub parse ($$;%) {
|
95 |
wakaba |
1.3 |
my $class = shift;
|
96 |
wakaba |
1.5 |
my $self = bless {}, $class;
|
97 |
|
|
$self->_init (@_);
|
98 |
|
|
#my $field_body = $self->Message::Util::decode_qcontent (shift);
|
99 |
|
|
$self->{field_body} = shift; #$field_body;
|
100 |
wakaba |
1.1 |
$self;
|
101 |
|
|
}
|
102 |
|
|
|
103 |
wakaba |
1.5 |
=back
|
104 |
|
|
|
105 |
wakaba |
1.9 |
=cut
|
106 |
|
|
|
107 |
|
|
## Template procedures for array/hash fields
|
108 |
|
|
## (As bare Message::Field::Structured module,
|
109 |
|
|
## these shall not be used.)
|
110 |
|
|
|
111 |
|
|
sub add ($$$%) {
|
112 |
|
|
my $self = shift;
|
113 |
|
|
|
114 |
|
|
my $array = $self->{option}->{_ARRAY_NAME};
|
115 |
|
|
if ($array) {
|
116 |
|
|
|
117 |
|
|
## --- field is non-named value list (i.e. not hash)
|
118 |
|
|
|
119 |
|
|
## Options
|
120 |
|
|
my %option = %{$self->{option}};
|
121 |
|
|
if (ref $_[0] eq 'HASH') {
|
122 |
|
|
my $option = shift (@_);
|
123 |
|
|
for (keys %$option) {my $n = $_; $n =~ s/^-//; $option{$n} = $$option{$_}}
|
124 |
|
|
}
|
125 |
wakaba |
1.11 |
$option{parse} = 1 if defined wantarray && !defined $option{parse};
|
126 |
|
|
$option{parse} = 1 if $option{parse_all} && !defined $option{parse};
|
127 |
wakaba |
1.9 |
|
128 |
|
|
## Additional items
|
129 |
|
|
my $avalue;
|
130 |
|
|
for (@_) {
|
131 |
wakaba |
1.11 |
local $option{parse} = $option{parse};
|
132 |
wakaba |
1.14 |
my $ok;
|
133 |
|
|
($ok, undef, $avalue) = $self->_add_array_check ($_, \%option);
|
134 |
wakaba |
1.9 |
if ($ok) {
|
135 |
wakaba |
1.11 |
$avalue = $self->_parse_value
|
136 |
|
|
($option{_ARRAY_VALTYPE} => $avalue) if $option{parse};
|
137 |
wakaba |
1.9 |
if ($option{prepend}) {
|
138 |
|
|
unshift @{$self->{$array}}, $avalue;
|
139 |
|
|
} else {
|
140 |
|
|
push @{$self->{$array}}, $avalue;
|
141 |
|
|
}
|
142 |
|
|
}
|
143 |
|
|
}
|
144 |
wakaba |
1.14 |
$self->_add_return_value (\$avalue, \%option);
|
145 |
|
|
## Return last added value if necessary.
|
146 |
wakaba |
1.9 |
|
147 |
|
|
} else {
|
148 |
|
|
$array = $self->{option}->{_HASH_NAME};
|
149 |
|
|
|
150 |
|
|
## --- field is not list
|
151 |
|
|
|
152 |
|
|
unless ($array) {
|
153 |
|
|
my %option = @_;
|
154 |
|
|
return if $option{-dont_croak};
|
155 |
|
|
Carp::croak q{add: Method not available for this module};
|
156 |
|
|
}
|
157 |
|
|
|
158 |
|
|
## --- field is named value list (i.e. hash)
|
159 |
|
|
|
160 |
|
|
## Options
|
161 |
|
|
my %p = @_; my %option = %{$self->{option}};
|
162 |
|
|
for (grep {/^-/} keys %p) {$option{substr ($_, 1)} = $p{$_}}
|
163 |
|
|
$option{parse} = 1 if defined wantarray && !defined $option{parse};
|
164 |
wakaba |
1.11 |
$option{parse} = 1 if $option{parse_all} && !defined $option{parse};
|
165 |
wakaba |
1.9 |
|
166 |
|
|
## Additional items
|
167 |
|
|
my $avalue;
|
168 |
|
|
while (my ($name => $value) = splice (@_, 0, 2)) {
|
169 |
|
|
next if $name =~ /^-/; $name =~ s/^\\//;
|
170 |
wakaba |
1.14 |
$name =~ tr/_/-/ if $option{translate_underscore};
|
171 |
wakaba |
1.9 |
|
172 |
|
|
my $ok;
|
173 |
wakaba |
1.11 |
local $option{parse} = $option{parse};
|
174 |
wakaba |
1.10 |
($ok, $name, $avalue) = $self->_add_hash_check ($name => $value, \%option);
|
175 |
wakaba |
1.9 |
if ($ok) {
|
176 |
wakaba |
1.10 |
$avalue = $self->_parse_value ($name => $avalue) if $option{parse};
|
177 |
wakaba |
1.9 |
if ($option{prepend}) {
|
178 |
|
|
unshift @{$self->{$array}}, $avalue;
|
179 |
|
|
} else {
|
180 |
|
|
push @{$self->{$array}}, $avalue;
|
181 |
|
|
}
|
182 |
|
|
}
|
183 |
|
|
}
|
184 |
wakaba |
1.14 |
$self->_add_return_value (\$avalue, \%option);
|
185 |
|
|
## Return last added value if necessary.
|
186 |
wakaba |
1.9 |
}
|
187 |
|
|
}
|
188 |
|
|
|
189 |
|
|
sub _add_array_check ($$\%) {
|
190 |
|
|
shift; 1, $_[0] => $_[0];
|
191 |
|
|
}
|
192 |
|
|
sub _add_hash_check ($$$\%) {
|
193 |
|
|
shift; 1, $_[0] => [@_[0,1]];
|
194 |
|
|
}
|
195 |
wakaba |
1.14 |
## Returns returned item value \$item-value, \%option
|
196 |
|
|
sub _add_return_value ($\$\%) {
|
197 |
|
|
$_[1];
|
198 |
|
|
}
|
199 |
wakaba |
1.9 |
|
200 |
|
|
sub replace ($$$%) {
|
201 |
|
|
my $self = shift;
|
202 |
|
|
|
203 |
|
|
$self->_replace_cleaning;
|
204 |
|
|
my $array = $self->{option}->{_ARRAY_NAME};
|
205 |
|
|
if ($array) {
|
206 |
|
|
|
207 |
|
|
## --- field is non-named value list (i.e. not hash)
|
208 |
|
|
|
209 |
|
|
## Options
|
210 |
|
|
my %option = %{$self->{option}};
|
211 |
|
|
if (ref $_[0] eq 'HASH') {
|
212 |
|
|
my $option = shift (@_);
|
213 |
|
|
for (keys %$option) {my $n = $_; $n =~ s/^-//; $option{$n} = $$option{$_}}
|
214 |
|
|
}
|
215 |
wakaba |
1.11 |
$option{parse} = 1 if defined wantarray && !defined $option{parse};
|
216 |
|
|
$option{parse} = 1 if $option{parse_all} && !defined $option{parse};
|
217 |
wakaba |
1.9 |
|
218 |
|
|
## Additional items
|
219 |
|
|
my ($avalue, %replace);
|
220 |
|
|
for (@_) {
|
221 |
wakaba |
1.11 |
local $option{parse} = $option{parse};
|
222 |
wakaba |
1.9 |
my ($ok, $aname);
|
223 |
|
|
($ok, $aname => $avalue)
|
224 |
|
|
= $self->_replace_array_check ($_, \%option);
|
225 |
|
|
if ($ok) {
|
226 |
wakaba |
1.11 |
$avalue = $self->_parse_value
|
227 |
|
|
($option{_ARRAY_VALTYPE} => $avalue) if $option{parse};
|
228 |
wakaba |
1.9 |
$replace{$aname} = $avalue;
|
229 |
|
|
}
|
230 |
|
|
}
|
231 |
|
|
for (@{$self->{$array}}) {
|
232 |
|
|
my ($v) = $self->_replace_array_shift (\%replace => $_, \%option);
|
233 |
|
|
if (defined $v) {
|
234 |
|
|
$_ = $v;
|
235 |
|
|
}
|
236 |
|
|
}
|
237 |
|
|
for (keys %replace) {
|
238 |
|
|
if ($option{prepend}) {
|
239 |
|
|
unshift @{$self->{$array}}, $replace{$_};
|
240 |
|
|
} else {
|
241 |
|
|
push @{$self->{$array}}, $replace{$_};
|
242 |
|
|
}
|
243 |
|
|
}
|
244 |
wakaba |
1.14 |
$self->_replace_return_value (\$avalue, \%option);
|
245 |
|
|
## Return last added value if necessary.
|
246 |
wakaba |
1.9 |
|
247 |
|
|
} else {
|
248 |
|
|
$array = $self->{option}->{_HASH_NAME};
|
249 |
|
|
|
250 |
|
|
## --- field is not list
|
251 |
|
|
|
252 |
|
|
unless ($array) {
|
253 |
|
|
my %option = @_;
|
254 |
|
|
return if $option{-dont_croak};
|
255 |
|
|
Carp::croak q{replace: Method not available for this module};
|
256 |
|
|
}
|
257 |
|
|
|
258 |
|
|
## --- field is named value list (i.e. hash)
|
259 |
|
|
|
260 |
|
|
## Options
|
261 |
|
|
my %p = @_; my %option = %{$self->{option}};
|
262 |
|
|
for (grep {/^-/} keys %p) {$option{substr ($_, 1)} = $p{$_}}
|
263 |
|
|
$option{parse} = 1 if defined wantarray && !defined $option{parse};
|
264 |
wakaba |
1.11 |
$option{parse} = 1 if $option{parse_all} && !defined $option{parse};
|
265 |
wakaba |
1.9 |
|
266 |
|
|
## Additional items
|
267 |
|
|
my ($avalue, %replace);
|
268 |
|
|
while (my ($name => $value) = splice (@_, 0, 2)) {
|
269 |
|
|
next if $name =~ /^-/; $name =~ s/^\\//;
|
270 |
wakaba |
1.14 |
$name =~ tr/_/-/ if $option{translate_underscore};
|
271 |
wakaba |
1.9 |
|
272 |
|
|
my ($ok, $aname);
|
273 |
wakaba |
1.11 |
local $option{parse} = $option{parse};
|
274 |
wakaba |
1.9 |
($ok, $aname => $avalue)
|
275 |
|
|
= $self->_replace_hash_check ($name => $value, \%option);
|
276 |
|
|
if ($ok) {
|
277 |
wakaba |
1.11 |
$avalue = $self->_parse_value ($name => $avalue) if $option{parse};
|
278 |
wakaba |
1.9 |
$replace{$aname} = $avalue;
|
279 |
|
|
}
|
280 |
|
|
}
|
281 |
|
|
for (@{$self->{$array}}) {
|
282 |
wakaba |
1.14 |
last unless keys %replace;
|
283 |
wakaba |
1.9 |
my ($v) = $self->_replace_hash_shift (\%replace => $_, \%option);
|
284 |
|
|
if (defined $v) {
|
285 |
|
|
$_ = $v;
|
286 |
|
|
}
|
287 |
|
|
}
|
288 |
|
|
for (keys %replace) {
|
289 |
|
|
if ($option{prepend}) {
|
290 |
|
|
unshift @{$self->{$array}}, $replace{$_};
|
291 |
|
|
} else {
|
292 |
|
|
push @{$self->{$array}}, $replace{$_};
|
293 |
|
|
}
|
294 |
|
|
}
|
295 |
wakaba |
1.14 |
$self->_replace_return_value (\$avalue, \%option);
|
296 |
|
|
## Return last added value if necessary.
|
297 |
wakaba |
1.9 |
}
|
298 |
|
|
}
|
299 |
|
|
|
300 |
wakaba |
1.17 |
## $self->_replace_cleaning
|
301 |
|
|
## -- Cleans the array/hash before replacing
|
302 |
wakaba |
1.9 |
sub _replace_cleaning ($) {
|
303 |
wakaba |
1.10 |
$_[0]->_delete_empty;
|
304 |
wakaba |
1.9 |
}
|
305 |
wakaba |
1.17 |
#*_replace_cleaning = \&_delete_empty;
|
306 |
|
|
## Be not aliasing for inheriting class
|
307 |
|
|
|
308 |
|
|
## (1/0, $name => $value) = $self->_replace_array_check ($value, \%option)
|
309 |
|
|
## -- Checks given value and prepares saving value (array version)
|
310 |
|
|
## Note that $name of return value is used as key for _replace_array_shift.
|
311 |
|
|
## Usually, it is same as $value.
|
312 |
|
|
## Note: In many case, same code as _add_array_check can be used.
|
313 |
wakaba |
1.9 |
sub _replace_array_check ($$\%) {
|
314 |
|
|
shift; 1, $_[0] => $_[0];
|
315 |
|
|
}
|
316 |
wakaba |
1.17 |
|
317 |
|
|
## $value = $self->_replace_array_shift (\%values, $name, $option)
|
318 |
|
|
## -- Returns a value (from %values, with key of $name) and deletes
|
319 |
|
|
## it from %values (like CORE::shift for array) (array version)
|
320 |
wakaba |
1.9 |
sub _replace_array_shift ($\%$\%) {
|
321 |
|
|
shift; my $r = shift; my $n = $_[0]->[0];
|
322 |
|
|
if ($$r{$n}) {
|
323 |
|
|
my $d = $$r{$n};
|
324 |
|
|
$$r{$n} = undef;
|
325 |
|
|
return $d;
|
326 |
|
|
}
|
327 |
|
|
undef;
|
328 |
|
|
}
|
329 |
wakaba |
1.17 |
|
330 |
|
|
## (1/0, $name => $value) = $self->_replace_hash_check ($name => $value, \%option)
|
331 |
|
|
## -- Checks given value and prepares saving value (hash version)
|
332 |
|
|
## Note: In many case, same code as _add_hash_check can be used.
|
333 |
wakaba |
1.9 |
sub _replace_hash_check ($$$\%) {
|
334 |
|
|
shift; 1, $_[0] => [@_[0,1]];
|
335 |
|
|
}
|
336 |
wakaba |
1.17 |
|
337 |
|
|
## $value = $self->_replace_hash_shift (\%values, $name, $option)
|
338 |
|
|
## -- Returns a value (from %values, with key of $name) and
|
339 |
|
|
## deletes it from %values (like CORE::shift for array) (hash version)
|
340 |
wakaba |
1.9 |
sub _replace_hash_shift ($\%$\%) {
|
341 |
|
|
shift; my $r = shift; my $n = $_[0]->[0];
|
342 |
|
|
if ($$r{$n}) {
|
343 |
|
|
my $d = $$r{$n};
|
344 |
|
|
$$r{$n} = undef;
|
345 |
|
|
return $d;
|
346 |
|
|
}
|
347 |
|
|
undef;
|
348 |
|
|
}
|
349 |
wakaba |
1.17 |
|
350 |
|
|
## $value = $self->_replace_return_value (\$item, \%option)
|
351 |
|
|
## -- Returns returning value of replace method
|
352 |
|
|
## Note: Usually this can share code with _item_return_value.
|
353 |
wakaba |
1.14 |
sub _replace_return_value ($\$\%) {
|
354 |
|
|
$_[1];
|
355 |
|
|
}
|
356 |
wakaba |
1.9 |
|
357 |
wakaba |
1.17 |
## TODO: Implement count by any and merge with item_exist
|
358 |
wakaba |
1.9 |
sub count ($;%) {
|
359 |
|
|
my $self = shift; my %option = @_;
|
360 |
|
|
my $array = $self->{option}->{_ARRAY_NAME}
|
361 |
|
|
|| $self->{option}->{_HASH_NAME};
|
362 |
|
|
unless ($array) {
|
363 |
|
|
return if $option{-dont_croak};
|
364 |
|
|
Carp::croak q{count: Method not available for this module};
|
365 |
|
|
}
|
366 |
|
|
$self->_count_cleaning;
|
367 |
|
|
return $self->_count_by_name ($array => \%option) if defined $option{-name};
|
368 |
|
|
$#{$self->{$array}} + 1;
|
369 |
|
|
}
|
370 |
wakaba |
1.17 |
|
371 |
|
|
## $self->_count_cleaning
|
372 |
|
|
## -- Cleans the array/hash before counting
|
373 |
wakaba |
1.9 |
sub _count_cleaning ($) {
|
374 |
wakaba |
1.10 |
$_[0]->_delete_empty;
|
375 |
wakaba |
1.9 |
}
|
376 |
wakaba |
1.17 |
|
377 |
wakaba |
1.9 |
sub _count_by_name ($$\%) {
|
378 |
|
|
# my $self = shift;
|
379 |
|
|
# my ($array, $option) = @_;
|
380 |
|
|
# my $name = $self->_n11n_*name* ($$option{-name});
|
381 |
|
|
# my @a = grep {$_->[0] eq $name} @{$self->{$array}};
|
382 |
|
|
# $#a + 1;
|
383 |
|
|
}
|
384 |
|
|
|
385 |
wakaba |
1.10 |
sub delete ($@) {
|
386 |
|
|
my $self = shift;
|
387 |
|
|
my %p; %p = %{shift (@_)} if ref $_[0] eq 'HASH';
|
388 |
|
|
my %option = %{$self->{option}};
|
389 |
|
|
for (grep {/^-/} keys %p) {$option{substr ($_, 1)} = $p{$_}}
|
390 |
|
|
my $array = $option{_ARRAY_NAME} || $option{_HASH_NAME};
|
391 |
|
|
unless ($array) {
|
392 |
|
|
return if $option{dont_croak};
|
393 |
|
|
Carp::croak q{delete: Method not available for this module};
|
394 |
|
|
}
|
395 |
|
|
if ($option{by} && $option{by} ne 'index') {
|
396 |
|
|
my %name; for (@_) {$name{$_} = 1}
|
397 |
|
|
for (@{$self->{$array}}) {
|
398 |
|
|
if ($self->_delete_match ($option{by}, \$_, \%name, \%option)) {
|
399 |
|
|
$_ = undef;
|
400 |
|
|
}
|
401 |
|
|
}
|
402 |
|
|
} else { ## by index
|
403 |
|
|
for (@_) {
|
404 |
|
|
$self->{$array}->[$_] = undef;
|
405 |
|
|
}
|
406 |
|
|
}
|
407 |
|
|
$self->_delete_cleaning;
|
408 |
|
|
}
|
409 |
|
|
|
410 |
wakaba |
1.17 |
## 1/0 = $self->_delete_match ($by, \$item, \%delete_list, \%option)
|
411 |
|
|
## -- Checks and returns whether given item is matched with
|
412 |
|
|
## deleting item list
|
413 |
|
|
## Note: Usually this code can be shared with _item_match.
|
414 |
|
|
## Note: $by eq 'index' is already defined in delete method
|
415 |
|
|
## itself, so in this function it need not be checked.
|
416 |
wakaba |
1.10 |
sub _delete_match ($$\$\%\%) {
|
417 |
wakaba |
1.17 |
my $self = shift;
|
418 |
|
|
my ($by, $item, $list, $option) = @_;
|
419 |
|
|
return 0 unless ref $$item; ## Already removed
|
420 |
|
|
## An example definition
|
421 |
|
|
if ($by eq 'name') {
|
422 |
|
|
$$item->{value} = $self->_parse_value ($$item->{type}, $$item->{value});
|
423 |
|
|
return 1 if ref $$item->{value} && $$list{ $$item->{value}->{name} };
|
424 |
|
|
}
|
425 |
|
|
0;
|
426 |
wakaba |
1.10 |
}
|
427 |
|
|
|
428 |
|
|
sub _delete_cleaning ($) {
|
429 |
|
|
$_[0]->_delete_empty;
|
430 |
|
|
}
|
431 |
|
|
|
432 |
wakaba |
1.9 |
## Delete empty items
|
433 |
|
|
sub _delete_empty ($) {
|
434 |
wakaba |
1.11 |
my $self = shift;
|
435 |
|
|
my $array = $self->{option}->{_ARRAY_NAME} || $self->{option}->{_HASH_NAME};
|
436 |
|
|
$self->{$array} = [grep {length $_} @{$self->{$array}}] if $array;
|
437 |
wakaba |
1.9 |
}
|
438 |
|
|
|
439 |
wakaba |
1.10 |
sub item ($$;%) {
|
440 |
|
|
my $self = shift;
|
441 |
wakaba |
1.17 |
my ($name, %p) = (shift, @_);
|
442 |
|
|
## BUG: don't support -by
|
443 |
wakaba |
1.10 |
return $self->replace ($name => $p{-value}, @_) if defined $p{-value};
|
444 |
|
|
my %option = %{$self->{option}};
|
445 |
wakaba |
1.11 |
$option{new_item_unless_exist} = 1;
|
446 |
wakaba |
1.10 |
for (grep {/^-/} keys %p) {$option{substr ($_, 1)} = $p{$_}}
|
447 |
|
|
my $array = $option{_ARRAY_NAME} || $option{_HASH_NAME};
|
448 |
|
|
unless ($array) {
|
449 |
|
|
return if $option{dont_croak};
|
450 |
|
|
Carp::croak q{item: Method not available for this module};
|
451 |
|
|
}
|
452 |
wakaba |
1.18 |
$option{parse} = 1 unless defined $option{parse};
|
453 |
|
|
$option{parse} = 1 if $option{parse_all} && !defined $option{parse};
|
454 |
wakaba |
1.11 |
my @r;
|
455 |
wakaba |
1.10 |
if ($option{by} eq 'index') {
|
456 |
|
|
for ($self->{$array}->[$name]) {
|
457 |
|
|
return $self->_item_return_value (\$_, \%option);
|
458 |
|
|
}
|
459 |
|
|
} else {
|
460 |
|
|
for (@{$self->{$array}}) {
|
461 |
|
|
if ($self->_item_match ($option{by}, \$_, {$name => 1}, \%option)) {
|
462 |
|
|
if (wantarray) {
|
463 |
|
|
push @r, $self->_item_return_value (\$_, \%option);
|
464 |
|
|
} else {
|
465 |
|
|
return $self->_item_return_value (\$_, \%option);
|
466 |
|
|
}
|
467 |
|
|
}
|
468 |
|
|
}
|
469 |
|
|
}
|
470 |
wakaba |
1.11 |
if (@r == 0 && $option{new_item_unless_exist}) {
|
471 |
|
|
my $v = $self->_item_new_value ($name, \%option);
|
472 |
|
|
if (defined $v) {
|
473 |
|
|
if ($option{prepend}) {
|
474 |
|
|
unshift @{$self->{$array}}, $v;
|
475 |
|
|
} else {
|
476 |
|
|
push @{$self->{$array}}, $v;
|
477 |
|
|
}
|
478 |
|
|
return $self->_item_return_value (\$v, \%option);
|
479 |
|
|
}
|
480 |
|
|
}
|
481 |
|
|
return undef unless wantarray;
|
482 |
|
|
@r;
|
483 |
wakaba |
1.10 |
}
|
484 |
|
|
|
485 |
wakaba |
1.14 |
sub item_exist ($$;%) {
|
486 |
|
|
my $self = shift;
|
487 |
|
|
my ($name, %p) = (shift, @_);
|
488 |
|
|
my %option = %{$self->{option}};
|
489 |
|
|
for (grep {/^-/} keys %p) {$option{substr ($_, 1)} = $p{$_}}
|
490 |
|
|
my $array = $option{_ARRAY_NAME} || $option{_HASH_NAME};
|
491 |
|
|
unless ($array) {
|
492 |
|
|
return if $option{dont_croak};
|
493 |
|
|
Carp::croak q{item-exist: Method not available for this module};
|
494 |
|
|
}
|
495 |
|
|
my @r;
|
496 |
|
|
if ($option{by} eq 'index') {
|
497 |
|
|
return 1 if ref $self->{$array}->[$name];
|
498 |
|
|
} else {
|
499 |
|
|
for (@{$self->{$array}}) {
|
500 |
|
|
if ($self->_item_match ($option{by}, \$_, {$name => 1}, \%option)) {
|
501 |
|
|
return 1;
|
502 |
|
|
}
|
503 |
|
|
}
|
504 |
|
|
}
|
505 |
|
|
0;
|
506 |
|
|
}
|
507 |
|
|
|
508 |
wakaba |
1.17 |
## 1/0 = $self->_item_match ($by, \$item, \%delete_list, \%option)
|
509 |
|
|
## -- Checks and returns whether given item is matched with
|
510 |
|
|
## returning item list
|
511 |
|
|
## Note: $by eq 'index' is already defined in delete method
|
512 |
|
|
## itself, so in this function it need not be checked.
|
513 |
wakaba |
1.10 |
sub _item_match ($$\$\%\%) {
|
514 |
wakaba |
1.17 |
my $self = shift;
|
515 |
|
|
my ($by, $item, $list, $option) = @_;
|
516 |
|
|
return 0 unless ref $$item; ## Removed
|
517 |
|
|
## An example definition
|
518 |
|
|
if ($by eq 'name') {
|
519 |
|
|
$$item->{value} = $self->_parse_value ($$item->{type}, $$item->{value});
|
520 |
|
|
return 1 if ref $$item->{value} && $$list{ $$item->{value}->{name} };
|
521 |
|
|
}
|
522 |
|
|
0;
|
523 |
wakaba |
1.10 |
}
|
524 |
|
|
|
525 |
wakaba |
1.17 |
## $value = $self->_item_return_value (\$item, \%option)
|
526 |
|
|
## -- Returns returning value of item method
|
527 |
wakaba |
1.10 |
sub _item_return_value ($\$\%) {
|
528 |
wakaba |
1.11 |
$_[1];
|
529 |
|
|
}
|
530 |
|
|
|
531 |
wakaba |
1.17 |
## $item = $self->_item_new_value ($name, \%option)
|
532 |
|
|
## -- Returns new item with key of $name (called when
|
533 |
|
|
## no returned value is found and -new_value_unless_exist
|
534 |
|
|
## option is true)
|
535 |
|
|
## (Note that the kind of key ('by' option) can be getten
|
536 |
|
|
## from $option->{by})
|
537 |
|
|
## Return undef when new value can't be generated.
|
538 |
wakaba |
1.11 |
sub _item_new_value ($$\%) {
|
539 |
|
|
$_[1];
|
540 |
wakaba |
1.10 |
}
|
541 |
|
|
|
542 |
wakaba |
1.9 |
## $self->_parse_value ($type, $value);
|
543 |
|
|
sub _parse_value ($$$) {
|
544 |
|
|
my $self = shift;
|
545 |
wakaba |
1.14 |
my $name = shift;
|
546 |
wakaba |
1.9 |
my $value = shift;
|
547 |
|
|
return $value if ref $value;
|
548 |
wakaba |
1.14 |
my $handler = $self->{option}->{value_type}->{$name}
|
549 |
|
|
|| $self->{option}->{value_type}->{$self->{option}->{_VALTYPE_DEFAULT}};
|
550 |
|
|
if (ref $handler eq 'CODE') {
|
551 |
|
|
$handler = &$handler ($self);
|
552 |
|
|
}
|
553 |
|
|
my $vtype = $handler->[0];
|
554 |
|
|
my %vopt = (
|
555 |
|
|
-format => $self->{option}->{format},
|
556 |
|
|
-field_ns => $self->{option}->{field_ns},
|
557 |
|
|
-field_name => $self->{option}->{field_name},
|
558 |
|
|
-field_param_name => $name,
|
559 |
|
|
-parse_all => $self->{option}->{parse_all},
|
560 |
|
|
);
|
561 |
|
|
## Media type specified option/parameters
|
562 |
|
|
if (ref $handler->[1] eq 'HASH') {
|
563 |
|
|
for (keys %{$handler->[1]}) {
|
564 |
|
|
$vopt{$_} = ${$handler->[1]}{$_};
|
565 |
|
|
}
|
566 |
|
|
}
|
567 |
|
|
## Inherited options
|
568 |
|
|
if (ref $handler->[2] eq 'ARRAY') {
|
569 |
|
|
for (@{$handler->[2]}) {
|
570 |
|
|
$vopt{'-'.$_} = $self->{option}->{$_};
|
571 |
|
|
}
|
572 |
|
|
}
|
573 |
|
|
|
574 |
wakaba |
1.9 |
if ($vtype eq ':none:') {
|
575 |
|
|
return $value;
|
576 |
|
|
} elsif (defined $value) {
|
577 |
|
|
eval "require $vtype" or Carp::croak qq{<parse>: $vtype: Can't load package: $@};
|
578 |
wakaba |
1.14 |
return $vtype->parse ($value, %vopt);
|
579 |
wakaba |
1.9 |
} else {
|
580 |
|
|
eval "require $vtype" or Carp::croak qq{<parse>: $vtype: Can't load package: $@};
|
581 |
wakaba |
1.14 |
return $vtype->new (%vopt);
|
582 |
wakaba |
1.9 |
}
|
583 |
|
|
}
|
584 |
|
|
|
585 |
wakaba |
1.11 |
## comments
|
586 |
|
|
|
587 |
|
|
|
588 |
|
|
sub comment_add ($@) {
|
589 |
|
|
my $self = shift;
|
590 |
|
|
my $array = 'comment';
|
591 |
|
|
## Options
|
592 |
|
|
my %option = %{$self->{option}};
|
593 |
|
|
if (ref $_[0] eq 'HASH') {
|
594 |
|
|
my $option = shift (@_);
|
595 |
|
|
for (keys %$option) {my $n = $_; $n =~ s/^-//; $option{$n} = $$option{$_}}
|
596 |
|
|
}
|
597 |
|
|
|
598 |
|
|
## Additional items
|
599 |
|
|
if ($option{prepend}) {
|
600 |
|
|
unshift @{$self->{$array}}, reverse @_;
|
601 |
|
|
} else {
|
602 |
|
|
push @{$self->{$array}}, @_;
|
603 |
|
|
}
|
604 |
|
|
}
|
605 |
|
|
|
606 |
|
|
sub comment_count ($) {
|
607 |
|
|
my $self = shift;
|
608 |
|
|
$self->_comment_cleaning;
|
609 |
|
|
$#{$self->{comment}} + 1;
|
610 |
|
|
}
|
611 |
|
|
|
612 |
|
|
sub comment_delete ($@) {
|
613 |
|
|
my $self = shift;
|
614 |
|
|
#my %p; %p = %{shift (@_)} if ref $_[0] eq 'HASH';
|
615 |
|
|
#my %option = %{$self->{option}};
|
616 |
|
|
#for (grep {/^-/} keys %p) {$option{substr ($_, 1)} = $p{$_}}
|
617 |
|
|
for (@_) {
|
618 |
|
|
$self->{comment}->[$_] = undef;
|
619 |
|
|
}
|
620 |
|
|
$self->_comment_cleaning;
|
621 |
|
|
}
|
622 |
|
|
|
623 |
|
|
sub comment_item ($$) {
|
624 |
|
|
$_[0]->{comment}->[$_[1]];
|
625 |
|
|
}
|
626 |
|
|
|
627 |
|
|
sub _comment_cleaning ($) {
|
628 |
|
|
my $self = shift;
|
629 |
|
|
$self->{comment} = [grep {length $_} @{$self->{comment}}];
|
630 |
|
|
}
|
631 |
|
|
|
632 |
|
|
sub _comment_stringify ($\%) {
|
633 |
|
|
my $self = shift;
|
634 |
wakaba |
1.15 |
my $option = shift;
|
635 |
|
|
$option->{_comment_min} ||= 0;
|
636 |
|
|
$option->{_comment_max} = $#{$self->{comment}} unless defined $option->{_comment_max};
|
637 |
wakaba |
1.11 |
my @v;
|
638 |
wakaba |
1.15 |
for (@{$self->{comment}}[$option->{_comment_min}..$option->{_comment_max}]) {
|
639 |
wakaba |
1.11 |
push @v, '('. $self->Message::Util::encode_ccontent ($_) .')';
|
640 |
|
|
}
|
641 |
|
|
join ' ', @v;
|
642 |
|
|
}
|
643 |
|
|
|
644 |
wakaba |
1.14 |
sub scan ($&;%) {
|
645 |
|
|
my $self = shift;
|
646 |
|
|
my $sub = shift;
|
647 |
wakaba |
1.16 |
my %p = @_; my %option;
|
648 |
|
|
if (ref $p{options} eq 'HASH') {
|
649 |
|
|
%option = %{$p{options}};
|
650 |
|
|
} else {
|
651 |
|
|
%option = %{$self->{option}};
|
652 |
|
|
for (grep {/^-/} keys %p) {$option{substr ($_, 1)} = $p{$_}}
|
653 |
|
|
}
|
654 |
|
|
my $array = $option{_ARRAY_NAME} || $option{_HASH_NAME};
|
655 |
|
|
my @param = $self->_scan_sort (\@{$self->{$array}}, \%option);
|
656 |
wakaba |
1.14 |
#my $sort = $option{sort};
|
657 |
|
|
#@param = sort $sort @param if ref $sort;
|
658 |
wakaba |
1.10 |
for my $param (@param) {
|
659 |
wakaba |
1.16 |
&$sub($self, $param, \%option);
|
660 |
wakaba |
1.10 |
}
|
661 |
|
|
}
|
662 |
|
|
|
663 |
wakaba |
1.14 |
sub _scan_sort ($\@) {
|
664 |
|
|
#my $self = shift;
|
665 |
|
|
@{$_[1]};
|
666 |
|
|
}
|
667 |
|
|
|
668 |
wakaba |
1.5 |
=head1 METHODS
|
669 |
|
|
|
670 |
|
|
=over 4
|
671 |
|
|
|
672 |
|
|
=item $self->stringify ([%options])
|
673 |
wakaba |
1.1 |
|
674 |
wakaba |
1.5 |
Returns field body as a string. Returned string is encoded,
|
675 |
|
|
quoted if necessary (by C<hook_encode_string>).
|
676 |
wakaba |
1.1 |
|
677 |
|
|
=cut
|
678 |
|
|
|
679 |
wakaba |
1.7 |
sub stringify ($;%) {
|
680 |
wakaba |
1.1 |
my $self = shift;
|
681 |
wakaba |
1.5 |
#$self->Message::Util::encode_qcontent ($self->{field_body});
|
682 |
|
|
$self->{field_body};
|
683 |
wakaba |
1.1 |
}
|
684 |
wakaba |
1.5 |
*as_string = \&stringify;
|
685 |
wakaba |
1.1 |
|
686 |
wakaba |
1.5 |
=item $self->as_plain_string
|
687 |
wakaba |
1.1 |
|
688 |
wakaba |
1.5 |
Returns field body as a string. Returned string is not encoded
|
689 |
|
|
or quoted, i.e. internal/bare coded string. This string
|
690 |
|
|
may be unable to use as field body content. (Its I<structures>
|
691 |
|
|
such as C<comment> and C<quoted-string> are lost.)
|
692 |
wakaba |
1.1 |
|
693 |
|
|
=cut
|
694 |
|
|
|
695 |
|
|
sub as_plain_string ($) {
|
696 |
|
|
my $self = shift;
|
697 |
wakaba |
1.5 |
my $s = $self->Message::Util::decode_qcontent ($self->{field_body});
|
698 |
|
|
Message::Util::unquote_quoted_string (Message::Util::unquote_ccontent ($s));
|
699 |
wakaba |
1.1 |
}
|
700 |
wakaba |
1.4 |
|
701 |
wakaba |
1.5 |
=item $self->option ( $option-name / $option-name, $option-value, ...)
|
702 |
wakaba |
1.4 |
|
703 |
wakaba |
1.5 |
If @_ == 1, returns option value. Else...
|
704 |
wakaba |
1.4 |
|
705 |
wakaba |
1.5 |
Set option value. You can pass multiple option name-value pair
|
706 |
|
|
as parameter. Example:
|
707 |
wakaba |
1.1 |
|
708 |
wakaba |
1.5 |
$msg->option (format => 'mail-rfc822',
|
709 |
|
|
capitalize => 0);
|
710 |
|
|
print $msg->option ('format'); ## mail-rfc822
|
711 |
wakaba |
1.1 |
|
712 |
|
|
=cut
|
713 |
|
|
|
714 |
wakaba |
1.5 |
sub option ($@) {
|
715 |
wakaba |
1.1 |
my $self = shift;
|
716 |
wakaba |
1.5 |
if (@_ == 1) {
|
717 |
|
|
return $self->{option}->{ $_[0] };
|
718 |
|
|
}
|
719 |
wakaba |
1.14 |
my %option = @_;
|
720 |
wakaba |
1.5 |
while (my ($name, $value) = splice (@_, 0, 2)) {
|
721 |
wakaba |
1.14 |
$self->{option}->{$name} = $value;
|
722 |
|
|
}
|
723 |
|
|
if ($option{-recursive}) {
|
724 |
|
|
$self->_option_recursive (\%option);
|
725 |
wakaba |
1.5 |
}
|
726 |
wakaba |
1.12 |
$self;
|
727 |
wakaba |
1.1 |
}
|
728 |
|
|
|
729 |
wakaba |
1.14 |
## $self->_option_recursive (\%argv)
|
730 |
|
|
sub _option_recursive ($\%) {}
|
731 |
|
|
|
732 |
wakaba |
1.9 |
## TODO: multiple value-type support
|
733 |
|
|
sub value_type ($;$$%) {
|
734 |
|
|
my $self = shift;
|
735 |
wakaba |
1.14 |
my $name = shift || $self->{option}->{_VALTYPE_DEFAULT};
|
736 |
wakaba |
1.9 |
my $new_value_type = shift;
|
737 |
|
|
if ($new_value_type) {
|
738 |
|
|
$self->{option}->{value_type}->{$name} = []
|
739 |
|
|
unless ref $self->{option}->{value_type}->{$name};
|
740 |
|
|
$self->{option}->{value_type}->{$name}->[0] = $new_value_type;
|
741 |
|
|
}
|
742 |
|
|
if (ref $self->{option}->{value_type}->{$name}) {
|
743 |
|
|
$self->{option}->{value_type}->{$name}->[0]
|
744 |
wakaba |
1.14 |
|| $self->{option}->{value_type}->{$self->{option}->{_VALTYPE_DEFAULT}}->[0];
|
745 |
wakaba |
1.9 |
} else {
|
746 |
wakaba |
1.14 |
$self->{option}->{value_type}->{$self->{option}->{_VALTYPE_DEFAULT}}->[0];
|
747 |
wakaba |
1.9 |
}
|
748 |
|
|
}
|
749 |
|
|
|
750 |
wakaba |
1.5 |
=item $self->clone ()
|
751 |
wakaba |
1.1 |
|
752 |
wakaba |
1.5 |
Returns a copy of Message::Field::Structured object.
|
753 |
wakaba |
1.1 |
|
754 |
|
|
=cut
|
755 |
|
|
|
756 |
wakaba |
1.5 |
sub clone ($) {
|
757 |
wakaba |
1.1 |
my $self = shift;
|
758 |
wakaba |
1.5 |
my $clone = ref($self)->new;
|
759 |
wakaba |
1.9 |
$clone->{option} = Message::Util::make_clone ($self->{option});
|
760 |
wakaba |
1.5 |
## Common hash value (not used in this module)
|
761 |
wakaba |
1.11 |
$self->_delete_empty;
|
762 |
|
|
$self->_comment_cleaning;
|
763 |
|
|
$clone->{value} = Message::Util::make_clone ($self->{value});
|
764 |
|
|
$clone->{comment} = Message::Util::make_clone ($self->{comment});
|
765 |
|
|
for (@{$self->{option}->{_MEMBERS}}) {
|
766 |
|
|
$clone->{$_} = Message::Util::make_clone ($self->{$_});
|
767 |
|
|
}
|
768 |
wakaba |
1.5 |
$clone;
|
769 |
wakaba |
1.1 |
}
|
770 |
|
|
|
771 |
wakaba |
1.8 |
|
772 |
wakaba |
1.10 |
my %_method_default_list = qw(new 1 parse 1 stringify 1 option 1 clone 1 method_available 1);
|
773 |
|
|
sub method_available ($$) {
|
774 |
|
|
my $self = shift;
|
775 |
|
|
my $name = shift;
|
776 |
|
|
return 1 if $_method_default_list{$name};
|
777 |
|
|
for (@{$self->{option}->{_METHODS}}) {
|
778 |
|
|
return 1 if $_ eq $name;
|
779 |
|
|
}
|
780 |
|
|
0;
|
781 |
|
|
}
|
782 |
wakaba |
1.5 |
|
783 |
wakaba |
1.1 |
=head1 EXAMPLE
|
784 |
|
|
|
785 |
|
|
use Message::Field::Structured;
|
786 |
|
|
|
787 |
|
|
my $field_body = '"This is an example of <\"> (quotation mark)."
|
788 |
|
|
(Comment within \q\u\o\t\e\d\-\p\a\i\r\(\s\))';
|
789 |
|
|
my $field = Message::Field::Structured->parse ($field_body);
|
790 |
|
|
|
791 |
|
|
print $field->as_plain_string;
|
792 |
|
|
|
793 |
wakaba |
1.5 |
=head1 SEE ALSO
|
794 |
|
|
|
795 |
|
|
=over 4
|
796 |
|
|
|
797 |
|
|
=item L<Message::Entity>, L<Message::Header>
|
798 |
|
|
|
799 |
|
|
=item L<Message::Field::Unstructured>
|
800 |
|
|
|
801 |
|
|
=item RFC 2822 E<lt>urn:ietf:rfc:2822E<gt>, usefor-article, HTTP/1.0, HTTP/1.1
|
802 |
|
|
|
803 |
|
|
=back
|
804 |
|
|
|
805 |
wakaba |
1.1 |
=head1 LICENSE
|
806 |
|
|
|
807 |
|
|
Copyright 2002 wakaba E<lt>w@suika.fam.cxE<gt>.
|
808 |
|
|
|
809 |
|
|
This program is free software; you can redistribute it and/or modify
|
810 |
|
|
it under the terms of the GNU General Public License as published by
|
811 |
|
|
the Free Software Foundation; either version 2 of the License, or
|
812 |
|
|
(at your option) any later version.
|
813 |
|
|
|
814 |
|
|
This program is distributed in the hope that it will be useful,
|
815 |
|
|
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
816 |
|
|
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
817 |
|
|
GNU General Public License for more details.
|
818 |
|
|
|
819 |
|
|
You should have received a copy of the GNU General Public License
|
820 |
|
|
along with this program; see the file COPYING. If not, write to
|
821 |
|
|
the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
822 |
|
|
Boston, MA 02111-1307, USA.
|
823 |
|
|
|
824 |
|
|
=head1 CHANGE
|
825 |
|
|
|
826 |
|
|
See F<ChangeLog>.
|
827 |
wakaba |
1.18 |
$Date: 2002/06/29 09:31:46 $
|
828 |
wakaba |
1.1 |
|
829 |
|
|
=cut
|
830 |
|
|
|
831 |
|
|
1;
|