view release on metacpan or  search on metacpan

t/request_upload.t  view on Meta::CPAN

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;
    $content = encode_utf8($content);


    do {
        open my $in, '<', \$content;
        my $req = Dancer2::Core::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,
            }
        );

        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 = $req->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 and decoded filename";
        my $encoded_filename = encode_utf8($filename);
        is_deeply $uploads[0]->headers,
          { 'Content-Disposition' =>
              qq[form-data; name="test_upload_file"; filename="$encoded_filename"],
            'Content-Type' => 'text/plain',
          };
        is $uploads[0]->filename, $filename;

        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";

        is $test_upload_file6[0]->content(':raw'), 'SHOGUN6';

        my $upload = $req->upload('test_upload_file6');
        isa_ok $upload, 'Dancer2::Core::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 = path( $dest_dir, $upload->basename )->stringify;
        $upload->copy_to($dest_file);
        ok( ( -f $dest_file ), "file '$dest_file' has been copied" );

        my $dest_file_link = path( $dest_dir, "hardlink" )->stringify;
        $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 request object lives' );

        # On Windows, files cannot be unlinked while open. Close all cached
        # file handles before destroying $req so that the temp dir cleanup
        # (which runs in File::Temp::Dir's DESTROY, triggered by freeing
        # $req's PSGI env) can succeed.
        if ( $^O eq 'MSWin32' ) {
            for my $up_or_list ( values %{ $req->uploads } ) {
                my @ups = ref $up_or_list eq 'ARRAY'
                    ? @{$up_or_list}
                    : $up_or_list;
                $_->{_fh} = undef for @ups;
            }
        }

        undef $req;
      SKIP: {
            skip