Message/Field/Path.pm


=head1 NAME

Message::Field::Path -- Perl module for C<Path:> header 
field body of Usenet news format messages

=cut

package Message::Field::Path;
use strict;
use vars qw(@ISA %REG $VERSION);
$VERSION=do{my @r=(q$Revision: 1.2 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
require Message::Util;
require Message::Field::Structured;
push @ISA, qw(Message::Field::Structured);
use Carp;

use overload '@{}' => sub {shift->{path}},
             '""' => sub {shift->stringify};

*REG = \%Message::Util::REG;
$REG{delimiter} = qr/[^0-9A-Za-z.:_-]+/;
$REG{delimiter_char} = qr#[!%,/?]#;
$REG{path_identity} = qr/[0-9A-Za-z.:_-]+/;
$REG{NON_delimiter} = qr#[^!%,/?]#;
$REG{NON_path_identity} = qr/[^0-9A-Za-z.:_-]/;


=head1 CONSTRUCTORS

The following methods construct new objects:

=over 4

=cut

## Initialize of this class -- called by constructors
sub _init ($;%) {
  my $self = shift;
  my %options = @_;
  my %DEFAULT = (
    -check_path_identity        => 1,
    -max_line_length    => 50,
    -output_obs_delimiter       =>  -1,
  );
  $self->SUPER::_init (%DEFAULT, %options);
  my @a = ();
  for (grep {/^[^-]/} keys %options) {
    push @a, $_ => $options{$_};
  }
  $self->add (@a) if $#a > -1;
}

=item $p = Message::Field::Path->new ([%options])

Constructs a new object.  You might pass some 
options as parameters to the constructor.

=cut

## Inherited

=item $p = Message::Field::Path->parse ($field-body, [%options])

Constructs a new object with given field body.  
You might pass some options as parameters to the constructor.

=cut

sub parse ($$;%) {
  my $class = shift;
  my $self = bless {}, $class;
  my $fbody = shift;
  $self->_init (@_);
  my @p = ();
  $fbody =~ s{^$REG{FWS}($REG{path_identity})}{
    push @p, [$1, ''];
    '';
  }ex;
  $fbody =~ s{($REG{delimiter})($REG{path_identity})}{
    my ($delimiter, $path_identity) = ($1, $2);
    $delimiter =~ tr/\x09\x20//d;
    push @p, [$path_identity, $delimiter];
    '';
  }gex;
  $self->{path} = \@p;
  $self;
}

=back

=head1 METHODS

=over 4

=item $p->add ($path-identity, [$delimiter], [%options])

Adds new C<path-identity> and C<delimiter> (optional).
Only one option, C<check_path_identity> is available.

See also L<EXAMPLE>.

=cut

sub add ($%) {
  my $self = shift;
  my %p = @_;
  my %option = %{$self->{option}};
  for (grep {/^-/} keys %p) {$option{substr ($_, 1)} = $p{$_}}
  for (grep {/^[^-]/} keys %p) {
    croak "add: $_: invalid path-identity"
      if $option{check_path_identity} && $_ =~ /$REG{NON_path_identity}/;
    unshift @{$self->{path}}, [$_, ''];
    $self->{path}->[1]->[1] = $p{$_} if $#{$self->{path}} > 0;
  }
}


=item $p->path_identity ($index)

Returns C<$index>'th C<path-identity>, if any.
You can't set value.  (Is it necessary?)  Use C<add> method
to add new C<path-identity>.

=cut

sub path_identity ($$) {
  my $self = shift;
  my $i = shift;
  $self->{path}->[$i]->[0] if ref $self->{path}->[$i];
}

=item $p->delimiter ($index)

Returns C<$index>'th C<delimiter>, if any.
You can't set new value.  (Is it necessary?)

Note that C<$self-E<gt>delimiter (0)> would return
no value in most situation.

=cut

sub delimiter ($$) {
  my $self = shift;
  my $i = shift;
  $self->{path}->[$i]->[1] if ref $self->{path}->[$i];
}

=item $p->stringify ([%options])

Returns C<field-body> as a string.

=cut

sub stringify ($;%) {
  my $self = shift;
  my %option = %{$self->{option}};  my %p = @_;
  for (grep {/^-/} keys %p) {$option{substr ($_, 1)} = $p{$_}}
  my ($r, $l) = ('', 0);
  for (@{$self->{path}}) {
    my ($path_identity, $delimiter) = (${$_}[0], ${$_}[1] || '!');
    next unless $path_identity;
    next if $option{check_path_identity}
            && $path_identity =~ /$REG{NON_path_identity}/;
    if ($l) {
      $delimiter = '!' if !$option{output_obs_delimiter}
                          && $delimiter !~ /^$REG{delimiter_char}$/;
      if ($option{max_line_length} && $l > $option{max_line_length}) {
        $delimiter .= ' ';  $l = 0;
      }
      $r .= $delimiter;  $l += length $delimiter;
    }
    $r .= $path_identity;  $l += length $path_identity;
  }
  $r;
}

=item $option-value = $p->option ($option-name)

Gets option value.

=item $p->option ($option-name, $option-value, ...)

Set option value(s).  You can pass multiple option name-value pair
as parameter when setting.

=cut

## Inherited

=item $clone = $p->clone ()

Returns a copy of the object.

=cut

sub clone ($) {
  my $self = shift;
  my $clone = $self->SUPER::clone;
  my @p;
  for (@{$self->{path}}) {
    my $id = ref $_->[0]? $_->[0]->clone: $_->[0];
    my $dl = ref $_->[1]? $_->[1]->clone: $_->[1];
    push @p, [$id, $dl];
  }
  $clone->{path} = \@p;
  $clone;
}

=head1 NOTE

C<stringify> of this module insert SPACE when C<Path-content>
is too long.  ("long" is determined by the value of option
C<max_line_length>.)  This is intended to be able to fold
C<Path:> field body.  But some of implementions does not support
folding this line though article format specifications 
(except son-of-RFC1036) allow to insert white-space character.

Implementor shold set value of C<max_line_length> as long as
possible.  (Default value C<50> can be too small...)
When C<max_line_length> is C<-1>, C<stringify> does not
insert any white-space characters.

=head1 EXAMPLE

  use Message::Field::Path;
  
  ## Parse Path: field-body and print path-identity list.
  my $path = 'foo.isp.example/foo-server/bar.isp.example?'
            .'10.123.12.2/old.site.example!barbaz/baz.isp.example'
            .'%dialup123.baz.isp.example!x';
  my $p = Message::Field::Path->parse ($path);
  
  for my $i (0..$#$p) {
    print $p->delimiter ($i), "\t", $p->path_identity ($i), "\n";
  }
  
  ## Compose new Path: header field content.  (You won't do
  ## such stupid operation usually.  This is only an example.)
  my $p = new Message::Field::Path;
  $p->add ('not-for-mail');
  $p->add ('spool.foo.example', '!');
  $p->add ('injecter.foo.example', '%');
  $p->add ('news.local.example' => '/' => 'news.bar.example' => '/');
  print "Path: ", fold ($p), "\n";      ## fold() is assumed as a function to fold
  # Path: news.local.example/news.bar.example/injecter.foo.example%
  #   spool.foo.example!not-for-mail

=head1 LICENSE

Copyright 2002 wakaba E<lt>w@suika.fam.cxE<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/04/13 01:33:54 $

=cut

1;
1	wakaba	1.1
2			=head1 NAME
3
4	wakaba	1.2	Message::Field::Path -- Perl module for C<Path:> header
5			field body of Usenet news format messages
6	wakaba	1.1
7			=cut
8
9			package Message::Field::Path;
10			use strict;
11	wakaba	1.2	use vars qw(@ISA %REG $VERSION);
12			$VERSION=do{my @r=(q$Revision: 1.2 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
13			require Message::Util;
14			require Message::Field::Structured;
15			push @ISA, qw(Message::Field::Structured);
16			use Carp;
17
18	wakaba	1.1	use overload '@{}' => sub {shift->{path}},
19			'""' => sub {shift->stringify};
20
21	wakaba	1.2	*REG = \%Message::Util::REG;
22	wakaba	1.1	$REG{delimiter} = qr/[^0-9A-Za-z.:_-]+/;
23			$REG{delimiter_char} = qr#[!%,/?]#;
24			$REG{path_identity} = qr/[0-9A-Za-z.:_-]+/;
25			$REG{NON_delimiter} = qr#[^!%,/?]#;
26			$REG{NON_path_identity} = qr/[^0-9A-Za-z.:_-]/;
27
28
29	wakaba	1.2	=head1 CONSTRUCTORS
30	wakaba	1.1
31	wakaba	1.2	The following methods construct new objects:
32
33			=over 4
34	wakaba	1.1
35			=cut
36
37	wakaba	1.2	## Initialize of this class -- called by constructors
38			sub _init ($;%) {
39			my $self = shift;
40			my %options = @_;
41			my %DEFAULT = (
42			-check_path_identity => 1,
43			-max_line_length => 50,
44			-output_obs_delimiter => -1,
45			);
46			$self->SUPER::_init (%DEFAULT, %options);
47			my @a = ();
48			for (grep {/^[^-]/} keys %options) {
49			push @a, $_ => $options{$_};
50			}
51			$self->add (@a) if $#a > -1;
52	wakaba	1.1	}
53
54	wakaba	1.2	=item $p = Message::Field::Path->new ([%options])
55
56			Constructs a new object. You might pass some
57			options as parameters to the constructor.
58
59			=cut
60
61			## Inherited
62	wakaba	1.1
63	wakaba	1.2	=item $p = Message::Field::Path->parse ($field-body, [%options])
64
65			Constructs a new object with given field body.
66			You might pass some options as parameters to the constructor.
67	wakaba	1.1
68			=cut
69
70			sub parse ($$;%) {
71	wakaba	1.2	my $class = shift;
72			my $self = bless {}, $class;
73	wakaba	1.1	my $fbody = shift;
74	wakaba	1.2	$self->_init (@_);
75	wakaba	1.1	my @p = ();
76			$fbody =~ s{^$REG{FWS}($REG{path_identity})}{
77			push @p, [$1, ''];
78			'';
79			}ex;
80			$fbody =~ s{($REG{delimiter})($REG{path_identity})}{
81			my ($delimiter, $path_identity) = ($1, $2);
82			$delimiter =~ tr/\x09\x20//d;
83			push @p, [$path_identity, $delimiter];
84			'';
85			}gex;
86			$self->{path} = \@p;
87			$self;
88			}
89
90	wakaba	1.2	=back
91
92			=head1 METHODS
93
94			=over 4
95
96			=item $p->add ($path-identity, [$delimiter], [%options])
97	wakaba	1.1
98			Adds new C<path-identity> and C<delimiter> (optional).
99	wakaba	1.2	Only one option, C<check_path_identity> is available.
100	wakaba	1.1
101			See also L<EXAMPLE>.
102
103			=cut
104
105	wakaba	1.2	sub add ($%) {
106	wakaba	1.1	my $self = shift;
107	wakaba	1.2	my %p = @_;
108			my %option = %{$self->{option}};
109			for (grep {/^-/} keys %p) {$option{substr ($_, 1)} = $p{$_}}
110			for (grep {/^[^-]/} keys %p) {
111			croak "add: $_: invalid path-identity"
112			if $option{check_path_identity} && $_ =~ /$REG{NON_path_identity}/;
113			unshift @{$self->{path}}, [$_, ''];
114			$self->{path}->[1]->[1] = $p{$_} if $#{$self->{path}} > 0;
115			}
116	wakaba	1.1	}
117
118	wakaba	1.2
119			=item $p->path_identity ($index)
120	wakaba	1.1
121			Returns C<$index>'th C<path-identity>, if any.
122			You can't set value. (Is it necessary?) Use C<add> method
123			to add new C<path-identity>.
124
125			=cut
126
127			sub path_identity ($$) {
128			my $self = shift;
129			my $i = shift;
130			$self->{path}->[$i]->[0] if ref $self->{path}->[$i];
131			}
132
133	wakaba	1.2	=item $p->delimiter ($index)
134	wakaba	1.1
135			Returns C<$index>'th C<delimiter>, if any.
136			You can't set new value. (Is it necessary?)
137
138			Note that C<$self-E<gt>delimiter (0)> would return
139			no value in most situation.
140
141			=cut
142
143			sub delimiter ($$) {
144			my $self = shift;
145			my $i = shift;
146			$self->{path}->[$i]->[1] if ref $self->{path}->[$i];
147			}
148
149	wakaba	1.2	=item $p->stringify ([%options])
150
151			Returns C<field-body> as a string.
152
153			=cut
154
155	wakaba	1.1	sub stringify ($;%) {
156			my $self = shift;
157	wakaba	1.2	my %option = %{$self->{option}}; my %p = @_;
158			for (grep {/^-/} keys %p) {$option{substr ($_, 1)} = $p{$_}}
159	wakaba	1.1	my ($r, $l) = ('', 0);
160			for (@{$self->{path}}) {
161			my ($path_identity, $delimiter) = (${$_}[0], ${$_}[1] \|\| '!');
162			next unless $path_identity;
163	wakaba	1.2	next if $option{check_path_identity}
164	wakaba	1.1	&& $path_identity =~ /$REG{NON_path_identity}/;
165			if ($l) {
166	wakaba	1.2	$delimiter = '!' if !$option{output_obs_delimiter}
167	wakaba	1.1	&& $delimiter !~ /^$REG{delimiter_char}$/;
168	wakaba	1.2	if ($option{max_line_length} && $l > $option{max_line_length}) {
169	wakaba	1.1	$delimiter .= ' '; $l = 0;
170			}
171			$r .= $delimiter; $l += length $delimiter;
172			}
173			$r .= $path_identity; $l += length $path_identity;
174			}
175			$r;
176			}
177
178	wakaba	1.2	=item $option-value = $p->option ($option-name)
179	wakaba	1.1
180	wakaba	1.2	Gets option value.
181
182			=item $p->option ($option-name, $option-value, ...)
183
184			Set option value(s). You can pass multiple option name-value pair
185			as parameter when setting.
186
187			=cut
188
189			## Inherited
190
191			=item $clone = $p->clone ()
192
193			Returns a copy of the object.
194	wakaba	1.1
195			=cut
196
197	wakaba	1.2	sub clone ($) {
198	wakaba	1.1	my $self = shift;
199	wakaba	1.2	my $clone = $self->SUPER::clone;
200			my @p;
201			for (@{$self->{path}}) {
202			my $id = ref $_->[0]? $_->[0]->clone: $_->[0];
203			my $dl = ref $_->[1]? $_->[1]->clone: $_->[1];
204			push @p, [$id, $dl];
205	wakaba	1.1	}
206	wakaba	1.2	$clone->{path} = \@p;
207			$clone;
208	wakaba	1.1	}
209
210			=head1 NOTE
211
212			C<stringify> of this module insert SPACE when C<Path-content>
213			is too long. ("long" is determined by the value of option
214			C<max_line_length>.) This is intended to be able to fold
215			C<Path:> field body. But some of implementions does not support
216			folding this line though article format specifications
217			(except son-of-RFC1036) allow to insert white-space character.
218
219			Implementor shold set value of C<max_line_length> as long as
220			possible. (Default value C<50> can be too small...)
221			When C<max_line_length> is C<-1>, C<stringify> does not
222			insert any white-space characters.
223
224			=head1 EXAMPLE
225
226			use Message::Field::Path;
227
228			## Parse Path: field-body and print path-identity list.
229			my $path = 'foo.isp.example/foo-server/bar.isp.example?'
230			.'10.123.12.2/old.site.example!barbaz/baz.isp.example'
231			.'%dialup123.baz.isp.example!x';
232			my $p = Message::Field::Path->parse ($path);
233
234			for my $i (0..$#$p) {
235			print $p->delimiter ($i), "\t", $p->path_identity ($i), "\n";
236			}
237
238			## Compose new Path: header field content. (You won't do
239			## such stupid operation usually. This is only an example.)
240			my $p = new Message::Field::Path;
241			$p->add ('not-for-mail');
242			$p->add ('spool.foo.example', '!');
243			$p->add ('injecter.foo.example', '%');
244	wakaba	1.2	$p->add ('news.local.example' => '/' => 'news.bar.example' => '/');
245	wakaba	1.1	print "Path: ", fold ($p), "\n"; ## fold() is assumed as a function to fold
246			# Path: news.local.example/news.bar.example/injecter.foo.example%
247			# spool.foo.example!not-for-mail
248
249			=head1 LICENSE
250
251			Copyright 2002 wakaba E<lt>w@suika.fam.cxE<gt>.
252
253			This program is free software; you can redistribute it and/or modify
254			it under the terms of the GNU General Public License as published by
255			the Free Software Foundation; either version 2 of the License, or
256			(at your option) any later version.
257
258			This program is distributed in the hope that it will be useful,
259			but WITHOUT ANY WARRANTY; without even the implied warranty of
260			MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
261			GNU General Public License for more details.
262
263			You should have received a copy of the GNU General Public License
264			along with this program; see the file COPYING. If not, write to
265			the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
266			Boston, MA 02111-1307, USA.
267
268			=head1 CHANGE
269
270			See F<ChangeLog>.
271	wakaba	1.2	$Date: 2002/04/13 01:33:54 $
272	wakaba	1.1
273			=cut
274
275			1;