Test-CGI-Multipart-v0.0.3000755001750001750 011443457767 16003 5ustar00nicholasnicholas000000000000Test-CGI-Multipart-v0.0.3/META.yml000444001750001750 205411443457767 17412 0ustar00nicholasnicholas000000000000--- abstract: 'Test posting of multi-part form data' author: - 'Nicholas Bamber ' build_requires: Perl6::Slurp: 0 Test::Exception: 0 Test::More: 0 configure_requires: Module::Build: 0.36 generated_by: 'Module::Build version 0.3607' keywords: - Test - CGI - upload - image - multipart/form-data license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: Test-CGI-Multipart provides: Test::CGI::Multipart: file: lib/Test/CGI/Multipart.pm version: v0.0.3 Test::CGI::Multipart::Gen::Image: file: lib/Test/CGI/Multipart/Gen/Image.pm version: v0.0.3 Test::CGI::Multipart::Gen::Text: file: lib/Test/CGI/Multipart/Gen/Text.pm version: v0.0.3 recommends: GD: 0 Text::Lorem: 0 requires: CGI: 3.41 MIME::Entity: 0 Params::Validate: 0 Readonly: 0 UNIVERSAL::require: 0 autodie: 0 perl: v5.6.1 version: 0 resources: license: http://dev.perl.org/licenses/ repository: http://github.com/periapt/Test-CGI-Multipart/tree version: v0.0.3 Test-CGI-Multipart-v0.0.3/Makefile.PL000444001750001750 154311443457767 20115 0ustar00nicholasnicholas000000000000# Note: this file was auto-generated by Module::Build::Compat version 0.3607 require 5.006001; use ExtUtils::MakeMaker; WriteMakefile ( 'NAME' => 'Test::CGI::Multipart', 'VERSION_FROM' => 'lib/Test/CGI/Multipart.pm', 'PREREQ_PM' => { 'CGI' => '3.41', 'MIME::Entity' => 0, 'Params::Validate' => 0, 'Perl6::Slurp' => 0, 'Readonly' => 0, 'Test::Exception' => 0, 'Test::More' => 0, 'UNIVERSAL::require' => 0, 'autodie' => 0, 'version' => 0 }, 'INSTALLDIRS' => 'site', 'EXE_FILES' => [], 'PL_FILES' => {} ) ; Test-CGI-Multipart-v0.0.3/README000444001750001750 2141311443457767 17041 0ustar00nicholasnicholas000000000000NAME Test::CGI::Multipart - Test posting of multi-part form data VERSION This document describes Test::CGI::Multipart version 0.0.2 SYNOPSIS use Test::CGI::Multipart; my $tcm = Test::CGI::Multipart; # specify the form parameters $tcm->set_param(name='email',value=>'jim@hacker.com'); $tcm->set_param(name=>'pets',value=> ['Rex', 'Oscar', 'Bidgie', 'Fish']); $tcm->set_param(name=>'first_name',value=>'Jim'); $tcm->set_param(name=>'last_name',value=>'Hacker'); $tcm->upload_file( name=>'file1', file=>'made_up_filename.txt', value=>$content ); $tcm->upload_file( name=>'file1', file=>'made_up_filename.blah', value=>$content_blah, type=>'application/blah' ); # Behind the scenes this will fake the browser and web server behaviour # with regard to environment variables, MIME format and standard input. my $cgi = $tcm->create_cgi; # Okay now we have a CGI object which we can pass into the code # that needs testing and run the form handling various tests. DESCRIPTION It is quite difficult to write test code to capture the behaviour of CGI or similar objects handling forms that include a file upload. Such code needs to harvest the parameters, build file content in MIME format, set the environment variables accordingly and pump it into the the standard input of the required CGI object. This module provides simple methods so that having prepared suitable content, the test script can simulate the submission of web forms including file uploads. However we also recognise that a test script is not always the best place to prepare content. Rather a test script would rather specify requirements for a file a upload: type, size, mismatches between the file name and its contents and so on. This module cannot hope to provide such open ended functionality but it can provide extension mechanisms. This module works with CGI (the default), CGI::Minimal and CGI::Simple. In principle it ought to work with all equivalent modules however each module has a slightly different interface when it comes to file uploads and so requires slightly different test code. INTERFACE Several of the methods below take named parameters. For convenience we define those parameters here: "cgi" This option defines the CGI module. It should be a scalar consisting only of alphanumeric characters and "::". It defaults to 'CGI'. "name" This is the name of form parameter. It must be a scalar. "value" This is the value of the form parameter. It should either be a scalar or an array reference of scalars. "file" Where a form parameter represents a file, this is the name of that file. "type" The MIME type of the content. This defaults to 'text/plain'. "ua" The HTTP_USER_AGENT environment variable. This defaults to 'Test::CGI::Multipart'. new An instance of this class might best be thought of as a "CGI object factory". The constructor takes no parameters. create_cgi This returns a CGI object created according to the specification encapsulated in the object. The exact mechanics are as follows: The parameters are packaged up in MIME format. The environment variables are set. A pipe is created. The far end of the pipe is attached to our standard input and the MIME content is pushed through the pipe. The appropriate CGI class is required. Uploads are enabled if the CGI class is CGI::Simple. Global variables are reset for CGI and CGI::Minimal. The CGI object is created and returned. As far as I can see this simulates what happens when a CGI script processes a multi-part POST form. One can specify a different CGI class using the "cgi" named parameter. One can set the HTTP_USER_AGENT environment variable with the "ua" parameter. set_param This can be used to set a single form parameter. It takes two named arguments "name" and "value". Note that this method overrides any previous settings including file uploads. get_param This retrieves a single form parameter. It takes a single named parameter: "name". The data returned will be a list either of scalar values or (in the case of a file upload) of HASHREFs. The HASHREFs would have the following fields: "file", "value" and "type" representing the parameter name, the file name, the content and the MIME type respectively. get_names This returns a list of stashed parameter names. upload_file In the absence of any defined callbacks, this method takes three mandatory named parameters: "name", "file" and "value" and one optional parameter "type". If there are any callbacks then the parameters are passed through each of the callbacks and must meet the standard parameter requirements by the time all the callbacks have been called. Unlike the "set_param" method this will not override previous settings for this parameter but will add. However setting a normal parameter and then an upload on the same name will throw an error. register_callback Callbacks are used by the "upload_file" method, to allow a file to be specified by properties rather than strict content. This method takes a single named parameter called "callback", which adds that callback to an internal array of callbacks. The idea being that the "upload_file" method can take any arguments you like so long as after all the callbacks have been applied, the parameters consist of "name", "file", "value" and possibly "type". A callback should take and return a single hash reference. DIAGNOSTICS "unexpected data structure" During the construction of the MIME data, the internal data structure turned out to have unexpected features. Since we control that data structure that should not happen. "mismatch: is %s a file upload or not" The parameter was being used for both for file upload and normal parameters. CONFIGURATION AND ENVIRONMENT Test::CGI::Multipart requires no configuration files or environment variables. However it should be noted that the module will overwrite the following environment variables: REQUEST_METHOD CONTENT_LENGTH CONTENT_TYPE HTTP_USER_AGENT INCOMPATIBILITIES I would like to get this working with CGI::Lite::Request and Apache::Request if that makes sense. So far I have not managed that. BUGS AND LIMITATIONS No bugs have been reported. Please report any bugs or feature requests to "bug-test-cgi-multipart@rt.cpan.org", or through the web interface at . This module depends upon MIME::Tools. Unfortunately that module does not handle newlines quite correctly. That seems to work fine for email but does not work with CGI. I have looked at MIME::Fast and MIME::Lite but MIME::Tools combined with a hack seems the best that can be done at the moment. Sooner or later someone is going to hit the limitations of that hack. AUTHOR Nicholas Bamber "" LICENCE AND COPYRIGHT Copyright (c) 2010, Nicholas Bamber "". All rights reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See perlartistic. DISCLAIMER OF WARRANTY BECAUSE THIS SOFTWARE IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE SOFTWARE, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE SOFTWARE "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE SOFTWARE IS WITH YOU. SHOULD THE SOFTWARE PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR, OR CORRECTION. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE SOFTWARE AS PERMITTED BY THE ABOVE LICENCE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE SOFTWARE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE SOFTWARE TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. Test-CGI-Multipart-v0.0.3/MANIFEST000444001750001750 75711443457767 17262 0ustar00nicholasnicholas000000000000Build.PL Changes ignore.txt lib/Test/CGI/Multipart.pm lib/Test/CGI/Multipart/Gen/Image.pm lib/Test/CGI/Multipart/Gen/Text.pm MANIFEST README t/00.load.t t/01.basic.t t/01.data_structure.t t/02.param.t t/03.upload.t t/04.multiple.t t/04.separate.t t/05.callbacks.t t/10.text.t t/11.reset.t t/20.image.t t/changes.t t/lib/AddParam.pm t/lib/AddValue.pm t/lib/FilePop.pm t/lib/Utils.pm t/manifest.t t/perlcritic.t t/perlcriticrc t/pod-coverage.t t/pod.t t/podspell.t t/prereq.t Makefile.PL META.yml Test-CGI-Multipart-v0.0.3/ignore.txt000444001750001750 20011443457767 20134 0ustar00nicholasnicholas000000000000blib* Makefile Makefile.old Build Build.bat _build* pm_to_blib* *.tar.gz .lwpcookies cover_db pod2htm*.tmp Test-CGI-Multipart-* Test-CGI-Multipart-v0.0.3/Build.PL000444001750001750 211011443457767 17426 0ustar00nicholasnicholas000000000000use strict; use warnings; use Module::Build; my $builder = Module::Build->new( module_name => 'Test::CGI::Multipart', license => 'perl', dist_author => 'Nicholas Bamber ', dist_version_from => 'lib/Test/CGI/Multipart.pm', build_requires => { 'Test::More' => 0, 'Test::Exception' => 0, 'Perl6::Slurp'=>0, }, requires => { 'perl'=>'5.6.1', 'MIME::Entity'=>0, 'autodie'=>0, 'version' => 0, 'UNIVERSAL::require' => 0, 'CGI' => '3.41', 'Readonly' => 0, 'Params::Validate'=>0, }, recommends => { 'Text::Lorem' => 0, 'GD'=>0, }, meta_merge => { resources => { repository => 'http://github.com/periapt/Test-CGI-Multipart/tree', }, keywords => [ 'Test', 'CGI', 'upload', 'image', 'multipart/form-data' ], }, create_makefile_pl => 'traditional', add_to_cleanup => [ 'Test-CGI-Multipart-*' ], ); $builder->create_build_script(); Test-CGI-Multipart-v0.0.3/Changes000444001750001750 63611443457767 17420 0ustar00nicholasnicholas000000000000Revision history for Test-CGI-Multipart v0.0.3 Mon Sep 13 2010 CGI >= 3.41 dependency due to file handle promotion. Refreshed README v0.0.2 Sun Sep 12 2010 Updating dependencies. Made perlcritic.t an author only test. Fixed layout of description sections in documentation and mentioned restting of global variables. v0.0.1 Sun Jun 27 00:06:07 2010 Initial release. Test-CGI-Multipart-v0.0.3/t000755001750001750 011443457767 16246 5ustar00nicholasnicholas000000000000Test-CGI-Multipart-v0.0.3/t/01.data_structure.t000444001750001750 132511443457767 22041 0ustar00nicholasnicholas000000000000#!perl -w use strict; use warnings; use Test::More; use Test::Exception; use Test::CGI::Multipart; use lib qw(t/lib); use Utils; my @cgi_modules = Utils::get_cgi_modules; plan tests => 1+scalar(@cgi_modules); my $tcm = Test::CGI::Multipart->new; isa_ok($tcm, 'Test::CGI::Multipart'); # This should not happen. $tcm->{params}->{weird} = sub {return "weird"}; foreach my $class (@cgi_modules) { if ($class) { diag "Testing with $class"; } my $cgi = undef; if ($class) { dies_ok { $cgi = $tcm->create_cgi(cgi=>$class); } 'unexpected data structure'; } else { dies_ok { $cgi = $tcm->create_cgi; } 'unexpected data structure'; } } Test-CGI-Multipart-v0.0.3/t/prereq.t000444001750001750 107411443457767 20070 0ustar00nicholasnicholas000000000000use strict; use warnings; use Test::More; if ( not $ENV{TEST_PREREQ} ) { my $msg = 'Author test. Set $ENV{TEST_PREREQ} to a true value to run.'; plan( skip_all => $msg ); } eval { require Test::Prereq::Build; }; if ( $@) { my $msg = 'Test::Prereq required to criticise code'; plan( skip_all => $msg ); } Test::Prereq::Build::prereq_ok(undef, 'prereq', ['Test::Perl::Critic','Test::CheckChanges', 'Test::CheckManifest', 'Test::Spelling', 'Test::Prereq', 'Test::Prereq::Build', 'Utils', 'GD::Simple', 'Text::Lorem', 'AddParam', 'FilePop', 'AddValue']); Test-CGI-Multipart-v0.0.3/t/20.image.t000444001750001750 445111443457767 20076 0ustar00nicholasnicholas000000000000#!perl -w use strict; use warnings; use Test::More; use Test::CGI::Multipart; use Readonly; use lib qw(t/lib); use Utils; use autodie qw(open close); Readonly my $PETS => ['Rex','Oscar','Bidgie','Fish']; eval {require Test::CGI::Multipart::Gen::Image;}; if ($@) { my $msg = "This test requires GD::Simple"; plan skip_all => $msg; } my @cgi_modules = Utils::get_cgi_modules; plan tests => 9+5*@cgi_modules; my $tcm = Test::CGI::Multipart->new; isa_ok($tcm, 'Test::CGI::Multipart'); ok(!defined $tcm->set_param( name=>'first_name', value=>'Jim'), 'setting parameter'); my @values = $tcm->get_param(name=>'first_name'); is_deeply(\@values, ['Jim'], 'get param'); my @names= $tcm->get_names; is_deeply(\@names, ['first_name'], 'first name deep'); ok(!defined $tcm->set_param( name=>'pets', value=>$PETS), 'setting parameter'); @values = $tcm->get_param(name=>'pets'); is_deeply(\@values, $PETS, 'get param'); @names= sort $tcm->get_names; is_deeply(\@names, ['first_name','pets'], 'names deep'); ok(!defined $tcm->upload_file( name=>'image', width=>400, height=>250, instructions=>[ ['bgcolor','red'], ['fgcolor','blue'], ['rectangle',30,30,100,100], ['moveTo',80,210], ['fontsize',20], ['string','Helloooooooooooo world!'], ], file=>'cleopatra.doc', type=>'image/jpeg' ), 'image'); @names= sort $tcm->get_names; is_deeply(\@names, ['first_name', 'image', 'pets'], 'names deep'); foreach my $class (@cgi_modules) { if ($class) { diag "Testing with $class"; } my $cgi = undef; if ($class) { $cgi = $tcm->create_cgi(cgi=>$class); } else { $cgi = $tcm->create_cgi; } isa_ok($cgi, $class||'CGI', 'created CGI object okay'); @names = grep {$_ ne '' and $_ ne '.submit'} sort $cgi->param; is_deeply(\@names, ['first_name', 'image', 'pets'], 'names deep'); foreach my $name (@names) { my $expected = Utils::get_expected($tcm, $name); my $got = undef; if (ref $expected->[0] eq 'HASH') { $got = Utils::get_actual_upload($cgi, $name); } else { my @got = $cgi->param($name); $got = \@got; } is_deeply($got, $expected, $name); } } Test-CGI-Multipart-v0.0.3/t/manifest.t000444001750001750 75711443457767 20367 0ustar00nicholasnicholas000000000000use strict; use warnings; use Test::More; if ( not $ENV{TEST_AUTHOR} ) { my $msg = 'Author test. Set $ENV{TEST_AUTHOR} to a true value to run.'; plan( skip_all => $msg ); } eval { require Test::CheckManifest; }; if ( $@ ) { my $msg = 'Test::CheckManifest required to check manifest'; plan( skip_all => $msg ); } Test::CheckManifest::ok_manifest({filter=>[qr/\/cover_db/,qr/\/\.git/,qr/\/\.dotest/,qr/\.bak$/,qr/\.old$/,qr/t\/dbfile$/,qr/\.tar\.gz$/,qr/Makefile(?:\.PL)$/]}); Test-CGI-Multipart-v0.0.3/t/02.param.t000444001750001750 267311443457767 20120 0ustar00nicholasnicholas000000000000#!perl -w use strict; use warnings; use Test::More; use Test::CGI::Multipart; use Readonly; use lib qw(t/lib); use Utils; Readonly my $PETS => ['Rex','Oscar','Bidgie','Fish']; my @cgi_modules = Utils::get_cgi_modules; plan tests => 7+4*scalar(@cgi_modules); my $tcm = Test::CGI::Multipart->new; isa_ok($tcm, 'Test::CGI::Multipart'); ok(!defined $tcm->set_param( name=>'first_name', value=>'Jim'), 'setting parameter'); my @values = $tcm->get_param(name=>'first_name'); is_deeply(\@values, ['Jim'], 'get param'); my @names= $tcm->get_names; is_deeply(\@names, ['first_name'], 'first name deep'); ok(!defined $tcm->set_param( name=>'pets', value=>$PETS), 'setting parameter'); @values = $tcm->get_param(name=>'pets'); is_deeply(\@values, $PETS, 'get param'); @names= sort $tcm->get_names; is_deeply(\@names, ['first_name','pets'], 'names deep'); foreach my $class (@cgi_modules) { if ($class) { diag "Testing with $class"; } my $cgi = undef; if ($class) { $cgi = $tcm->create_cgi(cgi=>$class); } else { $cgi = $tcm->create_cgi; } isa_ok($cgi, $class||'CGI', 'created CGI object okay'); @names = grep {$_ ne '' and $_ ne '.submit'} sort $cgi->param; is_deeply(\@names, ['first_name','pets'], 'names deep'); foreach my $name (@names) { my @got = $cgi->param($name); my @expected = $tcm->get_param(name=>$name); is_deeply(\@got, \@expected, $name); } } Test-CGI-Multipart-v0.0.3/t/10.text.t000444001750001750 1142211443457767 20013 0ustar00nicholasnicholas000000000000#!perl -w use strict; use warnings; use Test::More; use Test::CGI::Multipart; use Test::Exception; use Readonly; use lib qw(t/lib); use Utils; srand(0); eval {require Test::CGI::Multipart::Gen::Text;}; if ($@) { my $msg = "This test requires Text::Lorem"; plan skip_all => $msg; } Readonly my $PETS => ['Rex','Oscar','Bidgie','Fish']; Readonly my $NAMES => ['first_name', 'paragraphs', 'pets', 'sentences', 'uninteresting', 'words']; Readonly my $PARAGRAPH => qq{Reprehenderit similique a accusamus neque ad quaerat. Iusto temporibus consequuntur vitae earum accusantium sequi eum sequi. Debitis et voluptatem ipsam assumenda odit assumenda.\n\nOmnis velit est non quas. Iusto est in harum laudantium harum eos sapiente. Ducimus quia tenetur ea. Aut tenetur maiores in et voluptatem. Et veritatis tenetur delectus repellendus aut sunt veniam sapiente.}; my @cgi_modules = Utils::get_cgi_modules; plan tests => 22+(2+scalar @$NAMES)*@cgi_modules; my $tcm = Test::CGI::Multipart->new; isa_ok($tcm, 'Test::CGI::Multipart'); ok(!defined $tcm->set_param( name=>'first_name', value=>'Jim'), 'setting parameter'); my @values = $tcm->get_param(name=>'first_name'); is_deeply(\@values, ['Jim'], 'get param'); my @names= $tcm->get_names; is_deeply(\@names, ['first_name'], 'first name deep'); ok(!defined $tcm->set_param( name=>'pets', value=>$PETS), 'setting parameter'); @values = $tcm->get_param(name=>'pets'); is_deeply(\@values, $PETS, 'get param'); @names= sort $tcm->get_names; is_deeply(\@names, ['first_name','pets'], 'names deep'); ok(!defined $tcm->upload_file( name=>'uninteresting', file=>'other.blah', value=>'Fee Fi Fo Fum', ), 'uploading other file'); @names= sort $tcm->get_names; is_deeply(\@names, ['first_name', 'pets', 'uninteresting'], 'names deep'); ok(!defined $tcm->upload_file( name=>'words', file=>'words.txt', type=>'text/plain', words=>5, sentences=>2, paragraphs=>2, ), 'uploading other file'); @names= sort $tcm->get_names; is_deeply(\@names, ['first_name', 'pets', 'uninteresting', 'words'], 'names deep'); is_deeply(Utils::get_expected($tcm, 'words'), [{name=>'words',value=>'ipsum placeat explicabo accusamus in',file=>'words.txt',type=>'text/plain'}], 'words'); ok(!defined $tcm->upload_file( name=>'sentences', file=>'sentences.txt', type=>'text/plain', sentences=>2, paragraphs=>2, ), 'uploading other file'); @names= sort $tcm->get_names; is_deeply(\@names, ['first_name', 'pets', 'sentences', 'uninteresting', 'words']); is_deeply(Utils::get_expected($tcm, 'sentences'), [{name=>'sentences',value=>'Eligendi consequatur officiis maxime ducimus ex minus quaerat. Omnis nulla in porro vitae blanditiis.',file=>'sentences.txt',type=>'text/plain'}], 'sentences'); ok(!defined $tcm->upload_file( name=>'paragraphs', file=>'paragraphs.txt', type=>'text/plain', paragraphs=>2, ), 'uploading other file'); @names= sort $tcm->get_names; is_deeply(\@names, $NAMES); is_deeply(Utils::get_expected($tcm, 'paragraphs')->[0]->{value}, $PARAGRAPH, 'paragraphs'); throws_ok {$tcm->upload_file( name=>'paragraphs', file=>'paragraphs.txt', type=>'text/plain', )} qr/No words, sentences or paragraphs specified/, 'inadequately specified'; throws_ok {$tcm->upload_file( name=>'paragraphs', file=>'paragraphs.txt', type=>'text/plain', words=>'twenty', )} qr/No words, sentences or paragraphs specified/, 'inadequately specified'; throws_ok {$tcm->upload_file( name=>'paragraphs', file=>'paragraphs.txt', type=>'application/blah', words=>'twenty', )} qr/The following parameter was passed in the call to Test::CGI::Multipart::_upload_file but was not listed in the validation options: words/, 'wrong type'; throws_ok {$tcm->upload_file( name=>'paragraphs', file=>'paragraphs.txt', value=>'Hello world', type=>'text/plain', words=>'twenty', )} qr/The following parameter was passed in the call to Test::CGI::Multipart::_upload_file but was not listed in the validation options: words/, 'words and value specified'; foreach my $class (@cgi_modules) { if ($class) { diag "Testing with $class"; } my $cgi = undef; if ($class) { $cgi = $tcm->create_cgi(cgi=>$class); } else { $cgi = $tcm->create_cgi; } isa_ok($cgi, $class||'CGI', 'created CGI object okay'); @names = grep {$_ ne '' and $_ ne '.submit'} sort $cgi->param; is_deeply(\@names, $NAMES, 'names deep'); foreach my $name (@names) { my $expected = Utils::get_expected($tcm, $name); my $got = undef; if (ref $expected->[0] eq 'HASH') { $got = Utils::get_actual_upload($cgi, $name); } else { my @got = $cgi->param($name); $got = \@got; } is_deeply($got, $expected, $name); } } Test-CGI-Multipart-v0.0.3/t/perlcritic.t000444001750001750 54411443457767 20713 0ustar00nicholasnicholas000000000000#!perl use Test::More; if ( not $ENV{TEST_AUTHOR} ) { my $msg = 'Author test. Set $ENV{TEST_AUTHOR} to a true value to run.'; plan( skip_all => $msg ); } eval {require Test::Perl::Critic}; if ($@) { Test::More::plan( skip_all => "Test::Perl::Critic required for testing PBP compliance" ); } Test::Perl::Critic::all_critic_ok(); Test-CGI-Multipart-v0.0.3/t/pod.t000444001750001750 21411443457767 17327 0ustar00nicholasnicholas000000000000#!perl -T use Test::More; eval "use Test::Pod 1.14"; plan skip_all => "Test::Pod 1.14 required for testing POD" if $@; all_pod_files_ok(); Test-CGI-Multipart-v0.0.3/t/perlcriticrc000444001750001750 120311443457767 21007 0ustar00nicholasnicholas000000000000severity = 1 exclude = Subroutines::ProhibitExplicitReturnUndef Subroutines::RequireArgUnpacking ClassHierarchies::ProhibitAutoloading RegularExpressions Miscellanea::RequireRcsKeywords Documentation::RequirePodAtEnd ControlStructures::ProhibitUnlessBlocks ControlStructures::ProhibitNegativeExpressionsInUnlessAndUntilConditions ControlStructures::ProhibitPostfixControls Documentation::RequirePodSections References::ProhibitDoubleSigils Variables::ProhibitPunctuationVars ValuesAndExpressions::ProhibitInterpolationOfLiterals Subroutines::ProhibitManyArgs ValuesAndExpressions::ProhibitNoisyQuotes ValuesAndExpressions::ProhibitEmptyQuotes Test-CGI-Multipart-v0.0.3/t/podspell.t000444001750001750 214511443457767 20414 0ustar00nicholasnicholas000000000000use strict; use warnings; use English qw(-no_match_vars); use Test::More; if ( not $ENV{TEST_AUTHOR} ) { my $msg = 'Author test. Set $ENV{TEST_AUTHOR} to a true value to run.'; plan( skip_all => $msg ); } eval { require Test::Spelling; }; if ( $EVAL_ERROR ) { my $msg = 'Test::Spelling required to criticise code'; plan( skip_all => $msg ); } Test::Spelling::add_stopwords(qw( CPAN Bamber github AnnoCPAN RT HASHREFs API callback callbacks multipart param SQL DBI HTML CGI URLs)); Test::Spelling::all_pod_files_spelling_ok(); Test-CGI-Multipart-v0.0.3/t/01.basic.t000444001750001750 103411443457767 20066 0ustar00nicholasnicholas000000000000#!perl -w use strict; use warnings; use Test::More; use Test::CGI::Multipart; use lib qw(t/lib); use Utils; my @cgi_modules = Utils::get_cgi_modules; plan tests => 1+scalar(@cgi_modules); my $tcm = Test::CGI::Multipart->new; isa_ok($tcm, 'Test::CGI::Multipart'); foreach my $class (@cgi_modules) { if ($class) { diag "Testing with $class"; } my $cgi = undef; if ($class) { $cgi = $tcm->create_cgi(cgi=>$class); } else { $cgi = $tcm->create_cgi; } isa_ok($cgi, $class || 'CGI'); } Test-CGI-Multipart-v0.0.3/t/00.load.t000444001750001750 22011443457767 17677 0ustar00nicholasnicholas000000000000use Test::More tests => 1; BEGIN { use_ok( 'Test::CGI::Multipart' ); } diag( "Testing Test::CGI::Multipart $Test::CGI::Multipart::VERSION" ); Test-CGI-Multipart-v0.0.3/t/pod-coverage.t000444001750001750 25411443457767 21124 0ustar00nicholasnicholas000000000000#!perl -T use Test::More; eval "use Test::Pod::Coverage 1.04"; plan skip_all => "Test::Pod::Coverage 1.04 required for testing POD coverage" if $@; all_pod_coverage_ok(); Test-CGI-Multipart-v0.0.3/t/03.upload.t000444001750001750 406611443457767 20303 0ustar00nicholasnicholas000000000000#!perl -w use strict; use warnings; use Test::More; use Test::CGI::Multipart; use Test::Exception; use Readonly; use lib qw(t/lib); use Utils; Readonly my $PETS => ['Rex','Oscar','Bidgie','Fish']; #my @cgi_modules = (undef, 'CGI'); #Utils::get_cgi_modules; my @cgi_modules = Utils::get_cgi_modules; plan tests => 9+5*scalar(@cgi_modules); my $tcm = Test::CGI::Multipart->new; isa_ok($tcm, 'Test::CGI::Multipart'); ok(!defined $tcm->set_param( name=>'first_name', value=>'Jim'), 'setting parameter'); my @values = $tcm->get_param(name=>'first_name'); is_deeply(\@values, ['Jim'], 'get param'); my @names= $tcm->get_names; is_deeply(\@names, ['first_name'], 'first name deep'); ok(!defined $tcm->set_param( name=>'pets', value=>$PETS), 'setting parameter'); @values = $tcm->get_param(name=>'pets'); is_deeply(\@values, $PETS, 'get param'); @names= sort $tcm->get_names; is_deeply(\@names, ['first_name','pets'], 'names deep'); ok(!defined $tcm->upload_file( name=>'files', file=>'doo_doo.blah', value=>'Blah, Blah, Blah,....'), 'uploading blah file'); @names= sort $tcm->get_names; is_deeply(\@names, ['files', 'first_name', 'pets'], 'names deep'); SKIP: foreach my $class (@cgi_modules) { # if (defined $class and $class eq 'CGI::Simple') { # skip 'CGI::Simple not working', 5; # } if ($class) { diag "Testing with $class"; } my $cgi = undef; if ($class) { $cgi = $tcm->create_cgi(cgi=>$class); } else { $cgi = $tcm->create_cgi; } isa_ok($cgi, $class||'CGI', 'created CGI object okay'); @names = grep {$_ ne '' and $_ ne '.submit'} sort $cgi->param; is_deeply(\@names, ['files', 'first_name','pets'], 'names deep'); foreach my $name (@names) { my $expected = Utils::get_expected($tcm, $name); my $got = undef; if (ref $expected->[0] eq 'HASH') { $got = Utils::get_actual_upload($cgi, $name); } else { my @got = $cgi->param($name); $got = \@got; } is_deeply($got, $expected, $name); } } Test-CGI-Multipart-v0.0.3/t/04.multiple.t000444001750001750 473511443457767 20656 0ustar00nicholasnicholas000000000000#!perl -w use strict; use warnings; use Test::More; use Test::CGI::Multipart; use Test::Exception; use Readonly; use lib qw(t/lib); use Utils; Readonly my $PETS => ['Rex','Oscar','Bidgie','Fish']; my @cgi_modules = Utils::get_cgi_modules; plan tests => 12+5*@cgi_modules; my $tcm = Test::CGI::Multipart->new; isa_ok($tcm, 'Test::CGI::Multipart'); ok(!defined $tcm->set_param( name=>'first_name', value=>'Jim'), 'setting parameter'); my @values = $tcm->get_param(name=>'first_name'); is_deeply(\@values, ['Jim'], 'get param'); my @names= $tcm->get_names; is_deeply(\@names, ['first_name'], 'first name deep'); ok(!defined $tcm->set_param( name=>'pets', value=>$PETS), 'setting parameter'); @values = $tcm->get_param(name=>'pets'); is_deeply(\@values, $PETS, 'get param'); @names= sort $tcm->get_names; is_deeply(\@names, ['first_name','pets'], 'names deep'); ok(!defined $tcm->upload_file( name=>'files', file=>'doo_doo.blah', value=>'Blah, Blah, Blah,....'), 'uploading blah file'); @names= sort $tcm->get_names; is_deeply(\@names, ['files', 'first_name', 'pets'], 'names deep'); ok(!defined $tcm->upload_file( name=>'files', file=>'nah_nah.blah', value=>'Nah, Nah, Nah,....'), 'uploading second blah file'); @names= sort $tcm->get_names; is_deeply(\@names, ['files', 'first_name', 'pets'], 'names deep'); dies_ok{ $tcm->upload_file( name=>'first_name', file=>'name.blah', value=>'Alfred, Bob, Carl, Dexter, Edward, Frank, George, Harry, Ivan, John,,,,,,')} 'mismatch: is first_name a file upload or not'; foreach my $class (@cgi_modules) { SKIP: { if (defined $class and $class eq 'CGI::Simple') { skip 'CGI::Simple apparently does not support multiple files', 5; } if ($class) { diag "Testing with $class"; } my $cgi = undef; if ($class) { $cgi = $tcm->create_cgi(cgi=>$class); } else { $cgi = $tcm->create_cgi; } isa_ok($cgi, $class||'CGI', 'created CGI object okay'); @names = grep {$_ ne '' and $_ ne '.submit'} sort $cgi->param; is_deeply(\@names, ['files', 'first_name','pets'], 'names deep'); foreach my $name (@names) { my $expected = Utils::get_expected($tcm, $name); my $got = undef; if (ref $expected->[0] eq 'HASH') { $got = Utils::get_actual_upload($cgi, $name); } else { my @got = $cgi->param($name); $got = \@got; } is_deeply($got, $expected, $name); } } } Test-CGI-Multipart-v0.0.3/t/04.separate.t000444001750001750 435411443457767 20624 0ustar00nicholasnicholas000000000000#!perl -w use strict; use warnings; use Test::More; use Test::CGI::Multipart; use Readonly; use lib qw(t/lib); use Utils; Readonly my $PETS => ['Rex','Oscar','Bidgie','Fish']; my @cgi_modules = Utils::get_cgi_modules; plan tests => 11+6*@cgi_modules; my $tcm = Test::CGI::Multipart->new; isa_ok($tcm, 'Test::CGI::Multipart'); ok(!defined $tcm->set_param( name=>'first_name', value=>'Jim'), 'setting parameter'); my @values = $tcm->get_param(name=>'first_name'); is_deeply(\@values, ['Jim'], 'get param'); my @names= $tcm->get_names; is_deeply(\@names, ['first_name'], 'first name deep'); ok(!defined $tcm->set_param( name=>'pets', value=>$PETS), 'setting parameter'); @values = $tcm->get_param(name=>'pets'); is_deeply(\@values, $PETS, 'get param'); @names= sort $tcm->get_names; is_deeply(\@names, ['first_name','pets'], 'names deep'); ok(!defined $tcm->upload_file( name=>'files', file=>'doo_doo.blah', value=>'Blah, Blah, Blah,....'), 'uploading blah file'); @names= sort $tcm->get_names; is_deeply(\@names, ['files', 'first_name', 'pets'], 'names deep'); ok(!defined $tcm->upload_file( name=>'files2', file=>'nah_nah.blah', value=>'Nah, Nah, Nah,....'), 'uploading second blah file'); @names= sort $tcm->get_names; is_deeply(\@names, ['files', 'files2', 'first_name', 'pets'], 'names deep'); foreach my $class (@cgi_modules) { SKIP: { # if (defined $class and $class eq 'CGI::Simple') { ## skip 'CGI::Simple not working', 5; # } if ($class) { diag "Testing with $class"; } my $cgi = undef; if ($class) { $cgi = $tcm->create_cgi(cgi=>$class); } else { $cgi = $tcm->create_cgi; } isa_ok($cgi, $class||'CGI', 'created CGI object okay'); @names = grep {$_ ne '' and $_ ne '.submit'} sort $cgi->param; is_deeply(\@names, ['files', 'files2', 'first_name','pets'], 'names deep'); foreach my $name (@names) { my $expected = Utils::get_expected($tcm, $name); my $got = undef; if (ref $expected->[0] eq 'HASH') { $got = Utils::get_actual_upload($cgi, $name); } else { my @got = $cgi->param($name); $got = \@got; } is_deeply($got, $expected, $name); } } } Test-CGI-Multipart-v0.0.3/t/changes.t000444001750001750 55311443457767 20163 0ustar00nicholasnicholas000000000000use strict; use warnings; use Test::More; if ( not $ENV{TEST_AUTHOR} ) { my $msg = 'Author test. Set $ENV{TEST_AUTHOR} to a true value to run.'; plan( skip_all => $msg ); } eval { require Test::CheckChanges; }; if ( $@ ) { my $msg = 'Test::CheckChanges required to check Changes'; plan( skip_all => $msg ); } Test::CheckChanges::ok_changes(); Test-CGI-Multipart-v0.0.3/t/11.reset.t000444001750001750 450011443457767 20131 0ustar00nicholasnicholas000000000000#!perl -w use strict; use warnings; use Test::More; use Test::CGI::Multipart; use Readonly; use lib qw(t/lib); use Utils; Readonly my $PETS => ['Rex','Oscar','Bidgie','Fish']; my @cgi_modules = Utils::get_cgi_modules; plan tests => 8+6*scalar(@cgi_modules); { my $tcm = Test::CGI::Multipart->new; isa_ok($tcm, 'Test::CGI::Multipart'); ok(!defined $tcm->set_param( name=>'first_name', value=>'Jim'), 'setting parameter'); my @values = $tcm->get_param(name=>'first_name'); is_deeply(\@values, ['Jim'], 'get param'); my @names= $tcm->get_names; is_deeply(\@names, ['first_name'], 'first name deep'); foreach my $class (@cgi_modules) { if ($class) { diag "Testing with $class"; } my $cgi = undef; if ($class) { $cgi = $tcm->create_cgi(cgi=>$class); } else { $cgi = $tcm->create_cgi; } isa_ok($cgi, $class||'CGI', 'created CGI object okay'); @names = grep {$_ ne '' and $_ ne '.submit'} sort $cgi->param; is_deeply(\@names, ['first_name'], 'names deep'); foreach my $name (@names) { my @got = $cgi->param($name); my @expected = $tcm->get_param(name=>$name); is_deeply(\@got, \@expected, $name); } } } { my $tcm = Test::CGI::Multipart->new; isa_ok($tcm, 'Test::CGI::Multipart'); ok(!defined $tcm->set_param( name=>'pets', value=>$PETS), 'setting parameter'); my @values = $tcm->get_param(name=>'pets'); is_deeply(\@values, $PETS, 'get param'); my @names= sort $tcm->get_names; is_deeply(\@names, ['pets'], 'names deep'); foreach my $class (@cgi_modules) { if ($class) { diag "Testing with $class"; } my $cgi = undef; if ($class) { $cgi = $tcm->create_cgi(cgi=>$class); } else { $cgi = $tcm->create_cgi; } isa_ok($cgi, $class||'CGI', 'created CGI object okay'); @names = grep {$_ ne '' and $_ ne '.submit'} sort $cgi->param; is_deeply(\@names, ['pets'], 'names deep'); foreach my $name (@names) { my @got = $cgi->param($name); my @expected = $tcm->get_param(name=>$name); is_deeply(\@got, \@expected, $name); } } } Test-CGI-Multipart-v0.0.3/t/05.callbacks.t000444001750001750 444711443457767 20743 0ustar00nicholasnicholas000000000000#!perl -w use strict; use warnings; use Test::More; use Test::CGI::Multipart; use Readonly; use lib qw(t/lib); use Utils; use FilePop; use AddParam; use AddValue; Readonly my $PETS => ['Rex','Oscar','Bidgie','Fish']; my @cgi_modules = Utils::get_cgi_modules; plan tests => 13+6*@cgi_modules; my $tcm = Test::CGI::Multipart->new; isa_ok($tcm, 'Test::CGI::Multipart'); ok(!defined $tcm->set_param( name=>'first_name', value=>'Jim'), 'setting parameter'); my @values = $tcm->get_param(name=>'first_name'); is_deeply(\@values, ['Jim'], 'get param'); my @names= $tcm->get_names; is_deeply(\@names, ['first_name'], 'first name deep'); ok(!defined $tcm->set_param( name=>'pets', value=>$PETS), 'setting parameter'); @values = $tcm->get_param(name=>'pets'); is_deeply(\@values, $PETS, 'get param'); @names= sort $tcm->get_names; is_deeply(\@names, ['first_name','pets'], 'names deep'); ok(!defined $tcm->upload_file(), 'uploading blah file'); @names= sort $tcm->get_names; is_deeply(\@names, ['files', 'first_name', 'pets'], 'names deep'); ok(!defined $tcm->upload_file(), 'uploading blah file'); @names= sort $tcm->get_names; is_deeply(\@names, ['files', 'first_name', 'pets'], 'names deep'); ok(!defined $tcm->upload_file(), 'uploading blah file'); @names= sort $tcm->get_names; is_deeply(\@names, ['files', 'files2', 'first_name', 'pets'], 'names deep'); foreach my $class (@cgi_modules) { SKIP: { if (defined $class and $class eq 'CGI::Simple') { skip 'CGI::Simple apparently does not support multiple files', 6; } if ($class) { diag "Testing with $class"; } my $cgi = undef; if ($class) { $cgi = $tcm->create_cgi(cgi=>$class); } else { $cgi = $tcm->create_cgi; } isa_ok($cgi, $class||'CGI', 'created CGI object okay'); @names = grep {$_ ne '' and $_ ne '.submit'} sort $cgi->param; is_deeply(\@names, ['files', 'files2', 'first_name','pets'], 'names deep'); foreach my $name (@names) { my $expected = Utils::get_expected($tcm, $name); my $got = undef; if (ref $expected->[0] eq 'HASH') { $got = Utils::get_actual_upload($cgi, $name); } else { my @got = $cgi->param($name); $got = \@got; } is_deeply($got, $expected, $name); } } } Test-CGI-Multipart-v0.0.3/t/lib000755001750001750 011443457767 17014 5ustar00nicholasnicholas000000000000Test-CGI-Multipart-v0.0.3/t/lib/AddParam.pm000444001750001750 55711443457767 21147 0ustar00nicholasnicholas000000000000package AddParam; use Test::CGI::Multipart; use Readonly; Readonly my %PARAM_LOOKUP => ( 'doo_doo.blah' => 'files', 'nah_nah.blah' => 'files', 'noo_noo.blah' => 'files2', ); Test::CGI::Multipart->register_callback( callback => sub { my $hash = shift; $hash->{name} = $PARAM_LOOKUP{$hash->{file}}; return $hash; } ); 1 Test-CGI-Multipart-v0.0.3/t/lib/AddValue.pm000444001750001750 63111443457767 21154 0ustar00nicholasnicholas000000000000package AddValue; use Test::CGI::Multipart; use Readonly; Readonly my %VALUE_LOOKUP => ( 'doo_doo.blah' => 'Blah, Blah, Blah,....', 'nah_nah.blah' => 'Nah, Nah, Nah,....', 'noo_noo.blah' => 'Noo, Noo, Noo,....', ); Test::CGI::Multipart->register_callback( callback => sub { my $hash = shift; $hash->{value} = $VALUE_LOOKUP{$hash->{file}}; return $hash; } ); 1 Test-CGI-Multipart-v0.0.3/t/lib/FilePop.pm000444001750001750 53311443457767 21026 0ustar00nicholasnicholas000000000000package FilePop; use Test::CGI::Multipart; use Readonly; my $fileindex = 0; Readonly my @FILE_STASH => ( 'doo_doo.blah', 'nah_nah.blah', 'noo_noo.blah', ); Test::CGI::Multipart->register_callback( callback => sub { my $hash = shift; $hash->{file} = $FILE_STASH[$fileindex++]; return $hash; } ); 1 Test-CGI-Multipart-v0.0.3/t/lib/Utils.pm000444001750001750 563511443457767 20620 0ustar00nicholasnicholas000000000000package Utils; use Readonly; use Carp; use Perl6::Slurp; Readonly @CLASSES => ( 'CGI::Minimal', 'CGI::Simple', ); # TODO: # Can we work with CGI::Lite::Request, Apache::Request? sub get_cgi_modules { my @cgi_modules = (undef, 'CGI'); foreach $class (@CLASSES) { eval "require $class"; if (!$@) { push @cgi_modules, $class; } } return @cgi_modules; } sub get_expected { my $tcm = shift; my $name = shift; my @expected = $tcm->get_param(name=>$name); if (scalar(@expected) == 0) { croak 'where is the test data?'; } my $is_file_upload = (ref $expected[0] eq 'HASH'); if ($is_file_upload) { foreach my $e (@expected) { if (!exists $e->{type}) { $e->{type} = 'text/plain'; } #if ($e->{type} eq 'text/plain') { # $e->{value} = norm_eol($e->{value}); #} } } return \@expected; } sub get_actual_upload { my $cgi = shift; my $name = shift; my @got; my $class = ref $cgi; if ($class eq 'CGI::Minimal') { my @fnames = $cgi->param_filename($name); my @data = $cgi->param($name); my @types = $cgi->param_mime($name); foreach my $i (@0..$#fnames) { push @got, { file=>$fnames[$i], value=>$data[$i], type=>$types[$i], name=>$name } } } elsif ($class eq 'CGI::Simple') { my @fh = $cgi->upload($name); foreach my $fh (@fh) { if ($fh) { my $data = slurp($fh); $fh->close; my $file = $cgi->param($name); my $type = $cgi->upload_info($file, 'mime'); push @got, { file=>$file, value=>$data, type=>$type, name=>$name }; } else { return undef; } } } else { my @fh = $cgi->upload($name); foreach my $fh (@fh) { if ($fh) { my $io = $fh->handle; my $data = slurp($io); $io->close; my $file = scalar $fh; #my $file = $cgi->param($name); my $type = $cgi->uploadInfo($file)->{'Content-Type'}; push @got, { file=>$file, value=>$data, type=>$type, name=>$name }; } else { return undef; } } } # @got = sort { cmp_file($a,$b) } @got; return \@got; } sub cmp_file { my ($x, $y) = @_; return $x->{file} cmp $y->{file}; }; sub norm_eol { my $text = shift; $text =~ s{\s*$}{\n}xmsg; $text =~ s{\s*\z}{}xms; return $text; } 1 Test-CGI-Multipart-v0.0.3/lib000755001750001750 011443457767 16551 5ustar00nicholasnicholas000000000000Test-CGI-Multipart-v0.0.3/lib/Test000755001750001750 011443457767 17470 5ustar00nicholasnicholas000000000000Test-CGI-Multipart-v0.0.3/lib/Test/CGI000755001750001750 011443457767 20072 5ustar00nicholasnicholas000000000000Test-CGI-Multipart-v0.0.3/lib/Test/CGI/Multipart.pm000444001750001750 3701711443457767 22576 0ustar00nicholasnicholas000000000000package Test::CGI::Multipart; use warnings; use strict; use Carp; use UNIVERSAL::require; use Params::Validate qw(:all); use MIME::Entity; use Readonly; require 5.006_001; # we use 3-arg open in places use version; our $VERSION = qv('0.0.3'); # Module implementation here # Make callbacks a package variable as then loading callbacks # will be prettier. my @callbacks; # Parameter specs # Note the purpose of these spcs is to protect our data structures. # It should not protect the code that will be tested # as that must look after itself. Readonly my $NAME_SPEC => {type=>SCALAR}; Readonly my $VALUE_SPEC => {type=>SCALAR|ARRAYREF}; Readonly my $UA_SPEC => {type=>SCALAR, default=> 'Test::CGI::Multipart'}; Readonly my $CGI_SPEC => { type=>SCALAR, default=>'CGI', regex=> qr{ \A # start of string (?: \w |(?:\:\:) # Module name separator )+ \z # end of string }xms }; Readonly my $TYPE_SPEC => { type=>SCALAR, optional=>1, regex=> qr{ \A # start of string [\w\-]+ # major type \/ # MIME type separator [\w\-]+ # sub-type \z # end of string }xms }; Readonly my $FILE_SPEC => { type=>SCALAR, }; Readonly my $MIME_SPEC => { type=>OBJECT, isa=>'MIME::Entity', }; Readonly my $CODE_SPEC => { type=>CODEREF, }; # MIME parsing states Readonly my $TYPE_STATE => 0; Readonly my $HEADER_STATE => 1; Readonly my $DATA_STATE=> 2; Readonly my $EOL => "\015\012"; sub new { my $class = shift; my $self = { file_index=>0, params=>{}, }; bless $self, $class; return $self; } sub set_param { my $self = shift; my %params = validate(@_, {name=>$NAME_SPEC, value=>$VALUE_SPEC}); my @values = ref $params{value} eq 'ARRAY' ? @{$params{value}} : $params{value} ; $self->{params}->{$params{name}} = \@values; return; } sub upload_file { my $self = shift; my %params = @_; my $params = \%params; foreach my $code (@callbacks) { $params = &$code($params); } $self->_upload_file(%$params); return; } sub _upload_file { my $self = shift; my %params = validate(@_, { name=>$NAME_SPEC, value=>$VALUE_SPEC, file=>$FILE_SPEC, type=>$TYPE_SPEC }); my $name = $params{name}; if (!exists $self->{params}->{$name}) { $self->{params}->{$name} = {}; } if (ref $self->{params}->{$name} ne 'HASH') { croak "mismatch: is $name a file upload or not"; } my $file_index = $self->{file_index}; $self->{params}->{$name}->{$file_index} = \%params; $self->{file_index}++; return; } sub get_param { my $self = shift; my %params = validate(@_, {name=>$NAME_SPEC}); my $name = $params{name}; if (ref $self->{params}->{$name} eq 'HASH') { return values %{$self->{params}->{$name}}; } return @{$self->{params}->{$name}}; } sub get_names { my $self = shift; return keys %{$self->{params}}; } sub create_cgi { use autodie qw(open); my $self = shift; my %params = validate(@_, {cgi=>$CGI_SPEC, ua=>$UA_SPEC}); my $mime = $self->_mime_data; my $mime_str = $mime->stringify; my $mime_string = $self->_normalize1($mime_str); my $boundary = $mime->head->multipart_boundary; $ENV{REQUEST_METHOD}='POST'; $ENV{CONTENT_TYPE}="multipart/form-data; boundary=$boundary"; $ENV{CONTENT_LENGTH}=length($mime_string); $ENV{HTTP_USER_AGENT}=$params{ua}; # Would like to localize these but this causes problems with CGI::Simple. local *STDIN; open(STDIN, '<', \$mime_string); binmode STDIN; $params{cgi}->require; if ($params{cgi} eq 'CGI::Simple') { $CGI::Simple::DISABLE_UPLOADS = 0; } if ($params{cgi} eq 'CGI') { CGI::initialize_globals(); } if ($params{cgi} eq 'CGI::Minimal') { CGI::Minimal::reset_globals(); } my $cgi = $params{cgi}->new; return $cgi; } sub _normalize1 { my $self = shift; my $mime_string = shift; $mime_string =~ s{([\w-]+:\s+[^\n]+)\n\n}{$1$EOL$EOL}xmsg; $mime_string =~ s{\n([\w-]+:\s+)}{$EOL$1}xmsg; $mime_string =~ s{\n(-------)}{$EOL$1}xmsg; return $mime_string; } sub _mime_data { my $self = shift; my $mime = $self->_create_multipart; foreach my $name ($self->get_names) { my $value = $self->{params}->{$name}; if (ref($value) eq "ARRAY") { foreach my $v (@$value) { $self->_attach_field( mime=>$mime, name=>$name, value=>$v, ); } } elsif(ref($value) eq "HASH") { $self->_encode_upload(mime=>$mime,values=>$value); } else { croak "unexpected data structure"; } } # Required so at least we don't have an empty MIME structure. # And lynx at least does send it. # CGI.pm seems to strip it out where as the others seem to pass it on. $self->_attach_field( mime=>$mime, name=>'.submit', value=>'Submit', ); return $mime; } sub _attach_field { my $self = shift; my %params = validate(@_, { mime => $MIME_SPEC, name=>$NAME_SPEC, value=>$VALUE_SPEC, } ); $params{mime}->attach( 'Content-Disposition'=>"form-data; name=\"$params{name}\"", Data=>$params{value}, ); return; } sub _create_multipart { my $self = shift; my %params = validate(@_, {}); return MIME::Entity->build( 'Type'=>"multipart/form-data", ); } sub _encode_upload { my $self = shift; my %params = validate(@_, { mime => $MIME_SPEC, values => {type=>HASHREF} }); my %values = %{$params{values}}; foreach my $k (keys %values) { $self->_attach_file( mime=>$params{mime}, %{$values{$k}} ); } return; } sub _attach_file { my $self = shift; my %params = validate(@_, { mime => $MIME_SPEC, file=>$FILE_SPEC, type=>$TYPE_SPEC, name=>$NAME_SPEC, value=>$VALUE_SPEC, } ); my %attach = ( 'Content-Disposition'=> "form-data; name=\"$params{name}\"; filename=\"$params{file}\"", Data=>$params{value}, Encoding=>'binary', ); if ($params{type}) { $attach{Type} = $params{type}; } $params{mime}->attach( %attach ); return; } sub register_callback { my $self = shift; my %params = validate(@_, { callback => $CODE_SPEC, } ); push @callbacks, $params{callback}; return; } 1; # Magic true value required at end of module __END__ =head1 NAME Test::CGI::Multipart - Test posting of multi-part form data =head1 VERSION This document describes Test::CGI::Multipart version 0.0.3 =head1 SYNOPSIS use Test::CGI::Multipart; my $tcm = Test::CGI::Multipart; # specify the form parameters $tcm->set_param(name='email',value=>'jim@hacker.com'); $tcm->set_param(name=>'pets',value=> ['Rex', 'Oscar', 'Bidgie', 'Fish']); $tcm->set_param(name=>'first_name',value=>'Jim'); $tcm->set_param(name=>'last_name',value=>'Hacker'); $tcm->upload_file( name=>'file1', file=>'made_up_filename.txt', value=>$content ); $tcm->upload_file( name=>'file1', file=>'made_up_filename.blah', value=>$content_blah, type=>'application/blah' ); # Behind the scenes this will fake the browser and web server behaviour # with regard to environment variables, MIME format and standard input. my $cgi = $tcm->create_cgi; # Okay now we have a CGI object which we can pass into the code # that needs testing and run the form handling various tests. =head1 DESCRIPTION It is quite difficult to write test code to capture the behaviour of CGI or similar objects handling forms that include a file upload. Such code needs to harvest the parameters, build file content in MIME format, set the environment variables accordingly and pump it into the the standard input of the required CGI object. This module provides simple methods so that having prepared suitable content, the test script can simulate the submission of web forms including file uploads. However we also recognise that a test script is not always the best place to prepare content. Rather a test script would rather specify requirements for a file a upload: type, size, mismatches between the file name and its contents and so on. This module cannot hope to provide such open ended functionality but it can provide extension mechanisms. This module works with L (the default), L and L. In principle it ought to work with all equivalent modules however each module has a slightly different interface when it comes to file uploads and so requires slightly different test code. =head1 INTERFACE Several of the methods below take named parameters. For convenience we define those parameters here: =over =item C This option defines the CGI module. It should be a scalar consisting only of alphanumeric characters and C<::>. It defaults to 'CGI'. =item C This is the name of form parameter. It must be a scalar. =item C This is the value of the form parameter. It should either be a scalar or an array reference of scalars. =item C Where a form parameter represents a file, this is the name of that file. =item C The MIME type of the content. This defaults to 'text/plain'. =item C The HTTP_USER_AGENT environment variable. This defaults to 'Test::CGI::Multipart'. =back =head2 new An instance of this class might best be thought of as a "CGI object factory". The constructor takes no parameters. =head2 create_cgi This returns a CGI object created according to the specification encapsulated in the object. The exact mechanics are as follows: =over =item The parameters are packaged up in MIME format. =item The environment variables are set. =item A pipe is created. The far end of the pipe is attached to our standard input and the MIME content is pushed through the pipe. =item The appropriate CGI class is required. =item Uploads are enabled if the CGI class is L. =item Global variables are reset for L and L. =item The CGI object is created and returned. =back As far as I can see this simulates what happens when a CGI script processes a multi-part POST form. One can specify a different CGI class using the C named parameter. One can set the HTTP_USER_AGENT environment variable with the C parameter. =head2 set_param This can be used to set a single form parameter. It takes two named arguments C and C. Note that this method overrides any previous settings including file uploads. =head2 get_param This retrieves a single form parameter. It takes a single named parameter: C. The data returned will be a list either of scalar values or (in the case of a file upload) of HASHREFs. The HASHREFs would have the following fields: C, C and C representing the parameter name, the file name, the content and the MIME type respectively. =head2 get_names This returns a list of stashed parameter names. =head2 upload_file In the absence of any defined callbacks, this method takes three mandatory named parameters: C, C and C and one optional parameter C. If there are any callbacks then the parameters are passed through each of the callbacks and must meet the standard parameter requirements by the time all the callbacks have been called. Unlike the C method this will not override previous settings for this parameter but will add. However setting a normal parameter and then an upload on the same name will throw an error. =head2 register_callback Callbacks are used by the C method, to allow a file to be specified by properties rather than strict content. This method takes a single named parameter called C, which adds that callback to an internal array of callbacks. The idea being that the C method can take any arguments you like so long as after all the callbacks have been applied, the parameters consist of C, C, C and possibly C. A callback should take and return a single hash reference. =head1 DIAGNOSTICS =over =item C<< unexpected data structure >> During the construction of the MIME data, the internal data structure turned out to have unexpected features. Since we control that data structure that should not happen. =item C<< mismatch: is %s a file upload or not >> The parameter was being used for both for file upload and normal parameters. =back =head1 CONFIGURATION AND ENVIRONMENT Test::CGI::Multipart requires no configuration files or environment variables. However it should be noted that the module will overwrite the following environment variables: =over =item REQUEST_METHOD =item CONTENT_LENGTH =item CONTENT_TYPE =item HTTP_USER_AGENT =back =head1 INCOMPATIBILITIES I would like to get this working with L and L if that makes sense. So far I have not managed that. =head1 BUGS AND LIMITATIONS No bugs have been reported. Please report any bugs or feature requests to C, or through the web interface at L. This module depends upon L. Unfortunately that module does not handle newlines quite correctly. That seems to work fine for email but does not work with L. I have looked at L and L but L combined with a hack seems the best that can be done at the moment. Sooner or later someone is going to hit the limitations of that hack. =head1 AUTHOR Nicholas Bamber C<< >> =head1 LICENCE AND COPYRIGHT Copyright (c) 2010, Nicholas Bamber C<< >>. All rights reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See L. =head1 DISCLAIMER OF WARRANTY BECAUSE THIS SOFTWARE IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE SOFTWARE, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE SOFTWARE "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE SOFTWARE IS WITH YOU. SHOULD THE SOFTWARE PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR, OR CORRECTION. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE SOFTWARE AS PERMITTED BY THE ABOVE LICENCE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE SOFTWARE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE SOFTWARE TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. Test-CGI-Multipart-v0.0.3/lib/Test/CGI/Multipart000755001750001750 011443457767 22053 5ustar00nicholasnicholas000000000000Test-CGI-Multipart-v0.0.3/lib/Test/CGI/Multipart/Gen000755001750001750 011443457767 22564 5ustar00nicholasnicholas000000000000Test-CGI-Multipart-v0.0.3/lib/Test/CGI/Multipart/Gen/Text.pm000444001750001750 1126211443457767 24225 0ustar00nicholasnicholas000000000000package Test::CGI::Multipart::Gen::Text; use warnings; use strict; use Carp; use Readonly; use Test::CGI::Multipart; use Text::Lorem; use Scalar::Util qw(looks_like_number); use version; our $VERSION = qv('0.0.3'); # Module implementation here Test::CGI::Multipart->register_callback(callback => \&_random_text_cb); sub _random_text_cb { my $href = shift; # If the MIME type is not explicitly text/plain its not ours. return $href if !exists $href->{type}; return $href if $href->{type} ne 'text/plain'; return $href if exists $href->{value}; my $lorem = Text::Lorem->new; my $arg = sub { my $arg = shift; return exists $href->{$arg} && looks_like_number($href->{$arg}); }; $href->{value} = &$arg('words') ? $lorem->words($href->{words}) : &$arg('sentences') ? $lorem->sentences($href->{sentences}) : &$arg('paragraphs') ? $lorem->paragraphs($href->{paragraphs}) : croak 'No words, sentences or paragraphs specified'; delete $href->{words}; delete $href->{sentences}; delete $href->{paragraphs}; return $href; } 1; # Magic true value required at end of module __END__ =head1 NAME Test::CGI::Multipart::Gen::Text - Generate text test data for multipart forms =head1 VERSION This document describes Test::CGI::Multipart::Gen::Text version 0.0.3 =head1 SYNOPSIS use Test::CGI::Multipart; use Test::CGI::Multipart::Gen::Text; my $tcm = Test::CGI::Multipart; # specify the form parameters $tcm->upload_file( name='cv', file=>'cv.doc', paragraphs=>6, type=>'text/plain' ); $tcm->set_param(name=>'first_name',value=>'Jim'); $tcm->set_param(name=>'last_name',value=>'Hacker'); # Behind the scenes this will fake the browser and web server behaviour # with regard to environment variables, MIME format and standard input. my $cgi = $tcm->create_cgi; # Okay now we have a CGI object which we can pass into the code # that needs testing and run the form handling various tests. =head1 DESCRIPTION This is a callback package for L that facilitates the testing of the upload of text files of a given size and sample content. It generates random text using L. =head1 INTERFACE For information on how to use this module, see L, in particular the section on callbacks. The effect of loading this module is that the C parameter ceases to be mandatory. Instead one can use one of C, C, C which are simply passed to L. Of these the highest priority is C, then C. =head1 DIAGNOSTICS =over =item C<< No words, sentences or paragraphs specified >> This module does require that at least one of the three L parameters is provided. =back =head1 CONFIGURATION AND ENVIRONMENT Test::CGI::Multipart::Gen::Text requires no configuration files or environment variables. =head1 BUGS AND LIMITATIONS No bugs have been reported. Please report any bugs or feature requests to C, or through the web interface at L. =head1 AUTHOR Nicholas Bamber C<< >> =head1 LICENCE AND COPYRIGHT Copyright (c) 2010, Nicholas Bamber C<< >>. All rights reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See L. =head1 DISCLAIMER OF WARRANTY BECAUSE THIS SOFTWARE IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE SOFTWARE, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE SOFTWARE "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE SOFTWARE IS WITH YOU. SHOULD THE SOFTWARE PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR, OR CORRECTION. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE SOFTWARE AS PERMITTED BY THE ABOVE LICENCE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE SOFTWARE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE SOFTWARE TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. Test-CGI-Multipart-v0.0.3/lib/Test/CGI/Multipart/Gen/Image.pm000444001750001750 1473111443457767 24327 0ustar00nicholasnicholas000000000000package Test::CGI::Multipart::Gen::Image; use warnings; use strict; use Carp; use Readonly; use Test::CGI::Multipart; use GD::Simple; use version; our $VERSION = qv('0.0.3'); # Module implementation here Test::CGI::Multipart->register_callback( callback => sub { my $hashref = shift; my %to_delete; return $hashref if exists $hashref->{value}; # If the MIME type is not explicitly image/* its not ours. return $hashref if not exists $hashref->{type}; return $hashref if $hashref->{type} !~ m{\Aimage/(\w+)\z}xms; my $type = $1; # get dimensions croak "no width specified" if not exists $hashref->{width}; my $width = $hashref->{width}; $to_delete{width} = 1; croak "no height specified" if not exists $hashref->{height}; my $height = $hashref->{height}; $to_delete{height} = 1; my $image = GD::Simple->new($width, $height); croak "no instructions specified" if not exists $hashref->{instructions}; croak "intructions not a list" if ref $hashref->{instructions} ne 'ARRAY'; my @instructions = @{$hashref->{instructions}}; $to_delete{instructions} = 1; foreach my $instr (@instructions) { my ($cmd, @args) = @$instr; eval {$image->$cmd(@args)}; if ($@) { warn "GD: $@"; return $hashref; } } $hashref->{value} = eval {$image->$type}; if ($@) { warn "GD: $@"; delete $hashref->{value}; return $hashref; } foreach my $del (keys %to_delete) { delete $hashref->{$del}; } return $hashref; } ); 1; # Magic true value required at end of module __END__ =head1 NAME Test::CGI::Multipart::Gen::Image - Generate image test data for multipart forms =head1 VERSION This document describes Test::CGI::Multipart::Gen::Image version 0.0.3 =head1 SYNOPSIS use Test::CGI::Multipart; use Test::CGI::Multipart::Gen::Image; my $tcm = Test::CGI::Multipart; # specify the form parameters $tcm->upload_file( name='Image', file=>'cleopatra.doc', width=>400, height=>250, instructions=>[ ['bgcolor,'red'], ['fgcolor','blue'], ['rectangle',30,30,100,100], ['moveTo',280,210], ['font','Times:italic'], ['fontsize',20], ['angle',-90], ['string','Helloooooooooooo world!'], ], type=>'image/jpeg' ); $tcm->set_param(name=>'first_name',value=>'Jim'); $tcm->set_param(name=>'last_name',value=>'Hacker'); # Behind the scenes this will fake the browser and web server behaviour # with regard to environment variables, MIME format and standard input. my $cgi = $tcm->create_cgi; # Okay now we have a CGI object which we can pass into the code # that needs testing and run the form handling various tests. =head1 DESCRIPTION This is a callback package for L that facilitates the testing of the upload of text files of a given size and sample content. One can specify the dimensions of the image and the size, font and colours of a simple string. =head1 INTERFACE For information on how to use this module, see L especially the section on callbacks. What this module offers is that if the C parameter begins with 'image/' and there is no C parameter you can specify various human comprehensible inputs into the image rather than the raw binary. In particular this covers what appears to be common use cases in testing image upload: namely images of various types, file sizes and dimensions. =over =item C The MIME type of the content. For this module to be interested this parameter must be set, and must begin with 'image/'. What follows is taken to be the image format and is treated as a function to the L module. =item C, C These are the requested dimensions of the proposed image. They are mandatory parameters. =item C, C, C, C, C These parameters are passed straight through to the L module. =back =head1 DIAGNOSTICS =over =item C<< unexpected data structure >> During the construction of the MIME data, the internal data structure turned out to have unexpected features. Since we control that data structure that should not happen. =item C<< mismatch: is %s a file upload or not >> The parameter was being used for both for file upload and normal parameters. =back =head1 CONFIGURATION AND ENVIRONMENT Test::CGI::Multipart::Gen::Image requires no configuration files or environment variables. =head1 BUGS AND LIMITATIONS No bugs have been reported. Please report any bugs or feature requests to C, or through the web interface at L. =head1 AUTHOR Nicholas Bamber C<< >> =head1 LICENCE AND COPYRIGHT Copyright (c) 2010, Nicholas Bamber C<< >>. All rights reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See L. =head1 DISCLAIMER OF WARRANTY BECAUSE THIS SOFTWARE IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE SOFTWARE, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE SOFTWARE "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE SOFTWARE IS WITH YOU. SHOULD THE SOFTWARE PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR, OR CORRECTION. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE SOFTWARE AS PERMITTED BY THE ABOVE LICENCE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE SOFTWARE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE SOFTWARE TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES.