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;
use vars qw(%DEFAULT @ISA %REG $VERSION);
$VERSION=do{my @r=(q$Revision: 1.7 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
require Message::Header;
require Message::Field::AngleQuoted;
push @ISA, qw(Message::Field::AngleQuoted);

%REG = %Message::Util::REG;

=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
    #comment_to_display_name    => 0,
    #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,
    #output_keyword     => 0,
    #parse_all
    -value_pattern      => '%s',
    #unsafe_rule_of_display_name        => 'NON_http_attribute_char_wsp',
    #unsafe_rule_of_keyword
    #use_comment        => 1,
    #use_display_name   => 1,
    #use_keyword        => 0,
);

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}) {      ## List-*
    $self->{option}->{output_display_name} = 0;
    $self->{option}->{allow_empty} = 0;
  } elsif ($fieldns eq $Message::Header::NS_phname2uri{content}) {
    if ($field eq 'location') { ## Content-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 'base') {        ## 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 '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

## $self->_save_value ($value, $display_name, \@comment)
sub _save_value ($$\@%) {
  my $self = shift;
  my ($v, $dn, $comment, %misc) = @_;
  $v =~ tr/\x09\x0A\x0D\x20//d;
  $v =~ s/^[Uu][Rr][LlIi]://;
  $v = $self->_parse_value (uri => $v) if $self->{option}->{parse_all};
  $self->{value} = $v;
  $self->{display_name} = $dn;
  $self->{comment} = $comment;
  $self->{keyword} = $misc{keyword};
}

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

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

=cut

sub uri ($;$%) { shift->value (@_) }

## display_name: Inherited

## stringify: Inherited

## $self->_stringify_value (\%option)
sub _stringify_value ($\%) {
  my $self = shift;
  my $option = shift;
  my %r;
  my $v = $self->{value};
  unless (ref $v) {
    $v =~ s/([\x00-\x20\x22\x3C\x3E\x5C\x7F-\xFF])/sprintf('%%%02X', ord $1)/ge;
  }
  $r{value} = sprintf $option->{value_pattern}, $v;
  $r{display_name} = $self->{display_name};
  $r{comment} = $self->{comment};
  $r{keyword} = $self->{keyword};
  %r;
}

=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/08/03 04:57:59 $

=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	wakaba	1.3	use vars qw(%DEFAULT @ISA %REG $VERSION);
12	wakaba	1.7	$VERSION=do{my @r=(q$Revision: 1.7 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
13	wakaba	1.5	require Message::Header;
14			require Message::Field::AngleQuoted;
15			push @ISA, qw(Message::Field::AngleQuoted);
16	wakaba	1.1
17	wakaba	1.3	%REG = %Message::Util::REG;
18	wakaba	1.1
19	wakaba	1.3	=head1 CONSTRUCTORS
20
21			The following methods construct new objects:
22	wakaba	1.1
23	wakaba	1.3	=over 4
24
25			=cut
26	wakaba	1.1
27			%DEFAULT = (
28	wakaba	1.3	-_MEMBERS => [qw\|display_name\|],
29			-_METHODS => [qw\|display_name uri
30			comment_add comment_delete comment_item
31			comment_count\|],
32			-allow_absolute => 1, ## TODO: not implemented
33			-allow_empty => 1,
34			-allow_fragment => 1, ## TODO: not implemented
35			-allow_relative => 1, ## TODO: not implemented
36	wakaba	1.5	#comment_to_display_name => 0,
37	wakaba	1.3	#encoding_after_encode
38			#encoding_before_decode
39			#field_param_name
40			#field_name
41			#hook_encode_string
42			#hook_decode_string
43	wakaba	1.5	#output_angle_bracket => 1,
44			#output_comment => 1,
45			#output_display_name => 1,
46			#output_keyword => 0,
47	wakaba	1.3	#parse_all
48	wakaba	1.7	-value_pattern => '%s',
49	wakaba	1.5	#unsafe_rule_of_display_name => 'NON_http_attribute_char_wsp',
50			#unsafe_rule_of_keyword
51			#use_comment => 1,
52			#use_display_name => 1,
53			#use_keyword => 0,
54	wakaba	1.1	);
55
56	wakaba	1.3	sub _init ($;%) {
57	wakaba	1.1	my $self = shift;
58	wakaba	1.3	my %options = @_;
59			my $DEFAULT = Message::Util::make_clone (\%DEFAULT);
60			$self->SUPER::_init (%$DEFAULT, %options);
61			#$self->{option}->{value_type}->{uri} = ['URI::'];
62
63	wakaba	1.1	my $format = $self->{option}->{format};
64	wakaba	1.3	my $field = $self->{option}->{field_name};
65	wakaba	1.4	my $fieldns = $self->{option}->{field_ns};
66	wakaba	1.3	$format = 'mhtml' if $format =~ /mail\|news/;
67	wakaba	1.7	if ($fieldns eq $Message::Header::NS_phname2uri{list}) { ## List-*
68	wakaba	1.3	$self->{option}->{output_display_name} = 0;
69			$self->{option}->{allow_empty} = 0;
70	wakaba	1.4	} elsif ($fieldns eq $Message::Header::NS_phname2uri{content}) {
71	wakaba	1.7	if ($field eq 'location') { ## Content-Location
72	wakaba	1.4	$self->{option}->{output_angle_bracket} = 0;
73			$self->{option}->{output_display_name} = 0;
74			$self->{option}->{output_comment} = 0;
75			$self->{option}->{use_display_name} = 0;
76			$self->{option}->{allow_fragment} = 0;
77	wakaba	1.7	} elsif ($field eq 'base') { ## Content-Base
78	wakaba	1.4	$self->{option}->{output_angle_bracket} = 0;
79			$self->{option}->{output_comment} = 0;
80			$self->{option}->{use_display_name} = 0;
81			$self->{option}->{allow_relative} = 0;
82			$self->{option}->{allow_fragment} = 0;
83			}
84	wakaba	1.3	} elsif ($field eq 'link') { ## HTTP
85			$self->{option}->{output_display_name} = 0;
86			$self->{option}->{output_comment} = 0;
87			$self->{option}->{allow_fragment} = 0;
88			} elsif ($field eq 'location') { ## HTTP / HTTP-CGI
89			$self->{option}->{output_angle_bracket} = 0;
90			$self->{option}->{use_comment} = 0;
91			$self->{option}->{use_display_name} = 0;
92			if ($format =~ /cgi/) {
93			$self->{option}->{allow_relative} = 0;
94			$self->{option}->{allow_fragment} = 0;
95	wakaba	1.1	}
96	wakaba	1.3	} elsif ($field eq 'uri') { ## HTTP
97			$self->{option}->{output_comment} = 0;
98			$self->{option}->{output_display_name} = 0;
99	wakaba	1.1	}
100			}
101
102	wakaba	1.3	=item $uri = Message::Field::URI->new ([%options])
103	wakaba	1.1
104	wakaba	1.3	Constructs a new object. You might pass some options as parameters
105			to the constructor.
106	wakaba	1.1
107			=cut
108
109	wakaba	1.3	## Inherited
110	wakaba	1.1
111	wakaba	1.3	=item $uri = Message::Field::URI->parse ($field-body, [%options])
112	wakaba	1.1
113	wakaba	1.3	Constructs a new object with given field body. You might pass
114			some options as parameters to the constructor.
115	wakaba	1.1
116			=cut
117
118	wakaba	1.5	## $self->_save_value ($value, $display_name, \@comment)
119			sub _save_value ($$\@%) {
120			my $self = shift;
121			my ($v, $dn, $comment, %misc) = @_;
122			$v =~ tr/\x09\x0A\x0D\x20//d;
123	wakaba	1.7	$v =~ s/^[Uu][Rr][LlIi]://;
124	wakaba	1.5	$v = $self->_parse_value (uri => $v) if $self->{option}->{parse_all};
125			$self->{value} = $v;
126			$self->{display_name} = $dn;
127			$self->{comment} = $comment;
128			$self->{keyword} = $misc{keyword};
129	wakaba	1.1	}
130
131	wakaba	1.3	=head2 $URI = $uri->uri ([$newURI])
132	wakaba	1.2
133			Set/gets C<URI>. See also L<NOTE>.
134
135			=cut
136
137	wakaba	1.5	sub uri ($;$%) { shift->value (@_) }
138	wakaba	1.1
139	wakaba	1.5	## display_name: Inherited
140	wakaba	1.1
141	wakaba	1.5	## stringify: Inherited
142	wakaba	1.1
143	wakaba	1.5	## $self->_stringify_value (\%option)
144			sub _stringify_value ($\%) {
145	wakaba	1.1	my $self = shift;
146	wakaba	1.5	my $option = shift;
147			my %r;
148			my $v = $self->{value};
149			unless (ref $v) {
150			$v =~ s/([\x00-\x20\x22\x3C\x3E\x5C\x7F-\xFF])/sprintf('%%%02X', ord $1)/ge;
151			}
152	wakaba	1.7	$r{value} = sprintf $option->{value_pattern}, $v;
153	wakaba	1.5	$r{display_name} = $self->{display_name};
154			$r{comment} = $self->{comment};
155			$r{keyword} = $self->{keyword};
156			%r;
157	wakaba	1.1	}
158
159			=head1 NOTE
160
161			Current version of this module does not check whether
162			URI is correct or not. In particullar, implementor
163			should be careful not to output URI that is syntactically
164			valid, but do not match to context. For example,
165			C<Location:> field defined by HTTP/1.1 [RFC2616] doesn't
166			allow relative URIs. (Interestingly, with CGI/1.1,
167			we can use relative URI as value of C<Location> field.
168
169			There is three options related with URI type.
170			C<allow_absolute>, C<allow_relative>, and C<allow_fragment>.
171			But this options don't work as you hope.
172			These options are only reserved for future implemention.
173
174			=head1 LICENSE
175
176			Copyright 2002 wakaba E<lt>w@suika.fam.cxE<gt>.
177
178			This program is free software; you can redistribute it and/or modify
179			it under the terms of the GNU General Public License as published by
180			the Free Software Foundation; either version 2 of the License, or
181			(at your option) any later version.
182
183			This program is distributed in the hope that it will be useful,
184			but WITHOUT ANY WARRANTY; without even the implied warranty of
185			MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
186			GNU General Public License for more details.
187
188			You should have received a copy of the GNU General Public License
189			along with this program; see the file COPYING. If not, write to
190			the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
191			Boston, MA 02111-1307, USA.
192
193			=head1 CHANGE
194
195			See F<ChangeLog>.
196	wakaba	1.7	$Date: 2002/08/03 04:57:59 $
197	wakaba	1.1
198			=cut
199
200			1;