File Coverage

blib/lib/HTTP/Body/Builder/MultiPart.pm

Criterion	Covered	Total	%
statement	66	75	88.0
branch	13	20	65.0
condition			n/a
subroutine	14	15	93.3
pod	5	7	71.4
total	98	117	83.7

package HTTP::Body::Builder::MultiPart;
use strict;
use warnings;
use utf8;
use 5.008_005;

use File::Basename ();

my $CRLF = "\015\012";

sub new {
    my $class = shift;
    my %args = @_==1 ? %{$_[0]} : @_;
    my $content = delete $args{content};
    my $files = delete $args{files};
    my $self = bless {
        boundary => 'xYzZY',
        buffer_size => 2048,
        %args
    }, $class;
    if ($content) {
        for my $key (keys %{$content}) {
            for my $value (ref $content->{$key} ? @{$content->{$key}} : $content->{$key}) {
                $self->add_content($key => $value);
            }
        }
    }
    if ($files) {
        for my $name (keys %{$files}) {
            $self->add_file($name => $files->{$name});
        }
    }
    return $self;
}

sub add_content {
    my ($self, $name, $value) = @_;
    push @{$self->{content}}, [$name, $value];
}

sub add_file {
    my ($self, $name, $filename) = @_;
    push @{$self->{file}}, [$name, $filename];
}

sub content_type {
    my $self = shift;
    return 'multipart/form-data';
}

sub _gen {
    my ($self, $code) = @_;

    for my $row (@{$self->{content}}) {
        $code->(join('', "--$self->{boundary}$CRLF",
            qq{Content-Disposition: form-data; name="$row->[0]"$CRLF},
            "$CRLF",
            $row->[1] . $CRLF
        ));
    }
    for my $row (@{$self->{file}}) {
        my $filename = File::Basename::basename($row->[1]);
        $code->(join('', "--$self->{boundary}$CRLF",
            qq{Content-Disposition: form-data; name="$row->[0]"; filename="$filename"$CRLF},
            "Content-Type: text/plain$CRLF",
            "$CRLF",
        ));
        open my $fh, '<:raw', $row->[1]
            or do {
            $self->{errstr} = "Cannot open '$row->[1]' for reading: $!";
            return;
        };
        my $buf;
        while (1) {
            my $r = read $fh, $buf, $self->{buffer_size};
            if (not defined $r) {
                $self->{errstr} = "Cannot open '$row->[1]' for reading: $!";
                return;
            } elsif ($r == 0) { # eof
                last;
            } else {
                $code->($buf);
            }
        }
        $code->($CRLF);
    }
    $code->("--$self->{boundary}--$CRLF");
    return 1;
}

sub as_string {
    my ($self) = @_;
    my $buf = '';
    $self->_gen(sub { $buf .= $_[0] })
        or return;
    $buf;
}

sub errstr { shift->{errstr} }

sub write_file {
    my ($self, $filename) = @_;

    open my $fh, '>:raw', $filename
        or do {
        $self->{errstr} = "Cannot open '$filename' for writing: $!";
        return;
    };
    $self->_gen(sub { print {$fh} $_[0] })
        or return;
    close $fh;
}

1;
__END__