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.5 $=~/\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,
  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;
  #$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});
  $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});
  }
  unless ($self->{header}) {
    $self->{header} = new Message::Header ();
  }
  $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 = @_;
  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 (0);
    $self->{header}->field ('message-id')->add_new (addr_spec => $from)
      if $from;
  }
  $self->_add_ua_field;
  my ($header, $body) = ($self->{header}, $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;
  }
  $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 05:41:16 $

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