読者です 読者をやめる 読者になる 読者になる

HTTP::Engine::MinimalCGI で upload の挙動を他の interface と合わせる

perl

MinimalCGI だと $request->upload が CGI::Simple->upload の wrapper になっているので、他の interface みたいに HTTP::Engine::Request::Upload オブジェクトを返すようにしたかった。
まったく同じにはできなかったけど。

  • 同じ name の input (type=file) があると一つしか扱えない
  • upload->headers が空っぽ
{
    package # hide from pause
        HTTP::Engine::Request;
    use HTTP::Engine::Request::Upload;

    $CGI::Simple::DISABLE_UPLOADS = 0;
    $CGI::Simple::POST_MAX        = 1024 * 1024 * 10;

    sub uploads {
        my $self = shift;
        $self->{uploads} ||= $self->_prepare_uploads;
    }

    sub upload {
        my $self = shift;
        return keys %{ $self->uploads } if @_ == 0;

        if (@_ == 1) {
            my $upload = shift;
            return wantarray ? () : undef unless exists $self->uploads->{$upload};
            return (wantarray)
                ? ( $self->uploads->{$upload} )
                : $self->uploads->{$upload};
        }
    }

    sub _prepare_uploads {
        my $self = shift;

        $self->{cs} ||= CGI::Simple->new();
        my $q = $self->{cs};

        my %uploads;
        for my $name ( keys %{ $q->{".upload_fields"} } ) {
            my $filename = $q->{".upload_fields"}->{$name};
            my $headers = HTTP::Headers::Fast->new();
            $uploads{$name}
                = HTTP::Engine::Request::Upload->new(
                    headers  => $headers,
                    fh       => $q->upload($filename),
                    size     => $q->upload_info($filename, 'size'),
                    filename => $filename,
                );
        }
        return \%uploads;
    }
}

{
    package # hide from pause
        HTTP::Engine::Request::Upload;
    no warnings "redefine";
    sub copy_to {
        my $self = shift;
        require File::Copy;
        File::Copy::copy( ($self->tempname || $self->fh), @_ );
    }
}