Message/Field/AngleQuoted.pm


=head1 NAME

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

=cut

package Message::Field::AngleQuoted;
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::Field::Structured;
push @ISA, qw(Message::Field::Structured);

%REG = %Message::Util::REG;
        $REG{angle_qcontent} = qr/(?:$REG{quoted_string}|$REG{domain_literal}|[^\x3C\x3E\x22\x5B])+/;
        $REG{M_angle_quoted} = qr/<($REG{angle_qcontent})>|<>/;

=head1 CONSTRUCTORS

The following methods construct new objects:

=over 4

=cut

%DEFAULT = (
    -_MEMBERS   => [qw|display_name keyword|],
    -_METHODS   => [qw|display_name value
                       comment_add comment_delete comment_item
                       comment_count|],
    -allow_empty        => 0,
    -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     => 'NON_http_attribute_char_wsp',
    -use_comment        => 1,
    -use_comment_in_angle       => 0,
    -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);
}

=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 (@_);
  my ($value, $dname, @comment, $keyword);
  ($body, @comment)
    = $self->Message::Util::delete_comment_to_array ($body,
      -use_angle_quoted => $self->{option}->{use_comment_in_angle}? 0: 1,
    )
    if $self->{option}->{use_comment};
  if ($body =~ /($REG{angle_qcontent})?$REG{M_angle_quoted}/) {
    ($dname, $value) = ($1, $2);
    $dname =~ s/^$REG{WSP}+//;  $dname =~ s/$REG{WSP}+$//;
    $dname = $self->Message::Util::decode_quoted_string ($dname);
  } elsif ($self->{option}->{use_keyword}
    && $body =~ /^$REG{FWS}($REG{atext_dot})$REG{FWS}$/) {
    #$keyword = Message::Util::remove_meaningless_wsp ($1);
    $keyword = $1; $keyword =~ tr/\x09\x20//d;
  } else {
    $value = $body;
  }
  $self->_save_value ($value, $dname, \@comment, keyword => $keyword);
  $self;
}

## $self->_save_value ($value, $display_name, \@comment)
sub _save_value ($$\@%) {
  my $self = shift;
  my ($v, $dn, $comment, %misc) = @_;
  $self->{comment} = $comment;
  $self->{value} = $v;
  $self->{display_name} = $dn;
  $self->{keyword} = $misc{keyword};
}

sub value ($;$%) {
  my $self = shift;
  my $value = shift;
  if (defined $value) {
    $self->{value} = $value;
  }
  $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 %v = $self->_stringify_value (\%option);
  my ($dn, $as, $cm) = ('', '', '');
  if (length $v{keyword}) {
    if ($option{output_keyword}) {
      my %s = &{$option{hook_encode_string}} ($self, $v{keyword}, type => 'phrase');
      $as = Message::Util::quote_unsafe_string
          ($s{value}, unsafe => $option{unsafe_rule_of_keyword});
    } else {
      $as = '('. $self->Message::Util::encode_ccontent ($v{keyword}) .')';
    }
  } else {
    if (length ($v{value}) == 0 && !$option{allow_empty}) {
      return '';
    }
    if (length $v{display_name}) {
      if ($option{use_display_name} && $option{output_display_name}) {
          my %s = &{$option{hook_encode_string}} ($self, 
              $v{display_name}, type => 'phrase');
          $dn = Message::Util::quote_unsafe_string
              ($s{value}, unsafe => $option{unsafe_rule_of_display_name}) . ' ';
      } elsif ($option{use_comment} && $option{output_comment}) {
        $dn = ' ('. $self->Message::Util::encode_ccontent ($v{display_name}) .')';
      }
    } elsif ($option{comment_to_display_name}
          && $option{use_display_name} && $option{output_display_name}) {
      my $fullname = ${$v{comment}}[0];  $option{_comment_min} = 1;
      if (length $fullname) {
        my %s = &{$option{hook_encode_string}} ($self, $fullname, type => 'phrase');
        $dn = Message::Util::quote_unsafe_string
          ($s{value}, unsafe => $option{unsafe_rule_of_display_name}) . ' ';
      }
    }
    
    if ($option{output_angle_bracket}) {
      $as = '<' . $v{value} . '>';
    } else {
      $as = $v{value};
    }
  }
  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;

## $self->_stringify_value (\%option)
sub _stringify_value ($\%) {
  my $self = shift;
  my $option = shift;
  my %r;
  $r{value} = ''.$self->{value};
  $r{display_name} = $self->{display_name};
  $r{comment} = $self->{comment};
  $r{keyword} = $self->{keyword};
  %r;
}

## $self->_option_recursive (\%argv)
sub _option_recursive ($\%) {
  my $self = shift;
  my $o = shift;
  eval { $self->{value}->option (%$o) if ref $self->{value} };
}

=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			Message::Field::AngleQuoted --- A Perl Module for Internet Message
5			Header Field Bodies filled with a URI
6
7			=cut
8
9			package Message::Field::AngleQuoted;
10			use strict;
11			require 5.6.0;
12			use re 'eval';
13			use vars qw(%DEFAULT @ISA %REG $VERSION);
14			$VERSION=do{my @r=(q$Revision: 1.4 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
15			require Message::Field::Structured;
16			push @ISA, qw(Message::Field::Structured);
17
18			%REG = %Message::Util::REG;
19			$REG{angle_qcontent} = qr/(?:$REG{quoted_string}\|$REG{domain_literal}\|[^\x3C\x3E\x22\x5B])+/;
20			$REG{M_angle_quoted} = qr/<($REG{angle_qcontent})>\|<>/;
21
22			=head1 CONSTRUCTORS
23
24			The following methods construct new objects:
25
26			=over 4
27
28			=cut
29
30			%DEFAULT = (
31			-_MEMBERS => [qw\|display_name keyword\|],
32			-_METHODS => [qw\|display_name value
33			comment_add comment_delete comment_item
34			comment_count\|],
35			-allow_empty => 0,
36			-comment_to_display_name => 0,
37			#encoding_after_encode
38			#encoding_before_decode
39			#field_param_name
40			#field_name
41			#hook_encode_string
42			#hook_decode_string
43			-output_angle_bracket => 1,
44			-output_comment => 1,
45			-output_display_name => 1,
46			-output_keyword => 0,
47			#parse_all
48			-unsafe_rule_of_display_name => 'NON_http_attribute_char_wsp',
49			-unsafe_rule_of_keyword => 'NON_http_attribute_char_wsp',
50			-use_comment => 1,
51			-use_comment_in_angle => 0,
52			-use_display_name => 1,
53			-use_keyword => 0,
54			);
55
56			sub _init ($;%) {
57			my $self = shift;
58			my %options = @_;
59			my $DEFAULT = Message::Util::make_clone (\%DEFAULT);
60			$self->SUPER::_init (%$DEFAULT, %options);
61			}
62
63			=item $uri = Message::Field::URI->new ([%options])
64
65			Constructs a new object. You might pass some options as parameters
66			to the constructor.
67
68			=cut
69
70			## Inherited
71
72			=item $uri = Message::Field::URI->parse ($field-body, [%options])
73
74			Constructs a new object with given field body. You might pass
75			some options as parameters to the constructor.
76
77			=cut
78
79			sub parse ($$;%) {
80			my $class = shift;
81			my $self = bless {}, $class;
82			my $body = shift;
83			$self->_init (@_);
84			my ($value, $dname, @comment, $keyword);
85			($body, @comment)
86			= $self->Message::Util::delete_comment_to_array ($body,
87			-use_angle_quoted => $self->{option}->{use_comment_in_angle}? 0: 1,
88			)
89			if $self->{option}->{use_comment};
90			if ($body =~ /($REG{angle_qcontent})?$REG{M_angle_quoted}/) {
91			($dname, $value) = ($1, $2);
92			$dname =~ s/^$REG{WSP}+//; $dname =~ s/$REG{WSP}+$//;
93			$dname = $self->Message::Util::decode_quoted_string ($dname);
94			} elsif ($self->{option}->{use_keyword}
95			&& $body =~ /^$REG{FWS}($REG{atext_dot})$REG{FWS}$/) {
96			#$keyword = Message::Util::remove_meaningless_wsp ($1);
97			$keyword = $1; $keyword =~ tr/\x09\x20//d;
98			} else {
99			$value = $body;
100			}
101			$self->_save_value ($value, $dname, \@comment, keyword => $keyword);
102			$self;
103			}
104
105			## $self->_save_value ($value, $display_name, \@comment)
106			sub _save_value ($$\@%) {
107			my $self = shift;
108			my ($v, $dn, $comment, %misc) = @_;
109			$self->{comment} = $comment;
110			$self->{value} = $v;
111			$self->{display_name} = $dn;
112			$self->{keyword} = $misc{keyword};
113			}
114
115			sub value ($;$%) {
116			my $self = shift;
117			my $value = shift;
118			if (defined $value) {
119			$self->{value} = $value;
120			}
121			$self->{value};
122			}
123
124			sub display_name ($;$%) {
125			my $self = shift;
126			my $dname = shift;
127			if (defined $dname) {
128			$self->{display_name} = $dname;
129			}
130			$self->{display_name};
131			}
132
133
134			sub stringify ($;%) {
135			my $self = shift;
136			my %o = @_; my %option = %{$self->{option}};
137			for (grep {/^-/} keys %o) {$option{substr ($_, 1)} = $o{$_}}
138			my %v = $self->_stringify_value (\%option);
139			my ($dn, $as, $cm) = ('', '', '');
140			if (length $v{keyword}) {
141			if ($option{output_keyword}) {
142			my %s = &{$option{hook_encode_string}} ($self, $v{keyword}, type => 'phrase');
143			$as = Message::Util::quote_unsafe_string
144			($s{value}, unsafe => $option{unsafe_rule_of_keyword});
145			} else {
146			$as = '('. $self->Message::Util::encode_ccontent ($v{keyword}) .')';
147			}
148			} else {
149			if (length ($v{value}) == 0 && !$option{allow_empty}) {
150			return '';
151			}
152			if (length $v{display_name}) {
153			if ($option{use_display_name} && $option{output_display_name}) {
154			my %s = &{$option{hook_encode_string}} ($self,
155			$v{display_name}, type => 'phrase');
156			$dn = Message::Util::quote_unsafe_string
157			($s{value}, unsafe => $option{unsafe_rule_of_display_name}) . ' ';
158			} elsif ($option{use_comment} && $option{output_comment}) {
159			$dn = ' ('. $self->Message::Util::encode_ccontent ($v{display_name}) .')';
160			}
161			} elsif ($option{comment_to_display_name}
162			&& $option{use_display_name} && $option{output_display_name}) {
163			my $fullname = ${$v{comment}}[0]; $option{_comment_min} = 1;
164			if (length $fullname) {
165			my %s = &{$option{hook_encode_string}} ($self, $fullname, type => 'phrase');
166			$dn = Message::Util::quote_unsafe_string
167			($s{value}, unsafe => $option{unsafe_rule_of_display_name}) . ' ';
168			}
169			}
170
171			if ($option{output_angle_bracket}) {
172			$as = '<' . $v{value} . '>';
173			} else {
174			$as = $v{value};
175			}
176			}
177			if ($option{use_comment} && $option{output_comment}) {
178			$cm = $self->_comment_stringify (\%option);
179			$cm = ' ' . $cm if $cm;
180			if ($dn && !($option{use_display_name} && $option{output_display_name})) {
181			$cm = $dn . $cm; $dn = '';
182			}
183			}
184			$dn . $as . $cm;
185			}
186			*as_string = \&stringify;
187
188			## $self->_stringify_value (\%option)
189			sub _stringify_value ($\%) {
190			my $self = shift;
191			my $option = shift;
192			my %r;
193			$r{value} = ''.$self->{value};
194			$r{display_name} = $self->{display_name};
195			$r{comment} = $self->{comment};
196			$r{keyword} = $self->{keyword};
197			%r;
198			}
199
200			## $self->_option_recursive (\%argv)
201			sub _option_recursive ($\%) {
202			my $self = shift;
203			my $o = shift;
204			eval { $self->{value}->option (%$o) if ref $self->{value} };
205			}
206
207			=head1 LICENSE
208
209			Copyright 2002 wakaba E<lt>w@suika.fam.cxE<gt>.
210
211			This program is free software; you can redistribute it and/or modify
212			it under the terms of the GNU General Public License as published by
213			the Free Software Foundation; either version 2 of the License, or
214			(at your option) any later version.
215
216			This program is distributed in the hope that it will be useful,
217			but WITHOUT ANY WARRANTY; without even the implied warranty of
218			MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
219			GNU General Public License for more details.
220
221			You should have received a copy of the GNU General Public License
222			along with this program; see the file COPYING. If not, write to
223			the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
224			Boston, MA 02111-1307, USA.
225
226			=head1 CHANGE
227
228			See F<ChangeLog>.
229			$Date: 2002/06/09 11:08:28 $
230
231			=cut
232
233			1;