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

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

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.8 by wakaba, Sun Apr 21 04:27:42 2002 UTC revision 1.9 by wakaba, Sat May 4 06:03:58 2002 UTC
# Line 29  The following methods construct new C<Me Line 29  The following methods construct new C<Me
29  sub _init ($;%) {  sub _init ($;%) {
30    my $self = shift;    my $self = shift;
31    my %options = @_;    my %options = @_;
32    $self->{option} = {    $self->{option} = Message::Util::make_clone ({
33    encoding_after_encode => '*default',      _ARRAY_NAME => '',
34    encoding_before_decode        => '*default',      _HASH_NAME  => '',
35    field_name    => 'x-structured',      dont_croak  => 0,   ## Don't die unless very very fatal error
36    field_name_case_sensible      => 0,      encoding_after_encode       => '*default',
37    format        => 'mail-rfc2822',      encoding_before_decode      => '*default',
38    hook_encode_string    => #sub {shift; (value => shift, @_)},      field_param_name    => '',
39          \&Message::Util::encode_header_string,      field_name  => 'x-structured',
40    hook_decode_string    => #sub {shift; (value => shift, @_)},      format      => 'mail-rfc2822',
41          \&Message::Util::decode_header_string,      hook_encode_string  => #sub {shift; (value => shift, @_)},
42    };          \&Message::Util::encode_header_string,
43        hook_decode_string  => #sub {shift; (value => shift, @_)},
44            \&Message::Util::decode_header_string,
45        #name       ## Reserved for method level option
46        #parse      ## Reserved for method level option
47        parse_all   => 0,
48        prepend     => 0,   ## (Reserved for method level option)
49        value_type  => {'*default'  => [':none:']},
50      });
51    $self->{field_body} = '';    $self->{field_body} = '';
52        
53    for my $name (keys %options) {    for my $name (keys %options) {
# Line 83  sub parse ($$;%) { Line 91  sub parse ($$;%) {
91    
92  =back  =back
93    
94    =cut
95    
96    ## Template procedures for array/hash fields
97    ## (As bare Message::Field::Structured module,
98    ##  these shall not be used.)
99    
100    sub add ($$$%) {
101      my $self = shift;
102      
103      my $array = $self->{option}->{_ARRAY_NAME};
104      if ($array) {
105      
106      ## --- field is non-named value list (i.e. not hash)
107        
108        ## Options
109        my %option = %{$self->{option}};
110        if (ref $_[0] eq 'HASH') {
111          my $option = shift (@_);
112          for (keys %$option) {my $n = $_; $n =~ s/^-//; $option{$n} = $$option{$_}}
113        }
114        
115        ## Additional items
116        my $avalue;
117        for (@_) {
118          my ($ok, undef, $avalue) = $self->_add_array_check ($_, \%option);
119          if ($ok) {
120            if ($option{prepend}) {
121              unshift @{$self->{$array}}, $avalue;
122            } else {
123              push @{$self->{$array}}, $avalue;
124            }
125          }
126        }
127        $avalue;    ## Return last added value if necessary.
128        
129      } else {
130        $array = $self->{option}->{_HASH_NAME};
131      
132      ## --- field is not list
133      
134        unless ($array) {
135          my %option = @_;
136          return if $option{-dont_croak};
137          Carp::croak q{add: Method not available for this module};
138        }
139        
140      ## --- field is named value list (i.e. hash)
141        
142        ## Options
143        my %p = @_; my %option = %{$self->{option}};
144        for (grep {/^-/} keys %p) {$option{substr ($_, 1)} = $p{$_}}
145        $option{parse} = 1 if defined wantarray && !defined $option{parse};
146        
147        ## Additional items
148        my $avalue;
149        while (my ($name => $value) = splice (@_, 0, 2)) {
150          next if $name =~ /^-/; $name =~ s/^\\//;
151          
152          my $ok;
153          ($ok, undef, $avalue) = $self->_add_hash_check ($name => $value, \%option);
154          if ($ok) {
155            if ($option{prepend}) {
156              unshift @{$self->{$array}}, $avalue;
157            } else {
158              push @{$self->{$array}}, $avalue;
159            }
160          }
161        }
162        $avalue;    ## Return last added value if necessary.
163      }
164    }
165    
166    sub _add_array_check ($$\%) {
167      shift; 1, $_[0] => $_[0];
168    }
169    sub _add_hash_check ($$$\%) {
170      shift; 1, $_[0] => [@_[0,1]];
171    }
172    
173    sub replace ($$$%) {
174      my $self = shift;
175      
176      $self->_replace_cleaning;
177      my $array = $self->{option}->{_ARRAY_NAME};
178      if ($array) {
179      
180      ## --- field is non-named value list (i.e. not hash)
181        
182        ## Options
183        my %option = %{$self->{option}};
184        if (ref $_[0] eq 'HASH') {
185          my $option = shift (@_);
186          for (keys %$option) {my $n = $_; $n =~ s/^-//; $option{$n} = $$option{$_}}
187        }
188        
189        ## Additional items
190        my ($avalue, %replace);
191        for (@_) {
192          my ($ok, $aname);
193          ($ok, $aname => $avalue)
194            = $self->_replace_array_check ($_, \%option);
195          if ($ok) {
196            $replace{$aname} = $avalue;
197          }
198        }
199        for (@{$self->{$array}}) {
200          my ($v) = $self->_replace_array_shift (\%replace => $_, \%option);
201          if (defined $v) {
202            $_ = $v;
203          }
204        }
205        for (keys %replace) {
206          if ($option{prepend}) {
207            unshift @{$self->{$array}}, $replace{$_};
208          } else {
209            push @{$self->{$array}}, $replace{$_};
210          }
211        }
212        $avalue;    ## Return last added value if necessary.
213        
214      } else {
215        $array = $self->{option}->{_HASH_NAME};
216      
217      ## --- field is not list
218      
219        unless ($array) {
220          my %option = @_;
221          return if $option{-dont_croak};
222          Carp::croak q{replace: Method not available for this module};
223        }
224        
225      ## --- field is named value list (i.e. hash)
226        
227        ## Options
228        my %p = @_; my %option = %{$self->{option}};
229        for (grep {/^-/} keys %p) {$option{substr ($_, 1)} = $p{$_}}
230        $option{parse} = 1 if defined wantarray && !defined $option{parse};
231        
232        ## Additional items
233        my ($avalue, %replace);
234        while (my ($name => $value) = splice (@_, 0, 2)) {
235          next if $name =~ /^-/; $name =~ s/^\\//;
236          
237          my ($ok, $aname);
238          ($ok, $aname => $avalue)
239            = $self->_replace_hash_check ($name => $value, \%option);
240          if ($ok) {
241            $replace{$aname} = $avalue;
242          }
243        }
244        for (@{$self->{$array}}) {
245          my ($v) = $self->_replace_hash_shift (\%replace => $_, \%option);
246          if (defined $v) {
247            $_ = $v;
248          }
249        }
250        for (keys %replace) {
251          if ($option{prepend}) {
252            unshift @{$self->{$array}}, $replace{$_};
253          } else {
254            push @{$self->{$array}}, $replace{$_};
255          }
256        }
257        $avalue;    ## Return last added value if necessary.
258      }
259    }
260    
261    sub _replace_cleaning ($) {
262      # $_[0]->_delete_empty;
263    }
264    sub _replace_array_check ($$\%) {
265      shift; 1, $_[0] => $_[0];
266    }
267    sub _replace_array_shift ($\%$\%) {
268      shift; my $r = shift;  my $n = $_[0]->[0];
269      if ($$r{$n}) {
270        my $d = $$r{$n};
271        $$r{$n} = undef;
272        return $d;
273      }
274      undef;
275    }
276    sub _replace_hash_check ($$$\%) {
277      shift; 1, $_[0] => [@_[0,1]];
278    }
279    sub _replace_hash_shift ($\%$\%) {
280      shift; my $r = shift;  my $n = $_[0]->[0];
281      if ($$r{$n}) {
282        my $d = $$r{$n};
283        $$r{$n} = undef;
284        return $d;
285      }
286      undef;
287    }
288    
289    sub count ($;%) {
290      my $self = shift; my %option = @_;
291      my $array = $self->{option}->{_ARRAY_NAME}
292               || $self->{option}->{_HASH_NAME};
293      unless ($array) {
294        return if $option{-dont_croak};
295        Carp::croak q{count: Method not available for this module};
296      }
297      $self->_count_cleaning;
298      return $self->_count_by_name ($array => \%option) if defined $option{-name};
299      $#{$self->{$array}} + 1;
300    }
301    sub _count_cleaning ($) {
302      # $_[0]->_delete_empty;
303    }
304    sub _count_by_name ($$\%) {
305      # my $self = shift;
306      # my ($array, $option) = @_;
307      # my $name = $self->_n11n_*name* ($$option{-name});
308      # my @a = grep {$_->[0] eq $name} @{$self->{$array}};
309      # $#a + 1;
310    }
311    
312    ## Delete empty items
313    sub _delete_empty ($) {
314      # my $self = shift;
315      # $self->{*$array*} = [grep {ref $_ && length $_->[0]} @{$self->{*$array*}}];
316      # $self;
317    }
318    
319    ## $self->_parse_value ($type, $value);
320    sub _parse_value ($$$) {
321      my $self = shift;
322      my $name = shift || '*default';
323      my $value = shift;
324      return $value if ref $value;
325      my $vtype = $self->{option}->{value_type}->{$name}->[0]
326          || $self->{option}->{value_type}->{'*default'}->[0];
327      my %vopt; %vopt = %{$self->{option}->{value_type}->{$name}->[1]}
328        if ref $self->{option}->{value_type}->{$name}->[1];
329      if ($vtype eq ':none:') {
330        return $value;
331      } elsif (defined $value) {
332        eval "require $vtype" or Carp::croak qq{<parse>: $vtype: Can't load package: $@};
333        return $vtype->parse ($value,
334          -format   => $self->{option}->{format},
335          -field_name       => $self->{option}->{field_name},
336          -field_param_name => $name,
337          -parse_all        => $self->{option}->{parse_all},
338        %vopt);
339      } else {
340        eval "require $vtype" or Carp::croak qq{<parse>: $vtype: Can't load package: $@};
341        return $vtype->new (
342          -format   => $self->{option}->{format},
343          -field_name       => $self->{option}->{field_name},
344          -field_param_name => $name,
345          -parse_all        => $self->{option}->{parse_all},
346        %vopt);
347      }
348    }
349    
350  =head1 METHODS  =head1 METHODS
351    
352  =over 4  =over 4
# Line 147  sub option ($@) { Line 411  sub option ($@) {
411    }    }
412  }  }
413    
414    ## TODO: multiple value-type support
415    sub value_type ($;$$%) {
416      my $self = shift;
417      my $name = shift || '*default';
418      my $new_value_type = shift;
419      if ($new_value_type) {
420        $self->{option}->{value_type}->{$name} = []
421          unless ref $self->{option}->{value_type}->{$name};
422        $self->{option}->{value_type}->{$name}->[0] = $new_value_type;
423      }
424      if (ref $self->{option}->{value_type}->{$name}) {
425        $self->{option}->{value_type}->{$name}->[0]
426          || $self->{option}->{value_type}->{'*default'}->[0];
427      } else {
428        $self->{option}->{value_type}->{'*default'}->[0];
429      }
430    }
431    
432  =item $self->clone ()  =item $self->clone ()
433    
434  Returns a copy of Message::Field::Structured object.  Returns a copy of Message::Field::Structured object.
# Line 156  Returns a copy of Message::Field::Struct Line 438  Returns a copy of Message::Field::Struct
438  sub clone ($) {  sub clone ($) {
439    my $self = shift;    my $self = shift;
440    my $clone = ref($self)->new;    my $clone = ref($self)->new;
441    for my $name (%{$self->{option}}) {    $clone->_delete_empty;
442      if (ref $self->{option}->{$name} eq 'HASH') {    $clone->{option} = Message::Util::make_clone ($self->{option});
443        $clone->{option}->{$name} = {%{$self->{option}->{$name}}};    $clone->{field_body} = Message::Util::make_clone ($self->{field_body});
     } elsif (ref $self->{option}->{$name} eq 'ARRAY') {  
       $clone->{option}->{$name} = [@{$self->{option}->{$name}}];  
     } else {  
       $clone->{option}->{$name} = $self->{option}->{$name};  
     }  
   }  
   $clone->{field_body} = ref $self->{field_body}?  
                              $self->{field_body}->clone:  
                              $self->{field_body};  
444    ## Common hash value (not used in this module)    ## Common hash value (not used in this module)
445      if (ref $self->{value} eq 'HASH') {    $clone->{value} = Message::Util::make_clone ($self->{value});
446        $clone->{value} = {map {ref $_? $_->clone: $_} %{$self->{value}}};    $clone->{comment} = Message::Util::make_clone ($self->{comment});
     } elsif (ref $self->{value} eq 'ARRAY') {  
       $clone->{value} = [map {ref $_? $_->clone: $_} @{$self->{value}}];  
     } elsif (ref $self->{value}) {  
       $clone->{value} = $self->{value}->clone;  
     } else {  
       $clone->{value} = $self->{value};  
     }  
   for my $i (@{$self->{comment}}) {  
     if (ref $self->{comment}->[$i] eq 'HASH') {  
       $clone->{comment}->[$i] = {%{$self->{comment}->[$i]}};  
     } elsif (ref $self->{comment}->[$i] eq 'ARRAY') {  
       $clone->{comment}->[$i] = [@{$self->{comment}->[$i]}];  
     } else {  
       $clone->{comment}->[$i] = $self->{comment}->[$i];  
     }  
   }  
447    $clone;    $clone;
448  }  }
449    
450  sub _n11n_field_name ($$) {  sub _n11n_field_name ($$) {
451    my $self = shift;    my $self = shift;
452    my $s = shift;    my $s = shift;
453    $s = lc $s unless $self->{option}->{field_name_case_sensible};    $s = lc $s ;#unless $self->{option}->{field_name_case_sensible};
454    $s;    $s;
455  }  }
456    
Legend:
Removed from v.1.8  
changed lines
  Added in v.1.9
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24