File Coverage

blib/lib/PerlIO/via/Limit.pm

Criterion	Covered	Total	%
statement	50	50	100.0
branch	16	18	88.8
condition	1	3	33.3
subroutine	11	11	100.0
pod	1	3	33.3
total	79	85	92.9

package PerlIO::via::Limit;

use strict;
use warnings;
use vars qw($VERSION);
$VERSION = '0.04';

our @ISA;
unshift @ISA, qw(Class::Data::Inheritable);

use Exception::Class ('PerlIO::via::Limit::Exception');

__PACKAGE__->mk_classdata('length');
__PACKAGE__->mk_classdata('sensitive');

sub import {
    my ($class, %params) = @_;
    $class->$_( $params{$_} ) for keys %params;
}

my $create_count = 0;
sub create {
    my ($class, $len, $new_class) = @_;

    $new_class = sprintf('%s::_%s', __PACKAGE__, ++$create_count)
        unless( defined $new_class );

    no strict 'refs';
    @{"$new_class\::ISA"} = __PACKAGE__;

    $new_class->length($len);
    return $new_class;
}

sub PUSHED {
    my ($class, $mode, $fh) = @_;
    return bless {current => 0, reached => 0}, $class;
}

sub FILL {
    my ($obj, $fh) = @_;

    if( $obj->{reached} ){
        if( $obj->sensitive ){
            PerlIO::via::Limit::Exception
            ->throw( error => "$fh is trying to read exceeding the limit." );
        }
        return undef;
    }

    my $buf = <$fh>;

    if( defined $buf ){
        $obj->{current} += CORE::length $buf;
        $obj->_check(\$buf);
    }

    return $buf;
}

sub WRITE {
    my ($obj, $buf, $fh) = @_;
    return 0 if( $obj->{reached} or ! defined $buf );

    $obj->{current} += CORE::length $buf;
    $obj->_check(\$buf);

    print $fh $buf;

    if( $obj->{reached} ){
        if( $obj->sensitive ){
            PerlIO::via::Limit::Exception
            ->throw( error => "$fh is trying to write exceeding the limit." );
        }
    }

    return CORE::length $buf;
}

sub _check {
    my ($obj, $ref_buf) = @_;
    if( defined(my $len = $obj->length) ){
        my $over = $obj->{current} - $len;
        if( 0 <= $over ){
            $obj->{reached} = 1;
            substr($$ref_buf, $over * -1, $over, q{});
            # another expression:
            # $$ref_buf = substr( $$ref_buf, 0, CORE::length($$ref_buf) - $over );
        }
    }
}


1;
__END__