File Coverage

blib/lib/FU/MultipartFormData.pm

Criterion	Covered	Total	%
statement	61	89	68.5
branch	25	52	48.0
condition	3	12	25.0
subroutine	12	16	75.0
pod	12	12	100.0
total	113	181	62.4

package FU::MultipartFormData 1.4;
use v5.36;
use Carp 'confess';
use FU::Util 'utf8_decode';

sub _arg($d) { $d =~ s{^"(.+)"$}{$1 =~ s/\\([\\"])/$1/rg}er }

sub parse($pkg, $header, $data) {
    confess "Invalid multipart header '$header'"
        if $header !~ m{^multipart/form-data\s*;\s*boundary\s*=(.+)$};
    my $boundary = _arg $1;
    confess "Invalid multipart boundary '$boundary'" if $boundary !~ /^[\x21-\x7e]+$/;
    utf8::encode($boundary);

    my @a;
    while ($data =~ m{--\Q$boundary\E(?:--\r\n|\r\n((?:.+\r\n)+)\r\n)}xg) {
        my $hdrs = $1;
        $a[$#a]{length} = $-[0] - 2 - $a[$#a]{start} if @a;
        if (!$hdrs) {
            confess "Trailing garbage" if pos $data != length $data;
            last;
        }

        my $d = bless {
            data => $data,
            start => pos $data,
        }, $pkg;

        confess "Missing content-disposition header" if $hdrs !~ /content-disposition:\s*form-data(.+)/i;
        my $v = $1;
        my $pvalue = qr/("(?:\\[\\"]|[^\\"\r\n]+)*"|[^\s;"]*)/;
        confess "Missing 'name' parameter" if $v !~ /;\s*name\s*=\s*$pvalue/;
        $d->{name} = utf8_decode _arg $1;
        $d->{filename} = utf8_decode _arg $1 if $v =~ /;\s*filename\s*=\s*$pvalue/;

        if ($hdrs =~ /content-type:\s*$pvalue(?:\s*;\s*charset\s*=\s*$pvalue)?/i) {
            $d->{mime} = utf8_decode _arg $1;
            $d->{charset} = utf8_decode _arg $2 if $2;
        }
        push @a, $d;
    }
    confess "Missing end-of-data marker" if @a && !defined $a[$#a]{length};
    \@a
}

sub name     { $_[0]{name} }
sub filename { $_[0]{filename} }
sub mime     { $_[0]{mime} }
sub charset  { $_[0]{charset} }
sub length   { $_[0]{length} }

sub substr($o,$off,$len=undef) {
    $off += $o->{length} if $off < 0;
    $off = 0 if $off < 0;
    $off = $o->{length} if $off > $o->{length};

    $len //= $o->{length} - $off;
    $len += $o->{length} - 1 if $len < 0;
    $len = 0 if $len < 0;
    $len = $o->{length} - $off if $len > $o->{length} - $off;

    substr $o->{data}, $o->{start} + $off, $len;
}

sub data     { $_[0]->substr(0) }
sub value    { utf8_decode $_[0]->data }

sub syswrite($o, $fh) {
    my $off = $o->{start};
    my $end = $o->{start} + $o->{length};
    while ($off < $end) {
        my $r = syswrite $fh, $o->{data}, $end-$off, $off;
        return if !defined $r;
        $off += $r;
    }
    $o->{length};
}

sub save($o, $fn) {
    open my $F, '>', $fn or confess "Error opening '$fn': $!";
    defined $o->syswrite($F) or confess "Error writing to '$fn': $!";
}

sub describe($o) {
    my $head = eval { utf8_decode $o->substr(0, 100) };
    if (defined $head && $head =~ /\n/) {
        ($head) = split /\n/, $head, 2;
        $head .= '...';
    } elsif (defined $head && $o->{length} > 100) {
        $head .= '...';
    }
    $o->{name}.': '.join ' ',
        $o->{filename} ? "filename=$o->{filename}" : (),
        $o->{mime} ? "mime=$o->{mime}" : (),
        $o->{charset} ? "charset=$o->{charset}" : (),
        "length=$o->{length}",
        defined $head ? "value=$head" : ();
}

1;
__END__