view release on metacpan or  search on metacpan

Postgres.pm  view on Meta::CPAN

# -*-cperl-*-
#
# Persistence::Object::Postgres - Object Persistence with PostgreSQL.
# Copyright (C) 2000-2001, Ashish Gulhati <hash@netropolis.org>
#
# All rights reserved. This code is free software; you can
# redistribute it and/or modify it under the same terms as Perl
# itself.
#
# $Id: Postgres.pm,v 1.24 2001/07/07 00:37:13 cvs Exp $

package Persistence::Object::Postgres;

use DBI;
use Carp;
use IO::Wrap;
use IO::Handle;
use Data::Dumper;
use vars qw( $VERSION );

( $VERSION ) = '$Revision: 1.24 $' =~ /\s+([\d\.]+)/;

sub dbconnect {
  my ($class, $dbobj) = @_;
  my %options = (host     => $dbobj->{Host} || '',
		 port     => $dbobj->{Port} || '5432',
		);
  my $username = $dbobj->{Host} || (''.getpwuid $<);
  my $password = $dbobj->{Host} || '';
  my $options = join (';',"dbname=$dbobj->{Database}",
		      grep { /=.+$/ } map { "$_=$options{$_}" } keys %options);
  return undef unless $dbh = DBI->connect("dbi:Pg:$options", $username, $password);
} 

sub new {
  my ($class, %args) = @_; my $self=undef;
  return undef unless my $dope = $args{__Dope};
  $self = $class->load (__Dope => $dope, __Oid => $args{__Oid} )
    if my $oid = $args{__Oid};
  $self->{__Oid} = $oid if $self; $self = {} unless $self; 
  $self->{__Dope} = $dope; 
  delete $args{__Dope}; delete $args{__Oid};
  foreach (keys %args) { $self->{$_} = $args{$_} }
  bless $self, $class;
}

package Tie::PgBLOB;

sub IO::Handle::open {
  shift;
}

sub TIEHANDLE { 
  bless {
	 dbh   => $_[1], 
	 blob  => $_[2] 
	}, shift;
}

sub WRITE {
  my $r = shift;
  my ($buf, $len, $offset) = @_;
  $buf = substr ($buf, $offset, $len);
  my $nbytes = $r->{dbh}->func($r->{blob}, $buf, length ($buf), 'lo_write');    
}

sub PRINT { 
  my $r = shift; 
  my $buf = join($,,@_,$\); my $nbytes;
  $r->{dbh}->{AutoCommit} = 0;
  $r->{dbh}->{RaiseError} = 1;
  eval {
    my $blob = $r->{dbh}->func($r->{blob}, $r->{dbh}->{pg_INV_WRITE}, 'lo_open');
    $r->{dbh}->func($blob, $r->{loc}, 0, 'lo_lseek');
    $nbytes = $r->{dbh}->func($blob, $buf, length ($buf), 'lo_write');
    $r->{loc} = $r->{dbh}->func($blob, 'lo_tell');
    $r->{dbh}->func($blob, 'lo_close');
    $r->{dbh}->commit();
  };
  if ($@) {
    warn "Transaction aborted because $@";
    $r->{dbh}->rollback();
  }
  $r->{dbh}->{AutoCommit} = 1;
  return $nbytes;
}

sub PRINTF {