From 00b3113031e443112422d484f74b4d863bdb3fa4 Mon Sep 17 00:00:00 2001 From: Graham Knop Date: Tue, 4 May 2010 08:30:19 -0500 Subject: [PATCH] new upgrade stuff --- lib/WebGUI/Upgrade/File/pl.pm | 260 +++++---------------------------- lib/WebGUI/Upgrade/Script.pm | 268 ++++++++++++++++++++++++++++++++++ 2 files changed, 305 insertions(+), 223 deletions(-) create mode 100644 lib/WebGUI/Upgrade/Script.pm diff --git a/lib/WebGUI/Upgrade/File/pl.pm b/lib/WebGUI/Upgrade/File/pl.pm index f79f4a350..3de9c9f61 100644 --- a/lib/WebGUI/Upgrade/File/pl.pm +++ b/lib/WebGUI/Upgrade/File/pl.pm @@ -3,239 +3,53 @@ use 5.010; use strict; use warnings; -use WebGUI::Upgrade (); -use WebGUI::Upgrade::File::wgpkg (); -use POSIX (); +use WebGUI::Upgrade::Script (); use Path::Class::Dir (); -use Exporter qw(import); - -sub _runCode { - eval sprintf <<'END_CODE', $_[0], $_[1]; -package - WebGUI::Upgrade::File::pl::script; -use 5.010; -use strict; -use warnings; -no warnings 'uninitialized'; -local @_; -local $_; -use WebGUI::Upgrade::File::pl qw(:script); -# line 1 "%s" -%s -; +use Try::Tiny; use namespace::clean; -END_CODE -} -our @EXPORT_OK = qw( - quiet - report - done - config - session - dbh - version_tag - rm_lib - collateral - import_package -); -our %EXPORT_TAGS = ( - script => \@EXPORT_OK, -); - -my $configFile; -my $quiet; -my $version; -my $file; -my $session; -my $config; -my $dbh; -my $collateral; -my $versionTag; -sub run { - my $class = shift; - ($configFile, $version, $file, $quiet) = @_; - ($session, $config, $dbh, $versionTag, $collateral) = undef; - open my $fh, '<', $file; - my $contents = do { local $/; <$fh> }; - close $fh; +sub _runScript { + my $file = shift; my @res; - if (wantarray) { - @res = _runCode($file, $contents); - } - else { - $res[0] = _runCode($file, $contents); - } - - my $error = $@; - if ($session) { - require WebGUI::VersionTag; - if (WebGUI::VersionTag->getWorking($session, 'nocreate')) { - version_tag()->commit; + my $err; + { + local *_; + my $guard = WebGUI::Upgrade::Script->cleanup_guard; + # place this in a specific separate package to prevent namespace + # pollution and to allow us to clean it up afterward + package + WebGUI::Upgrade::File::pl::script; + # maintain context + if (wantarray) { + @res = do $file; } - $session->var->end; - $session->close; + elsif (defined wantarray) { + $res[0] = do $file; + } + else { + do $file; + } + # save error as soon as possible + $err = $@; } - die $error - if $error; + { + # delete entire namespace that script was run in + no strict 'refs'; + delete ${'WebGUI::Upgrade::File::pl::'}{'script::'}; + } + die $@ + if $@; return (wantarray ? @res : $res[0]); } -=head2 quiet +sub run { + my $class = shift; + my ($configFile, $version, $file, $quiet) = @_; -Returns the value of the quiet flag. - -=cut - -sub quiet () { - return $quiet; -} - -=head2 report ( $message ) - -Outputs $message unless quiet mode has been enabled. - -=cut - -sub report { - print @_ unless $quiet; -} - -=head2 done - -Reports that the current step has been completed. - -=cut - -sub done () { - print "Done.\n" unless $quiet; -} - -=head2 config - -Returns the WebGUI::Config object for the site. - -=cut - -sub config () { - require WebGUI::Config; - $config ||= WebGUI::Config->new($configFile, 1); - return $config; -} - -=head2 session - -Returns a session for the site. - -=cut - -sub session () { - return $session - if $session; - - require WebGUI::Session; - $session = WebGUI::Session->open(config); - $session->user({userId => 3}); - return $session; -} - -=head2 dbh - -Returns a database handle for the site's database. - -=cut - -sub dbh () { - return $dbh - if $dbh; - - $dbh = WebGUI::Upgrade->dbhForConfig(config); - return $dbh; -} - -=head2 version_tag ( [ $name ] ) - -If $name is specified, creates a new version tag with that name, -sets it as the active version tag, and returns it - -If $name is not specified, returns the current working version tag, -creating it if needed. - -The actual name of the version tag will automatically include a -note specifying that it is an upgrade version tag. - -=cut - -sub version_tag { - my $name = shift; - require WebGUI::VersionTag; - if ($versionTag) { - if ($name) { - $versionTag->commit; - } - else { - return $versionTag; - } - } - if (! $name) { - (undef, undef, my $shortname) = File::Spec->splitpath($file); - $shortname =~ s/\.[^.]*$//; - $name = $shortname; - } - $versionTag = WebGUI::VersionTag->getWorking(session); - $versionTag->set({name => "Upgrade to $version - $name"}); - return $versionTag; -} - -=head2 rm_lib ( $module ) - -Deletes the specified Perl module. The module should be specified -as a colon separated name, and it will be removed from all include -paths. - -=cut - -sub rm_lib { - my @modules = @_; - for my $module (@modules) { - $module =~ s{::}{/}g; - $module .= '.pm'; - for my $inc (@INC) { - my $fullPath = File::Spec->catfile($inc, $module); - unlink $fullPath; - } - } -} - -=head2 collateral - -Returns a Path::Class::Dir object for the upgrade script's collateral -path. The collateral path is the same as the name of the upgrade -script with the extension stripped off. - -=cut - -sub collateral () { - if (! $collateral) { - (my $vol, my $dir, my $shortname) = File::Spec->splitpath($file); - $shortname =~ s/\.[^.]*$//; - my $path = File::Spec->catpath($vol, File::Spec->catdir($dir, $shortname), ''); - $collateral = Path::Class::Dir->new($path); - } - return $collateral; -} - -=head2 import_package ( $package_file ) - -Imports the specified package from the upgrade script's collateral path. - -=cut - -sub import_package { - my $fullPath = collateral->file(@_); - require WebGUI::Upgrade::File::wgpkg; - WebGUI::Upgrade::File::wgpkg->import_package(session, $fullPath); + local $ENV{WEBGUI_CONFIG} = $configFile; + local $ENV{WEBGUI_UPGRADE_VERSION} = $version; + local $ENV{WEBGUI_UPGRADE_QUIET} = $quiet; + return _runScript($file); } 1; - diff --git a/lib/WebGUI/Upgrade/Script.pm b/lib/WebGUI/Upgrade/Script.pm new file mode 100644 index 000000000..081771545 --- /dev/null +++ b/lib/WebGUI/Upgrade/Script.pm @@ -0,0 +1,268 @@ +package WebGUI::Upgrade::Script; +use 5.010; +use strict; +use warnings; +use feature (); + +use Sub::Exporter; +use WebGUI::Upgrade (); + +my $exporter = Sub::Exporter::build_exporter({ + groups => { + default => \&_build_exports, + }, +}); + +sub import { + my ($class, @args) = @_; + my $extra = shift @args if ref $args[0] eq 'HASH'; + $extra ||= {}; + if ( !$extra->{into} ) { + $extra->{into_level} ||= 0; + $extra->{into_level}++; + } + + feature->import(':5.10'); + strict->import; + warnings->import; + warnings->unimport('uninitialized'); + $class->$exporter( $extra, @args ); +} + +my @cleanups; + +sub _build_exports { + my $configFile = $ENV{WEBGUI_CONFIG}; + my $version = $ENV{WEBGUI_UPGRADE_VERSION}; + my $quiet = $ENV{WEBGUI_UPGRADE_QUIET}; + + my $session; + my $config; + my $dbh; + my $collateral; + my $versionTag; + + my $subs; + + my $cleanup = sub { + if ($session) { + require WebGUI::VersionTag; + if (WebGUI::VersionTag->getWorking($session, 'nocreate')) { + $subs->{version_tag}->()->commit; + } + $session->var->end; + $session->close; + } + undef $session; + undef $versionTag; + }; + my $cleanup_installed = 0; + my $check_cleanup = sub { + push @cleanups, $cleanup + unless $cleanup_installed++; + }; + + $subs = { + quiet => sub () { + return $quiet; + }, + report => sub { + print @_ + unless $quiet; + }, + done => sub () { + print "Done.\n" + unless $quiet; + }, + config => sub () { + return $config + if $config; + $check_cleanup->(); + require WebGUI::Config; + $config = WebGUI::Config->new($configFile, 1); + return $config; + }, + session => sub () { + return $session + if $session && ! $session->closed; + + $check_cleanup->(); + require WebGUI::Session; + $session = WebGUI::Session->open($subs->{config}->()); + $session->user({userId => 3}); + return $session; + }, + dbh => sub () { + return $dbh + if $dbh; + + $check_cleanup->(); + $dbh = WebGUI::Upgrade->dbhForConfig($subs->{config}->()); + return $dbh; + }, + version_tag => sub { + my $name = shift; + $check_cleanup->(); + require WebGUI::VersionTag; + if ($versionTag) { + if ($name) { + $versionTag->commit; + } + elsif ( ! $versionTag->isCommitted ) { + return $versionTag; + } + } + if (! $name) { + (undef, undef, my $shortname) = File::Spec->splitpath((caller(0))[1]); + $shortname =~ s/\.[^.]*$//; + $name = $shortname; + } + $versionTag = WebGUI::VersionTag->getWorking($subs->{session}->()); + $versionTag->set({name => "Upgrade to $version - $name"}); + return $versionTag; + }, + rm_lib => sub { + my @modules = @_; + for my $module (@modules) { + $module =~ s{::}{/}g; + $module .= '.pm'; + for my $inc (@INC) { + my $fullPath = File::Spec->catfile($inc, $module); + unlink $fullPath; + } + } + }, + collateral => sub () { + return $collateral + if $collateral; + (my $vol, my $dir, my $shortname) = File::Spec->splitpath( + File::Spec->rel2abs( (caller(0))[1] ) + ); + $shortname =~ s/\.[^.]*$//; + my $path = File::Spec->catpath($vol, File::Spec->catdir($dir, $shortname), ''); + $collateral = Path::Class::Dir->new($path); + return $collateral; + }, + import_package => sub { + my $fullPath = $subs->{collateral}->()->file(@_); + require WebGUI::Upgrade::File::wgpkg; + WebGUI::Upgrade::File::wgpkg->import_package($subs->{session}->(), $fullPath); + }, + }; + return $subs; +} + +sub cleanup_guard { + my $class = shift; + my @previous_cleanups = @cleanups; + @cleanups = (); + return Scope::Guard->new(sub { + $class->cleanup; + @cleanups = @previous_cleanups; + }); +} + +sub cleanup { + $_->() for @cleanups; + @cleanups = (); +} + +END { + __PACKAGE__->cleanup; +} + +1; + +__END__ + +=head1 NAME + +WebGUI::Upgrade::Script - Functions for WebGUI upgrade scripts + +=head1 SYNOPSIS + + use WebGUI::Upgrade::Script; + report "Performing upgrade..."; + config->set('config/item', 'new value'); + done; + +=head1 DESCRIPTION + +This module exports a number of functions to simplify upgrade scripts. The +WEBGUI_CONFIG, WEBGUI_UPGRADE_VERSION, and WEBGUI_UPGRADE_QUIET variables +will be used to set up the subs. + +In addition to the upgrade subs, it has a number of methods available to +code that is wrapping an upgrade script. + +Some cleanup needs to be done after running an upgrade script. This will +be done on program exit by default, but can also be managed manually with +the methods. + +=head1 EXPORTED SUBROUTINES + +=head2 quiet + +Returns the value of the quiet flag. + +=head2 report ( $message ) + +Outputs $message unless quiet mode has been enabled. + +=head2 done + +Reports that the current step has been completed. + +=head2 config + +Returns the WebGUI::Config object for the site. + +=head2 session + +Returns a session for the site. + +=head2 dbh + +Returns a database handle for the site's database. + +=head2 version_tag ( [ $name ] ) + +If $name is specified, creates a new version tag with that name, +sets it as the active version tag, and returns it + +If $name is not specified, returns the current working version tag, +creating it if needed. + +The actual name of the version tag will automatically include a +note specifying that it is an upgrade version tag. + +=head2 rm_lib ( $module ) + +Deletes the specified Perl module. The module should be specified +as a colon separated name, and it will be removed from all include +paths. + +=head2 collateral + +Returns a Path::Class::Dir object for the upgrade script's collateral +path. The collateral path is the same as the name of the upgrade +script with the extension stripped off. + +=head2 import_package ( $package_file ) + +Imports the specified package from the upgrade script's collateral path. + +=head1 METHODS + +These methods are primarily of interest to someone wrapping an upgrade script. + +=head2 cleanup + +Performs all needed cleanup + +=head2 cleanup_guard + +Returns a guard object that when destroyed will run all of the cleanup +functions that have been added since it was created. + +=cut