Message/Field/URI.pm


=head1 NAME

Message::Field::URI --- A Perl Module for Internet Message
Header Field Bodies filled with a URI

=cut

package Message::Field::URI;
use strict;
require 5.6.0;
use re 'eval';
use vars qw(%DEFAULT @ISA %REG $VERSION);
$VERSION=do{my @r=(q$Revision: 1.3 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
require Message::Field::Structured;
push @ISA, qw(Message::Field::Structured);

%REG = %Message::Util::REG;
        $REG{SCM_angle_quoted} = qr/<([^\x3E]*)>/;

        ## Simple version of URI regex  See RFC 2396, RFC 2732, RFC 2324.
        #$REG{escaped} = qr/%[0-9A-Fa-f][0-9A-Fa-f]/;
        #$REG{scheme} = qr/(?:[A-Za-z]|$REG{escaped})(?:[0-9A-Za-z+.-]|$REG{escaped})*/;
                ## RFC 2324 defines escaped UTF-8 scheme names:-)
        #$REG{fragment} = qr/\x23(?:[\x21\x24\x26-\x3B\x3D\x3F-\x5A\x5F\x61-\x7A\x7E]|$REG{escaped})*/;
        #$REG{S_uri_body} = qr/(?:[\x21\x24\x26-\x3B\x3D\x3F-\x5A\x5B\x5D\x5F\x61-\x7A\x7E]|$REG{escaped})+/;
        #$REG{S_absoluteURI} = qr/$REG{scheme}:$REG{S_uri_body}/;
        #$REG{S_relativeURI} = qr/$REG{S_uri_body}/;
        #$REG{S_URI_reference} = qr/(?:$REG{S_absoluteURI}|$REG{S_relativeURI})(?:$REG{fragment})?|(?:$REG{fragment})/;
                ## RFC 2396 allows <> (empty URI), but this regex doesn't.
        
        #$REG{uri_phrase} = qr/[\x21\x23-\x3B\x3D\x3F-\x5B\x5D\x5F\x61-\x7A\x7E]+(?:$REG{WSP}+[\x21\x23-\x27\x29-\x3B\x3D\x3F-\x5B\x5D\x5F\x61-\x7A\x7E][\x21\x23-\x3B\x3D\x3F-\x5B\x5D\x5F\x61-\x7A\x7E]*)*/;

=head1 CONSTRUCTORS

The following methods construct new objects:

=over 4

=cut

%DEFAULT = (
    -_MEMBERS   => [qw|display_name|],
    -_METHODS   => [qw|display_name uri
                       comment_add comment_delete comment_item
                       comment_count|],
    -allow_absolute     => 1,   ## TODO: not implemented
    -allow_empty        => 1,
    -allow_fragment     => 1,   ## TODO: not implemented
    -allow_relative     => 1,   ## TODO: not implemented
    #encoding_after_encode
    #encoding_before_decode
    #field_param_name
    #field_name
    #hook_encode_string
    #hook_decode_string
    -output_angle_bracket       => 1,
    -output_comment     => 1,
    -output_display_name        => 1,
    #parse_all
    -unsafe_rule_display_name   => 'NON_http_attribute_char_wsp',
    -use_comment        => 1,
    -use_display_name   => 1,
);

sub _init ($;%) {
  my $self = shift;
  my %options = @_;
  my $DEFAULT = Message::Util::make_clone (\%DEFAULT);
  $self->SUPER::_init (%$DEFAULT, %options);
  #$self->{option}->{value_type}->{uri} = ['URI::'];
  
  my $format = $self->{option}->{format};
  my $field = $self->{option}->{field_name};
  my $fieldns = $self->{option}->{field_ns};
  $format = 'mhtml' if $format =~ /mail|news/;
  if ($fieldns eq $Message::Header::NS_phname2uri{list}) {
    $self->{option}->{output_display_name} = 0;
    $self->{option}->{allow_empty} = 0;
  } elsif ($fieldns eq $Message::Header::NS_phname2uri{content}) {
    if ($field eq 'location') {
      $self->{option}->{output_angle_bracket} = 0;
      $self->{option}->{output_display_name} = 0;
      $self->{option}->{output_comment} = 0;
      $self->{option}->{use_display_name} = 0;
      $self->{option}->{allow_fragment} = 0;
    } elsif ($field eq 'content-base') {
      $self->{option}->{output_angle_bracket} = 0;
      $self->{option}->{output_comment} = 0;
      $self->{option}->{use_display_name} = 0;
      $self->{option}->{allow_relative} = 0;
      $self->{option}->{allow_fragment} = 0;
    }
  } elsif ($field eq 'link') {  ## HTTP
    $self->{option}->{output_display_name} = 0;
    $self->{option}->{output_comment} = 0;
    $self->{option}->{allow_fragment} = 0;
  } elsif ($field eq 'location') {      ## HTTP / HTTP-CGI
    $self->{option}->{output_angle_bracket} = 0;
    $self->{option}->{use_comment} = 0;
    $self->{option}->{use_display_name} = 0;
    if ($format =~ /cgi/) {
      $self->{option}->{allow_relative} = 0;
      $self->{option}->{allow_fragment} = 0;
    }
  } elsif ($field eq 'referer') {       ## HTTP
    $self->{option}->{output_angle_bracket} = 0;
    $self->{option}->{use_comment} = 0;
    $self->{option}->{use_display_name} = 0;
    $self->{option}->{allow_fragment} = 0;
  } elsif ($field eq 'uri') {   ## HTTP
    $self->{option}->{output_comment} = 0;
    $self->{option}->{output_display_name} = 0;
  }
}

=item $uri = Message::Field::URI->new ([%options])

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

=cut

## Inherited

=item $uri = Message::Field::URI->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 $body = shift;
  $self->_init (@_);
  ($body, @{$self->{comment}})
    = $self->Message::Util::delete_comment_to_array ($body, -use_angle_quoted)
    if $self->{option}->{use_comment};
  if ($body =~ /([^\x3C]*)$REG{SCM_angle_quoted}/) {
    my ($dn, $as) = ($1, $2);
    $dn =~ s/^$REG{WSP}+//;  $dn =~ s/$REG{WSP}+$//;
    $self->{display_name} = $self->Message::Util::decode_quoted_string ($dn);
    #$as =~ s/^$REG{WSP}+//;  $as =~ s/$REG{WSP}+$//;
    $as =~ tr/\x09\x20//d;
    $self->{value} = $as;
  } else {
    #$body =~ s/^$REG{WSP}+//;  $body =~ s/$REG{WSP}+$//;
    $body =~ tr/\x09\x20//d;
    $self->{value} = $body;
  }
  $self->{value} = $self->_parse_value (uri => $self->{value})
    if $self->{option}->{parse_all};
  $self;
}


=head2 $URI = $uri->uri ([$newURI])

Set/gets C<URI>.  See also L<NOTE>.

=cut

sub uri ($;$%) {
  my $self = shift;
  my $dname = shift;
  if (defined $dname) {
    $self->{value} = $dname;
  }
  $self->{value};
}


sub display_name ($;$%) {
  my $self = shift;
  my $dname = shift;
  if (defined $dname) {
    $self->{display_name} = $dname;
  }
  $self->{display_name};
}


sub stringify ($;%) {
  my $self = shift;
  my %o = @_;  my %option = %{$self->{option}};
  for (grep {/^-/} keys %o) {$option{substr ($_, 1)} = $o{$_}}
  my $uri = ''.$self->{value};
  if ((!$option{allow_relative} || !$option{allow_empty})
    && length $uri == 0) {
    return '';
  }
  my ($dn, $as, $cm) = ('', '', '');
  if (length $self->{display_name}) {
    if ($option{use_display_name} && $option{output_display_name}) {
        my %s = &{$option{hook_encode_string}} ($self, 
            $self->{display_name}, type => 'phrase');
        $dn = Message::Util::quote_unsafe_string
            ($s{value}, unsafe => $option{unsafe_rule_display_name}) . ' ';
    } elsif ($option{use_comment} && $option{output_comment}) {
      $dn = ' ('. $self->Message::Util::encode_ccontent ($self->{display_name}) .')';
    }
  }
  
  if ($option{output_angle_bracket}) {
    $as = '<'.$uri.'>';
  } else {
    $as = $uri;
  }
  
  if ($option{use_comment} && $option{output_comment}) {
    $cm = $self->_comment_stringify (\%option);
    $cm = ' ' . $cm if $cm;
    if ($dn && !($option{use_display_name} && $option{output_display_name})) {
      $cm = $dn . $cm;  $dn = '';
    }
  }
  $dn . $as . $cm;
}
*as_string = \&stringify;


=head1 NOTE

Current version of this module does not check whether
URI is correct or not.  In particullar, implementor
should be careful not to output URI that is syntactically
valid, but do not match to context.  For example,
C<Location:> field defined by HTTP/1.1 [RFC2616] doesn't
allow relative URIs.  (Interestingly, with CGI/1.1,
we can use relative URI as value of C<Location> field.

There is three options related with URI type.
C<allow_absolute>, C<allow_relative>, and C<allow_fragment>.
But this options don't work as you hope.
These options are only reserved for future implemention.

=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/05/17 05:42:27 $

=cut

1;
1	wakaba	1.1
2			=head1 NAME
3
4	wakaba	1.4	Message::Field::URI --- A Perl Module for Internet Message
5			Header Field Bodies filled with a URI
6	wakaba	1.1
7			=cut
8
9			package Message::Field::URI;
10			use strict;
11			require 5.6.0;
12			use re 'eval';
13	wakaba	1.3	use vars qw(%DEFAULT @ISA %REG $VERSION);
14	wakaba	1.4	$VERSION=do{my @r=(q$Revision: 1.3 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
15	wakaba	1.3	require Message::Field::Structured;
16			push @ISA, qw(Message::Field::Structured);
17	wakaba	1.1
18	wakaba	1.3	%REG = %Message::Util::REG;
19			$REG{SCM_angle_quoted} = qr/<([^\x3E]*)>/;
20
21			## Simple version of URI regex See RFC 2396, RFC 2732, RFC 2324.
22	wakaba	1.4	#$REG{escaped} = qr/%[0-9A-Fa-f][0-9A-Fa-f]/;
23			#$REG{scheme} = qr/(?:[A-Za-z]\|$REG{escaped})(?:[0-9A-Za-z+.-]\|$REG{escaped})*/;
24			## RFC 2324 defines escaped UTF-8 scheme names:-)
25			#$REG{fragment} = qr/\x23(?:[\x21\x24\x26-\x3B\x3D\x3F-\x5A\x5F\x61-\x7A\x7E]\|$REG{escaped})*/;
26			#$REG{S_uri_body} = qr/(?:[\x21\x24\x26-\x3B\x3D\x3F-\x5A\x5B\x5D\x5F\x61-\x7A\x7E]\|$REG{escaped})+/;
27			#$REG{S_absoluteURI} = qr/$REG{scheme}:$REG{S_uri_body}/;
28			#$REG{S_relativeURI} = qr/$REG{S_uri_body}/;
29			#$REG{S_URI_reference} = qr/(?:$REG{S_absoluteURI}\|$REG{S_relativeURI})(?:$REG{fragment})?\|(?:$REG{fragment})/;
30	wakaba	1.3	## RFC 2396 allows <> (empty URI), but this regex doesn't.
31	wakaba	1.4
32			#$REG{uri_phrase} = qr/[\x21\x23-\x3B\x3D\x3F-\x5B\x5D\x5F\x61-\x7A\x7E]+(?:$REG{WSP}+[\x21\x23-\x27\x29-\x3B\x3D\x3F-\x5B\x5D\x5F\x61-\x7A\x7E][\x21\x23-\x3B\x3D\x3F-\x5B\x5D\x5F\x61-\x7A\x7E])/;
33	wakaba	1.1
34	wakaba	1.3	=head1 CONSTRUCTORS
35
36			The following methods construct new objects:
37	wakaba	1.1
38	wakaba	1.3	=over 4
39
40			=cut
41	wakaba	1.1
42			%DEFAULT = (
43	wakaba	1.3	-_MEMBERS => [qw\|display_name\|],
44			-_METHODS => [qw\|display_name uri
45			comment_add comment_delete comment_item
46			comment_count\|],
47			-allow_absolute => 1, ## TODO: not implemented
48			-allow_empty => 1,
49			-allow_fragment => 1, ## TODO: not implemented
50			-allow_relative => 1, ## TODO: not implemented
51			#encoding_after_encode
52			#encoding_before_decode
53			#field_param_name
54			#field_name
55			#hook_encode_string
56			#hook_decode_string
57			-output_angle_bracket => 1,
58			-output_comment => 1,
59			-output_display_name => 1,
60			#parse_all
61			-unsafe_rule_display_name => 'NON_http_attribute_char_wsp',
62			-use_comment => 1,
63			-use_display_name => 1,
64	wakaba	1.1	);
65
66	wakaba	1.3	sub _init ($;%) {
67	wakaba	1.1	my $self = shift;
68	wakaba	1.3	my %options = @_;
69			my $DEFAULT = Message::Util::make_clone (\%DEFAULT);
70			$self->SUPER::_init (%$DEFAULT, %options);
71			#$self->{option}->{value_type}->{uri} = ['URI::'];
72
73	wakaba	1.1	my $format = $self->{option}->{format};
74	wakaba	1.3	my $field = $self->{option}->{field_name};
75	wakaba	1.4	my $fieldns = $self->{option}->{field_ns};
76	wakaba	1.3	$format = 'mhtml' if $format =~ /mail\|news/;
77	wakaba	1.4	if ($fieldns eq $Message::Header::NS_phname2uri{list}) {
78	wakaba	1.3	$self->{option}->{output_display_name} = 0;
79			$self->{option}->{allow_empty} = 0;
80	wakaba	1.4	} elsif ($fieldns eq $Message::Header::NS_phname2uri{content}) {
81			if ($field eq 'location') {
82			$self->{option}->{output_angle_bracket} = 0;
83			$self->{option}->{output_display_name} = 0;
84			$self->{option}->{output_comment} = 0;
85			$self->{option}->{use_display_name} = 0;
86			$self->{option}->{allow_fragment} = 0;
87			} elsif ($field eq 'content-base') {
88			$self->{option}->{output_angle_bracket} = 0;
89			$self->{option}->{output_comment} = 0;
90			$self->{option}->{use_display_name} = 0;
91			$self->{option}->{allow_relative} = 0;
92			$self->{option}->{allow_fragment} = 0;
93			}
94	wakaba	1.3	} elsif ($field eq 'link') { ## HTTP
95			$self->{option}->{output_display_name} = 0;
96			$self->{option}->{output_comment} = 0;
97			$self->{option}->{allow_fragment} = 0;
98			} elsif ($field eq 'location') { ## HTTP / HTTP-CGI
99			$self->{option}->{output_angle_bracket} = 0;
100			$self->{option}->{use_comment} = 0;
101			$self->{option}->{use_display_name} = 0;
102			if ($format =~ /cgi/) {
103			$self->{option}->{allow_relative} = 0;
104			$self->{option}->{allow_fragment} = 0;
105	wakaba	1.1	}
106	wakaba	1.3	} elsif ($field eq 'referer') { ## HTTP
107			$self->{option}->{output_angle_bracket} = 0;
108			$self->{option}->{use_comment} = 0;
109			$self->{option}->{use_display_name} = 0;
110			$self->{option}->{allow_fragment} = 0;
111			} elsif ($field eq 'uri') { ## HTTP
112			$self->{option}->{output_comment} = 0;
113			$self->{option}->{output_display_name} = 0;
114	wakaba	1.1	}
115			}
116
117	wakaba	1.3	=item $uri = Message::Field::URI->new ([%options])
118	wakaba	1.1
119	wakaba	1.3	Constructs a new object. You might pass some options as parameters
120			to the constructor.
121	wakaba	1.1
122			=cut
123
124	wakaba	1.3	## Inherited
125	wakaba	1.1
126	wakaba	1.3	=item $uri = Message::Field::URI->parse ($field-body, [%options])
127	wakaba	1.1
128	wakaba	1.3	Constructs a new object with given field body. You might pass
129			some options as parameters to the constructor.
130	wakaba	1.1
131			=cut
132
133			sub parse ($$;%) {
134			my $class = shift;
135	wakaba	1.3	my $self = bless {}, $class;
136	wakaba	1.1	my $body = shift;
137	wakaba	1.3	$self->_init (@_);
138			($body, @{$self->{comment}})
139			= $self->Message::Util::delete_comment_to_array ($body, -use_angle_quoted)
140			if $self->{option}->{use_comment};
141			if ($body =~ /([^\x3C]*)$REG{SCM_angle_quoted}/) {
142			my ($dn, $as) = ($1, $2);
143			$dn =~ s/^$REG{WSP}+//; $dn =~ s/$REG{WSP}+$//;
144			$self->{display_name} = $self->Message::Util::decode_quoted_string ($dn);
145			#$as =~ s/^$REG{WSP}+//; $as =~ s/$REG{WSP}+$//;
146			$as =~ tr/\x09\x20//d;
147			$self->{value} = $as;
148			} else {
149			#$body =~ s/^$REG{WSP}+//; $body =~ s/$REG{WSP}+$//;
150			$body =~ tr/\x09\x20//d;
151			$self->{value} = $body;
152	wakaba	1.1	}
153	wakaba	1.3	$self->{value} = $self->_parse_value (uri => $self->{value})
154			if $self->{option}->{parse_all};
155	wakaba	1.1	$self;
156			}
157
158
159	wakaba	1.3	=head2 $URI = $uri->uri ([$newURI])
160	wakaba	1.2
161			Set/gets C<URI>. See also L<NOTE>.
162
163			=cut
164
165			sub uri ($;$%) {
166			my $self = shift;
167			my $dname = shift;
168			if (defined $dname) {
169	wakaba	1.3	$self->{value} = $dname;
170	wakaba	1.2	}
171	wakaba	1.3	$self->{value};
172	wakaba	1.2	}
173
174	wakaba	1.1
175			sub display_name ($;$%) {
176			my $self = shift;
177			my $dname = shift;
178			if (defined $dname) {
179			$self->{display_name} = $dname;
180			}
181			$self->{display_name};
182			}
183
184
185			sub stringify ($;%) {
186			my $self = shift;
187	wakaba	1.3	my %o = @_; my %option = %{$self->{option}};
188			for (grep {/^-/} keys %o) {$option{substr ($_, 1)} = $o{$_}}
189			my $uri = ''.$self->{value};
190			if ((!$option{allow_relative} \|\| !$option{allow_empty})
191			&& length $uri == 0) {
192	wakaba	1.1	return '';
193			}
194	wakaba	1.3	my ($dn, $as, $cm) = ('', '', '');
195	wakaba	1.1	if (length $self->{display_name}) {
196	wakaba	1.3	if ($option{use_display_name} && $option{output_display_name}) {
197			my %s = &{$option{hook_encode_string}} ($self,
198			$self->{display_name}, type => 'phrase');
199			$dn = Message::Util::quote_unsafe_string
200			($s{value}, unsafe => $option{unsafe_rule_display_name}) . ' ';
201			} elsif ($option{use_comment} && $option{output_comment}) {
202			$dn = ' ('. $self->Message::Util::encode_ccontent ($self->{display_name}) .')';
203	wakaba	1.1	}
204			}
205	wakaba	1.3
206			if ($option{output_angle_bracket}) {
207			$as = '<'.$uri.'>';
208	wakaba	1.1	} else {
209	wakaba	1.3	$as = $uri;
210	wakaba	1.1	}
211	wakaba	1.3
212			if ($option{use_comment} && $option{output_comment}) {
213			$cm = $self->_comment_stringify (\%option);
214			$cm = ' ' . $cm if $cm;
215			if ($dn && !($option{use_display_name} && $option{output_display_name})) {
216			$cm = $dn . $cm; $dn = '';
217	wakaba	1.1	}
218			}
219	wakaba	1.3	$dn . $as . $cm;
220	wakaba	1.1	}
221	wakaba	1.3	*as_string = \&stringify;
222	wakaba	1.1
223
224			=head1 NOTE
225
226			Current version of this module does not check whether
227			URI is correct or not. In particullar, implementor
228			should be careful not to output URI that is syntactically
229			valid, but do not match to context. For example,
230			C<Location:> field defined by HTTP/1.1 [RFC2616] doesn't
231			allow relative URIs. (Interestingly, with CGI/1.1,
232			we can use relative URI as value of C<Location> field.
233
234			There is three options related with URI type.
235			C<allow_absolute>, C<allow_relative>, and C<allow_fragment>.
236			But this options don't work as you hope.
237			These options are only reserved for future implemention.
238
239			=head1 LICENSE
240
241			Copyright 2002 wakaba E<lt>w@suika.fam.cxE<gt>.
242
243			This program is free software; you can redistribute it and/or modify
244			it under the terms of the GNU General Public License as published by
245			the Free Software Foundation; either version 2 of the License, or
246			(at your option) any later version.
247
248			This program is distributed in the hope that it will be useful,
249			but WITHOUT ANY WARRANTY; without even the implied warranty of
250			MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
251			GNU General Public License for more details.
252
253			You should have received a copy of the GNU General Public License
254			along with this program; see the file COPYING. If not, write to
255			the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
256			Boston, MA 02111-1307, USA.
257
258			=head1 CHANGE
259
260			See F<ChangeLog>.
261	wakaba	1.4	$Date: 2002/05/17 05:42:27 $
262	wakaba	1.1
263			=cut
264
265			1;