File Coverage

blib/lib/CGI/Test/Input/Multipart.pm
Criterion Covered Total %
statement 43 51 84.3
branch 2 4 50.0
condition n/a
subroutine 8 9 88.8
pod 1 4 25.0
total 54 68 79.4


line stmt bran cond sub pod time code
1             package CGI::Test::Input::Multipart;
2 2     2   8 use strict;
  2         4  
  2         50  
3 2     2   6 use warnings;
  2         2  
  2         36  
4             ####################################################################
5             # $Id: Multipart.pm 411 2011-09-26 11:19:30Z nohuhu@nohuhu.org $
6             # $Name: cgi-test_0-104_t1 $
7             ####################################################################
8             #
9             # Copyright (c) 2001, Raphael Manfredi
10             #
11             # You may redistribute only under the terms of the Artistic License,
12             # as specified in the README file that comes with the distribution.
13             #
14              
15             #
16             # POST input data to be encoded with "multipart/form-data".
17             #
18              
19 2     2   6 use Carp;
  2         4  
  2         82  
20              
21 2     2   6 use base qw(CGI::Test::Input);
  2         2  
  2         660  
22              
23             #
24             # ->new
25             #
26             # Creation routine
27             #
28             sub new
29             {
30 2     2 0 6 my $this = bless {}, shift;
31 2         10 $this->_init;
32 2         10 $this->{boundary} =
33             "-------------cgi-test--------------"
34             . int(rand(1 << 31)) . '-'
35             . int(rand(1 << 31));
36 2         4 return $this;
37             }
38              
39             # DEPRECATED METHOD
40             sub make
41             { #
42 0     0 0 0 my $class = shift;
43 0         0 return $class->new(@_);
44             }
45              
46             #
47             # Attribute access
48             #
49              
50             sub boundary
51             {
52 3     3 0 9 my $this = shift;
53 3         33 return $this->{boundary};
54             }
55              
56             #
57             # Defined interface
58             #
59              
60             sub mime_type
61             {
62 1     1 1 3 my $this = shift;
63 1         7 "multipart/form-data; boundary=" . $this->boundary();
64             }
65              
66             #
67             # ->_build_data
68             #
69             # Rebuild data buffer from input fields.
70             #
71             sub _build_data
72             {
73 2     2   7 my $this = shift;
74              
75 2         9 my $CRLF = "\015\012";
76 2         2 my $data = '';
77 2         5 my $fmt = 'Content-Disposition: form-data; name="%s"';
78 2         4 my $boundary = "--" . $this->boundary(); # With extra "--" per MIME specs
79              
80             # XXX field name encoding of special chars?
81             # XXX does not escape "" in filenames
82              
83 2         5 foreach my $tuple (@{$this->_fields()})
  2         10  
84             {
85 32         60 my ($name, $value) = @$tuple;
86 32         37 $data .= $boundary . $CRLF;
87 32         72 $data .= sprintf($fmt, $name) . $CRLF . $CRLF;
88 32         50 $data .= $value . $CRLF;
89             }
90              
91 2         3 foreach my $tuple (@{$this->_files()})
  2         9  
92             {
93 2         8 my ($name, $value, $content) = @$tuple;
94 2         11 $data .= $boundary . $CRLF;
95 2         6 $data .= sprintf($fmt, $name);
96 2         6 $data .= sprintf('; filename="%s"', $value) . $CRLF;
97 2         3 $data .= "Content-Type: application/octet-stream" . $CRLF . $CRLF;
98 2 50       7 if (defined $content)
99             {
100 0         0 $data .= $content;
101             }
102             else
103             {
104 2         4 local *FILE;
105 2 50       39 if (open(FILE, $value))
106             { # Might not exist, but that's OK
107 0         0 binmode FILE;
108 0         0 local $_;
109 0         0 while ()
110             {
111 0         0 $data .= $_;
112             }
113 0         0 close FILE;
114             }
115             }
116             }
117              
118 2         5 $data .= $boundary . $CRLF;
119              
120 2         8 return $data;
121             }
122              
123             1;
124              
125             =head1 NAME
126              
127             CGI::Test::Input::Multipart - POST input encoded as multipart/form-data
128              
129             =head1 SYNOPSIS
130              
131             # Inherits from CGI::Test::Input
132             require CGI::Test::Input::Multipart;
133              
134             my $input = CGI::Test::Input::Multipart->new();
135              
136             =head1 DESCRIPTION
137              
138             This class represents the input for HTTP POST requests, encoded
139             as C.
140              
141             Please see L for interface details.
142              
143             =head1 AUTHORS
144              
145             The original author is Raphael Manfredi.
146              
147             Steven Hilton was long time maintainer of this module.
148              
149             Current maintainer is Alexander Tokarev Ftokarev@cpan.orgE>.
150              
151             =head1 SEE ALSO
152              
153             CGI::Test::Input(3).
154              
155             =cut
156