File Coverage

blib/lib/Plack/App/CGIBin/Streaming/Request.pm

Criterion	Covered	Total	%
statement	112	117	95.7
branch	25	28	89.2
condition	1	3	33.3
subroutine	23	27	85.1
pod	5	6	83.3
total	166	181	91.7

package Plack::App::CGIBin::Streaming::Request;

use 5.014;
use strict;
use warnings;
no warnings 'uninitialized';
use Carp;

my %trace=
   (
    # new=>sub {warn "NEW: @_"},
    # header=>sub {warn "HEADER: @_"},
    # flush=>sub {warn "FLUSH: @_"},
    # status_out=>sub {warn "STATUS OUT: @_"},
    # content=>sub {warn "CONTENT: @_"},
    # finalize_start=>sub {warn "FINALIZE START: @_"},
    # finalize_end=>sub {warn "FINALIZE END: @_"},
   );
use constant TRACE=>0; do {
    no warnings 'void';
    sub {
        my $what=shift;
        local $SIG{__WARN__};
        $trace{$what} and $trace{$what}->(@_);
    };
};

our @attr;

our $DEFAULT_CONTENT_TYPE='text/plain';
our $DEFAULT_MAX_BUFFER=8000;

BEGIN {
    @attr=(qw/env responder writer _buffer _buflen _headers max_buffer
              content_type filter_before filter_after on_status_output
              parse_headers _header_buffer status notes on_flush on_finalize
              suppress_flush binmode_ok/);
    for (@attr) {
        my $attr=$_;
        no strict 'refs';
        *{__PACKAGE__.'::'.$attr}=sub : lvalue {
            my $I=$_[0];
            $I->{$attr}=$_[1] if @_>1;
            $I->{$attr};
        };
    }
}

sub new {
    my $class=shift;
    $class=ref($class) || $class;
    my $self=bless {
                    content_type=>$DEFAULT_CONTENT_TYPE,
                    max_buffer=>$DEFAULT_MAX_BUFFER,
                    filter_before=>sub{},
                    filter_after=>sub{},
                    on_status_output=>sub{},
                    on_flush=>sub{},
                    on_finalize=>sub{},
                    notes=>+{},
                    _headers=>[],
                    _buffer=>[],
                    _buflen=>0,
                    status=>200,
                   }, $class;

    for( my $i=0; $i<@_; $i+=2 ) {
        my $method=$_[$i];
        $self->$method($_[$i+1]);
    }

    if (TRACE) {
        (ref(TRACE) eq 'CODE'
         ? TRACE->(new=>$self)
         : warn "NEW $self");
    }

    return $self;
}

sub print_header {
    my $self = shift;

    croak "KEY => VALUE pairs expected" if @_%2;
    croak "It's too late to set a HTTP header" if $self->{writer};

    if (TRACE) {
        (ref(TRACE)
         ? TRACE->(header=>$self, @_)
         : warn "print_header $self: @_");
    }

    push @{$self->{_headers}}, @_;
}

sub print_content {
    my $self = shift;

    if ($self->{parse_headers}) {
        $self->{_header_buffer}.=join('', @_);
        while( $self->{_header_buffer}=~s/\A(\S+)[ \t]*:[ \t]*(.+?)\r?\n// ) {
            my ($hdr, $val)=($1, $2);
            if ($hdr=~/\Astatus\z/i) {
                $self->{status}=$val;
            } elsif ($hdr=~/\Acontent-type\z/i) {
                $self->{content_type}=$val;
            } else {
                $self->print_header($hdr, $val);
            }
        }
        if ($self->{_header_buffer}=~s/\A\r?\n//) {
            delete $self->{parse_headers}; # done
            $self->print_content(delete $self->{_header_buffer})
                if length $self->{_header_buffer};
        }
        return;
    }

    my @data=@_;
    $self->{filter_before}->($self, \@data);

    my $len = 0;
    $len += length $_ for @data;

    if (TRACE) {
        (ref(TRACE)
         ? TRACE->(content=>$self, @data)
         : warn "print_content $self: $len bytes");
    }

    push @{$self->{_buffer}}, @data;
    $len += $self->{_buflen};
    $self->{_buflen}=$len;

    if ($len > $self->{max_buffer}) {
        local $self->{suppress_flush};
        $self->flush;
    }

    $self->filter_after->($self, \@data);
}

sub _status_out {
    my $self = shift;
    my $is_done = shift;

    if (TRACE) {
        (ref(TRACE)
         ? TRACE->(status_out=>$self, $is_done)
         : warn "status_out $self: $self->{status}");
    }

    $self->print_header('Content-Type', $self->{content_type});
    $self->print_header('Content-Length', $self->{_buflen})
        if $is_done;
    $self->on_status_output->($self);

    $self->{writer}=$self->{responder}->([$self->{status},
                                          $self->{_headers},
                                          $is_done ? $self->{_buffer}: ()]);
}

sub status_written {
    my $self = shift;
    return !!$self->{writer};
}

sub flush {
    my $self = shift;
    return 0 unless @{$self->{_buffer}};

    if (TRACE) {
        (ref(TRACE)
         ? TRACE->(flush=>$self)
         : warn "flush $self");
    }

    $self->_status_out unless $self->{writer};

    $self->{writer}->write(join '', @{$self->{_buffer}});
    @{$self->{_buffer}}=();
    $self->{_buflen}=0;

    $self->{on_flush}->($self);

    return 0;
}

sub finalize {
    my $self = shift;

    if (TRACE) {
        (ref(TRACE)
         ? TRACE->(finalize_start=>$self)
         : warn "finalize start $self");
    }

    $self->{on_finalize}->($self);
    if ($self->{writer}) {
        $self->{writer}->write(join '', @{$self->{_buffer}});
        $self->{writer}->close;
    } else {
        $self->_status_out(1);
    }

    if (TRACE) {
        (ref(TRACE)
         ? TRACE->(finalize_end=>$self)
         : warn "finalize end $self");
    }

    %$self=();
    bless $self, 'Plack::App::CGIBin::Streaming::Request::Demolished';
}

package                         # prevent CPAN indexing
    Plack::App::CGIBin::Streaming::Request::Demolished;
use strict;

sub AUTOLOAD {
    our $AUTOLOAD;
    die "Calling $AUTOLOAD on a demolished request.";
}

sub flush {}
sub finalize {}
sub DESTROY {}

1;

__END__