/[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.18 - (hide annotations) (download)
Sat Jul 6 10:30:43 2002 UTC (22 years, 4 months ago) by wakaba
Branch: MAIN
Changes since 1.17: +4 -2 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.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;

admin@suikawiki.org
ViewVC Help
Powered by ViewVC 1.1.24