File Coverage

blib/lib/Dimedis/SqlDriver/Informix.pm

Criterion	Covered	Total	%
statement	18	179	10.0
branch	0	54	0.0
condition	0	6	0.0
subroutine	6	20	30.0
pod	0	14	0.0
total	24	273	8.7

package Dimedis::SqlDriver::Informix;

use strict;
use vars qw($VERSION @ISA);

$VERSION = '0.10';
@ISA = qw(Dimedis::Sql);	# Vererbung von Dimedis::Sql

use Carp;
use File::Copy;
use FileHandle;

my $exc = "Dimedis::SqlDriver::Informix:";	# Exception Prefix

# offizielles Dimedis::SqlDriver Interface ===========================

# install ------------------------------------------------------------

sub db_install {
	my $self = shift;

	return 1;	# wg. blob update mit temp table

	$self->{debug} && print STDERR "$exc:install\tblob Methode ohne temp. table\n";

	# erstmal alles löschen
	eval {
		$self->do (
			sql => "drop table dim_blob_insert"
		);
	};

	# Anlegen der INSERT Dummy Tabelle

	$self->do (
		sql => "create table dim_blob_insert (".
		       " id serial not null primary key,".
		       " myblob byte, myclob text )"
	);

	1;
}

# insert -------------------------------------------------------------

sub db_insert {
	my $self = shift;

	my ($par)= @_;
	$par->{db_action} = "insert";

	$self->db_insert_or_update ($par);
}

# update -------------------------------------------------------------

sub db_update {
	my $self = shift;

	my ($par)= @_;
	$par->{db_action} = "update";

	$self->db_insert_or_update ($par);
}

# blob_read ----------------------------------------------------------

sub db_blob_read {
	my $self = shift;

	my ($par) = @_;

	my $filename = $par->{filename};
	my $filehandle = $par->{filehandle};

	my $dbh = $self->{dbh};

	# das ist einfach! rausSELECTen halt...

	my $sth = $dbh->prepare (
		"select $par->{col}
		 from   $par->{table}
		 where  $par->{where}"
	) or croak "$DBI::errstr";

	$sth->execute(@{$par->{params}}) or croak $DBI::errstr;

	# Blob lesen

	my $ar = $sth->fetchrow_arrayref;
	croak $DBI::errstr if $DBI::errstr;
	if ( not defined $ar ) {
		return \"";
	}

	my $blob = $ar->[0];

	$sth->finish or croak $DBI::errstr;

	# und nun ggf. irgendwo hinschreiben...

	if ( $filename ) {
		open (BLOB, "> $filename") or croak "can't write $filename";
		binmode BLOB;
		print BLOB $blob;
		close BLOB;
		$blob = "";	# Speicher wieder freigeben
	} elsif ( $filehandle ) {
		binmode $filehandle;
		print $filehandle $blob;
		$blob = "";	# Speicher wieder freigeben
	}

	return \$blob;
}

# left_outer_join ----------------------------------------------------
{
	my $from;
	my $where;

	sub db_left_outer_join {
		my $self = shift;

		# static Variablen initialisieren

		$from = "";
		$where = "";

		# Rekursionsmethode anwerfen

		$self->db_left_outer_join_rec ( @_ );

		# Dreck bereinigen

		$from =~ s/,$//;
		$from =~ s/,\)/)/g;
		$where =~ s/ AND $//;

		return ($from, $where);
	}

	sub db_left_outer_join_rec {
		my $self = shift;

		my ($lref) = @_;

		# linke Tabelle in die FROM Zeile

		$from .= $lref->[0].",";

		if ( ref $lref->[1] ) {
			# aha, Outer Join
			if ( @{$lref->[1]} > 1 ) {
				# kein einfacher Outer Join
				# (verschachtelt oder outer join gegen
				#  simple join, Fall II/III)
				$from .= "outer (";
				$self->db_left_outer_join_rec ($lref->[1]);
				$from .= ")";
				$where .= $lref->[2]." AND ";
			} else {
				# Fall I, outer join einer linken Tabelle
				# gegen eine oder mehrere rechte Tabellen
				my $i = 1;
				while ($i < @{$lref}) {
					$from .= " outer ".$lref->[$i]->[0].",";
					$where .= $lref->[$i+1]." AND ";
					$i += 2;
				}
			}
		} else {
			# noe, kein Outer join
			croak "$exc:db_left_outer_join\tcase III does not exist anymore";
			$from .= $lref->[1];
			$where .= $lref->[2]." AND ";
		}
	}
}

# cmpi ---------------------------------------------------------------

sub db_cmpi {
	my $self = shift;
	my ($par)= @_;

	use locale;

	my $val = lc $par->{val};
	$val =~ s/(\w)/"[$1".uc($1)."]"/eg;
	$val =~ s/\%/*/g;
	my $not = $par->{op} eq '!=' ? 'not ' : '';

	return "$not$par->{col} matches ".
	       $self->{dbh}->quote ($val);
}

# contains -----------------------------------------------------------

sub db_contains {
	my $self = shift;

	my ($par) = @_;
	my $cond;

	# bei Informix z.Zt. nicht unterstüzt, deshalb undef returnen

	return $cond;
}

# db_prefix ----------------------------------------------------------

sub db_db_prefix {
	my $self = shift;

	my ($par)= @_;

	return $par->{db}.':';

	1;
}

# get_features -------------------------------------------------------

sub db_get_features {
	my $self = shift;

	return {
		serial => 1,
		blob_read => 1,
		blob_write => 1,
		left_outer_join => {
			simple => 1,
			nested => 1
		},
	  	cmpi => 1,
		contains => 0
	};
}

# Driverspezifische Hilfsmethoden ====================================

# Insert bzw. Update durchführen -------------------------------------

sub db_insert_or_update {
	my $self = shift;

	my ($par) = @_;
	my $type_href = $par->{type};

	my $serial;			# evtl. Serial Wert
	my (@columns, @values);		# Spaltennamen und -werte
	my $return_value;		# serial bei insert,
					# modified bei update

	# Parameter aufbereiten

	my ($col, $val);
	my $qm;		# Fragezeichen für Parameterbinding
	my %blobs;	# Hier werden BLOB Spalten abgelegt, die
			# nach dem INSERT eingefügt werden
	my $blob_found;
	my $primary_key;	# Name der primary key Spalte

	while ( ($col,$val) = each %{$par->{data}} ) {
		my $type = $type_href->{$col};
		$type =~ s/\[.*//;

		if ( $type eq 'serial' ) {
			# serial Typ bearbeiten

			if ( not defined $val ) {
				$serial = 0;
			} else {
				$serial = $val;
			}
			push @columns, $col;
			push @values, $serial;
			$qm .= "?,";
			$primary_key = $col;

		} elsif ( $type eq 'blob' or $type eq 'clob' ) {

			# Blob muß in jedem Fall im Speicher vorliegen

			$val = $self->db_blob2memory($val);

			if ( $par->{db_action} eq 'insert' ) {
				# Blobs können inline geinsertet werden
				push @columns, $col;
				push @values, $$val;
				$qm .= "?,";
			} else {
				# zum Updaten wirds komplizierter!
				# das machen wir später...
				$blob_found = 1;
				$blobs{$col} = $val;
			}
		} else {
			# alle übrigen Typen werden as is eingefügt
			push @columns, $col;
			push @values,  $val;
			$qm .= "?,";
		}
	}
	$qm =~ s/,$//;	# letztes Komma bügeln

	# Insert oder Update durchführen

	if ( $par->{db_action} eq 'insert' ) {
		# insert ausführen

		$self->do (
			sql => "insert into $par->{table} (".
			       join (",",@columns).
			       ") values ($qm)",
			params => \@values
		);
		$return_value = $self->{dbh}->{ix_sqlerrd}->[1];
	} else {
		# Parameter der where Klausel in @value pushen
		push @values, @{$par->{params}};

		# update ausführen, wenn columns da sind
		# (bei einem reinen BLOB updated passiert es,
		#  daß keine 'normalen' Spalten upgedated werden)

		if ( @columns ) {
			$return_value = $self->do (
				sql => "update $par->{table} set ".
				       join(",", map("$_=?", @columns)).
				       " where $par->{where}",
				params => \@values
			);
		}
	}

	# nun evtl. BLOBs verarbeiten (kann nur beim Update passieren)

	if ( $blob_found ) {
		while ( ($col,$val) = each %blobs ) {
			$self->db_update_blob (
				$par->{table},
				$par->{where},
				$col, $val,
				$type_href,
				$par->{params}
			);
		}
	}

	return $return_value;
}

# BLOB ins Memory holen, wenn nicht schon da -------------------------

sub db_blob2memory {
	my $self = shift;

	my ($val) = @_;

	my $blob;
	if ( ref $val and ref $val ne 'SCALAR' ) {
		# Referenz und zwar keine Scalarreferenz
		# => das ist ein Filehandle
		# => reinlesen den Kram
		binmode $val;
		$$blob = join ("", <$val>);
	} elsif ( not ref $val ) {
		# keine Referenz
		# => Dateiname
		# => reinlesen den Kram
		my $fh = new FileHandle;
		open ($fh, $val) or croak "can't open $val";
		binmode $fh;
		$$blob = join ("", <$fh>);
		$self->{debug} && print STDERR "$exc:db_blob2memory: blob_size ($val): ", length($$blob), "\n";
		close $fh;
	} else {
		# andernfalls ist val eine Skalarreferenz mit dem Blob
		# => nix tun
		$blob = $val;
	}

	return $blob;
}

# BLOB updaten -------------------------------------------------------

sub db_update_blob {
	my $self = shift;

	$self->{debug} && print STDERR "$exc:db_update_blob tmp table entered\n";

	my ($table, $where, $col, $val, $type_href, $param_lref) = @_;

	# blob oder clob?

	my $blob_col = $type_href->{$col} eq 'blob' ? 'myblob' : 'myclob';

	# temp table anlegen

	$self->do (
		sql => "create temp table dim_blob_insert (".
		       " myblob byte, myclob text ) with no log"
	);

	# dann Blob in temp Table inserten

	$self->do (
		sql => "insert into dim_blob_insert ($blob_col) ".
		       "values (?)",
		params => [ $$val ]
	);

	# nun von dort aus in die Zieltabelle updaten
        # FELIX: Einfuegen von Klaus-Fix am 4.8.99.
	# WHERE clause fehlte...

	$self->do (
		sql => "update $table set $col = ".
		       "(select $blob_col from dim_blob_insert) where $where",
			params => $param_lref
	);

	# und die temp. Tabelle löschen

	$self->do (
		sql => "drop table dim_blob_insert"
	);

	1;
}

# this is currently disabled

sub db_update_blob_with_fix_installed_table {
	my $self = shift;

	$self->{debug} && print STDERR "$exc:db_update_blob entered\n";

	my ($table, $where, $col, $val, $type_href, $param_lref) = @_;

	# blob oder clob?

	my $blob_col = $type_href->{$col} eq 'blob' ? 'myblob' : 'myclob';

	# erstmal Blob in Dummy Table inserten

	$self->do (
		sql => "insert into dim_blob_insert (id, $blob_col) ".
		       "values (0, ?)",
		params => [ $$val ]
	);

	my $id = $self->{dbh}->{ix_sqlerrd}->[1];

	# nun von dort aus in die Zieltabelle updaten

	$self->do (
		sql => "update $table set $col = ".
		       "(select $blob_col from dim_blob_insert ".
		       " where id=$id)"
	);

	# und aus der Dummy Tabelle löschen

	$self->do (
		sql => "delete from dim_blob_insert where id=$id"
	);

	1;
}

1;

__END__