CGI-ExtDirect
view release on metacpan or search on metacpan
- Fixed a bug in t/05_env.t
2.01 Wed Jun 20 18:37:54 2012
- Minor documentation tweaks.
2.00 Mon Jun 18 14:15:11 2012
- Updated code, documentation and test suite to accommodate
for new features in RPC::ExtDirect 2.00.
1.12 Thu Jun 7 13:41:33 2012
- Fixed a bug in handling uploaded files: CGI.pm below 3.41
did not have "handle" method in its "lightweight file handle"
objects, which CGI::ExtDirect relied on.
Somehow this bug only manifested itself in Perl 5.10.0.
- Fixed Makefile.PL to produce BUILD_REQUIRES only for
ExtUtils::MakeMaker that support it (>=6.55).
- Bumped RPC::Dependency to freshly released 1.30.
1.11 Mon May 20 18:54:05 2012
lib/CGI/ExtDirect.pm view on Meta::CPAN
# If form is not involved, it's easy: just return POSTDATA (or undef)
if ( !$is_form ) {
my $postdata = $cgi->param('POSTDATA');
return $postdata ne '' ? $postdata
: undef
;
};
# If any files are attached, extUpload will contain 'true'
my $has_uploads = $cgi->param('extUpload') eq 'true';
# Here file uploads data is stored
my @_uploads = ();
# This is to suppress a really annoying warning in CGI.pm 4.08+.
# I am perfectly aware of what the list context is and how to
# use it, thank you very much. :/
local $CGI::LIST_CONTEXT_WARN = 0;
# Now if the form IS involved, it gets a little bit complicated
PARAM:
for my $param ( keys %keyword ) {
# Defang CGI's idiosyncratic way of returning multi-valued params
my @values = $cgi->param( $param );
$keyword{ $param } = @values == 0 ? undef
: @values == 1 ? $values[0]
: [ @values ]
;
# Try to see if $param is a field with associated file upload
# Skip the standard ones first, of course
next PARAM if $STANDARD_KEYWORD{ $param } || !$has_uploads;
# Look for file uploads in this field
my @field_uploads = $self->_parse_uploads($cgi, $param);
# Found some, add them to the general stash and kill the field
if ( @field_uploads ) {
push @_uploads, @field_uploads;
delete $keyword{ $param };
};
};
# Metadata is JSON encoded; decode_metadata lives by side effects!
if ( exists $keyword{metadata} ) {
RPC::ExtDirect::Util::decode_metadata($self, \%keyword);
}
# Remove extType because it's meaningless later on
delete $keyword{ extType };
# Fix up the TID so that it comes as a number (JavaScript is picky)
$keyword{ extTID } += 0 if exists $keyword{ extTID };
# Now add files to hash, if any
$keyword{ '_uploads' } = \@_uploads if @_uploads;
return \%keyword;
}
### PRIVATE INSTANCE METHOD ###
#
# Parses CGI form input field looking for file uploads
#
sub _parse_uploads {
my ($self, $cgi, $param) = @_;
# CGI returns "lightweight file handles", or undef
my @file_handles = $cgi->upload($param);
# Empty list means no uploads for this field
return unless grep { defined $_ } @file_handles;
# Despite what CGI documentation says, the values returned
# as "file names" are actually some kind of key handles
my @file_keys = $cgi->param($param);
# Here file uploads get collected
my @uploads = ();
# Collect the info we need to repackage it in a consistent way
FILE:
for my $key ( @file_keys ) {
# First take a closer look at this "blah-blah handle"
my $file_handle = shift @file_handles;
# undef would mean there was an upload error (timeout perhaps)
# Following HTTP POST logic, when one upload breaks, that
# would mean all subsequent uploads in this POST are also
# broken.
# We can't recover from that so just stop trying.
last FILE unless defined $file_handle;
# In CGI.pm < 3.41, "lightweight handle" object doesn't support
# returning IO::Handle so we do it manually to avoid problems
my $io_handle = IO::Handle->new_from_fd(fileno $file_handle, '<');
# We also need a lot of info about the file (if provided)
my $upload_info = $cgi->uploadInfo($key);
my $temp_file = $cgi->tmpFileName($key);
my $file_type = $upload_info->{'Content-Type'};
my $file_name = $self->_get_file_name($upload_info);
my $file_size = $self->_get_file_size($io_handle);
my $base_name = basename($file_name);
# Now instead of a "blah-blah handle" we have a normalized hashref
push @uploads, {
type => $file_type,
size => $file_size,
path => $temp_file,
handle => $io_handle,
basename => $base_name,
filename => $file_name,
};
};
return @uploads;
}
### PRIVATE INSTANCE METHOD ###
#
# Tries hard to extract file name from multipart form guts
#
sub _get_file_name {
my ($self, $upload_info) = @_;
# Pluck file name from Content-Disposition string
my ($file_name)
= $upload_info->{'Content-Disposition'} =~ /filename="(.*?)"/;
# URL unescape it
$file_name =~ s/%([\dA-Fa-f]{2})/pack("C", hex $1)/eg;
return $file_name;
}
### PRIVATE INSTANCE METHOD ###
#
# Enquiries IO::Handle supplied by CGI for file size
t/04_headers.t view on Meta::CPAN
use strict;
use warnings;
# This test is CGI::ExtDirect specific, hence it is not unified with the rest
# of the framework
use Test::More tests => 54;
use lib 't/lib';
use RPC::ExtDirect::Test::Util::CGI qw/ raw_post form_post form_upload /;
use CGI::ExtDirect;
use constant WINDOWS => eval { $^O =~ /Win32|cygwin/ };
my $tests = eval do { local $/; <DATA>; } ## no critic
or die "Can't eval DATA: '$@'";
# Testing API
my $ct = CGI::Test->new(
t/cgi-bin/router2 view on Meta::CPAN
use CGI::ExtDirect;
use RPC::ExtDirect::Test::Pkg::Foo;
use RPC::ExtDirect::Test::Pkg::JuiceBar;
use RPC::ExtDirect::Test::Pkg::Qux;
# 2 argument open() is here for older Perls
open STDIN, '<&3' or die "Can't reopen STDIN";
# Set the cheat flag for file uploads
local $RPC::ExtDirect::Test::Pkg::JuiceBar::CHEAT = 1;
my $debug = 1;
my %headers = ();
my $cgi = CGI::ExtDirect->new({ debug => 1 });
print $cgi->route(%headers);
exit 0;
t/cgi-bin/router2.bat view on Meta::CPAN
@rem ';
#!perl
#line 15
use CGI::ExtDirect;
use RPC::ExtDirect::Test::Pkg::Foo;
use RPC::ExtDirect::Test::Pkg::JuiceBar;
use RPC::ExtDirect::Test::Pkg::Qux;
# Set the cheat flag for file uploads
local $RPC::ExtDirect::Test::Pkg::JuiceBar::CHEAT = 1;
my $debug = 1;
my %headers = ();
my $cgi = CGI::ExtDirect->new({ debug => 1 });
print $cgi->route(%headers);
exit 0;
t/cgi-bin/router3 view on Meta::CPAN
use CGI 'cookie';
use CGI::ExtDirect;
use RPC::ExtDirect::Test::Pkg::Foo;
use RPC::ExtDirect::Test::Pkg::JuiceBar;
use RPC::ExtDirect::Test::Pkg::Qux;
# 2 argument open() is here for older Perls
open STDIN, '<&3' or die "Can't reopen STDIN";
# Set the cheat flag for file uploads
local $RPC::ExtDirect::Test::Pkg::JuiceBar::CHEAT = 1;
my $cookie = cookie(-name=>'sessionID',
-value=>'xyzzy',
-expires=>'Thursday, 25-Apr-1999 00:40:33 GMT',
-path=>'/cgi-bin/database',
-domain=>'.capricorn.org',
-secure=>1);
my %headers = (
t/cgi-bin/router3.bat view on Meta::CPAN
#!perl
#line 15
use CGI 'cookie';
use CGI::ExtDirect;
use RPC::ExtDirect::Test::Pkg::Foo;
use RPC::ExtDirect::Test::Pkg::JuiceBar;
use RPC::ExtDirect::Test::Pkg::Qux;
# Set the cheat flag for file uploads
local $RPC::ExtDirect::Test::Pkg::JuiceBar::CHEAT = 1;
my $cookie = cookie(-name=>'sessionID',
-value=>'xyzzy',
-expires=>'Thursday, 25-Apr-1999 00:40:33 GMT',
-path=>'/cgi-bin/database',
-domain=>'.capricorn.org',
-secure=>1);
my %headers = (
t/lib/RPC/ExtDirect/Test/Util/CGI.pm view on Meta::CPAN
use base 'Exporter';
our @EXPORT = qw/
run_tests
/;
our @EXPORT_OK = qw/
raw_post
form_post
form_upload
/;
use constant WINDOWS => eval { $^O =~ /Win32|cygwin/ };
### EXPORTED PUBLIC PACKAGE SUBROUTINE ###
#
# Run the test battery from the passed definitions
#
sub run_tests {
t/lib/RPC/ExtDirect/Test/Util/CGI.pm view on Meta::CPAN
my $value = $fields{ $field };
$cgi_input->add_field($field, $value);
};
return $cgi_input;
}
### NON EXPORTED PUBLIC PACKAGE SUBROUTINE ###
#
# Return a new CGI::Test::Input object for a form call
# with file uploads
#
sub form_upload {
# This can be called either as a class method, or a plain sub
shift if $_[0] eq __PACKAGE__;
my ($url, $files, %fields) = @_;
my $cgi_input = CGI::Test::Input::Multipart->new();
for my $field ( keys %fields ) {
my $value = $fields{ $field };
$cgi_input->add_field($field, $value);
};
for my $file ( @$files ) {
$cgi_input->add_file_now("upload", "t/data/cgi-data/$file");
};
return $cgi_input;
}
1;
( run in 1.314 second using v1.01-cache-2.11-cpan-b16cb0d3907 )