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__
=head1 NAME
Dimedis::SqlDriver::Oracle - Oracle Treiber für das Dimedis::Sql Modul
=head1 SYNOPSIS
use Dimedis::SqlDriver;
=head1 DESCRIPTION
siehe Dimedis::Sql
=head1 BESONDERHEITEN DER IMPLEMENTIERUNG
=head2 SERIAL BEHANDLUNG
Der 'serial' Datentyp wird mit Sequences realisiert. Dabei wird
für jede Tabelle automatisch eine Sequence verwaltet, deren Name
sich wie folgt zusammensetzt:
${table}_SEQ
Wenn die Sequence noch nicht existiert, wird sie automatisch
angelegt. Die Zählung beginnt dabei mit 1.
=head2 BLOB BEHANDLUNG
Es werden nur die Oracle Blob Datentypen 'blob' und 'clob'
unterstützt. Der Datentyp 'long' kann nicht verwendet werden.
Das Schreiben von Blobs wird direkt mit DBD::Oracle durchgeführt.
DBD::Oracle verlangt, daß der Blob hierzu im Speicher vorliegt, er wird
also ggf. vorher vollständig in den Speicher gelesen.
Das Lesen von Blobs wird mit der DBI blob_read Methode realisiert.
Dabei werden Blobs mit einer Blockgröße von 32KB sequentiell eingelesen.
Wenn also ein Blob in das Filesystem geschrieben werden soll, wird er
hierzu nicht vollständig in den Hauptspeicher eingelesen.
=head2 INSTALL METHODE
Für Dimedis::SqlDriver::Oracle ist die install Methode leer,
d.h. es werden keine Objekte in der Datenbank vorausgesetzt.
=head2 CONTAINS METHODE
Es wird in für diese Abfrage korrekt konfiguriertes Oracle Context
Cartridge vorausgesetzt. Die Abfrage liefert _alle_ Einträge zurück,
die matchen, d.h. bei einem Score von > 0 liegt ein Match vor.
=head2 USE METHODE
Der Wechsel in eine andere Datenbank bedeutet bei Oracle den Wechsel
auf ein anderes Default Schema. Der User, mit dem die Datenbankverbindung
hergestellt wurde, muß also die Rechte haben, um auf die Objekte dieses
Schemas zugreifen zu dürfen.
=head1 AUTOR
Jörn Reder, joern@dimedis.de
=head1 COPYRIGHT
Copyright (c) 1999 dimedis GmbH, All Rights Reserved
=head1 SEE ALSO
perl(1).
=cut