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	wakaba	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;