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 strict;
|
||||||
use warnings;
|
use warnings;
|
||||||
|
|
||||||
use WebGUI::Upgrade ();
|
use WebGUI::Upgrade::Script ();
|
||||||
use WebGUI::Upgrade::File::wgpkg ();
|
|
||||||
use POSIX ();
|
|
||||||
use Path::Class::Dir ();
|
use Path::Class::Dir ();
|
||||||
use Exporter qw(import);
|
use Try::Tiny;
|
||||||
|
|
||||||
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 namespace::clean;
|
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;
|
my @res;
|
||||||
if (wantarray) {
|
my $err;
|
||||||
@res = _runCode($file, $contents);
|
{
|
||||||
}
|
local *_;
|
||||||
else {
|
my $guard = WebGUI::Upgrade::Script->cleanup_guard;
|
||||||
$res[0] = _runCode($file, $contents);
|
# place this in a specific separate package to prevent namespace
|
||||||
}
|
# pollution and to allow us to clean it up afterward
|
||||||
|
package
|
||||||
my $error = $@;
|
WebGUI::Upgrade::File::pl::script;
|
||||||
if ($session) {
|
# maintain context
|
||||||
require WebGUI::VersionTag;
|
if (wantarray) {
|
||||||
if (WebGUI::VersionTag->getWorking($session, 'nocreate')) {
|
@res = do $file;
|
||||||
version_tag()->commit;
|
|
||||||
}
|
}
|
||||||
$session->var->end;
|
elsif (defined wantarray) {
|
||||||
$session->close;
|
$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]);
|
return (wantarray ? @res : $res[0]);
|
||||||
}
|
}
|
||||||
|
|
||||||
=head2 quiet
|
sub run {
|
||||||
|
my $class = shift;
|
||||||
|
my ($configFile, $version, $file, $quiet) = @_;
|
||||||
|
|
||||||
Returns the value of the quiet flag.
|
local $ENV{WEBGUI_CONFIG} = $configFile;
|
||||||
|
local $ENV{WEBGUI_UPGRADE_VERSION} = $version;
|
||||||
=cut
|
local $ENV{WEBGUI_UPGRADE_QUIET} = $quiet;
|
||||||
|
return _runScript($file);
|
||||||
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);
|
|
||||||
}
|
}
|
||||||
|
|
||||||
1;
|
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