File Coverage

blib/lib/CGI/Application/Plugin/AJAXUpload.pm

Criterion	Covered	Total	%
statement	45	98	45.9
branch	2	28	7.1
condition	2	7	28.5
subroutine	13	17	76.4
pod	3	3	100.0
total	65	153	42.4

package 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__