Update guess_cc_type from Business::CreditCard
[interchange.git] / code / UI_Tag / backup_database.coretag
1 # Copyright 2002-2016 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.12
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                 local $Vend::Cfg->{NoExportExternal} if $opt->{force};
63                 eval {
64                         $status = export(
65                                                 $table,
66                                                 {
67                                                         force => 1,
68                                                         table => $table,
69                                                         file => $file,
70                                                         type => 'TAB',
71                                                         where => $opt->{where},
72                                                 },
73                                         );
74                 };
75
76                 if(! $status) {
77                         push @errors,
78                                 errmsg(
79                                                 "Error exporting %s to %s: %s",
80                                                 $table,
81                                                 $file,
82                                                 $@ || 'unspecified',
83                                         );
84                         next;
85                 }
86
87                 if($opt->{compress}) {
88                         my $new = "$file.gz";
89                         my $gz;
90                         eval {
91                                 $gz = Compress::Zlib::gzopen($new, "wb")
92                                         or die errmsg("error compressing %s to %s: %s", $new, $agg, $!);
93                                 open(ZIN, $file)
94                                         or die errmsg("error opening %s: %s", $file, $!);
95                                 while(<ZIN>) {
96                                         $gz->gzwrite($_)
97                                                 or die
98                                                         errmsg("gzwrite error on %s: %s", $new, $gz->gzerror());
99                                 }
100                                 $gz->gzclose();
101                                 close ZIN;
102                         };
103                         if($@) {
104                                 push @errors, $@;
105                                 next;
106                         }
107                         $unlink = 1;
108                 }
109                 if($gnum) {
110                         print AGG "\f" if $done;
111                         print AGG "$table\n";
112                         open(RECENT, $file)
113                                 or do {
114                                         push @errors,
115                                                 errmsg("Can't read written file %s: %s", $file, $!);
116                                         next;
117                                 };
118                         while(<RECENT>) {
119                                 /\t/ and s/^/'/ and
120                                         (
121                                                 s/\t(0\d+)/\t'$1/g,
122                                                 s/\t\+/\t'+/g,
123                                                 s/\t( *\d[^\t]*[-A-Za-z ])/\t'$1/g
124                                         );
125                                 print AGG;
126                         }
127                         close RECENT;
128                 }
129                 if($xls) {
130                         my $sheet = $xls->addworksheet($table);
131                         $sheet->{_xls_strmax} = $Max_xls_string
132                                 if defined $opt->{max_xls_string};
133                         $sheet->activate($table) if $table eq $Vend::Cfg->{ProductFiles}[0];
134                         open(RECENT, $file)
135                                 or do {
136                                         push @errors,
137                                                 errmsg("Can't read written file %s: %s", $file, $!);
138                                         next;
139                                 };
140                         my $fstring = <RECENT>;
141                         chomp $fstring;
142                         my @fields = split /\t/, $fstring;
143                         my $maxcol = scalar @fields - 1;
144                         my $j;
145                         for($j = 0; $j <= $maxcol; $j++) {
146                                 $sheet->write_string(0, $j, $fields[$j])
147                                         if length $fields[$j];
148                         }
149                         my $i = 1;
150                         while(<RECENT>) {
151                                 chomp;
152                                 my @extra;
153                                 my @overflow;
154                                 @fields = split /\t/, $_;
155                                 for($j = 0; $j <= $maxcol; $j++) {
156                                         my $l = 0;
157                                         my $ptr;
158                                         if ( length($fields[$j]) > $Max_xls_string) {
159                                                 $overflow[$j] = $fields[$j];
160                                                 $extra[$j] = [];
161                                                 while ( length($overflow[$j]) > $Max_xls_string) {
162                                                         for( ' ', "\n", "&nbsp;" ) {
163                                                                 $ptr = rindex $overflow[$j], $_, $Max_xls_string;
164 #::logDebug("char='$_' ptr=$ptr length=" . length($overflow[$j]) ) if $l < 10;
165                                                                 last if $ptr != -1;
166                                                         }
167 #::logDebug("char='$_' ptr=$ptr\nstring=$overflow[$j]") if $l++ < 10;
168
169                                                         $ptr = 254 if $ptr < 0;
170
171                                                         $ptr++;
172                                                         my $string = substr $overflow[$j], 0, $ptr;
173                                                         $overflow[$j] = substr $overflow[$j], $ptr;
174                                                         push @{$extra[$j]}, $string;
175                                                 }
176                                                 push @{$extra[$j]}, $overflow[$j];
177                                                 $fields[$j] = shift @{$extra[$j]};
178                                         }
179                                         $sheet->write_string($i, $j, $fields[$j]);
180                                 }
181                                 if(@extra) {
182                                         my $max = 0;
183                                         for(@extra) {
184                                                 next unless $_;
185                                                 my $current = scalar @$_;
186                                                 $max = $current if $max < $current;
187                                         }
188                                         for (my $k = 0; $k < $max; $k++) {
189                                                 $i++;
190                                                 for( $j = 0; $j < scalar @extra; $j++) {
191                                                         next unless $_;
192                                                         $sheet->write_string($i, $j, $extra[$j][$k]);
193                                                 }
194                                         }
195                                 }
196                                 $i++;
197                         }
198                         close RECENT;
199                 }
200
201                 unlink($file) if $unlink;
202                 undef $unlink;
203                 $done++;
204         }
205
206         close AGG if $opt->{compress};
207
208         if($opt->{compress} and $gnum and $gnum =~ /^compress/i) {
209                 my $file = $agg;
210                 my $new = "$file.gz";
211                 eval {
212                         my $gz = Compress::Zlib::gzopen($new, "wb")
213                                 or die errmsg("error compressing %s to %s: %s", $new, $agg, $!);
214                         open(ZIN, $file)
215                                 or die errmsg("error opening %s: %s", $file, $!);
216                         while(<ZIN>) {
217                                 $gz->gzwrite($_)
218                                         or die
219                                                 errmsg("gzwrite error on %s: %s", $new, $gz->gzerror());
220                         }
221                         $gz->gzclose();
222                         close ZIN;
223                 };
224                 if($@) {
225                         push @errors, $@;
226                 }
227                 else {
228                         unlink($file);
229                 }
230         }
231         if(@errors) {
232                 $::Scratch->{ui_error} = '<ul><li>';
233                 $::Scratch->{ui_error} .= join "</li>\n<li>", @errors;
234                 $::Scratch->{ui_error} .= '</li></ul>';
235         }
236         return $opt->{hide} ? "" : $done;
237 }
238 EOR