1package DBIx::QuickDB::Driver; 2use strict; 3use warnings; 4 5our $VERSION = '0.000021'; 6 7use Carp qw/croak confess/; 8use File::Path qw/remove_tree/; 9use File::Temp qw/tempdir/; 10use POSIX ":sys_wait_h"; 11use Scalar::Util qw/blessed/; 12use Time::HiRes qw/sleep time/; 13 14use DBIx::QuickDB::Util qw/clone_dir/; 15 16use DBIx::QuickDB::Watcher; 17 18use DBIx::QuickDB::Util::HashBase qw{ 19 -root_pid 20 -dir 21 -_cleanup 22 -autostop -autostart 23 verbose 24 -_log_id 25 username 26 password 27 env_vars 28 <watcher 29}; 30 31sub viable { (0, "viable() is not implemented for the " . $_[0]->name . " driver") } 32 33sub socket { confess "socket() is not implemented for the " . $_[0]->name . " driver" } 34sub load_sql { confess "load_sql() is not implemented for the " . $_[0]->name . " driver" } 35sub bootstrap { confess "bootstrap() is not implemented for the " . $_[0]->name . " driver" } 36sub connect_string { confess "connect_string() is not implemented for the " . $_[0]->name . " driver" } 37sub start_command { confess "start_command() is not implemented for the " . $_[0]->name . " driver" } 38sub shell_command { confess "shell_command() is not implemented for the " . $_[0]->name . " driver" } 39 40sub list_env_vars { qw/DBI_USER DBI_PASS DBI_DSN/ } 41 42sub version_string { 'unknown' } 43 44sub stop_sig { 'TERM' } 45 46sub write_config {} 47 48sub do_in_env { 49 my $self = shift; 50 my ($code) = @_; 51 52 my $old = $self->mask_env_vars; 53 54 my $ok = eval { $code->(); 1 }; 55 my $err = $@; 56 57 $self->unmask_env_vars($old); 58 59 die $err unless $ok; 60 61 return; 62} 63 64sub mask_env_vars { 65 my $self = shift; 66 67 my %old; 68 69 for my $var ($self->list_env_vars) { 70 next unless defined $ENV{$var}; 71 $old{$var} = delete $ENV{$var}; 72 } 73 74 my $env_vars = $self->env_vars || {}; 75 for my $var (keys %$env_vars) { 76 $old{$var} = delete $ENV{$var} unless defined $old{$var}; 77 $ENV{$var} = $env_vars->{$var}; 78 } 79 80 return \%old; 81} 82 83sub unmask_env_vars { 84 my $self = shift; 85 my ($old) = @_; 86 87 for my $var (keys %$old) { 88 my $val = $old->{$var}; 89 90 if (defined $val) { 91 $ENV{$var} = $val; 92 } 93 else { 94 delete $ENV{$var}; 95 } 96 } 97 98 return; 99} 100 101sub name { 102 my $in = shift; 103 my $type = blessed($in) || $in; 104 105 $in =~ s/^DBIx::QuickDB::Driver:://; 106 107 return $in; 108} 109 110sub init { 111 my $self = shift; 112 113 confess "'dir' is a required attribute" unless $self->{+DIR}; 114 115 $self->{+ROOT_PID} = $$; 116 $self->{+_CLEANUP} = delete $self->{cleanup}; 117 118 $self->{+USERNAME} = '' unless defined $self->{+USERNAME}; 119 $self->{+PASSWORD} = '' unless defined $self->{+PASSWORD}; 120 121 $self->{+ENV_VARS} ||= {}; 122 123 return; 124} 125 126sub clone_data { 127 my $self = shift; 128 129 return ( 130 USERNAME() => $self->{+USERNAME}, 131 PASSWORD() => $self->{+PASSWORD}, 132 VERBOSE() => $self->{+VERBOSE}, 133 AUTOSTOP() => $self->{+AUTOSTOP}, 134 AUTOSTART() => $self->{+AUTOSTART}, 135 136 cleanup => $self->{+_CLEANUP}, 137 138 ENV_VARS() => {%{$self->{+ENV_VARS}}}, 139 ); 140} 141 142sub clone { 143 my $self = shift; 144 my %params = @_; 145 146 confess "Cannot clone a started database, please stop it first." 147 if $self->started; 148 149 my $orig_dir = $self->{+DIR}; 150 my $new_dir = delete $params{dir} // tempdir('DB-QUICK-CLONE-XXXXXX', CLEANUP => 0, TMPDIR => 1); 151 152 clone_dir($orig_dir, $new_dir, verbose => (($self->{+VERBOSE} // 0) > 2) ? 1 : 0); 153 154 my $class = ref($self); 155 my %ok = ( 156 cleanup => 1, 157 map {$_ => 1} DBIx::QuickDB::Util::HashBase::attr_list($class), 158 ); 159 my @bad = grep { !$ok{$_} } keys %params; 160 161 confess "Invalid options to clone(): " . join(', ' => @bad) 162 if @bad; 163 164 my $clone = $class->new( 165 $self->clone_data, 166 167 %params, 168 169 DIR() => $new_dir, 170 171 WATCHER() => undef, 172 ); 173 174 $clone->write_config(); 175 $clone->start if $clone->{+AUTOSTART}; 176 177 return $clone; 178} 179 180sub gen_log { 181 my $self = shift; 182 return if $self->no_log(@_); 183 return $self->{+DIR} . "/cmd-log-$$-" . $self->{+_LOG_ID}++; 184} 185 186sub no_log { 187 my $self = shift; 188 my ($params) = @_; 189 return $self->{+VERBOSE} || $params->{no_log} || $ENV{DB_VERBOSE}; 190} 191 192sub run_command { 193 my $self = shift; 194 my ($cmd, $params) = @_; 195 196 my $no_log = $self->no_log($params); 197 my $log_file = $params->{log_file} || ($no_log ? undef : $self->gen_log); 198 199 my $pid = fork(); 200 croak "Could not fork" unless defined $pid; 201 202 if ($pid) { 203 local $?; 204 return ($pid, $log_file) if $params->{no_wait}; 205 my $ret = waitpid($pid, 0); 206 my $exit = $?; 207 die "waitpid returned $ret" unless $ret == $pid; 208 209 return unless $exit; 210 211 my $log = ""; 212 unless ($no_log) { 213 open(my $fh, '<', $log_file) or warn "Failed to open log: $!"; 214 $log = eval { join "" => <$fh> }; 215 } 216 croak "Failed to run command '" . join(' ' => @$cmd) . "' ($exit)\n$log"; 217 } 218 219 $self->mask_env_vars; 220 221 unless ($no_log) { 222 open(my $log, '>', $log_file) or die "Could not open log file ($log_file): $!"; 223 close(STDOUT); 224 open(STDOUT, '>&', $log); 225 close(STDERR); 226 open(STDERR, '>&', $log); 227 } 228 229 if (my $file = $params->{stdin}) { 230 close(STDIN); 231 open(STDIN, '<', $file) or die "Could not open new STDIN ($file): $!"; 232 } 233 234 exec(@$cmd); 235} 236 237sub should_cleanup { shift->{+_CLEANUP} } 238 239sub cleanup { 240 my $self = shift; 241 242 # Ignore errors here. 243 my $err = []; 244 remove_tree($self->{+DIR}, {safe => 1, error => \$err}) if -d $self->{+DIR}; 245 return; 246} 247 248sub connect { 249 my $self = shift; 250 my ($db_name, %params) = @_; 251 252 %params = (AutoCommit => 1, RaiseError => 1) unless @_ > 1; 253 254 my $dbh; 255 $self->do_in_env( 256 sub { 257 my $cstring = $self->connect_string($db_name); 258 require DBI; 259 $dbh = DBI->connect($cstring, $self->username, $self->password, \%params); 260 } 261 ); 262 263 return $dbh; 264} 265 266sub started { 267 my $self = shift; 268 269 my $socket = $self->socket; 270 return 1 if $self->{+WATCHER} || -S $socket; 271 return 0; 272} 273 274sub start { 275 my $self = shift; 276 my @args = @_; 277 278 my $dir = $self->{+DIR}; 279 my $socket = $self->socket; 280 281 return if $self->{+WATCHER} || -S $socket; 282 283 my $watcher = $self->{+WATCHER} = DBIx::QuickDB::Watcher->new(db => $self, args => \@args); 284 285 my $start = time; 286 until (-S $socket) { 287 my $waited = time - $start; 288 289 if ($waited > 10) { 290 $watcher->eliminate(); 291 confess "Timed out waiting for server to start"; 292 last; 293 } 294 295 sleep 0.01; 296 } 297 298 return; 299} 300 301sub stop { 302 my $self = shift; 303 my %params = @_; 304 305 my $watcher = delete $self->{+WATCHER} or return; 306 307 DBI->visit_handles( 308 sub { 309 my ($driver_handle) = @_; 310 311 $driver_handle->disconnect 312 if $driver_handle->{Type} && $driver_handle->{Type} eq 'db' 313 && $driver_handle->{Name} && index($driver_handle->{Name}, $self->{+DIR}) >= 0; 314 315 return 1; 316 } 317 ); 318 319 $watcher->stop(); 320 321 my $start = time; 322 unless ($params{no_wait}) { 323 $watcher->wait(); 324 325 while (-S $self->socket) { 326 my $waited = time - $start; 327 328 if ($waited > 10) { 329 confess "Timed out waiting for server to stop"; 330 last; 331 } 332 333 sleep 0.01; 334 } 335 } 336 337 return; 338} 339 340sub shell { 341 my $self = shift; 342 my ($db_name) = @_; 343 $db_name = 'quickdb' unless defined $db_name; 344 345 system($self->shell_command($db_name)); 346} 347 348sub DESTROY { 349 my $self = shift; 350 return unless $self->{+ROOT_PID} && $self->{+ROOT_PID} == $$; 351 352 if (my $watcher = delete $self->{+WATCHER}) { 353 $watcher->eliminate(); 354 } 355 elsif ($self->should_cleanup) { 356 $self->cleanup(); 357 } 358 359 return; 360} 361 3621; 363 364__END__ 365 366=pod 367 368=encoding UTF-8 369 370=head1 NAME 371 372DBIx::QuickDB::Driver - Base class for DBIx::QuickDB drivers. 373 374=head1 DESCRIPTION 375 376Base class for DBIx::QuickDB drivers. 377 378=head1 SYNOPSIS 379 380 package DBIx::QuickDB::Driver::MyDriver; 381 use strict; 382 use warnings; 383 384 use parent 'DBIx::QuickDB::Driver'; 385 386 use DBIx::QuickDB::Util::HashBase qw{ ... }; 387 388 sub viable { ... ? 1 : (0, "This driver will not work because ...") } 389 390 sub init { 391 my $self = shift; 392 393 $self->SUPER::init(); 394 395 ... 396 } 397 398 # Methods most drivers should implement 399 400 sub version_string { ... } 401 sub socket { ... } 402 sub load_sql { ... } 403 sub bootstrap { ... } 404 sub connect_string { ... } 405 sub start_command { ... } 406 sub shell_command { ... } 407 408 # Implement if necessary 409 sub write_config { ... } 410 sub stop_sig { return $SIG } 411 412 1; 413 414=head1 METHODS PROVIDED HERE 415 416=over 4 417 418=item $bool = $db->autostart 419 420True if this db was created with 'autostart' requested. 421 422=item $bool = $db->autostop 423 424True if this db was created with 'autostop' requested. 425 426=item $db->cleanup 427 428This will completely delete the database directory. B<BE CAREFUL>. 429 430=item $dbh = $db->connect() 431 432=item $dbh = $db->connect($db_name) 433 434=item $dbh = $db->connect($db_name, %connect_params) 435 436Connect to the database server. If no C<%connect_params> are specified then 437C<< (AutoCommit => 1) >> will be used. 438 439Behavior for an undef (or omitted) C<$db_name> is driver specific. 440 441This will use the username in C<username()> and the password in C<password()>. 442The connection string is defined by C<connect_string()> which must be overriden 443in each driver subclass. 444 445B<NOTE:> connect will hide all DBI and driver specific environment variables 446when it establishes a connection. If you want any environment variables to be 447used you must set them in the C<< $db->env_vars() >> hashref. 448 449=item $path = $db->dir 450 451Get the path to the database directory. 452 453=item $db->init 454 455This is called automatically during object construction. You B<SHOULD NOT> call 456this directly, except in a subclass which overrides C<init()>. 457 458=item $path = $db->log_file 459 460If the database is running this will point to the log file. If the database is 461not yet running, or has been stopped, this will be undef. 462 463=item $driver_name = $db->name 464 465Get the short name of the driver ('DBIx::QuickDB::Driver::' has been stripped). 466 467=item $pw = $db->password 468 469=item $db->password($pw) 470 471Get/Set the password to use when calling C<connect()>. 472 473=item $pid = $db->pid 474 475=item $db->pid($pid) 476 477If the server is running then this will have the pid. If the server is stopped 478this will be undef. 479 480B<NOTE:> This will also be undef if the server is running independantly of this 481object, if the server is running, but this is undef, it means another 482object/process is in control of it. 483 484=item $pid = $db->root_pid 485 486This should contain the original pid of the process in which the instance was 487created. 488 489=item $db->run_command(\@cmd) 490 491=item $db->run_command(\@cmd, \%params) 492 493=item ($pid, $logfile) = $db->run_command(\@cmd, {no_wait => 1}) 494 495This will execute the command specified in C<@cmd>. If the command fails an 496exception will be thrown. By default all output will be captured into log files 497and ignored. If the command fails the output will be attached to the exception. 498Normally this will block until the command exits. if C<verbose()> is set then 499all output is always shown. 500 501Normally there is no return value. If the 'no_wait' param is specified then 502the command will be run non-blocking and the pid and log file will be returned. 503 504B<NOTE:> C<run_command()> will clear any DBI and driver specific environment 505variables before running any commands. If you want any of the vars to be set 506then you must set them in the C<< $db->env_vars() >> hashref. 507 508Allowed params: 509 510=over 4 511 512=item no_log => bool 513 514Show the output in realtime, do not redirect it. 515 516=item no_wait => bool 517 518Do not block, instead return the pid and log file to use later. 519 520=item stdin => path_to_file 521 522Run the command with the specified file is input. 523 524=back 525 526=item $db->shell 527 528Launch a database shell. This depends on the C<shell_command> method, which 529drivers should provide. Not all driver may support this. 530 531=item $bool = $db->should_cleanup 532 533True if the instance was created with the 'cleanup' specification. If this is 534true then the database directory will be deleted when the program ends. 535 536=item $db->start 537 538Start the database. Most drivers will make this a no-op if the db is already 539running. 540 541=item $db->stop 542 543Stop the database. Most drivers will make this a no-op if the db is already 544stopped. 545 546=item $user = $db->username 547 548=item $db->username($user) 549 550Get/set the username to use in C<connect()>. 551 552=item $bool = $db->verbose 553 554=item $db->verbose($bool) 555 556If this is true then all output from C<run_command> will be shown at all times. 557 558=item $clone = $db->clone() 559 560=item $clone = $db->clone(%params) 561 562Create a copy of the database. This database should be identical, except it 563should not share any state changes moving forward, that means a new copy of all 564data, etc. 565 566=item %data = $db->clone_data() 567 568Data to use when cloning 569 570=item $db->write_config() 571 572no-op on the base class, used in cloning. 573 574=item $sig = $db->stop_sig() 575 576What signal to send to the database server to stop it. Default: C<'TERM'>. 577 578=item $db->DESTROY 579 580Used to stop the server and delete the data dir (if desired) when the program 581exits. 582 583=back 584 585=head1 ENVIRONMENT VARIABLE HANDLING 586 587All DBI and driver specific environment variables will be hidden Whenever a 588driver uses C<run_command()> or when the C<connect()> method is called. This is 589to prevent you from accidentally connecting to a real/production database 590unintentionally. 591 592If there are DBI or driver specific env vars you want to be honored you must 593add them to the hashref returned by C<< $db->env_vars >>. Any vars set in the 594C<env_vars> hashref will be set during C<connect()> and C<run_command()>. 595 596=head2 ENVIRONMENT VARIABLE METHODS 597 598=over 4 599 600=item $hashref = $db->env_vars() 601 602Get the hashref of env vars to set whenever C<run_command()>, C<connect()>, 603C<do_in_env()>, or C<mask_env_vars()> are called. 604 605You cannot replace te hashref, but you are free to add/remove keys. 606 607=item @vars = $db->list_env_vars 608 609This will return a list of all DBI and driver-specific environment variables. 610This is just a list of variable names, not their values. 611 612The base class provides the following list, drivers may add more: 613 614=over 4 615 616=item DBI_USER 617 618=item DBI_PASS 619 620=item DBI_DSN 621 622=back 623 624=item $db->do_in_env(sub { ... }) 625 626This will execute the provided codeblock with the environment variables masked, 627and any vars listed in C<env_vars()> will be set. Once the codeblock is 628complete the old environment vars will be unmaskd, even if an exception is 629thrown. 630 631B<NOTE:> The return value of the codeblock is ignored. 632 633=item $old = $db->mask_env_vars 634 635=item $db->unmask_env_vars($old) 636 637These methods are used to mask/unmask DBI and driver specific environment 638variables. 639 640The first method will completely clear any DBI/driver environment variables, 641then apply any variables in the C<env_vars()> hash. The value returned is a 642hashref needed to unmask/restore the original environment variables later. 643 644The second method will unmask/restore the original environment variables using 645the hashref returned by the first. 646 647=back 648 649=head1 METHODS SUBCLASSES SHOULD PROVIDE 650 651Drivers may override C<clone()> or C<clone_data()> to control cloning. 652 653=over 654 655=item ($bool, $why) = $db->viable() 656 657=item ($bool, $why) = $db->viable(\%spec) 658 659This should check if it is possible to launch this db type on the current 660system with the given spec. 661 662See L<DBIx::QuickDB/"SPEC HASH"> for what might be in C<%spec>. 663 664The first return value is a simple boolean, true if the driver is viable, false 665if it is not. The second value should be an explanation as to why the driver is 666not viable (in cases where it is not). 667 668=item $string = Your::Driver::version_string() 669 670=item $string = Your::Driver::version_string(\%PARAMS) 671 672=item $string = Your::Driver->version_string() 673 674=item $string = Your::Driver->version_string(\%PARAMS) 675 676=item $string = $db->version_string() 677 678=item $string = $db->version_string(\%PARAMS) 679 680The default implementation returns 'unknown'. 681 682This is complicated because it can be called as a function, a class method, or 683an object method. It can also optionally be called with a hashref of PARAMS 684that MAY be later used to construct an instance. 685 686Lets assume your driver uses the C<start_my_db> command to launch a database. 687Normally you default to the C<start_my_db> found in the $PATH environment 688variable. Alternatively someone can pass in an alternative path to the binary 689with the 'launcher' parameter. Here is a good implementation: 690 691 use Scalar::Util qw/reftype/; 692 693 sub version_string { 694 my $binary; 695 696 # Go in reverse order assuming the last param hash provided is most important 697 for my $arg (reverse @_) { 698 my $type = reftype($arg) or next; # skip if not a ref 699 next $type eq 'HASH'; # We have a hashref, possibly blessed 700 701 # If we find a launcher we are done looping, we want to use this binary. 702 $binary = $arg->{launcher} and last; 703 } 704 705 # If no args provided one to use we fallback to the default from $PATH 706 $binary ||= DEFAULT_BINARY; 707 708 # Call the binary with '-V', capturing and returning the output using backticks. 709 return `$binary -V`; 710 } 711 712=item $socket = $db->socket() 713 714Unix Socket used to communicate with the db. If the db type does not use 715sockets (such as SQLite) then this can be skipped. B<NOTE:> If you skip this 716you will need to override C<stop()> and C<start()> to account for it. See 717L<DBIx::QuickDB::Driver::SQLite> for an example. 718 719=item $db->load_sql($db_name, $file) 720 721Load the specified sql file into the specified db. It is possible that 722C<$db_name> will be undef in some drivers. 723 724=item $db->bootstrap() 725 726Initialize the database server and create the 'quickdb' database. 727 728=item $string = $db->connect_string() 729 730=item $string $db->connect_string($db_name) 731 732String to pass into C<< DBI->connect >>. 733 734Example: C<"dbi:Pg:dbname=$db_name;host=$socket"> 735 736=item @cmd = $db->start_command() 737 738Command used to start the server. 739 740=item @cmd = $db->shell_command() 741 742Command used to launch a shell into the database. 743 744=back 745 746=head1 SOURCE 747 748The source code repository for DBIx-QuickDB can be found at 749F<https://github.com/exodist/DBIx-QuickDB/>. 750 751=head1 MAINTAINERS 752 753=over 4 754 755=item Chad Granum E<lt>exodist@cpan.orgE<gt> 756 757=back 758 759=head1 AUTHORS 760 761=over 4 762 763=item Chad Granum E<lt>exodist@cpan.orgE<gt> 764 765=back 766 767=head1 COPYRIGHT 768 769Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. 770 771This program is free software; you can redistribute it and/or 772modify it under the same terms as Perl itself. 773 774See F<http://dev.perl.org/licenses/> 775 776=cut 777