/[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.4 by wakaba, Sun Mar 31 13:11:55 2002 UTC revision 1.5 by wakaba, Fri Apr 5 14:55:28 2002 UTC
# Line 1  Line 1 
1    
2  =head1 NAME  =head1 NAME
3    
4  Message::Field::Structured Perl module  Message::Field::Structured -- Perl module for
5    structured header field bodies of the Internet message
 =head1 DESCRIPTION  
   
 Perl module for RFC 822/2822 structured C<field>s.  
6    
7  =cut  =cut
8    
9  package Message::Field::Structured;  package Message::Field::Structured;
 require 5.6.0;  
10  use strict;  use strict;
11  use re 'eval';  use vars qw($VERSION);
 use vars qw(%DEFAULT %REG $VERSION);  
12  $VERSION=do{my @r=(q$Revision$=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};  $VERSION=do{my @r=(q$Revision$=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
13  require Message::Util;  require Message::Util;
14    use overload '""' => sub { $_[0]->stringify },
15                 '.=' => sub { $_[0]->value_append ($_[1]) },
16                 'eq' => sub { $_[0]->{field_body} eq $_[1] },
17                 'ne' => sub { $_[0]->{field_body} ne $_[1] },
18                 fallback => 1;
19    
20  use overload '""' => sub {shift->stringify};  =head1 CONSTRUCTORS
21    
22  $REG{comment} = qr/\x28(?:\x5C[\x00-\xFF]|[\x00-\x0C\x0E-\x27\x2A-\x5B\x5D-\xFF]|(??{$REG{comment}}))*\x29/;  The following methods construct new C<Message::Field::Structured> objects:
 $REG{quoted_string} = qr/\x22(?:\x5C[\x00-\xFF]|[\x00-\x0C\x0E-\x21\x23-\x5B\x5D-\xFF])*\x22/;  
 $REG{domain_literal} = qr/\x5B(?:\x5C[\x00-\xFF]|[\x00-\x0C\x0E-\x5A\x5E-\xFF])*\x5D/;  
23    
24  $REG{WSP} = qr/[\x20\x09]+/;  =over 4
 $REG{FWS} = qr/[\x20\x09]*/;  
 $REG{M_quoted_string} = qr/\x22((?:\x5C[\x00-\xFF]|[\x00-\x0C\x0E-\x21\x23-\x5B\x5D-\xFF])*)\x22/;  
 $REG{M_comment} = qr/\x28((?:\x5C[\x00-\xFF]|[\x00-\x0C\x0E-\x27\x2A-\x5B\x5D-\xFF]|(??{$REG{comment}}))*)\x29/;  
25    
26  $REG{NON_atom} = qr/[^\x09\x20\x21\x23-\x27\x2A\x2B\x2D\x2F\x30-\x39\x3D\x3F\x41-\x5A\x5E-\x7E]/;  =cut
27    
28  %DEFAULT = (  ## Initialize of this class -- called by constructors
29    sub _init ($;%) {
30      my $self = shift;
31      my %options = @_;
32      $self->{option} = {
33    encoding_after_encode => '*default',    encoding_after_encode => '*default',
34    encoding_before_decode        => '*default',    encoding_before_decode        => '*default',
35    hook_encode_string    => #sub {shift; (value => shift, @_)},    hook_encode_string    => #sub {shift; (value => shift, @_)},
36          \&Message::Util::encode_header_string,          \&Message::Util::encode_header_string,
37    hook_decode_string    => #sub {shift; (value => shift, @_)},    hook_decode_string    => #sub {shift; (value => shift, @_)},
38          \&Message::Util::decode_header_string,          \&Message::Util::decode_header_string,
39  );    };
40      $self->{field_body} = '';
41      
42      for my $name (keys %options) {
43        if (substr ($name, 0, 1) eq '-') {
44          $self->{option}->{substr ($name, 1)} = $options{$name};
45        } elsif (lc $name eq 'body') {
46          $self->{field_body} = $options{$name};
47        }
48      }
49    }
50    
51  =head2 Message::Field::Structured->new ()  =item Message::Field::Structured->new ([%options])
52    
53  Return empty Message::Field::Structured object.  Constructs a new C<Message::Field::Structured> object.  You might pass some
54    options as parameters to the constructor.
55    
56  =cut  =cut
57    
58  sub new ($;%) {  sub new ($;%) {
59    my $class = shift;    my $class = shift;
60    my $self = bless {option => {@_}}, $class;    my $self = bless {}, $class;
61    for (keys %DEFAULT) {$self->{option}->{$_} ||= $DEFAULT{$_}}    $self->_init (@_);
62    $self;    $self;
63  }  }
64    
65  =head2 Message::Field::Structured->parse ($unfolded_field_body)  =item Message::Field::Structured->parse ($field-body, [%options])
66    
67  Parse structured C<field-body>.  Constructs a new C<Message::Field::Structured> object with
68    given field body.  You might pass some options as parameters to the constructor.
69    
70  =cut  =cut
71    
72  sub parse ($$;%) {  sub parse ($$;%) {
73    my $class = shift;    my $class = shift;
74    my $self = bless {option => {@_}}, $class;    my $self = bless {}, $class;
75    for (keys %DEFAULT) {$self->{option}->{$_} ||= $DEFAULT{$_}}    $self->_init (@_);
76    my $field_body = $self->_decode_qcontent (shift);    #my $field_body = $self->Message::Util::decode_qcontent (shift);
77    $self->{field_body} = $field_body;    $self->{field_body} = shift; #$field_body;
78    $self;    $self;
79  }  }
80    
81  =head2 $self->stringify ()  =back
82    
83    =head1 METHODS
84    
85    =over 4
86    
87    =item $self->stringify ([%options])
88    
89  Returns C<field-body> as a string.  Returns field body as a string.  Returned string is encoded,
90    quoted if necessary (by C<hook_encode_string>).
91    
92  =cut  =cut
93    
94  sub stringify ($) {  sub stringify ($) {
95    my $self = shift;    my $self = shift;
96    $self->_encode_qcontent ($self->{field_body});    #$self->Message::Util::encode_qcontent ($self->{field_body});
97      $self->{field_body};
98  }  }
99    *as_string = \&stringify;
100    
101  =head2 $self->as_plain_string ()  =item $self->as_plain_string
102    
103  Returns C<field-body> contents as a plain text fragment.  Returns field body as a string.  Returned string is not encoded
104  C<quoted-string> and C<quoted-pair> in C<comment> are  or quoted, i.e. internal/bare coded string.  This string
105  unquoted, so return value of this method can be invalid  may be unable to use as field body content.  (Its I<structures>
106  as a part of the C<field>.  such as C<comment> and C<quoted-string> are lost.)
107    
108  =cut  =cut
109    
110  sub as_plain_string ($) {  sub as_plain_string ($) {
111    my $self = shift;    my $self = shift;
112    $self->unquote_quoted_string ($self->unquote_comment ($self->{field_body}));    my $s = $self->Message::Util::decode_qcontent ($self->{field_body});
113      Message::Util::unquote_quoted_string (Message::Util::unquote_ccontent ($s));
114  }  }
 =head2 $self->option ($option_name, [$option_value])  
115    
116  Set/gets new value of the option.  =item $self->option ( $option-name / $option-name, $option-value, ...)
117    
118  =cut  If @_ == 1, returns option value.  Else...
119    
120  sub option ($$;$) {  Set option value.  You can pass multiple option name-value pair
121    my $self = shift;  as parameter.  Example:
   my ($name, $value) = @_;  
   if (defined $value) {  
     $self->{option}->{$name} = $value;  
   }  
   $self->{option}->{$name};  
 }  
122    
123  ## Decode C<qcontent> (content of C<quoted-string>).    $msg->option (-format => 'mail-rfc822',
124  sub _decode_qcontent ($$) {                  -capitalize => 0);
125    my $self = shift;    print $msg->option ('-format');       ## mail-rfc822
   my $quoted_string = shift;  
   $quoted_string =~ s{$REG{M_quoted_string}}{  
     my ($qtext) = ($1);  
       $qtext =~ s/\x5C([\x00-\xFF])/$1/g;  
       my %s = &{$self->{option}->{hook_decode_string}} ($self, $qtext,  
                 type => 'phrase/quoted');  
       $s{value} =~ s/([\x22\x5C])([\x20-\xFF])?/"\x5C$1".($2?"\x5C$2":'')/ge;  
       '"'.$s{value}.'"';  
   }goex;  
   $quoted_string;  
 }  
126    
127  ## Encode C<qcontent> (content of C<quoted-string>).  Note that introduction character, i.e. C<-> (HYPHEN-MINUS)
128  sub _encode_qcontent ($$) {  is optional.  You can also write as this:
   my $self = shift;  
   my $quoted_string = shift;  
   $quoted_string =~ s{$REG{M_quoted_string}}{  
     my ($qtext) = ($1);  
       $qtext =~ s/\x5C([\x00-\xFF])/$1/g;  
       my %s = &{$self->{option}->{hook_encode_string}} ($self, $qtext,  
                 type => 'phrase/quoted');  
       $s{value} =~ s/([\x22\x5C])([\x20-\xFF])?/"\x5C$1".($2?"\x5C$2":'')/ge;  
       '"'.$s{value}.'"';  
   }goex;  
   $quoted_string;  
 }  
129    
130  sub quote_unsafe_string ($$) {    $msg->option (format => 'mail-rfc822',
131    my $self = shift;                  capitalize => 0);
132    my $string = shift;    print $msg->option ('format');        ## mail-rfc822
   if ($string =~ /$REG{NON_atom}/ || $string =~ /$REG{WSP}$REG{WSP}+/) {  
     $string =~ s/([\x22\x5C])([\x20-\xFF])?/"\x5C$1".($2?"\x5C$2":'')/ge;  
     $string = '"'.$string.'"';  
   }  
   $string;  
 }  
   
 =head2 $self->unquote_quoted_string ($string)  
   
 Unquote C<quoted-string>.  Get rid of C<DQUOTE>s and  
 C<REVERSED SOLIDUS> included in C<quoted-pair>.  
 This method is intended for internal use.  
133    
134  =cut  =cut
135    
136  sub unquote_quoted_string ($$) {  sub option ($@) {
   my $self = shift;  
   my $quoted_string = shift;  
   $quoted_string =~ s{$REG{M_quoted_string}}{  
     my $qtext = $1;  
     $qtext =~ s/\x5C([\x00-\xFF])/$1/g;  
     $qtext;  
   }goex;  
   $quoted_string;  
 }  
   
 sub unquote_comment ($$) {  
137    my $self = shift;    my $self = shift;
138    my $quoted_string = shift;    if (@_ == 1) {
139    $quoted_string =~ s{$REG{M_comment}}{      return $self->{option}->{ $_[0] };
140      my $qtext = $1;    }
141      $qtext =~ s/\x5C([\x00-\xFF])/$1/g;    while (my ($name, $value) = splice (@_, 0, 2)) {
142      '('.$qtext.')';      $name =~ s/^-//;
143    }goex;      $self->{option}->{$name} = $value;
144    $quoted_string;    }
145  }  }
146    
147  =head2 $self->delete_comment ($field_body)  =item $self->clone ()
148    
149  Remove all C<comment> in given strictured C<field-body>.  Returns a copy of Message::Field::Structured object.
 This method is intended for internal use.  
150    
151  =cut  =cut
152    
153  sub delete_comment ($$) {  sub clone ($) {
154    my $self = shift;    my $self = shift;
155    my $body = shift;    my $clone = ref($self)->new;
156    $body =~ s{($REG{quoted_string}|$REG{domain_literal})|$REG{comment}}{    for my $name (%{$self->{option}}) {
157      my $o = $1;  $o? $o : ' ';      if (ref $self->{option}->{$name} eq 'HASH') {
158    }gex;        $clone->{option}->{$name} = {%{$self->{option}->{$name}}};
159    $body;      } elsif (ref $self->{option}->{$name} eq 'ARRAY') {
160          $clone->{option}->{$name} = [@{$self->{option}->{$name}}];
161        } else {
162          $clone->{option}->{$name} = $self->{option}->{$name};
163        }
164      }
165      $clone->{field_body} = ref $self->{field_body}?
166                                 $self->{field_body}->clone:
167                                 $self->{field_body};
168      ## Common hash value (not used in this module)
169      $clone->{value} = ref $self->{value}?
170                            $self->{value}->clone:
171                            $self->{value};
172      for my $i (@{$self->{comment}}) {
173        if (ref $self->{comment}->[$i] eq 'HASH') {
174          $clone->{comment}->[$i] = {%{$self->{comment}->[$i]}};
175        } elsif (ref $self->{comment}->[$i] eq 'ARRAY') {
176          $clone->{comment}->[$i] = [@{$self->{comment}->[$i]}];
177        } else {
178          $clone->{comment}->[$i] = $self->{comment}->[$i];
179        }
180      }
181      $clone;
182  }  }
183    
184    
185  =head1 EXAMPLE  =head1 EXAMPLE
186    
187    use Message::Field::Structured;    use Message::Field::Structured;
# Line 202  sub delete_comment ($$) { Line 192  sub delete_comment ($$) {
192        
193    print $field->as_plain_string;    print $field->as_plain_string;
194    
195    =head1 SEE ALSO
196    
197    =over 4
198    
199    =item L<Message::Entity>, L<Message::Header>
200    
201    =item L<Message::Field::Unstructured>
202    
203    =item RFC 2822 E<lt>urn:ietf:rfc:2822E<gt>, usefor-article, HTTP/1.0, HTTP/1.1
204    
205    =back
206    
207  =head1 LICENSE  =head1 LICENSE
208    
209  Copyright 2002 wakaba E<lt>w@suika.fam.cxE<gt>.  Copyright 2002 wakaba E<lt>w@suika.fam.cxE<gt>.
# Line 224  Boston, MA 02111-1307, USA. Line 226  Boston, MA 02111-1307, USA.
226  =head1 CHANGE  =head1 CHANGE
227    
228  See F<ChangeLog>.  See F<ChangeLog>.
229    $Date$
230    
231  =cut  =cut
232    
Legend:
Removed from v.1.4  
changed lines
  Added in v.1.5
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24