File Coverage

blib/lib/IO/BLOB/Pg.pm

Criterion	Covered	Total	%
statement	18	218	8.2
branch	0	92	0.0
condition	0	26	0.0
subroutine	6	34	17.6
pod	5	23	21.7
total	29	393	7.3

package IO::BLOB::Pg;

# Copyright 2000 Mark A. Hershberger
#
# This library is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.

require 5.005_03;
use strict;
use vars qw($VERSION $DEBUG $IO_CONSTANTS);
$VERSION = "0.91";  # $Date: 2002/08/12 06:14:57 $

use Symbol ();
use Carp;
use IO::Handle;

my $SEEK_SET = &IO::Handle::SEEK_SET;
my $SEEK_END = &IO::Handle::SEEK_END;

sub new
{
  my $class = shift;
  my $self = bless Symbol::gensym(), ref($class) || $class;

  tie *$self, $self;
  return $self->open(@_) ? $self : undef;
}

sub open
{
  my $self = shift;
  return $self->new(@_) unless ref($self);

  if (@_ == 2) {
    *$self->{dbi} = $_[0];
    *$self->{id}  = $_[1];
  } elsif(@_ == 1) {
    *$self->{dbi} = $_[0];
    *$self->{id}  = *$self->{dbi}->func(*$self->{dbi}->{pg_INV_READ} |
					*$self->{dbi}->{pg_INV_WRITE}, "lo_creat");
  } else {
    croak "open \$DBI[, \$id]";
  }
  croak "AutoCommit needs to be off"
    if *$self->{dbi}->{AutoCommit};
  *$self->{fh}  = *$self->{dbi}->func(*$self->{id},
				      *$self->{dbi}->{pg_INV_READ} |
				      *$self->{dbi}->{pg_INV_WRITE}, "lo_open");

  if(not defined *$self->{fh} || not defined *$self->{id}) {
    return undef;
  }
  *$self->{pos} = 0;
  *$self->{lno} = 0;

  $self;
}

sub oid {
  my $self = shift;
  return *$self->{id};
}

sub pad {
  my $self = shift;
  my $old = *$self->{pad};
  *$self->{pad} = substr($_[0], 0, 1) if @_;
  return "\0" unless defined($old) && length($old);
  $old;
}

sub dump
{
    require Data::Dumper;
    my $self = shift;
    print Data::Dumper->Dump([$self], ['*self']);
    print Data::Dumper->Dump([*$self{HASH}], ['$self{HASH}']);
}

sub TIEHANDLE
{
    print "TIEHANDLE @_\n" if $DEBUG;
    return $_[0] if ref($_[0]);
    my $class = shift;
    my $self = bless Symbol::gensym(), $class;
    $self->open(@_);
    $self;
}

sub DESTROY
{
    print "DESTROY @_\n" if $DEBUG;
}

sub close
{
    my $self = shift;
    *$self->{dbi}->func(*$self->{fh}, 'lo_close')
      if defined (*$self->{dbi} && defined *$self->{fh});
    delete *$self->{buf};
    delete *$self->{pos};
    delete *$self->{lno};

    $self;
}

sub opened
{
    my $self = shift;
    defined *$self->{buf};
}

sub getc
{
    my $self = shift;
    my $buf;
    return $buf if $self->read($buf, 1);
    return undef;
}

sub ungetc
{
    my $self = shift;
    $self->setpos($self->getpos() - 1)
}

sub eof
{
    my $self = shift;
    my $dbi = *$self->{dbi};
    my $id  = *$self->{id};
    my $tmp  = $self->tell;
    $self->seek(0, 2);
    my $end  = $self->tell;
    $self->seek($tmp, 0);

    $end <= $tmp;
}

sub print
{
    my $self = shift;
    if (defined $\) {
	if (defined $,) {
	    $self->write(join($,, @_).$\);
	} else {
	    $self->write(join("",@_).$\);
	}
    } else {
	if (defined $,) {
	    $self->write(join($,, @_));
	} else {
	    $self->write(join("",@_));
	}
    }
}
*printflush = \*print;

sub printf
{
    my $self = shift;
    print "PRINTF(@_)\n" if $DEBUG;
    my $fmt = shift;
    $self->write(sprintf($fmt, @_));
}


sub seek {
  my($self,$off,$whence) = @_;
  my $fh = *$self->{fh};
  my $pos;

  $pos = *$self->{dbi}->func($fh, $off, $whence, 'lo_lseek');
  carp "Error during seek: ", $DBI::errstr
    if $DBI::err || not defined $pos;

  if(defined $pos && $pos < 0) {
    $pos = 0;
    *$self->{lno} = 0;
  } elsif(defined $pos) {
    *$self->{pos} = $pos;
  }
  return 1 if defined $pos;
  return 0;
}

sub _length {
  my $self = shift;
  my $old = *$self->{pos};

  $self->seek(0, 2);
  my $len = $self->tell;
  $self->seek($old, 0);

  return $len;
}
*length   = \&_length;

sub pos {
  my $self = shift;
  my $old = *$self->{pos};
  _init_seek_constants() unless defined $SEEK_SET;

    if (@_) {
	my $pos = shift || 0;
	my $fh = *$self->{fh};
	my $len = $self->_length;
	$pos = $pos > $len ? $len : $pos;
	*$self->{dbi}->func($fh, $pos, $SEEK_SET, 'lo_lseek');
	*$self->{pos} = $pos;
	*$self->{lno} = 0;
    }
    $old;
}

sub getpos { shift->pos; }

*sysseek = \&seek;
*setpos  = \&pos;
*tell    = \&getpos;



sub getline
{
    my $self = shift;
    my $fh  = *$self->{fh};
    my $dbi = *$self->{dbi};
    my $len  = $self->_length();
    my $pos  = *$self->{pos};
    return if $pos >= $len;
    my $line = "";

    unless (defined $/) {  # slurp
	*$self->{pos} = $len;
	$dbi->func($fh, $line, $len - $pos, 'lo_read');
	return $line;
    }

    unless (length $/) {  # paragraph mode
	# XXX slow&lazy implementation using getc()
	my $para = "";
	my $eol = 0;
	my $c;
	while (defined($c = $self->getc)) {
	    if ($c eq "\n") {
		$eol++;
	    } elsif ($eol > 1) {
		$self->ungetc($c);
		last;
	    }
	    $para .= $c;
	}
	return $para;   # XXX wantarray
    }

    my $ret = "";
    my $tmp = "";
    my $br;
  READ:
    while (($br = $self->read($tmp, 512)) != 0) {
      my $idx = index($tmp, $/);
      if($idx > ($[ - 1)) {
	*$self->{pos} += $idx + length($/) - $br;
	$self->seek(*$self->{pos}, 0);
	$ret .= substr($tmp, 0, $idx+length($/));
	$. = ++*$self->{lno};
	return $ret;
      } else {
	$ret .= $tmp;
	*$self->{pos} += $br
      }
    }
    $. = ++*$self->{lno};

    return $ret;
}

sub getlines
{
    die "getlines() called in scalar context\n" unless wantarray;
    my $self = shift;
    my($line, @lines);
    push(@lines, $line) while defined($line = $self->getline);
    return @lines;
}

sub READLINE
{
    goto &getlines if wantarray;
    goto &getline;
}

sub input_line_number
{
    my $self = shift;
    my $old = *$self->{lno};
    *$self->{lno} = shift if @_;

    $old;
}

sub truncate {
  my $self = shift;
  my $len = shift || 0;
  my $fh = *$self->{fh};
  if ($self->_length > $len) {
    carp "Not Implemented";
#    substr($fh, $len) = '';
#    *$self->{pos} = $len if $len < *$self->{pos};
  } elsif ($self->_length < $len) {
    $self->seek(0, $SEEK_END);
    $self->write($self->pad x ($len - $self->_length))
  }
  $self;
}

sub read
{
    my $self = shift;
    my $fh = *$self->{fh};
    my $dbi = *$self->{dbi};
    my $tbuf = "";
    my $len = $_[1];
    my $pos = *$self->{pos};
    my $rem = $self->_length - $pos;

    my $nbytes = $dbi->func($fh, $tbuf, $len, "lo_read");

    if (@_ > 2) { # read offset
      substr($_[0],$_[2]) = $tbuf;
    } else {
      $_[0] = $tbuf;
    }
    *$self->{pos} += $nbytes;
    return $nbytes
}

sub write
{
    my $self = shift;
    my $fh = *$self->{fh};
    my $dbi = *$self->{dbi};

    my $pos = *$self->{pos};
    my $slen = length($_[0]);
    my $len = $slen;
    my $off = 0;
    if (@_ > 1) {
	$len = $_[1] if $_[1] < $len;
	if (@_ > 2) {
	    $off = $_[2] || 0;
	    die "Offset outside file" if $off > $slen;
	    if ($off < 0) {
		$off += $slen;
		die "Offset outside file" if $off < 0;
	    }
	    my $rem = $slen - $off;
	    $len = $rem if $rem < $len;
	}
    }

    my $nbytes = $dbi->func($fh, substr($_[0], $off), $len, "lo_write");
    *$self->{pos} += $nbytes;
    $nbytes;
}

*sysread = \&read;
*syswrite = \&write;

sub stat
{
    my $self = shift;
    return unless $self->opened;
    return 1 unless wantarray;
    my $len = $self->_length;

    return (
     undef, undef,  # dev, ino
     0666,          # filemode
     1,             # links
     $>,            # user id
     $),            # group id
     undef,         # device id
     $len,          # size
     undef,         # atime
     undef,         # mtime
     undef,         # ctime
     512,           # blksize
     int(($len+511)/512)  # blocks
    );
}

sub blocking {
    my $self = shift;
    my $old = *$self->{blocking} || 0;
    *$self->{blocking} = shift if @_;
    $old;
}

my $notmuch = sub { return };

*fileno    = $notmuch;
*error     = $notmuch;
*clearerr  = $notmuch;
*sync      = $notmuch;
*flush     = $notmuch;
*setbuf    = $notmuch;
*setvbuf   = $notmuch;

*untaint   = $notmuch;
*autoflush = $notmuch;
*fcntl     = $notmuch;
*ioctl     = $notmuch;

*GETC   = \&getc;
*PRINT  = \&print;
*PRINTF = \&printf;
*READ   = \&read;
*WRITE  = \&write;
*CLOSE  = \&close;

1;

__END__