File Coverage

blib/lib/DiaColloDB/Upgrade/v0_10_x2t.pm
Criterion Covered Total %
statement 18 148 12.1
branch 0 66 0.0
condition 0 3 0.0
subroutine 6 14 42.8
pod 5 5 100.0
total 29 236 12.2


line stmt bran cond sub pod time code
1             ## -*- Mode: CPerl -*-
2             ##
3             ## File: DiaColloDB::Upgrade::v0_10_x2t.pm
4             ## Author: Bryan Jurish <moocow@cpan.org>
5             ## Description: DiaColloDB utilities: auto-magic upgrade: v0.09.x -> v0.10.x: x-tuples (+date) -> t-tuples (-date)
6              
7             package DiaColloDB::Upgrade::v0_10_x2t;
8 1     1   5 use DiaColloDB::Upgrade::Base;
  1         2  
  1         25  
9 1     1   342 use DiaColloDB::Compat::v0_09;
  1         3  
  1         32  
10 1     1   7 use DiaColloDB::Utils qw(:pack :env :run :file);
  1         39  
  1         36  
11 1     1   257 use version;
  1         2  
  1         7  
12 1     1   64 use strict;
  1         2  
  1         71  
13             our @ISA = qw(DiaColloDB::Upgrade::Base);
14              
15             ##==============================================================================
16             ## API
17              
18             ## $version = $CLASS_OR_OBJECT->toversion()
19             ## + returns default target version; default just returns $DiaColloDB::VERSION
20             sub toversion {
21 0     0 1   return '0.10.000';
22             }
23              
24             ## $bool = $CLASS_OR_OBJECT->upgrade()
25             ## + performs upgrade
26             sub upgrade {
27 0     0 1   my $up = shift;
28              
29             ##-- backup
30 0 0         $up->backup() or return undef;
31              
32             ##-- read header
33 0           my $dbdir = $up->{dbdir};
34 0           my $hdr = $up->dbheader();
35              
36             ##-- common variables
37 1     1   6 no warnings 'portable';
  1         2  
  1         1767  
38 0           my $pack_t = $hdr->{pack_t} = $hdr->{pack_id}."[".scalar(@{$hdr->{attrs}})."]";
  0            
39 0           my $len_t = packsize($pack_t);
40 0           my $pack_xd = '@'.$len_t.$hdr->{pack_date};
41 0           my $nbits_d = packsize($hdr->{pack_date}) * 8;
42 0           my $nbits_t = packsize($hdr->{pack_id}) * 8;
43              
44             ##-- convert xenum to tenum
45 0           $up->info("creating $dbdir/tenum.*");
46             my $xenum = $DiaColloDB::XECLASS->new(base=>"$dbdir/xenum", pack_s=>$hdr->{pack_x})
47 0 0         or $up->logconfess("failed to open $dbdir/xenum.*: $!");
48 0           my %xeopts = map {($_=>$xenum->{$_})} qw(pack_i pack_o pack_l);
  0            
49 0           my $xi2s = $xenum->toArray;
50 0           my $xi2t = '';
51 0           my $xi2d = '';
52 0           my $ts2i = {};
53 0           my $nt = 0;
54 0           my ($xi,$xs,$xd,$ts,$ti);
55 0           vec($xi2t, $#$xi2s, $nbits_t) = 0; ##-- $xi2t : [$xi] => $ti
56 0           vec($xi2d, $#$xi2s, $nbits_d) = 0; ##-- $xi2d : [$xi] => $date
57 0           for ($xi=0; $xi <= $#$xi2s; ++$xi) {
58 0           $xs = $xi2s->[$xi];
59 0           $ts = substr($xs,0,$len_t);
60 0 0         $ti = $ts2i->{$ts} = $nt++ if (!defined($ti=$ts2i->{$ts}));
61 0           vec($xi2d,$xi,$nbits_d) = unpack($pack_xd,$xs);
62 0           vec($xi2t,$xi,$nbits_t) = $ti;
63             }
64 0 0         $xenum->unlink()
65             or $up->logconfess("failed to remove old $dbdir/xenum.*: $!");
66 0           my $tenum = $DiaColloDB::XECLASS->new(pack_s=>$pack_t, %xeopts);
67 0 0         $tenum->fromHash($ts2i)->save("$dbdir/tenum")
68             or $up->logconfess("failed to save $dbdir/tenum.*: $!");
69 0           delete $hdr->{pack_x};
70              
71             ##-- convert attribute-wise multimaps & pack-templates
72 0           foreach my $attr (@{$hdr->{attrs}}) {
  0            
73 0           $up->info("creating multimap $dbdir/${attr}_2t.*");
74 0 0         my $xmm = $DiaColloDB::MMCLASS->new(flags=>'r', base=>"$dbdir/${attr}_2x", logCompat=>'off')
75             or $up->logconfess("failed to open $dbdir/${attr}_2x.*");
76 0           my $mma = $xmm->toArray();
77 0           my %mmopts = (map {($_=>$xmm->{$_})} qw(pack_i));
  0            
78 0 0         $xmm->unlink()
79             or $up->logconfess("failed to unlink $dbdir/${attr}_2x.*");
80              
81 0           my $pack_bs = "$mmopts{pack_i}*";
82 0           my ($ai,$tmp);
83 0           for ($ai=0; $ai <= $#$mma; ++$ai) {
84 0           $tmp = undef;
85             $mma->[$ai] = pack($pack_bs,
86 0 0 0       map {defined($tmp) && $tmp==$_ ? qw(): ($tmp=$_)}
87 0           sort {$a<=>$b}
88 0           map {vec($xi2t,$_,$nbits_t)}
  0            
89             unpack($pack_bs, $mma->[$ai])
90             );
91             }
92              
93 0 0         my $tmm = $DiaColloDB::MMCLASS->new(flags=>'rw', %mmopts)
94             or $up->logconfess("failed to create new multimap for attribute '$attr'");
95 0 0         $tmm->fromArray($mma)
96             or $up->logconfess("failed to convert multimap data for attirbute '$attr'");
97 0 0         $tmm->save("$dbdir/${attr}_2t")
98             or $up->logconfess("failed to save multimap data for attrbute '$attr' to $dbdir/${attr}_2t.*: $!");
99              
100             ##-- adopt pack template
101 0           $hdr->{"pack_t${attr}"} = $hdr->{"pack_x${attr}"};
102 0           delete $hdr->{"pack_x${attr}"};
103             }
104              
105             ##-- convert relations: unigrams
106             {
107 0 0         my $xf = DiaColloDB::Relation::Unigrams->new(base=>"$dbdir/xf", logCompat=>'off')
108             or $up->logconfess("failed to open unigram index '$dbdir/xf.dba': $!");
109 0           $up->info("upgrading unigram index $dbdir/xf.*");
110 0 0         $up->warn("unigram data in $dbdir/xf.* doesn't seem to be v0.09 format; trying to upgrade anyways")
111             if (!$xf->isa('DiaColloDB::Compat::v0_09::Relation::Unigrams'));
112              
113 0           env_push('LC_ALL'=>'C');
114 0           my $tmpfile = "$dbdir/upgrade_xf.tmp";
115 0 0         my $sortfh = opencmd("| sort -nk2 -nk3 -o \"$tmpfile\"")
116             or $up->logconfess("open failed for pipe to sort for '$tmpfile': $!");
117 0           binmode($sortfh,':raw');
118 0     0     $xf->saveTextFh_v0_10($sortfh, i2s=>sub { join("\t", vec($xi2t,$_[0],$nbits_t), vec($xi2d,$_[0],$nbits_d)) })
119 0 0         or $up->logconfess("failed to create temporary file '$tmpfile'");
120 0 0         $sortfh->close()
121             or $up->logconfess("failed to close pipe to sort for '$tmpfile': $!");
122 0           env_pop();
123 0 0         $xf->unlink()
124             or $up->logconfess("failed to unlink old $dbdir/xf.*: $!");
125              
126             my $tf = DiaColloDB::Relation::Unigrams->new(base=>"$dbdir/xf", flags=>'rw', version=>$up->toversion,
127 0           pack_i=>$hdr->{pack_id}, pack_f=>$hdr->{pack_f}, pack_d=>$hdr->{pack_date});
128 0 0         $tf->loadTextFile($tmpfile)
129             or $up->logconfess("failed to load unigram data from '$tmpfile': $!");
130             }
131              
132             ##-- convert relations: cofreqs
133             {
134 0 0         my $cof = DiaColloDB::Relation::Cofreqs->new(base=>"$dbdir/cof", logCompat=>'off')
  0            
  0            
135             or $up->logconfess("failed to open co-frequency index $dbdir/cof.*: $!");
136 0           my %cofopts = (map {($_=>$cof->{$_})} qw(pack_i pack_f fmin dmax));
  0            
137 0           $up->info("upgrading co-frequency index $dbdir/cof.*");
138 0 0         $up->warn("co-frequency data in $dbdir/cof.* doesn't seem to be v0.09 format; trying to upgrade anyways")
139             if (!$cof->isa('DiaColloDB::Compat::v0_09::Relation::Cofreqs'));
140              
141 0           env_push('LC_ALL'=>'C');
142 0           my $tmpfile = "$dbdir/upgrade_cof.tmp";
143 0 0         my $sortfh = opencmd("| sort -nk2 -nk3 -nk4 -o \"$tmpfile\"")
144             or $up->logconfess("open failed for pipe to sort for '$tmpfile': $!");
145 0           binmode($sortfh,':raw');
146             $cof->saveTextFh($sortfh,
147 0     0     i2s1=>sub { join("\t", vec($xi2t,$_[0],$nbits_t), vec($xi2d,$_[0],$nbits_d)) },
148 0     0     i2s2=>sub { vec($xi2t,$_[0],$nbits_t) })
149 0 0         or $up->logconfess("failed to create temporary file '$tmpfile'");
150 0 0         $sortfh->close()
151             or $up->logconfess("failed to close pipe to sort for '$tmpfile': $!");
152 0           env_pop();
153 0 0         $cof->unlink()
154             or $up->logconfess("failed to unlink old $dbdir/cof.*: $!");
155              
156             my $tcof = DiaColloDB::Relation::Cofreqs->new(base=>"$dbdir/cof", flags=>'rw', version=>$up->toversion,
157 0           pack_d=>$hdr->{pack_date}, %cofopts);
158 0 0         $tcof->loadTextFile($tmpfile)
159             or $up->logconfess("failed to load co-frequency data from '$tmpfile': $!");
160             }
161              
162             ##-- cleanup
163 0 0         if (!$up->{keep}) {
164 0           $up->info("removing temporary file(s)");
165 0 0         CORE::unlink("$dbdir/upgrade_xf.tmp")
166             or $up->logconfess("failed to remove temporary file $dbdir/upgrade_xf.tmp: $!");
167 0 0         CORE::unlink("$dbdir/upgrade_cof.tmp")
168             or $up->logconfess("failed to remove temporary file $dbdir/upgrade_cof.tmp: $!");
169             }
170              
171             ##-- update header
172 0           return $up->updateHeader();
173             }
174              
175             ##==============================================================================
176             ## Backup & Revert
177              
178             ## $bool = $up->backup()
179             ## + perform backup any files we expect to change to $up->backupdir()
180             sub backup {
181 0     0 1   my $up = shift;
182 0 0         $up->SUPER::backup() or return undef;
183 0 0         return 1 if (!$up->{backup});
184              
185 0           my $dbdir = $up->{dbdir};
186 0           my $hdr = $up->dbheader;
187 0           my $backd = $up->backupdir;
188              
189             ##-- backup: xenum
190 0           $up->info("backing up $dbdir/xenum.*");
191 0 0         copyto_a([glob "$dbdir/xenum.*"], $backd)
192             or $up->logconfess("backup failed for $dbdir/xenum.*: $!");
193              
194             ##-- backup: by attribute: multimaps
195 0           foreach my $base (map {"$dbdir/${_}_2x"} @{$hdr->{attrs}}) {
  0            
  0            
196 0           $up->info("backing up $base.*");
197 0 0         copyto_a([glob "$base.*"], $backd)
198             or $up->logconfess("backup failed for $base.*: $!");
199             }
200              
201             ##-- backup: relations
202 0           foreach my $base (map {"$dbdir/$_"} qw(xf cof)) {
  0            
203 0           $up->info("backing up $base.*");
204 0 0         copyto_a([glob "$base.*"], $backd)
205             or $up->logconfess("backup failed for $base.*: $!");
206             }
207              
208 0           return 1;
209             }
210              
211             ## @files = $up->revert_created()
212             ## + returns list of files created by this upgrade, for use with default revert() implementation
213             sub revert_created {
214 0     0 1   my $up = shift;
215 0           my $hdr = $up->dbheader;
216              
217             return (
218             ##-- multimaps
219             (map {
220 0           my $base="${_}_2t";
221 0           map {"$base.$_"} qw(hdr ma mb)
  0            
222 0           } @{$hdr->{attrs}}),
223              
224             ##-- tenum
225 0           (map {"tenum.$_"} qw(hdr fix fsx)),
226              
227             ##-- unigrams
228 0           (map {"xf.$_"} qw(dba1 dba1.hdr dba2 dba2.hdr hdr)),
229              
230             ##-- cofreqs
231 0           (map {"cof.$_"} qw(dba3 dba3.hdr)),
  0            
232              
233             ##-- header
234             'header.json',
235             );
236             }
237              
238             ## @files = $up->revert_updated()
239             ## + returns list of files updated by this upgrade, for use with default revert() implementation
240             sub revert_updated {
241 0     0 1   my $up = shift;
242 0           my $hdr = $up->dbheader;
243              
244             return (
245             ##-- multimaps
246             (map {
247 0           my $base="${_}_2x";
248 0           map {"$base.$_"} qw(hdr ma mb)
  0            
249 0           } @{$hdr->{attrs}}),
250              
251             ##-- xenum
252 0           (map {"xenum.$_"} qw(hdr fix fsx)),
253              
254             ##-- unigrams
255 0           (map {"xf.$_"} qw(dba dba.hdr)),
256              
257             ##-- cofreqs
258 0           (map {"cof.$_"} qw(dba1 dba1.hdr dba2 dba2.hdr hdr)),
  0            
259              
260             ##-- header
261             'header.json',
262             );
263             }
264              
265              
266             ##==============================================================================
267             ## Footer
268             1; ##-- be happy