File Coverage

blib/lib/DiaColloDB/Upgrade.pm
Criterion Covered Total %
statement 21 62 33.8
branch 0 22 0.0
condition 0 11 0.0
subroutine 7 12 58.3
pod 4 5 80.0
total 32 112 28.5


line stmt bran cond sub pod time code
1             ## -*- Mode: CPerl -*-
2             ##
3             ## File: DiaColloDB::Upgrade.pm
4             ## Author: Bryan Jurish <moocow@cpan.org>
5             ## Description: DiaColloDB utilities: auto-magic upgrades: top level
6              
7             package DiaColloDB::Upgrade;
8              
9             # "Attempt to reload DiaColloDB.pm aborted." on perl v5.31.7 (http://www.cpantesters.org/cpan/report/b8caf29a-4121-11ea-9d04-93d2cf6284ad)
10             # - maybe due to 'eval "use threads";' in Client/list.pm? --> nope, no joy
11             #use DiaColloDB;
12              
13 1     1   2018 use DiaColloDB::Upgrade::Base;
  1         3  
  1         39  
14 1     1   431 use DiaColloDB::Upgrade::v0_04_dlimits;
  1         3  
  1         36  
15 1     1   422 use DiaColloDB::Upgrade::v0_09_multimap;
  1         2  
  1         39  
16 1     1   477 use DiaColloDB::Upgrade::v0_10_x2t;
  1         4  
  1         47  
17 1     1   524 use DiaColloDB::Upgrade::v0_12_sliceN;
  1         3  
  1         46  
18 1     1   8 use Carp;
  1         2  
  1         23  
19 1     1   126 use strict;
  1         2  
  1         652  
20              
21             ##==============================================================================
22             ## Globals
23              
24             our @ISA = qw(DiaColloDB::Logger);
25              
26             ## @upgrades : list of available auto-magic upgrade sub-packages (suffixes)
27             our @upgrades = (
28             'v0_04_dlimits',
29             'v0_09_multimap',
30             'v0_10_x2t',
31             'v0_12_sliceN',
32             );
33              
34             ##==============================================================================
35             ## Top-level
36              
37             ## @upgrade_pkgs = $CLASS_OR_OBJECT->available()
38             ## + returns list of available upgrade-packages (suffixes)
39             sub available {
40 0     0 1   return @upgrades;
41             }
42              
43             ## @needed = $CLASS_OR_OBJECT->needed($dbdir, \%opts?, @upgrade_pkgs)
44             ## + returns list of those package-names in @upgrade_pkgs which are needed for DB in $dbdir
45             ## + %opts are passed to upgrade-package new() methods
46             sub needed {
47 0     0 1   my $that = shift;
48 0           my $dbdir = shift;
49 0 0         my $opts = UNIVERSAL::isa($_[0],'HASH') ? shift : {};
50             return grep {
51 0           my $pkg = $_;
  0            
52 0 0         $pkg = "DiaColloDB::Upgrade::$pkg" if (!UNIVERSAL::can($pkg,'needed'));
53 0 0         $that->warn("unknown upgrade package $_") if (!UNIVERSAL::can($pkg,'needed'));
54 0           $that->uobj($pkg,$dbdir,$opts)->needed();
55             } @_;
56             }
57              
58             ## @upgrades = $CLASS_OR_OBJECT->which($dbdir, \%opts?)
59             ## + returns a list of upgrades applied to $dbdir
60             ## + list is created by parsing "upgraded" field from "$dbdir/header.json"
61             ## + if the upgrade-item "by" keyword inherits from DiaColloDB::Upgrade::Base,
62             ## a new object will be created and returned in @upgrades; otherwise the
63             ## parsed HASH-ref is returned as-is
64             sub which {
65 0     0 1   my ($that,$dbdir,$opts) = @_;
66 0   0       $opts //= {};
67 0           my $hdr = DiaColloDB::Upgrade::Base->dbheader($dbdir);
68 0           my @ups = qw();
69 0   0       foreach (@{$hdr->{upgraded}//[]}) {
  0            
70 0   0       my $class = $_->{class} // $_->{by};
71 0 0         $class = "DiaColloDB::Upgrade::$class" if (!UNIVERSAL::isa($class,'DiaColloDB::Upgrade::Base'));
72 0           push(@ups, $that->uobj($class, $dbdir, { %$opts, %$_ }));
73             }
74 0           return @ups;
75             }
76              
77             ## $bool = $CLASS_OR_OBJECT->upgrade($dbdir, \%opts?, \@upgrades_or_pkgs)
78             ## + applies upgrades in @upgrades to DB in $dbdir
79             ## + %opts are passed to upgrade-package new() methods
80             sub upgrade {
81 0     0 1   my $that = shift;
82 0           my $dbdir = shift;
83 0 0         my $opts = UNIVERSAL::isa($_[0],'HASH') ? shift : {};
84 0           foreach (@_) {
85 0           my $pkg = $_;
86 0 0         $pkg = "DiaColloDB::Upgrade::$pkg" if (!UNIVERSAL::can($pkg,'upgrade'));
87 0 0         $that->logconfess("unknown upgrade package $_") if (!UNIVERSAL::can($pkg,'upgrade'));
88 0           $that->info("applying upgrade package $_ to $dbdir/");
89 0 0         $that->uobj($pkg,$dbdir,$opts)->upgrade()
90             or $that->logconfess("upgrade via package $pkg failed for $dbdir/");
91             }
92 0           return $that;
93             }
94              
95             ##==============================================================================
96             ## Utils
97              
98             ## $up = $CLASS_OR_OBJECT->uobj($pkg,$dbdir,\%opts)
99             ## + create or instantiate an upgrade-object $up as an instance of $pkg for $dbdir with options %opts
100             sub uobj {
101 0     0 0   my $that = shift;
102 0           my ($pkg,$dbdir,$opts) = @_;
103 0           my ($up);
104 0 0         if (ref($pkg)) {
    0          
105 0           $up = $pkg;
106 0 0         @$up{keys %$opts} = values %$opts if ($opts);
107 0           $up->{dbdir} = $dbdir;
108             } elsif (UNIVERSAL::can($pkg,'new')) {
109 0   0       $up = $pkg->new(%{$opts//{}}, dbdir=>$dbdir);
  0            
110             } else {
111 0   0       $up = { %{$opts//{}}, dbdir=>$dbdir };
  0            
112             }
113 0           return $up;
114             }
115              
116             ##==============================================================================
117             ## Footer
118             1; ##-- be happy