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 %DEFAULT);
$VERSION=do{my @r=(q$Revision: 1.6 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};

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

%DEFAULT = (
  add_ua        => 1,
  body_class    => {'/DEFAULT' => 'Message::Body::TextPlain'},
  fill_date     => 1,
  fill_msgid    => 1,
  format        => 'rfc2822',   ## rfc2822, usefor, http
  parse_all     => -1,
  ua_field_name => 'user-agent',
  ua_use_config => 1,
);

=head2 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 {option => {@_}}, $class;
  for (keys %DEFAULT) {$self->{option}->{$_} ||= $DEFAULT{$_}}
  $self->{header} = new Message::Header (format => $self->{option}->{format});
  #$self->_add_ua_field;
  $self;
}

=head2 Message::Entity->parse ($message, [%option])

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

=cut

sub parse ($$;%) {
  my $class = shift;
  my $message = shift;
  my $self = bless {option => {@_}}, $class;
  for (keys %DEFAULT) {$self->{option}->{$_} ||= $DEFAULT{$_}}
  my ($isheader, @header, @body) = 1;
  for my $line (split /\x0D?\x0A/, $message) {
    if ($isheader && !length($line)) {
      $isheader = 0;
    } elsif ($isheader) {
      push @header, $line
    } else {
      push @body, $line;
    }
  }
  $self->{header} = Message::Header->parse (join ("\n", @header),
    parse_all => $self->{option}->{parse_all},
    format => $self->{option}->{format});
  $self->{body} = join "\n", @body;
  $self->{body} = $self->_body ($self->{body}, $self->content_type)
    if $self->{option}->{parse_all}>0;
  #$self->_add_ua_field;
  $self;
}

=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 %OPT = @_;
  $OPT{format} ||= $self->{option}->{format};
  if (($OPT{fill_date} || $self->{option}->{fill_date})>0
    && !$self->{header}->field_exist ('date')) {
    $self->{header}->field ('date')->unix_time (time);
  }
  if (($OPT{fill_msgid} || $self->{option}->{fill_msgid})>0
    && !$self->{header}->field_exist ('message-id')) {
    my $from = $self->{header}->field ('from')->addr_spec (1);
    $self->{header}->field ('message-id')->add_new (addr_spec => $from)
      if $from;
  }
  $self->_add_ua_field;
  my ($header, $body);
  if (ref $self->{header}) {
    $header = $self->{header}->stringify (format => $OPT{format});
  } else {
    $header = $self->{header};
  }
  if (ref $self->{body}) {
    $body = $self->{body}->stringify (format => $OPT{format});
  } else {
    $body = $self->{body};
  }
  $header .= "\n" if $header && $header !~ /\n$/;
  $header."\n".$body;
}
sub as_string ($;%) {shift->stringify}

=head2 $self->option ($option_name)

Returns/set (new) value of the option.

=cut

sub option ($$;$) {
  my $self = shift;
  my ($name, $newval) = @_;
  if ($newval) {
    $self->{option}->{$name} = $newval;
    if ($name eq 'format') {
      $self->header->option ($name => $newval);
    }
  }
  $self->{option}->{$name};
}

=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 ($;%) {
  'text/plain';
}

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

sub _add_ua_field ($) {
  my $self = shift;
  if ($self->{option}->{add_ua}>0) {
    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}>0) {
      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}>0;
  }
  $self;
}


=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/26 15:19:53 $

=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.2	use vars qw($VERSION %DEFAULT);
16	wakaba	1.7	$VERSION=do{my @r=(q$Revision: 1.6 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
17	wakaba	1.1
18			use Message::Header;
19			use overload '""' => sub {shift->stringify};
20
21	wakaba	1.3	%DEFAULT = (
22	wakaba	1.5	add_ua => 1,
23	wakaba	1.3	body_class => {'/DEFAULT' => 'Message::Body::TextPlain'},
24	wakaba	1.5	fill_date => 1,
25			fill_msgid => 1,
26	wakaba	1.7	format => 'rfc2822', ## rfc2822, usefor, http
27	wakaba	1.4	parse_all => -1,
28	wakaba	1.5	ua_field_name => 'user-agent',
29			ua_use_config => 1,
30	wakaba	1.3	);
31
32	wakaba	1.1	=head2 Message::Entity->new ([%option])
33
34			Returns new Message::Entity instance. Some options can be
35			specified as hash.
36
37			=cut
38
39			sub new ($;%) {
40			my $class = shift;
41			my $self = bless {option => {@_}}, $class;
42			for (keys %DEFAULT) {$self->{option}->{$_} \|\|= $DEFAULT{$_}}
43	wakaba	1.7	$self->{header} = new Message::Header (format => $self->{option}->{format});
44	wakaba	1.5	#$self->_add_ua_field;
45	wakaba	1.1	$self;
46			}
47
48			=head2 Message::Entity->parse ($message, [%option])
49
50			Parses given C<message> and return a new Message::Entity
51			object. Some options can be specified as hash.
52
53			=cut
54
55			sub parse ($$;%) {
56			my $class = shift;
57			my $message = shift;
58			my $self = bless {option => {@_}}, $class;
59			for (keys %DEFAULT) {$self->{option}->{$_} \|\|= $DEFAULT{$_}}
60			my ($isheader, @header, @body) = 1;
61			for my $line (split /\x0D?\x0A/, $message) {
62			if ($isheader && !length($line)) {
63			$isheader = 0;
64			} elsif ($isheader) {
65			push @header, $line
66			} else {
67			push @body, $line;
68			}
69			}
70	wakaba	1.4	$self->{header} = Message::Header->parse (join ("\n", @header),
71	wakaba	1.7	parse_all => $self->{option}->{parse_all},
72			format => $self->{option}->{format});
73	wakaba	1.1	$self->{body} = join "\n", @body;
74	wakaba	1.4	$self->{body} = $self->_body ($self->{body}, $self->content_type)
75			if $self->{option}->{parse_all}>0;
76	wakaba	1.5	#$self->_add_ua_field;
77	wakaba	1.1	$self;
78			}
79
80			=head2 $self->header ([$new_header])
81
82			Returns Message::Header unless $new_header.
83			Set $new_header instead of current C<header>.
84			If !ref $new_header, Message::Header->parse is automatically
85			called.
86
87			=cut
88
89			sub header ($;$) {
90			my $self = shift;
91			my $new_header = shift;
92			if (ref $new_header) {
93			$self->{header} = $new_header;
94			} elsif ($new_header) {
95	wakaba	1.4	$self->{header} = Message::Header->parse ($new_header,
96	wakaba	1.7	parse_all => $self->{option}->{parse_all},
97			format => $self->{option}->{format});
98	wakaba	1.1	}
99	wakaba	1.2	unless ($self->{header}) {
100	wakaba	1.7	$self->{header} = new Message::Header (format => $self->{option}->{format});
101	wakaba	1.2	}
102	wakaba	1.1	$self->{header};
103			}
104
105			=head2 $self->body ([$new_body])
106
107			Returns C<body> as string unless $new_body.
108			Set $new_body instead of current C<body>.
109
110			=cut
111
112			sub body ($;$) {
113			my $self = shift;
114			my $new_body = shift;
115			if ($new_body) {
116			$self->{body} = $new_body;
117			}
118	wakaba	1.3	$self->{body} = $self->_body ($self->{body}, $self->content_type)
119			unless ref $self->{body};
120	wakaba	1.1	$self->{body};
121			}
122
123	wakaba	1.3	sub _body ($;$$) {
124			my $self = shift;
125			my $body = shift;
126			my $ct = shift;
127			$ct = $self->{option}->{body_class}->{$ct}
128			\|\| $self->{option}->{body_class}->{'/DEFAULT'};
129			eval "require $ct";
130			if (ref $body) {
131			return $body;
132			} elsif ($body) {
133	wakaba	1.4	return $ct->parse ($body,
134			parse_all => $self->{option}->{parse_all});
135	wakaba	1.3	} else {
136			return $ct->new ($body);
137			}
138			}
139
140	wakaba	1.1	=head2 $self->stringify ([%option])
141
142			Returns the C<message> as a string.
143
144			=cut
145
146			sub stringify ($;%) {
147			my $self = shift;
148			my %OPT = @_;
149	wakaba	1.7	$OPT{format} \|\|= $self->{option}->{format};
150	wakaba	1.5	if (($OPT{fill_date} \|\| $self->{option}->{fill_date})>0
151			&& !$self->{header}->field_exist ('date')) {
152			$self->{header}->field ('date')->unix_time (time);
153			}
154			if (($OPT{fill_msgid} \|\| $self->{option}->{fill_msgid})>0
155			&& !$self->{header}->field_exist ('message-id')) {
156	wakaba	1.7	my $from = $self->{header}->field ('from')->addr_spec (1);
157	wakaba	1.5	$self->{header}->field ('message-id')->add_new (addr_spec => $from)
158			if $from;
159			}
160			$self->_add_ua_field;
161	wakaba	1.7	my ($header, $body);
162			if (ref $self->{header}) {
163			$header = $self->{header}->stringify (format => $OPT{format});
164			} else {
165			$header = $self->{header};
166			}
167			if (ref $self->{body}) {
168			$body = $self->{body}->stringify (format => $OPT{format});
169			} else {
170			$body = $self->{body};
171			}
172	wakaba	1.1	$header .= "\n" if $header && $header !~ /\n$/;
173			$header."\n".$body;
174			}
175	wakaba	1.4	sub as_string ($;%) {shift->stringify}
176	wakaba	1.1
177	wakaba	1.3	=head2 $self->option ($option_name)
178	wakaba	1.1
179	wakaba	1.3	Returns/set (new) value of the option.
180	wakaba	1.1
181			=cut
182
183	wakaba	1.3	sub option ($$;$) {
184	wakaba	1.1	my $self = shift;
185	wakaba	1.3	my ($name, $newval) = @_;
186			if ($newval) {
187			$self->{option}->{$name} = $newval;
188	wakaba	1.7	if ($name eq 'format') {
189			$self->header->option ($name => $newval);
190			}
191	wakaba	1.3	}
192	wakaba	1.1	$self->{option}->{$name};
193			}
194	wakaba	1.3
195			=head2 $self->content_type ([%options])
196
197			Returns C<body>'s content-type (Internet Media Type).
198			This method is not implemented yet so always returns
199			C<text/plain>.
200
201			=cut
202
203			sub content_type ($;%) {
204			'text/plain';
205	wakaba	1.1	}
206
207	wakaba	1.5	sub id ($) {
208			my $self = shift;
209			return scalar $self->{header}->field ('message-id')->id
210			if $self->{header}->field_exist ('message-id');
211			'';0
212			}
213
214			sub _add_ua_field ($) {
215			my $self = shift;
216			if ($self->{option}->{add_ua}>0) {
217			my $ua = $self->{header}->field ($self->{option}->{ua_field_name});
218			$ua->replace (name => 'Message-pm', version => $VERSION, add_prepend => -1);
219			my @os;
220			my @perl_comment;
221			if ($self->{option}->{ua_use_config}>0) {
222			eval q{use Config;
223			@os = (name => $^O, version => $Config{osvers}, add_prepend => -1);
224			push @perl_comment, $Config{archname};
225			};
226			} else {
227			push @perl_comment, $^O;
228			}
229			if ($^V) { ## 5.6 or later
230	wakaba	1.6	$ua->replace (name => 'Perl', version => sprintf ('%vd', $^V),
231			comment => [@perl_comment], add_prepend => -1);
232	wakaba	1.5	} elsif ($]) { ## Before 5.005
233			$ua->replace (name => 'Perl', version => $],
234			comment => [@perl_comment], add_prepend => -1);
235			}
236			$ua->replace (@os) if $self->{option}->{ua_use_config}>0;
237			}
238			$self;
239			}
240
241
242	wakaba	1.1	=head1 EXAMPLE
243
244			use Message::Entity;
245			my $msg = new Message::Entity;
246			$msg->header ($header);
247			$msg->body ($body);
248			print $msg;
249
250	wakaba	1.3	=head1 SEE ALSO
251
252			Message::* Perl modules
253			<http://suika.fam.cx/~wakaba/Message-pm/>
254
255	wakaba	1.1	=head1 LICENSE
256
257			Copyright 2002 wakaba E<lt>[email protected]<gt>.
258
259			This program is free software; you can redistribute it and/or modify
260			it under the terms of the GNU General Public License as published by
261			the Free Software Foundation; either version 2 of the License, or
262			(at your option) any later version.
263
264			This program is distributed in the hope that it will be useful,
265			but WITHOUT ANY WARRANTY; without even the implied warranty of
266			MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
267			GNU General Public License for more details.
268
269			You should have received a copy of the GNU General Public License
270			along with this program; see the file COPYING. If not, write to
271			the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
272			Boston, MA 02111-1307, USA.
273
274			=head1 CHANGE
275
276			See F<ChangeLog>.
277	wakaba	1.7	$Date: 2002/03/26 15:19:53 $
278	wakaba	1.1
279			=cut
280
281			1;