new upgrade stuff
This commit is contained in:
Graham Knop
parent
a26859298c
commit
00b3113031
2 changed files with 305 additions and 223 deletions
|
|
@ -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;
|
||||
|
||||
|
|
|
|||
268
lib/WebGUI/Upgrade/Script.pm
Normal file
268
lib/WebGUI/Upgrade/Script.pm
Normal file
|
|
@ -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
|
||||
Loading…
Add table
Add a link
Reference in a new issue