1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
|
use strict;
use warnings;
use Dancer ':syntax';
use Dancer::Request;
use Dancer::Test;
use Dancer::FileUtils;
use Test::More 'import' => ['!pass'];
plan skip_all => "File::Temp 0.22 required"
unless Dancer::ModuleLoader->load( 'File::Temp', '0.22' );
sub test_path {
my ($file, $dir) = @_;
is dirname($file), $dir, "dir of $file is $dir";
}
my $filename = "some_\x{1A9}_file.txt";
my $filename_as_bytes = $filename;
if ( $] >= 5.017009 ) {
# The following song-and-dance is because Perl has, in 5.17.9,
# started flagging wide characters in in-memory files as errors, to
# wit:
# Strings with code points over 0xFF may not be mapped into
# in-memory file handles
open my $out, '>:encoding(utf8)', \$filename_as_bytes;
print { $out } "some_\x{1A9}_file.txt";
close $out;
}
my $content = qq{------BOUNDARY
Content-Disposition: form-data; name="test_upload_file"; filename="$filename_as_bytes"
Content-Type: text/plain
SHOGUN
------BOUNDARY
Content-Disposition: form-data; name="test_upload_file"; filename="yappo2.txt"
Content-Type: text/plain
SHOGUN2
------BOUNDARY
Content-Disposition: form-data; name="test_upload_file3"; filename="yappo3.txt"
Content-Type: text/plain
SHOGUN3
------BOUNDARY
Content-Disposition: form-data; name="test_upload_file4"; filename="yappo4.txt"
Content-Type: text/plain
SHOGUN4
------BOUNDARY
Content-Disposition: form-data; name="test_upload_file4"; filename="yappo5.txt"
Content-Type: text/plain
SHOGUN4
------BOUNDARY
Content-Disposition: form-data; name="test_upload_file6"; filename="yappo6.txt"
Content-Type: text/plain
SHOGUN6
------BOUNDARY--
};
$content =~ s/\r\n/\n/g;
$content =~ s/\n/\r\n/g;
plan tests => 21;
do {
open my $in, '<', \$content;
my $req = Dancer::Request->new(
env => {
'psgi.input' => $in,
CONTENT_LENGTH => length($content),
CONTENT_TYPE => 'multipart/form-data; boundary=----BOUNDARY',
REQUEST_METHOD => 'POST',
SCRIPT_NAME => '/',
SERVER_PORT => 80,
}
);
Dancer::SharedData->request($req);
my @undef = $req->upload('undef');
is @undef, 0, 'non-existent upload as array is empty';
my $undef = $req->upload('undef');
is $undef, undef, '... and non-existent upload as scalar is undef';
my @uploads = upload('test_upload_file');
like $uploads[0]->content, qr|^SHOGUN|,
"content for first upload is ok, via 'upload'";
like $uploads[1]->content, qr|^SHOGUN|, "... content for second as well";
is $req->uploads->{'test_upload_file4'}[0]->content, 'SHOGUN4',
"... content for other also good";
note "headers";
is_deeply $uploads[0]->headers, {
'Content-Disposition' => qq[form-data; name="test_upload_file"; filename="$filename"],
'Content-Type' => 'text/plain',
};
note "type";
is $uploads[0]->type, 'text/plain';
my $test_upload_file3 = $req->upload('test_upload_file3');
is $test_upload_file3->content, 'SHOGUN3',
"content for upload #3 as a scalar is good, via req->upload";
my @test_upload_file6 = $req->upload('test_upload_file6');
is $test_upload_file6[0]->content, 'SHOGUN6',
"content for upload #6 is good";
my $upload = $req->upload('test_upload_file6');
isa_ok $upload, 'Dancer::Request::Upload';
is $upload->filename, 'yappo6.txt', 'filename is ok';
ok $upload->file_handle, 'file handle is defined';
is $req->params->{'test_upload_file6'}, 'yappo6.txt',
"filename is accessible via params";
# copy_to, link_to
my $dest_dir = File::Temp::tempdir(CLEANUP => 1, TMPDIR => 1);
my $dest_file = File::Spec->catfile( $dest_dir, $upload->basename );
$upload->copy_to($dest_file);
ok( ( -f $dest_file ), "file '$dest_file' has been copied" );
my $dest_file_link = File::Spec->catfile( $dest_dir, "hardlink" );
$upload->link_to( $dest_file_link );
ok( ( -f $dest_file_link ), "hardlink '$dest_file_link' has been created" );
# make sure cleanup is performed when the HTTP::Body object is purged
my $file = $upload->tempname;
ok( ( -f $file ), 'temp file exists while HTTP::Body lives' );
undef $req->{_http_body};
SKIP: {
skip "Win32 can't remove file/link while open, deadlock with HTTP::Body", 1 if ($^O eq 'MSWin32');
ok( ( !-f $file ), 'temp file is removed when HTTP::Body object dies' );
}
unlink($file) if ($^O eq 'MSWin32');
};
# test with Dancer::Test
my $dest_dir = File::Temp::tempdir(CLEANUP => 1, TMPDIR => 1);
my $dest_file = File::Spec->catfile( $dest_dir, 'foo' );
post(
'/upload',
sub {
my $file = upload('test');
is $file->{filename}, $dest_file;
return $file->content;
}
);
post(
'/uploads',
sub {
my $content;
my $uploads = request->uploads;
foreach my $u (keys %$uploads){
$content .= $uploads->{$u}->content;
}
return $content;
}
);
$content = "foo";
open my $fh, '>', $dest_file;
print $fh $content;
close $fh;
my $resp =
dancer_response( 'POST', '/upload',
{ files => [ { name => 'test', filename => $dest_file } ] } );
is $resp->content, $content;
my $files;
for (qw/a b c/){
my $dest_file = File::Spec->catfile( $dest_dir, $_ );
open my $fh, '>', $dest_file;
print $fh $_;
close $fh;
push @$files, {name => $_, filename => $dest_file};
}
$resp = dancer_response( 'POST', '/uploads', {files => $files});
is length($resp->content), 3;
like $resp->content, qr/a/;
|
