PGObject-Util-DBChange-0.050.2/0000755000175000017500000000000013034743775016714 5ustar ehuelsmannehuelsmannPGObject-Util-DBChange-0.050.2/lib/0000755000175000017500000000000013034743775017462 5ustar ehuelsmannehuelsmannPGObject-Util-DBChange-0.050.2/lib/PGObject/0000755000175000017500000000000013034743775021117 5ustar ehuelsmannehuelsmannPGObject-Util-DBChange-0.050.2/lib/PGObject/Util/0000755000175000017500000000000013034743775022034 5ustar ehuelsmannehuelsmannPGObject-Util-DBChange-0.050.2/lib/PGObject/Util/DBChange.pm0000644000175000017500000002323713034743710023761 0ustar ehuelsmannehuelsmannpackage PGObject::Util::DBChange; use 5.010; # double forward slash requires 5.10 use strict; use warnings; use strict; use warnings; use PGObject::Util::DBChange::History; use Digest::SHA; use Cwd; use Moo; =head1 NAME PGObject::Util::DBChange - Track applied change files in the database =head1 VERSION Version 0.050.2 =cut our $VERSION = '0.050.2'; =head1 SYNOPSIS Quick summary of what the module does. Perhaps a little code snippet. use PGObject::Util::DBChange; my $foo = PGObject::Util::DBChange->new(); ... =head1 PROPERTIES =head2 path Path to load content from -- Must be defined and '' or a string =cut has path => (is => 'ro', isa => sub { die 'path undefined' unless defined $_[0]; die 'references not allowed' if ref $_[0]; } ); =head2 no_transactions If true, we assume success even if transaction fails Future versions may add additional checking possibilies instead =cut has no_transactions =>(is => 'ro'); =head2 content Content of the file. Can be specified at load, or is built by reading from the file. =cut has content => (is => 'lazy'); sub _build_content { my ($self) = @_; my $file; local $!; open(FILE, '<', $self->path) or die 'FileError: ' . Cwd::abs_path($self->path) . ": $!"; binmode FILE, ':utf8'; my $content = join '', ; close FILE; return $content; } =head2 succeeded (rwp) Undefined until run. After run, 1 if success, 0 if failure. =cut has succeeded => (is => 'rwp'); =head2 dependencies A list of other changes to apply first. If strings are provided, these are turned into path objects. Currently these must be explicitly provided. Future bersions may read these from comments in the files themselves. =cut has dependencies => (is => 'ro', default => sub { [] }, isa => sub { die 'dependencies must be an arrayref' if ref $_[0] !~ /ARRAY/ and defined $_[0]; for (@{$_[0]}) { die 'dependency must be a PGObject::Util::Change object' unless eval { $_->isa(__PACKAGE__) }; } } ); =head2 sha The sha hash of the normalized content (comments and whitespace lines stripped) of the file. =cut has sha => (is => 'lazy'); sub _build_sha { my ($self) = @_; my $content = $self->content; my $normalized = join "\n", grep { /\S/ } map { my $string = $_; $string =~ s/--.*//; $string } split("\n", $content); return Digest::SHA::sha512_base64($normalized); } =head2 begin_txn Code to begin transaction, defaults to 'BEGIN;' =cut has begin_txn => (is => 'ro', default => 'BEGIN;'); =head2 commit_txn Code to commit transaction, defaults to 'COMMIT;' Useful if one needs to do two phase commit or similar =cut has commit_txn => (is => 'ro', default => 'COMMIT;'); =head1 METHODS =head2 content_wrapped($before, $after) Returns content wrapped with before and after. =cut sub content_wrapped { my ($self, $before, $after) = @_; $before //= ""; $after //= ""; return $self->_wrap_transaction( _wrap($self->content, $before, $after) ); } sub _wrap_transaction { my ($self, $content) = @_; $content = _wrap($content, $self->begin_txn, $self->commit_txn) unless $self->no_transactions; return $content; } sub _wrap { my ($content, $before, $after) = @_; return "$before\n$content\n$after"; } =head2 is_applied($dbh) returns 1 if has already been applied, false if not =cut sub is_applied { my ($self, $dbh) = @_; my $sha = $self->sha; my $sth = $dbh->prepare( "SELECT * FROM db_patches WHERE sha = ?" ); $sth->execute($sha); my $retval = int $sth->rows; $sth->finish; return $retval; } =head2 run($dbh) Runs against the current dbh without tracking. =cut sub run { my ($self, $dbh) = @_; $dbh->do($self->content); # not raw } =head2 apply($dbh) Applies the current file to the db in the current dbh. =cut sub apply { my ($self, $dbh, $log) = @_; my $need_commit = $self->_need_commit($dbh); my $before = ""; my $after; my $sha = $dbh->quote($self->sha); my $path = $dbh->quote($self->path); my $no_transactions = $self->no_transactions; if ($self->is_applied($dbh)){ $after = " UPDATE db_patches SET last_updated = now() WHERE sha = $sha; "; } else { $after = " INSERT INTO db_patches (sha, path, last_updated) VALUES ($sha, $path, now()); "; } if ($no_transactions){ $dbh->do($after); $after = ""; $dbh->commit if $need_commit; } my $success = eval { $dbh->do($self->content_wrapped($before, $after)); }; $dbh->commit if $need_commit; die "$DBI::state: $DBI::errstr" unless $success or $no_transactions; $self->log(dbh => $dbh, state => $DBI::state, errstr => $DBI::errstr) if $log; return 1; } sub log { my ($self, %args) = @_; my $dbh = $args{dbh}; $dbh->prepare(" INSERT INTO db_patch_log(when_applied, path, sha, sqlstate, error) VALUES(now(), ?, ?, ?, ?) ")->execute($self->path, $self->sha, $args{state}, $args{errstr}); $dbh->commit if $self->_need_commit($dbh); } our $commit = 1; sub _need_commit{ my ($self, $dbh) = @_; return $commit; } =head1 Functions (package-level) =head2 needs_init($dbh) Checks to see whether the schema has been initialized =cut sub needs_init { my $dbh = pop @_; my $count = $dbh->prepare(" select relname from pg_class where relname = 'db_patches' and pg_table_is_visible(oid) ")->execute(); return !int($count); } =head2 init($dbh); Initializes the system. Modifications are maintained through the History module. Returns 0 if was up to date, 1 if was initialized. =cut sub init { my $dbh = pop @_; return update($dbh) unless needs_init($dbh); my $success = $dbh->prepare(" CREATE TABLE db_patch_log ( when_applied timestamp primary key, path text NOT NULL, sha text NOT NULL, sqlstate text not null, error text ); CREATE TABLE db_patches ( sha text primary key, path text not null, last_updated timestamp not null ); ")->execute(); die "$DBI::state: $DBI::errstr" unless $success; return update($dbh) || 1; } =head2 update($dbh) Updates the current schema to the most recent. =cut sub update { my $dbh = pop @_; my $applied_num = 0; #my @changes = __PACKAGE__::History::get_changes(); #$applied_num += $_->apply($dbh) for @changes; return $applied_num; } =head1 AUTHOR Chris Travers, C<< >> =head1 BUGS Please report any bugs or feature requests to C, or through the web interface at L. I will be notified, and then you'll automatically be notified of progress on your bug as I make changes. =head1 SUPPORT You can find documentation for this module with the perldoc command. perldoc PGObject::Util::DBChange You can also look for information at: =over 4 =item * RT: CPAN's request tracker (report bugs here) L =item * AnnoCPAN: Annotated CPAN documentation L =item * CPAN Ratings L =item * Search CPAN L =back =head1 ACKNOWLEDGEMENTS Portions of this code were developed for LedgerSMB 1.5 and copied from appropriate sources there. Many thanks to Sedex Global for their sponsorship of portions of the module. =head1 LICENSE AND COPYRIGHT Copyright 2016, 2017 Chris Travers. This program is distributed under the (Revised) BSD License: L Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of LedgerSMB nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. =cut 1; # End of PGObject::Util::DBChange PGObject-Util-DBChange-0.050.2/lib/PGObject/Util/DBChange/0000755000175000017500000000000013034743775023427 5ustar ehuelsmannehuelsmannPGObject-Util-DBChange-0.050.2/lib/PGObject/Util/DBChange/History.pm0000644000175000017500000000020713014622006025402 0ustar ehuelsmannehuelsmann# just returns a list of values package PGObject::Util::DBChange::History; use PGObject::Util::DBChange; sub get_changes { [] }; 1; PGObject-Util-DBChange-0.050.2/Makefile.PL0000644000175000017500000000133013034743611020650 0ustar ehuelsmannehuelsmannuse 5.006; use strict; use warnings; use ExtUtils::MakeMaker; WriteMakefile( NAME => 'PGObject::Util::DBChange', AUTHOR => q{Chris Travers }, VERSION_FROM => 'lib/PGObject/Util/DBChange.pm', ABSTRACT_FROM => 'lib/PGObject/Util/DBChange.pm', LICENSE => 'bsd', PL_FILES => {}, MIN_PERL_VERSION => 5.010, CONFIGURE_REQUIRES => { 'ExtUtils::MakeMaker' => 0, }, BUILD_REQUIRES => { 'Test::More' => 0, }, PREREQ_PM => { 'Digest::SHA' => 0, 'Moo' => 0, }, dist => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', }, clean => { FILES => 'PGObject-Util-DBChange-*' }, ); PGObject-Util-DBChange-0.050.2/README0000644000175000017500000000555213034510647017571 0ustar ehuelsmannehuelsmannPGObject-Util-DBChange The README is used to introduce the module and provide instructions on how to install the module, any machine dependencies it may have (for example C compilers and installed libraries) and any other information that should be provided before the module is installed. A README file is required for CPAN modules since CPAN extracts the README file from a module distribution so that people browsing the archive can use it to get an idea of the module's uses. It is usually a good idea to provide version information here so that people can decide whether fixes for the module are worth downloading. INSTALLATION To install this module, run the following commands: perl Makefile.PL make make test make install SUPPORT AND DOCUMENTATION After installing, you can find documentation for this module with the perldoc command. perldoc PGObject::Util::DBChange You can also look for information at: RT, CPAN's request tracker (report bugs here) http://rt.cpan.org/NoAuth/Bugs.html?Dist=PGObject-Util-DBChange AnnoCPAN, Annotated CPAN documentation http://annocpan.org/dist/PGObject-Util-DBChange CPAN Ratings http://cpanratings.perl.org/d/PGObject-Util-DBChange Search CPAN http://search.cpan.org/dist/PGObject-Util-DBChange/ LICENSE AND COPYRIGHT Copyright (C) 2016, 2017 Chris Travers This program is distributed under the (Revised) BSD License: L Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of Chris Travers's Organization nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. PGObject-Util-DBChange-0.050.2/Changes0000644000175000017500000000142313034743663020203 0ustar ehuelsmannehuelsmannRevision history for PGObject-Util-DBChange 0.050.2 2017-01-09 Change minimum Perl version dependency (5.10) in Makefile.PL 0.050.1 2017-01-08 Update copyright years 0.050 2017-01-08 Remove Makefile from MANIFEST Change version number Increase minimum requirement (5.10 from 5.6) due to '//' operator 0.040 2016-08-16 Fixing handling of multiple statements in an update file. Fixing copyright notice Harmonizing version numbers across files 0.03 2016-08-15 Transaction wrapping cannot possibly work given that a single $dbh->do call cannot wrap transactions, so removing it for now. Also fixing boilerplate. 0.02 2016-07-16 Fixed missing files in tests 0.01 Date/time First version, released on an unsuspecting world. PGObject-Util-DBChange-0.050.2/META.json0000644000175000017500000000167213034743775020343 0ustar ehuelsmannehuelsmann{ "abstract" : "Track applied change files in the database", "author" : [ "Chris Travers " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 6.98, CPAN::Meta::Converter version 2.142690", "license" : [ "bsd" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "PGObject-Util-DBChange", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "Test::More" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : { "Digest::SHA" : "0", "Moo" : "0", "perl" : "5.01" } } }, "release_status" : "stable", "version" : "v0.050.2" } PGObject-Util-DBChange-0.050.2/xt/0000755000175000017500000000000013034743775017347 5ustar ehuelsmannehuelsmannPGObject-Util-DBChange-0.050.2/xt/boilerplate.t0000644000175000017500000000250113014622006022011 0ustar ehuelsmannehuelsmann#!perl -T use 5.006; use strict; use warnings; use Test::More; plan tests => 3; sub not_in_file_ok { my ($filename, %regex) = @_; open( my $fh, '<', $filename ) or die "couldn't open $filename for reading: $!"; my %violated; while (my $line = <$fh>) { while (my ($desc, $regex) = each %regex) { if ($line =~ $regex) { push @{$violated{$desc}||=[]}, $.; } } } if (%violated) { fail("$filename contains boilerplate text"); diag "$_ appears on lines @{$violated{$_}}" for keys %violated; } else { pass("$filename contains no boilerplate text"); } } sub module_boilerplate_ok { my ($module) = @_; not_in_file_ok($module => 'the great new $MODULENAME' => qr/ - The great new /, 'boilerplate description' => qr/Quick summary of what the module/, 'stub function definition' => qr/function[12]/, ); } TODO: { local $TODO = "Need to replace the boilerplate text"; not_in_file_ok(README => "The README is used..." => qr/The README is used/, "'version information here'" => qr/to provide version information/, ); not_in_file_ok(Changes => "placeholder date/time" => qr(Date/time) ); module_boilerplate_ok('lib/PGObject/Util/DBChange.pm'); } PGObject-Util-DBChange-0.050.2/META.yml0000644000175000017500000000104413034743775020164 0ustar ehuelsmannehuelsmann--- abstract: 'Track applied change files in the database' author: - 'Chris Travers ' build_requires: Test::More: '0' configure_requires: ExtUtils::MakeMaker: '0' dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 6.98, CPAN::Meta::Converter version 2.142690' license: bsd meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: PGObject-Util-DBChange no_index: directory: - t - inc requires: Digest::SHA: '0' Moo: '0' perl: '5.01' version: v0.050.2 PGObject-Util-DBChange-0.050.2/t/0000755000175000017500000000000013034743775017157 5ustar ehuelsmannehuelsmannPGObject-Util-DBChange-0.050.2/t/pod-coverage.t0000644000175000017500000000125013014622006021672 0ustar ehuelsmannehuelsmann#!perl -T use 5.006; use strict; use warnings; use Test::More; unless ( $ENV{RELEASE_TESTING} ) { plan( skip_all => "Author tests not required for installation" ); } # Ensure a recent version of Test::Pod::Coverage my $min_tpc = 1.08; eval "use Test::Pod::Coverage $min_tpc"; plan skip_all => "Test::Pod::Coverage $min_tpc required for testing POD coverage" if $@; # Test::Pod::Coverage doesn't require a minimum Pod::Coverage version, # but older versions don't recognize some common documentation styles my $min_pc = 0.18; eval "use Pod::Coverage $min_pc"; plan skip_all => "Pod::Coverage $min_pc required for testing POD coverage" if $@; all_pod_coverage_ok(); PGObject-Util-DBChange-0.050.2/t/data/0000755000175000017500000000000013034743775020070 5ustar ehuelsmannehuelsmannPGObject-Util-DBChange-0.050.2/t/data/sql/0000755000175000017500000000000013034743775020667 5ustar ehuelsmannehuelsmannPGObject-Util-DBChange-0.050.2/t/data/sql/test1.sql0000644000175000017500000000003313014622006022421 0ustar ehuelsmannehuelsmann select 'this is a test!'; PGObject-Util-DBChange-0.050.2/t/data/sql/test2.sql0000644000175000017500000000015113014622006022423 0ustar ehuelsmannehuelsmann -- this is designed to show if sha ignores comments and whitespace lines select 'this is a test!'; PGObject-Util-DBChange-0.050.2/t/data/sql/test3.sql0000644000175000017500000000004013014622006022421 0ustar ehuelsmannehuelsmann select 'this is a test also!'; PGObject-Util-DBChange-0.050.2/t/00-load.t0000644000175000017500000000037313014622006020460 0ustar ehuelsmannehuelsmann#!perl -T use 5.006; use strict; use warnings; use Test::More; plan tests => 1; BEGIN { use_ok( 'PGObject::Util::DBChange' ) || print "Bail out!\n"; } diag( "Testing PGObject::Util::DBChange $PGObject::Util::DBChange::VERSION, Perl $], $^X" ); PGObject-Util-DBChange-0.050.2/t/manifest.t0000644000175000017500000000047013014622006021130 0ustar ehuelsmannehuelsmann#!perl -T use 5.006; use strict; use warnings; use Test::More; unless ( $ENV{RELEASE_TESTING} ) { plan( skip_all => "Author tests not required for installation" ); } my $min_tcm = 0.9; eval "use Test::CheckManifest $min_tcm"; plan skip_all => "Test::CheckManifest $min_tcm required" if $@; ok_manifest(); PGObject-Util-DBChange-0.050.2/t/pod.t0000644000175000017500000000053613014622006020107 0ustar ehuelsmannehuelsmann#!perl -T use 5.006; use strict; use warnings; use Test::More; unless ( $ENV{RELEASE_TESTING} ) { plan( skip_all => "Author tests not required for installation" ); } # Ensure a recent version of Test::Pod my $min_tp = 1.22; eval "use Test::Pod $min_tp"; plan skip_all => "Test::Pod $min_tp required for testing POD" if $@; all_pod_files_ok(); PGObject-Util-DBChange-0.050.2/t/10-non-db.t0000644000175000017500000000315713014622006020722 0ustar ehuelsmannehuelsmann=head1 UNIT TESTS FOR PGObject::Util::DBChange =cut use PGObject::Util::DBChange; use Test::More tests => 12; my $testpath = 't/data/sql/'; =head1 TEST PLAN Data is in t/data/sql =head2 File Load Tests =over =item basic constructor, no properties for test1 =item basic constructor, all properties for test2 =item sha should be same for both, but different from test3 =back =cut my @properties = qw(no_transactions); my $test1 = PGObject::Util::DBChange->new(path => $testpath . 'test1.sql'); ok($test1, 'got test1 object'); is($test1->path, 't/data/sql/test1.sql', 'got correct path for test1'); is($test1->$_, undef, "$_ property for test1 is undefined") for @properties; my $test2 = PGObject::Util::DBChange->new(path => $testpath . 'test2.sql', map { $_ => 1 } @properties ); ok($test2, 'got test2 object'); is($test2->path, 't/data/sql/test2.sql', 'got correct path for test2'); is($test2->$_, 1, "$_ property for test2 is 1") for @properties; is($test1->sha, $test2->sha, 'SHA is equal for both test1 and test2'); isnt($test1->sha, PGObject::Util::DBChange->new(path => $testpath . 'test3.sql')->sha, 'SHA changes when content chenges'); =head2 Wrapping Tests =over =item test1 should have begin/commit when asking for content =item test2 should not have begin/commit when asking for content =back =cut like($test1->content_wrapped, qr/BEGIN;/, 'Test1 content has BEGIN'); like($test1->content_wrapped, qr/COMMIT;/, 'Test1 content has COMMIT'); unlike($test2->content_wrapped, qr/BEGIN;/, 'Test2 content has no BEGIN'); unlike($test2->content_wrapped, qr/COMMIT;/, 'Test2 content has no COMMIT');