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
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	use vars qw($VERSION %DEFAULT);
16	$VERSION=do{my @r=(q$Revision: 1.6 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
17
18	use Message::Header;
19	use overload '""' => sub {shift->stringify};
20
21	%DEFAULT = (
22	add_ua => 1,
23	body_class => {'/DEFAULT' => 'Message::Body::TextPlain'},
24	fill_date => 1,
25	fill_msgid => 1,
26	format => 'rfc2822', ## rfc2822, usefor, http
27	parse_all => -1,
28	ua_field_name => 'user-agent',
29	ua_use_config => 1,
30	);
31
32	=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	$self->{header} = new Message::Header (format => $self->{option}->{format});
44	#$self->_add_ua_field;
45	$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	$self->{header} = Message::Header->parse (join ("\n", @header),
71	parse_all => $self->{option}->{parse_all},
72	format => $self->{option}->{format});
73	$self->{body} = join "\n", @body;
74	$self->{body} = $self->_body ($self->{body}, $self->content_type)
75	if $self->{option}->{parse_all}>0;
76	#$self->_add_ua_field;
77	$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	$self->{header} = Message::Header->parse ($new_header,
96	parse_all => $self->{option}->{parse_all},
97	format => $self->{option}->{format});
98	}
99	unless ($self->{header}) {
100	$self->{header} = new Message::Header (format => $self->{option}->{format});
101	}
102	$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	$self->{body} = $self->_body ($self->{body}, $self->content_type)
119	unless ref $self->{body};
120	$self->{body};
121	}
122
123	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	return $ct->parse ($body,
134	parse_all => $self->{option}->{parse_all});
135	} else {
136	return $ct->new ($body);
137	}
138	}
139
140	=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	$OPT{format} \|\|= $self->{option}->{format};
150	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	my $from = $self->{header}->field ('from')->addr_spec (1);
157	$self->{header}->field ('message-id')->add_new (addr_spec => $from)
158	if $from;
159	}
160	$self->_add_ua_field;
161	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	$header .= "\n" if $header && $header !~ /\n$/;
173	$header."\n".$body;
174	}
175	sub as_string ($;%) {shift->stringify}
176
177	=head2 $self->option ($option_name)
178
179	Returns/set (new) value of the option.
180
181	=cut
182
183	sub option ($$;$) {
184	my $self = shift;
185	my ($name, $newval) = @_;
186	if ($newval) {
187	$self->{option}->{$name} = $newval;
188	if ($name eq 'format') {
189	$self->header->option ($name => $newval);
190	}
191	}
192	$self->{option}->{$name};
193	}
194
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	}
206
207	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	$ua->replace (name => 'Perl', version => sprintf ('%vd', $^V),
231	comment => [@perl_comment], add_prepend => -1);
232	} 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	=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	=head1 SEE ALSO
251
252	Message::* Perl modules
253	<http://suika.fam.cx/~wakaba/Message-pm/>
254
255	=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	$Date: 2002/03/26 15:19:53 $
278
279	=cut
280
281	1;