CGI-Application-Plugin-AJAXUpload-v0.0.3000755001750001750 011455551355 20461 5ustar00nicholasnicholas000000000000CGI-Application-Plugin-AJAXUpload-v0.0.3/META.yml000444001750001750 222111455551355 22064 0ustar00nicholasnicholas000000000000--- abstract: 'Run mode to handle a file upload and return a JSON response' author: - 'Nicholas Bamber ' build_requires: CGI::Application::Plugin::JSON: 0 File::Temp: 0 Test::CGI::Multipart: 0 Test::Image::GD: 0 Test::More: 0.94 Test::NoWarnings: 0 Test::Warn: 0 configure_requires: Module::Build: 0.36 generated_by: 'Module::Build version 0.3607' keywords: - CGI::Application - 'File upload' - 'Image resizing' - HTML - 'YUI rich text editor' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: CGI-Application-Plugin-AJAXUpload provides: CGI::Application::Plugin::AJAXUpload: file: lib/CGI/Application/Plugin/AJAXUpload.pm version: v0.0.3 Data::FormValidator::Filters::ImgData: file: lib/Data/FormValidator/Filters/ImgData.pm version: v0.0.3 requires: CGI: 3.41 CGI::Application: 0 Data::FormValidator: 0 Exporter: 0 GD: 0 Perl6::Slurp: 0 Readonly: 0 autodie: 0 version: 0 resources: license: http://dev.perl.org/licenses/ repository: http://github.com/periapt/CGI-Application-Plugin-AJAXUpload/tree version: v0.0.3 CGI-Application-Plugin-AJAXUpload-v0.0.3/Makefile.PL000444001750001750 224211455551355 22570 0ustar00nicholasnicholas000000000000# Note: this file was auto-generated by Module::Build::Compat version 0.3607 use ExtUtils::MakeMaker; WriteMakefile ( 'NAME' => 'CGI::Application::Plugin::AJAXUpload', 'VERSION_FROM' => 'lib/CGI/Application/Plugin/AJAXUpload.pm', 'PREREQ_PM' => { 'CGI' => '3.41', 'CGI::Application' => 0, 'CGI::Application::Plugin::JSON' => 0, 'Data::FormValidator' => 0, 'Exporter' => 0, 'File::Temp' => 0, 'GD' => 0, 'Perl6::Slurp' => 0, 'Readonly' => 0, 'Test::CGI::Multipart' => 0, 'Test::Image::GD' => 0, 'Test::More' => '0.94', 'Test::NoWarnings' => 0, 'Test::Warn' => 0, 'autodie' => 0, 'version' => 0 }, 'INSTALLDIRS' => 'site', 'EXE_FILES' => [], 'PL_FILES' => {} ) ; CGI-Application-Plugin-AJAXUpload-v0.0.3/README000444001750001750 1712011455551355 21517 0ustar00nicholasnicholas000000000000NAME CGI::Application::Plugin::AJAXUpload - Run mode to handle a file upload and return a JSON response VERSION This document describes CGI::Application::Plugin::AJAXUpload version 0.0.3 SYNOPSIS use MyWebApp; use CGI::Application::Plugin::JSON qw(to_json); use CGI::Application::Plugin::AJAXUpload; sub setup { my $c = shift; $c->ajax_upload_httpdocs('/var/www/vhosts/mywebapp/httpdocs'); $c->ajax_upload_setup( run_mode=>'file_upload', upload_subdir=>'/img/uploads', ); return; } DESCRIPTION This module provides a customisable run mode that handles a file upload and responds with a JSON message like the following: {status: 'UPLOADED', image_url: '/img/uploads/666.png'} or on failure {status: 'The image was too big.'} This is specifically intended to provide a CGI::Application based back end for 's to the . However as far as I can see it could be used as a back end for any CGI::Application website that uploads files behind the scenes using AJAX. In any case this module does NOT provide any of that client side code and you must also map the run mode onto the URL used by client-side code. That said a working example is provided which could form the basis of a rich text editor. INTERFACE ajax_upload_httpdocs The module needs to know the document root because it will need to to copy the file to a sub-directory of the document root, and it will need to pass that sub-directory back to the client as part of the URL. If passed a value it will store that as the document root. If not passed a value it will return the document root. ajax_upload_setup This method sets up a run mode to handle a file upload and return a JSON message providing status. It takes a number of named parameters: upload_subdir This is the sub-directory of *httpdocs_dir* where the files will actually be written to. It must be writeable. It defaults to '/img/uploads'. dfv_profile This is a Data::FormValidator profile. The hash array that is validated consists of the fields described below. A very basic profile is provided by default. *value* This is contains the actual data contained in the upload. It will be untainted. One can of course apply filters that resize the image (assuming it is an image) or scrub the HTML (if that is appropriate). *file_name* This is the filename given by the browser. By default it will be required to be no more than 30 alphanumeric, hyphen or full stop, underscore characters; it will be untainted and passed through unmodified. One could however specify a filter that completely ignores the filename, generates a safe one and does other housekeeping. *mime_type* This is the file extension passed by the browser. *data_size* By default this is required to be less than 512K. Note that this module's handling of file upload and data validation is somewhat different from that expected by Data::FormValidator::Constraints::Upload and Data::FormValidator::Filters::Image. Those modules work with file handles. The Data::FormValidator profiles required by this module are expected to work with the data and meta data. run_mode This is the name of the run mode that will handle this upload. It defaults to *ajax_upload_rm*. ajax_upload_default_profile This returns a hash reference to the default Data::FormValidator profile. It can be called as a class method. _ajax_upload_rm This private method forms the implementation of the run mode. It requires a *file* CGI query parameter that provides the file data. Optionally it also takes a *validate* parameter that will make other more paranoid checks. These checks are only optional because if the system is set up correctly they should never fail. It takes the following actions: -- It will get the filename and data associated with the upload and pass the data through the Data::FormValidator if a profile is supplied. -- If it fails the Data::FormValidator test a failed message will be passed back to the caller. -- If the *validate* parameter is set the setup will check. If there is a problem a status message will be passed back to the user. -- The data will then be copied to the given file, its path being the combination of the *httpdocs_dir* parameter, the *upload_subdir* and the generated file name. - The successful JSON message will be passed back to the client. DIAGNOSTICS Most error messages will be passed back to the client as a JSON message, though in a sanitised form. One error 'Internal Error' is fairly generic and so the underlying error message is written to standard error. CONFIGURATION AND ENVIRONMENT CGI::Application::Plugin::AJAXUpload requires no configuration files or environment variables. However the client side code, the URL to run mode dispatching and the general web server setup is not supplied. DEPENDENCIES This is using the "to_json" method from CGI::Application::Plugin::JSON. As such that module needs to be exported before this module. Or of course you could just define your own. BUGS AND LIMITATIONS Please report any bugs or feature requests to "bug-cgi-application-plugin-ajaxupload@rt.cpan.org", or through the web interface at . One really odd thing is that the content header of the AJAX reply cannot be 'application/json' as one would expect. This module sets it to 'text/javascript' which works. There is a very short discussion on the . 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. The javascript code in the example draws heavily on the code provided by AllMyBrain.com. 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. CGI-Application-Plugin-AJAXUpload-v0.0.3/MANIFEST000444001750001750 73611455551355 21735 0ustar00nicholasnicholas000000000000Build.PL Changes example/httpdocs/css/editor.css example/httpdocs/js/editor.js example/template.cgi example/templates/one.tmpl example/templates/two.tmpl ignore.txt lib/CGI/Application/Plugin/AJAXUpload.pm lib/Data/FormValidator/Filters/ImgData.pm Makefile.PL MANIFEST META.yml README t/00.load.t t/01.basic.t t/02.warnings.t t/03.images.t t/04-resize.t t/changes.t t/lib/TestWebApp.pm t/manifest.t t/perlcritic.t t/pod-coverage.t t/pod-no404s.t t/pod.t t/podspell.t t/prereq.t CGI-Application-Plugin-AJAXUpload-v0.0.3/ignore.txt000444001750001750 21711455551355 22622 0ustar00nicholasnicholas000000000000blib* Makefile Makefile.old Build Build.bat _build* pm_to_blib* *.tar.gz .lwpcookies cover_db pod2htm*.tmp CGI-Application-Plugin-AJAXUpload-* CGI-Application-Plugin-AJAXUpload-v0.0.3/Build.PL000444001750001750 242311455551355 22113 0ustar00nicholasnicholas000000000000use strict; use warnings; use Module::Build; my $builder = Module::Build->new( module_name => 'CGI::Application::Plugin::AJAXUpload', license => 'perl', dist_author => 'Nicholas Bamber ', dist_version_from => 'lib/CGI/Application/Plugin/AJAXUpload.pm', build_requires => { 'Test::More' => '0.94', 'File::Temp' => 0, 'Test::NoWarnings' => 0, 'Test::Warn'=>0, 'Test::Image::GD'=>0, 'CGI::Application::Plugin::JSON'=>0, 'Test::CGI::Multipart'=>0, }, requires => { 'version' => 0, 'Exporter' => 0, 'CGI' => '3.41', 'CGI::Application' => 0, 'Perl6::Slurp'=>0, 'Readonly'=>0, 'Data::FormValidator'=>0, 'GD'=>0, 'autodie'=>0, }, meta_merge => { resources => { repository => 'http://github.com/periapt/CGI-Application-Plugin-AJAXUpload/tree', }, keywords => [ 'CGI::Application', 'File upload', 'Image resizing', 'HTML', 'YUI rich text editor' ], }, create_makefile_pl => 'traditional', create_readme=>1, add_to_cleanup => [ 'CGI-Application-Plugin-AJAXUpload-*' ], ); $builder->create_build_script(); CGI-Application-Plugin-AJAXUpload-v0.0.3/Changes000444001750001750 44411455551355 22073 0ustar00nicholasnicholas000000000000Revision history for CGI-Application-Plugin-AJAXUpload v0.0.3 15th October 2010 Added missing dependency on Test::CGI::Multipart. v0.0.2 13th October 2010 Removed file size test in image resizing as it was failing v0.0.1 Wed Sep 15 13:48:34 2010 Initial release. CGI-Application-Plugin-AJAXUpload-v0.0.3/example000755001750001750 011455551355 22114 5ustar00nicholasnicholas000000000000CGI-Application-Plugin-AJAXUpload-v0.0.3/example/template.cgi000555001750001750 1134411455551355 24576 0ustar00nicholasnicholas000000000000#!/usr/bin/perl # # Sample application # # To get this working you need to copy the relevant files to their correct places. # This file (template.cgi) to the cgi-bin directory. # The templates directory to your preferred template location and change $TEMPLATE_DIR accordingly. # The httpdocs directory contents will need to be copied and the value in # ajax_upload_httpdocs updated accordingly. # The directory corresponding to he /img/uploads needs to be writeable. # You can of course change that location. # You will of course need to install vaious modules - not all of which # are dependencies of the module. # You will also require internet access as the web page loads a lot of YUI code. # use strict; use warnings; use Readonly; # This bit needs to be modified for the local system. Readonly my $TEMPLATE_DIR => '/home/nicholas/git/CGI-Application-Plugin-AJAXUpload/example/templates'; Readonly my $IMAGE_WIDTH => 350; Readonly my $IMAGE_HEIGHT => 248; Readonly my $HTML_CHAR_FRAG => qr{ [\w\s\.,'!/\)\(;%] }xms; Readonly my $HTML_ENTITY_FRAG => qr{ &\w+; }xms; Readonly my $HTML_STRICT_REGEXP => qr{ \A # Start of string (?!\s) # No initial space (?: $HTML_CHAR_FRAG |$HTML_ENTITY_FRAG ){1,255} # Words, spaces and limited punctuation (? qr{ \A # Start of string (?: [\&\;\=\<\>\"\]\[] |$HTML_CHAR_FRAG |$HTML_ENTITY_FRAG )+ \z # end string }xms; { package SampleEditor; use base ("CGI::Application::Plugin::HTDot", "CGI::Application"); use CGI::Application::Plugin::AutoRunmode; use CGI::Application::Plugin::JSON qw(json_body to_json); use CGI::Application::Plugin::AJAXUpload; use CGI::Application::Plugin::ValidateRM; use Data::FormValidator::Filters::ImgData; use CGI::Carp qw(fatalsToBrowser); sub setup { my $self = shift; $self->start_mode('one'); $self->ajax_upload_httpdocs('/var/www/vhosts/editor/httpdocs'); my $profile = $self->ajax_upload_default_profile; $profile->{field_filters}->{value} = filter_resize($IMAGE_WIDTH,$IMAGE_HEIGHT); $self->ajax_upload_setup(dfv_profile=>$profile); } sub one : Runmode { my $self = shift; my $tmpl_obj = $self->load_tmpl('one.tmpl'); return $tmpl_obj->output; } sub two : Runmode { my $c = shift; # I am using HTML::Acid here because that was written exactly for # this setup. However of course you can use whatever HTML cleansing # you like. use Data::FormValidator::Filters::HTML::Acid; my $form_profile = { required=>[qw(title body)], untaint_all_constraints => 1, missing_optional_valid => 1, debug=>1, filters=>['trim'], field_filters=>{ body=>[filter_html( img_height_default=>$IMAGE_HEIGHT, img_width_default=>$IMAGE_WIDTH, tag_hierarchy => { h3 => '', p => '', a => 'p', img => 'p', em => 'p', strong => 'p', ul => 'p', li => 'ul', }, )], }, constraint_methods => { title=>$HTML_STRICT_REGEXP, body=>$HTML_BODY_REGEXP, }, msgs => { any_errors => 'err__', prefix => 'err_', invalid => 'Invalid', missing => 'Missing', format => '%s', }, }; my ($results, $err_page) = $c->check_rm( sub { my $self = shift; my $err = shift; my $template = $self->load_tmpl('one.tmpl'); $template->param(%$err) if $err; return $template->output; }, $form_profile ); return $err_page if $err_page; my $valid = $results->valid; my $template = $c->load_tmpl('two.tmpl'); $template->param(article=>$valid); return $template->output; } } SampleEditor->new(TMPL_PATH=>$TEMPLATE_DIR)->run; CGI-Application-Plugin-AJAXUpload-v0.0.3/example/httpdocs000755001750001750 011455551355 23744 5ustar00nicholasnicholas000000000000CGI-Application-Plugin-AJAXUpload-v0.0.3/example/httpdocs/css000755001750001750 011455551355 24534 5ustar00nicholasnicholas000000000000CGI-Application-Plugin-AJAXUpload-v0.0.3/example/httpdocs/css/editor.css000444001750001750 151211455551355 26670 0ustar00nicholasnicholas000000000000/* general */ .hide, .yui-skin-sam .yui-editor-panel label.hide { display: none; } .form_control .dfv-errors { color: red; font-weight: bold; display: inline; vertical-align: top; } form { border: thin solid black; margin: 2em; } fieldset { display: table; } legend, h2 { width: 100%; font-weight: bold; text-align: center; } .form_control { width: 100%; display: table-row; } .form_control .label { width: 30%; display: table-cell; vertical-align: top; padding-left: 5em; } .form_control input, .form_control textarea { width: 70%; display: table-cell; } input.form_control[type="submit"] { width: 200px; margin: 1em; } .yui-toolbar-group-border, .yui-toolbar-group-padding, .yui-toolbar-group-height-width, .yui-toolbar-group-textflow { display: none; } CGI-Application-Plugin-AJAXUpload-v0.0.3/example/httpdocs/js000755001750001750 011455551355 24360 5ustar00nicholasnicholas000000000000CGI-Application-Plugin-AJAXUpload-v0.0.3/example/httpdocs/js/editor.js000444001750001750 1470411455551355 26367 0ustar00nicholasnicholas000000000000YAHOO.namespace("periapt"); YAHOO.periapt.Editor = function(elementId) { YAHOO.widget.Editor.superclass.constructor.call(this, elementId, { width: 450, handleSubmit: true, animate: true //Animates the opening, closing and moving of Editor windows }); this._defaultToolbar.titlebar = false; this._defaultToolbar.buttons = [ { group: 'textstyle', label: 'Font Style', buttons: [ { type: 'push', label: 'Bold CTRL + SHIFT + B', value: 'bold' }, { type: 'push', label: 'Italic CTRL + SHIFT + I', value: 'italic' } ] }, { type: 'separator' }, { group: 'parastyle', label: 'Paragraph Style', buttons: [ { type: 'select', label: 'Normal', value: 'heading', disabled: true, menu: [ { text: 'Normal', value: 'none', checked: true }, { text: 'Subheading', value: 'h3' } ] } ] }, { type: 'separator' }, { group: 'indentlist', label: 'Lists', buttons: [ { type: 'push', label: 'Create an Unordered List', value: 'insertunorderedlist' }, ] }, { type: 'separator' }, { group: 'insertitem', label: 'Insert Item', buttons: [ { type: 'push', label: 'HTML Link CTRL + SHIFT + L', value: 'createlink', disabled: true }, { type: 'push', label: 'Insert Image', value: 'insertimage' } ] } ]; this.on('toolbarLoaded', function() { this.toolbar.on ('createlinkClick', function(o) { try { var Dom=YAHOO.util.Dom; var labels = Dom.getElementsBy( function(o) { return true; }, 'label', elementId + '-panel' ); for(var l = 0; l < labels.length; l++) { if (Dom.getElementsBy( function(o) { if (o.id == elementId+"_createlink_target") { return true; } return false; }, 'input', labels[l] ).length > 0) { labels[l].className="hide"; } } } catch(l) { alert(l.message); } }); this.toolbar.on ('insertimageClick', function(o) { try { var imgPanel=new YAHOO.util.Element(elementId + '-panel'); imgPanel.on ( 'contentReady', function() { try { var Dom=YAHOO.util.Dom; if (! Dom.get(elementId + '_insertimage_upload')) { var label=document.createElement('label'); label.innerHTML='Upload:'; var img_elem=Dom.get(elementId + '_insertimage_url'); Dom.getAncestorByTagName(img_elem, 'form').encoding = 'multipart/form-data'; Dom.insertAfter(label, img_elem.parentNode); var labels = Dom.getElementsBy( function(o) { return true; }, 'label', elementId + '-panel' ); for(var l = 0; l < labels.length; l++) { if (Dom.getElementsBy( function(o) { if (o.id == elementId+"_insertimage_link") { return true; } if (o.id == elementId+"_insertimage_target") { return true; } return false; }, 'input', labels[l] ).length > 0) { labels[l].className="hide"; } } YAHOO.util.Event.on ( elementId + '_insertimage_upload', 'change', function(ev) { YAHOO.util.Event.stopEvent(ev); // no default click action YAHOO.util.Connect.setForm ( img_elem.form, true); var c=YAHOO.util.Connect.asyncRequest( 'POST', '/cgi-bin/template.cgi', { upload: function(o) { var resp=o.responseText.replace( /
/i, '').replace ( /<\/pre>/i, '');
                               				var data = YAHOO.lang.JSON.parse(resp);
                               				if (data.status == "UPLOADED") {
                               					Dom.get(elementId + '_insertimage_upload').value='';
                               					Dom.get(elementId + '_insertimage_url').value=data.image_url;
                               					// tell the image panel the url changed
                                               // hack instead of fireEvent('blur')
                                               // which for some reason isn't working
                                               Dom.get(elementId + '_insertimage_url').focus();
                                               Dom.get(elementId + '_insertimage_upload').focus();
                               				}
                               				else {
                               					alert(data.status);
                               				}
                               			},
                               		}
                               	);
                            	return false;
                           	});
                           	
                           	
					   }
               		}
               		catch(ee) {
               			alert(ee.message);
               		}
               	});
			}
			catch(e) {
				alert(e.message);
			}
		});
	}, this, true);
	
	
};


YAHOO.lang.extend(YAHOO.periapt.Editor, YAHOO.widget.Editor);

var myEditor = new YAHOO.periapt.Editor('body');
myEditor.render();
CGI-Application-Plugin-AJAXUpload-v0.0.3/example/templates000755001750001750          011455551355 24112 5ustar00nicholasnicholas000000000000CGI-Application-Plugin-AJAXUpload-v0.0.3/example/templates/one.tmpl000444001750001750       453411455551355 25734 0ustar00nicholasnicholas000000000000


  
  

Modified YUI Rich text editor









 
 





			

				Article
   				
   				
   				
   				
				
Please correct these errors.

			


    

		
CGI-Application-Plugin-AJAXUpload-v0.0.3/example/templates/two.tmpl000444001750001750        64111455551355 25737 0ustar00nicholasnicholas000000000000


Processed document







CGI-Application-Plugin-AJAXUpload-v0.0.3/t000755001750001750          011455551355 20724 5ustar00nicholasnicholas000000000000CGI-Application-Plugin-AJAXUpload-v0.0.3/t/prereq.t000444001750001750       102711455551355 22544 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::Pod::No404s', 'Test::CheckChanges', 'Test::CheckManifest', 'Test::Spelling', 'Test::Prereq', 'Test::Prereq::Build', 'Test::Perl::Critic', 'TestWebApp']);


CGI-Application-Plugin-AJAXUpload-v0.0.3/t/manifest.t000444001750001750        75711455551355 23045 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)$/]});

CGI-Application-Plugin-AJAXUpload-v0.0.3/t/perlcritic.t000444001750001750        54411455551355 23371 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();
CGI-Application-Plugin-AJAXUpload-v0.0.3/t/04-resize.t000444001750001750      2273211455551355 23016 0ustar00nicholasnicholas000000000000#!/usr/bin/perl -wT
use strict;
use warnings;
use Carp;
use Test::More tests=>12;
use Test::NoWarnings;
use Test::CGI::Multipart;
use Test::CGI::Multipart::Gen::Image;
use Test::Image::GD;
use lib qw(t/lib);
use Perl6::Slurp;
use Readonly;
use File::Temp;
use TestWebApp;
use Data::FormValidator::Filters::ImgData;

Readonly my $CONTENT_RE =>
    qr{
        \A
        Encoding:\s+utf-8\s+Content-Type:\s+text/javascript
        (?:;\s+charset=utf-8)?
    }xms;
    
Readonly my $IMAGE_INSTRUCTIONS => [
    ['bgcolor','red'],
    ['fgcolor','blue'],
    ['rectangle',30,30,100,100],
    ['moveTo',80,210],
    ['fontsize',20],
    ['string','Helloooooooooooo world!'],
]; 

sub nonexistent_dir {
    my $new_dir = File::Temp->newdir;
    return $new_dir->dirname;
}

sub valid_dir {
    my $tmpdir = File::Temp->newdir;
    my $tmpdir_name = $tmpdir->dirname;
    mkdir "$tmpdir_name/img";
    mkdir "$tmpdir_name/img/uploads";
    return $tmpdir;
}

my $tcm = Test::CGI::Multipart->new;
$tcm->set_param(name=>'rm', value=>'ajax_upload_rm');
$tcm->upload_file(
        name=>'file',
        width=>400,
        height=>250,
        instructions=>$IMAGE_INSTRUCTIONS,
        file=>'test.jpeg',
        type=>'image/jpeg'
);

my $profile = CGI::Application::Plugin::AJAXUpload->ajax_upload_default_profile;
$profile->{field_filters}->{value} = filter_resize(300,200);

subtest 'httpdocs_dir not specified' => sub{
    plan tests => 3;
    my $app = TestWebApp->new(
        QUERY=>$tcm->create_cgi(),
        PARAMS=>{
            document_root=>sub {},
            ajax_spec=>{
                dfv_profile=>$profile,
            },
        },
    );
    isa_ok($app, 'CGI::Application');
    $app->response_like(
        $CONTENT_RE,
        qr/{"status":"No document root specified"}/,
        'httpdocs_dir not specified'
    );
};

subtest 'httpdocs_dir does not exist' => sub{
    plan tests => 3;
    my $app = TestWebApp->new(
        QUERY=>$tcm->create_cgi(),
        PARAMS=>{
            document_root=>sub {
                my $c = shift;
                $c->ajax_upload_httpdocs(nonexistent_dir());
            },
            ajax_spec=>{
                dfv_profile=>$profile,
            },
        },
    );
    isa_ok($app, 'CGI::Application');
    $app->query->param(validate=>1);
    $app->response_like(
        $CONTENT_RE,
        qr/{"status":"Document root is not a directory"}/,
        'httpdocs_dir does not exist'
    );
};

subtest 'httpdocs_dir not a directory' => sub{
    plan tests => 3;
    my $actually_a_file = File::Temp->new;
    my $app = TestWebApp->new(
        QUERY=>$tcm->create_cgi(),
        PARAMS=>{
            document_root=>sub {
                my $c = shift;
                $c->ajax_upload_httpdocs($actually_a_file->filename);
            },
            ajax_spec=>{
                dfv_profile=>$profile,
            },
        },
    );
    isa_ok($app, 'CGI::Application');
    $app->query->param(rm=>'ajax_upload_rm');
    $app->query->param(validate=>1);
    $app->response_like(
        $CONTENT_RE,
        qr/{"status":"Document root is not a directory"}/,
        'httpdocs_dir not a directory'
    );
};

subtest 'upload_subdir does not exist' => sub{
    plan tests => 3;
    my $tmpdir = File::Temp->newdir;
    my $app = TestWebApp->new(
        QUERY=>$tcm->create_cgi(),
        PARAMS=>{
            document_root=>sub {
                my $c = shift;
                $c->ajax_upload_httpdocs($tmpdir->dirname);
            },
            ajax_spec=>{
                dfv_profile=>$profile,
            },
        },
    );
    isa_ok($app, 'CGI::Application');
    $app->query->param(validate=>1);
    $app->response_like(
        $CONTENT_RE,
        qr/{"status":"Upload folder is not a directory"}/,
        'upload folder does not exist'
    );
};

subtest 'upload_subdir is not writeable' => sub{
    plan tests => 3;
    my $tmpdir = valid_dir();
    my $tmpdir_name = $tmpdir->dirname;
    chmod 300, "$tmpdir_name/img/uploads";
    my $app = TestWebApp->new(
        QUERY=>$tcm->create_cgi(),
        PARAMS=>{
            document_root=>sub {
                my $c = shift;
                $c->ajax_upload_httpdocs($tmpdir_name);
            },
            ajax_spec=>{
                dfv_profile=>$profile,
            },
        },
    );
    isa_ok($app, 'CGI::Application');
    $app->query->param(validate=>1);
    $app->response_like(
        $CONTENT_RE,
        qr/{"status":"Upload folder is not writeable"}/,
        'Upload folder is not writeable'
    );
};

my $tcm2 = Test::CGI::Multipart->new;
$tcm2->set_param(name=>'rm', value=>'ajax_upload_rm');
subtest 'no file parameter' => sub{
    plan tests => 3;
    my $tmpdir = valid_dir();
    my $tmpdir_name = $tmpdir->dirname;
    my $app = TestWebApp->new(
        QUERY=>$tcm2->create_cgi(),
        PARAMS=>{
            document_root=>sub {
                my $c = shift;
                $c->ajax_upload_httpdocs($tmpdir_name);
            },
            ajax_spec=>{
                dfv_profile=>$profile,
            },
        },
    );
    isa_ok($app, 'CGI::Application');
    $app->response_like(
        $CONTENT_RE,
        qr/{"status":"No file handle obtained"}/,
        'no file parameter'
    );
};

my $tcm4 = Test::CGI::Multipart->new;
$tcm4->set_param(name=>'rm', value=>'ajax_upload_rm');
$tcm4->upload_file(
        name=>'file',
        width=>400,
        height=>250,
        instructions=>$IMAGE_INSTRUCTIONS,
        file=>'test*blah.jpeg',
        type=>'image/jpeg'
);
subtest 'DFV messages' => sub{
    plan tests => 3;
    my $tmpdir = valid_dir();
    my $tmpdir_name = $tmpdir->dirname;
    my $app = TestWebApp->new(
        QUERY=>$tcm4->create_cgi(),
        PARAMS=>{
            document_root=>sub {
                my $c = shift;
                $c->ajax_upload_httpdocs($tmpdir_name);
            },
            ajax_spec=>{
                dfv_profile=>$profile,
            },
        },
    );
    isa_ok($app, 'CGI::Application');
    $app->response_like(
        $CONTENT_RE,
        qr/{"status":"file_name: Invalid, "}/,
        'DFV messages'
    );
};

my $tcm3 = Test::CGI::Multipart->new;
$tcm3->set_param(name=>'rm', value=>'file_upload');
$tcm3->upload_file(
        name=>'file',
        width=>400,
        height=>250,
        instructions=>$IMAGE_INSTRUCTIONS,
        file=>'test.jpeg',
        type=>'image/jpeg'
);
subtest 'options' => sub{
    plan tests => 4;
    my $upload_subdir = '/images';
    my $tmpdir = File::Temp->newdir;
    my $tmpdir_name = $tmpdir->dirname;
    mkdir "$tmpdir_name$upload_subdir";
    my $app = TestWebApp->new(
        QUERY=>$tcm3->create_cgi(),
        PARAMS=>{
            document_root=>sub {
                my $c = shift;
                $c->ajax_upload_httpdocs($tmpdir_name);
            },
            ajax_spec=> {
                run_mode=>'file_upload',
                upload_subdir=>$upload_subdir,
                dfv_profile=>$profile,
            },
        },
    );
    isa_ok($app, 'CGI::Application');
    $app->response_like(
        $CONTENT_RE,
        qr!{"status":"UPLOADED","image_url":"$upload_subdir/test.jpeg"}!xms,
        'UPLOADED'
    );
    size_ok("$tmpdir_name$upload_subdir/test.jpeg", [300,int(250*300/400)], "size 300x200");
};

subtest 'UPLOADED' => sub{
    plan tests => 4;
    my $tmpdir = valid_dir();
    my $tmpdir_name = $tmpdir->dirname;
    my $app = TestWebApp->new(
        QUERY=>$tcm->create_cgi(),
        PARAMS=>{
            document_root=>sub {
                my $c = shift;
                $c->ajax_upload_httpdocs($tmpdir_name);
            },
            ajax_spec=>{
                dfv_profile=>$profile,
            },
        },
    );
    isa_ok($app, 'CGI::Application');
    $app->query->param(validate=>1);
    $app->response_like(
        $CONTENT_RE,
        qr!{"status":"UPLOADED","image_url":"/img/uploads/test.jpeg"}!xms,
        'UPLOADED'
    );
    size_ok("$tmpdir_name/img/uploads/test.jpeg", [300,int(250*300/400)], "size 300x200");
};

subtest 'png' => sub{
    plan tests => 4;
    my $tmpdir = valid_dir();
    my $tmpdir_name = $tmpdir->dirname;
    local $profile->{field_filters}->{value} = filter_resize(300,200,'png');
    my $app = TestWebApp->new(
        QUERY=>$tcm->create_cgi(),
        PARAMS=>{
            document_root=>sub {
                my $c = shift;
                $c->ajax_upload_httpdocs($tmpdir_name);
            },
            ajax_spec=>{
                dfv_profile=>$profile,
            },
        },
    );
    isa_ok($app, 'CGI::Application');
    $app->query->param(validate=>1);
    $app->response_like(
        $CONTENT_RE,
        qr!{"status":"UPLOADED","image_url":"/img/uploads/test.jpeg"}!xms,
        'UPLOADED'
    );
    size_ok("$tmpdir_name/img/uploads/test.jpeg", [300,int(250*300/400)], "size 300x200");
};

subtest 'square' => sub{
    plan tests => 4;
    my $tmpdir = valid_dir();
    my $tmpdir_name = $tmpdir->dirname;
    local $profile->{field_filters}->{value} = filter_resize(300,50);
    my $app = TestWebApp->new(
        QUERY=>$tcm->create_cgi(),
        PARAMS=>{
            document_root=>sub {
                my $c = shift;
                $c->ajax_upload_httpdocs($tmpdir_name);
            },
            ajax_spec=>{
                dfv_profile=>$profile,
            },
        },
    );
    isa_ok($app, 'CGI::Application');
    $app->query->param(validate=>1);
    $app->response_like(
        $CONTENT_RE,
        qr!{"status":"UPLOADED","image_url":"/img/uploads/test.jpeg"}!xms,
        'UPLOADED'
    );
    size_ok("$tmpdir_name/img/uploads/test.jpeg", [80,50], "size 300x50");
};


CGI-Application-Plugin-AJAXUpload-v0.0.3/t/pod.t000444001750001750        43111455551355 22006 0ustar00nicholasnicholas000000000000#!perl -T

if ( not $ENV{TEST_AUTHOR} ) {
    my $msg = 'Author test.  Set $ENV{TEST_AUTHOR} to a true value to run.';
    plan( skip_all => $msg );
}

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();
CGI-Application-Plugin-AJAXUpload-v0.0.3/t/podspell.t000444001750001750       436211455551355 23075 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(   JSON
                                    CPAN
                                    Bamber
                                    com
                                    javascript
                                    AllMyBrain
                                    CGI
                                    com's
                                    github
                                    YUI
                                    AnnoCPAN
                                    RT
                                    API
                                    SQL
                                    DBI
                                    username
                                    usernames
                                    CALLBACKS
                                    CALLBACKS
                                    HTML
                                    LDAP
                                    RUNMODES
                                    TODO
                                    URL
                                    CAPAUTHTOKEN
                                    webserver
                                    Hardcode
                                    hardcode
                                    everytime
                                    initialize
                                    authen
                                    customizations
                                    runmode
                                    runmodes
                                    prerun
                                    pre
                                    callback
                                    callbacks
                                    checkbox
                                    desaturating
                                    writeable
                                    detaint
                                    URLs));
Test::Spelling::all_pod_files_spelling_ok();

CGI-Application-Plugin-AJAXUpload-v0.0.3/t/01.basic.t000444001750001750        41111455551355 22522 0ustar00nicholasnicholas000000000000use strict;
use warnings;
use Carp;
use Test::More tests => 2;
use Test::NoWarnings;
use lib qw(t/lib);
use CGI;
use TestWebApp;

subtest 'create a webapp object' => sub{
    plan tests => 1;
    my $app = TestWebApp->new;
    isa_ok($app, 'CGI::Application');
}


CGI-Application-Plugin-AJAXUpload-v0.0.3/t/00.load.t000444001750001750        36311455551355 22365 0ustar00nicholasnicholas000000000000use Test::More tests => 2;

BEGIN {
use_ok( 'CGI::Application::Plugin::AJAXUpload' );
use_ok( 'Data::FormValidator::Filters::ImgData' );
}

diag( "Testing CGI::Application::Plugin::AJAXUpload $CGI::Application::Plugin::AJAXUpload::VERSION" );
CGI-Application-Plugin-AJAXUpload-v0.0.3/t/pod-coverage.t000444001750001750        47111455551355 23603 0ustar00nicholasnicholas000000000000#!perl -T

if ( not $ENV{TEST_AUTHOR} ) {
    my $msg = 'Author test.  Set $ENV{TEST_AUTHOR} to a true value to run.';
    plan( skip_all => $msg );
}

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();
CGI-Application-Plugin-AJAXUpload-v0.0.3/t/02.warnings.t000444001750001750      2205311455551355 23340 0ustar00nicholasnicholas000000000000#!/usr/bin/perl -wT
use strict;
use warnings;
use Carp;
use Test::More tests=>12;
use Test::NoWarnings;
use Test::CGI::Multipart;
use lib qw(t/lib);
use Perl6::Slurp;
use Readonly;
use File::Temp;
use TestWebApp;

Readonly my $CONTENT_RE =>
    qr{
        \A
        Encoding:\s+utf-8\s+Content-Type:\s+text/javascript
        (?:;\s+charset=utf-8)?
    }xms;

my $profile = TestWebApp->ajax_upload_default_profile();
$profile->{constraint_methods}->{mime_type} = qr{^text/plain$};
$profile->{required} = [qw(value file_name data_size)];
$profile->{optional} = [qw(mime_type)];

sub nonexistent_dir {
    my $new_dir = File::Temp->newdir;
    return $new_dir->dirname;
}

sub valid_dir {
    my $tmpdir = File::Temp->newdir;
    my $tmpdir_name = $tmpdir->dirname;
    mkdir "$tmpdir_name/img";
    mkdir "$tmpdir_name/img/uploads";
    return $tmpdir;
}

my $tcm = Test::CGI::Multipart->new;
$tcm->set_param(name=>'rm', value=>'ajax_upload_rm');
$tcm->upload_file(name=>'file', value=>'This is a test!',file=>'test.txt');

subtest 'httpdocs_dir not specified' => sub{
    plan tests => 3;
    my $app = TestWebApp->new(
        QUERY=>$tcm->create_cgi(),
        PARAMS=>{
            document_root=>sub {},
            ajax_spec=> {
                dfv_profile=>$profile
            },
        },
    );
    isa_ok($app, 'CGI::Application');
    $app->response_like(
        $CONTENT_RE,
        qr/{"status":"No document root specified"}/,
        'httpdocs_dir not specified'
    );
};

subtest 'httpdocs_dir does not exist' => sub{
    plan tests => 3;
    my $app = TestWebApp->new(
        QUERY=>$tcm->create_cgi(),
        PARAMS=>{
            document_root=>sub {
                my $c = shift;
                $c->ajax_upload_httpdocs(nonexistent_dir());
            },
            ajax_spec=> {
                dfv_profile=>$profile
            },
        },
    );
    isa_ok($app, 'CGI::Application');
    $app->query->param(validate=>1);
    $app->response_like(
        $CONTENT_RE,
        qr/{"status":"Document root is not a directory"}/,
        'httpdocs_dir does not exist'
    );
};

subtest 'httpdocs_dir not a directory' => sub{
    plan tests => 3;
    my $actually_a_file = File::Temp->new;
    my $app = TestWebApp->new(
        QUERY=>$tcm->create_cgi(),
        PARAMS=>{
            document_root=>sub {
                my $c = shift;
                $c->ajax_upload_httpdocs($actually_a_file->filename);
            },
            ajax_spec=> {
                dfv_profile=>$profile
            },
        },
    );
    isa_ok($app, 'CGI::Application');
    $app->query->param(rm=>'ajax_upload_rm');
    $app->query->param(validate=>1);
    $app->response_like(
        $CONTENT_RE,
        qr/{"status":"Document root is not a directory"}/,
        'httpdocs_dir not a directory'
    );
};

subtest 'upload_subdir does not exist' => sub{
    plan tests => 3;
    my $tmpdir = File::Temp->newdir;
    my $app = TestWebApp->new(
        QUERY=>$tcm->create_cgi(),
        PARAMS=>{
            document_root=>sub {
                my $c = shift;
                $c->ajax_upload_httpdocs($tmpdir->dirname);
            },
            ajax_spec=> {
                dfv_profile=>$profile
            },
        },
    );
    isa_ok($app, 'CGI::Application');
    $app->query->param(validate=>1);
    $app->response_like(
        $CONTENT_RE,
        qr/{"status":"Upload folder is not a directory"}/,
        'upload folder does not exist'
    );
};

subtest 'upload_subdir is not writeable' => sub{
    plan tests => 3;
    my $tmpdir = valid_dir();
    my $tmpdir_name = $tmpdir->dirname;
    chmod 300, "$tmpdir_name/img/uploads";
    my $app = TestWebApp->new(
        QUERY=>$tcm->create_cgi(),
        PARAMS=>{
            document_root=>sub {
                my $c = shift;
                $c->ajax_upload_httpdocs($tmpdir_name);
            },
            ajax_spec=> {
                dfv_profile=>$profile
            },
        },
    );
    isa_ok($app, 'CGI::Application');
    $app->query->param(validate=>1);
    $app->response_like(
        $CONTENT_RE,
        qr/{"status":"Upload folder is not writeable"}/,
        'Upload folder is not writeable'
    );
};

my $tcm2 = Test::CGI::Multipart->new;
$tcm2->set_param(name=>'rm', value=>'ajax_upload_rm');
subtest 'no file parameter' => sub{
    plan tests => 3;
    my $tmpdir = valid_dir();
    my $tmpdir_name = $tmpdir->dirname;
    my $app = TestWebApp->new(
        QUERY=>$tcm2->create_cgi(),
        PARAMS=>{
            document_root=>sub {
                my $c = shift;
                $c->ajax_upload_httpdocs($tmpdir_name);
            },
            ajax_spec=> {
                dfv_profile=>$profile
            },
        },
    );
    isa_ok($app, 'CGI::Application');
    $app->response_like(
        $CONTENT_RE,
        qr/{"status":"No file handle obtained"}/,
        'no file parameter'
    );
};

my $tcm4 = Test::CGI::Multipart->new;
$tcm4->set_param(name=>'rm', value=>'ajax_upload_rm');
$tcm4->upload_file(name=>'file', value=>'This is a test!',file=>'test*blah.txt');
subtest 'DFV messages' => sub{
    plan tests => 3;
    my $tmpdir = valid_dir();
    my $tmpdir_name = $tmpdir->dirname;
    my $app = TestWebApp->new(
        QUERY=>$tcm4->create_cgi(),
        PARAMS=>{
            document_root=>sub {
                my $c = shift;
                $c->ajax_upload_httpdocs($tmpdir_name);
            },
            ajax_spec=> {
                dfv_profile=>$profile
            },
        },
    );
    isa_ok($app, 'CGI::Application');
    $app->response_like(
        $CONTENT_RE,
        qr/{"status":"file_name: Invalid, "}/,
        'DFV messages'
    );
};

subtest 'internal error' => sub{
    plan  tests => 4;
    my $tmpdir = valid_dir();
    my $tmpdir_name = $tmpdir->dirname;
    local $profile->{field_filters} = {
        file_name => [
            sub {croak "Help!"},
        ],
    };
    my $app = TestWebApp->new(
        QUERY=>$tcm->create_cgi(),
        PARAMS=>{
            document_root=>sub {
                my $c = shift;
                $c->ajax_upload_httpdocs($tmpdir_name);
            },
            ajax_spec=> {
                dfv_profile=>$profile
            },
        },
    );
    isa_ok($app, 'CGI::Application');
    $app->response_like(
        $CONTENT_RE,
        qr/{"status":"Internal Error"}/,
        'Internal Error',
        qr/Help!/
    );
};

my $tcm5 = Test::CGI::Multipart->new;
$tcm5->set_param(name=>'rm', value=>'ajax_upload_rm');
$tcm5->upload_file(name=>'file', value=>'',file=>'test.txt');
subtest 'no data' => sub{
    plan  tests => 3;
    my $tmpdir = valid_dir();
    my $tmpdir_name = $tmpdir->dirname;
    local $profile->{constraint_methods} = {
        value => qr/^.{0,100}$/,
    };
    local $profile->{required} = [
        qw(file_name data_size)
    ];
    local $profile->{optional} = [
        qw(mime_type value)
    ];
    my $app = TestWebApp->new(
        QUERY=>$tcm5->create_cgi(),
        PARAMS=>{
            document_root=>sub {
                my $c = shift;
                $c->ajax_upload_httpdocs($tmpdir_name);
            },
            ajax_spec=> {
                dfv_profile=>$profile
            },
        },
    );
    isa_ok($app, 'CGI::Application');
    $app->query->param(validate=>1);
    $app->response_like(
        $CONTENT_RE,
        qr/{"status":"No data uploaded"}/,
        'No data uploaded'
    );
};

my $tcm3 = Test::CGI::Multipart->new;
$tcm3->set_param(name=>'rm', value=>'file_upload');
$tcm3->upload_file(name=>'file', value=>'This is a test!',file=>'test.txt');
subtest 'options' => sub{
    plan tests => 4;
    my $upload_subdir = '/images';
    my $tmpdir = File::Temp->newdir;
    my $tmpdir_name = $tmpdir->dirname;
    mkdir "$tmpdir_name$upload_subdir";
    my $app = TestWebApp->new(
        QUERY=>$tcm3->create_cgi(),
        PARAMS=>{
            document_root=>sub {
                my $c = shift;
                $c->ajax_upload_httpdocs($tmpdir_name);
            },
            ajax_spec=> {
                run_mode=>'file_upload',
                dfv_profile=>$profile,
                upload_subdir=>$upload_subdir,
            },
        },
    );
    isa_ok($app, 'CGI::Application');
    $app->response_like(
        $CONTENT_RE,
        qr!{"status":"UPLOADED","image_url":"$upload_subdir/test.txt"}!xms,
        'UPLOADED'
    );
    is(slurp("$tmpdir_name$upload_subdir/test.txt"), "This is a test!", 'file contents');
};

subtest 'UPLOADED' => sub{
    plan tests => 4;
    my $tmpdir = valid_dir();
    my $tmpdir_name = $tmpdir->dirname;
    my $app = TestWebApp->new(
        QUERY=>$tcm->create_cgi(),
        PARAMS=>{
            document_root=>sub {
                my $c = shift;
                $c->ajax_upload_httpdocs($tmpdir_name);
            },
            ajax_spec=> {
                dfv_profile=>$profile
            },
        },
    );
    isa_ok($app, 'CGI::Application');
    $app->query->param(validate=>1);
    $app->response_like(
        $CONTENT_RE,
        qr!{"status":"UPLOADED","image_url":"/img/uploads/test.txt"}!xms,
        'UPLOADED'
    );
    is(slurp("$tmpdir_name/img/uploads/test.txt"), "This is a test!", 'file contents');
};






CGI-Application-Plugin-AJAXUpload-v0.0.3/t/changes.t000444001750001750        55311455551355 22641 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();


CGI-Application-Plugin-AJAXUpload-v0.0.3/t/pod-no404s.t000444001750001750       132711455551355 23060 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::Pod::No404s; };

if ( $EVAL_ERROR ) {
   my $msg = 'Test::Pod::No404s required to criticise code';
   plan( skip_all => $msg );
}


eval "require Net::Ping";
if ( $EVAL_ERROR) {
   my $msg = 'Cannot verify the internet connectivity without Net::Ping';
   plan( skip_all => $msg );
}
my $ping = Net::Ping->new;
my @google = $ping->ping('www.google.com');
if (! @google) {
   my $msg = 'Apparently no internet at all';
   plan( skip_all => $msg );
}


Test::Pod::No404s::all_pod_files_ok();

CGI-Application-Plugin-AJAXUpload-v0.0.3/t/03.images.t000444001750001750      1575011455551355 22764 0ustar00nicholasnicholas000000000000#!/usr/bin/perl -wT
use strict;
use warnings;
use Carp;
use Test::More tests=>10;
use Test::NoWarnings;
use Test::CGI::Multipart;
use Test::CGI::Multipart::Gen::Image;
use lib qw(t/lib);
use Perl6::Slurp;
use Readonly;
use File::Temp;
use TestWebApp;

Readonly my $CONTENT_RE =>
    qr{
        \A
        Encoding:\s+utf-8\s+Content-Type:\s+text/javascript
        (?:;\s+charset=utf-8)?
    }xms;
    
Readonly my $IMAGE_INSTRUCTIONS => [
    ['bgcolor','red'],
    ['fgcolor','blue'],
    ['rectangle',30,30,100,100],
    ['moveTo',80,210],
    ['fontsize',20],
    ['string','Helloooooooooooo world!'],
]; 

sub nonexistent_dir {
    my $new_dir = File::Temp->newdir;
    return $new_dir->dirname;
}

sub valid_dir {
    my $tmpdir = File::Temp->newdir;
    my $tmpdir_name = $tmpdir->dirname;
    mkdir "$tmpdir_name/img";
    mkdir "$tmpdir_name/img/uploads";
    return $tmpdir;
}

my $tcm = Test::CGI::Multipart->new;
$tcm->set_param(name=>'rm', value=>'ajax_upload_rm');
$tcm->upload_file(
        name=>'file',
        width=>400,
        height=>250,
        instructions=>$IMAGE_INSTRUCTIONS,
        file=>'test.jpeg',
        type=>'image/jpeg'
);

subtest 'httpdocs_dir not specified' => sub{
    plan tests => 3;
    my $app = TestWebApp->new(
        QUERY=>$tcm->create_cgi(),
        PARAMS=>{
            document_root=>sub {},
        },
    );
    isa_ok($app, 'CGI::Application');
    $app->response_like(
        $CONTENT_RE,
        qr/{"status":"No document root specified"}/,
        'httpdocs_dir not specified'
    );
};

subtest 'httpdocs_dir does not exist' => sub{
    plan tests => 3;
    my $app = TestWebApp->new(
        QUERY=>$tcm->create_cgi(),
        PARAMS=>{
            document_root=>sub {
                my $c = shift;
                $c->ajax_upload_httpdocs(nonexistent_dir());
            },
        },
    );
    isa_ok($app, 'CGI::Application');
    $app->query->param(validate=>1);
    $app->response_like(
        $CONTENT_RE,
        qr/{"status":"Document root is not a directory"}/,
        'httpdocs_dir does not exist'
    );
};

subtest 'httpdocs_dir not a directory' => sub{
    plan tests => 3;
    my $actually_a_file = File::Temp->new;
    my $app = TestWebApp->new(
        QUERY=>$tcm->create_cgi(),
        PARAMS=>{
            document_root=>sub {
                my $c = shift;
                $c->ajax_upload_httpdocs($actually_a_file->filename);
            },
        },
    );
    isa_ok($app, 'CGI::Application');
    $app->query->param(rm=>'ajax_upload_rm');
    $app->query->param(validate=>1);
    $app->response_like(
        $CONTENT_RE,
        qr/{"status":"Document root is not a directory"}/,
        'httpdocs_dir not a directory'
    );
};

subtest 'upload_subdir does not exist' => sub{
    plan tests => 3;
    my $tmpdir = File::Temp->newdir;
    my $app = TestWebApp->new(
        QUERY=>$tcm->create_cgi(),
        PARAMS=>{
            document_root=>sub {
                my $c = shift;
                $c->ajax_upload_httpdocs($tmpdir->dirname);
            },
        },
    );
    isa_ok($app, 'CGI::Application');
    $app->query->param(validate=>1);
    $app->response_like(
        $CONTENT_RE,
        qr/{"status":"Upload folder is not a directory"}/,
        'upload folder does not exist'
    );
};

subtest 'upload_subdir is not writeable' => sub{
    plan tests => 3;
    my $tmpdir = valid_dir();
    my $tmpdir_name = $tmpdir->dirname;
    chmod 300, "$tmpdir_name/img/uploads";
    my $app = TestWebApp->new(
        QUERY=>$tcm->create_cgi(),
        PARAMS=>{
            document_root=>sub {
                my $c = shift;
                $c->ajax_upload_httpdocs($tmpdir_name);
            },
        },
    );
    isa_ok($app, 'CGI::Application');
    $app->query->param(validate=>1);
    $app->response_like(
        $CONTENT_RE,
        qr/{"status":"Upload folder is not writeable"}/,
        'Upload folder is not writeable'
    );
};

my $tcm2 = Test::CGI::Multipart->new;
$tcm2->set_param(name=>'rm', value=>'ajax_upload_rm');
subtest 'no file parameter' => sub{
    plan tests => 3;
    my $tmpdir = valid_dir();
    my $tmpdir_name = $tmpdir->dirname;
    my $app = TestWebApp->new(
        QUERY=>$tcm2->create_cgi(),
        PARAMS=>{
            document_root=>sub {
                my $c = shift;
                $c->ajax_upload_httpdocs($tmpdir_name);
            },
        },
    );
    isa_ok($app, 'CGI::Application');
    $app->response_like(
        $CONTENT_RE,
        qr/{"status":"No file handle obtained"}/,
        'no file parameter'
    );
};

my $tcm4 = Test::CGI::Multipart->new;
$tcm4->set_param(name=>'rm', value=>'ajax_upload_rm');
$tcm4->upload_file(
        name=>'file',
        width=>400,
        height=>250,
        instructions=>$IMAGE_INSTRUCTIONS,
        file=>'test*blah.jpeg',
        type=>'image/jpeg'
);
subtest 'DFV messages' => sub{
    plan tests => 3;
    my $tmpdir = valid_dir();
    my $tmpdir_name = $tmpdir->dirname;
    my $app = TestWebApp->new(
        QUERY=>$tcm4->create_cgi(),
        PARAMS=>{
            document_root=>sub {
                my $c = shift;
                $c->ajax_upload_httpdocs($tmpdir_name);
            },
        },
    );
    isa_ok($app, 'CGI::Application');
    $app->response_like(
        $CONTENT_RE,
        qr/{"status":"file_name: Invalid, "}/,
        'DFV messages'
    );
};

my $tcm3 = Test::CGI::Multipart->new;
$tcm3->set_param(name=>'rm', value=>'file_upload');
$tcm3->upload_file(
        name=>'file',
        width=>400,
        height=>250,
        instructions=>$IMAGE_INSTRUCTIONS,
        file=>'test.jpeg',
        type=>'image/jpeg'
);
subtest 'options' => sub{
    plan tests => 4;
    my $upload_subdir = '/images';
    my $tmpdir = File::Temp->newdir;
    my $tmpdir_name = $tmpdir->dirname;
    mkdir "$tmpdir_name$upload_subdir";
    my $app = TestWebApp->new(
        QUERY=>$tcm3->create_cgi(),
        PARAMS=>{
            document_root=>sub {
                my $c = shift;
                $c->ajax_upload_httpdocs($tmpdir_name);
            },
            ajax_spec=> {
                run_mode=>'file_upload',
                upload_subdir=>$upload_subdir,
            },
        },
    );
    isa_ok($app, 'CGI::Application');
    $app->response_like(
        $CONTENT_RE,
        qr!{"status":"UPLOADED","image_url":"$upload_subdir/test.jpeg"}!xms,
        'UPLOADED'
    );
    is(-s "$tmpdir_name$upload_subdir/test.jpeg", 4046, 'file size');
};

subtest 'UPLOADED' => sub{
    plan tests => 4;
    my $tmpdir = valid_dir();
    my $tmpdir_name = $tmpdir->dirname;
    my $app = TestWebApp->new(
        QUERY=>$tcm->create_cgi(),
        PARAMS=>{
            document_root=>sub {
                my $c = shift;
                $c->ajax_upload_httpdocs($tmpdir_name);
            },
        },
    );
    isa_ok($app, 'CGI::Application');
    $app->query->param(validate=>1);
    $app->response_like(
        $CONTENT_RE,
        qr!{"status":"UPLOADED","image_url":"/img/uploads/test.jpeg"}!xms,
        'UPLOADED'
    );
    is(-s "$tmpdir_name/img/uploads/test.jpeg", 4046, 'file size');
};






CGI-Application-Plugin-AJAXUpload-v0.0.3/t/lib000755001750001750          011455551355 21472 5ustar00nicholasnicholas000000000000CGI-Application-Plugin-AJAXUpload-v0.0.3/t/lib/TestWebApp.pm000444001750001750       260111455551355 24202 0ustar00nicholasnicholas000000000000package TestWebApp;
use base qw(CGI::Application);
use CGI::Application::Plugin::JSON qw(to_json);
use CGI::Application::Plugin::AJAXUpload;
use File::Temp;
use Test::More;
use Test::Warn;

$ENV{CGI_APP_RETURN_ONLY} = 1;

sub setup {
    my $self = shift;
    $self->header_props(-encoding=>'utf-8',-charset=>'utf-8');

    if ($self->param('document_root')) {
        my $setup = $self->param('document_root');
        $self->$setup();
    }
    else {
        $self->{_TESTWEBAPP_TEMPDIR} = File::Temp->newdir();
        my $httpdocs_dir = $self->{_TESTWEBAPP_TEMPDIR}->dirname;
        mkdir "${httpdocs_dir}/img";
        mkdir "${httpdocs_dir}/img/uploads";
        $self->ajax_upload_httpdocs($httpdocs_dir);
    }

    if ($self->param('ajax_spec')) {
        $self->ajax_upload_setup(%{$self->param('ajax_spec')});
    }
    else {
        $self->ajax_upload_setup();
    }

    return;
}

sub response_like {
    my $self = shift;
    my $header_re = shift;
    my $body_re = shift;
    my $comment = shift;
    my $warning_re = shift;

    my $output = undef;
    if ($warning_re) {
        warning_like {$output = $self->run;} $warning_re, "warning: $comment";
    }
    else {
        $output = $self->run;
    }

    my ($header, $body) = split /\r\n\r\n/, $output;
    like($header, $header_re, "$comment (header match)");
    like($body, $body_re, "$comment (body match)");

    return;
}



1
CGI-Application-Plugin-AJAXUpload-v0.0.3/lib000755001750001750          011455551355 21227 5ustar00nicholasnicholas000000000000CGI-Application-Plugin-AJAXUpload-v0.0.3/lib/CGI000755001750001750          011455551355 21631 5ustar00nicholasnicholas000000000000CGI-Application-Plugin-AJAXUpload-v0.0.3/lib/CGI/Application000755001750001750          011455551355 24074 5ustar00nicholasnicholas000000000000CGI-Application-Plugin-AJAXUpload-v0.0.3/lib/CGI/Application/Plugin000755001750001750          011455551355 25332 5ustar00nicholasnicholas000000000000CGI-Application-Plugin-AJAXUpload-v0.0.3/lib/CGI/Application/Plugin/AJAXUpload.pm000444001750001750      3021111455551355 27732 0ustar00nicholasnicholas000000000000package CGI::Application::Plugin::AJAXUpload;

use warnings;
use strict;
use Carp;
use base qw(Exporter);
use vars qw(@EXPORT);
use Perl6::Slurp;
use Readonly;
use Data::FormValidator;

@EXPORT = qw(
    ajax_upload_httpdocs
    ajax_upload_setup
    ajax_upload_default_profile
    _ajax_upload_rm
    _ajax_upload_compile_messages
);

use version; our $VERSION = qv('0.0.3');

# Module implementation here

Readonly my $FIELD_NAME => 'file';
Readonly my $MAX_UPLOAD => 512*1024;

sub ajax_upload_httpdocs {
    my $self = shift;
    my $httpdocs = shift;
    if ($httpdocs) {
        $self->{__CAP__AJAXUPLOAD_HTTPDOCS} = $httpdocs;
        return;
    }
    return $self->{__CAP__AJAXUPLOAD_HTTPDOCS};
}

sub ajax_upload_setup {
    my $self = shift;
    my %args = @_;

    my $upload_subdir = $args{upload_subdir} || '/img/uploads';
    my $dfv_profile = $args{dfv_profile};
    if (!$dfv_profile) {
        $dfv_profile = $self->ajax_upload_default_profile();
    }
    my $run_mode = $args{run_mode} || 'ajax_upload_rm';

    $self->run_modes(
        $run_mode => sub {
            my $c = shift;
            $c->header_props(
                -type=>'text/javascript',
                -encoding=>'utf-8',
                -charset=>'utf-8'
            );
            my $r = eval {
                $c->_ajax_upload_rm($upload_subdir, $dfv_profile);
            };
            if ($@) {
                carp $@;
                return $c->to_json({status=> 'Internal Error'});
            }
            return $r;
        }
    );

    return;
}

sub _ajax_upload_rm {
    use autodie qw(open close);
    my $self = shift;
    my $upload_subdir = shift;
    my $dfv_profile = shift;
    my $httpdocs_dir = $self->ajax_upload_httpdocs;  

    return $self->to_json({status => 'No document root specified'})
        if not defined $httpdocs_dir;

    my $full_upload_dir = "$httpdocs_dir/$upload_subdir";
    my $query = $self->query;

    my $lightweight_fh  = $query->upload('file');
    return $self->to_json({status=>'No file handle obtained'})
        if !defined $lightweight_fh;
        
    my $fh = $lightweight_fh->handle;
    return $self->to_json({status => 'No file handle promoted'})
        if not $fh;

    my $value = slurp $fh;
    close $fh;
    my $filename = $query->param('file');
    my $info = $query->uploadInfo($filename);
    return $self->to_json({status => 'No file name obtained'})
        if not $filename;
    $filename = "$filename"; # force $filename to be a strict string

    my $mime_type = 'text/plain';
    if ($info and exists $info->{'Content-Type'}) {
        $mime_type = $info->{'Content-Type'};
    }
    
    my $data = {
        value => $value,
        file_name => $filename,
        mime_type   => $mime_type,
        data_size => length $value,
    };
    my $results = Data::FormValidator->check($data, $dfv_profile);
    return $self->_ajax_upload_compile_messages($results->msgs)
        if ! $results->success;

    $value = $results->valid('value');
    $filename = $results->valid('file_name');

    if ($query->param('validate')) {

        return $self->to_json({status => 'Document root is not a directory'})
            if not -d $httpdocs_dir;

        return $self->to_json({status => 'Upload folder is not a directory'})
            if not -d $full_upload_dir;

        return $self->to_json({status => 'Upload folder is not writeable'})
            if not -w $full_upload_dir;
        
        return $self->to_json({status => 'No data uploaded'})
            if not $value;

    }

    open $fh, '>', "$full_upload_dir/$filename";
    print {$fh} $value;
    close $fh;

    return $self->to_json({
        status=>'UPLOADED',
        image_url=>"$upload_subdir/$filename"
    });
}

sub _ajax_upload_compile_messages {
    my $self = shift;
    my $msgs = shift;
    my $text = '';
    foreach my $key (keys  %$msgs) {
        $text .= "$key: $msgs->{$key}, ";
    }
    return $self->to_json({status=>$text});
}

sub ajax_upload_default_profile {
    return {
        required=>[qw(value file_name mime_type data_size)],
        untaint_all_constraints=>1,
        constraint_methods => {
            value=>qr{\A.+\z}xms,
            file_name=>qr/^[\w\.\-\_]{1,30}$/,
            data_size=>sub {
                my ($dfv, $val) = @_;
                $dfv->set_current_constraint_name('data_size');
                return $val < $MAX_UPLOAD;
            },
            mime_type=>qr{
                \A
                image/
                (?:
                    jpeg|png|gif
                )
                \z
            }xms,
        },
        msgs => {
            format => '%s',
        },
    };
}

1; # Magic true value required at end of module
__END__

=head1 NAME

CGI::Application::Plugin::AJAXUpload - Run mode to handle a file upload and return a JSON response

=head1 VERSION

This document describes CGI::Application::Plugin::AJAXUpload version 0.0.3

=head1 SYNOPSIS

    use MyWebApp;
    use CGI::Application::Plugin::JSON qw(to_json);
    use CGI::Application::Plugin::AJAXUpload;

    sub setup {
        my $c = shift;
        $c->ajax_upload_httpdocs('/var/www/vhosts/mywebapp/httpdocs');

        $c->ajax_upload_setup(
            run_mode=>'file_upload',
            upload_subdir=>'/img/uploads',
        );
        return;
    }

=head1 DESCRIPTION

This module provides a customisable run mode that handles a file upload
and responds with a JSON message like the following:

    {status: 'UPLOADED', image_url: '/img/uploads/666.png'}

or on failure

    {status: 'The image was too big.'}

This is specifically intended to provide a L based back
end for L's 
L to the
L. However as far as
I can see it could be used as a back end for any L website that uploads files behind the scenes using AJAX. In any case this module does NOT
provide any of that client side code and you must also map the run mode onto the URL used by client-side code.
That said a working example is provided which could form the basis of
a rich text editor.  

=head1 INTERFACE 

=head2 ajax_upload_httpdocs

The module needs to know the document root because it will need to
to copy the file to a sub-directory of the document root,
and it will need to pass that sub-directory back to the client as part
of the URL. If passed a value it will store that as the document root.
If not passed a value it will return the document root.

=head2 ajax_upload_setup

This method sets up a run mode to handle a file upload
and return a JSON message providing status. It takes a number of named
parameters:

=over

=item upload_subdir

This is the sub-directory of I where the files will actually
be written to. It must be writeable. It defaults to '/img/uploads'.

=item dfv_profile

This is a L profile. The hash array that is validated
consists of the fields described below. A very basic profile is provided by
default.

=over 4

=item I This is contains the actual data contained in the upload. It will
be untainted. One can of course apply filters that resize the image (assuming
it is an image) or scrub the HTML (if that is appropriate). 

=item I This is the filename given by the browser. By default it will
be required to be no more than 30 alphanumeric, hyphen or full stop,
underscore characters; it will be untainted and passed through unmodified. One
could however specify a filter that completely ignores the filename, generates
a safe one and does other housekeeping.

=item I This is the file extension passed by the browser.

=item I By default this is required to be less than 512K. 

=back 

Note that this module's handling of file upload and data validation is
somewhat different from that expected by
L and 
L. Those modules work with file handles.
The L profiles required  by this module are expected
to work with the data and meta data.

=item run_mode

This is the name of the run mode that will handle this upload. It defaults to
I.

=back

=head2 ajax_upload_default_profile

This returns a hash reference to the default L
profile. It can be called as a class method.

=head2 _ajax_upload_rm

This private method forms the implementation of the run mode. It requires a
I CGI query parameter that provides the file data. Optionally it also
takes a I parameter that will make other more paranoid checks.
These checks are only optional because if the system is set up correctly
they should never fail.

It takes the following actions:

=over 

=item --

It will get the filename and data associated with the upload and 
pass the data through the L if a profile is 
supplied.

=item --

If it fails the L test a failed message will be passed
back to the caller.

=item --

If the I parameter is set the setup will check. If there
is a problem a status message will be passed back to the user.

=item --

The data will then be copied to the given file, its path being the 
combination of the I parameter, the
I and the generated file name.

=item - 

The successful JSON message will be passed back to the client.

=back

=head1 DIAGNOSTICS

Most error messages will be passed back to the client as a JSON
message, though in a sanitised form. One error 'Internal Error' is
fairly generic and so the underlying error message is written to standard 
error. 

=head1 CONFIGURATION AND ENVIRONMENT

CGI::Application::Plugin::AJAXUpload requires no configuration files or
environment variables. However the client side code, the URL to run mode
dispatching and the general web server setup is not supplied.

=head1 DEPENDENCIES

This is using the C method from L.
As such that module needs to be exported before this module. Or of course you
could just define your own.

=head1 BUGS AND LIMITATIONS

Please report any bugs or feature requests to
C, or through the web interface at
L.

One really odd thing is that the content header of the AJAX reply cannot
be 'application/json' as one would expect. This module sets it to
'text/javascript' which works. There is a very short discussion on the
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.

The javascript code in the example draws heavily on the code provided
by AllMyBrain.com. 

=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.
CGI-Application-Plugin-AJAXUpload-v0.0.3/lib/Data000755001750001750          011455551355 22100 5ustar00nicholasnicholas000000000000CGI-Application-Plugin-AJAXUpload-v0.0.3/lib/Data/FormValidator000755001750001750          011455551355 24651 5ustar00nicholasnicholas000000000000CGI-Application-Plugin-AJAXUpload-v0.0.3/lib/Data/FormValidator/Filters000755001750001750          011455551355 26261 5ustar00nicholasnicholas000000000000CGI-Application-Plugin-AJAXUpload-v0.0.3/lib/Data/FormValidator/Filters/ImgData.pm000444001750001750      1073311455551355 30306 0ustar00nicholasnicholas000000000000package Data::FormValidator::Filters::ImgData;

use warnings;
use strict;
use Carp;
use base qw(Exporter);
use vars qw(@EXPORT);

@EXPORT = qw(
    filter_resize
);

use version; our $VERSION = qv('0.0.3');

# Module implementation here

sub filter_resize {
    my $width = shift;
    my $height = shift;
    my $type = shift || 'jpeg';
    return sub {
        use GD;
        GD::Image->trueColor( 1 );
        my $data = shift;
        my $image = GD::Image->new($data);
        my $old_width = ($image->getBounds)[0];
        my $old_height = ($image->getBounds)[1];
        my $k_h = $height / $old_height;
        my $k_w = $width / $old_width;
        my $k = ($k_h < $k_w ? $k_h : $k_w);
        my $new_height = int($old_height * $k);
        my $new_width  = int($old_width * $k);
        my $new_image = GD::Image->new($new_width, $new_height);
        $new_image->copyResampled($image,
            0, 0,               # (destX, destY)
            0, 0,               # (srcX,  srxY )
            $new_width, $new_height,    # (destX, destY)
            $old_width, $old_height
        );
        return $new_image->$type();
    };
}

1; # Magic true value required at end of module
__END__

=head1 NAME

Data::FormValidator::Filters::ImgData - Resize image on the fly

=head1 VERSION

This document describes Data::FormValidator::Filters::ImgData version 0.0.3

=head1 SYNOPSIS

    use MyWebApp;
    use CGI::Application::Plugin::JSON qw(to_json);
    use CGI::Application::Plugin::AJAXUpload;
    use Data::FormValidator::Filters::ImgData;

    sub setup {
        my $c = shift;
        $c->ajax_upload_httpdocs('/var/www/vhosts/mywebapp/httpdocs');
        
        my $profile = $c->ajax_upload_default_profile;
        $profile->{field_filters}->{value} = filter_resize(300,200);

        $c->ajax_upload_setup(
            run_mode=>'file_upload',
            upload_subdir=>'/img/uploads',
            dfv_profile=>$profile,
        );
        return;
    }

=head1 DESCRIPTION

This module rewrites and formats an image. It is intended specifically to work
with L and hence
L. Unlike, for example L,
it takes raw image data and returns raw image data.

=head1 INTERFACE 

=head2 filter_resize

This returns the subroutine reference that does the work. It takes as arguments
the I and I in that order. There is an optional third argument
which is the format. This defaults to C but can be anything that works as
a method on a L object returning image data.

=head1 ACKNOWLEDGEMENTS

The core of the code is copied from L. However the constructor
for that module does not take raw data.

=head1 DEPENDENCIES

This module uses the L module.

=head1 BUGS AND LIMITATIONS

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.