/[suikacvs]/messaging/manakai/lib/Message/Field/Path.pm
Suika

Diff of /messaging/manakai/lib/Message/Field/Path.pm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1 by wakaba, Tue Apr 2 11:52:12 2002 UTC revision 1.2 by wakaba, Sat Apr 13 01:33:54 2002 UTC
# Line 1  Line 1 
1    
2  =head1 NAME  =head1 NAME
3    
4  Message::Field::Path Perl module  Message::Field::Path -- Perl module for C<Path:> header
5    field body of Usenet news format messages
 =head1 DESCRIPTION  
   
 Perl module for C<Path:> header field.  
6    
7  =cut  =cut
8    
9  package Message::Field::Path;  package Message::Field::Path;
10  use strict;  use strict;
11  use vars qw(%REG $VERSION);  use vars qw(@ISA %REG $VERSION);
12  $VERSION=do{my @r=(q$Revision$=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};  $VERSION=do{my @r=(q$Revision$=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
 use overload '@{}' => sub {shift->{path}},  
              '""' => sub {shift->stringify};  
13  require Message::Util;  require Message::Util;
14    require Message::Field::Structured;
15    push @ISA, qw(Message::Field::Structured);
16  use Carp;  use Carp;
 $REG{WSP} = qr/[\x20\x09]+/;  
 $REG{FWS} = qr/[\x20\x09]*/;  
17    
18    use overload '@{}' => sub {shift->{path}},
19                 '""' => sub {shift->stringify};
20    
21    *REG = \%Message::Util::REG;
22  $REG{delimiter} = qr/[^0-9A-Za-z.:_-]+/;  $REG{delimiter} = qr/[^0-9A-Za-z.:_-]+/;
23  $REG{delimiter_char} = qr#[!%,/?]#;  $REG{delimiter_char} = qr#[!%,/?]#;
24  $REG{path_identity} = qr/[0-9A-Za-z.:_-]+/;  $REG{path_identity} = qr/[0-9A-Za-z.:_-]+/;
25  $REG{NON_delimiter} = qr#[^!%,/?]#;  $REG{NON_delimiter} = qr#[^!%,/?]#;
26  $REG{NON_path_identity} = qr/[^0-9A-Za-z.:_-]/;  $REG{NON_path_identity} = qr/[^0-9A-Za-z.:_-]/;
27    
 my %DEFAULT = (  
   check_invalid_path_identity   => 1,  
   max_line_length       => 50,  
   output_obs_delimiter  =>  -1,  
 );  
28    
29  =head2 Message::Field::Path->new ()  =head1 CONSTRUCTORS
30    
31  Returns new instance for Message::Field::Path.  The following methods construct new objects:
32    
33    =over 4
34    
35  =cut  =cut
36    
37  sub new ($;%) {  ## Initialize of this class -- called by constructors
38    my $self = bless {option => {@_}, path => []}, shift;  sub _init ($;%) {
39    for (%DEFAULT) {$self->{option}->{$_} ||= $DEFAULT{$_}}    my $self = shift;
40    $self;    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  }  }
53    
54  =head2 Message::Field::Path->parse ($unfolded-field-body)  =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    
63  Parses C<field-body> as C<Path> field.  =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    
68  =cut  =cut
69    
70  sub parse ($$;%) {  sub parse ($$;%) {
71    my $self = bless {}, shift;    my $class = shift;
72      my $self = bless {}, $class;
73    my $fbody = shift;    my $fbody = shift;
74    my %option = @_;    $self->_init (@_);
   for (%DEFAULT) {$option{$_} ||= $DEFAULT{$_}}  
   $self->{option} = \%option;  
75    my @p = ();    my @p = ();
76    $fbody =~ s{^$REG{FWS}($REG{path_identity})}{    $fbody =~ s{^$REG{FWS}($REG{path_identity})}{
77      push @p, [$1, ''];      push @p, [$1, ''];
# Line 71  sub parse ($$;%) { Line 87  sub parse ($$;%) {
87    $self;    $self;
88  }  }
89    
90  =head2 $self->add ($path-identity, [$delimiter], [%options])  =back
91    
92    =head1 METHODS
93    
94    =over 4
95    
96    =item $p->add ($path-identity, [$delimiter], [%options])
97    
98  Adds new C<path-identity> and C<delimiter> (optional).  Adds new C<path-identity> and C<delimiter> (optional).
99  Only one option, C<check_invalid_path_identity> is available.  Only one option, C<check_path_identity> is available.
100    
101  See also L<EXAMPLE>.  See also L<EXAMPLE>.
102    
103  =cut  =cut
104    
105  sub add ($$;$%) {  sub add ($%) {
106    my $self = shift;    my $self = shift;
107    my ($path_identity, $delimiter, %option) = (@_);    my %p = @_;
108    $option{check_invalid_path_identity}    my %option = %{$self->{option}};
109      ||= $self->{option}->{check_invalid_path_identity};    for (grep {/^-/} keys %p) {$option{substr ($_, 1)} = $p{$_}}
110    croak "add: $path_identity: invalid path-identity"    for (grep {/^[^-]/} keys %p) {
111      if $option{check_invalid_path_identity}>0      croak "add: $_: invalid path-identity"
112         && $path_identity =~ /$REG{NON_path_identity}/;        if $option{check_path_identity} && $_ =~ /$REG{NON_path_identity}/;
113    unshift @{$self->{path}}, [$path_identity, ''];      unshift @{$self->{path}}, [$_, ''];
114    $self->{path}->[1]->[1] = $delimiter if $#{$self->{path}} > 0;      $self->{path}->[1]->[1] = $p{$_} if $#{$self->{path}} > 0;
115    $self;    }
116  }  }
117    
118  =head2 $self->path_identity ($index)  
119    =item $p->path_identity ($index)
120    
121  Returns C<$index>'th C<path-identity>, if any.  Returns C<$index>'th C<path-identity>, if any.
122  You can't set value.  (Is it necessary?)  Use C<add> method  You can't set value.  (Is it necessary?)  Use C<add> method
# Line 107  sub path_identity ($$) { Line 130  sub path_identity ($$) {
130    $self->{path}->[$i]->[0] if ref $self->{path}->[$i];    $self->{path}->[$i]->[0] if ref $self->{path}->[$i];
131  }  }
132    
133  =head2 $self->delimiter ($index)  =item $p->delimiter ($index)
134    
135  Returns C<$index>'th C<delimiter>, if any.  Returns C<$index>'th C<delimiter>, if any.
136  You can't set new value.  (Is it necessary?)  You can't set new value.  (Is it necessary?)
# Line 123  sub delimiter ($$) { Line 146  sub delimiter ($$) {
146    $self->{path}->[$i]->[1] if ref $self->{path}->[$i];    $self->{path}->[$i]->[1] if ref $self->{path}->[$i];
147  }  }
148    
149    =item $p->stringify ([%options])
150    
151    Returns C<field-body> as a string.
152    
153    =cut
154    
155  sub stringify ($;%) {  sub stringify ($;%) {
156    my $self = shift;    my $self = shift;
157    my %option = @_;    my %option = %{$self->{option}};  my %p = @_;
158    $option{check_invalid_path_identity}    for (grep {/^-/} keys %p) {$option{substr ($_, 1)} = $p{$_}}
     ||= $self->{option}->{check_invalid_path_identity};  
   $option{max_line_length} ||= $self->{option}->{max_line_length};  
   $option{output_obs_delimiter} ||= $self->{option}->{output_obs_delimiter};  
159    my ($r, $l) = ('', 0);    my ($r, $l) = ('', 0);
160    for (@{$self->{path}}) {    for (@{$self->{path}}) {
161      my ($path_identity, $delimiter) = (${$_}[0], ${$_}[1] || '!');      my ($path_identity, $delimiter) = (${$_}[0], ${$_}[1] || '!');
162      next unless $path_identity;      next unless $path_identity;
163      next if $option{check_invalid_path_identity}>0      next if $option{check_path_identity}
164              && $path_identity =~ /$REG{NON_path_identity}/;              && $path_identity =~ /$REG{NON_path_identity}/;
165      if ($l) {      if ($l) {
166        $delimiter = '!' if $option{output_obs_delimiter}<0        $delimiter = '!' if !$option{output_obs_delimiter}
167                            && $delimiter !~ /^$REG{delimiter_char}$/;                            && $delimiter !~ /^$REG{delimiter_char}$/;
168        if ($option{max_line_length}>0 && $l > $option{max_line_length}) {        if ($option{max_line_length} && $l > $option{max_line_length}) {
169          $delimiter .= ' ';  $l = 0;          $delimiter .= ' ';  $l = 0;
170        }        }
171        $r .= $delimiter;  $l += length $delimiter;        $r .= $delimiter;  $l += length $delimiter;
# Line 149  sub stringify ($;%) { Line 175  sub stringify ($;%) {
175    $r;    $r;
176  }  }
177    
178  =head2 $self->option ($option_name, [$option_value])  =item $option-value = $p->option ($option-name)
179    
180  Set/gets new value of the option.  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    
195  =cut  =cut
196    
197  sub option ($$;$) {  sub clone ($) {
198    my $self = shift;    my $self = shift;
199    my ($name, $value) = @_;    my $clone = $self->SUPER::clone;
200    if (defined $value) {    my @p;
201      $self->{option}->{$name} = $value;    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    }    }
206    $self->{option}->{$name};    $clone->{path} = \@p;
207      $clone;
208  }  }
209    
210  =head1 NOTE  =head1 NOTE
# Line 198  insert any white-space characters. Line 241  insert any white-space characters.
241    $p->add ('not-for-mail');    $p->add ('not-for-mail');
242    $p->add ('spool.foo.example', '!');    $p->add ('spool.foo.example', '!');
243    $p->add ('injecter.foo.example', '%');    $p->add ('injecter.foo.example', '%');
244    $p->add ('news.bar.example', '/');    $p->add ('news.local.example' => '/' => 'news.bar.example' => '/');
   $p->add ('news.local.example', '/');  
245    print "Path: ", fold ($p), "\n";      ## fold() is assumed as a function to fold    print "Path: ", fold ($p), "\n";      ## fold() is assumed as a function to fold
246    # Path: news.local.example/news.bar.example/injecter.foo.example%    # Path: news.local.example/news.bar.example/injecter.foo.example%
247    #   spool.foo.example!not-for-mail    #   spool.foo.example!not-for-mail
Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24