UserDB: log timestamps to second granularity
[interchange.git] / code / UI_Tag / backup_database.coretag
1 # Copyright 2002-2009 Interchange Development Group and others
2
3 # This program is free software; you can redistribute it and/or modify
4 # it under the terms of the GNU General Public License as published by
5 # the Free Software Foundation; either version 2 of the License, or
6 # (at your option) any later version.  See the LICENSE file for details.
7
8 UserTag backup-database Order    tables
9 UserTag backup-database AddAttr
10 UserTag backup-database Version  1.11
11 UserTag backup-database Routine  <<EOR
12 sub {
13         my ($tables, $opt) = @_;
14         my (@tables) = grep /\S/, split /['\s\0]+/, $tables;
15         my $backup_dir =        $opt->{dir}
16                                                 || $::Variable->{BACKUP_DIRECTORY}
17                                                 || "$Vend::Cfg->{VendRoot}/backup";
18         my $gnum   = $opt->{gnumeric};
19         my $agg = "$backup_dir/DBDOWNLOAD.all";
20
21         my $Max_xls_string = 255;
22
23         eval {
24                 require Compress::Zlib;
25         } if $opt->{compress};
26
27         my $xls;
28
29         if ($opt->{xls}) {
30                 eval {
31                         require Spreadsheet::WriteExcel;
32                         import Spreadsheet::WriteExcel;
33                         $xls = Spreadsheet::WriteExcel->new("$backup_dir/DBDOWNLOAD.xls");
34                 };
35                 if ($xls) {
36                         if ($opt->{max_xls_string}) {
37                                 $Max_xls_string = int($opt->{max_xls_string}) || 255;
38                                 $xls->{_xls_strmax} = $Max_xls_string;
39                         }
40                 }
41                 else {
42                         undef $opt->{xls};
43                 }
44         }
45
46         my $gz;
47
48         my @errors;
49
50         if($gnum) {
51                 open (AGG, ">$agg")
52                         or die "Cannot write aggregate file $agg; $!\n";
53         }
54         my $done = 0;
55         for my $table (@tables) {
56                 my $unlink;
57                 my $db = Vend::Data::database_exists_ref($table);
58                 my $fn = $db->config('file');
59                 $fn =~ s:.*/::;
60                 my $file = "$backup_dir/$fn";
61                 my $status;
62                 eval {
63                         $status = export(
64                                                 $table,
65                                                 {
66                                                         force => 1,
67                                                         table => $table,
68                                                         file => $file,
69                                                         type => 'TAB',
70                                                         where => $opt->{where},
71                                                 },
72                                         );
73                 };
74
75                 if(! $status) {
76                         push @errors,
77                                 errmsg(
78                                                 "Error exporting %s to %s: %s",
79                                                 $table,
80                                                 $file,
81                                                 $@ || 'unspecified',
82                                         );
83                         next;
84                 }
85
86                 if($opt->{compress}) {
87                         my $new = "$file.gz";
88                         my $gz;
89                         eval {
90                                 $gz = Compress::Zlib::gzopen($new, "wb")
91                                         or die errmsg("error compressing %s to %s: %s", $new, $agg, $!);
92                                 open(ZIN, $file)
93                                         or die errmsg("error opening %s: %s", $file, $!);
94                                 while(<ZIN>) {
95                                         $gz->gzwrite($_)
96                                                 or die
97                                                         errmsg("gzwrite error on %s: %s", $new, $gz->gzerror());
98                                 }
99                                 $gz->gzclose();
100                                 close ZIN;
101                         };
102                         if($@) {
103                                 push @errors, $@;
104                                 next;
105                         }
106                         $unlink = 1;
107                 }
108                 if($gnum) {
109                         print AGG "\f" if $done;
110                         print AGG "$table\n";
111                         open(RECENT, $file)
112                                 or do {
113                                         push @errors,
114                                                 errmsg("Can't read written file %s: %s", $file, $!);
115                                         next;
116                                 };
117                         while(<RECENT>) {
118                                 /\t/ and s/^/'/ and
119                                         (
120                                                 s/\t(0\d+)/\t'$1/g,
121                                                 s/\t\+/\t'+/g,
122                                                 s/\t( *\d[^\t]*[-A-Za-z ])/\t'$1/g
123                                         );
124                                 print AGG;
125                         }
126                         close RECENT;
127                 }
128                 if($xls) {
129                         my $sheet = $xls->addworksheet($table);
130                         $sheet->{_xls_strmax} = $Max_xls_string
131                                 if defined $opt->{max_xls_string};
132                         $sheet->activate($table) if $table eq $Vend::Cfg->{ProductFiles}[0];
133                         open(RECENT, $file)
134                                 or do {
135                                         push @errors,
136                                                 errmsg("Can't read written file %s: %s", $file, $!);
137                                         next;
138                                 };
139                         my $fstring = <RECENT>;
140                         chomp $fstring;
141                         my @fields = split /\t/, $fstring;
142                         my $maxcol = scalar @fields - 1;
143                         my $j;
144                         for($j = 0; $j <= $maxcol; $j++) {
145                                 $sheet->write_string(0, $j, $fields[$j])
146                                         if length $fields[$j];
147                         }
148                         my $i = 1;
149                         while(<RECENT>) {
150                                 chomp;
151                                 my @extra;
152                                 my @overflow;
153                                 @fields = split /\t/, $_;
154                                 for($j = 0; $j <= $maxcol; $j++) {
155                                         my $l = 0;
156                                         my $ptr;
157                                         if ( length($fields[$j]) > $Max_xls_string) {
158                                                 $overflow[$j] = $fields[$j];
159                                                 $extra[$j] = [];
160                                                 while ( length($overflow[$j]) > $Max_xls_string) {
161                                                         for( ' ', "\n", "&nbsp;" ) {
162                                                                 $ptr = rindex $overflow[$j], $_, $Max_xls_string;
163 #::logDebug("char='$_' ptr=$ptr length=" . length($overflow[$j]) ) if $l < 10;
164                                                                 last if $ptr != -1;
165                                                         }
166 #::logDebug("char='$_' ptr=$ptr\nstring=$overflow[$j]") if $l++ < 10;
167
168                                                         $ptr = 254 if $ptr < 0;
169
170                                                         $ptr++;
171                                                         my $string = substr $overflow[$j], 0, $ptr;
172                                                         $overflow[$j] = substr $overflow[$j], $ptr;
173                                                         push @{$extra[$j]}, $string;
174                                                 }
175                                                 push @{$extra[$j]}, $overflow[$j];
176                                                 $fields[$j] = shift @{$extra[$j]};
177                                         }
178                                         $sheet->write_string($i, $j, $fields[$j]);
179                                 }
180                                 if(@extra) {
181                                         my $max = 0;
182                                         for(@extra) {
183                                                 next unless $_;
184                                                 my $current = scalar @$_;
185                                                 $max = $current if $max < $current;
186                                         }
187                                         for (my $k = 0; $k < $max; $k++) {
188                                                 $i++;
189                                                 for( $j = 0; $j < scalar @extra; $j++) {
190                                                         next unless $_;
191                                                         $sheet->write_string($i, $j, $extra[$j][$k]);
192                                                 }
193                                         }
194                                 }
195                                 $i++;
196                         }
197                         close RECENT;
198                 }
199
200                 unlink($file) if $unlink;
201                 undef $unlink;
202                 $done++;
203         }
204
205         close AGG if $opt->{compress};
206
207         if($opt->{compress} and $gnum and $gnum =~ /^compress/i) {
208                 my $file = $agg;
209                 my $new = "$file.gz";
210                 eval {
211                         my $gz = Compress::Zlib::gzopen($new, "wb")
212                                 or die errmsg("error compressing %s to %s: %s", $new, $agg, $!);
213                         open(ZIN, $file)
214                                 or die errmsg("error opening %s: %s", $file, $!);
215                         while(<ZIN>) {
216                                 $gz->gzwrite($_)
217                                         or die
218                                                 errmsg("gzwrite error on %s: %s", $new, $gz->gzerror());
219                         }
220                         $gz->gzclose();
221                         close ZIN;
222                 };
223                 if($@) {
224                         push @errors, $@;
225                 }
226                 else {
227                         unlink($file);
228                 }
229         }
230         if(@errors) {
231                 $::Scratch->{ui_error} = '<ul><li>';
232                 $::Scratch->{ui_error} .= join "</li>\n<li>", @errors;
233                 $::Scratch->{ui_error} .= '</li></ul>';
234         }
235         return $opt->{hide} ? "" : $done;
236 }
237 EOR