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


line stmt bran cond sub pod time code
1             package Dimedis::SqlDriver::Oracle;
2              
3 1     1   885 use strict;
  1         2  
  1         45  
4 1     1   6 use vars qw($VERSION @ISA);
  1         2  
  1         77  
5              
6             $VERSION = '0.23';
7             @ISA = qw(Dimedis::Sql); # Vererbung von Dimedis::Sql
8              
9 1     1   6 use Carp;
  1         2  
  1         92  
10 1     1   7 use File::Copy;
  1         1  
  1         66  
11 1     1   6 use File::Basename;
  1         3  
  1         81  
12 1     1   6 use FileHandle;
  1         2  
  1         7  
13              
14             my $exc = "Dimedis::SqlDriver::Oracle:"; # Exception Prefix
15              
16             # offizielles Dimedis::SqlDriver Interface ===========================
17              
18             # insert -------------------------------------------------------------
19              
20             sub db_insert {
21 0     0 0   my $self = shift;
22              
23 0           my ($par)= @_;
24 0           $par->{db_action} = "insert";
25            
26 0           $self->db_insert_or_update ($par);
27             }
28              
29             # update -------------------------------------------------------------
30              
31             sub db_update {
32 0     0 0   my $self = shift;
33              
34 0           my ($par)= @_;
35 0           $par->{db_action} = "update";
36            
37 0           $self->db_insert_or_update ($par);
38             }
39              
40             # blob_read ----------------------------------------------------------
41              
42             sub db_blob_read {
43 0     0 0   my $self = shift;
44 0           my ($par) = @_;
45 0           my $filename = $par->{filename};
46            
47 0           my $dbh = $self->{dbh};
48              
49 0 0         $self->{debug} && print STDERR "$exc:db_blob_read: entered\n";
50            
51             # Truncating ist Ok. Die Blobs werden ja eh mit blob_read() gelesen,
52             # da kann beim fetch() ruhig abgeschnitten werden.
53 0           $dbh->{LongTruncOk} = 1;
54            
55             # Ohne eine zusätzliche Spalte funktioniert das Ganze nicht,
56             # deshalb wird noch konstant 1 dazuselektiert
57 0 0         my $sth = $dbh->prepare (
58             "select 1, $par->{col}
59             from $par->{table}
60             where ($par->{where}) and $par->{col} is not NULL"
61             ) or die "$DBI::errstr";
62            
63 0 0         $sth->execute(@{$par->{params}}) or die $DBI::errstr;
  0            
64 0 0         die $DBI::errstr if $DBI::errstr;
65              
66 0           my $blob = '';
67 0           my $offset = 0;
68            
69             # Blob lesen
70 0           my $fh;
71              
72 0 0         if ( $filename ) {
73 0           $fh = new FileHandle;
74 0 0         open ($fh, "> $filename")
75             or die "can't write $filename";
76 0 0         $self->{debug} && print STDERR "$exc:db_blob_read: will write to $filename\n";
77             } else {
78 0           $fh = $par->{filehandle};
79 0 0 0       $self->{debug} && print STDERR "$exc:db_blob_read: will write to fh\n"
80             if $fh;
81 0 0 0       $self->{debug} && print STDERR "$exc:db_blob_read: will return as sref\n"
82             if not $fh;
83             }
84              
85 0 0         binmode $fh if $fh;
86              
87 0 0         if ( $sth->fetchrow_arrayref ) {
88 0           while (1) {
89 0 0         $self->{debug} && print STDERR "$exc:db_blob_read: sth->blob_read(1, $offset, 32768)\n";
90 0           my $frag = $sth->blob_read(1, $offset, 32768);
91 0 0 0       $self->{debug} && print STDERR "$exc:db_blob_read: got something: len=".length($frag)."\n"
92             if $frag ne '';
93 0 0 0       $self->{debug} && print STDERR "$exc:db_blob_read: got nothing\n" if $frag eq "";
94 0 0         last unless defined $frag;
95 0           my $len = length $frag;
96 0 0         last unless $len;
97 0 0         if ( $fh ) {
98 0 0         print $fh $frag or
99             die "$exc:db_blob_read\tcan't write blob ".
100             "chunk to $filename";
101             } else {
102 0           $blob .= $frag;
103             }
104 0           $offset += $len;
105             }
106            
107 0 0         $sth->finish or die $DBI::errstr;
108             }
109            
110 0 0 0       close $fh if $fh and not $par->{filehandle};
111            
112 0 0 0       return if $par->{filehandle} or $par->{filename};
113 0           return \$blob;
114             }
115              
116             # left_outer_join ----------------------------------------------------
117              
118             {
119             my $from;
120             my $where;
121             my %from_tables;
122              
123             sub db_left_outer_join {
124 0     0 0   my $self = shift;
125            
126             # static Variablen initialisieren
127            
128 0           $from = "";
129 0           $where = "";
130 0           %from_tables = ();
131              
132             # Rekursionsmethode anwerfen
133              
134 0           $self->db_left_outer_join_rec ( @_ );
135              
136             # Dreck bereinigen
137            
138 0           $from =~ s/,$//;
139 0           $where =~ s/ AND $//;
140              
141 0           return ($from, $where);
142             }
143              
144             sub db_left_outer_join_rec {
145 0     0 0   my $self = shift;
146              
147 0           my ($lref) = @_;
148            
149             # linke Tabelle in die FROM Zeile
150              
151 0           my $left = $lref->[0];
152 0 0         $from .= $left."," unless $from_tables{$left};
153 0           $from_tables{$left} = 1;
154            
155 0 0         if ( ref $lref->[1] ) {
156             # aha, Outer Join
157 0 0         if ( @{$lref->[1]} > 1 ) {
  0            
158             # kein einfacher Outer Join
159             # (verschachtelt oder outer join gegen
160             # simple join, Fall II/III)
161              
162 0           $where .= $self->db_join_cond (
163             $left,
164             $lref->[2],
165             $lref->[1]->[0],
166             'outer'
167             )." AND ";
168 0           $self->db_left_outer_join_rec ($lref->[1]);
169             } else {
170             # Fall I, outer join einer linken Tabelle
171             # gegen eine oder mehrere rechte Tabellen
172 0           my $i = 1;
173 0           while ($i < @{$lref}) {
  0            
174 0 0         $from .= $lref->[$i]->[0].","
175             unless $from_tables{$lref->[$i]->[0]};
176 0           $from_tables{$lref->[$i]->[0]} = 1;
177 0           $where .= $self->db_join_cond (
178             $left,
179             $lref->[$i+1],
180             $lref->[$i]->[0],
181             'outer'
182             )." AND ";
183 0           $i += 2;
184             }
185             }
186             } else {
187             # noe, kein Outer join
188 0           die "$exc:db_left_outer_join\tcase III does not exist anymore";
189 0           $from .= $lref->[1];
190 0           $where .= $lref->[2]." AND ";
191             }
192             }
193             }
194              
195             # cmpi ---------------------------------------------------------------
196              
197             sub db_cmpi {
198 0     0 0   my $self = shift;
199 0           my ($par)= @_;
200              
201 1     1   10066 use locale;
  1         314  
  1         8  
202 0           my $quoted = $self->{dbh}->quote ( lc($par->{val}) );
203              
204 0 0         Encode::_utf8_on($quoted) if $self->{utf8};
205              
206 0           return "lower($par->{col}) $par->{op} ".$quoted;
207             }
208              
209             # use_db -------------------------------------------------------------
210              
211             sub db_use_db {
212 0     0 0   my $self = shift;
213            
214 0           my ($par)= @_;
215              
216 0           $self->do (
217             sql => "alter session set current_schema = $par->{db}"
218             );
219              
220 0           1;
221             }
222              
223             # db_prefix ----------------------------------------------------------
224              
225             sub db_db_prefix {
226 0     0 0   my $self = shift;
227            
228 0           my ($par)= @_;
229              
230 0           return $par->{db}.'.';
231              
232 0           1;
233             }
234              
235             # install ------------------------------------------------------------
236              
237             sub db_install {
238             # nichts zu tun hier, für Oracle
239              
240 0     0 0   1;
241             }
242              
243             # contains -----------------------------------------------------------
244              
245             sub db_contains {
246 0     0 0   my $self = shift;
247 0           my ($par) = @_;
248 0           my $val_lr = $par->{vals};
249              
250             #---- Die Sonderzeichen in den Values muessen escaped werden,
251             #---- da sonst "DRG-50937: query too complex" Fehler schnell
252             #---- auftreten koennen, wenn man bspw. nach "e-mail" sucht.
253             #---- Die Alternative, die Suchworte einfach in "{}" zu setzen,
254             #---- escaped zwar auch die Sonderzeichen, behandelt aber
255             #---- die Teilworte trotzdem als einzelne Suchworte.
256             #---- Bei bspw. "e-mail" wird dann auch wieder nach "e" und "mail"
257             #---- gesucht, was wieder in einer too complex Suche resultieren kann.
258             #---- Daher die Zeichen einzeln escapen.
259 0           my @values;
260 0           foreach my $v ( @{$val_lr} ) {
  0            
261 0           my $value = $v;
262 0           $value =~ s/[^0-9a-z]+$//i;
263 0           $value =~ s/([^0-9a-z])/\\$1/ig;
264 0 0         push @values, $value if $value ne '';
265             }
266            
267 0 0         return "" if not @values;
268            
269 0           my $cond;
270 0 0         if ( $par->{search_op} eq 'sub' ) {
271 0           $cond = "contains($par->{col}, ".
272             $self->{dbh}->quote (
273             join (
274             " ".$par->{logic_op}." ",
275             map "$_%", @values
276             )
277             ).
278             ") > 0";
279             }
280              
281 0           return $cond;
282             }
283              
284             # get_features -------------------------------------------------------
285              
286             sub db_get_features {
287 0     0 0   my $self = shift;
288            
289             return {
290 0           serial => 1,
291             blob_read => 1,
292             blob_write => 1,
293             left_outer_join => {
294             simple => 1,
295             nested => 1
296             },
297             cmpi => 1,
298             contains => 1,
299             utf8 => 1,
300             };
301             }
302              
303             # Driverspezifische Hilfsmethoden ====================================
304              
305             # join Bedingung bauen -----------------------------------------------
306              
307             sub db_join_cond {
308 0     0 0   my $self = shift;
309            
310 0           my ($left, $cond, $right, $join) = @_;
311            
312             # beim outer join müssen (+) Zeichen bei Ausdrücken der
313             # rechten Tabelle angehängt werden
314            
315 0           my ($table, $alias) = split (/\s/, $right);
316 0   0       $alias ||= $table;
317            
318 0           $cond =~ s/($alias\.[^\s]+)/$1 (+)/g;
319            
320 0           return $cond;
321             }
322              
323             # Insert bzw. Update durchführen -------------------------------------
324              
325             sub db_insert_or_update {
326 0     0 0   my $self = shift;
327            
328 0           my ($par) = @_;
329 0           my $type_href = $par->{type};
330              
331 0           my $serial; # evtl. Serial Wert
332 0           my (@columns, @values); # Spaltennamen und -werte
333 0           my $return_value; # serial bei insert,
334             # modified bei update
335            
336             # Parameter aufbereiten
337              
338 0           my ($col, $val);
339 0           my $qm; # Fragezeichen für Parameterbinding
340 0           my %blobs; # Hier werden BLOB Spalten abgelegt, die
341             # nach dem INSERT eingefügt werden
342 0           my $blob_found;
343 0           my $primary_key; # Name der primary key Spalte
344            
345 0           while ( ($col,$val) = each %{$par->{data}} ) {
  0            
346 0           my $type = $type_href->{$col};
347 0           $type =~ s/\[.*//;
348              
349 0 0 0       if ( $type eq 'serial' ) {
    0          
350             # serial Typ bearbeiten
351              
352 0 0         if ( not defined $val ) {
353 0           $serial = $self->db_get_serial (
354             $par->{table},
355             $col,
356             $type_href->{$col}
357             );
358             } else {
359 0           $serial = $val;
360             }
361 0           push @columns, $col;
362 0           push @values, $serial;
363 0           $qm .= "?,";
364 0           $primary_key = $col;
365            
366             } elsif ( $type eq 'blob' or $type eq 'clob' ) {
367              
368             # Blobs werden nach dem INSERT/UPDATE verarbeitet
369              
370 0 0         if ( $par->{db_action} eq 'insert' ) {
371 0           push @columns, $col;
372 0 0         $qm .= $type eq 'blob' ?
373             "empty_blob()," :
374             "empty_clob(),";
375             }
376              
377 0           $blob_found = 1;
378 0           $blobs{$col} = $val;
379              
380             } else {
381             # alle übrigen Typen werden as is eingefügt
382 0           push @columns, $col;
383 0           push @values, $val;
384 0           $qm .= "?,";
385             }
386             }
387 0           $qm =~ s/,$//; # letztes Komma bügeln
388            
389             # Insert oder Update durchführen
390            
391 0 0         if ( $par->{db_action} eq 'insert' ) {
392             # insert ausführen
393 0           $self->do (
394             sql => "insert into $par->{table} (".
395             join (",",@columns).
396             ") values ($qm)",
397             params => \@values
398             );
399 0           $return_value = $serial;
400             } else {
401             # Parameter der where Klausel in @value pushen
402 0           push @values, @{$par->{params}};
  0            
403            
404             # update ausführen, wenn columns da sind
405             # (bei einem reinen BLOB updated passiert es,
406             # daß keine 'normalen' Spalten upgedated werden)
407            
408 0 0         if ( @columns ) {
409 0           $return_value = $self->do (
410             sql => "update $par->{table} set ".
411             join(",", map("$_=?", @columns)).
412             " where $par->{where}",
413             params => \@values
414             );
415             }
416             }
417              
418             # nun evtl. BLOBs verarbeiten
419            
420 0 0         if ( $blob_found ) {
421 0 0         if ( $par->{db_action} eq 'insert' ) {
422 0           while ( ($col,$val) = each %blobs ) {
423 0           $self->db_put_blob (
424             $par->{table},
425             "$primary_key=$serial",
426             $col, $val,
427             $type_href
428             );
429             }
430             } else {
431 0           while ( ($col,$val) = each %blobs ) {
432 0           $self->db_put_blob (
433             $par->{table},
434             $par->{where},
435             $col, $val,
436             $type_href,
437             $par->{params}
438             );
439             }
440             }
441             }
442              
443 0           return $return_value;
444             }
445              
446             # Serial ermitteln ---------------------------------------------------
447              
448             sub db_get_serial {
449 0     0 0   my $self = shift;
450            
451 0           my ($table, $col, $type) = @_;
452            
453             # SEQUENCE Namen bestimmen
454            
455 0   0       my $sequence ||= "${table}_SEQ";
456            
457             # Sequence auslesen
458              
459 0           my $serial;
460            
461 0           eval {
462 0           ($serial) = $self->get (
463             sql => "select $sequence.nextval from dual",
464             cache => 1
465             );
466             };
467            
468             # wenn's nicht geklappt hat, gab's die SEQUENCE wohl nicht
469            
470 0 0         if ( $@ ) {
471 0 0         $self->{debug} && print STDERR "$exc:get_serial: sequence existiert nicht\n";
472             # also: legen wir sie doch einfach an!
473            
474 0           my ($max_id) = $self->get (
475             sql => "select max($col) from $table"
476             );
477              
478 0 0         $self->{debug} && print STDERR "$exc:get_serial: max_id=$max_id\n";
479              
480 0           $max_id += 100;
481              
482 0 0         $self->{debug} && print STDERR "$exc:get_serial: create sequence mit start=$max_id\n";
483              
484 0           $self->do (
485             sql => "create sequence $sequence
486             start with $max_id
487             increment by 1"
488             );
489 0           $serial = $max_id-1;
490             }
491            
492 0           return $serial;
493             }
494              
495             # BLOB speichern -----------------------------------------------------
496              
497             sub db_put_blob {
498 0     0 0   my $self = shift;
499              
500 0 0         $self->{debug} && print STDERR "$exc:db_put_blob entered\n";
501              
502             # Workaround für DBD::Proxy. Wenn kein DBD::Oracle installiert
503             # geht das natürlich nicht. Somit funktionieren aber wenigstens
504             # alle Funktionen außer db_put_blob auch unter DBD::Proxy.
505 0           require "DBD/Oracle.pm";
506 0 0         import DBD::Oracle qw(:ora_types)
507             if not $Dimedis::SqlDriver::Oracle::already_imported;
508 0           $Dimedis::SqlDriver::Oracle::already_imported = 1;
509              
510 0           my ($table, $where, $col, $val, $type_href, $param_lref) = @_;
511            
512 0           my $type = $type_href->{$col};
513              
514 0   0       my $set_utf8 = $self->{utf8} && $type eq 'clob';
515              
516 0           my $blob = $self->blob2memory($val, $col, $type);
517              
518             # in $blob steht nun eine Skalarrereferenz auf den Blob
519              
520 0 0         $self->{debug} && print STDERR "$exc:db_put_blob ".
521             "prepare: update $table set $col = ? where $where\n";
522              
523 0 0         my $sth = $self->{dbh}->prepare (qq{
524             update $table set $col = ? where $where
525             }) or croak "$exc:db_put_blob\t$DBI::errstr";
526              
527 0           my $ora_type;
528 0 0         $ora_type = $type eq 'blob' ? ORA_BLOB() : ORA_CLOB();
529              
530 0 0         $self->{debug} && print STDERR "$exc:db_put_blob ora_type=$ora_type\n";
531              
532 0 0         $sth->bind_param(1, $$blob, {ora_type => $ora_type, ora_field => $col} )
533             or croak "$exc:db_put_blob\t$DBI::errstr";
534              
535 0           my $i = 2;
536 0           foreach my $par (@{$param_lref}) {
  0            
537 0           $sth->bind_param($i, $par);
538 0           ++$i;
539             }
540            
541             $sth->execute
542 0 0         or croak "$exc:db_put_blob\t$DBI::errstr";
543              
544 0 0         $sth->finish
545             or croak "$exc:db_put_blob\t$DBI::errstr";
546              
547 0 0         $self->{debug} && print STDERR "$exc:db_put_blob succesfully put blob\n";
548              
549 0           1;
550             }
551              
552             1;
553              
554             __END__