File Coverage

blib/lib/PGObject/Util/DBAdmin.pm
Criterion Covered Total %
statement 26 156 16.6
branch 0 84 0.0
condition 0 64 0.0
subroutine 9 29 31.0
pod 11 11 100.0
total 46 344 13.3


line stmt bran cond sub pod time code
1             package PGObject::Util::DBAdmin;
2              
3 6     6   437293 use 5.010; # Uses // defined-or operator
  6         71  
4 6     6   28 use strict;
  6         8  
  6         119  
5 6     6   25 use warnings FATAL => 'all';
  6         11  
  6         238  
6              
7 6     6   3030 use Capture::Tiny 'capture';
  6         109354  
  6         340  
8 6     6   41 use Carp;
  6         11  
  6         249  
9 6     6   7896 use DBI;
  6         94246  
  6         344  
10 6     6   54 use File::Temp;
  6         12  
  6         386  
11              
12 6     6   3877 use Moo;
  6         61417  
  6         27  
13 6     6   11393 use namespace::clean;
  6         63815  
  6         39  
14              
15             =head1 NAME
16              
17             PGObject::Util::DBAdmin - PostgreSQL Database Management Facilities for
18             PGObject
19              
20             =head1 VERSION
21              
22             version 1.0.3
23              
24             =cut
25              
26             our $VERSION = '1.0.3';
27              
28              
29             =head1 SYNOPSIS
30              
31             This module provides an interface to the basic Postgres db manipulation
32             utilities.
33              
34             my $db = PGObject::Util::DBAdmin->new(
35             username => 'postgres',
36             password => 'mypassword',
37             host => 'localhost',
38             port => '5432',
39             dbname => 'mydb'
40             );
41              
42             my @dbnames = $db->list_dbs(); # like psql -l
43              
44             $db->create(); # createdb
45             $db->run_file(file => 'sql/initial_schema.sql'); # psql -f
46              
47             my $filename = $db->backup(format => 'c'); # pg_dump -Fc
48              
49             my $db2 = PGObject::Util::DBAdmin->new($db->export, (dbname => 'otherdb'));
50              
51             =head1 PROPERTIES
52              
53             =head2 username
54              
55             The username used to authenticate with the PostgreSQL server.
56              
57             =cut
58              
59             has username => (is => 'ro');
60              
61             =head2 password
62              
63             The password used to authenticate with the PostgreSQL server.
64              
65             =cut
66              
67             has password => (is => 'ro');
68              
69             =head2 host
70              
71             In PostgreSQL, this can refer to the hostname or the absolute path to the
72             directory where the UNIX sockets are set up.
73              
74             =cut
75              
76             has host => (is => 'ro');
77              
78             =head2 port
79              
80             Default '5432'
81              
82             =cut
83              
84             has port => (is => 'ro');
85              
86             =head2 dbname
87              
88             The database name to create or connect to.
89              
90             =cut
91              
92             has dbname => (is => 'ro');
93              
94             =head2 stderr
95              
96             When applicable, the stderr output captured from any external commands (for
97             example createdb or pg_restore) run during the previous method call. See
98             notes in L</"CAPTURING">.
99              
100             =cut
101              
102             has stderr => (is => 'ro');
103              
104             =head2 stdout
105              
106             When applicable, the stdout output captured from any external commands (for
107             example createdb or pg_restore) run during the previous method call. See
108             notes in L</"CAPTURING">.
109              
110             =cut
111              
112             has stdout => (is => 'ro');
113              
114              
115             our %helpers =
116             (
117             create => [ qw/createdb/ ],
118             run_file => [ qw/psql/ ],
119             backup => [ qw/pg_dump/ ],
120             backup_globals => [ qw/pg_dumpall/ ],
121             restore => [ qw/pg_restore psql/ ],
122             drop => [ qw/dropdb/ ],
123             );
124              
125             =head1 GLOBAL VARIABLES
126              
127              
128             =head2 %helper_paths
129              
130             This hash variable contains as its keys the names of the PostgreSQL helper
131             executables C<psql>, C<dropdb>, C<pg_dump>, etc. The values contain the
132             paths at which the executables to be run are located. The default values
133             are the names of the executables only, allowing them to be looked up in
134             C<$PATH>.
135              
136             Modification of the values in this variable are the strict realm of
137             I<applications>. Libraries using this library should defer potential
138             required modifications to the applications based upon them.
139              
140             =cut
141              
142             our %helper_paths =
143             (
144             psql => 'psql',
145             dropdb => 'dropdb',
146             createdb => 'createdb',
147             pg_dump => 'pg_dump',
148             pg_dumpall => 'pg_dumpall',
149             pg_restore => 'pg_restore',
150             );
151              
152             sub _run_with_env {
153 0     0     my %args = @_;
154 0           my $env = $args{env};
155              
156             local %ENV = (
157             # Note that we're intentionally *not* passing
158             # PERL5LIB & PERL5OPT into the environment here!
159             # doing so prevents the system settings to be used, which
160             # we *do* want. If we don't, hopefully, that's coded into
161             # the executables themselves.
162             # Before using this whitelisting, coverage tests in LedgerSMB
163             # would break on the bleeding through this caused.
164             HOME => $ENV{HOME},
165             PATH => $ENV{PATH},
166 0   0       %{$env // {}},
  0            
167             );
168              
169 0           return system @{$args{command}};
  0            
170             }
171              
172             sub _run_command {
173 0     0     my ($self, %args) = @_;
174 0           my %env;
175             my $exit_code;
176              
177 0 0         %env = %{$args{env}} if $args{env};
  0            
178             # Any files created should be accessible only by the current user
179 0           my $original_umask = umask 0077;
180              
181             ($self->{stdout}, $self->{stderr}, $exit_code) = capture {
182              
183 0 0 0 0     if ($self->username or exists $ENV{PGUSER}) {
184 0   0       $env{PGUSER} //= $self->username // $ENV{PGUSER};
      0        
185             }
186 0 0 0       if ($self->password or exists $ENV{PGPASSWORD}) {
187 0   0       $env{PGPASSWORD} //= $self->password // $ENV{PGPASSWORD};
      0        
188             }
189 0 0 0       if ($self->host or exists $ENV{PGHOST}) {
190 0   0       $env{PGHOST} //= $self->host // $ENV{PGHOST};
      0        
191             }
192 0 0 0       if ($self->port or exists $ENV{PGPORT}) {
193 0   0       $env{PGPORT} //= $self->port // $ENV{PGPORT};
      0        
194             }
195 0 0 0       if ($self->dbname or exists $ENV{PGDATABASE}) {
196 0   0       $env{PGDATABASE} //= $self->dbname // $ENV{PGDATABASE};
      0        
197             }
198 0 0         if (exists $ENV{PGSERVICE}) {
199 0   0       $env{PGSERVICE} //= $ENV{PGSERVICE};
200             }
201              
202 0           _run_with_env(%args, env => \%env);
203 0           };
204              
205 0 0 0       if(defined ($args{errlog} // $args{stdout_log})) {
206 0           $self->_write_log_files(%args);
207             }
208              
209             # Reset original umask
210 0           umask $original_umask;
211              
212             # Return true if system command is successful
213 0           return ($exit_code == 0);
214             }
215              
216              
217             sub _unlink_file_and_croak {
218 0     0     my ($self, $filename, $message) = @_;
219              
220 0 0         unlink $filename or carp "error unlinking $filename $!";
221 0           croak $message;
222             }
223              
224              
225             sub _generate_output_filename {
226 0     0     my ($self, %args) = @_;
227              
228             # If caller has supplied a file path, use that
229             # rather than generating our own temp file.
230 0 0         defined $args{file} and return $args{file};
231              
232 0           my %file_options = (UNLINK => 0);
233              
234 0 0         if(defined $args{tempdir}) {
235             -d $args{tempdir}
236 0 0         or croak "directory $args{tempdir} does not exist or is not a directory";
237 0           $file_options{DIR} = $args{tempdir};
238             }
239              
240             # File::Temp creates files with permissions 0600
241 0 0         my $fh = File::Temp->new(%file_options)
242             or croak "could not create temp file: $@, $!";
243              
244 0           return $fh->filename;
245             }
246              
247              
248             sub _write_log_files {
249 0     0     my ($self, %args) = @_;
250              
251             defined $args{stdout_log} and $self->_append_to_file(
252             $args{stdout_log},
253             $self->{stdout},
254 0 0         );
255              
256             defined $args{errlog} and $self->_append_to_file(
257             $args{errlog},
258             $self->{stderr},
259 0 0         );
260              
261 0           return;
262             }
263              
264              
265             sub _append_to_file {
266 0     0     my ($self, $filename, $data) = @_;
267              
268 0 0         open(my $fh, '>>', $filename)
269             or croak "couldn't open file $filename for appending $!";
270              
271 0 0 0       print $fh ($data // '')
272             or croak "failed writing to file $!";
273              
274 0 0         close $fh
275             or croak "failed closing file $filename $!";
276              
277 0           return;
278             }
279              
280              
281              
282             =head1 SUBROUTINES/METHODS
283              
284             =head2 new
285              
286             Creates a new db admin object for manipulating databases.
287              
288             =head2 verify_helpers( [ helpers => [...]], [operations => [...]])
289              
290             Verifies ability to execute (external) helper applications by
291             method name (through the C<operations> argument) or by external helper
292             name (through the C<helpers> argument). Returns a hash ref with each
293             key being the name of a helper application (see C<helpers> below) with
294             the values being a boolean indicating whether or not the helper can be
295             successfully executed.
296              
297             Valid values in the array referenced by the C<operations> parameter are
298             C<create>, C<run_file>, C<backup>, C<backup_globals>, C<restore> and
299             C<drop>; the methods this module implements with the help of external
300             helper programs. (Other values may be passed, but unsupported values
301             aren't included in the return value.)
302              
303             Valid values in the array referenced by the C<helpers> parameter are the
304             names of the PostgreSQL helper programs C<createdb>, C<dropdb>, C<pg_dump>,
305             C<pg_dumpall>, C<pg_restore> and C<psql>. (Other values may be passed, but
306             unsupported values will not be included in the return value.)
307              
308             When no arguments are passed, all helpers will be tested.
309              
310             Note: C<verify_helpers> is a class method, meaning it wants to be called
311             as C<PGObject::Util::DBAdmin->verify_helpers()>.
312              
313             =cut
314              
315              
316             sub _run_capturing_output {
317 0     0     my @args = @_;
318 0     0     my ($stdout, $stderr, $exitcode) = capture { _run_with_env(@args); };
  0            
319              
320 0           return $exitcode;
321             }
322              
323             sub verify_helpers {
324 0     0 1   my ($class, %args) = @_;
325              
326             my @helpers = (
327 0   0       @{$args{helpers} // []},
328 0   0       map { @{$helpers{$_} // []} } @{$args{operations} // []}
  0   0        
  0            
  0            
329             );
330 0 0         if (not @helpers) {
331 0           @helpers = keys %helper_paths;
332             }
333             return {
334             map {
335 0           $_ => not _run_capturing_output(command =>
336 0           [ $helper_paths{$_} , '--help' ])
337             } @helpers
338             };
339             }
340              
341              
342             =head2 export
343              
344             Exports the database parameters in a hash so it can be used to create another
345             object.
346              
347             =cut
348              
349             sub export {
350 0     0 1   my $self = shift;
351 0           return map {$_ => $self->$_() } qw(username password host port dbname)
  0            
352             }
353              
354             =head2 connect($options)
355              
356             Connects to the database using DBI and returns a database connection.
357              
358             Connection options may be specified in the $options hashref.
359              
360             =cut
361              
362             sub connect {
363 0     0 1   my ($self, $options) = @_;
364              
365 0           my $connect = 'dbname="' . $self->dbname . '"';
366              
367 0 0         $connect .= ';host=' . $self->host
368             if defined $self->host;
369              
370 0 0         $connect .= ';port=' . $self->port
371             if defined $self->port;
372              
373 0 0         my $dbh = DBI->connect(
374             'dbi:Pg:' . $connect,
375             $self->username,
376             $self->password,
377             $options
378             ) or croak 'Could not connect to database!';
379              
380 0           return $dbh;
381             }
382              
383             =head2 server_version
384              
385             Returns a version string (like 9.1.4) for PostgreSQL. Croaks on error.
386              
387             =cut
388              
389             sub server_version {
390 0     0 1   my $self = shift @_;
391 0           my $version =
392             __PACKAGE__->new($self->export, (dbname => 'template1')
393             )->connect->selectrow_array('SELECT version()');
394 0 0         my ($retval) = $version =~ /(\d+\.\d+\.\d+)/
395             or croak 'failed to extract version string';
396 0           return $retval;
397             }
398              
399              
400             =head2 list_dbs
401              
402             Returns a list of db names.
403              
404             =cut
405              
406             sub list_dbs {
407 0     0 1   my $self = shift;
408              
409 0           return map { $_->[0] }
410 0           @{ __PACKAGE__->new($self->export, (dbname => 'template1')
  0            
411             )->connect->selectall_arrayref(
412             'SELECT datname from pg_database order by datname'
413             ) };
414             }
415              
416             =head2 create
417              
418             Creates a new database.
419              
420             Croaks on error, returns true on success.
421              
422             Supported arguments:
423              
424             =over
425              
426             =item copy_of
427              
428             Creates the new database as a copy of the specified one (using it as
429             a template). Optional parameter. Default is to create a database
430             without a template.
431              
432             =back
433              
434             =cut
435              
436             sub create {
437 0     0 1   my $self = shift;
438 0           my %args = @_;
439              
440 0           my @command = ($helper_paths{createdb});
441 0 0         defined $args{copy_of} and push(@command, '-T', $args{copy_of});
442 0 0         defined $self->dbname and push(@command, $self->dbname);
443              
444 0 0         $self->_run_command(command => [@command])
445             or croak 'error running command';
446              
447 0           return 1;
448             }
449              
450              
451             =head2 run_file
452              
453             Run the specified file on the db.
454              
455             After calling this method, STDOUT and STDERR output from the external
456             utility which runs the file on the database are available as properties
457             $db->stdout and $db->stderr respectively.
458              
459             Croaks on error. Returns true on success.
460              
461             Recognized arguments are:
462              
463             =over
464              
465             =item file
466              
467             Path to file to be run. This is a mandatory argument.
468              
469             =item stdout_log
470              
471             Provided for legacy compatibility. Optional argument. The full path of
472             a file to which STDOUT from the external psql utility will be appended.
473              
474             =item errlog
475              
476             Provided for legacy compatibility. Optional argument. The full path of
477             a file to which STDERR from the external psql utility will be appended.
478              
479             =back
480              
481             =cut
482              
483             sub run_file {
484 0     0 1   my ($self, %args) = @_;
485 0           $self->{stderr} = undef;
486 0           $self->{stdout} = undef;
487              
488 0 0         croak 'Must specify file' unless defined $args{file};
489 0 0         croak 'Specified file does not exist' unless -e $args{file};
490              
491             # Build command
492             my @command =
493 0           ($helper_paths{psql}, '--set=ON_ERROR_STOP=on', '-f', $args{file});
494              
495             my $result = $self->_run_command(
496             command => [@command],
497             errlog => $args{errlog},
498             stdout_log => $args{stdout_log},
499 0 0         ) or croak 'error running command';
500              
501 0           return $result;
502             }
503              
504              
505             =head2 backup
506              
507             Creates a database backup file.
508              
509             After calling this method, STDOUT and STDERR output from the external
510             utility which runs the file on the database are available as properties
511             $db->stdout and $db->stderr respectively.
512              
513             Unlinks the output file and croaks on error.
514              
515             Returns the full path of the file containining the backup.
516              
517             Accepted parameters:
518              
519             =over
520              
521             =item format
522              
523             The specified format, for example c for custom. Defaults to plain text.
524              
525             =item file
526              
527             Full path of the file to which the backup will be written. If the file
528             does not exist, one will be created with umask 0600. If the file exists,
529             it will be overwritten, but its permissions will not be changed.
530              
531             If undefined, a file will be created using File::Temp having umask 0600.
532              
533             =item tempdir
534              
535             The directory in which to write the backup file. Optional parameter. Uses
536             File::Temp default if not defined. Ignored if file parameter is given.
537              
538             =item compress
539              
540             Optional parameter. Specifies the compression level to use and is passed to
541             the underlying pg_dump command. Default is no compression.
542              
543             =back
544              
545             =cut
546              
547             sub backup {
548 0     0 1   my ($self, %args) = @_;
549 0           $self->{stderr} = undef;
550 0           $self->{stdout} = undef;
551              
552 0           my $output_filename = $self->_generate_output_filename(%args);
553              
554 0           my @command = ($helper_paths{pg_dump}, '-f', $output_filename);
555 0 0         defined $args{compress} and push(@command, '-Z', $args{compress});
556 0 0         defined $args{format} and push(@command, "-F$args{format}");
557              
558 0 0         $self->_run_command(command => [@command])
559             or $self->_unlink_file_and_croak($output_filename,
560             'error running pg_dump command');
561              
562 0           return $output_filename;
563             }
564              
565              
566             =head2 backup_globals
567              
568             This creates a file containing a plain text dump of global (inter-db)
569             objects, such as users and tablespaces. It uses pg_dumpall to do this.
570              
571             Being a plain text file, it can be restored using the run_file method.
572              
573             Unlinks the output file and croaks on error.
574              
575             Returns the full path of the file containining the backup.
576              
577             Accepted parameters:
578              
579             =over
580              
581             =item file
582              
583             Full path of the file to which the backup will be written. If the file
584             does not exist, one will be created with umask 0600. If the file exists,
585             it will be overwritten, but its permissions will not be changed.
586              
587             If undefined, a file will be created using File::Temp having umask 0600.
588              
589             =item tempdir
590              
591             The directory in which to write the backup file. Optional parameter. Uses
592             File::Temp default if not defined. Ignored if file parameter is given.
593              
594             =back
595              
596             =cut
597              
598             sub backup_globals {
599 0     0 1   my ($self, %args) = @_;
600 0           $self->{stderr} = undef;
601 0           $self->{stdout} = undef;
602              
603 0 0         local $ENV{PGPASSWORD} = $self->password if defined $self->password;
604 0           my $output_filename = $self->_generate_output_filename(%args);
605              
606 0           my @command = ($helper_paths{pg_dumpall}, '-g', '-f', $output_filename);
607              
608 0 0         $self->_run_command(command => [@command])
609             or $self->_unlink_file_and_croak($output_filename,
610             'error running pg_dumpall command');
611              
612 0           return $output_filename;
613             }
614              
615              
616             =head2 restore
617              
618             Restores from a saved file. Must pass in the file name as a named argument.
619              
620             After calling this method, STDOUT and STDERR output from the external
621             restore utility are available as properties $db->stdout and $db->stderr
622             respectively.
623              
624             Croaks on error. Returns true on success.
625              
626             Recognized arguments are:
627              
628             =over
629              
630             =item file
631              
632             Path to file which will be restored to the database. Required.
633              
634             =item format
635              
636             The file format, for example c for custom. Defaults to plain text.
637              
638             =back
639              
640             =cut
641              
642             sub restore {
643 0     0 1   my ($self, %args) = @_;
644 0           $self->{stderr} = undef;
645 0           $self->{stdout} = undef;
646              
647 0 0         croak 'Must specify file' unless defined $args{file};
648 0 0         croak 'Specified file does not exist' unless -e $args{file};
649              
650             return $self->run_file(%args)
651 0 0 0       if not defined $args{format} or $args{format} eq 'p';
652              
653             # Build command options
654 0           my @command = ($helper_paths{pg_restore}, '--verbose', '--exit-on-error');
655 0 0         defined $args{format} and push(@command, "-F$args{format}");
656 0 0         defined $self->dbname and push(@command, '-d', $self->dbname);
657 0           push(@command, $args{file});
658              
659 0 0         $self->_run_command(command => [@command])
660             or croak 'error running command';
661              
662 0           return 1;
663             }
664              
665              
666             =head2 drop
667              
668             Drops the database. This is not recoverable. Croaks on error, returns
669             true on success.
670              
671             =cut
672              
673             sub drop {
674 0     0 1   my ($self) = @_;
675              
676 0 0         croak 'No db name of this object' unless $self->dbname;
677              
678 0           my @command = ($helper_paths{dropdb});
679 0           push(@command, $self->dbname);
680              
681 0 0         $self->_run_command(command => [@command])
682             or croak 'error running command';
683              
684 0           return 1;
685             }
686              
687              
688             =head1 CAPTURING
689              
690             This module uses C<Capture::Tiny> to run extenal commands and capture their
691             output, which is made available through the C<stderr> and C<stdout>
692             properties.
693              
694             This capturing does not work if Perl's standard C<STDOUT> or
695             C<STDERR> filehandles have been localized. In this situation, the localized
696             filehandles are captured, but external system calls are not
697             affected by the localization, so their output is sent to the original
698             filehandles and is not captured.
699              
700             See the C<Capture::Tiny> documentation for more details.
701              
702             =head1 AUTHOR
703              
704             Chris Travers, C<< <chris at efficito.com> >>
705              
706             =head1 BUGS
707              
708             Please report any bugs or feature requests to C<bug-pgobject-util-dbadmin at rt.cpan.org>, or through
709             the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=PGObject-Util-DBAdmin>. I will be notified, and then you'll
710             automatically be notified of progress on your bug as I make changes.
711              
712              
713              
714              
715             =head1 SUPPORT
716              
717             You can find documentation for this module with the perldoc command.
718              
719             perldoc PGObject::Util::DBAdmin
720              
721              
722             You can also look for information at:
723              
724             =over 4
725              
726             =item * RT: CPAN's request tracker (report bugs here)
727              
728             L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=PGObject-Util-DBAdmin>
729              
730             =item * AnnoCPAN: Annotated CPAN documentation
731              
732             L<http://annocpan.org/dist/PGObject-Util-DBAdmin>
733              
734             =item * CPAN Ratings
735              
736             L<http://cpanratings.perl.org/d/PGObject-Util-DBAdmin>
737              
738             =item * Search CPAN
739              
740             L<http://search.cpan.org/dist/PGObject-Util-DBAdmin/>
741              
742             =back
743              
744              
745             =head1 ACKNOWLEDGEMENTS
746              
747              
748             =head1 LICENSE AND COPYRIGHT
749              
750             Copyright 2014-2019 Chris Travers.
751              
752             This program is distributed under the (Revised) BSD License:
753             L<http://www.opensource.org/licenses/BSD-3-Clause>
754              
755             Redistribution and use in source and binary forms, with or without
756             modification, are permitted provided that the following conditions
757             are met:
758              
759             * Redistributions of source code must retain the above copyright
760             notice, this list of conditions and the following disclaimer.
761              
762             * Redistributions in binary form must reproduce the above copyright
763             notice, this list of conditions and the following disclaimer in the
764             documentation and/or other materials provided with the distribution.
765              
766             * Neither the name of Chris Travers's Organization
767             nor the names of its contributors may be used to endorse or promote
768             products derived from this software without specific prior written
769             permission.
770              
771             THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
772             "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
773             LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
774             A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
775             OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
776             SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
777             LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
778             DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
779             THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
780             (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
781             OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
782              
783              
784             =cut
785              
786             1; # End of PGObject::Util::DBAdmin