File Coverage

blib/lib/PGObject/Util/DBChange.pm
Criterion Covered Total %
statement 51 97 52.5
branch 3 22 13.6
condition 2 9 22.2
subroutine 14 22 63.6
pod 7 8 87.5
total 77 158 48.7


line stmt bran cond sub pod time code
1             package PGObject::Util::DBChange;
2              
3 2     2   53505 use 5.010; # double forward slash requires 5.10
  2         13  
4 2     2   11 use strict;
  2         4  
  2         36  
5 2     2   19 use warnings;
  2         3  
  2         70  
6              
7 2     2   11 use strict;
  2         3  
  2         47  
8 2     2   10 use warnings;
  2         4  
  2         53  
9 2     2   783 use PGObject::Util::DBChange::History;
  2         6  
  2         52  
10 2     2   1046 use Digest::SHA;
  2         5788  
  2         102  
11 2     2   15 use Cwd;
  2         5  
  2         125  
12 2     2   1017 use Moo;
  2         22703  
  2         11  
13              
14             =head1 NAME
15              
16             PGObject::Util::DBChange - Track applied change files in the database
17              
18             =head1 VERSION
19              
20             Version 0.050.4
21              
22             =cut
23              
24             our $VERSION = '0.050.4';
25              
26              
27             =head1 SYNOPSIS
28              
29             Quick summary of what the module does.
30              
31             Perhaps a little code snippet.
32              
33             use PGObject::Util::DBChange;
34              
35             my $foo = PGObject::Util::DBChange->new();
36             ...
37              
38             =head1 PROPERTIES
39              
40             =head2 path
41              
42             Path to load content from -- Must be defined and '' or a string
43              
44             =cut
45              
46             has path => (is => 'ro',
47             isa => sub { die 'path undefined' unless defined $_[0];
48             die 'references not allowed' if ref $_[0]; } );
49              
50             =head2 no_transactions
51              
52             If true, we assume success even if transaction fails
53              
54             Future versions may add additional checking possibilies instead
55              
56             =cut
57              
58             has no_transactions =>(is => 'ro');
59              
60             =head2 content
61              
62             Content of the file. Can be specified at load, or is built by reading from the
63             file.
64              
65             =cut
66              
67             has content => (is => 'lazy');
68              
69             sub _build_content {
70 3     3   25 my ($self) = @_;
71 3         5 my $file;
72 3         10 local $!;
73 3 50       121 open(FILE, '<', $self->path) or
74             die 'FileError: ' . Cwd::abs_path($self->path) . ": $!";
75 3         19 binmode FILE, ':utf8';
76 3         89 my $content = join '', ;
77 3         33 close FILE;
78 3         22 return $content;
79             }
80              
81             =head2 succeeded (rwp)
82              
83             Undefined until run. After run, 1 if success, 0 if failure.
84              
85             =cut
86              
87             has succeeded => (is => 'rwp');
88              
89             =head2 dependencies
90              
91             A list of other changes to apply first. If strings are provided, these are
92             turned into path objects.
93              
94             Currently these must be explicitly provided. Future bersions may read these from
95             comments in the files themselves.
96              
97             =cut
98              
99             has dependencies => (is => 'ro',
100             default => sub { [] },
101             isa => sub { die 'dependencies must be an arrayref'
102             if ref $_[0] !~ /ARRAY/
103             and defined $_[0];
104             for (@{$_[0]}) {
105             die 'dependency must be a PGObject::Util::Change object'
106             unless eval { $_->isa(__PACKAGE__) };
107             }
108             }
109             );
110            
111              
112             =head2 sha
113              
114             The sha hash of the normalized content (comments and whitespace lines stripped)
115             of the file.
116              
117             =cut
118              
119             has sha => (is => 'lazy');
120              
121             sub _build_sha {
122 3     3   1432 my ($self) = @_;
123 3         48 my $content = $self->content;
124             my $normalized = join "\n",
125 9         29 grep { /\S/ }
126 3         21 map { my $string = $_; $string =~ s/--.*//; $string }
  9         19  
  9         54  
  9         22  
127             split("\n", $content);
128 3         67 return Digest::SHA::sha512_base64($normalized);
129             }
130              
131             =head2 begin_txn
132              
133             Code to begin transaction, defaults to 'BEGIN;'
134              
135             =cut
136              
137             has begin_txn => (is => 'ro', default => 'BEGIN;');
138              
139             =head2 commit_txn
140              
141             Code to commit transaction, defaults to 'COMMIT;'
142              
143             Useful if one needs to do two phase commit or similar
144              
145             =cut
146              
147             has commit_txn => (is => 'ro', default => 'COMMIT;');
148              
149             =head1 METHODS
150              
151             =head2 content_wrapped($before, $after)
152              
153             Returns content wrapped with before and after.
154              
155             =cut
156              
157             sub content_wrapped {
158 4     4 1 11 my ($self, $before, $after) = @_;
159 4   50     23 $before //= "";
160 4   50     17 $after //= "";
161 4         94 return $self->_wrap_transaction(
162             _wrap($self->content, $before, $after)
163             );
164             }
165              
166             sub _wrap_transaction {
167 4     4   9 my ($self, $content) = @_;
168 4 100       20 $content = _wrap($content, $self->begin_txn, $self->commit_txn)
169             unless $self->no_transactions;
170 4         33 return $content;
171             }
172              
173             sub _wrap {
174 6     6   41 my ($content, $before, $after) = @_;
175 6         26 return "$before\n$content\n$after";
176             }
177              
178             =head2 is_applied($dbh)
179              
180             returns 1 if has already been applied, false if not
181              
182             =cut
183              
184             sub is_applied {
185 0     0 1   my ($self, $dbh) = @_;
186 0           my $sha = $self->sha;
187 0           my $sth = $dbh->prepare(
188             "SELECT * FROM db_patches WHERE sha = ?"
189             );
190 0           $sth->execute($sha);
191 0           my $retval = int $sth->rows;
192 0           $sth->finish;
193 0           return $retval;
194             }
195              
196             =head2 run($dbh)
197              
198             Runs against the current dbh without tracking.
199              
200             =cut
201              
202             sub run {
203 0     0 1   my ($self, $dbh) = @_;
204 0           $dbh->do($self->content); # not raw
205             }
206              
207             =head2 apply($dbh)
208              
209             Applies the current file to the db in the current dbh.
210              
211             =cut
212              
213             sub apply {
214 0     0 1   my ($self, $dbh, $log) = @_;
215 0           my $need_commit = $self->_need_commit($dbh);
216 0           my $before = "";
217 0           my $after;
218 0           my $sha = $dbh->quote($self->sha);
219 0           my $path = $dbh->quote($self->path);
220 0           my $no_transactions = $self->no_transactions;
221 0 0         if ($self->is_applied($dbh)){
222 0           $after = "
223             UPDATE db_patches
224             SET last_updated = now()
225             WHERE sha = $sha;
226             ";
227             } else {
228 0           $after = "
229             INSERT INTO db_patches (sha, path, last_updated)
230             VALUES ($sha, $path, now());
231             ";
232             }
233 0 0         if ($no_transactions){
234 0           $dbh->do($after);
235 0           $after = "";
236 0 0         $dbh->commit if $need_commit;
237             }
238 0           my $success = eval {
239 0           $dbh->do($self->content_wrapped($before, $after));
240             };
241 0 0         $dbh->commit if $need_commit;
242 0 0 0       die "$DBI::state: $DBI::errstr" unless $success or $no_transactions;
243 0 0         $self->log(dbh => $dbh, state => $DBI::state, errstr => $DBI::errstr)
244             if $log;
245 0           return 1;
246             }
247              
248             sub log {
249 0     0 0   my ($self, %args) = @_;
250 0           my $dbh = $args{dbh};
251             $dbh->prepare("
252             INSERT INTO db_patch_log(when_applied, path, sha, sqlstate, error)
253             VALUES(now(), ?, ?, ?, ?)
254 0           ")->execute($self->path, $self->sha, $args{state}, $args{errstr});
255 0 0         $dbh->commit if $self->_need_commit($dbh);
256             }
257              
258             our $commit = 1;
259              
260             sub _need_commit{
261 0     0     my ($self, $dbh) = @_;
262 0           return $commit;
263             }
264              
265             =head1 Functions (package-level)
266              
267             =head2 needs_init($dbh)
268              
269             Checks to see whether the schema has been initialized
270              
271             =cut
272              
273             sub needs_init {
274 0     0 1   my $dbh = pop @_;
275 0           my $count = $dbh->prepare("
276             select relname from pg_class
277             where relname = 'db_patches'
278             and pg_table_is_visible(oid)
279             ")->execute();
280 0           return !int($count);
281             }
282              
283             =head2 init($dbh);
284              
285             Initializes the system. Modifications are maintained through the History
286             module. Returns 0 if was up to date, 1 if was initialized.
287              
288             =cut
289              
290             sub init {
291 0     0 1   my $dbh = pop @_;
292 0 0         return update($dbh) unless needs_init($dbh);
293 0           my $success = $dbh->prepare("
294             CREATE TABLE db_patch_log (
295             when_applied timestamp primary key,
296             path text NOT NULL,
297             sha text NOT NULL,
298             sqlstate text not null,
299             error text
300             );
301             CREATE TABLE db_patches (
302             sha text primary key,
303             path text not null,
304             last_updated timestamp not null
305             );
306             ")->execute();
307 0 0         die "$DBI::state: $DBI::errstr" unless $success;
308              
309 0   0       return update($dbh) || 1;
310             }
311              
312             =head2 update($dbh)
313              
314             Updates the current schema to the most recent.
315              
316             =cut
317              
318             sub update {
319 0     0 1   my $dbh = pop @_;
320 0           my $applied_num = 0;
321             #my @changes = __PACKAGE__::History::get_changes();
322             #$applied_num += $_->apply($dbh) for @changes;
323 0           return $applied_num;
324             }
325              
326             =head1 AUTHOR
327              
328             Chris Travers, C<< >>
329              
330             =head1 BUGS
331              
332             Please report any bugs or feature requests to C, or through
333             the web interface at L. I will be notified, and then you'll
334             automatically be notified of progress on your bug as I make changes.
335              
336              
337              
338              
339             =head1 SUPPORT
340              
341             You can find documentation for this module with the perldoc command.
342              
343             perldoc PGObject::Util::DBChange
344              
345              
346             You can also look for information at:
347              
348             =over 4
349              
350             =item * RT: CPAN's request tracker (report bugs here)
351              
352             L
353              
354             =item * AnnoCPAN: Annotated CPAN documentation
355              
356             L
357              
358             =item * CPAN Ratings
359              
360             L
361              
362             =item * Search CPAN
363              
364             L
365              
366             =back
367              
368              
369             =head1 ACKNOWLEDGEMENTS
370              
371             Portions of this code were developed for LedgerSMB 1.5 and copied from
372             appropriate sources there.
373              
374             Many thanks to Sedex Global for their sponsorship of portions of the module.
375              
376             =head1 LICENSE AND COPYRIGHT
377              
378             Copyright 2016, 2017 Chris Travers.
379              
380             This program is distributed under the (Revised) BSD License:
381             L
382              
383             Redistribution and use in source and binary forms, with or without
384             modification, are permitted provided that the following conditions
385             are met:
386              
387             * Redistributions of source code must retain the above copyright
388             notice, this list of conditions and the following disclaimer.
389              
390             * Redistributions in binary form must reproduce the above copyright
391             notice, this list of conditions and the following disclaimer in the
392             documentation and/or other materials provided with the distribution.
393              
394             * Neither the name of LedgerSMB
395             nor the names of its contributors may be used to endorse or promote
396             products derived from this software without specific prior written
397             permission.
398              
399             THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
400             "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
401             LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
402             A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
403             OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
404             SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
405             LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
406             DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
407             THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
408             (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
409             OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
410              
411              
412             =cut
413              
414             1; # End of PGObject::Util::DBChange