File Coverage

blib/lib/Dimedis/SqlDriver/Oracle.pm

Criterion	Covered	Total	%
statement	21	217	9.6
branch	0	104	0.0
condition	0	30	0.0
subroutine	7	22	31.8
pod	0	15	0.0
total	28	388	7.2

package Dimedis::SqlDriver::Oracle;

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

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

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

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

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

# 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 $dbh = $self->{dbh};

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

	# Truncating ist Ok. Die Blobs werden ja eh mit blob_read() gelesen,
	# da kann beim fetch() ruhig abgeschnitten werden.
	$dbh->{LongTruncOk} = 1;

	# Ohne eine zusätzliche Spalte funktioniert das Ganze nicht,
	# deshalb wird noch konstant 1 dazuselektiert
	my $sth = $dbh->prepare (
		"select 1, $par->{col}
		 from   $par->{table}
		 where  ($par->{where}) and $par->{col} is not NULL"
	) or die "$DBI::errstr";

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

	my $blob = '';
	my $offset = 0;

	# Blob lesen
	my $fh;

	if ( $filename ) {
		$fh = new FileHandle;
		open ($fh, "> $filename")
			or die "can't write $filename";
	        $self->{debug} && print STDERR "$exc:db_blob_read: will write to $filename\n";
	} else {
		$fh = $par->{filehandle};
	        $self->{debug} && print STDERR "$exc:db_blob_read: will write to fh\n"
			if $fh;
	        $self->{debug} && print STDERR "$exc:db_blob_read: will return as sref\n"
			if not $fh;
	}

	binmode $fh if $fh;

	if ( $sth->fetchrow_arrayref ) {
		while (1) {
			$self->{debug} && print STDERR "$exc:db_blob_read: sth->blob_read(1, $offset, 32768)\n";
			my $frag = $sth->blob_read(1, $offset, 32768);
			$self->{debug} && print STDERR "$exc:db_blob_read: got something: len=".length($frag)."\n"
				if $frag ne '';
			$self->{debug} && print STDERR "$exc:db_blob_read: got nothing\n" if $frag eq "";
			last unless defined $frag;
			my $len = length $frag;
			last unless $len;
			if ( $fh ) {
				print $fh $frag or
					die "$exc:db_blob_read\tcan't write blob ".
					    "chunk to $filename";
			} else {
				$blob .= $frag;
			}
			$offset += $len;
		}

		$sth->finish or die $DBI::errstr;
	}

	close $fh if $fh and not $par->{filehandle};

	return if $par->{filehandle} or $par->{filename};
	return \$blob;
}

# left_outer_join ----------------------------------------------------

{
	my $from;
	my $where;
	my %from_tables;

	sub db_left_outer_join {
		my $self = shift;

		# static Variablen initialisieren

		$from = "";
		$where = "";
		%from_tables = ();

		# Rekursionsmethode anwerfen

		$self->db_left_outer_join_rec ( @_ );

		# Dreck bereinigen

		$from =~ s/,$//;
		$where =~ s/ AND $//;

		return ($from, $where);
	}

	sub db_left_outer_join_rec {
		my $self = shift;

		my ($lref) = @_;

		# linke Tabelle in die FROM Zeile

		my $left = $lref->[0];
		$from .= $left."," unless $from_tables{$left};
		$from_tables{$left} = 1;

		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)

				$where .= $self->db_join_cond (
					$left,
					$lref->[2],
					$lref->[1]->[0],
					'outer'
				)." AND ";
				$self->db_left_outer_join_rec ($lref->[1]);
			} else {
				# Fall I, outer join einer linken Tabelle
				# gegen eine oder mehrere rechte Tabellen
				my $i = 1;
				while ($i < @{$lref}) {
					$from  .= $lref->[$i]->[0].","
						unless $from_tables{$lref->[$i]->[0]};
					$from_tables{$lref->[$i]->[0]} = 1;
					$where .= $self->db_join_cond (
						$left,
						$lref->[$i+1],
						$lref->[$i]->[0],
						'outer'
					)." AND ";
					$i += 2;
				}
			}
		} else {
			# noe, kein Outer join
			die "$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 $quoted = $self->{dbh}->quote ( lc($par->{val}) );

	Encode::_utf8_on($quoted) if $self->{utf8};

	return "lower($par->{col}) $par->{op} ".$quoted;
}

# use_db -------------------------------------------------------------

sub db_use_db {
	my $self = shift;

	my ($par)= @_;

	$self->do (
		sql => "alter session set current_schema = $par->{db}"
	);

	1;
}

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

sub db_db_prefix {
	my $self = shift;

	my ($par)= @_;

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

	1;
}

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

sub db_install {
	# nichts zu tun hier, für Oracle

	1;
}

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

sub db_contains {
	my $self = shift;
	my ($par) = @_;
	my $val_lr = $par->{vals};

	#---- Die Sonderzeichen in den Values muessen escaped werden,
	#---- da sonst "DRG-50937: query too complex" Fehler schnell
	#---- auftreten koennen, wenn man bspw. nach "e-mail" sucht.
	#---- Die Alternative, die Suchworte einfach in "{}" zu setzen,
	#---- escaped zwar auch die Sonderzeichen, behandelt aber
	#---- die Teilworte trotzdem als einzelne Suchworte.
	#---- Bei bspw. "e-mail" wird dann auch wieder nach "e" und "mail"
	#---- gesucht, was wieder in einer too complex Suche resultieren kann.
	#---- Daher die Zeichen einzeln escapen.
	my @values;
        foreach my $v ( @{$val_lr} ) {
                my $value = $v;
                $value =~ s/[^0-9a-z]+$//i;
                $value =~ s/([^0-9a-z])/\\$1/ig;
                push @values, $value if $value ne '';
        }

	return "" if not @values;

	my $cond;
	if ( $par->{search_op} eq 'sub' ) {
		$cond = "contains($par->{col}, ".
		$self->{dbh}->quote (
		    join (
			" ".$par->{logic_op}." ",
			map "$_%", @values
		    )
		).
		") > 0";
	}

	return $cond;
}

# 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 => 1,
		utf8 => 1,
	};
}

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

# join Bedingung bauen -----------------------------------------------

sub db_join_cond {
	my $self = shift;

	my ($left, $cond, $right, $join) = @_;

	# beim outer join müssen (+) Zeichen bei Ausdrücken der
	# rechten Tabelle angehängt werden

	my ($table, $alias) = split (/\s/, $right);
	$alias ||= $table;

	$cond =~ s/($alias\.[^\s]+)/$1 (+)/g;

	return $cond;
}

# 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 = $self->db_get_serial (
					$par->{table},
					$col,
					$type_href->{$col}
				);
			} else {
				$serial = $val;
			}
			push @columns, $col;
			push @values, $serial;
			$qm .= "?,";
			$primary_key = $col;

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

			# Blobs werden nach dem INSERT/UPDATE verarbeitet

			if ( $par->{db_action} eq 'insert' ) {
				push @columns, $col;
				$qm .= $type eq 'blob' ?
					"empty_blob()," :
					"empty_clob(),";
			}

			$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 = $serial;
	} 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

	if ( $blob_found ) {
		if ( $par->{db_action} eq 'insert' ) {
			while ( ($col,$val) = each %blobs ) {
				$self->db_put_blob (
					$par->{table},
					"$primary_key=$serial",
					$col, $val,
					$type_href
				);
			}
		} else {
			while ( ($col,$val) = each %blobs ) {
				$self->db_put_blob (
					$par->{table},
					$par->{where},
					$col, $val,
					$type_href,
					$par->{params}
				);
			}
		}
	}

	return $return_value;
}

# Serial ermitteln ---------------------------------------------------

sub db_get_serial {
	my $self = shift;

	my ($table, $col, $type) = @_;

	# SEQUENCE Namen bestimmen

	my $sequence ||= "${table}_SEQ";

	# Sequence auslesen

	my $serial;

	eval {
		($serial) = $self->get (
			sql => "select $sequence.nextval from dual",
			cache => 1
		);
	};

	# wenn's nicht geklappt hat, gab's die SEQUENCE wohl nicht

	if ( $@ ) {
		$self->{debug} && print STDERR "$exc:get_serial: sequence existiert nicht\n";
		# also: legen wir sie doch einfach an!

		my ($max_id) = $self->get (
			sql => "select max($col) from $table"
		);

		$self->{debug} && print STDERR "$exc:get_serial: max_id=$max_id\n";

		$max_id += 100;

		$self->{debug} && print STDERR "$exc:get_serial: create sequence mit start=$max_id\n";

		$self->do (
			sql => "create sequence $sequence
				start with $max_id
				increment by 1"
		);
		$serial = $max_id-1;
	}

	return $serial;
}

# BLOB speichern -----------------------------------------------------

sub db_put_blob {
	my $self = shift;

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

	# Workaround für DBD::Proxy. Wenn kein DBD::Oracle installiert
	# geht das natürlich nicht. Somit funktionieren aber wenigstens
	# alle Funktionen außer db_put_blob auch unter DBD::Proxy.
	require "DBD/Oracle.pm";
	import DBD::Oracle qw(:ora_types)
		if not $Dimedis::SqlDriver::Oracle::already_imported;
	$Dimedis::SqlDriver::Oracle::already_imported = 1;

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

	my $type = $type_href->{$col};

	my $set_utf8 = $self->{utf8} && $type eq 'clob';

	my $blob = $self->blob2memory($val, $col, $type);

	# in $blob steht nun eine Skalarrereferenz auf den Blob

	$self->{debug} && print STDERR "$exc:db_put_blob ".
		"prepare: update $table set $col = ? where $where\n";

	my $sth = $self->{dbh}->prepare (qq{
		update $table set $col = ? where $where
	}) or croak "$exc:db_put_blob\t$DBI::errstr";

	my $ora_type;
	$ora_type = $type eq 'blob' ? ORA_BLOB() : ORA_CLOB();

	$self->{debug} && print STDERR "$exc:db_put_blob ora_type=$ora_type\n";

	$sth->bind_param(1, $$blob, {ora_type => $ora_type, ora_field => $col} )
		or croak "$exc:db_put_blob\t$DBI::errstr";

	my $i = 2;
	foreach my $par (@{$param_lref}) {
		$sth->bind_param($i, $par);
		++$i;
	}

	$sth->execute
		or croak "$exc:db_put_blob\t$DBI::errstr";

	$sth->finish
		or croak "$exc:db_put_blob\t$DBI::errstr";

	$self->{debug} && print STDERR "$exc:db_put_blob succesfully put blob\n";

	1;
}

1;

__END__