File Coverage

blib/lib/Test/CGI/Multipart.pm

Criterion	Covered	Total	%
statement	129	131	98.4
branch	17	20	85.0
condition			n/a
subroutine	23	23	100.0
pod	7	7	100.0
total	176	181	97.2

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