view release on metacpan or  search on metacpan

lib/HTTP/Range.pm  view on Meta::CPAN

sub split
{
    my $class = shift;
 
    my %args = validate( @_,
        {
            request => {
                type        => OBJECT,
                isa         => 'HTTP::Request',
            },
            length => {
                type        => SCALAR,
                callbacks   => {
                    'length is > 0'         => sub { $_[0] > 0 },
                    'length is + integer'   => sub { $_[0] =~ /^\d+$/ },
                },
            },
            segments => {
                type        => SCALAR,
                default     => 4,
                callbacks   => {
                    'segments is > 1'       => sub { $_[0] > 1 },
                    'segments is + integer' => sub { $_[0] =~ /^\d+$/ },
                    'segments is <= length' => sub { $_[0] <= $_[1]->{ 'length' } },
                },
            },
        },
    );

    # size of byte range per requested segment
    $args{ 'seg_size' } = int ( $args{ 'length' } / $args{ 'segments' } );

    # if the length is not evenly divisible by the number of segments we have to 
    # account for the leftover bytes
    $args{ 'seg_extras' } = $args{ 'length' } % $args{ 'segments' };

    # total number of bytes to process
    $args{ 'len_remain' } = $args{ 'length' };

    my @requests;
    while ( $args{ 'len_remain' } || $args{ 'seg_extras' } ) {
        # size of this segment
        my $seg_len = $args{ 'seg_size' };

        # do we have extra bytes?
        if ( $args{ 'seg_extras' } ) {
            $seg_len++;
            $args{ 'seg_extras' }--;
        }

        # offset into length
        $args{ 'len_index' } = $args{ 'length' } - $args{ 'len_remain' };
        
        # bytes remaining
        $args{ 'len_remain' } -= $seg_len;

        # copy the request object - this must be a deep clone
        my $req = $args{ 'request' }->clone;

        # start-end of byte offset for this segment
        $req->header( Range => "bytes=$args{ 'len_index' }-"
                . ( $args{ 'len_index' } + $seg_len - 1 ) );

        push( @requests, $req );
    }

    return( wantarray ? @requests : \@requests );
}

sub join
{
    my $class = shift;
 
    my %args = validate( @_,
        {
            responses => {
                type        => ARRAYREF,
            },
            length => {
                type        => SCALAR,
                optional    => 1,
                callbacks   => {
                    'length is > 0'         => sub { shift > 0 },
                    'length is + integer'   => sub { $_[0] =~ /^\d+$/ },
                },
            },
            segments => {
                type        => SCALAR,
                optional    => 1,
                callbacks   => {
                    'segments is > 1'           => sub { $_[0] > 1 },
                    'segments is + integer'     => sub { $_[0] =~ /^\d+$/ },
                    'segments is == responses'  => sub {
                        $_[0] == @{ $_[1]->{ 'responses' } };
                    },
                    'segments is <= length'     => sub {
                        if ( $_[1]->{ 'length' } ) {
                            return $_[0] <= $_[1]->{ 'length' };
                        } else {
                            return 1;
                        }
                    },
                },
            },
        },
    );

    # validate each object in the responses arrayref
    foreach my $res ( @{ $args{ 'responses' } } ) {
        croak "not isa HTTP::Response" unless isa( $res, 'HTTP::Response' );
        croak "not a successful HTTP status" unless HTTP::Status::is_success( $res->code );
        croak "multi-part messages are not supported" if @{[ $res->parts ]};
        croak "segment has invalid content length" unless length $res->content == $res->content_length;
    }

    # scalar w/ IO::Handle interface to hold the reassembled segments
    my $content = IO::String->new;

    # set of content ranges processed
    my @ranges;