Message/Field/Path.pm


=head1 NAME

Message::Field::Path Perl module

=head1 DESCRIPTION

Perl module for C<Path:> header field.

=cut

package Message::Field::Path;
use strict;
use vars qw(%REG $VERSION);
$VERSION=do{my @r=(q$Revision: 1.4 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
use overload '@{}' => sub {shift->{path}},
             '""' => sub {shift->stringify};
require Message::Util;
use Carp;
$REG{WSP} = qr/[\x20\x09]+/;
$REG{FWS} = qr/[\x20\x09]*/;

$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.:_-]/;

my %DEFAULT = (
  check_invalid_path_identity   => 1,
  max_line_length       => 50,
  output_obs_delimiter  =>  -1,
);

=head2 Message::Field::Path->new ()

Returns new instance for Message::Field::Path.

=cut

sub new ($;%) {
  my $self = bless {option => {@_}, path => []}, shift;
  for (%DEFAULT) {$self->{option}->{$_} ||= $DEFAULT{$_}}
  $self;
}

=head2 Message::Field::Path->parse ($unfolded-field-body)

Parses C<field-body> as C<Path> field.

=cut

sub parse ($$;%) {
  my $self = bless {}, shift;
  my $fbody = shift;
  my %option = @_;
  for (%DEFAULT) {$option{$_} ||= $DEFAULT{$_}}
  $self->{option} = \%option;
  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;
}

=head2 $self->add ($path-identity, [$delimiter], [%options])

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

See also L<EXAMPLE>.

=cut

sub add ($$;$%) {
  my $self = shift;
  my ($path_identity, $delimiter, %option) = (@_);
  $option{check_invalid_path_identity}
    ||= $self->{option}->{check_invalid_path_identity};
  croak "add: $path_identity: invalid path-identity"
    if $option{check_invalid_path_identity}>0 
       && $path_identity =~ /$REG{NON_path_identity}/;
  unshift @{$self->{path}}, [$path_identity, ''];
  $self->{path}->[1]->[1] = $delimiter if $#{$self->{path}} > 0;
  $self;
}

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

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

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

=head2 $self->option ($option_name, [$option_value])

Set/gets new value of the option.

=cut

sub option ($$;$) {
  my $self = shift;
  my ($name, $value) = @_;
  if (defined $value) {
    $self->{option}->{$name} = $value;
  }
  $self->{option}->{$name};
}

=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.bar.example', '/');
  $p->add ('news.local.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/03/31 13:11:55 $

=cut

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