view release on metacpan or  search on metacpan

lib/CGI/ExtDirect.pm  view on Meta::CPAN

    # Make sure we have the required headers
    $cgi_headers{'-type'} = $content_type
        unless exists $cgi_headers{ '-type' };
    
    $cgi_headers{'-status'} = $http_status
        unless exists $cgi_headers{ '-status' };
    
    # Content-length we force
    $cgi_headers{'-content_length'} = $content_length;

    # If they passed charset, then they probably know what they're doing
    $cgi_headers{ '-charset' } = $charset
        unless exists $cgi_headers{ '-charset' };

    # Defang CGI.pm's interface idiosyncracies by ensuring that
    # a header starting with a dash always comes first. Otherwise
    # the hash key randomizer introduced in Perl 5.18 may screw up
    # for us by placing a header with no dash in the first place,
    # making CGI->header() think that it has been fed the first argument
    # form header('content/type', 'HTTP status') instead of the hash
    # form. This leads to CGI::ExtDirect returning a HTTP status line
    # like "HTTP/1.1 1" instead of "HTTP/1.1 200 OK" *sometimes*.
    # Dang.
    return (
        '-type' => delete $cgi_headers{ '-type' },
         %cgi_headers,
    );
}

### PRIVATE INSTANCE METHOD ###
#
# Deals with intricacies of POST-fu and returns something suitable to
# feed to the Router (string or hashref, really). Or undef if something
# goes too wrong to recover.

my @STANDARD_KEYWORDS
    = qw(action method extAction extMethod extTID extUpload extType); 
my %STANDARD_KEYWORD = map { $_ => 1 } @STANDARD_KEYWORDS;

sub _extract_post_data {
    my ($self) = @_;

    # We need CGI object here real bad
    my $cgi = $self->cgi;

    # The smartest way to tell if a form was submitted that *I* know of
    # is to look for 'extAction' and 'extMethod' keywords in CGI params.
    my %keyword = map { $_ => 1 } $cgi->param();
    my $is_form = exists $keyword{ extAction } &&
                  exists $keyword{ extMethod };

    # If form is not involved, it's easy: just return POSTDATA (or undef)
    if ( !$is_form ) {
        my $postdata = $cgi->param('POSTDATA');
        return $postdata ne '' ? $postdata
               :                 undef
               ;
    };

    # If any files are attached, extUpload will contain 'true'
    my $has_uploads = $cgi->param('extUpload') eq 'true';

    # Here file uploads data is stored
    my @_uploads = ();

    # This is to suppress a really annoying warning in CGI.pm 4.08+.
    # I am perfectly aware of what the list context is and how to
    # use it, thank you very much. :/
    local $CGI::LIST_CONTEXT_WARN = 0;

    # Now if the form IS involved, it gets a little bit complicated
    PARAM:
    for my $param ( keys %keyword ) {
        # Defang CGI's idiosyncratic way of returning multi-valued params
        my @values = $cgi->param( $param );
        $keyword{ $param } = @values == 0 ? undef
                           : @values == 1 ? $values[0]
                           :                [ @values ]
                           ;

        # Try to see if $param is a field with associated file upload
        # Skip the standard ones first, of course
        next PARAM if $STANDARD_KEYWORD{ $param } || !$has_uploads;

        # Look for file uploads in this field
        my @field_uploads = $self->_parse_uploads($cgi, $param);

        # Found some, add them to the general stash and kill the field
        if ( @field_uploads ) {
            push @_uploads, @field_uploads;
            delete $keyword{ $param };
        };
    };

    # Metadata is JSON encoded; decode_metadata lives by side effects!
    if ( exists $keyword{metadata} ) {
        RPC::ExtDirect::Util::decode_metadata($self, \%keyword);
    }

    # Remove extType because it's meaningless later on
    delete $keyword{ extType };

    # Fix up the TID so that it comes as a number (JavaScript is picky)
    $keyword{ extTID } += 0 if exists $keyword{ extTID };

    # Now add files to hash, if any
    $keyword{ '_uploads' } = \@_uploads if @_uploads;

    return \%keyword;
}

### PRIVATE INSTANCE METHOD ###
#
# Parses CGI form input field looking for file uploads
#

sub _parse_uploads {
    my ($self, $cgi, $param) = @_;

    # CGI returns "lightweight file handles", or undef
    my @file_handles = $cgi->upload($param);

    # Empty list means no uploads for this field
    return unless grep { defined $_ } @file_handles;

    # Despite what CGI documentation says, the values returned
    # as "file names" are actually some kind of key handles
    my @file_keys = $cgi->param($param);

    # Here file uploads get collected
    my @uploads = ();

    # Collect the info we need to repackage it in a consistent way
    FILE:
    for my $key ( @file_keys ) {
        # First take a closer look at this "blah-blah handle"
        my $file_handle = shift @file_handles;

        # undef would mean there was an upload error (timeout perhaps)
        # Following HTTP POST logic, when one upload breaks, that
        # would mean all subsequent uploads in this POST are also
        # broken.
        # We can't recover from that so just stop trying.
        last FILE unless defined $file_handle;

        # In CGI.pm < 3.41, "lightweight handle" object doesn't support
        # returning IO::Handle so we do it manually to avoid problems
        my $io_handle = IO::Handle->new_from_fd(fileno $file_handle, '<');

        # We also need a lot of info about the file (if provided)
        my $upload_info = $cgi->uploadInfo($key);
        my $temp_file   = $cgi->tmpFileName($key);
        my $file_type   = $upload_info->{'Content-Type'};
        my $file_name   = $self->_get_file_name($upload_info);
        my $file_size   = $self->_get_file_size($io_handle);
        my $base_name   = basename($file_name);

        # Now instead of a "blah-blah handle" we have a normalized hashref
        push @uploads, {
            type     => $file_type,
            size     => $file_size,
            path     => $temp_file,
            handle   => $io_handle,
            basename => $base_name,
            filename => $file_name,
        };
    };

    return @uploads;
}

### PRIVATE INSTANCE METHOD ###
#
# Tries hard to extract file name from multipart form guts
#

sub _get_file_name {
    my ($self, $upload_info) = @_;

    # Pluck file name from Content-Disposition string
    my ($file_name)
        = $upload_info->{'Content-Disposition'} =~ /filename="(.*?)"/;

    # URL unescape it
    $file_name =~ s/%([\dA-Fa-f]{2})/pack("C", hex $1)/eg;

    return $file_name;
}

### PRIVATE INSTANCE METHOD ###
#
# Enquiries IO::Handle supplied by CGI for file size
#

sub _get_file_size {
    my ($self, $handle) = @_;

    # Fall through in case $handle is invalid
    return unless $handle;

    return ($handle->stat)[7];
}

1;