Upgrade to CGI.pm-3.48
[perl.git] / cpan / CGI / t / upload.t
1 #!/usr/local/bin/perl -w
2
3 #################################################################
4 #  Emanuele Zeppieri, Mark Stosberg                             #
5 #  Shamelessly stolen from Data::FormValidator and CGI::Upload  #
6 #################################################################
7
8 use strict;
9
10 use Test::More 'no_plan';
11
12 use CGI;
13
14 #-----------------------------------------------------------------------------
15 # %ENV setup.
16 #-----------------------------------------------------------------------------
17
18 my %myenv;
19
20 BEGIN {
21     %myenv = (
22         'SCRIPT_NAME'       => '/test.cgi',
23         'SERVER_NAME'       => 'perl.org',
24         'HTTP_CONNECTION'   => 'TE, close',
25         'REQUEST_METHOD'    => 'POST',
26         'SCRIPT_URI'        => 'http://www.perl.org/test.cgi',
27         'CONTENT_LENGTH'    => 3285,
28         'SCRIPT_FILENAME'   => '/home/usr/test.cgi',
29         'SERVER_SOFTWARE'   => 'Apache/1.3.27 (Unix) ',
30         'HTTP_TE'           => 'deflate,gzip;q=0.3',
31         'QUERY_STRING'      => '',
32         'REMOTE_PORT'       => '1855',
33         'HTTP_USER_AGENT'   => 'Mozilla/5.0 (compatible; Konqueror/2.1.1; X11)',
34         'SERVER_PORT'       => '80',
35         'REMOTE_ADDR'       => '127.0.0.1',
36         'CONTENT_TYPE'      => 'multipart/form-data; boundary=xYzZY',
37         'SERVER_PROTOCOL'   => 'HTTP/1.1',
38         'PATH'              => '/usr/local/bin:/usr/bin:/bin',
39         'REQUEST_URI'       => '/test.cgi',
40         'GATEWAY_INTERFACE' => 'CGI/1.1',
41         'SCRIPT_URL'        => '/test.cgi',
42         'SERVER_ADDR'       => '127.0.0.1',
43         'DOCUMENT_ROOT'     => '/home/develop',
44         'HTTP_HOST'         => 'www.perl.org'
45     );
46
47     for my $key (keys %myenv) {
48         $ENV{$key} = $myenv{$key};
49     }
50 }
51
52 END {
53     for my $key (keys %myenv) {
54         delete $ENV{$key};
55     }
56 }
57
58 #-----------------------------------------------------------------------------
59 # Simulate the upload (really, multiple uploads contained in a single stream).
60 #-----------------------------------------------------------------------------
61
62 my $q;
63
64 {
65     local *STDIN;
66     open STDIN, '<t/upload_post_text.txt'
67         or die 'missing test file t/upload_post_text.txt';
68     binmode STDIN;
69     $q = CGI->new;
70 }
71
72 #-----------------------------------------------------------------------------
73 # Check that the file names retrieved by CGI are correct.
74 #-----------------------------------------------------------------------------
75
76 is( $q->param('does_not_exist_gif'), 'does_not_exist.gif', 'filename_2' );
77 is( $q->param('100;100_gif')       , '100;100.gif'       , 'filename_3' );
78 is( $q->param('300x300_gif')       , '300x300.gif'       , 'filename_4' );
79
80
81     my $test = "multiple file names are handled right with same-named upload fields";
82     my @hello_names = $q->param('hello_world');
83     is ($hello_names[0],'goodbye_world.txt',$test. "...first file");
84     is ($hello_names[1],'hello_world.txt',$test. "...second file");
85 }
86
87 #-----------------------------------------------------------------------------
88 # Now check that the upload method works.
89 #-----------------------------------------------------------------------------
90
91 ok( defined $q->upload('does_not_exist_gif'), 'upload_basic_2' );
92 ok( defined $q->upload('100;100_gif')       , 'upload_basic_3' );
93 ok( defined $q->upload('300x300_gif')       , 'upload_basic_4' );
94
95 {
96     my $test = "file handles have expected length for multi-valued field. ";
97     my ($goodbye_fh,$hello_fh) = $q->upload('hello_world');
98
99         # Go to end of file;
100         seek($goodbye_fh,0,2);
101         # How long is the file?
102         is(tell($goodbye_fh), 15, "$test..first file");
103
104         # Go to end of file;
105         seek($hello_fh,0,2);
106         # How long is the file?
107         is(tell($hello_fh), 13, "$test..second file");
108
109 }
110
111
112
113 {
114     my $test = "300x300_gif has expected length";
115     my $fh1 = $q->upload('300x300_gif');
116     is(tell($fh1), 0, "First object: filehandle starts with position set at zero");
117
118     # Go to end of file;
119     seek($fh1,0,2);
120     # How long is the file?
121     is(tell($fh1), 1656, $test);
122 }
123
124 my $q2 = CGI->new;
125
126 {
127     my $test = "Upload filehandles still work after calling CGI->new a second time";
128     $q->param('new','zoo');
129
130     is($q2->param('new'),undef, 
131         "Reality Check: params set in one object instance don't appear in another instance");
132
133     my $fh2 = $q2->upload('300x300_gif');
134         is(tell($fh2), 0, "...so the state of a file handle shouldn't be carried to a new object instance, either.");
135         # Go to end of file;
136         seek($fh2,0,2);
137         # How long is the file?
138         is(tell($fh2), 1656, $test);
139 }
140
141 {
142     my $test = "multi-valued uploads are reset properly";
143     my ($dont_care, $hello_fh2) = $q2->upload('hello_world');
144     is(tell($hello_fh2), 0, $test);
145 }
146
147 # vim: nospell