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.5 $=~/\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
    #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}) {
    $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

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