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.4 $=~/\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/09 11:08:28 $

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