/[suikacvs]/test/cvs

Diff of /test/cvs

Parent Directory | Revision Log | View Patch Patch

-revision 1.3 by wakaba,
Wed Mar 13 14:47:07 2002 UTC
+revision 1.18 by wakaba,
Tue May 14 13:50:11 2002 UTC
 Line 11 
 Perl module for RFC 822/2822 message C<h
  package Message::Header;
  use strict;
- use vars qw($VERSION %REG %DEFAULT);
+ use vars qw($VERSION %REG);
  $VERSION = '1.00';
+ use Carp ();
- use overload '@{}' => sub {shift->_delete_empty_field()->{field}},
+ use overload '@{}' => sub { shift->_delete_empty_field->{field} },
-              '""' => sub {shift->stringify};
+              '""' => sub { shift->stringify },
+              fallback => 1;
  $REG{WSP}     = qr/[\x09\x20]/;
  $REG{FWS}     = qr/[\x09\x20]*/;
-Line 44 
 when C<stringify>.  (Default = 0)
+Line 45 
 when C<stringify>.  (Default = 0)
  =cut
- %DEFAULT = (
+ =head1 CONSTRUCTORS
+ The following methods construct new C<Message::Header> objects:
+ =over 4
+ =cut
+ ## Initialize
+ my %DEFAULT = (
    capitalize    => 1,
+   fold  => 1,
    fold_length   => 70,
+   field_format_pattern  => '%s: %s',
+   #field_type   => {},
+   format        => 'mail-rfc2822',
+   linebreak_strict      => 0,
    mail_from     => 0,
+   output_bcc    => 0,
+   parse_all     => 0,
+   sort  => 'none',
+   translate_underscore  => 1,
+   uri_mailto_safe       => {
+         ## 1 all (no check)     2 no trace & bcc & from
+         ## 3 no sender's info   4 (default) (currently not used)
+         ## 5 only a few
+         ':default'      => 4,
+         'cc'    => 4,
+         'bcc'   => 1,
+         'body'  => 1,
+         'comment'       => 5,
+         'content-id'    => 1,
+         'date'  => 1,
+         'from'  => 1,
+         'keywords'      => 5,
+         'list-id'       => 1,
+         'mail-from'     => 1,
+         'message-id'    => 1,
+         'received'      => 1,
+         'resent-bcc'    => 1,
+         'resent-date'   => 1,
+         'resent-from'   => 1,
+         'resent-sender' => 1,
+         'return-path'   => 1,
+         'sender'        => 1,
+         'subject'       => 5,
+         'summary'       => 5,
+         'to'    => 4,
+         'user-agent'    => 3,
+         'x-face'        => 2,
+         'x-mailer'      => 3,
+         'x-nsubject'    => 5,
+         'x-received'    => 1,
+         'x400-received' => 1,
+         },
+   uri_mailto_safe_level => 4,
+   validate      => 1,
+ );
+ $DEFAULT{field_type} = {
+         ':DEFAULT'      => 'Message::Field::Unstructured',
+         received        => 'Message::Field::Received',
+         'x-received'    => 'Message::Field::Received',
+         'content-type'  => 'Message::Field::ContentType',
+         p3p     => 'Message::Field::Params',
+         'auto-submitted'        => 'Message::Field::ValueParams',
+         'content-disposition'   => 'Message::Field::ValueParams',
+         link    => 'Message::Field::ValueParams',
+         archive => 'Message::Field::ValueParams',
+         'x-face-type'   => 'Message::Field::ValueParams',
+         'x-mozilla-draft-info'  => 'Message::Field::ValueParams',
+         subject => 'Message::Field::Subject',
+         'x-nsubject'    => 'Message::Field::Subject',
+         'list-software' => 'Message::Field::UA',
+         'user-agent'    => 'Message::Field::UA',
+         server  => 'Message::Field::UA',
+         ## A message id
+         'content-id'    => 'Message::Field::MsgID',
+         'message-id'    => 'Message::Field::MsgID',
+         'resent-message-id'     => 'Message::Field::MsgID',
+         ## Numeric value
+         'content-length'        => 'Message::Field::Numval',
+         lines   => 'Message::Field::Numval',
+         'max-forwards'  => 'Message::Field::Numval',
+         'mime-version'  => 'Message::Field::Numval',
+         'x-jsmail-priority'     => 'Message::Field::Numval',
+         'x-mail-count'  => 'Message::Field::Numval',
+         'x-ml-count'    => 'Message::Field::Numval',
+         'x-priority'    => 'Message::Field::Numval',
+         path    => 'Message::Field::Path',
+ };
+ for (qw(archive cancel-lock content-features content-md5
+   disposition-notification-options encoding
+   importance injector-info
+   pics-label posted-and-mailed precedence list-id message-type
+   original-recipient priority x-list-id
+   sensitivity status x-face x-msmail-priority xref))
+   {$DEFAULT{field_type}->{$_} = 'Message::Field::Structured'}
+         ## Not supported yet, but to be supported...
+         # x-list: unstructured, ml name
+ for (qw(abuse-reports-to apparently-to approved approved-by bcc cc complaints-to
+   delivered-to disposition-notification-to envelope-to
+   errors-to  from mail-copies-to mail-followup-to mail-reply-to
+   notice-requested-upon-delivery-to read-receipt-to register-mail-reply-requested-by
+   reply-to resent-bcc
+   resent-cc resent-to resent-from resent-sender return-path
+   return-receipt-to return-receipt-requested-to sender to x-abuse-reports-to
+   x-admin x-approved
+   x-beenthere
+   x-confirm-reading-to
+   x-complaints-to x-envelope-from x-envelope-sender
+   x-envelope-to x-ml-address x-ml-command x-ml-to x-nfrom x-nto
+   x-rcpt-to x-sender x-x-sender))
+   {$DEFAULT{field_type}->{$_} = 'Message::Field::Address'}
+ for (qw(client-date date date-received delivery-date expires
+   expire-date nntp-posting-date posted posted-date received-date
+   reply-by resent-date
+   x-originalarrivaltime x-tcup-date))
+   {$DEFAULT{field_type}->{$_} = 'Message::Field::Date'}
+ for (qw(article-updates in-reply-to
+   obsoletes references replaces see-also supersedes))
+   {$DEFAULT{field_type}->{$_} = 'Message::Field::MsgIDs'}
+ for (qw(accept accept-charset accept-encoding accept-language
+   content-language
+   content-transfer-encoding encrypted followup-to keywords
+   list-archive list-digest list-help list-owner
+   list-post list-subscribe list-unsubscribe list-url uri newsgroups
+   posted-to))
+   {$DEFAULT{field_type}->{$_} = 'Message::Field::CSV'}
+ for (qw(x-brother x-boss x-classmate x-daughter x-dearfriend x-favoritesong
+   x-friend x-me
+   x-moe x-respect
+   x-sublimate x-son x-sister x-wife))
+   {$DEFAULT{field_type}->{$_} = 'Message::Field::CSV'}  ## NOT M::F::XMOE!
+ for (qw(content-alias content-base content-location location referer
+   url x-home-page x-http_referer
+   x-info x-pgp-key x-ml-url x-uri x-url x-web))
+   {$DEFAULT{field_type}->{$_} = 'Message::Field::URI'}
+ my %header_goodcase = (
+         'article-i.d.'  => 'Article-I.D.',
+         'content-id'    => 'Content-ID',
+         'content-md5'   => 'Content-MD5',
+         'content-sgml-entity'   => 'Content-SGML-Entity',
+         etag    => 'ETag',
+         fax     => 'FAX',
+         'pics-label'    => 'PICS-Label',
+         'list-url'      => 'List-URL',
+         'list-id'       => 'List-ID',
+         'message-id'    => 'Message-ID',
+         'mime-version'  => 'MIME-Version',
+         'nic'   => 'NIC',
+         'nntp-posting-date'     => 'NNTP-Posting-Date',
+         'nntp-posting-host'     => 'NNTP-Posting-Host',
+         'resent-message-id'     => 'Resent-Message-ID',
+         te      => 'TE',
+         url     => 'URL',
+         'www-authenticate'      => 'WWW-Authenticate',
+         'x-dearfriend'  => 'X-DearFriend',
+         'x-mime-autoconverted'  => 'X-MIME-Autoconverted',
+         'x-nntp-posting-date'   => 'X-NNTP-Posting-Date',
+         'x-nntp-posting-host'   => 'X-NNTP-Posting-Host',
+         'x-uri' => 'X-URI',
+         'x-url' => 'X-URL',
+ );
+ $DEFAULT{capitalize} = sub {
+   my $self = shift;
+   my $name = shift;
+   if ($header_goodcase{$name}) {
+     return $header_goodcase{$name};
+   }
+   $name =~ s/(?:^|-)cgi-/uc $&/ge;
+   $name =~ s/(?:^|-)[a-z]/uc $&/ge;
+   $name;
+ };
+ ## taken from L<HTTP::Header>
+ # "Good Practice" order of HTTP message headers:
+ #    - General-Headers
+ #    - Request-Headers
+ #    - Response-Headers
+ #    - Entity-Headers
+ # (From draft-ietf-http-v11-spec-rev-01, Nov 21, 1997)
+ my @header_order = qw(
+   mail-from x-envelope-from relay-version path status
+    cache-control connection date pragma transfer-encoding upgrade trailer via
+    accept accept-charset accept-encoding accept-language
+    authorization expect from host
+    if-modified-since if-match if-none-match if-range if-unmodified-since
+    max-forwards proxy-authorization range referer te user-agent
+    accept-ranges age location proxy-authenticate retry-after server vary
+    warning www-authenticate
+    mime-version
+    allow content-base content-encoding content-language content-length
+    content-location content-md5 content-range content-type
+    etag expires last-modified content-style-type content-script-type
+    link
+   xref
  );
+ my %header_order;
+ sub _init ($;%) {
+   my $self = shift;
+   my %options = @_;
+   $self->{field} = [];
+   $self->{option} = \%DEFAULT;
+   my @new_fields = ();
+   for my $name (keys %options) {
+     if (substr ($name, 0, 1) eq '-') {
+       $self->{option}->{substr ($name, 1)} = $options{$name};
+     } else {
+       push @new_fields, ($name => $options{$name});
+     }
+   }
+   $self->_init_by_format ($self->{option}->{format}, $self->{option});
+   # Make alternative representations of @header_order.  This is used
+   # for sorting.
+   my $i = 1;
+   for (@header_order) {
+       $header_order{$_} = $i++ unless $header_order{$_};
+   }
+   $self->add (@new_fields, -parse => $self->{option}->{parse_all})
+     if $#new_fields > -1;
+ }
+ sub _init_by_format ($$\%) {
+   my $self = shift;
+   my ($format, $option) = @_;
+   if ($format =~ /rfc822/) {
+     $header_goodcase{bcc} = 'bcc';
+     $header_goodcase{cc} = 'cc';
+     $header_goodcase{'resent-bcc'} = 'Resent-bcc';
+     $header_goodcase{'resent-cc'} = 'Resent-cc';
+   } elsif ($format =~ /cgi/) {
+     unshift @header_order, qw(content-type location);
+     $option->{sort} = 'good-practice';
+     $option->{fold} = 0;
+   } elsif ($format =~ /http/) {
+     $option->{sort} = 'good-practice';
+   }
+   if ($format =~ /uri-url-mailto/) {
+     $option->{output_bcc} = 0;
+     $option->{capitalize} = 0;
+     $option->{field_format_pattern} = '%s=%s';
+     $option->{fold} = sub {
+       $_[1] =~ s/([^:@+\$A-Za-z0-9\-_.!~*])/sprintf('%%%02X', ord $1)/ge;
+       $_[1];
+     };
+   }
+ }
+ =item Message::Header->new ([%initial-fields/options])
- =head2 Message::Header->new ([%option])
+ Constructs a new C<Message::Headers> object.  You might pass some initial
+ C<field-name>-C<field-body> pairs and/or options as parameters to the constructor.
- Returns new Message::Header instance.  Some options can be
+ Example:
- specified as hash.
+  $hdr = new Message::Headers
+         Date         => 'Thu, 03 Feb 1994 00:00:00 +0000',
+         Content_Type => 'text/html',
+         Content_Location => 'http://www.foo.example/',
+         -format => 'mail-rfc2822'       ## not to be header field
+         ;
  =cut
  sub new ($;%) {
    my $class = shift;
-   my $self = bless {option => {@_}}, $class;
+   my $self = bless {}, $class;
-   for (keys %DEFAULT) {$self->{option}->{$_} ||= $DEFAULT{$_}}
+   $self->_init (@_);
    $self;
  }
- =head2 Message::Header->parse ($header, [%option])
+ =item Message::Header->parse ($header, [%initial-fields/options])
- Parses given C<header> and return a new Message::Header
+ Parses given C<header> and constructs a new C<Message::Headers>
- object.  Some options can be specified as hash.
+ object.  You might pass some additional C<field-name>-C<field-body> pairs
+ or/and initial options as parameters to the constructor.
  =cut
  sub parse ($$;%) {
    my $class = shift;
    my $header = shift;
-   my $self = bless {option => {@_}}, $class;
+   my $self = bless {}, $class;
-   for (keys %DEFAULT) {$self->{option}->{$_} ||= $DEFAULT{$_}}
+   $self->_init (@_);    ## BUG: don't check linebreak_strict
-   $header =~ s/\x0D?\x0A$REG{WSP}+/\x20/gos;    ## unfold
+   $header =~ s/\x0D?\x0A$REG{WSP}/\x20/gos;     ## unfold
    for my $field (split /\x0D?\x0A/, $header) {
      if ($field =~ /$REG{M_fromline}/) {
-       push @{$self->{field}}, {name => 'mail-from', body => $1};
+       my $body = $1;
+       $body = $self->_field_body ($body, 'mail-from')
+         if $self->{option}->{parse_all};
+       push @{$self->{field}}, {name => 'mail-from', body => $body};
      } elsif ($field =~ /$REG{M_field}/) {
-       my ($name, $body) = ($1, $2);
+       my ($name, $body) = (lc $1, $2);
        $name =~ s/$REG{WSP}+$//;
        $body =~ s/$REG{WSP}+$//;
-       push @{$self->{field}}, {name => lc $name, body => $body};
+       $body = $self->_field_body ($body, $name) if $self->{option}->{parse_all};
+       push @{$self->{field}}, {name => $name, body => $body};
      }
    }
    $self;
  }
+ =item Message::Header->parse_array (\@header, [%initial-fields/options])
+ Parses given C<header> and constructs a new C<Message::Headers>
+ object.  Same as C<Message::Header-E<lt>parse> but this method
+ is given an array reference.  You might pass some additional
+ C<field-name>-C<field-body> pairs or/and initial options
+ as parameters to the constructor.
+ =cut
+ sub parse_array ($\@;%) {
+   my $class = shift;
+   my $header = shift;
+   Carp::croak "parse_array: first argument is not an array reference"
+     unless ref $header eq 'ARRAY';
+   my $self = bless {}, $class;
+   $self->_init (@_);
+   while (1) {
+     my $field = shift @$header;
+     while (1) {
+       if ($$header[0] =~ /^$REG{WSP}/) {
+         $field .= shift @$header;
+       } else {last}
+     }
+     if ($self->{option}->{linebreak_strict}) {
+       $field =~ s/\x0D\x0A//g;
+     } else {
+       $field =~ tr/\x0D\x0A//d;
+     }
+     if ($field =~ /$REG{M_fromline}/) {
+       my $body = $1;
+       $body = $self->_field_body ($body, 'mail-from')
+         if $self->{option}->{parse_all};
+       push @{$self->{field}}, {name => 'mail-from', body => $body};
+     } elsif ($field =~ /$REG{M_field}/) {
+       my ($name, $body) = (lc $1, $2);
+       $name =~ s/$REG{WSP}+$//;
+       $body =~ s/$REG{WSP}+$//;
+       $body = $self->_field_body ($body, $name) if $self->{option}->{parse_all};
+       push @{$self->{field}}, {name => $name, body => $body};
+     }
+     last if $#$header < 0;
+   }
+   $self;
+ }
+ =back
+ =head1 METHODS
  =head2 $self->field ($field_name)
  Returns C<field-body> of given C<field-name>.
-Line 106 
 sub field ($$) {
+Line 428 
 sub field ($$) {
    for my $field (@{$self->{field}}) {
      if ($field->{name} eq $name) {
        unless (wantarray) {
+         $field->{body} = $self->_field_body ($field->{body}, $name);
          return $field->{body};
        } else {
+         $field->{body} = $self->_field_body ($field->{body}, $name);
          push @ret, $field->{body};
        }
      }
    }
+   if ($#ret < 0) {
+     return $self->add ($name);
+   }
    @ret;
  }
+ sub field_exist ($$) {
+   my $self = shift;
+   my $name = lc shift;
+   my @ret;
+   for my $field (@{$self->{field}}) {
+     return 1 if ($field->{name} eq $name);
+   }
+;
+ }
  =head2 $self->field_name ($index)
  Returns C<field-name> of $index'th C<field>.
-Line 131 
 sub field_name ($$) {
+Line 468 
 sub field_name ($$) {
  }
  sub field_body ($$) {
    my $self = shift;
-   $self->{field}->[shift]->{body};
+   my $i = shift;
+   $self->{field}->[$i]->{body}
+    = $self->_field_body ($self->{field}->[$i]->{body}, $self->{field}->[$i]->{name});
+   $self->{field}->[$i]->{body};
+ }
+ sub _field_body ($$$) {
+   my $self = shift;
+   my ($body, $name) = @_;
+   unless (ref $body) {
+     my $type = $self->{option}->{field_type}->{$name}
+             || $self->{option}->{field_type}->{':DEFAULT'};
+     eval "require $type" or Carp::croak ("_field_body: $type: $@");
+     unless ($body) {
+       $body = $type->new (-field_name => $name,
+         -format => $self->{option}->{format},
+         -parse_all => $self->{option}->{parse_all},
+         field_name => $name, format => $self->{option}->{format});
+     } else {
+       $body = $type->parse ($body, -field_name => $name,
+         -format => $self->{option}->{format},
+         -parse_all => $self->{option}->{parse_all},
+          field_name => $name,format => $self->{option}->{format});
+     }
+   }
+   $body;
  }
  =head2 $self->field_name_list ()
-Line 148 
 sub field_name_list ($) {
+Line 510 
 sub field_name_list ($) {
    map {$_->{name}} @{$self->{field}};
  }
- =head2 $self->add ($field_name, $field_body)
+ =item $hdr->add ($field-name, $field-body, [$name, $body, ...])
- Adds an new C<field>.  It is not checked whether
+ Adds some field name/body pairs.  Even if there are
- the field which named $field_body is already exist or not.
+ one or more fields named given C<$field-name>,
- If you don't want duplicated C<field>s, use C<replace> method.
+ given name/body pairs are ADDed.  Use C<replace>
+ to remove same-name-fields.
+ Instead of field name-body pair, you might pass some options.
+ Four options are available for this method.
+ C<-parse>: Parses and validates C<field-body>, and returns
+ C<field-body> object.  (When multiple C<field-body>s are
+ added, returns only last one.)  (Default: C<defined wantarray>)
+ C<-prepend>: New fields are not appended,
+ but prepended to current fields.  (Default: C<0>)
+ C<-translate-underscore>: Do C<field-name> =~ tr/_/-/.  (Default: C<1>)
+ C<-validate>: Checks whether C<field-name> is valid or not.
  =cut
- sub add ($$$) {
+ sub add ($%) {
    my $self = shift;
-   my ($name, $body) = (lc shift, shift);
+   my %fields = @_;
-   return 0 if $name =~ /$REG{UNSAFE_field_name}/;
+   my %option = %{$self->{option}};
-   push @{$self->{field}}, {name => $name, body => $body};
+   $option{parse} = 1 if defined wantarray;
-   $self;
+   for (grep {/^-/} keys %fields) {$option{substr ($_, 1)} = $fields{$_}}
+   my $body;
+   for (grep {/^[^-]/} keys %fields) {
+     my $name = lc $_;  $body = $fields{$_};
+     $name =~ tr/_/-/ if $option{translate_underscore};
+     Carp::croak "add: $name: invalid field-name"
+       if $option{validate} && $name =~ /$REG{UNSAFE_field_name}/;
+     $body = $self->_field_body ($body, $name) if $option{parse};
+     if ($option{prepend}) {
+       unshift @{$self->{field}}, {name => $name, body => $body};
+     } else {
+       push @{$self->{field}}, {name => $name, body => $body};
+     }
+   }
+   $body if $option{parse};
  }
  =head2 $self->relace ($field_name, $field_body)
-Line 174 
 first one is used and the others are not
+Line 565 
 first one is used and the others are not
  =cut
- sub replace ($$$) {
+ sub replace ($%) {
    my $self = shift;
-   my ($name, $body) = (lc shift, shift);
+   my %params = @_;
-   return 0 if $name =~ /$REG{UNSAFE_field_name}/;
+   my %option = %{$self->{option}};
+   $option{parse} = defined wantarray unless defined $option{parse};
+   for (grep {/^-/} keys %params) {$option{substr ($_, 1)} = $params{$_}}
+   my (%new_field);
+   for (grep {/^[^-]/} keys %params) {
+     my $name = lc $_;
+     $name =~ tr/_/-/ if $option{translate_underscore};
+     Carp::croak "replace: $name: invalid field-name"
+       if $option{validate} && $name =~ /$REG{UNSAFE_field_name}/;
+     $params{$_} = $self->_field_body ($params{$_}, $name) if $option{parse};
+     $new_field{$name} = $params{$_};
+   }
+   my $body = (%new_field)[-1];
    for my $field (@{$self->{field}}) {
-     if ($field->{name} eq $name) {
+     if (defined $new_field{$field->{name}}) {
-       $field->{body} = $body;
+       $field->{body} = $new_field {$field->{name}};
-       return $self;
+       $new_field{$field->{name}} = undef;
      }
    }
-   push @{$self->{field}}, {name => $name, body => $body};
+   for (keys %new_field) {
-   $self;
+     push @{$self->{field}}, {name => $_, body => $new_field{$_}};
+   }
+   $body if $option{parse};
  }
- =head2 $self->delete ($field_name, [$index])
+ =head2 $self->delete ($field-name, [$name, ...])
  Deletes C<field> named as $field_name.
- If $index is specified, only $index'th C<field> is deleted.
- If not, ($index == 0), all C<field>s that have the C<field-name>
- $field_name are deleted.
  =cut
- sub delete ($$;$) {
+ sub delete ($@) {
    my $self = shift;
-   my ($name, $index) = (lc shift, shift);
+   my %delete;  for (@_) {$delete{lc $_} = 1}
-   my $i = 0;
    for my $field (@{$self->{field}}) {
-     if ($field->{name} eq $name) {
+     undef $field if $delete{$field->{name}};
-       $i++;
-       if ($index == 0 || $i == $index) {
-         undef $field;
-         return $self if $i == $index;
-       }
-     }
    }
-   $self;
  }
  =head2 $self->count ([$field_name])
-Line 237 
 sub count ($;$) {
+Line 631 
 sub count ($;$) {
    $count;
  }
+ =head2 $self->rename ($field-name, $new-name, [$old, $new,...])
+ Renames C<$field-name> as C<$new-name>.
+ =cut
+ sub rename ($%) {
+   my $self = shift;
+   my %params = @_;
+   my %option = %{$self->{option}};
+   for (grep {/^-/} keys %params) {$option{substr ($_, 1)} = $params{$_}}
+   my %new_name;
+   for (grep {/^[^-]/} keys %params) {
+     my ($old => $new) = (lc $_ => lc $params{$_});
+     $new =~ tr/_/-/ if $option{translate_underscore};
+     Carp::croak "rename: $new: invalid field-name"
+       if $option{validate} && $new =~ /$REG{UNSAFE_field_name}/;
+     $new_name{$old} = $new;
+   }
+   for my $field (@{$self->{field}}) {
+     if (length $new_name{$field->{name}}) {
+       $field->{name} = $new_name{$field->{name}};
+     }
+   }
+   $self if defined wantarray;
+ }
+ =item $self->scan(\&doit)
+ Apply a subroutine to each header field in turn.  The callback routine is
+ called with two parameters; the name of the field and a single value.
+ If the header has more than one value, then the routine is called once
+ for each value.
+ =cut
+ sub scan ($&) {
+   my ($self, $sub) = @_;
+   my $sort;
+   $sort = \&_header_cmp if $self->{option}->{sort} eq 'good-practice';
+   $sort = {$a cmp $b} if $self->{option}->{sort} eq 'alphabetic';
+   my @field = @{$self->{field}};
+   if (ref $sort) {
+     @field = sort $sort @{$self->{field}};
+   }
+   for my $field (@field) {
+     next if $field->{name} =~ /^_/;
+     &$sub($field->{name} => $field->{body});
+   }
+ }
+ # Compare function which makes it easy to sort headers in the
+ # recommended "Good Practice" order.
+ ## taken from HTTP::Header
+ sub _header_cmp
+ {
+   my ($na, $nb) = ($a->{name}, $b->{name});
+     # Unknown headers are assign a large value so that they are
+     # sorted last.  This also helps avoiding a warning from -w
+     # about comparing undefined values.
+     $header_order{$na} = 999 unless defined $header_order{$na};
+     $header_order{$nb} = 999 unless defined $header_order{$nb};
+     $header_order{$na} <=> $header_order{$nb} || $na cmp $nb;
+ }
  =head2 $self->stringify ([%option])
  Returns the C<header> as a string.
-Line 245 
 Returns the C<header> as a string.
+Line 706 
 Returns the C<header> as a string.
  sub stringify ($;%) {
    my $self = shift;
-   my %OPT = @_;
+   my %params = @_;
+   my %option = %{$self->{option}};
+   $option{format} = $params{-format} if $params{-format};
+   $self->_init_by_format ($option{format}, \%option);
+   for (grep {/^-/} keys %params) {$option{substr ($_, 1)} = $params{$_}}
    my @ret;
-   $OPT{capitalize} ||= $self->{option}->{capitalize};
+   my $_stringify = sub {
-   $OPT{mail_from} ||= $self->{option}->{mail_from};
+       my ($name, $body) = (@_);
-   push @ret, 'From '.$self->field ('mail-from') if $OPT{mail_from};
+       return unless length $name;
-   for my $field (@{$self->{field}}) {
+       return if $option{mail_from} && $name eq 'mail-from';
-     my $name = $field->{name};
+       return if !$option{output_bcc} && ($name eq 'bcc' || $name eq 'resent-bcc');
-     next unless $field->{name};
+       if ($option{format} =~ /uri-url-mailto/) {
-     next if !$OPT{mail_from} && $name eq 'mail-from';
+         return if ((   $option{uri_mailto_safe}->{$name}
-     $name =~ s/((?:^|-)[a-z])/uc($1)/ge if $OPT{capitalize};
+              || $option{uri_mailto_safe}->{':default'})
-     push @ret, $name.': '.$self->fold ($field->{body});
+               < $option{uri_mailto_safe_level});
+         if ($name eq 'to') {
+           $body = $self->field ('to');
+           return unless ref $body && $body->have_group;
+         }
+       }
+       my $fbody;
+       if (ref $body) {
+         $fbody = $body->stringify (-format => $option{format});
+       } else {
+         $fbody = $body;
+       }
+       return unless length $fbody;
+       unless ($option{linebreak_strict}) {
+         ## bare \x0D and bare \x0A are unsafe
+         $fbody =~ s/\x0D(?=[^\x09\x0A\x20])/\x0D\x20/g;
+         $fbody =~ s/\x0A(?=[^\x09\x20])/\x0A\x20/g;
+       } else {
+         $fbody =~ s/\x0D\x0A(?=[^\x09\x20])/\x0D\x0A\x20/g;
+       }
+       if (ref $option{capitalize}) {
+         $name = &{$option{capitalize}} ($self, $name);
+       } elsif ($option{capitalize}) {
+         $name =~ s/((?:^|-)[a-z])/uc($1)/ge;
+       }
+       if (ref $option{fold}) {
+         $fbody = &{$option{fold}} ($self, $fbody);
+       } elsif ($option{fold}) {
+         $fbody = $self->_fold ($fbody);
+       }
+       push @ret, sprintf $option{field_format_pattern}, $name, $fbody;
+     };
+   if ($option{format} =~ /uri-url-mailto-to/) {
+     if ($self->field_exist ('to')) {
+       my $to = $self->field ('to');
+       unless ($to->have_group) {
+         my $fbody = $to->stringify (-format => $option{format});
+         return &{$option{fold}} ($self, $fbody);
+       }
+     }
+     '';
+   } elsif ($option{format} =~ /uri-url-mailto/) {
+     $self->scan ($_stringify);
+     my $ret = join ('&', @ret);
+     $ret;
+   } else {
+     if ($option{mail_from}) {
+       my $fromline = $self->field ('mail-from');
+       push @ret, 'From '.$fromline if $fromline;
+     }
+     $self->scan ($_stringify);
+     my $ret = join ("\n", @ret);
+     $ret? $ret."\n": '';
    }
-   my $ret = join ("\n", @ret);
-   $ret? $ret."\n": "";
  }
+ *as_string = \&stringify;
- =head2 $self->get_option ($option_name)
+ =head2 $self->option ($option_name, [$option_value])
- Returns value of the option.
- =head2 $self->set_option ($option_name, $option_value)
- Set new value of the option.
+ Set/gets new value of the option.
  =cut
- sub get_option ($$) {
+ sub option ($@) {
    my $self = shift;
-   my ($name) = @_;
+   if (@_ == 1) {
-   $self->{option}->{$name};
+     return $self->{option}->{ shift (@_) };
+   }
+   while (my ($name, $value) = splice (@_, 0, 2)) {
+     $name =~ s/^-//;
+     $self->{option}->{$name} = $value;
+     if ($name eq 'format') {
+       for my $f (@{$self->{field}}) {
+         if (ref $f->{body}) {
+           $f->{body}->option (-format => $value);
+         }
+       }
+     }
+   }
  }
- sub set_option ($$$) {
+ sub field_type ($$;$) {
    my $self = shift;
-   my ($name, $value) = @_;
+   my $field_name = shift;
-   $self->{option}->{$name} = $value;
+   my $new_field_type = shift;
-   $self;
+   if ($new_field_type) {
+     $self->{option}->{field_type}->{$field_name} = $new_field_type;
+   }
+   $self->{option}->{field_type}->{$field_name}
+   || $self->{option}->{field_type}->{':DEFAULT'};
  }
  sub _delete_empty_field ($) {
-Line 293 
 sub _delete_empty_field ($) {
+Line 822 
 sub _delete_empty_field ($) {
    $self;
  }
- sub fold ($$;$) {
+ sub _fold ($$;$) {
    my $self = shift;
    my $string = shift;
    my $len = shift || $self->{option}->{fold_length};
-Line 311 
 sub fold ($$;$) {
+Line 840 
 sub fold ($$;$) {
       # next split a whitespace
       # else we are looking at a single word and probably don't want to split
       my $x = "";
-      $x .= "$1\n    "
+      $x .= "$1\n "
         while($string =~ s/^$REG{WSP}*(
                            [^"]{$min,$max}?[\,\;]
                            |[^"]{1,$max}$REG{WSP}
-Line 327 
 sub fold ($$;$) {
+Line 856 
 sub fold ($$;$) {
    $string;
  }
+ =head2 $self->clone ()
+ Returns a copy of Message::Header object.
+ =cut
+ sub clone ($) {
+   my $self = shift;
+   my $clone = new Message::Header;
+   for my $name (%{$self->{option}}) {
+     if (ref $self->{option}->{$name} eq 'HASH') {
+       $clone->{option}->{$name} = {%{$self->{option}->{$name}}};
+     } elsif (ref $self->{option}->{$name} eq 'ARRAY') {
+       $clone->{option}->{$name} = [@{$self->{option}->{$name}}];
+     } else {
+       $clone->{option}->{$name} = $self->{option}->{$name};
+     }
+   }
+   for (@{$self->{field}}) {
+     $clone->add ($_->{name}, scalar $_->{body});
+   }
+   $clone;
+ }
+ =head1 NOTE
+ =head2 C<field-name>
+ The header field name is not case sensitive.  To make the life
+ easier for perl users who wants to avoid quoting before the => operator,
+ you can use '_' as a synonym for '-' in header field names
+ (this behaviour can be suppressed by setting
+ C<translate_underscore> option to C<0> value).
  =head1 EXAMPLE
    ## Print field list
-Line 334 
 sub fold ($$;$) {
+Line 897 
 sub fold ($$;$) {
    use Message::Header;
    my $header = Message::Header->parse ($header);
-   ## Next sample is better.
-   #for my $field (@$header) {
-   #  print $field->{name}, "\t=> ", $field->{body}, "\n";
-   #}
    for my $i (0..$#$header) {
      print $header->field_name ($i), "\t=> ", $header->field_body ($i), "\n";
    }
-Line 361 
 sub fold ($$;$) {
+Line 919 
 sub fold ($$;$) {
    $header->add ('References' => '<hoge.msgid%foo@foo.example>');
    print $header;
+ =head1 ACKNOWLEDGEMENTS
+ Some of codes are taken from other modules such as
+ HTTP::Header, Mail::Header.
  =head1 LICENSE
  Copyright 2002 wakaba E<lt>w@suika.fam.cxE<gt>.

 Legend:



Removed from v.1.3
 


changed lines


 
Added in v.1.18
 Legend:



Removed from v.1.3
 


changed lines


 
Added in v.1.18
-Removed from v.1.3
+Added in v.1.18

admin@suikawiki.org	ViewVC Help
Powered by ViewVC 1.1.24