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.10 $=~/\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 ('Message-pm' => $VERSION, -prepend => 0);
    my @os;
    my @perl_comment;
    if ($self->{option}->{ua_use_config}) {
      eval q{use Config;
        @os = ($^O => $Config{osvers}, -prepend => 0);
        push @perl_comment, $Config{archname};
      };
    } else {
      push @perl_comment, $^O;
    }
    if ($^V) {  ## 5.6 or later
      $ua->replace (Perl => [sprintf ('%vd', $^V), @perl_comment], -prepend => 0);
    } elsif ($]) {      ## Before 5.005
      $ua->replace (Perl => [ $], @perl_comment], -prepend => 0);
    }
    $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 C<format>

=over 2

=item mail-rfc650

Internet mail message, defined by IETF RFC 650

=item mail-rfc724

Internet mail message, defined by IETF RFC 724

=item mail-rfc733

Internet mail message, defined by IETF RFC 733

=item mail-rfc822

Internet mail message, defined by IETF RFC 822

=item mail-rfc2822

Internet mail message, defined by IETF RFC 2822

=item mime-1.0

MIME entity

=item mime-1.0-rfc1341

MIME entity, defined by RFC 1341 (and RFC 1342)

=item mime-1.0-rfc1521

MIME entity, defined by RFC 1521 and 1522

=item mime-1.0-rfc2045

MIME entity, defined by RFC 2045,..., 2049

=item news-bnews

Usenet Bnews format

=item news-rfc850

Usenet news format, defined by IETF RFC 850

=item news-rfc1036

Usenet news format, defined by IETF RFC 1036

=item news-son-of-rfc1036

Usenet news format, defined by son-of-RFC1036

=item news-usefor

Usenet news format, defined by usefor-article (IETF Internet Draft)

=item http-1.0-rfc1945

HTTP/1.0 message, defined by IETF RFC 1945

=item http-1.0-rfc1945-request

HTTP/1.0 request message, defined by IETF RFC 1945

=item http-1.0-rfc1945-response

HTTP/1.0 response message, defined by IETF RFC 1945

=item http-1.1-rfc2068

HTTP/1.1 message, defined by IETF RFC 2068

=item http-1.1-rfc2068-request

HTTP/1.1 request message, defined by IETF RFC 2068

=item http-1.1-rfc2068-response

HTTP/1.1 response message, defined by IETF RFC 2068

=item http-1.1-rfc2616

HTTP/1.1 message, defined by IETF RFC 2616

=item http-1.1-rfc2616-request

HTTP/1.1 request message, defined by IETF RFC 2616

=item http-1.1-rfc2616-response

HTTP/1.1 response message, defined by IETF RFC 2616

=item http-cgi-1.1

CGI/1.1 output (for HTTP), defined by coar-cgi-v11 (IETF Internet Draft)

=item http-1.0-cgi-1.1

CGI/1.1 output (for HTTP/1.0), defined by coar-cgi-v11 (IETF Internet Draft)

=item http-1.1-cgi-1.1

CGI/1.1 output (for HTTP/1.1), defined by coar-cgi-v11 (IETF Internet Draft)

=item http-cgi-1.2

CGI/1.2 output, defined by coar-cgi-v12 (to be IETF Internet Draft)

=item http-1.0-cgi-1.2

CGI/1.2 output (for HTTP/1.0), defined by coar-cgi-v11 (IETF Internet Draft)

=item http-1.1-cgi-1.2

CGI/1.2 output (for HTTP/1.1), defined by coar-cgi-v11 (IETF Internet Draft)

=item http-sip-2.0

SIP/2.0 message, defined by IETF RFC 2543

=item http-sip-2.0-request

SIP/2.0 request message, defined by IETF RFC 2543

=item http-sip-2.0-response

SIP/2.0 response message, defined by IETF RFC 2543

=item http-sip-cgi

SIP/2.0 CGI (IETF Internet Draft)

=item cpim-1.0

CPIM/1.0 (IETF Internet Draft)

=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/19 12:00: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.11	$VERSION=do{my @r=(q$Revision: 1.10 $=~/\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	wakaba	1.10	$ua->replace ('Message-pm' => $VERSION, -prepend => 0);
296	wakaba	1.5	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	wakaba	1.10	@os = ($^O => $Config{osvers}, -prepend => 0);
301	wakaba	1.5	push @perl_comment, $Config{archname};
302			};
303			} else {
304			push @perl_comment, $^O;
305			}
306			if ($^V) { ## 5.6 or later
307	wakaba	1.10	$ua->replace (Perl => [sprintf ('%vd', $^V), @perl_comment], -prepend => 0);
308	wakaba	1.5	} elsif ($]) { ## Before 5.005
309	wakaba	1.10	$ua->replace (Perl => [ $], @perl_comment], -prepend => 0);
310	wakaba	1.5	}
311	wakaba	1.8	$ua->replace (@os) if $self->{option}->{ua_use_config};
312	wakaba	1.5	}
313			$self;
314			}
315
316	wakaba	1.9	=back
317
318			=head1 MISC. METHODS
319
320			=over 4
321
322			=item $self->option ( $option-name / $option-name, $option-value, ...)
323
324			If @_ == 1, returns option value. Else...
325
326			Set option value. You can pass multiple option name-value pair
327			as parameter. Example:
328
329			$msg->option (-format => 'mail-rfc822',
330			-capitalize => 0);
331			print $msg->option ('-format'); ## mail-rfc822
332
333			Note that introduction character, i.e. C<-> (HYPHEN-MINUS)
334			is optional. You can also write as this:
335
336			$msg->option (format => 'mail-rfc822',
337			capitalize => 0);
338			print $msg->option ('format'); ## mail-rfc822
339
340			=cut
341
342			sub option ($@) {
343			my $self = shift;
344			if (@_ == 1) {
345			return $self->{option}->{ $_[0] };
346			}
347			while (my ($name, $value) = splice (@_, 0, 2)) {
348			$name =~ s/^-//;
349			$self->{option}->{$name} = $value;
350			if ($name eq 'format') {
351			$self->header->option (-format => $value);
352			}
353			}
354			}
355
356			=item $self->clone ()
357	wakaba	1.8
358			Returns a copy of Message::Entity object.
359
360			=cut
361
362			sub clone ($) {
363			my $self = shift;
364			my $clone = new Message::Entity;
365			for my $name (%{$self->{option}}) {
366			if (ref $self->{option}->{$name} eq 'HASH') {
367			$clone->{option}->{$name} = {%{$self->{option}->{$name}}};
368			} elsif (ref $self->{option}->{$name} eq 'ARRAY') {
369			$clone->{option}->{$name} = [@{$self->{option}->{$name}}];
370			} else {
371			$clone->{option}->{$name} = $self->{option}->{$name};
372			}
373			}
374			$clone->{header} = ref $self->{header}? $self->{header}->clone: $self->{header};
375			$clone->{body} = ref $self->{body}? $self->{body}->clone: $self->{body};
376			$clone;
377			}
378	wakaba	1.5
379	wakaba	1.9	=back
380
381	wakaba	1.11	=head1 C<format>
382
383			=over 2
384
385			=item mail-rfc650
386
387			Internet mail message, defined by IETF RFC 650
388
389			=item mail-rfc724
390
391			Internet mail message, defined by IETF RFC 724
392
393			=item mail-rfc733
394
395			Internet mail message, defined by IETF RFC 733
396
397			=item mail-rfc822
398
399			Internet mail message, defined by IETF RFC 822
400
401			=item mail-rfc2822
402
403			Internet mail message, defined by IETF RFC 2822
404
405			=item mime-1.0
406
407			MIME entity
408
409			=item mime-1.0-rfc1341
410
411			MIME entity, defined by RFC 1341 (and RFC 1342)
412
413			=item mime-1.0-rfc1521
414
415			MIME entity, defined by RFC 1521 and 1522
416
417			=item mime-1.0-rfc2045
418
419			MIME entity, defined by RFC 2045,..., 2049
420
421			=item news-bnews
422
423			Usenet Bnews format
424
425			=item news-rfc850
426
427			Usenet news format, defined by IETF RFC 850
428
429			=item news-rfc1036
430
431			Usenet news format, defined by IETF RFC 1036
432
433			=item news-son-of-rfc1036
434
435			Usenet news format, defined by son-of-RFC1036
436
437			=item news-usefor
438
439			Usenet news format, defined by usefor-article (IETF Internet Draft)
440
441			=item http-1.0-rfc1945
442
443			HTTP/1.0 message, defined by IETF RFC 1945
444
445			=item http-1.0-rfc1945-request
446
447			HTTP/1.0 request message, defined by IETF RFC 1945
448
449			=item http-1.0-rfc1945-response
450
451			HTTP/1.0 response message, defined by IETF RFC 1945
452
453			=item http-1.1-rfc2068
454
455			HTTP/1.1 message, defined by IETF RFC 2068
456
457			=item http-1.1-rfc2068-request
458
459			HTTP/1.1 request message, defined by IETF RFC 2068
460
461			=item http-1.1-rfc2068-response
462
463			HTTP/1.1 response message, defined by IETF RFC 2068
464
465			=item http-1.1-rfc2616
466
467			HTTP/1.1 message, defined by IETF RFC 2616
468
469			=item http-1.1-rfc2616-request
470
471			HTTP/1.1 request message, defined by IETF RFC 2616
472
473			=item http-1.1-rfc2616-response
474
475			HTTP/1.1 response message, defined by IETF RFC 2616
476
477			=item http-cgi-1.1
478
479			CGI/1.1 output (for HTTP), defined by coar-cgi-v11 (IETF Internet Draft)
480
481			=item http-1.0-cgi-1.1
482
483			CGI/1.1 output (for HTTP/1.0), defined by coar-cgi-v11 (IETF Internet Draft)
484
485			=item http-1.1-cgi-1.1
486
487			CGI/1.1 output (for HTTP/1.1), defined by coar-cgi-v11 (IETF Internet Draft)
488
489			=item http-cgi-1.2
490
491			CGI/1.2 output, defined by coar-cgi-v12 (to be IETF Internet Draft)
492
493			=item http-1.0-cgi-1.2
494
495			CGI/1.2 output (for HTTP/1.0), defined by coar-cgi-v11 (IETF Internet Draft)
496
497			=item http-1.1-cgi-1.2
498
499			CGI/1.2 output (for HTTP/1.1), defined by coar-cgi-v11 (IETF Internet Draft)
500
501			=item http-sip-2.0
502
503			SIP/2.0 message, defined by IETF RFC 2543
504
505			=item http-sip-2.0-request
506
507			SIP/2.0 request message, defined by IETF RFC 2543
508
509			=item http-sip-2.0-response
510
511			SIP/2.0 response message, defined by IETF RFC 2543
512
513			=item http-sip-cgi
514
515			SIP/2.0 CGI (IETF Internet Draft)
516
517			=item cpim-1.0
518
519			CPIM/1.0 (IETF Internet Draft)
520
521			=back
522
523	wakaba	1.1	=head1 EXAMPLE
524
525			use Message::Entity;
526	wakaba	1.9	my $msg = new Message::Entity From => '[email protected]',
527			Subject => 'Example message',
528			To => '[email protected]',
529			-format => 'mail-rfc2822',
530			body => $body;
531	wakaba	1.1	$msg->header ($header);
532			$msg->body ($body);
533			print $msg;
534
535	wakaba	1.3	=head1 SEE ALSO
536
537			Message::* Perl modules
538			<http://suika.fam.cx/~wakaba/Message-pm/>
539
540	wakaba	1.1	=head1 LICENSE
541
542			Copyright 2002 wakaba E<lt>[email protected]<gt>.
543
544			This program is free software; you can redistribute it and/or modify
545			it under the terms of the GNU General Public License as published by
546			the Free Software Foundation; either version 2 of the License, or
547			(at your option) any later version.
548
549			This program is distributed in the hope that it will be useful,
550			but WITHOUT ANY WARRANTY; without even the implied warranty of
551			MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
552			GNU General Public License for more details.
553
554			You should have received a copy of the GNU General Public License
555			along with this program; see the file COPYING. If not, write to
556			the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
557			Boston, MA 02111-1307, USA.
558
559			=head1 CHANGE
560
561			See F<ChangeLog>.
562	wakaba	1.11	$Date: 2002/04/19 12:00:36 $
563	wakaba	1.1
564			=cut
565
566			1;