File Coverage

blib/lib/CGI/Easy/SendFile.pm

Criterion	Covered	Total	%
statement	83	83	100.0
branch	26	30	86.6
condition	31	33	93.9
subroutine	15	15	100.0
pod	1	1	100.0
total	156	162	96.3

package CGI::Easy::SendFile;
use 5.010001;
use warnings;
use strict;
use utf8;
use Carp;

our $VERSION = 'v2.0.1';

use Export::Attrs;
use List::Util qw( min );
use CGI::Easy::Util qw( date_http );

use constant STAT_MTIME => 9;
use constant BUF_SIZE   => 64*1024;


sub send_file :Export {
    my ($r, $h, $file, $opt) = @_;
    my %p = (
        type    => 'application/x-download',
        range   => !ref $file,
        cache   => 0,
        inline  => 0,
        %{$opt || {}},
    );

    if (!$p{cache}) {
        $h->{'Expires'} = 'Sat, 01 Jan 2000 00:00:00 GMT';
    }
    else {
        delete $h->{'Expires'};
        if (!ref $file) {
            my $lastmod = date_http((stat $file)[STAT_MTIME]);
            my $ifmod = $r->{ENV}{HTTP_IF_MODIFIED_SINCE};
            if ($ifmod && $ifmod eq $lastmod) {
                $h->{'Status'} = '304 Not Modified';
                return \q{};
            }
            else {
                $h->{'Last-Modified'} = $lastmod;
            }
        }
    }

    my $len = ref $file ? length ${$file} : -s $file;
    my ($start, $end) = _get_range($p{range}, $r, $len);
    my $size = $end-$start+1;

    $h->{'Accept-Ranges'}       = 'bytes';
    $h->{'Content-Length'}      = $size;
    $h->{'Content-Type'}        = $p{type};
    if (!$p{inline}) {
        $h->{'Content-Disposition'} = 'attachment';
    }
    if (!($start == 0 && $end == $len-1)) {
        $h->{Status}            = '206 Partial Content';
        $h->{'Content-Range'}   = "bytes $start-$end/$len";
    }

    return _read_block($file, $start, $size);
}

sub _get_range {
    my ($allow_range, $r, $len) = @_;
    my ($start, $end) = (0, $len-1);
    if ($allow_range && defined $r->{ENV}{HTTP_RANGE}) {
        if ($r->{ENV}{HTTP_RANGE} =~ /\Abytes=(\d*)-(\d*)\z/ixms) {
            my ($from, $to) = ($1, $2);
            if ($from ne q{} && $to ne q{} && $from <= $to && $to < $len) { # 0-0, 0-499, 500-999
                $start  = $from;
                $end    = $to;
            }
            elsif ($from ne q{} && $to eq q{} && $from < $len) {            # 0-, 500-, 999-
                $start  = $from;
            }
            elsif ($from eq q{} && $to ne q{} && 0 < $to && $to <= $len) {  # -1, -500, -1000
                $start  = $len - $to;
            }
        }
    }
    return ($start, $end);
}

sub _read_block {
    my ($file, $start, $size) = @_;
    my $data = q{};
    open my $fh, '<', $file or croak "open: $!";
    seek $fh, $start, 0;
    my ($n, $buf);
    while ($n = read $fh, $buf, min($size, BUF_SIZE)) {
        $size -= length $buf;
        $data .= $buf;
    }
    croak "read: $!" if !defined $n;
    close $fh or croak "close: $!";
    return \$data;
}


1; # Magic true value required at end of module
__END__