File Coverage

blib/lib/Dimedis/SqlDriver/mysql.pm
Criterion Covered Total %
statement 15 173 8.6
branch 0 66 0.0
condition 0 15 0.0
subroutine 5 19 26.3
pod 0 14 0.0
total 20 287 6.9


line stmt bran cond sub pod time code
1             # $Id: mysql.pm,v 1.20 2006/10/20 09:57:43 cvsinst Exp $
2              
3             package Dimedis::SqlDriver::mysql;
4              
5 1     1   1258 use strict;
  1         2  
  1         51  
6 1     1   6 use vars qw($VERSION @ISA $DEFAULT_CHARSET $DEFAULT_COLLATE);
  1         2  
  1         103  
7              
8             $VERSION = '0.17';
9             @ISA = qw(Dimedis::Sql); # Vererbung von Dimedis::Sql
10              
11             $DEFAULT_CHARSET = "latin1";
12             $DEFAULT_COLLATE = "latin1_german1_ci";
13              
14 1     1   13 use Carp;
  1         3  
  1         76  
15 1     1   864 use File::Copy;
  1         2293  
  1         97  
16 1     1   5 use FileHandle;
  1         1  
  1         8  
17              
18             my $exc = "Dimedis::SqlDriver::mysql:"; # Exception Prefix
19              
20             # set_utf8 muß überschrieben werden ==================================
21              
22             sub set_utf8 {
23 0     0 0   my $self = shift;
24 0           my ($utf8) = @_;
25 0           $self->{utf8} = $utf8;
26 0           $self->db_init;
27 0           return $utf8;
28             }
29              
30             # offizielles Dimedis::SqlDriver Interface ===========================
31              
32             # init ---------------------------------------------------------------
33              
34             sub db_init {
35 0     0 0   my $self = shift;
36              
37             # Bei MySQL ab 4.1 muß das Character Set der Verbindung auf
38             # auf den richtigen Wert gesetzt werden, sonst
39             # nimmt der MySQL Server zusätzliche Konvertierungen
40             # vor - damit stehen dann z.B. "doppelt" utf8 kodierte Zeichen
41             # in der Datenbank.
42              
43 0           my $dbh = $self->{dbh};
44 0           my $version = $dbh->{mysql_serverinfo};
45 0           my @v = $version =~ /(\d+)/g;
46 0           my $num_version = $v[0]*10000+$v[1]*100+$v[2];
47              
48 0 0         $self->{debug} &&
49             print STDERR "$exc:db_init: MySQL ".
50             "Server version $version detected\n";
51              
52 0 0         my $charset = $self->{utf8} ? "utf8" : $DEFAULT_CHARSET;
53 0 0         my $collate = $self->{utf8} ? "utf8_general_ci" : $DEFAULT_COLLATE;
54              
55 0 0         if ( $num_version >= 40100 ) {
56 0           $dbh->do ("set character_set_client='$charset'");
57 0           $dbh->do ("set character_set_connection='$charset'");
58 0           $dbh->do ("set character_set_results='$charset'");
59 0           $dbh->do ("set collation_connection='$collate'");
60            
61 0 0         $self->{debug} &&
62             print STDERR "$exc:db_init: version > 4.1 => set charset/collate $charset/$collate\n";
63             } else {
64 0 0         $self->{debug} &&
65             print STDERR "$exc:db_init: version < 4.1 => no charset setting\n";
66             }
67            
68 0           return 1;
69             }
70              
71             # install ------------------------------------------------------------
72              
73             sub db_install {
74 0     0 0   my $self = shift;
75            
76 0           return 1;
77             }
78              
79             # insert -------------------------------------------------------------
80              
81             sub db_insert {
82 0     0 0   my $self = shift;
83              
84 0           my ($par)= @_;
85 0           $par->{db_action} = "insert";
86            
87 0           $self->db_insert_or_update ($par);
88             }
89              
90             # update -------------------------------------------------------------
91              
92             sub db_update {
93 0     0 0   my $self = shift;
94              
95 0           my ($par)= @_;
96 0           $par->{db_action} = "update";
97            
98 0           $self->db_insert_or_update ($par);
99             }
100              
101             # blob_read ----------------------------------------------------------
102              
103             sub db_blob_read {
104 0     0 0   my $self = shift;
105            
106 0           my ($par) = @_;
107              
108 0           my $filename = $par->{filename};
109 0           my $filehandle = $par->{filehandle};
110            
111 0           my $dbh = $self->{dbh};
112            
113             # das ist einfach! rausSELECTen halt...
114              
115 0 0         my $sth = $dbh->prepare (
116             "select $par->{col}
117             from $par->{table}
118             where $par->{where}"
119             ) or croak "$DBI::errstr";
120            
121 0 0         $sth->execute(@{$par->{params}}) or croak $DBI::errstr;
  0            
122              
123             # Blob lesen
124              
125 0           my $ar = $sth->fetchrow_arrayref;
126 0 0         croak $DBI::errstr if $DBI::errstr;
127 0 0         if ( not defined $ar ) {
128 0           return \"";
129             }
130              
131 0           my $blob = $ar->[0];
132              
133 0 0         $sth->finish or croak $DBI::errstr;
134            
135             # und nun ggf. irgendwo hinschreiben...
136            
137 0 0         if ( $filename ) {
    0          
138 0 0         open (BLOB, "> $filename") or croak "can't write $filename";
139             # Kein UTF8 Handling nötig hier. Die BLOB Variable hat
140             # kein UTF8 Flag. Falls die DB UTF8 geliefert hat, können
141             # die Daten also raw geschrieben werden. Sonst müßte der
142             # IO Layer auf utf8 gesetzt werden *und* $blob müßte das
143             # UTF8-Flag bekommen. Überflüssig!
144 0           binmode BLOB;
145 0           print BLOB $blob;
146 0           close BLOB;
147 0           $blob = ""; # Speicher wieder freigeben
148              
149             } elsif ( $filehandle ) {
150 0           binmode $filehandle;
151 0           print $filehandle $blob;
152 0           $blob = ""; # Speicher wieder freigeben
153             }
154              
155 0 0 0       return if $par->{filehandle} or $par->{filename};
156 0           return \$blob;
157             }
158              
159             # left_outer_join ----------------------------------------------------
160             {
161             my $from;
162             my $where;
163              
164             sub db_left_outer_join {
165 0     0 0   my $self = shift;
166            
167             # static Variablen initialisieren
168            
169 0           $from = "";
170 0           $where = "";
171              
172             # Rekursionsmethode anwerfen
173              
174 0           $self->db_left_outer_join_rec ( @_ );
175            
176             # Dreck bereinigen
177              
178 0           $from =~ s/,$//;
179 0           $from =~ s/,\)/)/g;
180 0           $where =~ s/ AND $//;
181              
182 0 0         $where = '1=1' if $where eq '';
183              
184 0           return ($from, $where);
185             }
186              
187             sub db_left_outer_join_rec {
188 0     0 0   my $self = shift;
189              
190 0           my ($lref, $left_table_out) = @_;
191            
192             # linke Tabelle in die FROM Zeile
193              
194 0 0         $from .= " ".$lref->[0]
195             if not $left_table_out;
196            
197 0 0         if ( ref $lref->[1] ) {
198             # aha, Outer Join
199 0 0         if ( @{$lref->[1]} > 1 ) {
  0            
200             # kein einfacher Outer Join
201             # (verschachtelt oder outer join gegen
202             # simple join, Fall II/III)
203              
204 0           $from .= " left outer join ".$lref->[1]->[0].
205             " on ".$lref->[2];
206              
207 0           $self->db_left_outer_join_rec ($lref->[1], 1);
208              
209             } else {
210             # Fall I, outer join einer linken Tabelle
211             # gegen eine oder mehrere rechte Tabellen
212 0           my $i = 1;
213 0           while ($i < @{$lref}) {
  0            
214 0           $from .= " left outer join ".$lref->[$i]->[0].
215             " on ".$lref->[$i+1];
216 0           $i += 2;
217             }
218             }
219             } else {
220             # noe, kein Outer join
221 0           croak "$exc:db_left_outer_join\tcase III does not exist anymore";
222 0           $from .= $lref->[1];
223 0           $where .= $lref->[2]." AND ";
224             }
225             }
226             }
227              
228             # cmpi ---------------------------------------------------------------
229              
230             sub db_cmpi {
231 0     0 0   my $self = shift;
232 0           my ($par)= @_;
233              
234 0 0         my $not = $par->{op} eq '!=' ? 'not ' : '';
235              
236 0           my $quoted = $self->{dbh}->quote ($par->{val});
237              
238             # Bug in DBI->quote. utf8 flag ist weg :(
239             # (wurde durch utf8::upgrade in ->cmpi gesetzt)
240 0 0         Encode::_utf8_on($quoted) if $self->{utf8};
241              
242 0           return "${not}lower($par->{col}) like $quoted";
243             }
244              
245             # use_db -------------------------------------------------------------
246              
247             sub db_use_db {
248 0     0 0   my $self = shift;
249            
250 0           my ($par)= @_;
251              
252 0           $self->do (
253             sql => "use $par->{db}"
254             );
255              
256 0           1;
257             }
258              
259             # db_prefix ----------------------------------------------------------
260              
261             sub db_db_prefix {
262 0     0 0   my $self = shift;
263            
264 0           my ($par)= @_;
265              
266 0           return $par->{db}.'.';
267              
268 0           1;
269             }
270              
271             # contains -----------------------------------------------------------
272              
273             sub db_contains {
274 0     0 0   my $self = shift;
275 0           my ($par) = @_;
276              
277 0           my $col = $par->{col};
278 0           my $vals = $par->{vals};
279 0           my $logic_op = $par->{logic_op};
280              
281 0           my $dbh = $self->{dbh};
282              
283 0           my $cond;
284 0           foreach my $val ( @{$vals} ) {
  0            
285 0           $cond .= "$col like ".
286             $dbh->quote('%'.$val.'%').
287             " $logic_op ";
288             }
289            
290 0           $cond =~ s/ $logic_op $//;
291 0           $cond = "($cond)";
292              
293 0           return $cond;
294             }
295              
296             # get_features -------------------------------------------------------
297              
298             sub db_get_features {
299 0     0 0   my $self = shift;
300            
301             return {
302 0           serial => 1,
303             blob_read => 1,
304             blob_write => 1,
305             left_outer_join => {
306             simple => 1,
307             nested => 1
308             },
309             cmpi => 1,
310             contains => 1,
311             use_db => 1,
312             utf8 => 1,
313             };
314             }
315              
316             # Driverspezifische Hilfsmethoden ====================================
317              
318             # Insert bzw. Update durchführen -------------------------------------
319              
320             sub db_insert_or_update {
321 0     0 0   my $self = shift;
322              
323 0           my ($par) = @_;
324 0           my $type_href = $par->{type};
325              
326 0           my $serial; # evtl. Serial Wert
327 0           my (@columns, @values); # Spaltennamen und -werte
328 0           my $return_value; # serial bei insert,
329             # modified bei update
330            
331             # Parameter aufbereiten
332              
333 0           my ($col, $val);
334 0           my $qm; # Fragezeichen für Parameterbinding
335 0           my %blobs; # Hier werden BLOB Spalten abgelegt, die
336             # nach dem INSERT eingefügt werden
337 0           my $blob_found;
338            
339 0           while ( ($col,$val) = each %{$par->{data}} ) {
  0            
340 0           my $type = $type_href->{$col};
341 0           $type =~ s/\[.*//;
342              
343 0 0 0       if ( $type eq 'serial' and not defined $val ) {
    0 0        
344             # serial Typ bearbeiten
345 0           push @columns, $col;
346 0           push @values, 0;
347 0           $qm .= "?,";
348            
349             } elsif ( $type eq 'blob' or $type eq 'clob' ) {
350              
351             # Blob muß in jedem Fall im Speicher vorliegen
352 0           $val = $self->blob2memory($val, $col, $type);
353              
354             # Ggf. UTF8 draus machen (utf-8 Handling wird bei
355             # Dimedis::Sql->do Aufruf abgeschaltet, das muss
356             # der mysql Driver selbst machen, weil Blobs auch
357             # via Params übergeben werden, da darf kein utf8::upgrade
358             # drauf gemacht werden
359 0 0 0       if ( $self->{utf8} and $type_href->{$col} eq 'clob' ) {
    0 0        
360 0           utf8::upgrade($$val);
361             }
362             elsif ( !$self->{utf8} and $type_href->{$col} eq 'clob' ) {
363 0 0         $$val = Encode::encode("windows-1252", $$val)
364             if Encode::is_utf8($$val);
365             }
366              
367             # Blobs können inline geinsertet
368             # und updated werden
369 0           push @columns, $col;
370 0           push @values, $$val;
371 0           $qm .= "?,";
372              
373             } else {
374             # utf8 Behandlung
375 0 0         if ( $self->{utf8} ) {
376 0           utf8::upgrade($val);
377             }
378             else {
379 0 0         $val = Encode::encode("windows-1252", $val)
380             if Encode::is_utf8($val);
381             }
382              
383             # Leerstring zu NULL machen
384             # (wird hier gemacht, da CLOB's nicht so behandelt
385             # werden dürfen - hier gibt es den Unterschied
386             # zwischen NULL und '' noch)
387 0 0         $val = undef if $val eq '';
388              
389             # alle übrigen Typen werden as is eingefügt
390 0           push @columns, $col;
391 0           push @values, $val;
392 0           $qm .= "?,";
393             }
394             }
395 0           $qm =~ s/,$//; # letztes Komma bügeln
396              
397             # Insert oder Update durchführen
398 0 0         if ( $par->{db_action} eq 'insert' ) {
399             # insert ausführen
400              
401 0           $self->do (
402             sql => "insert into $par->{table} (".
403             join (",",@columns).
404             ") values ($qm)",
405             params => \@values,
406              
407             no_utf8 => 1, # Das haben wir schon gemacht,
408             # außer bei Blobs. Die werden bei
409             # MySQL as-is eingefügt, aber
410             # dürfen natürlich *nicht* nach
411             # UTF8 konvertiert werden,
412              
413             no_nulling => 1,# Das haben wir schon gemacht,
414             # nur bei CLOBs nicht, weil hier
415             # '' und NULL unterscheidbar sein
416             # sollen.
417            
418             );
419            
420 0           $return_value = $self->{dbh}->{'mysql_insertid'};
421            
422             } else {
423             # ggf. UTF8 Konvertierung der Parameter vornehmen
424             # (wird in Dimedis::Sql->do nicht gemacht, Kommentar s.o.)
425 0 0         if ( $self->{utf8} ) {
426 0           foreach my $p ( @{$par->{params}} ) {
  0            
427 0           utf8::upgrade($p);
428             }
429             }
430             else {
431 0           foreach my $p ( @{$par->{params}} ) {
  0            
432 0 0         $p = Encode::encode("windows-1252", $p)
433             if Encode::is_utf8($p);
434             }
435             }
436              
437             # Parameter der where Klausel in @value pushen
438 0           push @values, @{$par->{params}};
  0            
439            
440             # update ausführen, wenn columns da sind
441             # (bei einem reinen BLOB updated passiert es,
442             # daß keine 'normalen' Spalten upgedated werden)
443            
444 0 0         if ( @columns ) {
445 0           $return_value = $self->do (
446             sql => "update $par->{table} set ".
447             join(",", map("$_=?", @columns)).
448             " where $par->{where}",
449             params => \@values,
450             no_utf8 => 1,
451             no_nulling => 1,
452             );
453             }
454             }
455              
456 0           return $return_value;
457             }
458              
459             1;
460              
461             __END__