富豪的 multipart/form-data スキャナ

既にメモリ中のバッファに全 POST データを読み取った後に使うことを考えて、そのデータを対象とする multipart/form-data スキャナを書いてみます。

multipart/form-data は正規文法なので、構文を正規表現で表せます。今の Perl5 のキャプチャ機構では実用上の意味はありませんけど、全体にマッチする正規表現は次のようになります。postdata は読み取った POST データ、boundary は Content-Type ヘッダに記入されている境界の文字列です。各パートはハイフン 2 個に boundary を続けた境界で区切られており、最後の境界は boundary の後ろにもハイフン 2 個がくっつきます。行末記号はすべて CRLF です。

use 5.016;
use Carp;

my $CRLF = "\x0d\x0a";

sub match_multipart_form_data {
    my($postdata, $boundary) = @_;
    $boundary = quotemeta $boundary;
    my $crlf = quotemeta $CRLF;
    my $pattern = qr{
        \A --$boundary $crlf
        (?: (?<header> (?:[^$crlf]+ $crlf)+ )
            $crlf
            (?<body> .*?) $crlf
            --$boundary $crlf
        )*
        (?<header> (?:[^$crlf]+ $crlf)+ )
        $crlf
        (?<body> .*?) $crlf
        --$boundary-- $crlf
    }msx;
    if ($postdata =~ $pattern) {
        return 'ok';
    }
    croak '400 Bad Request';
}

キャプチャするべきは、各パートごとにヘッダ、ボディ、そして最後の境界の 3 つです。上の全体にマッチする正規表現をばらして、各パートごとにスキャンを繰り返すように書き換えたものは次のようになります。

use 5.016;
use Carp;
use English qw(-no_match_vars);

my $CRLF = "\x0d\x0a";

sub scan_multipart_form_data {
    my($postdata, $boundary) = @_;
    $boundary = quotemeta $boundary;
    my $crlf = quotemeta $CRLF;
    my @result;
    $postdata =~ m/\G--$boundary$crlf/gcmsx or croak '400 Bad Request';
    my $pattern = qr{
        (?<header> (?:[^$crlf]+ $crlf)+ )
        $crlf
        (?<body> .*?) $crlf
        --$boundary (?<endmark> --)? $crlf
    }msx;
    while ($postdata =~ m/\G$pattern/gcmsx) {
        my($header, $body, $endmark) = @LAST_PAREN_MATCH{qw(header body endmark)};
        push @result, [$header, $body, $endmark];
        last if $endmark;
    }
    return @result;
}

form データのフィールド名は各パートの Content-Disposition ヘッダに記入されているので、拾いださなければなりません。そのために、ヘッダごと1行に変形しておいてから、Content-Disposition ヘッダから name と filename フレーズをとりだします。とりだした値は MIME-Header でデコードしておきます。ボディは、アップロードされたものとそうでないもので扱いを変えます。アップロードされたものは、ここでは PSGI レスポンスに似た配列リファレンスに変形しています。そうでないものは UTF-8 デコードしたスカラーにします。

use strict;
use warnings;
use Carp;
use Encode;
use English qw(-no_match_vars);

my $CRLF = "\x0d\x0a";
my $FBCROAK = Encode::FB_CROAK|Encode::LEAVE_SRC;
my $HEADERPHRASE = qr/"([^"]*)"|([^\s;]*)/msx;

sub scan_multipart_form_data {
    my($postdata, $boundary, %opt) = @_;
    my $enable_upload = $opt{'enable_upload'};
    my $max_params = $opt{'max_params'} || 256;
    $boundary = quotemeta $boundary;
    my $crlf = quotemeta $CRLF;
    my @result;
    my $nparam = 0;
    $postdata =~ m/\G--$boundary$crlf/gcmsx or croak '400 Bad Request';
    my $pattern = qr{
        ((?:[^$crlf]+ $crlf)+)
        $crlf
        (.*?) $crlf
        --$boundary(--)? $crlf
    }msx;
    while ($postdata =~ m/\G$pattern/gcmsx) {
        croak '400 Bad Request' if ++$nparam > $max_params;
        my($header, $body, $endmark) = ($1, $2, $3);
        $header =~ s/$crlf([ \t]+)?/$1 ? q( ) : "\n"/egmsx;
        my %dispos;
        if ($header =~ m/^Content-Disposition:[ \t]*form-data;([^\n]+)/msx) {
            my $s = $1;
            while ($s =~ m/[ \t]+((?:file)?name)=$HEADERPHRASE/gmsx) {
                my($k, $v) = ($1, $LAST_PAREN_MATCH);
                $dispos{$k} = decode('MIME-Header', $v, $FBCROAK);
            }
        }
        croak '400 Bad Request' if ! defined $dispos{'name'};
        if (defined $dispos{'filename'}) {
            croak '400 Bad Request' if ! $enable_upload;
            $body = [
                $dispos{'filename'},
                [map { split /:[ \t]*/msx, $_, 2 } split /\n/msx, $header],
                [$body],
            ];
        }
        else {
            $body = decode('UTF-8', $body, $FBCROAK);
        }
        push @result, $dispos{'name'}, $body;
        last if $endmark;
    }
    return @result;
}