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.3 $=~/\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_http_token}#) {
    $self->{type} = $new_value;
  }
  $self->{type};
}
sub value ($;$) {shift->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/04/02 11:52:12 $

=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	wakaba	1.4	$VERSION=do{my @r=(q$Revision: 1.3 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
20	wakaba	1.1
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	wakaba	1.2	if ($new_value && $new_value !~ m#$REG{NON_http_token}#) {
169	wakaba	1.1	$self->{type} = $new_value;
170			}
171			$self->{type};
172			}
173	wakaba	1.3	sub value ($;$) {shift->type}
174	wakaba	1.1
175
176			=head2 $self->option ($option_name)
177
178			Returns/set (new) value of the option.
179
180			=cut
181
182			## Inherited.
183
184			=head1 STANDARDS
185
186			This module supports MIME (RFC 1806 and RFC 2183,
187			ammended by RFC 2184, RFC 2231), HTTP (HTTP/1.0, HTTP/1.1).
188
189			On C<Content-Disposition:> header field of non-MIME specifications
190			(and that of MIME with RFC 1806), extended parameter
191			syntax (character set and language specification, encoded
192			parameter value and continuation) is not allowed.
193			To use such environment, specify use_extended_parameter = -1.
194			(Even this value is -1, decode of those parameter values
195			is still enabled.)
196
197			## Examples
198			my $ct = new Message::Field::ContentDisposition (use_extended_parameter => -1);
199			## or
200			my $ct = new Message::Field::ContentDisposition;
201			$ct->option (use_extended_parameter => -1);
202
203			=head1 EXAMPLE
204
205			use Message::Field::ContentDisposition;
206			my $cd = new Message::Field::ContentDisposition;
207			$cd->type ('attachment');
208			$cd->parameter ('filename' => 'foobar');
209			$cd->parameter ('creation-date' => '')->unix_time (0);
210			print $cd; ## attachment; filename=foobar;
211			## creation-date="Thr, 01 Jan 1970 00:00:00 +0000"
212
213			use Message::Field::ContentDisposition;
214			my $b = q{attachment; filename*=iso-2022-jp''%1B%24B%25U%25%21%25%24%25k%1B%28B};
215			my $cd = Message::Field::ContentDisposition->parse ($b);
216			my $filename = $cd->parameter ('FileName');
217			if (!$filename \|\| $filename =~ /[^A-Za-z0-9.,_~=+-]/ \|\| -e $filename) {
218			## $filename can be unsafe, see RFC 2183.
219			$filename = 'default';
220			}
221			open MSG, "> $filename";
222			print $something;
223			close MSG;
224
225			=head1 LICENSE
226
227			Copyright 2002 wakaba E<lt>w@suika.fam.cxE<gt>.
228
229			This program is free software; you can redistribute it and/or modify
230			it under the terms of the GNU General Public License as published by
231			the Free Software Foundation; either version 2 of the License, or
232			(at your option) any later version.
233
234			This program is distributed in the hope that it will be useful,
235			but WITHOUT ANY WARRANTY; without even the implied warranty of
236			MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
237			GNU General Public License for more details.
238
239			You should have received a copy of the GNU General Public License
240			along with this program; see the file COPYING. If not, write to
241			the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
242			Boston, MA 02111-1307, USA.
243
244			=head1 CHANGE
245
246			See F<ChangeLog>.
247	wakaba	1.4	$Date: 2002/04/02 11:52:12 $
248	wakaba	1.1
249			=cut
250
251			1;