File Coverage

blib/lib/Dimedis/SqlDriver/Sybase.pm
Criterion Covered Total %
statement 18 268 6.7
branch 0 122 0.0
condition 0 18 0.0
subroutine 6 23 26.0
pod 0 17 0.0
total 24 448 5.3


line stmt bran cond sub pod time code
1             package Dimedis::SqlDriver::Sybase;
2              
3 1     1   1061 use strict;
  1         2  
  1         44  
4 1     1   6 use vars qw($VERSION @ISA);
  1         2  
  1         74  
5              
6             $VERSION = '0.12';
7             @ISA = qw(Dimedis::Sql); # Vererbung von Dimedis::Sql
8              
9 1     1   5 use Carp;
  1         2  
  1         68  
10 1     1   13 use File::Copy;
  1         1  
  1         54  
11 1     1   6 use FileHandle;
  1         3  
  1         7  
12              
13             my $exc = "Dimedis::SqlDriver::Sybase:"; # 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           eval {
36             # und eine für Blobs
37 0           $self->do (
38             sql => "create table dim_blob (
39             id integer not null,
40             pos integer not null,
41             chunk image null,
42             primary key(id, pos)
43             )"
44             );
45             };
46              
47 0           return 1;
48             }
49              
50             # insert -------------------------------------------------------------
51              
52             sub db_insert {
53 0     0 0   my $self = shift;
54              
55 0           my ($par)= @_;
56 0           $par->{db_action} = "insert";
57            
58 0           $self->db_insert_or_update ($par);
59             }
60              
61             # update -------------------------------------------------------------
62              
63             sub db_update {
64 0     0 0   my $self = shift;
65              
66 0           my ($par)= @_;
67 0           $par->{db_action} = "update";
68            
69 0           $self->db_insert_or_update ($par);
70             }
71              
72             # blob_read ----------------------------------------------------------
73              
74             sub db_blob_read {
75 0     0 0   my $self = shift;
76            
77 0           my ($par) = @_;
78              
79 0           my $filename = $par->{filename};
80 0           my $filehandle = $par->{filehandle};
81            
82 0           my $dbh = $self->{dbh};
83              
84             # erstmal die Blob-ID holen
85 0           my ($blob_id) = $self->get (
86             sql => "select $par->{col}
87             from $par->{table}
88             where $par->{where}",
89             params => $par->{params},
90             );
91            
92 0 0         return \'' if not $blob_id;
93            
94 0 0         $self->{debug} &&
95             print STDERR "$exc:blob_read blob_id=$blob_id\n";
96            
97             # nun die Chunks dieser ID rausholen
98 0 0         $self->{debug} &&
99             print STDERR "$exc:blob_read SQL=
100             select chunk
101             from dim_blob
102             where id=?
103             order by pos\n";
104 0 0         $self->{debug} && print STDERR "$exc:blob_read PARAMS: $blob_id\n";
105            
106 0 0         my $sth = $self->{dbh}->prepare_cached (qq{
107             select chunk
108             from dim_blob
109             where id=?
110             order by pos
111             }) or die "$exc: prepare $DBI::errstr";
112            
113 0 0         $sth->execute ($blob_id) or croak "$exc: execute $DBI::errstr";
114              
115             # Blob lesen
116 0           my $ar;
117 0           my $blob = "";
118 0           my $chunk;
119             my $cnt;
120 0           while ( $ar = $sth->fetchrow_arrayref ) {
121 0           ++$cnt;
122 0 0         croak "$exc:db_blob_read fetch $DBI::errstr" if $DBI::errstr;
123 0           $chunk = pack("H*", $ar->[0]);
124 0           $chunk = substr($chunk, 0, length($chunk)-1);
125 0           $blob .= $chunk;
126 0 0         $self->{debug} &&
127             printf STDERR "$exc:db_blob_read %d bytes\n",
128             length($chunk);
129             }
130              
131 0 0         $sth->finish or croak $DBI::errstr;
132            
133 0 0         $self->{debug} &&
134             print STDERR "$exc:db_blob_read read $cnt chunks of $BLOB_CHUNK_SIZE bytes\n";
135            
136             # und nun ggf. irgendwo hinschreiben...
137            
138 0 0         if ( $filename ) {
    0          
139 0 0         open (BLOB, "> $filename") or croak "can't write $filename";
140 0           binmode BLOB;
141 0           print BLOB $blob;
142 0           close BLOB;
143 0           $blob = ""; # Speicher wieder freigeben
144             } elsif ( $filehandle ) {
145 0           binmode $filehandle;
146 0           print $filehandle $blob;
147 0           $blob = ""; # Speicher wieder freigeben
148             }
149            
150 0           return \$blob;
151             }
152              
153             # left_outer_join ----------------------------------------------------
154             {
155             my $from;
156             my $where;
157             my %from_tables;
158              
159             sub db_left_outer_join {
160 0     0 0   my $self = shift;
161            
162             # static Variablen initialisieren
163            
164 0           $from = "";
165 0           $where = "";
166 0           %from_tables = ();
167              
168             # Rekursionsmethode anwerfen
169              
170 0           $self->db_left_outer_join_rec ( @_ );
171              
172             # Dreck bereinigen
173            
174 0           $from =~ s/,$//;
175 0           $where =~ s/ AND $//;
176              
177 0           return ($from, $where);
178             }
179              
180             sub db_left_outer_join_rec {
181 0     0 0   my $self = shift;
182              
183 0           my ($lref) = @_;
184            
185             # linke Tabelle in die FROM Zeile
186              
187 0           my $left = $lref->[0];
188 0 0         $from .= $left."," unless $from_tables{$left};
189 0           $from_tables{$left} = 1;
190            
191 0 0         if ( ref $lref->[1] ) {
192             # aha, Outer Join
193 0 0         if ( @{$lref->[1]} > 1 ) {
  0            
194             # kein einfacher Outer Join
195             # (verschachtelt oder outer join gegen
196             # simple join, Fall II/III)
197              
198 0           $where .= $self->db_join_cond (
199             $left,
200             $lref->[2],
201             $lref->[1]->[0],
202             'outer'
203             )." AND ";
204 0           $self->db_left_outer_join_rec ($lref->[1]);
205             } else {
206             # Fall I, outer join einer linken Tabelle
207             # gegen eine oder mehrere rechte Tabellen
208 0           my $i = 1;
209 0           while ($i < @{$lref}) {
  0            
210 0 0         $from .= $lref->[$i]->[0].","
211             unless $from_tables{$lref->[$i]->[0]};
212 0           $from_tables{$lref->[$i]->[0]} = 1;
213 0           $where .= $self->db_join_cond (
214             $left,
215             $lref->[$i+1],
216             $lref->[$i]->[0],
217             'outer'
218             )." AND ";
219 0           $i += 2;
220             }
221             }
222             } else {
223             # noe, kein Outer join
224 0           die "$exc:db_left_outer_join\tcase III does not exist anymore";
225 0           $from .= $lref->[1];
226 0           $where .= $lref->[2]." AND ";
227             }
228             }
229             }
230              
231             # cmpi ---------------------------------------------------------------
232              
233             sub db_cmpi {
234 0     0 0   my $self = shift;
235 0           my ($par)= @_;
236              
237 1     1   1579 use locale;
  1         2  
  1         6  
238              
239 0           return "lower($par->{col}) $par->{op} ".
240             $self->{dbh}->quote (lc($par->{val}));
241             }
242              
243             # use_db -------------------------------------------------------------
244              
245             sub db_use_db {
246 0     0 0   my $self = shift;
247            
248 0           my ($par)= @_;
249              
250 0           $self->do (
251             sql => "use $par->{db}",
252             cache => 1
253             );
254              
255 0           1;
256             }
257              
258             # db_prefix ----------------------------------------------------------
259              
260             sub db_db_prefix {
261 0     0 0   my $self = shift;
262            
263 0           my ($par)= @_;
264              
265 0           return $par->{db}.'..';
266              
267 0           1;
268             }
269              
270             # contains -----------------------------------------------------------
271              
272             sub db_contains {
273 0     0 0   my $self = shift;
274            
275 0           my ($par) = @_;
276 0           my $cond;
277              
278             # bei Sybase z.Zt. nicht unterstüzt, deshalb undef returnen
279              
280 0           return $cond;
281             }
282              
283             # get_features -------------------------------------------------------
284              
285             sub db_get_features {
286 0     0 0   my $self = shift;
287            
288             return {
289 0           serial => 1,
290             blob_read => 1,
291             blob_write => 1,
292             left_outer_join => {
293             simple => 1,
294             nested => 0
295             },
296             cmpi => 1,
297             contains => 0,
298             use_db => 1,
299             cache_control => 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             # linken Tabelle angehängt werden
314              
315              
316 0           my ($left_table, $left_alias) = split (/\s/, $left);
317 0   0       $left_alias ||= $left_table;
318              
319 0           $cond =~ s/($left_alias\.[^\s]+)\s*=\s*(\w)/$1 *= $2/g;
320            
321             #------ Diese Ersetzung erzeugt teilweise einen Syntaxfehler
322             # und zwar genau dann, wenn in der geouter jointen Tabelle
323             # auchnoch Werte eingeschränkt werden
324             # my ($table, $alias) = split (/\s/, $left);
325             # $alias ||= $table;
326            
327             # $cond =~ s/($alias\.[^\s]+)\s*=/$1 *=/g;
328            
329 0           return $cond;
330             }
331              
332             # Serial ermitteln ---------------------------------------------------
333              
334             sub db_get_serial {
335 0     0 0   my $self = shift;
336            
337 0           my ($table, $col) = @_;
338            
339             # Serials erzeugen wir selber, da der identity Mechanismus
340             # von Sybase nicht im Zusammenhang mit Platzhaltern zu
341             # gebrauchen ist (der zuletzt vergebene Wert kann nicht
342             # ermittelt werden).
343            
344             # erstmal die Spalte (bzw. wohl leider die ganze
345             # Tabelle) sperren, mit einem Pseudo Update.
346             # (sonst könnten serials doppelt vergeben werden, da wir
347             # ja erst lesen und dann updaten müssen. Deshalb muß dieser
348             # Vorgang in jedem Fall atomar ablaufen.)
349            
350 0           my $modified = $self->do (
351             sql => "update dim_serial
352             set id=id
353             where name=?",
354             params => [ $table ]
355             );
356            
357             # Hier kommt unsere serial rein.
358 0           my $id;
359            
360 0 0         if ( $modified != 1 ) {
361             # oha, die Zeile für unsere Tabelle gibt's noch
362             # gar nicht: also anlegen!
363             #
364             # Wenn das gelingt, setzen wir $id auf 1,
365             # wenn nicht, war ein anderer Prozeß
366             # schneller und wir müssen uns den Wert
367             # später noch rauslesen ($id bleibt erstmal
368             # undef)
369              
370 0           my ($max_id) = $self->get (
371             sql => "select max($col) from $table"
372             );
373              
374 0 0         $self->{debug} && print STDERR "$exc:get_serial: max_id=$max_id\n";
375              
376 0           $max_id += 100;
377              
378 0 0         $self->{debug} && print STDERR "$exc:get_serial: create sequence mit start=$max_id\n";
379            
380 0           eval {
381 0           $self->do (
382             sql => "insert into dim_serial
383             (name, id)
384             values
385             (?, ?)",
386             params => [ $table, $max_id ]
387             );
388 0           $id = 1;
389             };
390             }
391            
392             # wenn $id noch undef, dann müssen wir uns den Wert
393             # aus der Datenbank holen, eins hochzählen und
394             # wieder wegschreiben
395            
396 0 0         if ( not $id ) {
397 0           ($id) = $self->get (
398             sql => "select id
399             from dim_serial
400             where name=?",
401             params => [ $table ]
402             );
403 0           ++$id;
404 0           $modified = $self->do (
405             sql => "update dim_serial
406             set id=?
407             where name=?",
408             params => [ $id, $table ]
409             );
410 0 0         croak "Serial konnte nicht upgedated werden!"
411             unless $modified == 1;
412             }
413            
414 0           return $id;
415             }
416              
417              
418             # Insert bzw. Update durchführen -------------------------------------
419              
420             sub db_insert_or_update {
421 0     0 0   my $self = shift;
422              
423 0 0         $self->{debug} && print STDERR "$exc:db_insert_or_update entered\n";
424              
425 0           my ($par) = @_;
426 0           my $type_href = $par->{type};
427 0           my $par_cache = $par->{cache};
428              
429 0           my $serial; # evtl. Serial Wert
430 0           my (@columns, @values); # Spaltennamen und -werte
431 0           my $return_value; # serial bei insert,
432             # modified bei update
433            
434             # Parameter aufbereiten
435              
436 0           my ($col, $val);
437 0           my @parameters; # Parameter (Parameterbinding, falls moeglich)
438 0           my %blobs; # Hier werden BLOB Spalten abgelegt, die
439             # nach dem INSERT eingefügt werden
440 0           my $blob_found;
441 0           my $primary_key; # Name der primary key Spalte
442              
443             # Normalerweise werden Statements gecached,
444             # es gibt aber auch Ausnahmen (z.B. bei globaler
445             # Abschaltung oder größeren Texten, s.u.)
446 0           my $cache = 1;
447              
448 0 0         if ( exists $par->{cache} ) {
449             # oder der Benutzer will das Caching Verhalten
450             # explizit selbst steuern
451             # (wobei das später trotzdem noch abgeschaltet werden
452             # kann, z.B. bei größeren Texten, s.u.)
453 0           $cache = $par_cache;
454             }
455              
456             # wenn global abgeschaltet, dann bleibt's auch so
457 0 0         $cache = 0 if not $self->{cache};
458              
459 0           while ( ($col,$val) = each %{$par->{data}} ) {
  0            
460 0           my $type = $type_href->{$col};
461 0           $type =~ s/\(([^\(]+)\)$//;
462 0           my $scale = $1;
463            
464 0           $type =~ s/\[.*//;
465              
466 0 0 0       if ( $type eq 'serial' and ( not $val or not $self->{serial_write} ) ) {
    0 0        
    0 0        
      0        
467              
468             # serials generieren wir uns selber
469 0           $return_value = $self->db_get_serial ($par->{table}, $col);
470 0           push @columns, $col;
471 0           push @values, $return_value;
472 0           push @parameters, "?";
473 0           $primary_key = $col;
474              
475             } elsif ( $type eq 'blob' or $type eq 'clob' ) {
476              
477             # Blobs müssen später reingeupdated
478             # werden (keine Blob-Handling mit
479             # Platzhaltern möglich)
480              
481 0           my $blob_id;
482 0 0         if ( $par->{db_action} eq 'insert' ) {
483             # bei einem Insert legen wir schonmal
484             # die Blob-ID an
485 0           $blob_id = $self->db_get_serial ("dim_blob", "id");
486 0           push @columns, $col;
487 0           push @values, $blob_id;
488 0           push @parameters, "?";
489             } else {
490             # bei einem Update holen wir uns die
491             # Blob-ID aus der Tabelle
492 0           ($blob_id) = $self->get (
493             sql => "select $col
494             from $par->{table}
495             where $par->{where}",
496             params => $par->{params}
497             );
498             }
499            
500 0           $blob_found = 1;
501 0           $blobs{$col} = {
502             id => $blob_id,
503             val => $val
504             };
505             } elsif ( $type eq 'varchar' and $scale > 255) {
506             # grosse Texte muessen im Datentyp Text gespeichert werden,
507             # fuer den allerdings kein Parameterbinding gemacht werden
508             # kann
509 0           push @columns, $col;
510            
511 0 0 0       if ( $val eq '' or not defined $val ) {
512 0           push @parameters, "NULL";
513             } else {
514 0           push @parameters, $self->{dbh}->quote($val);
515             }
516            
517 0           $cache = 0;
518              
519             } else {
520             # alle übrigen Typen werden as is eingefügt
521 0           push @columns, $col;
522 0           push @values, $val;
523 0           push @parameters, "?";
524             }
525             }
526            
527             # Insert oder Update durchführen
528            
529 0 0         if ( $par->{db_action} eq 'insert' ) {
530             # insert ausführen
531              
532 0           $self->do (
533             sql => "insert into $par->{table} (".
534             join (",",@columns).
535             ") values (".
536             join (",",@parameters).
537             ")",
538             params => \@values,
539             cache => $cache
540             );
541             } else {
542             # Parameter der where Klausel in @value pushen
543 0           push @values, @{$par->{params}};
  0            
544            
545             # update ausführen, wenn columns da sind
546             # (bei einem reinen BLOB updated passiert es,
547             # daß keine 'normalen' Spalten upgedated werden)
548            
549 0 0         if ( @columns ) {
550 0           my $i = 0;
551 0           $return_value = $self->do (
552             sql => "update $par->{table} set ".
553             join(",", map( "$_=" . $parameters[$i++],
554             @columns)).
555             " where $par->{where}",
556             params => \@values,
557             cache => $cache
558             );
559            
560             }
561             }
562              
563             # nun evtl. BLOBs verarbeiten
564            
565 0 0         if ( $blob_found ) {
566 0           my $method = "db_$par->{db_action}_blob";
567 0           while ( ($col,$val) = each %blobs ) {
568 0           $self->db_update_or_insert_blob (
569             $val->{id}, # Blob ID
570             $type_href->{$col}, # Blob Typ
571             $par->{table}, # Tabellenname
572             $col, # Blob Spalte
573             $val->{val} # Blob
574             );
575             }
576             }
577              
578 0           return $return_value;
579             }
580              
581             # BLOB updaten oder einfügen -----------------------------------------
582              
583             sub db_update_or_insert_blob {
584 0     0 0   my $self = shift;
585              
586 0 0         $self->{debug} && print STDERR "$exc:db_update_or_insert_blob entered\n";
587              
588 0           my ($blob_id) = @_;
589              
590             # gibt's schon einen Blob?
591 0           my ($blob_exists) = $self->get (
592             sql => "select pos
593             from dim_blob
594             where id=? and pos=1",
595             params => [ $blob_id ]
596             );
597              
598 0 0         if ( $blob_exists ) {
599             # update
600 0           $self->db_update_blob (@_);
601             } else {
602             # insert
603 0           $self->db_insert_blob (@_);
604             }
605             }
606              
607             sub db_insert_blob {
608 0     0 0   my $self = shift;
609              
610 0           my ($blob_id, $type, $table, $col, $val) = @_;
611            
612 0 0         $self->{debug} && print STDERR "$exc:db_insert_blob: serial=$blob_id\n";
613              
614 0           my $fh;
615 0 0         if ( not ref $val ) {
    0          
616             # ein Dateiname: öffnen
617 0           $fh = new FileHandle;
618 0 0         open ($fh, $val) or croak "$exc: can't read file '$val'";
619 0           binmode $fh;
620             } elsif ( ref $val ne 'SCALAR' ) {
621             # kein Skalar, dann Filehandle
622 0           $fh = $val;
623 0           binmode $fh;
624             }
625            
626             # nun ist $fh das FileHandle des Blobs, oder undef,
627             # wenn der Blob im Speicher liegt und $val die
628             # entsprechende Skalarreferenz ist
629            
630 0           my $pos = 0;
631 0 0         if ( not $fh ) {
632             # Blob liegt im Speicher vor
633 0           my $len = length($$val);
634 0           my $idx = 0;
635 0           while ( $idx < $len ) {
636 0           ++$pos;
637 0 0         $self->{debug} &&
638             print STDERR "$exc:db_insert_blob: insert $BLOB_CHUNK_SIZE characters...\n";
639 0           $self->do (
640             sql => "insert into dim_blob (id, pos, chunk)
641             values ($blob_id, $pos, 0x".
642             unpack("H*", substr($$val, $idx, $BLOB_CHUNK_SIZE)).
643             "FF)",
644             cache => 0
645             );
646 0           $idx += $BLOB_CHUNK_SIZE;
647             }
648             } else {
649             # Blob liegt als File vor
650 0           my $chunk;
651 0           while ( read ($fh, $chunk, $BLOB_CHUNK_SIZE) ) {
652 0           ++$pos;
653 0 0         $self->{debug} &&
654             print STDERR "$exc:db_insert_blob: insert ", length($chunk), " characters...\n";
655 0           $self->do (
656             sql => "insert into dim_blob (id, pos, chunk)
657             values ($blob_id, $pos, 0x".
658             unpack("H*", $chunk).
659             "FF)",
660             cache => 0
661             );
662             }
663            
664             # Datei schließen, wenn wir sie selber geöffnet haben
665 0 0         close $fh if not ref $val;
666             }
667              
668 0           1;
669             }
670              
671             sub db_update_blob {
672 0     0 0   my $self = shift;
673              
674 0           my ($blob_id, $type, $table, $col, $val) = @_;
675            
676 0 0         $self->{debug} && print STDERR "$exc:db_update_blob: serial=$blob_id\n";
677              
678 0           my $fh;
679 0 0         if ( not ref $val ) {
    0          
680             # ein Dateiname: öffnen
681 0           $fh = new FileHandle;
682 0 0         open ($fh, $val) or croak "$exc: can't read file '$val'";
683 0           binmode $fh;
684             } elsif ( ref $val ne 'SCALAR' ) {
685             # kein Skalar, dann Filehandle
686 0           $fh = $val;
687 0           binmode $fh;
688             }
689            
690             # nun ist $fh das FileHandle des Blobs, oder undef,
691             # wenn der Blob im Speicher liegt und $val die
692             # entsprechende Skalarreferenz ist
693            
694 0           my $pos = 0;
695 0           my $insert = 0; # wird auf evtl. auf 1 gesetzt, wenn neuer Blob
696             # größer als aktueller Blob ist, dann müssen
697             # neue Chunks angehängt werden.
698              
699 0 0         if ( not $fh ) {
700             # Blob liegt im Speicher vor
701 0           my $len = length($$val);
702 0           my $idx = 0;
703 0           while ( $idx < $len ) {
704 0           ++$pos;
705              
706 0 0         if ( not $insert ) {
707 0           my $updated = $self->do (
708             sql => "update dim_blob set chunk=0x".
709             unpack("H*", substr($$val, $idx, $BLOB_CHUNK_SIZE)).
710             "FF where id=$blob_id and pos=$pos",
711             cache => 0
712             );
713 0 0         $self->{debug} && print STDERR "$exc:db_blob_update update ".
714             "$BLOB_CHUNK_SIZE characters (modified=$updated)...\n";
715 0 0         if ( $updated == 0 ) {
716 0           $insert = 1;
717             }
718             }
719              
720 0 0         if ( $insert ) {
721 0           $self->do (
722             sql => "insert into dim_blob (id, pos, chunk)
723             values ($blob_id, $pos, 0x".
724             unpack("H*", substr($$val, $idx, $BLOB_CHUNK_SIZE)).
725             "FF)",
726             cache => 0
727             );
728 0 0         $self->{debug} && print STDERR "$exc:db_blob_update insert ".
729             "$BLOB_CHUNK_SIZE characters...\n";
730             }
731              
732 0           $idx += $BLOB_CHUNK_SIZE;
733             }
734             } else {
735             # Blob liegt als File vor
736 0           my $chunk;
737 0           while ( read ($fh, $chunk, $BLOB_CHUNK_SIZE) ) {
738 0           ++$pos;
739              
740 0 0         if ( not $insert ) {
741 0           my $updated = $self->do (
742             sql => "update dim_blob set chunk=0x".
743             unpack("H*", $chunk).
744             "FF where id=$blob_id and pos=$pos",
745             cache => 0
746             );
747 0 0         $self->{debug} &&
748             print STDERR "$exc:db_blob_update update ".
749             length($chunk)." characters (modified=$updated)...\n";
750 0 0         if ( $updated == 0 ) {
751 0           $insert = 1;
752             }
753             }
754              
755 0 0         if ( $insert ) {
756 0           $self->do (
757             sql => "insert into dim_blob (id, pos, chunk)
758             values ($blob_id, $pos, 0x".
759             unpack("H*", $chunk).
760             "FF)",
761             cache => 0
762             );
763 0 0         $self->{debug} &&
764             print STDERR "$exc:db_blob_update insert ".
765             length($chunk)." characters...\n";
766             }
767             }
768            
769             # Datei schließen, wenn wir sie selber geöffnet haben
770 0 0         close $fh if not ref $val;
771             }
772              
773 0 0         if ( not $insert ) {
774             # wenn noch im UPDATE Modus, ist der neue Blob vielleicht
775             # kleiner. In dem Fall löschen wir den Rest.
776 0           my $deleted = $self->do (
777             sql => "delete from dim_blob
778             where id=? and pos > ?",
779             params => [ $blob_id, $pos ]
780             );
781            
782 0 0         $self->{debug} &&
783             print STDERR "$exc:db_blob_update deleted ".
784             $deleted." unused blob chunks!\n";
785             }
786              
787 0           1;
788             }
789              
790             1;
791              
792             __END__