File Coverage

blib/lib/Dimedis/SqlDriver/ASAny.pm
Criterion Covered Total %
statement 18 177 10.1
branch 0 50 0.0
condition 0 9 0.0
subroutine 6 21 28.5
pod 0 15 0.0
total 24 272 8.8


line stmt bran cond sub pod time code
1             package Dimedis::SqlDriver::ASAny;
2              
3 1     1   788 use strict;
  1         2  
  1         38  
4 1     1   6 use vars qw($VERSION @ISA);
  1         2  
  1         84  
5              
6             $VERSION = '0.03';
7             @ISA = qw(Dimedis::Sql); # Vererbung von Dimedis::Sql
8              
9 1     1   6 use Carp;
  1         2  
  1         60  
10 1     1   5 use File::Copy;
  1         2  
  1         46  
11 1     1   6 use FileHandle;
  1         2  
  1         6  
12              
13             my $exc = "Dimedis::SqlDriver::ASAny:"; # Exception Prefix
14              
15             my $BLOB_CHUNK_SIZE = 16382;
16              
17             # offizielles Dimedis::SqlDriver Interface ===========================
18              
19             # install ------------------------------------------------------------
20              
21             sub db_install {
22 0     0 0   my $self = shift;
23              
24 0           eval {
25             # wir brauchen eine Tabelle für serials
26 0           $self->do (
27             sql => "create table dim_serial (
28             name varchar(32) not null,
29             id integer default 0,
30             primary key(name)
31             )"
32             );
33             };
34              
35 0           return 1;
36             }
37              
38             # insert -------------------------------------------------------------
39              
40             sub db_insert {
41 0     0 0   my $self = shift;
42              
43 0           my ($par)= @_;
44 0           $par->{db_action} = "insert";
45            
46 0           $self->db_insert_or_update ($par);
47             }
48              
49             # update -------------------------------------------------------------
50              
51             sub db_update {
52 0     0 0   my $self = shift;
53              
54 0           my ($par)= @_;
55 0           $par->{db_action} = "update";
56            
57 0           $self->db_insert_or_update ($par);
58             }
59              
60             # blob_read ----------------------------------------------------------
61              
62             sub db_blob_read {
63 0     0 0   my $self = shift;
64              
65 0           my ($par) = @_;
66              
67 0           my $filename = $par->{filename};
68 0           my $filehandle = $par->{filehandle};
69              
70 0           my $dbh = $self->{dbh};
71              
72 0           $dbh->{LongReadLen} = 4000000;
73              
74             # das ist einfach! rausSELECTen halt...
75              
76 0 0         my $sth = $dbh->prepare (
77             "select $par->{col}
78             from $par->{table}
79             where $par->{where}"
80             ) or croak "$DBI::errstr";
81              
82 0 0         $sth->execute(@{$par->{params}}) or croak $DBI::errstr;
  0            
83              
84             # Blob lesen
85              
86 0 0         my $ar = $sth->fetchrow_arrayref or croak $DBI::errstr;
87 0           my $blob = $ar->[0];
88              
89 0 0         $sth->finish or croak $DBI::errstr;
90              
91             # und nun ggf. irgendwo hinschreiben...
92              
93 0 0         if ( $filename ) {
    0          
94 0 0         open (BLOB, "> $filename") or croak "can't write $filename";
95 0           binmode BLOB;
96 0           print BLOB $blob;
97 0           close BLOB;
98 0           $blob = ""; # Speicher wieder freigeben
99             } elsif ( $filehandle ) {
100 0           binmode $filehandle;
101 0           print $filehandle $blob;
102 0           $blob = ""; # Speicher wieder freigeben
103             }
104              
105 0           return \$blob;
106             }
107              
108             # left_outer_join ----------------------------------------------------
109             {
110             my $from;
111             my $where;
112             my %from_tables;
113              
114             sub db_left_outer_join {
115 0     0 0   my $self = shift;
116            
117             # static Variablen initialisieren
118            
119 0           $from = "";
120 0           $where = "";
121 0           %from_tables = ();
122              
123             # Rekursionsmethode anwerfen
124              
125 0           $self->db_left_outer_join_rec ( @_ );
126              
127             # Dreck bereinigen
128            
129 0           $from =~ s/,$//;
130 0           $where =~ s/ AND $//;
131              
132 0           return ($from, $where);
133             }
134              
135             sub db_left_outer_join_rec {
136 0     0 0   my $self = shift;
137              
138 0           my ($lref) = @_;
139            
140             # linke Tabelle in die FROM Zeile
141              
142 0           my $left = $lref->[0];
143 0 0         $from .= $left."," unless $from_tables{$left};
144 0           $from_tables{$left} = 1;
145            
146 0 0         if ( ref $lref->[1] ) {
147             # aha, Outer Join
148 0 0         if ( @{$lref->[1]} > 1 ) {
  0            
149             # kein einfacher Outer Join
150             # (verschachtelt oder outer join gegen
151             # simple join, Fall II/III)
152              
153 0           $where .= $self->db_join_cond (
154             $left,
155             $lref->[2],
156             $lref->[1]->[0],
157             'outer'
158             )." AND ";
159 0           $self->db_left_outer_join_rec ($lref->[1]);
160             } else {
161             # Fall I, outer join einer linken Tabelle
162             # gegen eine oder mehrere rechte Tabellen
163 0           my $i = 1;
164 0           while ($i < @{$lref}) {
  0            
165 0 0         $from .= $lref->[$i]->[0].","
166             unless $from_tables{$lref->[$i]->[0]};
167 0           $from_tables{$lref->[$i]->[0]} = 1;
168 0           $where .= $self->db_join_cond (
169             $left,
170             $lref->[$i+1],
171             $lref->[$i]->[0],
172             'outer'
173             )." AND ";
174 0           $i += 2;
175             }
176             }
177             } else {
178             # noe, kein Outer join
179 0           die "$exc:db_left_outer_join\tcase III does not exist anymore";
180 0           $from .= $lref->[1];
181 0           $where .= $lref->[2]." AND ";
182             }
183             }
184             }
185              
186             # cmpi ---------------------------------------------------------------
187              
188             sub db_cmpi {
189 0     0 0   my $self = shift;
190 0           my ($par)= @_;
191              
192 1     1   1558 use locale;
  1         2  
  1         8  
193              
194 0           return "lower($par->{col}) $par->{op} ".
195             $self->{dbh}->quote (lc($par->{val}));
196             }
197              
198             # use_db -------------------------------------------------------------
199              
200             sub db_use_db {
201 0     0 0   my $self = shift;
202            
203 0           my ($par)= @_;
204              
205 0           $self->do (
206             sql => "use $par->{db}",
207             cache => 1
208             );
209              
210 0           1;
211             }
212              
213             # db_prefix ----------------------------------------------------------
214              
215             sub db_db_prefix {
216 0     0 0   my $self = shift;
217            
218 0           my ($par)= @_;
219              
220 0           return $par->{db}.'..';
221              
222 0           1;
223             }
224              
225             # contains -----------------------------------------------------------
226              
227             sub db_contains {
228 0     0 0   my $self = shift;
229            
230 0           my ($par) = @_;
231 0           my $cond;
232              
233             # bei ASAny z.Zt. nicht unterstüzt, deshalb undef returnen
234              
235 0           return $cond;
236             }
237              
238             # get_features -------------------------------------------------------
239              
240             sub db_get_features {
241 0     0 0   my $self = shift;
242            
243             return {
244 0           serial => 1,
245             blob_read => 1,
246             blob_write => 1,
247             left_outer_join => {
248             simple => 1,
249             nested => 0
250             },
251             cmpi => 1,
252             contains => 0,
253             use_db => 1,
254             cache_control => 1
255             };
256             }
257              
258             # Driverspezifische Hilfsmethoden ====================================
259              
260             # join Bedingung bauen -----------------------------------------------
261              
262             sub db_join_cond {
263 0     0 0   my $self = shift;
264            
265 0           my ($left, $cond, $right, $join) = @_;
266            
267             # beim outer join müssen * Zeichen bei = Ausdrücken der
268             # linken Tabelle angehängt werden
269            
270 0           my ($table, $alias) = split (/\s/, $left);
271 0   0       $alias ||= $table;
272            
273 0           $cond =~ s/($alias\.[^\s]+)\s*=/$1 *=/g;
274            
275 0           return $cond;
276             }
277              
278             # Serial ermitteln ---------------------------------------------------
279              
280             sub db_get_serial {
281 0     0 0   my $self = shift;
282            
283 0           my ($table) = @_;
284            
285             # Serials erzeugen wir selber, da der identity Mechanismus
286             # von Sybase nicht im Zusammenhang mit Platzhaltern zu
287             # gebrauchen ist (der zuletzt vergebene Wert kann nicht
288             # ermittelt werden).
289            
290             # erstmal die Spalte (bzw. wohl leider die ganze
291             # Tabelle) sperren, mit einem Pseudo Update.
292             # (sonst könnten serials doppelt vergeben werden, da wir
293             # ja erst lesen und dann updaten müssen. Deshalb muß dieser
294             # Vorgang in jedem Fall atomar ablaufen.)
295            
296 0           my $modified = $self->do (
297             sql => "update dim_serial
298             set id=id
299             where name=?",
300             params => [ $table ]
301             );
302            
303             # Hier kommt unsere serial rein.
304 0           my $id;
305            
306 0 0         if ( $modified != 1 ) {
307             # oha, die Zeile für unsere Tabelle gibt's noch
308             # gar nicht: also anlegen!
309             #
310             # Wenn das gelingt, setzen wir $id auf 1,
311             # wenn nicht, war ein anderer Prozeß
312             # schneller und wir müssen uns den Wert
313             # später noch rauslesen ($id bleibt erstmal
314             # undef)
315            
316 0           eval {
317 0           $self->do (
318             sql => "insert into dim_serial
319             (name, id)
320             values
321             (?, ?)",
322             params => [ $table, 1 ]
323             );
324 0           $id = 1;
325             };
326             }
327            
328             # wenn $id noch undef, dann müssen wir uns den Wert
329             # aus der Datenbank holen, eins hochzählen und
330             # wieder wegschreiben
331            
332 0 0         if ( not $id ) {
333 0           ($id) = $self->get (
334             sql => "select id
335             from dim_serial
336             where name=?",
337             params => [ $table ]
338             );
339 0           ++$id;
340 0           $modified = $self->do (
341             sql => "update dim_serial
342             set id=?
343             where name=?",
344             params => [ $id, $table ]
345             );
346 0 0         croak "Serial konnte nicht upgedated werden!"
347             unless $modified == 1;
348             }
349            
350 0           return $id;
351             }
352              
353              
354             # Insert bzw. Update durchführen -------------------------------------
355              
356             sub db_insert_or_update {
357 0     0 0   my $self = shift;
358              
359 0 0         $self->{debug} && print STDERR "$exc:db_insert_or_update entered\n";
360              
361 0           my ($par) = @_;
362 0           my $type_href = $par->{type};
363 0           my $par_cache = $par->{cache};
364              
365 0           my $serial; # evtl. Serial Wert
366 0           my (@columns, @values); # Spaltennamen und -werte
367 0           my $return_value; # serial bei insert,
368             # modified bei update
369            
370             # Parameter aufbereiten
371              
372 0           my ($col, $val);
373 0           my @parameters; # Parameter (Parameterbinding, falls moeglich)
374 0           my %blobs; # Hier werden BLOB Spalten abgelegt, die
375             # nach dem INSERT eingefügt werden
376 0           my $blob_found;
377 0           my $primary_key; # Name der primary key Spalte
378 0           my $qm; # für ? Parameterbinding
379              
380             # Normalerweise werden Statements gecached,
381             # es gibt aber auch Ausnahmen (z.B. bei globaler
382             # Abschaltung oder größeren Texten, s.u.)
383 0           my $cache = 1;
384              
385 0 0         if ( exists $par->{cache} ) {
386             # oder der Benutzer will das Caching Verhalten
387             # explizit selbst steuern
388             # (wobei das später trotzdem noch abgeschaltet werden
389             # kann, z.B. bei größeren Texten, s.u.)
390 0           $cache = $par_cache;
391             }
392              
393             # wenn global abgeschaltet, dann bleibt's auch so
394 0 0         $cache = 0 if not $self->{cache};
395              
396 0           while ( ($col,$val) = each %{$par->{data}} ) {
  0            
397 0           my $type = $type_href->{$col};
398 0           $type =~ s/\(([^\(]+)\)$//;
399 0           my $scale = $1;
400            
401 0           $type =~ s/\[.*//;
402              
403 0 0 0       if ( $type eq 'serial' ) {
    0          
404              
405             # serials generieren wir uns selber
406 0           $return_value = $self->db_get_serial ($par->{table});
407 0           push @columns, $col;
408 0           push @values, $return_value;
409 0           push @parameters, "?";
410 0           $primary_key = $col;
411 0           $qm .= '?,';
412              
413             } elsif ( $type eq 'blob' or $type eq 'clob' ) {
414              
415             # Blob muß in jedem Fall im Speicher vorliegen
416              
417 0           $val = $self->db_blob2memory($val);
418              
419             # Blobs können inline geinsertet
420             # und updated werden
421 0           push @columns, $col;
422 0           push @values, $$val;
423 0           $qm .= "?,";
424              
425             } else {
426             # alle übrigen Typen werden as is eingefügt
427 0           push @columns, $col;
428 0           push @values, $val;
429 0           $qm .= "?,";
430             }
431             }
432 0           $qm =~ s/,$//; # letztes Komma bügeln
433            
434             # Insert oder Update durchführen
435            
436 0 0         if ( $par->{db_action} eq 'insert' ) {
437             # insert ausführen
438              
439 0           $self->do (
440             sql => "insert into $par->{table} (".
441             join (",",@columns).
442             ") values ($qm)",
443             params => \@values,
444             cache => $cache
445             );
446             } else {
447             # Parameter der where Klausel in @value pushen
448 0           push @values, @{$par->{params}};
  0            
449            
450             # update ausführen, wenn columns da sind
451             # (bei einem reinen BLOB updated passiert es,
452             # daß keine 'normalen' Spalten upgedated werden)
453            
454 0 0         if ( @columns ) {
455 0           $return_value = $self->do (
456             sql => "update $par->{table} set ".
457             join(",", map("$_=?", @columns)).
458             " where $par->{where}",
459             params => \@values
460             );
461             }
462             }
463              
464 0           return $return_value;
465             }
466              
467             # BLOB ins Memory holen, wenn nicht schon da -------------------------
468              
469             sub db_blob2memory {
470 0     0 0   my $self = shift;
471              
472 0           my ($val) = @_;
473              
474 0           my $blob;
475 0 0 0       if ( ref $val and ref $val ne 'SCALAR' ) {
    0          
476             # Referenz und zwar keine Scalarreferenz
477             # => das ist ein Filehandle
478             # => reinlesen den Kram
479 0           binmode $val;
480 0           $$blob = join ("", <$val>);
481             } elsif ( not ref $val ) {
482             # keine Referenz
483             # => Dateiname
484             # => reinlesen den Kram
485 0           my $fh = new FileHandle;
486 0 0         open ($fh, $val) or croak "can't open file '$val'";
487 0           binmode $fh;
488 0           $$blob = join ("", <$fh>);
489 0 0         $self->{debug} && print STDERR "$exc:db_blob2memory: blob_size ($val): ", length($$blob), "\n";
490 0           close $fh;
491             } else {
492             # andernfalls ist val eine Skalarreferenz mit dem Blob
493             # => nix tun
494 0           $blob = $val;
495             }
496              
497 0           return $blob;
498             }
499              
500             1;
501              
502             __END__