Message/Field/ContentDisposition.pm


=head1 NAME

Message::Field::ContentDisposition Perl module

=head1 DESCRIPTION

Perl module for C<Content-Disposition:> field body.

=cut

package Message::Field::ContentDisposition;
use strict;
BEGIN {
  no strict;
  use base Message::Field::Params;
  use vars qw(%DEFAULT %REG $VERSION);
}
$VERSION=do{my @r=(q$Revision: 1.1 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};

%REG = %Message::Field::Params::REG;

%DEFAULT = (
  use_parameter_extension       => 1,
  value_type => {'*DEFAULT'     => ':none:',
    'creation-date'     => 'Message::Field::Date',
    'modification-date' => 'Message::Field::Date',
    'read-date' => 'Message::Field::Date',
  },
);

=head2 Message::Field::ContentDisposition->new ([%option])

Returns new Message::Field::ContentDisposition.  Some options can be given as hash.

=cut

## Inherited

## Initialization for new () method.
sub _initialize_new ($;%) {
  my $self = shift;
  for (keys %DEFAULT) {$self->{option}->{$_} ||= $DEFAULT{$_}}
  $self->{type} = 'inline';
}

## Initialization for parse () method.
sub _initialize_parse ($;%) {
  my $self = shift;
  for (keys %DEFAULT) {$self->{option}->{$_} ||= $DEFAULT{$_}}
}

=head2 Message::Field::ContentDisposition->parse ($nantara, [%option])

Parse Message::Field::ContentDisposition and new ContentDisposition instance.  
Some options can be given as hash.

=cut

## Inherited

sub _save_param ($@) {
  my $self = shift;
  my @p = @_;
  if ($p[0]->[1]->{is_parameter} == 0) {
    my $type = shift (@p)->[0];
    if ($type && $type !~ /$REG{NON_token}/) {
      $self->{type} = $type;
    } elsif ($type) {
      push @p, ['x-invalid-type' => {value => $type, is_parameter => 1}];
    }
  }
  $self->{type} ||= 'inline';
  $self->{param} = \@p;
  $self;
}

=head2 $self->replace ($name, $value, [%option]

Sets new parameter C<value> of $name.

  Example:
    $self->add (title => 'foo of bar'); ## title="foo of bar"
    $self->add (subject => 'hogehoge, foo');    ## subject*=''hogehoge%2C%20foo
    $self->add (foo => 'bar', language => 'en') ## foo*='en'bar

This method returns array reference of (name, {value => value, attribute...}).
C<value> is same as returned value of C<$self-E<gt>parameter>.

Available options: charset (charset name), language (language tag),
value (1/0, see example above).

=head2 $self->count ()

Returns the number of C<parameter>.

=head2 $self->parameter ($name, [$new_value])

Returns given C<name>'ed C<parameter>'s C<value>.

Note that when $self->{option}->{value_type}->{$name}
is defined (and it is class name), returned value
is a reference to the object.

=head2 $self->parameter_name ($index, [$new_name])

Returns (and set) C<$index>'th C<parameter>'s name.

=head2 $self->parameter_value ($index, [$new_value])

Returns (and set) C<$index>'th C<parameter>'s value.

Note that when $self->{option}->{value_type}->{$name}
is defined (and it is class name), returned value
is a reference to the object.

=cut

## replace, count, parameter, parameter_name, parameter_value: Inherited.
## add: inherited but should not be used.

## Hook called before returning C<value>.
## $self->_param_value ($name, $value);
sub _param_value ($$$) {
  my $self = shift;
  my $name = shift;
  my $value = shift;
  my $vtype = $self->{option}->{value_type}->{$name}
           || $self->{option}->{value_type}->{'*DEFAULT'};
  if (ref $value) {
    return $value;
  } elsif ($vtype eq ':none:') {
    return $value;
  } elsif ($value) {
    eval "require $vtype";
    return $vtype->parse ($value);
  } else {
    eval "require $vtype";
    return $vtype->new ();
  }
}

=head2 $self->stringify ([%option])

Returns Content-Disposition C<field-body> as a string.

=head2 $self->as_string ([%option])

An alias of C<stringify>.

=cut

sub stringify ($;%) {
  my $self = shift;
  my $param = $self->SUPER::stringify (@_);
  $self->type ().($param? '; '.$param: '');
}

=head2 $self->type ([$new_value])

Returns or set disposition type.

=cut

sub type ($;$) {
  my $self = shift;
  my $new_value = shift;
  if ($new_value && $new_value !~ m#$REG{NON_token}#) {
    $self->{type} = $new_value;
  }
  $self->{type};
}


=head2 $self->option ($option_name)

Returns/set (new) value of the option.

=cut

## Inherited.

=head1 STANDARDS

This module supports MIME (RFC 1806 and RFC 2183, 
ammended by RFC 2184, RFC 2231), HTTP (HTTP/1.0, HTTP/1.1).

On C<Content-Disposition:> header field of non-MIME specifications
(and that of MIME with RFC 1806), extended parameter
syntax (character set and language specification, encoded
parameter value and continuation) is not allowed.
To use such environment, specify use_extended_parameter = -1.
(Even this value is -1, decode of those parameter values
is still enabled.)

  ## Examples
  my $ct = new Message::Field::ContentDisposition (use_extended_parameter => -1);
  ## or
  my $ct = new Message::Field::ContentDisposition;
  $ct->option (use_extended_parameter => -1);

=head1 EXAMPLE

  use Message::Field::ContentDisposition;
  my $cd = new Message::Field::ContentDisposition;
  $cd->type ('attachment');
  $cd->parameter ('filename' => 'foobar');
  $cd->parameter ('creation-date' => '')->unix_time (0);
  print $cd;    ## attachment; filename=foobar; 
                ## creation-date="Thr, 01 Jan 1970 00:00:00 +0000"

  use Message::Field::ContentDisposition;
  my $b = q{attachment; filename*=iso-2022-jp''%1B%24B%25U%25%21%25%24%25k%1B%28B};
  my $cd = Message::Field::ContentDisposition->parse ($b);
  my $filename = $cd->parameter ('FileName');
  if (!$filename || $filename =~ /[^A-Za-z0-9.,_~=+-]/ || -e $filename) {
    ## $filename can be unsafe, see RFC 2183.
    $filename = 'default';
  }
  open MSG, "> $filename";
    print $something;
  close MSG;

=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/03/21 04:33:44 $

=cut

1;
1	wakaba	1.1
2			=head1 NAME
3
4			Message::Field::ContentDisposition Perl module
5
6			=head1 DESCRIPTION
7
8			Perl module for C<Content-Disposition:> field body.
9
10			=cut
11
12			package Message::Field::ContentDisposition;
13			use strict;
14			BEGIN {
15			no strict;
16			use base Message::Field::Params;
17			use vars qw(%DEFAULT %REG $VERSION);
18			}
19			$VERSION=do{my @r=(q$Revision: 1.1 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
20
21			%REG = %Message::Field::Params::REG;
22
23			%DEFAULT = (
24			use_parameter_extension => 1,
25			value_type => {'*DEFAULT' => ':none:',
26			'creation-date' => 'Message::Field::Date',
27			'modification-date' => 'Message::Field::Date',
28			'read-date' => 'Message::Field::Date',
29			},
30			);
31
32			=head2 Message::Field::ContentDisposition->new ([%option])
33
34			Returns new Message::Field::ContentDisposition. Some options can be given as hash.
35
36			=cut
37
38			## Inherited
39
40			## Initialization for new () method.
41			sub _initialize_new ($;%) {
42			my $self = shift;
43			for (keys %DEFAULT) {$self->{option}->{$_} \|\|= $DEFAULT{$_}}
44			$self->{type} = 'inline';
45			}
46
47			## Initialization for parse () method.
48			sub _initialize_parse ($;%) {
49			my $self = shift;
50			for (keys %DEFAULT) {$self->{option}->{$_} \|\|= $DEFAULT{$_}}
51			}
52
53			=head2 Message::Field::ContentDisposition->parse ($nantara, [%option])
54
55			Parse Message::Field::ContentDisposition and new ContentDisposition instance.
56			Some options can be given as hash.
57
58			=cut
59
60			## Inherited
61
62			sub _save_param ($@) {
63			my $self = shift;
64			my @p = @_;
65			if ($p[0]->[1]->{is_parameter} == 0) {
66			my $type = shift (@p)->[0];
67			if ($type && $type !~ /$REG{NON_token}/) {
68			$self->{type} = $type;
69			} elsif ($type) {
70			push @p, ['x-invalid-type' => {value => $type, is_parameter => 1}];
71			}
72			}
73			$self->{type} \|\|= 'inline';
74			$self->{param} = \@p;
75			$self;
76			}
77
78			=head2 $self->replace ($name, $value, [%option]
79
80			Sets new parameter C<value> of $name.
81
82			Example:
83			$self->add (title => 'foo of bar'); ## title="foo of bar"
84			$self->add (subject => 'hogehoge, foo'); ## subject*=''hogehoge%2C%20foo
85			$self->add (foo => 'bar', language => 'en') ## foo*='en'bar
86
87			This method returns array reference of (name, {value => value, attribute...}).
88			C<value> is same as returned value of C<$self-E<gt>parameter>.
89
90			Available options: charset (charset name), language (language tag),
91			value (1/0, see example above).
92
93			=head2 $self->count ()
94
95			Returns the number of C<parameter>.
96
97			=head2 $self->parameter ($name, [$new_value])
98
99			Returns given C<name>'ed C<parameter>'s C<value>.
100
101			Note that when $self->{option}->{value_type}->{$name}
102			is defined (and it is class name), returned value
103			is a reference to the object.
104
105			=head2 $self->parameter_name ($index, [$new_name])
106
107			Returns (and set) C<$index>'th C<parameter>'s name.
108
109			=head2 $self->parameter_value ($index, [$new_value])
110
111			Returns (and set) C<$index>'th C<parameter>'s value.
112
113			Note that when $self->{option}->{value_type}->{$name}
114			is defined (and it is class name), returned value
115			is a reference to the object.
116
117			=cut
118
119			## replace, count, parameter, parameter_name, parameter_value: Inherited.
120			## add: inherited but should not be used.
121
122			## Hook called before returning C<value>.
123			## $self->_param_value ($name, $value);
124			sub _param_value ($$$) {
125			my $self = shift;
126			my $name = shift;
127			my $value = shift;
128			my $vtype = $self->{option}->{value_type}->{$name}
129			\|\| $self->{option}->{value_type}->{'*DEFAULT'};
130			if (ref $value) {
131			return $value;
132			} elsif ($vtype eq ':none:') {
133			return $value;
134			} elsif ($value) {
135			eval "require $vtype";
136			return $vtype->parse ($value);
137			} else {
138			eval "require $vtype";
139			return $vtype->new ();
140			}
141			}
142
143			=head2 $self->stringify ([%option])
144
145			Returns Content-Disposition C<field-body> as a string.
146
147			=head2 $self->as_string ([%option])
148
149			An alias of C<stringify>.
150
151			=cut
152
153			sub stringify ($;%) {
154			my $self = shift;
155			my $param = $self->SUPER::stringify (@_);
156			$self->type ().($param? '; '.$param: '');
157			}
158
159			=head2 $self->type ([$new_value])
160
161			Returns or set disposition type.
162
163			=cut
164
165			sub type ($;$) {
166			my $self = shift;
167			my $new_value = shift;
168			if ($new_value && $new_value !~ m#$REG{NON_token}#) {
169			$self->{type} = $new_value;
170			}
171			$self->{type};
172			}
173
174
175			=head2 $self->option ($option_name)
176
177			Returns/set (new) value of the option.
178
179			=cut
180
181			## Inherited.
182
183			=head1 STANDARDS
184
185			This module supports MIME (RFC 1806 and RFC 2183,
186			ammended by RFC 2184, RFC 2231), HTTP (HTTP/1.0, HTTP/1.1).
187
188			On C<Content-Disposition:> header field of non-MIME specifications
189			(and that of MIME with RFC 1806), extended parameter
190			syntax (character set and language specification, encoded
191			parameter value and continuation) is not allowed.
192			To use such environment, specify use_extended_parameter = -1.
193			(Even this value is -1, decode of those parameter values
194			is still enabled.)
195
196			## Examples
197			my $ct = new Message::Field::ContentDisposition (use_extended_parameter => -1);
198			## or
199			my $ct = new Message::Field::ContentDisposition;
200			$ct->option (use_extended_parameter => -1);
201
202			=head1 EXAMPLE
203
204			use Message::Field::ContentDisposition;
205			my $cd = new Message::Field::ContentDisposition;
206			$cd->type ('attachment');
207			$cd->parameter ('filename' => 'foobar');
208			$cd->parameter ('creation-date' => '')->unix_time (0);
209			print $cd; ## attachment; filename=foobar;
210			## creation-date="Thr, 01 Jan 1970 00:00:00 +0000"
211
212			use Message::Field::ContentDisposition;
213			my $b = q{attachment; filename*=iso-2022-jp''%1B%24B%25U%25%21%25%24%25k%1B%28B};
214			my $cd = Message::Field::ContentDisposition->parse ($b);
215			my $filename = $cd->parameter ('FileName');
216			if (!$filename \|\| $filename =~ /[^A-Za-z0-9.,_~=+-]/ \|\| -e $filename) {
217			## $filename can be unsafe, see RFC 2183.
218			$filename = 'default';
219			}
220			open MSG, "> $filename";
221			print $something;
222			close MSG;
223
224			=head1 LICENSE
225
226			Copyright 2002 wakaba E<lt>w@suika.fam.cxE<gt>.
227
228			This program is free software; you can redistribute it and/or modify
229			it under the terms of the GNU General Public License as published by
230			the Free Software Foundation; either version 2 of the License, or
231			(at your option) any later version.
232
233			This program is distributed in the hope that it will be useful,
234			but WITHOUT ANY WARRANTY; without even the implied warranty of
235			MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
236			GNU General Public License for more details.
237
238			You should have received a copy of the GNU General Public License
239			along with this program; see the file COPYING. If not, write to
240			the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
241			Boston, MA 02111-1307, USA.
242
243			=head1 CHANGE
244
245			See F<ChangeLog>.
246			$Date: 2002/03/21 04:33:44 $
247
248			=cut
249
250			1;