File Coverage

blib/lib/Dimedis/Sql.pm
Criterion Covered Total %
statement 18 284 6.3
branch 0 184 0.0
condition 0 67 0.0
subroutine 6 35 17.1
pod 0 28 0.0
total 24 598 4.0


line stmt bran cond sub pod time code
1             package Dimedis::Sql;
2              
3 1     1   1143 use strict;
  1         3  
  1         52  
4 1     1   7 use vars qw($VERSION);
  1         2  
  1         60  
5 1     1   15 use Carp;
  1         2  
  1         82  
6 1     1   954 use FileHandle;
  1         14139  
  1         5  
7 1     1   368471 use Encode;
  1         44756  
  1         1154  
8              
9             $VERSION = '0.44';
10              
11             my $exc = "Dimedis::Sql:"; # Exception-Type prefix
12              
13             my %known_data_types = ( # bekannte Datentypen
14             'serial' => 1,
15             'date' => 1,
16             'clob' => 1,
17             'blob' => 1,
18             'varchar' => 1,
19             'char' => 1,
20             'integer' => 1,
21             'numeric' => 1,
22             );
23              
24             my %known_operators = ( # bekannte Operatoren
25             '=' => 1,
26             '!=' => 1,
27             'like' => 1
28             );
29              
30 0     0 0   sub get_dbh { shift->{dbh} }
31 0     0 0   sub get_debug { shift->{debug} }
32 0     0 0   sub get_type { shift->{type} }
33 0     0 0   sub get_cache { shift->{cache} }
34 0     0 0   sub get_serial_write { shift->{serial_write} }
35 0     0 0   sub get_utf8 { shift->{utf8} }
36              
37 0     0 0   sub set_debug { shift->{debug} = $_[1] }
38 0     0 0   sub set_type { shift->{type} = $_[1] }
39 0     0 0   sub set_cache { shift->{cache} = $_[1] }
40 0     0 0   sub set_serial_write { shift->{serial_write} = $_[1] }
41 0     0 0   sub set_utf8 { shift->{utf8} = $_[1] }
42              
43             # Kann, muss aber nicht von Drivern implementiert werden
44 0     0 0   sub db_init { 1 }
45              
46             # Konstruktor --------------------------------------------------------
47              
48             sub new {
49 0     0 0   my $class = shift;
50 0           my %par = @_;
51 0           my ($dbh, $debug, $type, $cache, $serial_write, $utf8) =
52             @par{'dbh','debug','type','cache','serial_write','utf8'};
53              
54 0   0       $type ||= {};
55            
56             # Abwärtskompatibilität: wenn cache nicht angegeben ist,
57             # wird das Caching eingeschaltet.
58              
59 0 0         if ( not exists $par{cache} ) {
60 0           $cache = 1;
61             }
62              
63             # Parametercheck
64            
65 0 0         croak "$exc:new\tmissing dbh" if not $dbh;
66              
67             # Datenbanktyp ermitteln
68              
69 0           my $db_type = $dbh->{Driver}->{Name};
70              
71             # Sonderbehandlung fuer das Proxymodul
72 0 0         if ( $db_type eq "Proxy") {
73             # Aus dem DSN die eigentlichen Datenbanktyp ermitteln
74 0           $dbh->{Name} =~ m/;dsn=dbi:([^:]+):/;
75 0           $db_type = $1;
76             }
77              
78             # Instanzhash zusammenbauen
79            
80 0           my $self = {
81             dbh => $dbh,
82             debug => $debug,
83             db_type => $db_type,
84             db_features => undef,
85             type_href => $type,
86             cache => $cache,
87             serial_write => $serial_write,
88             utf8 => $utf8,
89             };
90              
91 0 0         $debug && print STDERR "$exc:new\tdb_type=$db_type\n";
92              
93             # datenbankspezifische Methoden definieren
94 0           require "Dimedis/SqlDriver/$db_type.pm";
95              
96             # diese Klasse in die Vererbungshierarchie einfügen
97 0           my $driver_isa = "Dimedis::SqlDriver::$db_type:\:ISA";
98 1     1   16 { no strict; @{$driver_isa} = ( $class ); }
  1         13  
  1         7725  
  0            
  0            
  0            
99              
100             # diese Instanz auf die SqlDriver Klasse setzen
101 0           bless $self, "Dimedis::SqlDriver::$db_type";
102            
103             # Initialisierungsmethode aufrufen
104 0           $self->db_init;
105            
106             # features Hash initialisieren
107 0           $self->{db_features} = $self->db_get_features;
108              
109             # ggf. Encode Modul laden
110 0 0         require Encode if $utf8;
111            
112 0           return $self;
113             }
114              
115             # Datentyp-Check -----------------------------------------------------
116              
117             sub check_data_types {
118 0     0 0   my $self = shift;
119            
120 0           my ($type_href, $data_href, $action) = @_;
121              
122 0           my $serial_found;
123             my $blob_found;
124            
125 0           my ($col, $type);
126 0           while ( ($col,$type) = each %{$type_href} ) {
  0            
127            
128             # Nur der Datentyp ohne Groessenangabe
129 0           $type =~ s/\([^\(]+\)$//;
130            
131 0 0         croak "$exc:check_data_types\ttype $type unknown"
132             unless defined $known_data_types{$type};
133              
134 0 0 0       if ( $type eq 'serial' ) {
    0          
    0          
135             # Serials dürfen nur 1x vorkommen
136 0 0         if ( exists $data_href->{$col} ) {
137 0 0         croak "$exc:check_data_types\tmultiple serial type"
138             if $serial_found;
139 0           $serial_found = $col;
140             }
141             # wurde was anderes als undef übergeben,
142             # dann Exception
143 0 0 0       croak "$exc:check_data_types\t".
144             "only the undef value allowed for serial columns"
145             if defined $data_href->{$col} and
146             not $self->{serial_write};
147            
148             } elsif ( $type eq 'date') {
149             # GROBER Datumsformatcheck
150 0 0 0       croak "$exc:check_data_types\t".
151             "illegal date: $col=$data_href->{$col}"
152             if $data_href->{$col} and
153             $data_href->{$col} !~
154             /^\d\d\d\d\d\d\d\d\d\d:\d\d:\d\d$/;
155             } elsif ( $type eq 'blob' or $type eq 'clob' ) {
156 0 0         $blob_found = 1 if exists $data_href->{$col};
157             }
158             }
159              
160 0 0 0       croak "$exc:check_data_types\tblob/clob handling only with serial column"
      0        
      0        
161             if $action eq 'insert' and $blob_found and
162             (not $serial_found or
163             not exists $data_href->{$serial_found});
164              
165 0           return $serial_found;
166             }
167              
168             # INSERT -------------------------------------------------------------
169              
170             sub insert {
171 0     0 0   my $self = shift;
172 0           my %par = @_;
173              
174 0   0       $par{type} ||= $self->{type_href}->{$par{table}}; # wenn undef, globales Type Hash holen
175              
176             # Parametercheck
177            
178 0 0         croak "$exc:insert\tmissing table" unless defined $par{table};
179 0 0         croak "$exc:insert\tmissing data" unless defined $par{data};
180              
181 0           $self->check_data_types (
182             $par{type}, $par{data}, 'insert'
183             );
184              
185             # Hier kein UTF8 Upgrading, wird beim späteren
186             # $self->do ( sql => ... ) gemacht. Die Werte
187             # in Data sind noch nicht unbedingt die finalen
188             # Werte (z.B. bei Blobs können hier Filenamen
189             # drin stehen, die an dieser Stelle also noch
190             # nicht zu UTF8 gewandelt werden dürfen).
191              
192             # Driver-Methode aufrufen
193 0           my $serial;
194 0           eval {
195 0           $serial = $self->db_insert (\%par);
196             };
197 0 0         croak "$exc:insert\t$@" if $@;
198              
199 0           return $serial;
200             }
201              
202             # UPDATE -------------------------------------------------------------
203              
204             sub update {
205 0     0 0   my $self = shift;
206 0           my %par = @_;
207            
208 0   0       $par{type} ||= $self->{type_href}->{$par{table}}; # wenn undef, globales Type Hash holen
209 0   0       $par{params} ||= []; # wenn undef, leeres Listref draus machen
210            
211             # Parametercheck
212            
213 0 0         croak "$exc:insert\tmissing table" unless defined $par{table};
214 0 0         croak "$exc:insert\tmissing data" unless defined $par{data};
215 0 0         croak "$exc:insert\tmissing where" unless defined $par{where};
216              
217 0           my $serial_found = $self->check_data_types (
218             $par{type}, $par{data}, 'update'
219             );
220            
221 0 0         croak "$exc:insert\tserial in update not allowed" if $serial_found;
222            
223             # ggf. UTF8 Konvertierung vornehmen
224 0 0         if ( $self->{utf8} ) {
225 0           foreach my $p ( $par{where}, @{$par{params}} ) {
  0            
226 0           utf8::upgrade($p);
227             }
228             }
229            
230             # Kein UTF8 Upgrading auf %{$data}, wird beim späteren
231             # $self->do ( sql => ... ) gemacht. Die Werte
232             # in %{$data} sind noch nicht unbedingt die finalen
233             # Werte (z.B. bei Blobs können hier Filenamen
234             # drin stehen, die an dieser Stelle also noch
235             # nicht zu UTF8 gewandelt werden dürfen).
236              
237             # Driver-Methode aufrufen
238            
239 0           my $modified;
240 0           eval {
241 0           $modified = $self->db_update (\%par);
242             };
243 0 0         croak "$exc:update\t$@" if $@;
244              
245 0           return $modified;
246             }
247              
248             # BLOB_READ ----------------------------------------------------------
249              
250             sub blob_read {
251 0     0 0   my $self = shift;
252 0           my %par = @_;
253            
254 0   0       $par{params} ||= []; # wenn undef, leeres Listref draus machen
255              
256             # Parametercheck
257            
258 0 0         croak "$exc:blob_read\tmissing table" unless defined $par{table};
259 0 0         croak "$exc:blob_read\tmissing where" unless defined $par{where};
260 0 0         croak "$exc:blob_read\tmissing col" unless defined $par{col};
261 0 0 0       croak "$exc:blob_read\tgot filehandle and filename parameter"
262             if defined $par{filehandle} and defined $par{filename};
263            
264             # ggf. UTF8 Konvertierung vornehmen
265 0 0         if ( $self->{utf8} ) {
266 0           foreach my $p ( $par{where}, @{$par{params}} ) {
  0            
267 0           utf8::upgrade($p);
268             }
269             }
270            
271             # Driver-Methode aufrufen
272 0           my $blob;
273 0           eval {
274 0           $blob = $self->db_blob_read (\%par);
275             };
276              
277 0 0         croak "$exc:blob_read\t$@" if $@;
278              
279             # ggf. UTF8 Flag setzen, wenn clob
280 0 0 0       if ( $blob and $self->{utf8} and
      0        
281             $self->{type_href}->{$par{table}}->{$par{col}} eq 'clob' ) {
282 0 0         $self->{debug} && print STDERR "$exc:db_blob_read: Encode::_utf8_on($par{col})\n";
283 0           Encode::_utf8_on($$blob);
284             }
285              
286 0           return $blob;
287             }
288              
289             # DO -----------------------------------------------------------------
290              
291             sub do {
292 0     0 0   my $self = shift;
293 0           my %par = @_;
294 0           my ($sql, $par_cache, $no_utf8, $params, $no_nulling) =
295             @par{'sql','par_cache','no_utf8','params','no_nulling'};
296              
297 0   0       $params ||= [];
298            
299             # ggf. UTF8 Konvertierung vornehmen
300 0 0 0       if ( $self->{utf8} and not $no_utf8 ) {
    0 0        
301 0           foreach my $p ( $par{sql}, @{$params} ) {
  0            
302 0           utf8::upgrade($p);
303             }
304             }
305             elsif ( not $self->{utf8} and not $no_utf8 ) {
306 0           foreach my $p ( $par{sql}, @{$params} ) {
  0            
307 0 0         $p = Encode::encode("windows-1252", $p)
308             if Encode::is_utf8($p);
309             }
310             }
311              
312             # Normalerweise werden SQL Statements hier von DBI gecached.
313             # Es gibt aber Befehle, bei denen das keinen Sinn macht.
314             # Deshalb gibt es drei Mechanismen, die das Caching steuern:
315            
316             # 1. wenn keine SQL Parameter übergeben wurden, gehen wir davon
317             # aus, daß das Statement die Parameter enthält. In diesem
318             # Fall wollen wir das Statement nicht cachen.
319 0           my $use_prepare_cached = @{$params};
  0            
320              
321             # 2. über den Parameter cache kann das Caching explizit
322             # gesteuert werden
323 0 0         if ( exists $par{cache} ) {
324 0           $use_prepare_cached = $par_cache;
325             }
326              
327             # 3. wenn das Caching beim Erzeugen des Dimedis::Sql Instanz
328             # abgeschaltet wurde, gibt's kein Caching!
329            
330 0 0         $use_prepare_cached = 0 if not $self->{cache};
331              
332 0 0         $self->{debug} && print STDERR "$exc:do: sql = $sql\n";
333 0           $self->{debug} && print STDERR "$exc:do: params = ".
334 0 0         join(",", @{$params}), "\n";
335              
336 0           my $sth;
337 0 0         if ( $use_prepare_cached ) {
338 0 0         $self->{debug} && print STDERR "$exc:do: statement is cached\n";
339 0           $sth = $self->{dbh}->prepare_cached ($sql);
340             } else {
341 0 0         $self->{debug} && print STDERR "$exc:do: statement is NOT cached\n";
342 0           $sth = $self->{dbh}->prepare ($sql);
343             }
344 0 0         croak "$exc:do\t$DBI::errstr\n$sql" if $DBI::errstr;
345              
346 0 0         if ( not $no_nulling ) {
347 0           for ( @{$params} ) {
  0            
348 0 0         $_ = undef if $_ eq ''
349             };
350             }
351              
352 0           my $modified = $sth->execute (@{$params});
  0            
353 0 0         croak "$exc:do\t$DBI::errstr\n$sql" if $DBI::errstr;
354            
355 0           $sth->finish;
356            
357 0           return $modified;
358             }
359              
360             sub do_without_cache {
361 0     0 0   my $self = shift;
362 0           my %par = @_;
363              
364 0           my $sql = $par{sql};
365 0   0       my $params = $par{params} ||= [];
366            
367             # ggf. UTF8 Konvertierung vornehmen
368 0 0         if ( $self->{utf8} ) {
    0          
369 0           foreach my $p ( $par{sql}, @{$params} ) {
  0            
370 0           utf8::upgrade($p);
371             }
372             }
373             elsif ( not $self->{utf8} ) {
374 0           foreach my $p ( $par{sql}, @{$params} ) {
  0            
375 0 0         $p = Encode::encode("windows-1252", $p)
376             if Encode::is_utf8($p);
377             }
378             }
379            
380 0 0         $self->{debug} && print STDERR "$exc:do: sql = $sql\n";
381 0           $self->{debug} && print STDERR "$exc:do: params = ".
382 0 0         join(",", @{$params}), "\n";
383              
384 0           my $modified = $self->{dbh}->do ($sql, undef, @{$params});
  0            
385            
386 0 0         croak "$exc:do\t$DBI::errstr\n$sql" if $DBI::errstr;
387            
388 0           return $modified;
389             }
390              
391             # GET ----------------------------------------------------------------
392              
393             sub get {
394 0     0 0   my $self = shift;
395              
396 0           my %par = @_;
397              
398 0           my $sql = $par{sql};
399 0           my $par_cache = $par{cache};
400 0           my $params = $par{params};
401              
402             # ggf. UTF8 Konvertierung vornehmen
403 0 0         if ( $self->{utf8} ) {
404 0           foreach my $p ( $par{sql}, @{$params} ) {
  0            
405 0           utf8::upgrade($p);
406             }
407             }
408            
409 0           my $dbh = $self->{dbh};
410              
411             # Normalerweise werden SQL Statements hier von DBI gecached.
412             # Es gibt aber Befehle, bei denen das keinen Sinn macht.
413             # Deshalb gibt es drei Mechanismen, die das Caching steuern:
414            
415             # 1. wenn keine SQL Parameter übergeben wurden, gehen wir davon
416             # aus, daß das Statement die Parameter enthält. In diesem
417             # Fall wollen wir das Statement nicht cachen.
418 0           my $use_prepare_cached = defined $params;
419              
420             # 2. über den Parameter cache kann das Caching explizit
421             # gesteuert werden
422 0 0         if ( exists $par{cache} ) {
423 0           $use_prepare_cached = $par_cache;
424             }
425              
426             # 3. wenn das Caching beim Erzeugen des Dimedis::Sql Instanz
427             # abgeschaltet wurde, gibt's kein Caching!
428            
429 0 0         $use_prepare_cached = 0 if not $self->{cache};
430              
431 0 0         $self->{debug} && print STDERR "$exc:get sql = $sql\n";
432              
433 0           my $sth;
434            
435 0 0         if ( $use_prepare_cached ) {
436 0 0         $self->{debug} && print STDERR "$exc:get: statement is cached\n";
437 0 0         $sth = $dbh->prepare_cached ($sql)
438             or croak "$exc:get\t$DBI::errstr\n$sql";
439             } else {
440 0 0         $self->{debug} && print STDERR "$exc:get: statement is NOT cached\n";
441 0 0         $sth = $dbh->prepare ($sql)
442             or croak "$exc:get\t$DBI::errstr\n$sql";
443             }
444              
445 0 0         $sth->execute (@{$params})
  0            
446             or croak "$exc:get\t$DBI::errstr\n$sql";
447              
448 0 0         if ( wantarray ) {
449 0           my $lref = $sth->fetchrow_arrayref;
450             # ggf. UTF8 Flag setzen
451 0 0 0       if ( $self->{utf8} and defined $lref ) {
452 0           foreach my $p ( @{$lref} ) {
  0            
453 0           Encode::_utf8_on($p);
454             }
455             }
456 0 0         $sth->finish or croak "$exc:get\t$DBI::errstr\n$sql";
457 0 0         return defined $lref ? @{$lref} : undef;
  0            
458             } else {
459 0           my $href = $sth->fetchrow_hashref;
460 0 0         $sth->finish or croak "$exc:get\t$DBI::errstr\n$sql";
461 0 0         return if not keys %{$href};
  0            
462 0           my %lc_hash;
463 0 0         map { Encode::_utf8_on($href->{$_}) if $self->{utf8};
  0            
464 0           $lc_hash{lc($_)} = $href->{$_} } keys %{$href};
  0            
465 0           return \%lc_hash;
466             }
467             }
468              
469             # LEFT_OUTER_JOIN ----------------------------------------------------
470              
471             sub left_outer_join {
472 0     0 0   my $self = shift;
473              
474             # ggf. UTF8 Konvertierung vornehmen
475 0 0         if ( $self->{utf8} ) {
476 0           _utf8_upgrade_lref (\@_);
477             }
478            
479 0           return $self->db_left_outer_join (\@_);
480             }
481              
482             sub _utf8_upgrade_lref {
483 0     0     my ($lref) = @_;
484            
485 0           foreach my $p ( @{$lref} ) {
  0            
486 0 0         if ( ref $p ) {
487 0           _utf8_upgrade_lref($p);
488             } else {
489 0           utf8::upgrade($p);
490             }
491             }
492              
493 0           1;
494             }
495              
496             # CMPI ---------------------------------------------------------------
497              
498             sub cmpi {
499 0     0 0   my $self = shift;
500            
501 0           my %par = @_;
502              
503             # Parametercheck
504            
505 0 0         croak "$exc:cmpi\tmissing col" unless defined $par{col};
506 0 0         croak "$exc:cmpi\tmissing val" unless defined $par{val};
507 0 0         croak "$exc:cmpi\tmissing op" unless defined $par{op};
508              
509 0 0         croak "$exc:cmpi\tunknown op '$par{op}'"
510             unless defined $known_operators{$par{op}};
511              
512             # ggf. UTF8 Konvertierung vornehmen
513 0 0         if ( $self->{utf8} ) {
514 0           utf8::upgrade($par{col});
515 0           utf8::upgrade($par{val});
516             }
517            
518 0           return $self->db_cmpi (\%par);
519             }
520              
521             # USE_DB -------------------------------------------------------------
522              
523             sub use_db {
524 0     0 0   my $self = shift;
525            
526 0           my %par = @_;
527              
528             # Parametercheck
529            
530 0 0         croak "$exc:cmpi\tmissing db" unless defined $par{db};
531            
532 0           return $self->db_use_db (\%par);
533             }
534              
535             # DB_PREFIX ----------------------------------------------------------
536              
537             sub db_prefix {
538 0     0 0   my $self = shift;
539            
540 0           my %par = @_;
541              
542             # Parametercheck
543            
544 0 0         croak "$exc:cmpi\tmissing db" unless defined $par{db};
545            
546 0           return $self->db_db_prefix (\%par);
547             }
548              
549             # INSTALL ------------------------------------------------------------
550              
551             sub install {
552 0     0 0   my $self = shift;
553            
554 0           my %par = @_;
555            
556 0           eval {
557 0           $self->db_install (\%par);
558             };
559 0 0         croak "$exc:install\t$@" if $@;
560            
561 0           1;
562             }
563              
564             # LEFT_OUTER_JOIN ----------------------------------------------------
565              
566             sub contains {
567 0     0 0   my $self = shift;
568            
569 0           my %par = @_;
570            
571 0 0         croak "$exc:contains\tmissing col" unless defined $par{col};
572 0 0         croak "$exc:contains\tmissing vals" unless defined $par{vals};
573 0 0         croak "$exc:contains\tmissing search_op" unless defined $par{search_op};
574              
575 0 0         croak "$exc:contains\tunsupported search_op '$par{search_op}'"
576             if $par{search_op} ne 'sub';
577              
578 0           croak "$exc:contains\tmissing logic_op (number of vals > 1)"
579 0 0 0       if @{$par{vals}} > 1 and not defined $par{logic_op};
580              
581 0 0 0       croak "$exc:contains\tunknown logic_op ($par{logic_op})"
582             if defined $par{logic_op} and $par{logic_op} !~ /^(and|or)$/;
583              
584             # ggf. UTF8 Konvertierung vornehmen
585 0 0         if ( $self->{utf8} ) {
586 0           foreach my $p ( @{$par{vals}} ) {
  0            
587 0           utf8::upgrade($p);
588             }
589             }
590            
591 0           $self->db_contains (\%par);
592             }
593              
594             # GET_FEATURES -------------------------------------------------------
595              
596             sub get_features {
597 0     0 0   my $self = shift;
598            
599 0           return $self->{db_features};
600             }
601              
602             # HELPDER METHODS FOR DRIVERS ----------------------------------------
603              
604             sub blob2memory {
605 0     0 0   my $self = shift;
606 0           my ($val, $col, $type, $layer) = @_;
607              
608 0 0 0       $layer ||= $self->{utf8} && $type eq 'clob' ? ":utf8" : ":raw";
      0        
609              
610 0 0         $self->{debug} && print STDERR "$exc:db_blob2memory col=$col type=$type layer=$layer\n";
611              
612 0           my $blob;
613 0 0 0       if ( ref $val and ref $val ne 'SCALAR' ) {
    0          
614             # Referenz und zwar keine Scalarreferenz
615             # => das ist ein Filehandle
616             # => reinlesen den Kram
617 0           binmode $val, $layer;
618 0           { local $/ = undef; $blob = <$val> }
  0            
  0            
619              
620             } elsif ( not ref $val ) {
621             # keine Referenz
622             # => Dateiname
623             # => reinlesen den Kram
624 0           my $fh = new FileHandle;
625 0 0         open ($fh, $val) or croak "can't open file '$val'";
626 0           binmode $fh, $layer;
627 0           { local $/ = undef; $blob = <$fh> }
  0            
  0            
628 0           close $fh;
629              
630             } else {
631             # andernfalls ist val eine Skalarreferenz mit dem Blob
632             # => nur ggf. upgraden
633 0 0         utf8::upgrade($$val) if $layer eq ':utf8';
634 0           return $val;
635             }
636              
637 0           return \$blob;
638             }
639              
640             1;
641              
642             __END__