/[suikacvs]/messaging/manakai/lib/Message/Field/Structured.pm
Suika

Contents of /messaging/manakai/lib/Message/Field/Structured.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.17 - (hide annotations) (download)
Sat Jun 29 09:31:46 2002 UTC (22 years, 5 months ago) by wakaba
Branch: MAIN
Changes since 1.16: +73 -10 lines
2002-06-29  Wakaba <w@suika.fam.cx>

	* ContentType.pm, Params.pm, ValueParams.pm,
	XMoe.pm: Rewritten.

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.17 $VERSION=do{my @r=(q$Revision: 1.16 $=~/\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.11 my @r;
453 wakaba 1.10 if ($option{by} eq 'index') {
454     for ($self->{$array}->[$name]) {
455     return $self->_item_return_value (\$_, \%option);
456     }
457     } else {
458     for (@{$self->{$array}}) {
459     if ($self->_item_match ($option{by}, \$_, {$name => 1}, \%option)) {
460     if (wantarray) {
461     push @r, $self->_item_return_value (\$_, \%option);
462     } else {
463     return $self->_item_return_value (\$_, \%option);
464     }
465     }
466     }
467     }
468 wakaba 1.11 if (@r == 0 && $option{new_item_unless_exist}) {
469     my $v = $self->_item_new_value ($name, \%option);
470     if (defined $v) {
471     if ($option{prepend}) {
472     unshift @{$self->{$array}}, $v;
473     } else {
474     push @{$self->{$array}}, $v;
475     }
476     return $self->_item_return_value (\$v, \%option);
477     }
478     }
479     return undef unless wantarray;
480     @r;
481 wakaba 1.10 }
482    
483 wakaba 1.14 sub item_exist ($$;%) {
484     my $self = shift;
485     my ($name, %p) = (shift, @_);
486     my %option = %{$self->{option}};
487     for (grep {/^-/} keys %p) {$option{substr ($_, 1)} = $p{$_}}
488     my $array = $option{_ARRAY_NAME} || $option{_HASH_NAME};
489     unless ($array) {
490     return if $option{dont_croak};
491     Carp::croak q{item-exist: Method not available for this module};
492     }
493     my @r;
494     if ($option{by} eq 'index') {
495     return 1 if ref $self->{$array}->[$name];
496     } else {
497     for (@{$self->{$array}}) {
498     if ($self->_item_match ($option{by}, \$_, {$name => 1}, \%option)) {
499     return 1;
500     }
501     }
502     }
503     0;
504     }
505    
506 wakaba 1.17 ## 1/0 = $self->_item_match ($by, \$item, \%delete_list, \%option)
507     ## -- Checks and returns whether given item is matched with
508     ## returning item list
509     ## Note: $by eq 'index' is already defined in delete method
510     ## itself, so in this function it need not be checked.
511 wakaba 1.10 sub _item_match ($$\$\%\%) {
512 wakaba 1.17 my $self = shift;
513     my ($by, $item, $list, $option) = @_;
514     return 0 unless ref $$item; ## Removed
515     ## An example definition
516     if ($by eq 'name') {
517     $$item->{value} = $self->_parse_value ($$item->{type}, $$item->{value});
518     return 1 if ref $$item->{value} && $$list{ $$item->{value}->{name} };
519     }
520     0;
521 wakaba 1.10 }
522    
523 wakaba 1.17 ## $value = $self->_item_return_value (\$item, \%option)
524     ## -- Returns returning value of item method
525 wakaba 1.10 sub _item_return_value ($\$\%) {
526 wakaba 1.11 $_[1];
527     }
528    
529 wakaba 1.17 ## $item = $self->_item_new_value ($name, \%option)
530     ## -- Returns new item with key of $name (called when
531     ## no returned value is found and -new_value_unless_exist
532     ## option is true)
533     ## (Note that the kind of key ('by' option) can be getten
534     ## from $option->{by})
535     ## Return undef when new value can't be generated.
536 wakaba 1.11 sub _item_new_value ($$\%) {
537     $_[1];
538 wakaba 1.10 }
539    
540 wakaba 1.9 ## $self->_parse_value ($type, $value);
541     sub _parse_value ($$$) {
542     my $self = shift;
543 wakaba 1.14 my $name = shift;
544 wakaba 1.9 my $value = shift;
545     return $value if ref $value;
546 wakaba 1.14 my $handler = $self->{option}->{value_type}->{$name}
547     || $self->{option}->{value_type}->{$self->{option}->{_VALTYPE_DEFAULT}};
548     if (ref $handler eq 'CODE') {
549     $handler = &$handler ($self);
550     }
551     my $vtype = $handler->[0];
552     my %vopt = (
553     -format => $self->{option}->{format},
554     -field_ns => $self->{option}->{field_ns},
555     -field_name => $self->{option}->{field_name},
556     -field_param_name => $name,
557     -parse_all => $self->{option}->{parse_all},
558     );
559     ## Media type specified option/parameters
560     if (ref $handler->[1] eq 'HASH') {
561     for (keys %{$handler->[1]}) {
562     $vopt{$_} = ${$handler->[1]}{$_};
563     }
564     }
565     ## Inherited options
566     if (ref $handler->[2] eq 'ARRAY') {
567     for (@{$handler->[2]}) {
568     $vopt{'-'.$_} = $self->{option}->{$_};
569     }
570     }
571    
572 wakaba 1.9 if ($vtype eq ':none:') {
573     return $value;
574     } elsif (defined $value) {
575     eval "require $vtype" or Carp::croak qq{<parse>: $vtype: Can't load package: $@};
576 wakaba 1.14 return $vtype->parse ($value, %vopt);
577 wakaba 1.9 } else {
578     eval "require $vtype" or Carp::croak qq{<parse>: $vtype: Can't load package: $@};
579 wakaba 1.14 return $vtype->new (%vopt);
580 wakaba 1.9 }
581     }
582    
583 wakaba 1.11 ## comments
584    
585    
586     sub comment_add ($@) {
587     my $self = shift;
588     my $array = 'comment';
589     ## Options
590     my %option = %{$self->{option}};
591     if (ref $_[0] eq 'HASH') {
592     my $option = shift (@_);
593     for (keys %$option) {my $n = $_; $n =~ s/^-//; $option{$n} = $$option{$_}}
594     }
595    
596     ## Additional items
597     if ($option{prepend}) {
598     unshift @{$self->{$array}}, reverse @_;
599     } else {
600     push @{$self->{$array}}, @_;
601     }
602     }
603    
604     sub comment_count ($) {
605     my $self = shift;
606     $self->_comment_cleaning;
607     $#{$self->{comment}} + 1;
608     }
609    
610     sub comment_delete ($@) {
611     my $self = shift;
612     #my %p; %p = %{shift (@_)} if ref $_[0] eq 'HASH';
613     #my %option = %{$self->{option}};
614     #for (grep {/^-/} keys %p) {$option{substr ($_, 1)} = $p{$_}}
615     for (@_) {
616     $self->{comment}->[$_] = undef;
617     }
618     $self->_comment_cleaning;
619     }
620    
621     sub comment_item ($$) {
622     $_[0]->{comment}->[$_[1]];
623     }
624    
625     sub _comment_cleaning ($) {
626     my $self = shift;
627     $self->{comment} = [grep {length $_} @{$self->{comment}}];
628     }
629    
630     sub _comment_stringify ($\%) {
631     my $self = shift;
632 wakaba 1.15 my $option = shift;
633     $option->{_comment_min} ||= 0;
634     $option->{_comment_max} = $#{$self->{comment}} unless defined $option->{_comment_max};
635 wakaba 1.11 my @v;
636 wakaba 1.15 for (@{$self->{comment}}[$option->{_comment_min}..$option->{_comment_max}]) {
637 wakaba 1.11 push @v, '('. $self->Message::Util::encode_ccontent ($_) .')';
638     }
639     join ' ', @v;
640     }
641    
642 wakaba 1.14 sub scan ($&;%) {
643     my $self = shift;
644     my $sub = shift;
645 wakaba 1.16 my %p = @_; my %option;
646     if (ref $p{options} eq 'HASH') {
647     %option = %{$p{options}};
648     } else {
649     %option = %{$self->{option}};
650     for (grep {/^-/} keys %p) {$option{substr ($_, 1)} = $p{$_}}
651     }
652     my $array = $option{_ARRAY_NAME} || $option{_HASH_NAME};
653     my @param = $self->_scan_sort (\@{$self->{$array}}, \%option);
654 wakaba 1.14 #my $sort = $option{sort};
655     #@param = sort $sort @param if ref $sort;
656 wakaba 1.10 for my $param (@param) {
657 wakaba 1.16 &$sub($self, $param, \%option);
658 wakaba 1.10 }
659     }
660    
661 wakaba 1.14 sub _scan_sort ($\@) {
662     #my $self = shift;
663     @{$_[1]};
664     }
665    
666 wakaba 1.5 =head1 METHODS
667    
668     =over 4
669    
670     =item $self->stringify ([%options])
671 wakaba 1.1
672 wakaba 1.5 Returns field body as a string. Returned string is encoded,
673     quoted if necessary (by C<hook_encode_string>).
674 wakaba 1.1
675     =cut
676    
677 wakaba 1.7 sub stringify ($;%) {
678 wakaba 1.1 my $self = shift;
679 wakaba 1.5 #$self->Message::Util::encode_qcontent ($self->{field_body});
680     $self->{field_body};
681 wakaba 1.1 }
682 wakaba 1.5 *as_string = \&stringify;
683 wakaba 1.1
684 wakaba 1.5 =item $self->as_plain_string
685 wakaba 1.1
686 wakaba 1.5 Returns field body as a string. Returned string is not encoded
687     or quoted, i.e. internal/bare coded string. This string
688     may be unable to use as field body content. (Its I<structures>
689     such as C<comment> and C<quoted-string> are lost.)
690 wakaba 1.1
691     =cut
692    
693     sub as_plain_string ($) {
694     my $self = shift;
695 wakaba 1.5 my $s = $self->Message::Util::decode_qcontent ($self->{field_body});
696     Message::Util::unquote_quoted_string (Message::Util::unquote_ccontent ($s));
697 wakaba 1.1 }
698 wakaba 1.4
699 wakaba 1.5 =item $self->option ( $option-name / $option-name, $option-value, ...)
700 wakaba 1.4
701 wakaba 1.5 If @_ == 1, returns option value. Else...
702 wakaba 1.4
703 wakaba 1.5 Set option value. You can pass multiple option name-value pair
704     as parameter. Example:
705 wakaba 1.1
706 wakaba 1.5 $msg->option (format => 'mail-rfc822',
707     capitalize => 0);
708     print $msg->option ('format'); ## mail-rfc822
709 wakaba 1.1
710     =cut
711    
712 wakaba 1.5 sub option ($@) {
713 wakaba 1.1 my $self = shift;
714 wakaba 1.5 if (@_ == 1) {
715     return $self->{option}->{ $_[0] };
716     }
717 wakaba 1.14 my %option = @_;
718 wakaba 1.5 while (my ($name, $value) = splice (@_, 0, 2)) {
719 wakaba 1.14 $self->{option}->{$name} = $value;
720     }
721     if ($option{-recursive}) {
722     $self->_option_recursive (\%option);
723 wakaba 1.5 }
724 wakaba 1.12 $self;
725 wakaba 1.1 }
726    
727 wakaba 1.14 ## $self->_option_recursive (\%argv)
728     sub _option_recursive ($\%) {}
729    
730 wakaba 1.9 ## TODO: multiple value-type support
731     sub value_type ($;$$%) {
732     my $self = shift;
733 wakaba 1.14 my $name = shift || $self->{option}->{_VALTYPE_DEFAULT};
734 wakaba 1.9 my $new_value_type = shift;
735     if ($new_value_type) {
736     $self->{option}->{value_type}->{$name} = []
737     unless ref $self->{option}->{value_type}->{$name};
738     $self->{option}->{value_type}->{$name}->[0] = $new_value_type;
739     }
740     if (ref $self->{option}->{value_type}->{$name}) {
741     $self->{option}->{value_type}->{$name}->[0]
742 wakaba 1.14 || $self->{option}->{value_type}->{$self->{option}->{_VALTYPE_DEFAULT}}->[0];
743 wakaba 1.9 } else {
744 wakaba 1.14 $self->{option}->{value_type}->{$self->{option}->{_VALTYPE_DEFAULT}}->[0];
745 wakaba 1.9 }
746     }
747    
748 wakaba 1.5 =item $self->clone ()
749 wakaba 1.1
750 wakaba 1.5 Returns a copy of Message::Field::Structured object.
751 wakaba 1.1
752     =cut
753    
754 wakaba 1.5 sub clone ($) {
755 wakaba 1.1 my $self = shift;
756 wakaba 1.5 my $clone = ref($self)->new;
757 wakaba 1.9 $clone->{option} = Message::Util::make_clone ($self->{option});
758 wakaba 1.5 ## Common hash value (not used in this module)
759 wakaba 1.11 $self->_delete_empty;
760     $self->_comment_cleaning;
761     $clone->{value} = Message::Util::make_clone ($self->{value});
762     $clone->{comment} = Message::Util::make_clone ($self->{comment});
763     for (@{$self->{option}->{_MEMBERS}}) {
764     $clone->{$_} = Message::Util::make_clone ($self->{$_});
765     }
766 wakaba 1.5 $clone;
767 wakaba 1.1 }
768    
769 wakaba 1.8
770 wakaba 1.10 my %_method_default_list = qw(new 1 parse 1 stringify 1 option 1 clone 1 method_available 1);
771     sub method_available ($$) {
772     my $self = shift;
773     my $name = shift;
774     return 1 if $_method_default_list{$name};
775     for (@{$self->{option}->{_METHODS}}) {
776     return 1 if $_ eq $name;
777     }
778     0;
779     }
780 wakaba 1.5
781 wakaba 1.1 =head1 EXAMPLE
782    
783     use Message::Field::Structured;
784    
785     my $field_body = '"This is an example of <\"> (quotation mark)."
786     (Comment within \q\u\o\t\e\d\-\p\a\i\r\(\s\))';
787     my $field = Message::Field::Structured->parse ($field_body);
788    
789     print $field->as_plain_string;
790    
791 wakaba 1.5 =head1 SEE ALSO
792    
793     =over 4
794    
795     =item L<Message::Entity>, L<Message::Header>
796    
797     =item L<Message::Field::Unstructured>
798    
799     =item RFC 2822 E<lt>urn:ietf:rfc:2822E<gt>, usefor-article, HTTP/1.0, HTTP/1.1
800    
801     =back
802    
803 wakaba 1.1 =head1 LICENSE
804    
805     Copyright 2002 wakaba E<lt>w@suika.fam.cxE<gt>.
806    
807     This program is free software; you can redistribute it and/or modify
808     it under the terms of the GNU General Public License as published by
809     the Free Software Foundation; either version 2 of the License, or
810     (at your option) any later version.
811    
812     This program is distributed in the hope that it will be useful,
813     but WITHOUT ANY WARRANTY; without even the implied warranty of
814     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
815     GNU General Public License for more details.
816    
817     You should have received a copy of the GNU General Public License
818     along with this program; see the file COPYING. If not, write to
819     the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
820     Boston, MA 02111-1307, USA.
821    
822     =head1 CHANGE
823    
824     See F<ChangeLog>.
825 wakaba 1.17 $Date: 2002/06/23 12:10:16 $
826 wakaba 1.1
827     =cut
828    
829     1;

admin@suikawiki.org
ViewVC Help
Powered by ViewVC 1.1.24