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.12 $=~/\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',
    linebreak_strict    => 0,   ## BUG: not work perfectly
    parse_all   => 0,
    #ua_field_name      => 'user-agent',
    ua_use_config       => 1,
    uri_mailto_safe_level       => 4,
  };
  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|uri-url-mailto/;
  }
  unless (defined $self->{option}->{fill_msgid}) {
    $self->{option}->{fill_msgid} = $format !~ /http|uri-url-mailto/;
  }
  unless (defined $self->{option}->{fill_mimever}) {
    $self->{option}->{fill_mimever} = $format !~ /http/;
  }
  unless (length $self->{option}->{ua_field_name}) {
    $self->{option}->{ua_field_name} = $format =~ /response|cgi|uri-url-mailto/?
      '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 = ();      ## BUG: don't check linebreak_strict
  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;     ## BUG: binary-unsafe
  $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;
      $self->{header}->field ('message-id')->generate (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);
      }
    }
    if ($option{format} =~ /uri-url-mailto/ && $exist{'content-type'}
     && $option{uri_mailto_safe_level} > 1) {
      $self->{header}->field ('content-type')->media_type ('text/plain');
    }
    $self->_add_ua_field;
    $header = $self->{header}->stringify (-format => $option{format},
      -linebreak_strict => $option{linebreak_strict},
      -uri_mailto_safe_level => $option{uri_mailto_safe_level});
  } else {
    $header = $self->{header};
    unless ($option{linebreak_strict}) {
      ## bare \x0D and bare \x0A are unsafe
      $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},
      -linebreak_strict => $option{linebreak_strict});
  } else {
    $body = $self->{body};
  }
  if ($option{format} =~ /uri-url-mailto/) {
    my $f = $option{format};  $f =~ s/-mailto/-mailto-to/;
    my $to = $self->{header}->stringify (-format => $f,
      -uri_mailto_safe_level => $option{uri_mailto_safe_level});
    $body =~ s/([^:@+\$A-Za-z0-9\-_.!~*])/sprintf('%%%02X', ord $1)/ge;
    if (length $body) {
      $header .= '&' if $header;
      $header .= 'body='.$body;
    }
    $header = '?'.$header if $header;
    'mailto:'.$to.$header;
  } else {
    $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)

=item uri-url-mailto-mail-rfc822, uri-url-mailto-mail-rfc2822

mailto: URL scheme

=item uri-url-mailto-rfc1738

mailto: URL scheme (defined by RFC 1738)

=item uri-url-mailto-rfc2368, uri-url-mailto-rfc2822

mailto: URL scheme (defined by RFC 2368)

=item uri-url-mailto-to-mail-rfc822, uri-url-mailto-to-mail-rfc2822

C<to> part of mailto: URL scheme (for internal use only)

=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/05/14 13:50:11 $

=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.13	$VERSION=do{my @r=(q$Revision: 1.12 $=~/\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	wakaba	1.12	linebreak_strict => 0, ## BUG: not work perfectly
33	wakaba	1.8	parse_all => 0,
34			#ua_field_name => 'user-agent',
35			ua_use_config => 1,
36	wakaba	1.12	uri_mailto_safe_level => 4,
37	wakaba	1.8	};
38			my @new_fields = ();
39			for my $name (keys %options) {
40			if (substr ($name, 0, 1) eq '-') {
41			$self->{option}->{substr ($name, 1)} = $options{$name};
42			} else {
43			push @new_fields, (lc $name => $options{$name});
44			}
45			}
46			my $format = $self->{option}->{format};
47			unless (defined $self->{option}->{fill_date}) {
48	wakaba	1.12	$self->{option}->{fill_date} = $format !~ /cgi\|uri-url-mailto/;
49	wakaba	1.8	}
50			unless (defined $self->{option}->{fill_msgid}) {
51	wakaba	1.12	$self->{option}->{fill_msgid} = $format !~ /http\|uri-url-mailto/;
52	wakaba	1.8	}
53			unless (defined $self->{option}->{fill_mimever}) {
54	wakaba	1.12	$self->{option}->{fill_mimever} = $format !~ /http/;
55	wakaba	1.8	}
56			unless (length $self->{option}->{ua_field_name}) {
57	wakaba	1.12	$self->{option}->{ua_field_name} = $format =~ /response\|cgi\|uri-url-mailto/?
58	wakaba	1.8	'server': 'user-agent';
59			}
60			@new_fields;
61			}
62
63			=head1 CONSTRUCTORS
64
65			The following methods construct new C<Message::Entity> objects:
66	wakaba	1.3
67	wakaba	1.8	=over 4
68
69	wakaba	1.9	=item Message::Entity->new ([%initial-fields/options])
70	wakaba	1.1
71	wakaba	1.9	Constructs a new C<Message::Entity> object. You might pass some initial
72			C<field-name>-C<field-body> pairs and/or options as parameters to the constructor.
73
74			Example:
75
76			$msg = new Message::Entity
77			Date => 'Thu, 03 Feb 1994 00:00:00 +0000',
78			Content_Type => 'text/html',
79			X_URI => '<http://www.foo.example/>',
80			-format => 'mail-rfc2822' ## not to be header field
81			;
82	wakaba	1.1
83			=cut
84
85			sub new ($;%) {
86			my $class = shift;
87	wakaba	1.8	my $self = bless {}, $class;
88			my %new_field = $self->_init (@_);
89			if (length $new_field{body}) {
90			$self->{body} = $new_field{body}; $new_field{body} = undef;
91			$self->{body} = $self->_body ($self->{body}, $self->content_type)
92			if $self->{option}->{parse_all};
93			}
94			$self->{header} = new Message::Header -format => $self->{option}->{format},
95			-parse_all => $self->{option}->{parse_all}, %new_field;
96	wakaba	1.1	$self;
97			}
98
99	wakaba	1.9	=item Message::Entity->parse ($message, [%options])
100	wakaba	1.1
101	wakaba	1.9	Parses given C<message> (a message entity) and constructs a new C<Message::Entity>
102			object. You might pass some additional C<field-name>-C<field-body> pairs
103			or/and initial options as parameters to the constructor.
104	wakaba	1.8
105	wakaba	1.1	=cut
106
107			sub parse ($$;%) {
108			my $class = shift;
109			my $message = shift;
110	wakaba	1.8	my $self = bless {}, $class;
111			my %new_field = $self->_init (@_);
112	wakaba	1.12	my @header = (); ## BUG: don't check linebreak_strict
113	wakaba	1.8	my @body = split /\x0D?\x0A/, $message; ## BUG: not binary-clean...
114			while (1) {
115			my $line = shift @body;
116			unless (length($line)) {
117			last;
118	wakaba	1.1	} else {
119	wakaba	1.8	push @header, $line;
120	wakaba	1.1	}
121			}
122	wakaba	1.8	$new_field{body} = undef if $new_field{body};
123			$self->{header} = parse_array Message::Header \@header,
124			-parse_all => $self->{option}->{parse_all},
125			-format => $self->{option}->{format}, %new_field;
126	wakaba	1.12	$self->{body} = join "\n", @body; ## BUG: binary-unsafe
127	wakaba	1.4	$self->{body} = $self->_body ($self->{body}, $self->content_type)
128	wakaba	1.8	if $self->{option}->{parse_all};
129	wakaba	1.1	$self;
130			}
131
132	wakaba	1.9	=back
133
134	wakaba	1.8	=head1 METHODS
135
136	wakaba	1.1	=head2 $self->header ([$new_header])
137
138			Returns Message::Header unless $new_header.
139			Set $new_header instead of current C<header>.
140			If !ref $new_header, Message::Header->parse is automatically
141			called.
142
143			=cut
144
145	wakaba	1.9	## TODO: to be compatible with HTTP::Message
146	wakaba	1.1	sub header ($;$) {
147			my $self = shift;
148			my $new_header = shift;
149			if (ref $new_header) {
150			$self->{header} = $new_header;
151			} elsif ($new_header) {
152	wakaba	1.4	$self->{header} = Message::Header->parse ($new_header,
153	wakaba	1.8	-parse_all => $self->{option}->{parse_all},
154			-format => $self->{option}->{format});
155	wakaba	1.1	}
156	wakaba	1.2	unless ($self->{header}) {
157	wakaba	1.8	$self->{header} = new Message::Header (-format => $self->{option}->{format});
158	wakaba	1.2	}
159	wakaba	1.1	$self->{header};
160			}
161
162			=head2 $self->body ([$new_body])
163
164			Returns C<body> as string unless $new_body.
165			Set $new_body instead of current C<body>.
166
167			=cut
168
169			sub body ($;$) {
170			my $self = shift;
171			my $new_body = shift;
172			if ($new_body) {
173			$self->{body} = $new_body;
174			}
175	wakaba	1.3	$self->{body} = $self->_body ($self->{body}, $self->content_type)
176			unless ref $self->{body};
177	wakaba	1.1	$self->{body};
178			}
179
180	wakaba	1.3	sub _body ($;$$) {
181			my $self = shift;
182			my $body = shift;
183			my $ct = shift;
184			$ct = $self->{option}->{body_class}->{$ct}
185			\|\| $self->{option}->{body_class}->{'/DEFAULT'};
186			eval "require $ct";
187			if (ref $body) {
188			return $body;
189			} elsif ($body) {
190	wakaba	1.4	return $ct->parse ($body,
191	wakaba	1.8	-parse_all => $self->{option}->{parse_all});
192	wakaba	1.3	} else {
193			return $ct->new ($body);
194			}
195			}
196
197	wakaba	1.1	=head2 $self->stringify ([%option])
198
199			Returns the C<message> as a string.
200
201			=cut
202
203			sub stringify ($;%) {
204			my $self = shift;
205	wakaba	1.8	my %params = @_;
206			my %option = %{$self->{option}};
207			for (grep {/^-/} keys %params) {$option{substr ($_, 1)} = $params{$_}}
208	wakaba	1.12	my ($header, $body);
209			if (ref $self->{header}) {
210			my %exist;
211			for ($self->{header}->field_name_list) {$exist{$_} = 1}
212			if ($option{fill_date} && !$exist{'date'}) {
213			$self->{header}->field ('date')->unix_time (time);
214			}
215	wakaba	1.8	if ($option{fill_msgid} && !$exist{'message-id'}) {
216	wakaba	1.13	my $from = $self->{header}->field ('from')->addr_spec;
217	wakaba	1.12	$self->{header}->field ('message-id')->generate (addr_spec => $from)
218	wakaba	1.8	if $from;
219			}
220			if ($option{fill_mimever} && !$exist{'mime-version'}) {
221			## BUG: rfc1049...
222			my $ismime = 0;
223			for (keys %exist) {if (/^content-/) {$ismime = 1; last}}
224			if ($ismime) {
225			$self->{header}->add ('mime-version' => '1.0', -parse => 0);
226			}
227			}
228	wakaba	1.12	if ($option{format} =~ /uri-url-mailto/ && $exist{'content-type'}
229			&& $option{uri_mailto_safe_level} > 1) {
230			$self->{header}->field ('content-type')->media_type ('text/plain');
231			}
232	wakaba	1.8	$self->_add_ua_field;
233	wakaba	1.12	$header = $self->{header}->stringify (-format => $option{format},
234			-linebreak_strict => $option{linebreak_strict},
235			-uri_mailto_safe_level => $option{uri_mailto_safe_level});
236	wakaba	1.7	} else {
237			$header = $self->{header};
238	wakaba	1.12	unless ($option{linebreak_strict}) {
239			## bare \x0D and bare \x0A are unsafe
240			$header =~ s/\x0D(?=[^\x09\x0A\x20])/\x0D\x20/g;
241			$header =~ s/\x0A(?=[^\x09\x20])/\x0A\x20/g;
242			}
243	wakaba	1.7	}
244			if (ref $self->{body}) {
245	wakaba	1.12	$body = $self->{body}->stringify (-format => $option{format},
246			-linebreak_strict => $option{linebreak_strict});
247	wakaba	1.7	} else {
248			$body = $self->{body};
249			}
250	wakaba	1.12	if ($option{format} =~ /uri-url-mailto/) {
251			my $f = $option{format}; $f =~ s/-mailto/-mailto-to/;
252			my $to = $self->{header}->stringify (-format => $f,
253			-uri_mailto_safe_level => $option{uri_mailto_safe_level});
254			$body =~ s/([^:@+\$A-Za-z0-9\-_.!~*])/sprintf('%%%02X', ord $1)/ge;
255			if (length $body) {
256			$header .= '&' if $header;
257			$header .= 'body='.$body;
258			}
259			$header = '?'.$header if $header;
260			'mailto:'.$to.$header;
261			} else {
262			$header .= "\n" if $header && $header !~ /\n$/;
263			$header."\n".$body;
264			}
265	wakaba	1.1	}
266	wakaba	1.8	*as_string = \&stringify;
267	wakaba	1.1
268
269	wakaba	1.9	=head1 SHORTCUT METHOD FOR MESSAGE PROPERTIES
270
271			=over 4
272
273			=item $self->content_type ([%options])
274	wakaba	1.1
275	wakaba	1.9	Returns Internet media type of message body
276			(aka MIME type, content type). Only media type
277			(type/subtype pair) is returned, i.e. no parameter
278			is returned, if any. To get such value, or to set
279			new value, use C<field> method.
280	wakaba	1.1
281	wakaba	1.9	Default is C<text/plain>.
282	wakaba	1.3
283	wakaba	1.9	Example:
284	wakaba	1.3
285	wakaba	1.9	$msg->field ('Content-Type')->media_type ('text/html');
286			print $msg->content_type; ## text/html
287	wakaba	1.3
288			=cut
289
290			sub content_type ($;%) {
291	wakaba	1.8	my $self = shift;
292			return scalar $self->{header}->field ('content-type')->media_type
293			if $self->{header}->field_exist ('content-type');
294	wakaba	1.3	'text/plain';
295	wakaba	1.1	}
296
297	wakaba	1.9	=item $self->id
298
299			Returns ID of message entity. If there are C<Message-ID:>
300			field, its value is returned. Unless, but there are
301			C<Content-ID:> field, it is returned. Without both of
302			fields, C<""> is returned.
303
304			=cut
305
306	wakaba	1.5	sub id ($) {
307			my $self = shift;
308			return scalar $self->{header}->field ('message-id')->id
309			if $self->{header}->field_exist ('message-id');
310	wakaba	1.9	return scalar $self->{header}->field ('content-id')->id
311			if $self->{header}->field_exist ('content-id');
312	wakaba	1.8	'';
313	wakaba	1.5	}
314
315	wakaba	1.9	## Internal function for addition of User-Agent: C<product>.
316	wakaba	1.5	sub _add_ua_field ($) {
317			my $self = shift;
318	wakaba	1.8	if ($self->{option}->{add_ua}) {
319	wakaba	1.5	my $ua = $self->{header}->field ($self->{option}->{ua_field_name});
320	wakaba	1.10	$ua->replace ('Message-pm' => $VERSION, -prepend => 0);
321	wakaba	1.5	my @os;
322			my @perl_comment;
323	wakaba	1.8	if ($self->{option}->{ua_use_config}) {
324	wakaba	1.5	eval q{use Config;
325	wakaba	1.10	@os = ($^O => $Config{osvers}, -prepend => 0);
326	wakaba	1.5	push @perl_comment, $Config{archname};
327			};
328			} else {
329			push @perl_comment, $^O;
330			}
331			if ($^V) { ## 5.6 or later
332	wakaba	1.10	$ua->replace (Perl => [sprintf ('%vd', $^V), @perl_comment], -prepend => 0);
333	wakaba	1.5	} elsif ($]) { ## Before 5.005
334	wakaba	1.10	$ua->replace (Perl => [ $], @perl_comment], -prepend => 0);
335	wakaba	1.5	}
336	wakaba	1.8	$ua->replace (@os) if $self->{option}->{ua_use_config};
337	wakaba	1.5	}
338			$self;
339			}
340
341	wakaba	1.9	=back
342
343			=head1 MISC. METHODS
344
345			=over 4
346
347			=item $self->option ( $option-name / $option-name, $option-value, ...)
348
349			If @_ == 1, returns option value. Else...
350
351			Set option value. You can pass multiple option name-value pair
352			as parameter. Example:
353
354			$msg->option (-format => 'mail-rfc822',
355			-capitalize => 0);
356			print $msg->option ('-format'); ## mail-rfc822
357
358			Note that introduction character, i.e. C<-> (HYPHEN-MINUS)
359			is optional. You can also write as this:
360
361			$msg->option (format => 'mail-rfc822',
362			capitalize => 0);
363			print $msg->option ('format'); ## mail-rfc822
364
365			=cut
366
367			sub option ($@) {
368			my $self = shift;
369			if (@_ == 1) {
370			return $self->{option}->{ $_[0] };
371			}
372			while (my ($name, $value) = splice (@_, 0, 2)) {
373			$name =~ s/^-//;
374			$self->{option}->{$name} = $value;
375			if ($name eq 'format') {
376			$self->header->option (-format => $value);
377			}
378			}
379			}
380
381			=item $self->clone ()
382	wakaba	1.8
383			Returns a copy of Message::Entity object.
384
385			=cut
386
387			sub clone ($) {
388			my $self = shift;
389			my $clone = new Message::Entity;
390			for my $name (%{$self->{option}}) {
391			if (ref $self->{option}->{$name} eq 'HASH') {
392			$clone->{option}->{$name} = {%{$self->{option}->{$name}}};
393			} elsif (ref $self->{option}->{$name} eq 'ARRAY') {
394			$clone->{option}->{$name} = [@{$self->{option}->{$name}}];
395			} else {
396			$clone->{option}->{$name} = $self->{option}->{$name};
397			}
398			}
399			$clone->{header} = ref $self->{header}? $self->{header}->clone: $self->{header};
400			$clone->{body} = ref $self->{body}? $self->{body}->clone: $self->{body};
401			$clone;
402			}
403	wakaba	1.5
404	wakaba	1.9	=back
405
406	wakaba	1.11	=head1 C<format>
407
408			=over 2
409
410			=item mail-rfc650
411
412			Internet mail message, defined by IETF RFC 650
413
414			=item mail-rfc724
415
416			Internet mail message, defined by IETF RFC 724
417
418			=item mail-rfc733
419
420			Internet mail message, defined by IETF RFC 733
421
422			=item mail-rfc822
423
424			Internet mail message, defined by IETF RFC 822
425
426			=item mail-rfc2822
427
428			Internet mail message, defined by IETF RFC 2822
429
430			=item mime-1.0
431
432			MIME entity
433
434			=item mime-1.0-rfc1341
435
436			MIME entity, defined by RFC 1341 (and RFC 1342)
437
438			=item mime-1.0-rfc1521
439
440			MIME entity, defined by RFC 1521 and 1522
441
442			=item mime-1.0-rfc2045
443
444			MIME entity, defined by RFC 2045,..., 2049
445
446			=item news-bnews
447
448			Usenet Bnews format
449
450			=item news-rfc850
451
452			Usenet news format, defined by IETF RFC 850
453
454			=item news-rfc1036
455
456			Usenet news format, defined by IETF RFC 1036
457
458			=item news-son-of-rfc1036
459
460			Usenet news format, defined by son-of-RFC1036
461
462			=item news-usefor
463
464			Usenet news format, defined by usefor-article (IETF Internet Draft)
465
466			=item http-1.0-rfc1945
467
468			HTTP/1.0 message, defined by IETF RFC 1945
469
470			=item http-1.0-rfc1945-request
471
472			HTTP/1.0 request message, defined by IETF RFC 1945
473
474			=item http-1.0-rfc1945-response
475
476			HTTP/1.0 response message, defined by IETF RFC 1945
477
478			=item http-1.1-rfc2068
479
480			HTTP/1.1 message, defined by IETF RFC 2068
481
482			=item http-1.1-rfc2068-request
483
484			HTTP/1.1 request message, defined by IETF RFC 2068
485
486			=item http-1.1-rfc2068-response
487
488			HTTP/1.1 response message, defined by IETF RFC 2068
489
490			=item http-1.1-rfc2616
491
492			HTTP/1.1 message, defined by IETF RFC 2616
493
494			=item http-1.1-rfc2616-request
495
496			HTTP/1.1 request message, defined by IETF RFC 2616
497
498			=item http-1.1-rfc2616-response
499
500			HTTP/1.1 response message, defined by IETF RFC 2616
501
502			=item http-cgi-1.1
503
504			CGI/1.1 output (for HTTP), defined by coar-cgi-v11 (IETF Internet Draft)
505
506			=item http-1.0-cgi-1.1
507
508			CGI/1.1 output (for HTTP/1.0), defined by coar-cgi-v11 (IETF Internet Draft)
509
510			=item http-1.1-cgi-1.1
511
512			CGI/1.1 output (for HTTP/1.1), defined by coar-cgi-v11 (IETF Internet Draft)
513
514			=item http-cgi-1.2
515
516			CGI/1.2 output, defined by coar-cgi-v12 (to be IETF Internet Draft)
517
518			=item http-1.0-cgi-1.2
519
520			CGI/1.2 output (for HTTP/1.0), defined by coar-cgi-v11 (IETF Internet Draft)
521
522			=item http-1.1-cgi-1.2
523
524			CGI/1.2 output (for HTTP/1.1), defined by coar-cgi-v11 (IETF Internet Draft)
525
526			=item http-sip-2.0
527
528			SIP/2.0 message, defined by IETF RFC 2543
529
530			=item http-sip-2.0-request
531
532			SIP/2.0 request message, defined by IETF RFC 2543
533
534			=item http-sip-2.0-response
535
536			SIP/2.0 response message, defined by IETF RFC 2543
537
538			=item http-sip-cgi
539
540			SIP/2.0 CGI (IETF Internet Draft)
541
542			=item cpim-1.0
543
544			CPIM/1.0 (IETF Internet Draft)
545
546	wakaba	1.12	=item uri-url-mailto-mail-rfc822, uri-url-mailto-mail-rfc2822
547
548			mailto: URL scheme
549
550			=item uri-url-mailto-rfc1738
551
552			mailto: URL scheme (defined by RFC 1738)
553
554			=item uri-url-mailto-rfc2368, uri-url-mailto-rfc2822
555
556			mailto: URL scheme (defined by RFC 2368)
557
558			=item uri-url-mailto-to-mail-rfc822, uri-url-mailto-to-mail-rfc2822
559
560			C<to> part of mailto: URL scheme (for internal use only)
561
562	wakaba	1.11	=back
563
564	wakaba	1.1	=head1 EXAMPLE
565
566			use Message::Entity;
567	wakaba	1.9	my $msg = new Message::Entity From => '[email protected]',
568			Subject => 'Example message',
569			To => '[email protected]',
570			-format => 'mail-rfc2822',
571			body => $body;
572	wakaba	1.1	$msg->header ($header);
573			$msg->body ($body);
574			print $msg;
575
576	wakaba	1.3	=head1 SEE ALSO
577
578			Message::* Perl modules
579			<http://suika.fam.cx/~wakaba/Message-pm/>
580
581	wakaba	1.1	=head1 LICENSE
582
583			Copyright 2002 wakaba E<lt>[email protected]<gt>.
584
585			This program is free software; you can redistribute it and/or modify
586			it under the terms of the GNU General Public License as published by
587			the Free Software Foundation; either version 2 of the License, or
588			(at your option) any later version.
589
590			This program is distributed in the hope that it will be useful,
591			but WITHOUT ANY WARRANTY; without even the implied warranty of
592			MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
593			GNU General Public License for more details.
594
595			You should have received a copy of the GNU General Public License
596			along with this program; see the file COPYING. If not, write to
597			the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
598			Boston, MA 02111-1307, USA.
599
600			=head1 CHANGE
601
602			See F<ChangeLog>.
603	wakaba	1.13	$Date: 2002/05/14 13:50:11 $
604	wakaba	1.1
605			=cut
606
607			1;