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.7 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};

require Message::Header;
require Message::Util;
use overload '""' => sub {shift->stringify};

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 ([%option])

Returns new Message::Entity instance.  Some options can be
specified as hash.

=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, [%option])

Parses given C<message> and return a new Message::Entity
object.  Some options can be specified as hash.

=back

=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;
}

=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

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;

=head2 $self->option ($option_name)

Returns/set (new) value of the option.

=cut

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

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

Returns C<body>'s content-type (Internet Media Type).
This method is not implemented yet so always returns
C<text/plain>.

=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';
}

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

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;
}

=head2 $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;
}

=head1 EXAMPLE

  use Message::Entity;
  my $msg = new Message::Entity;
  $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/03/31 13:12:41 $

=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			$VERSION=do{my @r=(q$Revision: 1.7 $=~/\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.1	use overload '""' => sub {shift->stringify};
21
22	wakaba	1.8	sub _init ($;%) {
23			my $self = shift;
24			my %options = @_;
25			$self->{option} = {
26			add_ua => 1,
27			body_class => {'/DEFAULT' => 'Message::Body::TextPlain'},
28			#fill_date => 1,
29			#fill_msgid => 1,
30			format => 'mail-rfc2822',
31			parse_all => 0,
32			#ua_field_name => 'user-agent',
33			ua_use_config => 1,
34			};
35			my @new_fields = ();
36			for my $name (keys %options) {
37			if (substr ($name, 0, 1) eq '-') {
38			$self->{option}->{substr ($name, 1)} = $options{$name};
39			} else {
40			push @new_fields, (lc $name => $options{$name});
41			}
42			}
43			my $format = $self->{option}->{format};
44			unless (defined $self->{option}->{fill_date}) {
45			$self->{option}->{fill_date} = $format !~ /^cgi/;
46			}
47			unless (defined $self->{option}->{fill_msgid}) {
48			$self->{option}->{fill_msgid} = $format !~ /^(?:cgi\|http)/;
49			}
50			unless (defined $self->{option}->{fill_mimever}) {
51			$self->{option}->{fill_mimever} = $format !~ /^(?:cgi\|http)/;
52			}
53			unless (length $self->{option}->{ua_field_name}) {
54			$self->{option}->{ua_field_name} = $format =~ /^(?:http-response\|cgi)/?
55			'server': 'user-agent';
56			}
57			@new_fields;
58			}
59
60			=head1 CONSTRUCTORS
61
62			The following methods construct new C<Message::Entity> objects:
63	wakaba	1.3
64	wakaba	1.8	=over 4
65
66			=item Message::Entity->new ([%option])
67	wakaba	1.1
68			Returns new Message::Entity instance. Some options can be
69			specified as hash.
70
71			=cut
72
73			sub new ($;%) {
74			my $class = shift;
75	wakaba	1.8	my $self = bless {}, $class;
76			my %new_field = $self->_init (@_);
77			if (length $new_field{body}) {
78			$self->{body} = $new_field{body}; $new_field{body} = undef;
79			$self->{body} = $self->_body ($self->{body}, $self->content_type)
80			if $self->{option}->{parse_all};
81			}
82			$self->{header} = new Message::Header -format => $self->{option}->{format},
83			-parse_all => $self->{option}->{parse_all}, %new_field;
84	wakaba	1.1	$self;
85			}
86
87	wakaba	1.8	=item Message::Entity->parse ($message, [%option])
88	wakaba	1.1
89			Parses given C<message> and return a new Message::Entity
90			object. Some options can be specified as hash.
91
92	wakaba	1.8	=back
93
94	wakaba	1.1	=cut
95
96			sub parse ($$;%) {
97			my $class = shift;
98			my $message = shift;
99	wakaba	1.8	my $self = bless {}, $class;
100			my %new_field = $self->_init (@_);
101			my @header = ();
102			my @body = split /\x0D?\x0A/, $message; ## BUG: not binary-clean...
103			while (1) {
104			my $line = shift @body;
105			unless (length($line)) {
106			last;
107	wakaba	1.1	} else {
108	wakaba	1.8	push @header, $line;
109	wakaba	1.1	}
110			}
111	wakaba	1.8	$new_field{body} = undef if $new_field{body};
112			$self->{header} = parse_array Message::Header \@header,
113			-parse_all => $self->{option}->{parse_all},
114			-format => $self->{option}->{format}, %new_field;
115	wakaba	1.1	$self->{body} = join "\n", @body;
116	wakaba	1.4	$self->{body} = $self->_body ($self->{body}, $self->content_type)
117	wakaba	1.8	if $self->{option}->{parse_all};
118	wakaba	1.1	$self;
119			}
120
121	wakaba	1.8	=head1 METHODS
122
123	wakaba	1.1	=head2 $self->header ([$new_header])
124
125			Returns Message::Header unless $new_header.
126			Set $new_header instead of current C<header>.
127			If !ref $new_header, Message::Header->parse is automatically
128			called.
129
130			=cut
131
132			sub header ($;$) {
133			my $self = shift;
134			my $new_header = shift;
135			if (ref $new_header) {
136			$self->{header} = $new_header;
137			} elsif ($new_header) {
138	wakaba	1.4	$self->{header} = Message::Header->parse ($new_header,
139	wakaba	1.8	-parse_all => $self->{option}->{parse_all},
140			-format => $self->{option}->{format});
141	wakaba	1.1	}
142	wakaba	1.2	unless ($self->{header}) {
143	wakaba	1.8	$self->{header} = new Message::Header (-format => $self->{option}->{format});
144	wakaba	1.2	}
145	wakaba	1.1	$self->{header};
146			}
147
148			=head2 $self->body ([$new_body])
149
150			Returns C<body> as string unless $new_body.
151			Set $new_body instead of current C<body>.
152
153			=cut
154
155			sub body ($;$) {
156			my $self = shift;
157			my $new_body = shift;
158			if ($new_body) {
159			$self->{body} = $new_body;
160			}
161	wakaba	1.3	$self->{body} = $self->_body ($self->{body}, $self->content_type)
162			unless ref $self->{body};
163	wakaba	1.1	$self->{body};
164			}
165
166	wakaba	1.3	sub _body ($;$$) {
167			my $self = shift;
168			my $body = shift;
169			my $ct = shift;
170			$ct = $self->{option}->{body_class}->{$ct}
171			\|\| $self->{option}->{body_class}->{'/DEFAULT'};
172			eval "require $ct";
173			if (ref $body) {
174			return $body;
175			} elsif ($body) {
176	wakaba	1.4	return $ct->parse ($body,
177	wakaba	1.8	-parse_all => $self->{option}->{parse_all});
178	wakaba	1.3	} else {
179			return $ct->new ($body);
180			}
181			}
182
183	wakaba	1.1	=head2 $self->stringify ([%option])
184
185			Returns the C<message> as a string.
186
187			=cut
188
189			sub stringify ($;%) {
190			my $self = shift;
191	wakaba	1.8	my %params = @_;
192			my %option = %{$self->{option}};
193			for (grep {/^-/} keys %params) {$option{substr ($_, 1)} = $params{$_}}
194			my ($header, $body);
195			if (ref $self->{header}) {
196			my %exist;
197			for ($self->{header}->field_name_list) {$exist{$_} = 1}
198			if ($option{fill_date} && !$exist{'date'}) {
199			$self->{header}->field ('date')->unix_time (time);
200			}
201			if ($option{fill_msgid} && !$exist{'message-id'}) {
202			my $from = $self->{header}->field ('from')->addr_spec (1);
203			$self->{header}->field ('message-id')->add_new (addr_spec => $from)
204			if $from;
205			}
206			if ($option{fill_mimever} && !$exist{'mime-version'}) {
207			## BUG: rfc1049...
208			my $ismime = 0;
209			for (keys %exist) {if (/^content-/) {$ismime = 1; last}}
210			if ($ismime) {
211			$self->{header}->add ('mime-version' => '1.0', -parse => 0);
212			}
213			}
214			$self->_add_ua_field;
215			$header = $self->{header}->stringify (-format => $option{format});
216	wakaba	1.7	} else {
217			$header = $self->{header};
218	wakaba	1.8	$header =~ s/\x0D(?=[^\x09\x0A\x20])/\x0D\x20-/g;
219			$header =~ s/\x0A(?=[^\x09\x20])/\x0A\x20-/g;
220	wakaba	1.7	}
221			if (ref $self->{body}) {
222	wakaba	1.8	$body = $self->{body}->stringify (-format => $option{format});
223	wakaba	1.7	} else {
224			$body = $self->{body};
225			}
226	wakaba	1.1	$header .= "\n" if $header && $header !~ /\n$/;
227			$header."\n".$body;
228			}
229	wakaba	1.8	*as_string = \&stringify;
230	wakaba	1.1
231	wakaba	1.3	=head2 $self->option ($option_name)
232	wakaba	1.1
233	wakaba	1.3	Returns/set (new) value of the option.
234	wakaba	1.1
235			=cut
236
237	wakaba	1.8	sub option ($@) {
238	wakaba	1.1	my $self = shift;
239	wakaba	1.8	if (@_ == 1) {
240			return $self->{option}->{ shift (@_) };
241			}
242			while (my ($name, $value) = splice (@_, 0, 2)) {
243			$name =~ s/^-//;
244			$self->{option}->{$name} = $value;
245	wakaba	1.7	if ($name eq 'format') {
246	wakaba	1.8	$self->header->option (-format => $value);
247	wakaba	1.7	}
248	wakaba	1.3	}
249	wakaba	1.1	}
250	wakaba	1.3
251			=head2 $self->content_type ([%options])
252
253			Returns C<body>'s content-type (Internet Media Type).
254			This method is not implemented yet so always returns
255			C<text/plain>.
256
257			=cut
258
259			sub content_type ($;%) {
260	wakaba	1.8	my $self = shift;
261			return scalar $self->{header}->field ('content-type')->media_type
262			if $self->{header}->field_exist ('content-type');
263	wakaba	1.3	'text/plain';
264	wakaba	1.1	}
265
266	wakaba	1.5	sub id ($) {
267			my $self = shift;
268			return scalar $self->{header}->field ('message-id')->id
269			if $self->{header}->field_exist ('message-id');
270	wakaba	1.8	'';
271	wakaba	1.5	}
272
273			sub _add_ua_field ($) {
274			my $self = shift;
275	wakaba	1.8	if ($self->{option}->{add_ua}) {
276	wakaba	1.5	my $ua = $self->{header}->field ($self->{option}->{ua_field_name});
277			$ua->replace (name => 'Message-pm', version => $VERSION, add_prepend => -1);
278			my @os;
279			my @perl_comment;
280	wakaba	1.8	if ($self->{option}->{ua_use_config}) {
281	wakaba	1.5	eval q{use Config;
282			@os = (name => $^O, version => $Config{osvers}, add_prepend => -1);
283			push @perl_comment, $Config{archname};
284			};
285			} else {
286			push @perl_comment, $^O;
287			}
288			if ($^V) { ## 5.6 or later
289	wakaba	1.6	$ua->replace (name => 'Perl', version => sprintf ('%vd', $^V),
290			comment => [@perl_comment], add_prepend => -1);
291	wakaba	1.5	} elsif ($]) { ## Before 5.005
292			$ua->replace (name => 'Perl', version => $],
293			comment => [@perl_comment], add_prepend => -1);
294			}
295	wakaba	1.8	$ua->replace (@os) if $self->{option}->{ua_use_config};
296	wakaba	1.5	}
297			$self;
298			}
299
300	wakaba	1.8	=head2 $self->clone ()
301
302			Returns a copy of Message::Entity object.
303
304			=cut
305
306			sub clone ($) {
307			my $self = shift;
308			my $clone = new Message::Entity;
309			for my $name (%{$self->{option}}) {
310			if (ref $self->{option}->{$name} eq 'HASH') {
311			$clone->{option}->{$name} = {%{$self->{option}->{$name}}};
312			} elsif (ref $self->{option}->{$name} eq 'ARRAY') {
313			$clone->{option}->{$name} = [@{$self->{option}->{$name}}];
314			} else {
315			$clone->{option}->{$name} = $self->{option}->{$name};
316			}
317			}
318			$clone->{header} = ref $self->{header}? $self->{header}->clone: $self->{header};
319			$clone->{body} = ref $self->{body}? $self->{body}->clone: $self->{body};
320			$clone;
321			}
322	wakaba	1.5
323	wakaba	1.1	=head1 EXAMPLE
324
325			use Message::Entity;
326			my $msg = new Message::Entity;
327			$msg->header ($header);
328			$msg->body ($body);
329			print $msg;
330
331	wakaba	1.3	=head1 SEE ALSO
332
333			Message::* Perl modules
334			<http://suika.fam.cx/~wakaba/Message-pm/>
335
336	wakaba	1.1	=head1 LICENSE
337
338			Copyright 2002 wakaba E<lt>[email protected]<gt>.
339
340			This program is free software; you can redistribute it and/or modify
341			it under the terms of the GNU General Public License as published by
342			the Free Software Foundation; either version 2 of the License, or
343			(at your option) any later version.
344
345			This program is distributed in the hope that it will be useful,
346			but WITHOUT ANY WARRANTY; without even the implied warranty of
347			MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
348			GNU General Public License for more details.
349
350			You should have received a copy of the GNU General Public License
351			along with this program; see the file COPYING. If not, write to
352			the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
353			Boston, MA 02111-1307, USA.
354
355			=head1 CHANGE
356
357			See F<ChangeLog>.
358	wakaba	1.8	$Date: 2002/03/31 13:12:41 $
359	wakaba	1.1
360			=cut
361
362			1;