lib/Message/Entity.pm


=head1 NAME

Message::Entity Perl module

=head1 DESCRIPTION

Perl module for RFC 822/2822 C<message>.
MIME multipart will be also supported (but not implemented yet).

=cut

package Message::Entity;
use strict;
use vars qw($VERSION);
$VERSION=do{my @r=(q$Revision: 1.8 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};

require Message::Header;
require Message::Util;
use overload '""' => sub { $_[0]->stringify },
             fallback => 1;

sub _init ($;%) {
  my $self = shift;
  my %options = @_;
  $self->{option} = {
    add_ua      => 1,
    body_class  => {'/DEFAULT' => 'Message::Body::TextPlain'},
    #fill_date  => 1,
    #fill_msgid => 1,
    format      => 'mail-rfc2822',
    parse_all   => 0,
    #ua_field_name      => 'user-agent',
    ua_use_config       => 1,
  };
  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, (lc $name => $options{$name});
    }
  }
  my $format = $self->{option}->{format};
  unless (defined $self->{option}->{fill_date}) {
    $self->{option}->{fill_date} = $format !~ /^cgi/;
  }
  unless (defined $self->{option}->{fill_msgid}) {
    $self->{option}->{fill_msgid} = $format !~ /^(?:cgi|http)/;
  }
  unless (defined $self->{option}->{fill_mimever}) {
    $self->{option}->{fill_mimever} = $format !~ /^(?:cgi|http)/;
  }
  unless (length $self->{option}->{ua_field_name}) {
    $self->{option}->{ua_field_name} = $format =~ /^(?:http-response|cgi)/?
      'server': 'user-agent';
  }
  @new_fields;
}

=head1 CONSTRUCTORS

The following methods construct new C<Message::Entity> objects:

=over 4

=item Message::Entity->new ([%initial-fields/options])

Constructs a new C<Message::Entity> object.  You might pass some initial
C<field-name>-C<field-body> pairs and/or options as parameters to the constructor.

Example:

 $msg = new Message::Entity
        Date         => 'Thu, 03 Feb 1994 00:00:00 +0000',
        Content_Type => 'text/html',
        X_URI => '<http://www.foo.example/>',
        -format => 'mail-rfc2822'       ## not to be header field
        ;

=cut

sub new ($;%) {
  my $class = shift;
  my $self = bless {}, $class;
  my %new_field = $self->_init (@_);
  if (length $new_field{body}) {
    $self->{body} = $new_field{body};  $new_field{body} = undef;
    $self->{body} = $self->_body ($self->{body}, $self->content_type)
      if $self->{option}->{parse_all};
  }
  $self->{header} = new Message::Header -format => $self->{option}->{format},
    -parse_all => $self->{option}->{parse_all}, %new_field;
  $self;
}

=item Message::Entity->parse ($message, [%options])

Parses given C<message> (a message entity) and constructs a new C<Message::Entity>
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 $message = shift;
  my $self = bless {}, $class;
  my %new_field = $self->_init (@_);
  my @header = ();
  my @body = split /\x0D?\x0A/, $message;       ## BUG: not binary-clean...
  while (1) {
    my $line = shift @body;
    unless (length($line)) {
      last;
    } else {
      push @header, $line;
    }
  }
  $new_field{body} = undef if $new_field{body};
  $self->{header} = parse_array Message::Header \@header,
    -parse_all => $self->{option}->{parse_all},
    -format => $self->{option}->{format}, %new_field;
  $self->{body} = join "\n", @body;
  $self->{body} = $self->_body ($self->{body}, $self->content_type)
    if $self->{option}->{parse_all};
  $self;
}

=back

=head1 METHODS

=head2 $self->header ([$new_header])

Returns Message::Header unless $new_header.
Set $new_header instead of current C<header>.
If !ref $new_header, Message::Header->parse is automatically
called.

=cut

## TODO: to be compatible with HTTP::Message
sub header ($;$) {
  my $self = shift;
  my $new_header = shift;
  if (ref $new_header) {
    $self->{header} = $new_header;
  } elsif ($new_header) {
    $self->{header} = Message::Header->parse ($new_header,
      -parse_all => $self->{option}->{parse_all},
      -format => $self->{option}->{format});
  }
  unless ($self->{header}) {
    $self->{header} = new Message::Header (-format => $self->{option}->{format});
  }
  $self->{header};
}

=head2 $self->body ([$new_body])

Returns C<body> as string unless $new_body.
Set $new_body instead of current C<body>.

=cut

sub body ($;$) {
  my $self = shift;
  my $new_body = shift;
  if ($new_body) {
    $self->{body} = $new_body;
  }
  $self->{body} = $self->_body ($self->{body}, $self->content_type)
    unless ref $self->{body};
  $self->{body};
}

sub _body ($;$$) {
  my $self = shift;
  my $body = shift;
  my $ct = shift;
  $ct = $self->{option}->{body_class}->{$ct}
     || $self->{option}->{body_class}->{'/DEFAULT'};
  eval "require $ct";
  if (ref $body) {
    return $body;
  } elsif ($body) {
    return $ct->parse ($body,
      -parse_all => $self->{option}->{parse_all});
  } else {
    return $ct->new ($body);
  }
}

=head2 $self->stringify ([%option])

Returns the C<message> as a string.

=cut

sub stringify ($;%) {
  my $self = shift;
  my %params = @_;
  my %option = %{$self->{option}};
  for (grep {/^-/} keys %params) {$option{substr ($_, 1)} = $params{$_}}
    my ($header, $body);
    if (ref $self->{header}) {
      my %exist;
      for ($self->{header}->field_name_list) {$exist{$_} = 1}
      if ($option{fill_date} && !$exist{'date'}) {
        $self->{header}->field ('date')->unix_time (time);
      }
    if ($option{fill_msgid} && !$exist{'message-id'}) {
      my $from = $self->{header}->field ('from')->addr_spec (1);
      $self->{header}->field ('message-id')->add_new (addr_spec => $from)
        if $from;
    }
    if ($option{fill_mimever} && !$exist{'mime-version'}) {
      ## BUG: rfc1049...
      my $ismime = 0;
      for (keys %exist) {if (/^content-/) {$ismime = 1; last}}
      if ($ismime) {
        $self->{header}->add ('mime-version' => '1.0', -parse => 0);
      }
    }
    $self->_add_ua_field;
    $header = $self->{header}->stringify (-format => $option{format});
  } else {
    $header = $self->{header};
    $header =~ s/\x0D(?=[^\x09\x0A\x20])/\x0D\x20-/g;
    $header =~ s/\x0A(?=[^\x09\x20])/\x0A\x20-/g;
  }
  if (ref $self->{body}) {
    $body = $self->{body}->stringify (-format => $option{format});
  } else {
    $body = $self->{body};
  }
  $header .= "\n" if $header && $header !~ /\n$/;
  $header."\n".$body;
}
*as_string = \&stringify;


=head1 SHORTCUT METHOD FOR MESSAGE PROPERTIES

=over 4

=item $self->content_type ([%options])

Returns Internet media type of message body
(aka MIME type, content type).  Only media type
(type/subtype pair) is returned, i.e. no parameter
is returned, if any.  To get such value, or to set
new value, use C<field> method.

Default is C<text/plain>.

Example:

  $msg->field ('Content-Type')->media_type ('text/html');
  print $msg->content_type;     ## text/html

=cut

sub content_type ($;%) {
  my $self = shift;
  return scalar $self->{header}->field ('content-type')->media_type
    if $self->{header}->field_exist ('content-type');
  'text/plain';
}

=item $self->id

Returns ID of message entity.  If there are C<Message-ID:>
field, its value is returned.  Unless, but there are
C<Content-ID:> field, it is returned.  Without both of
fields, C<""> is returned.

=cut

sub id ($) {
  my $self = shift;
  return scalar $self->{header}->field ('message-id')->id
    if $self->{header}->field_exist ('message-id');
  return scalar $self->{header}->field ('content-id')->id
    if $self->{header}->field_exist ('content-id');
  '';
}

## Internal function for addition of User-Agent: C<product>.
sub _add_ua_field ($) {
  my $self = shift;
  if ($self->{option}->{add_ua}) {
    my $ua = $self->{header}->field ($self->{option}->{ua_field_name});
    $ua->replace (name => 'Message-pm', version => $VERSION, add_prepend => -1);
    my @os;
    my @perl_comment;
    if ($self->{option}->{ua_use_config}) {
      eval q{use Config;
        @os = (name => $^O, version => $Config{osvers}, add_prepend => -1);
        push @perl_comment, $Config{archname};
      };
    } else {
      push @perl_comment, $^O;
    }
    if ($^V) {  ## 5.6 or later
      $ua->replace (name => 'Perl', version => sprintf ('%vd', $^V),
                    comment => [@perl_comment], add_prepend => -1);
    } elsif ($]) {      ## Before 5.005
      $ua->replace (name => 'Perl', version => $],
                    comment => [@perl_comment], add_prepend => -1);
    }
    $ua->replace (@os) if $self->{option}->{ua_use_config};
  }
  $self;
}

=back

=head1 MISC. METHODS

=over 4

=item $self->option ( $option-name / $option-name, $option-value, ...)

If @_ == 1, returns option value.  Else...

Set option value.  You can pass multiple option name-value pair
as parameter.  Example:

  $msg->option (-format => 'mail-rfc822',
                -capitalize => 0);
  print $msg->option ('-format');       ## mail-rfc822

Note that introduction character, i.e. C<-> (HYPHEN-MINUS)
is optional.  You can also write as this:

  $msg->option (format => 'mail-rfc822',
                capitalize => 0);
  print $msg->option ('format');        ## mail-rfc822

=cut

sub option ($@) {
  my $self = shift;
  if (@_ == 1) {
    return $self->{option}->{ $_[0] };
  }
  while (my ($name, $value) = splice (@_, 0, 2)) {
    $name =~ s/^-//;
    $self->{option}->{$name} = $value;
    if ($name eq 'format') {
      $self->header->option (-format => $value);
    }
  }
}

=item $self->clone ()

Returns a copy of Message::Entity object.

=cut

sub clone ($) {
  my $self = shift;
  my $clone = new Message::Entity;
  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};
    }
  }
  $clone->{header} = ref $self->{header}? $self->{header}->clone: $self->{header};
  $clone->{body} = ref $self->{body}? $self->{body}->clone: $self->{body};
  $clone;
}

=back

=head1 EXAMPLE

  use Message::Entity;
  my $msg = new Message::Entity From    => '[email protected]',
                                Subject => 'Example message',
                                To      => '[email protected]',
                                -format => 'mail-rfc2822',
                                body    => $body;
  $msg->header ($header);
  $msg->body ($body);
  print $msg;

=head1 SEE ALSO

Message::* Perl modules
<http://suika.fam.cx/~wakaba/Message-pm/>

=head1 LICENSE

Copyright 2002 wakaba E<lt>[email protected]<gt>.

This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program; see the file COPYING.  If not, write to
the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
Boston, MA 02111-1307, USA.

=head1 CHANGE

See F<ChangeLog>.
$Date: 2002/04/03 13:31:36 $

=cut

1;
1	wakaba	1.1
2			=head1 NAME
3
4			Message::Entity Perl module
5
6			=head1 DESCRIPTION
7
8			Perl module for RFC 822/2822 C<message>.
9			MIME multipart will be also supported (but not implemented yet).
10
11			=cut
12
13			package Message::Entity;
14			use strict;
15	wakaba	1.8	use vars qw($VERSION);
16	wakaba	1.9	$VERSION=do{my @r=(q$Revision: 1.8 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
17	wakaba	1.1
18	wakaba	1.8	require Message::Header;
19			require Message::Util;
20	wakaba	1.9	use overload '""' => sub { $_[0]->stringify },
21			fallback => 1;
22	wakaba	1.1
23	wakaba	1.8	sub _init ($;%) {
24			my $self = shift;
25			my %options = @_;
26			$self->{option} = {
27			add_ua => 1,
28			body_class => {'/DEFAULT' => 'Message::Body::TextPlain'},
29			#fill_date => 1,
30			#fill_msgid => 1,
31			format => 'mail-rfc2822',
32			parse_all => 0,
33			#ua_field_name => 'user-agent',
34			ua_use_config => 1,
35			};
36			my @new_fields = ();
37			for my $name (keys %options) {
38			if (substr ($name, 0, 1) eq '-') {
39			$self->{option}->{substr ($name, 1)} = $options{$name};
40			} else {
41			push @new_fields, (lc $name => $options{$name});
42			}
43			}
44			my $format = $self->{option}->{format};
45			unless (defined $self->{option}->{fill_date}) {
46			$self->{option}->{fill_date} = $format !~ /^cgi/;
47			}
48			unless (defined $self->{option}->{fill_msgid}) {
49			$self->{option}->{fill_msgid} = $format !~ /^(?:cgi\|http)/;
50			}
51			unless (defined $self->{option}->{fill_mimever}) {
52			$self->{option}->{fill_mimever} = $format !~ /^(?:cgi\|http)/;
53			}
54			unless (length $self->{option}->{ua_field_name}) {
55			$self->{option}->{ua_field_name} = $format =~ /^(?:http-response\|cgi)/?
56			'server': 'user-agent';
57			}
58			@new_fields;
59			}
60
61			=head1 CONSTRUCTORS
62
63			The following methods construct new C<Message::Entity> objects:
64	wakaba	1.3
65	wakaba	1.8	=over 4
66
67	wakaba	1.9	=item Message::Entity->new ([%initial-fields/options])
68	wakaba	1.1
69	wakaba	1.9	Constructs a new C<Message::Entity> object. You might pass some initial
70			C<field-name>-C<field-body> pairs and/or options as parameters to the constructor.
71
72			Example:
73
74			$msg = new Message::Entity
75			Date => 'Thu, 03 Feb 1994 00:00:00 +0000',
76			Content_Type => 'text/html',
77			X_URI => '<http://www.foo.example/>',
78			-format => 'mail-rfc2822' ## not to be header field
79			;
80	wakaba	1.1
81			=cut
82
83			sub new ($;%) {
84			my $class = shift;
85	wakaba	1.8	my $self = bless {}, $class;
86			my %new_field = $self->_init (@_);
87			if (length $new_field{body}) {
88			$self->{body} = $new_field{body}; $new_field{body} = undef;
89			$self->{body} = $self->_body ($self->{body}, $self->content_type)
90			if $self->{option}->{parse_all};
91			}
92			$self->{header} = new Message::Header -format => $self->{option}->{format},
93			-parse_all => $self->{option}->{parse_all}, %new_field;
94	wakaba	1.1	$self;
95			}
96
97	wakaba	1.9	=item Message::Entity->parse ($message, [%options])
98	wakaba	1.1
99	wakaba	1.9	Parses given C<message> (a message entity) and constructs a new C<Message::Entity>
100			object. You might pass some additional C<field-name>-C<field-body> pairs
101			or/and initial options as parameters to the constructor.
102	wakaba	1.8
103	wakaba	1.1	=cut
104
105			sub parse ($$;%) {
106			my $class = shift;
107			my $message = shift;
108	wakaba	1.8	my $self = bless {}, $class;
109			my %new_field = $self->_init (@_);
110			my @header = ();
111			my @body = split /\x0D?\x0A/, $message; ## BUG: not binary-clean...
112			while (1) {
113			my $line = shift @body;
114			unless (length($line)) {
115			last;
116	wakaba	1.1	} else {
117	wakaba	1.8	push @header, $line;
118	wakaba	1.1	}
119			}
120	wakaba	1.8	$new_field{body} = undef if $new_field{body};
121			$self->{header} = parse_array Message::Header \@header,
122			-parse_all => $self->{option}->{parse_all},
123			-format => $self->{option}->{format}, %new_field;
124	wakaba	1.1	$self->{body} = join "\n", @body;
125	wakaba	1.4	$self->{body} = $self->_body ($self->{body}, $self->content_type)
126	wakaba	1.8	if $self->{option}->{parse_all};
127	wakaba	1.1	$self;
128			}
129
130	wakaba	1.9	=back
131
132	wakaba	1.8	=head1 METHODS
133
134	wakaba	1.1	=head2 $self->header ([$new_header])
135
136			Returns Message::Header unless $new_header.
137			Set $new_header instead of current C<header>.
138			If !ref $new_header, Message::Header->parse is automatically
139			called.
140
141			=cut
142
143	wakaba	1.9	## TODO: to be compatible with HTTP::Message
144	wakaba	1.1	sub header ($;$) {
145			my $self = shift;
146			my $new_header = shift;
147			if (ref $new_header) {
148			$self->{header} = $new_header;
149			} elsif ($new_header) {
150	wakaba	1.4	$self->{header} = Message::Header->parse ($new_header,
151	wakaba	1.8	-parse_all => $self->{option}->{parse_all},
152			-format => $self->{option}->{format});
153	wakaba	1.1	}
154	wakaba	1.2	unless ($self->{header}) {
155	wakaba	1.8	$self->{header} = new Message::Header (-format => $self->{option}->{format});
156	wakaba	1.2	}
157	wakaba	1.1	$self->{header};
158			}
159
160			=head2 $self->body ([$new_body])
161
162			Returns C<body> as string unless $new_body.
163			Set $new_body instead of current C<body>.
164
165			=cut
166
167			sub body ($;$) {
168			my $self = shift;
169			my $new_body = shift;
170			if ($new_body) {
171			$self->{body} = $new_body;
172			}
173	wakaba	1.3	$self->{body} = $self->_body ($self->{body}, $self->content_type)
174			unless ref $self->{body};
175	wakaba	1.1	$self->{body};
176			}
177
178	wakaba	1.3	sub _body ($;$$) {
179			my $self = shift;
180			my $body = shift;
181			my $ct = shift;
182			$ct = $self->{option}->{body_class}->{$ct}
183			\|\| $self->{option}->{body_class}->{'/DEFAULT'};
184			eval "require $ct";
185			if (ref $body) {
186			return $body;
187			} elsif ($body) {
188	wakaba	1.4	return $ct->parse ($body,
189	wakaba	1.8	-parse_all => $self->{option}->{parse_all});
190	wakaba	1.3	} else {
191			return $ct->new ($body);
192			}
193			}
194
195	wakaba	1.1	=head2 $self->stringify ([%option])
196
197			Returns the C<message> as a string.
198
199			=cut
200
201			sub stringify ($;%) {
202			my $self = shift;
203	wakaba	1.8	my %params = @_;
204			my %option = %{$self->{option}};
205			for (grep {/^-/} keys %params) {$option{substr ($_, 1)} = $params{$_}}
206			my ($header, $body);
207			if (ref $self->{header}) {
208			my %exist;
209			for ($self->{header}->field_name_list) {$exist{$_} = 1}
210			if ($option{fill_date} && !$exist{'date'}) {
211			$self->{header}->field ('date')->unix_time (time);
212			}
213			if ($option{fill_msgid} && !$exist{'message-id'}) {
214			my $from = $self->{header}->field ('from')->addr_spec (1);
215			$self->{header}->field ('message-id')->add_new (addr_spec => $from)
216			if $from;
217			}
218			if ($option{fill_mimever} && !$exist{'mime-version'}) {
219			## BUG: rfc1049...
220			my $ismime = 0;
221			for (keys %exist) {if (/^content-/) {$ismime = 1; last}}
222			if ($ismime) {
223			$self->{header}->add ('mime-version' => '1.0', -parse => 0);
224			}
225			}
226			$self->_add_ua_field;
227			$header = $self->{header}->stringify (-format => $option{format});
228	wakaba	1.7	} else {
229			$header = $self->{header};
230	wakaba	1.8	$header =~ s/\x0D(?=[^\x09\x0A\x20])/\x0D\x20-/g;
231			$header =~ s/\x0A(?=[^\x09\x20])/\x0A\x20-/g;
232	wakaba	1.7	}
233			if (ref $self->{body}) {
234	wakaba	1.8	$body = $self->{body}->stringify (-format => $option{format});
235	wakaba	1.7	} else {
236			$body = $self->{body};
237			}
238	wakaba	1.1	$header .= "\n" if $header && $header !~ /\n$/;
239			$header."\n".$body;
240			}
241	wakaba	1.8	*as_string = \&stringify;
242	wakaba	1.1
243
244	wakaba	1.9	=head1 SHORTCUT METHOD FOR MESSAGE PROPERTIES
245
246			=over 4
247
248			=item $self->content_type ([%options])
249	wakaba	1.1
250	wakaba	1.9	Returns Internet media type of message body
251			(aka MIME type, content type). Only media type
252			(type/subtype pair) is returned, i.e. no parameter
253			is returned, if any. To get such value, or to set
254			new value, use C<field> method.
255	wakaba	1.1
256	wakaba	1.9	Default is C<text/plain>.
257	wakaba	1.3
258	wakaba	1.9	Example:
259	wakaba	1.3
260	wakaba	1.9	$msg->field ('Content-Type')->media_type ('text/html');
261			print $msg->content_type; ## text/html
262	wakaba	1.3
263			=cut
264
265			sub content_type ($;%) {
266	wakaba	1.8	my $self = shift;
267			return scalar $self->{header}->field ('content-type')->media_type
268			if $self->{header}->field_exist ('content-type');
269	wakaba	1.3	'text/plain';
270	wakaba	1.1	}
271
272	wakaba	1.9	=item $self->id
273
274			Returns ID of message entity. If there are C<Message-ID:>
275			field, its value is returned. Unless, but there are
276			C<Content-ID:> field, it is returned. Without both of
277			fields, C<""> is returned.
278
279			=cut
280
281	wakaba	1.5	sub id ($) {
282			my $self = shift;
283			return scalar $self->{header}->field ('message-id')->id
284			if $self->{header}->field_exist ('message-id');
285	wakaba	1.9	return scalar $self->{header}->field ('content-id')->id
286			if $self->{header}->field_exist ('content-id');
287	wakaba	1.8	'';
288	wakaba	1.5	}
289
290	wakaba	1.9	## Internal function for addition of User-Agent: C<product>.
291	wakaba	1.5	sub _add_ua_field ($) {
292			my $self = shift;
293	wakaba	1.8	if ($self->{option}->{add_ua}) {
294	wakaba	1.5	my $ua = $self->{header}->field ($self->{option}->{ua_field_name});
295			$ua->replace (name => 'Message-pm', version => $VERSION, add_prepend => -1);
296			my @os;
297			my @perl_comment;
298	wakaba	1.8	if ($self->{option}->{ua_use_config}) {
299	wakaba	1.5	eval q{use Config;
300			@os = (name => $^O, version => $Config{osvers}, add_prepend => -1);
301			push @perl_comment, $Config{archname};
302			};
303			} else {
304			push @perl_comment, $^O;
305			}
306			if ($^V) { ## 5.6 or later
307	wakaba	1.6	$ua->replace (name => 'Perl', version => sprintf ('%vd', $^V),
308			comment => [@perl_comment], add_prepend => -1);
309	wakaba	1.5	} elsif ($]) { ## Before 5.005
310			$ua->replace (name => 'Perl', version => $],
311			comment => [@perl_comment], add_prepend => -1);
312			}
313	wakaba	1.8	$ua->replace (@os) if $self->{option}->{ua_use_config};
314	wakaba	1.5	}
315			$self;
316			}
317
318	wakaba	1.9	=back
319
320			=head1 MISC. METHODS
321
322			=over 4
323
324			=item $self->option ( $option-name / $option-name, $option-value, ...)
325
326			If @_ == 1, returns option value. Else...
327
328			Set option value. You can pass multiple option name-value pair
329			as parameter. Example:
330
331			$msg->option (-format => 'mail-rfc822',
332			-capitalize => 0);
333			print $msg->option ('-format'); ## mail-rfc822
334
335			Note that introduction character, i.e. C<-> (HYPHEN-MINUS)
336			is optional. You can also write as this:
337
338			$msg->option (format => 'mail-rfc822',
339			capitalize => 0);
340			print $msg->option ('format'); ## mail-rfc822
341
342			=cut
343
344			sub option ($@) {
345			my $self = shift;
346			if (@_ == 1) {
347			return $self->{option}->{ $_[0] };
348			}
349			while (my ($name, $value) = splice (@_, 0, 2)) {
350			$name =~ s/^-//;
351			$self->{option}->{$name} = $value;
352			if ($name eq 'format') {
353			$self->header->option (-format => $value);
354			}
355			}
356			}
357
358			=item $self->clone ()
359	wakaba	1.8
360			Returns a copy of Message::Entity object.
361
362			=cut
363
364			sub clone ($) {
365			my $self = shift;
366			my $clone = new Message::Entity;
367			for my $name (%{$self->{option}}) {
368			if (ref $self->{option}->{$name} eq 'HASH') {
369			$clone->{option}->{$name} = {%{$self->{option}->{$name}}};
370			} elsif (ref $self->{option}->{$name} eq 'ARRAY') {
371			$clone->{option}->{$name} = [@{$self->{option}->{$name}}];
372			} else {
373			$clone->{option}->{$name} = $self->{option}->{$name};
374			}
375			}
376			$clone->{header} = ref $self->{header}? $self->{header}->clone: $self->{header};
377			$clone->{body} = ref $self->{body}? $self->{body}->clone: $self->{body};
378			$clone;
379			}
380	wakaba	1.5
381	wakaba	1.9	=back
382
383	wakaba	1.1	=head1 EXAMPLE
384
385			use Message::Entity;
386	wakaba	1.9	my $msg = new Message::Entity From => '[email protected]',
387			Subject => 'Example message',
388			To => '[email protected]',
389			-format => 'mail-rfc2822',
390			body => $body;
391	wakaba	1.1	$msg->header ($header);
392			$msg->body ($body);
393			print $msg;
394
395	wakaba	1.3	=head1 SEE ALSO
396
397			Message::* Perl modules
398			<http://suika.fam.cx/~wakaba/Message-pm/>
399
400	wakaba	1.1	=head1 LICENSE
401
402			Copyright 2002 wakaba E<lt>[email protected]<gt>.
403
404			This program is free software; you can redistribute it and/or modify
405			it under the terms of the GNU General Public License as published by
406			the Free Software Foundation; either version 2 of the License, or
407			(at your option) any later version.
408
409			This program is distributed in the hope that it will be useful,
410			but WITHOUT ANY WARRANTY; without even the implied warranty of
411			MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
412			GNU General Public License for more details.
413
414			You should have received a copy of the GNU General Public License
415			along with this program; see the file COPYING. If not, write to
416			the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
417			Boston, MA 02111-1307, USA.
418
419			=head1 CHANGE
420
421			See F<ChangeLog>.
422	wakaba	1.9	$Date: 2002/04/03 13:31:36 $
423	wakaba	1.1
424			=cut
425
426			1;