File Coverage

blib/lib/DBIx/BLOB/Handle.pm

Criterion	Covered	Total	%
statement	23	123	18.7
branch	1	46	2.1
condition	0	31	0.0
subroutine	8	17	47.0
pod	1	1	100.0
total	33	218	15.1

package DBIx::BLOB::Handle;

use base qw( IO::Handle IO::Seekable );
use strict;
use vars qw( $VERSION );
use warnings;
use Symbol;
use DBI;

$VERSION = '0.2';

sub import {
    my $class = shift;
    if( grep { $_ eq ':INTO_STATEMENT' } @_ ){
        # Danger! Pretend the DBI statement class can provide blobs as handles
        no warnings;
        *DBI::st::blob_as_handle = sub {
            return "$class"->new(@_);
        };
    }
}

# required is the DBI statement
# optional is the 0 based column index that contains the blob (default = 0)
# optional is the blocksize to be read from the database (default = 4096)
sub new {
	my($self, $sth, $field, $blocksize) = @_;
    $self = ref $self || $self;
    my $s = Symbol::gensym;
    tie $$s,$self,$sth,$field,$blocksize;
    return bless $s, $self;
}

sub TIEHANDLE {
    my $class = shift;
    return bless {sth       => shift
                 ,field     => shift || 0
                 ,blocksize => shift || 4096
                 ,pos       => 0
                 ,eof       => 0
                 ,line      => undef
                 ,lines_ref => []
                 },$class;
}

sub READLINE {
    my $self = shift;
    my $buf;
    ( my $sep = $/ ) ||= '';
    unless( $sep ){ # more efficient if we want to slurp the whole lot
        my @frags;
        while( ! $self->{eof} ){
            READ($self, $buf);
            last if $self->{eof};
            push @frags, $buf;
        }
        $. = ++$self->{line};
        wantarray ? return ( join('',@frags) ) : return join('',@frags);
    }
    elsif(wantarray){
        while( ! $self->{eof} ){
            READ($self,$buf);
            my $lines = pop( @{$self->{lines_ref}} ) . $buf;
            push @{$self->{lines_ref}}, $lines =~ /(.*?$sep|.+)/gs;
        }
        $. = $self->{line} = scalar @{$self->{lines_ref}};
        return @{ delete $self->{lines_ref} };
    }else{
        while(1){
            if( ( @{$self->{lines_ref}} > 1 ) || $self->{eof} ){
                $. = ++$self->{line} if @{$self->{lines_ref}};
                return shift @{$self->{lines_ref}};
            }
            READ($self,$buf);
            my $lines = pop( @{$self->{lines_ref}} ) . $buf;
            push @{$self->{lines_ref}}, $lines =~ /(.*?$sep|.+)/gs;
        }
    }
}

sub TELL {
    return $_[0]->{pos};
}

sub EOF {
    return $_[0]->{eof};
}

sub GETC {
    my $self = shift;
    my($len,$buf) = (0,'');
    $self->{sth}->blob_read($self->{field}, $self->{pos}, 1,\$buf);
    $len = length $buf;
    if( $len ){
        $self->{pos} += $len;
        return $buf;
    }else{
        $self->{eof} = 1;
        return undef;
    }
}

sub READ {
    my($self,undef,$length,$offset) = @_;
    $length ||= $self->{blocksize} unless defined $length;
    die "Negative length" unless $length >= 0; # like the built in read does
    $offset ||= 0;
    if( defined($_[1]) && ( ( $offset > length($_[1]) ) || ( $offset < 0 ) ) ){
        die "Offset outside string"; # like the built in read does
    }
    my($len,$buf) = (0,'');
    $self->{sth}->blob_read($self->{field}, $self->{pos}, $length,\$buf);
# The 5 argument form of blob_read appears to be broken
# (dies when called as such) otherwise we could do
# $h->blob_read($field, $offset, $len [, \$buf [, $bufoffset]])
# and then we wouldn't have to do the substring manipulation of $_[1]
    $len = length $buf;
    if($len){
        $self->{pos} += $len;
    }else{
        $self->{eof} = 1;
    }
    $_[1] ||= ''; # avoids substr error
    substr($_[1],$offset) = $buf;
    return $len;
}

sub SEEK {
    my($self,$offset,$whence) = @_;
    if( $whence == IO::Seekable::SEEK_SET() ){
        if( $offset > 0 ){
            if( $offset > $self->{pos} ){
                $offset -= $self->{pos};
                while( ! $self->{eof} && ( $self->{pos} < $offset ) ){
                    READ($self, undef, undef);
                }
                if( $offset < $self->{pos} ){
                    $self->{pos} = $offset;
                    $self->{eof} = 0;
                }
            }else{
                $self->{pos} = $offset;
                $self->{eof} = 0;
            }
        }else{
            $self->{pos} = 0;
            $self->{eof} = 0;
        }
    }
    elsif( $whence == IO::Seekable::SEEK_CUR() ){
        if( $offset < 0 ){
            $self->{pos} += $offset;
            $self->{pos} = 0 if $self->{pos} < 0;
            $self->{eof} = 0;
        }else{
            my $seekto = $self->{pos} + $offset;
            while( ! $self->{eof} && ( $self->{pos} < $seekto ) ){
                READ($self, undef, undef);
            }
            if( $seekto < $self->{pos} ){
                $self->{pos} = $seekto;
                $self->{eof} = 0;
            }
        }
    }
    elsif( $whence == IO::Seekable::SEEK_END() ){
        while( ! $self->{eof} ){
            READ($self, undef, undef);
        }
        if( $offset < 0 ){
            $self->{eof} = 0; # reset eof
            $self->{pos} += $offset;
            $self->{pos} = 0 if $self->{pos} < 0;
        }
    }
    return $self->{pos}; # tell
}

1;

__END__