WebGUI::BackgroundProcess (used now by AssetExport)
This commit is contained in:
Paul Driver
parent
20db0287b4
commit
79de38dc4a
11 changed files with 1309 additions and 43 deletions
|
|
@ -22,7 +22,7 @@ use Getopt::Long;
|
||||||
use WebGUI::Session;
|
use WebGUI::Session;
|
||||||
use WebGUI::Storage;
|
use WebGUI::Storage;
|
||||||
use WebGUI::Asset;
|
use WebGUI::Asset;
|
||||||
|
use List::Util qw(first);
|
||||||
|
|
||||||
my $toVersion = '7.10.2';
|
my $toVersion = '7.10.2';
|
||||||
my $quiet; # this line required
|
my $quiet; # this line required
|
||||||
|
|
@ -31,9 +31,52 @@ my $quiet; # this line required
|
||||||
my $session = start(); # this line required
|
my $session = start(); # this line required
|
||||||
|
|
||||||
# upgrade functions go here
|
# upgrade functions go here
|
||||||
|
addBackgroundProcessTable($session);
|
||||||
|
installBackgroundProcessCleanup($session);
|
||||||
|
|
||||||
finish($session); # this line required
|
finish($session); # this line required
|
||||||
|
|
||||||
|
#----------------------------------------------------------------------------
|
||||||
|
# Creates a new table for tracking background processes
|
||||||
|
sub addBackgroundProcessTable {
|
||||||
|
my $session = shift;
|
||||||
|
my $db = $session->db;
|
||||||
|
my $sth = $db->dbh->table_info('', '', 'BackgroundProcess', 'TABLE');
|
||||||
|
return if ($sth->fetch);
|
||||||
|
print "\tAdding BackgroundProcess table..." unless $quiet;
|
||||||
|
my $sql = q{
|
||||||
|
CREATE TABLE BackgroundProcess (
|
||||||
|
id CHAR(22),
|
||||||
|
groupId CHAR(22),
|
||||||
|
status LONGTEXT,
|
||||||
|
error TEXT,
|
||||||
|
startTime BIGINT(20),
|
||||||
|
endTime BIGINT(20),
|
||||||
|
finished BOOLEAN DEFAULT FALSE,
|
||||||
|
latch BOOLEAN DEFAULT FALSE,
|
||||||
|
|
||||||
|
PRIMARY KEY(id)
|
||||||
|
);
|
||||||
|
};
|
||||||
|
$db->write($sql);
|
||||||
|
print "DONE!\n" unless $quiet;
|
||||||
|
}
|
||||||
|
|
||||||
|
#----------------------------------------------------------------------------
|
||||||
|
# install a workflow to clean up old background processes
|
||||||
|
sub installBackgroundProcessCleanup {
|
||||||
|
my $session = shift;
|
||||||
|
print "\tInstalling Background Process Cleanup workflow..." unless $quiet;
|
||||||
|
my $class = 'WebGUI::Workflow::Activity::RemoveOldBackgroundProcesses';
|
||||||
|
$session->config->addToArray('workflowActivities/None', $class);
|
||||||
|
my $wf = WebGUI::Workflow->new($session, 'pbworkflow000000000001');
|
||||||
|
my $a = first { ref $_ eq $class } @{ $wf->getActivities };
|
||||||
|
unless ($a) {
|
||||||
|
$a = $wf->addActivity($class);
|
||||||
|
$a->set(title => 'Remove Old Background Processes');
|
||||||
|
};
|
||||||
|
print "DONE!\n" unless $quiet;
|
||||||
|
}
|
||||||
|
|
||||||
#----------------------------------------------------------------------------
|
#----------------------------------------------------------------------------
|
||||||
# Describe what our function does
|
# Describe what our function does
|
||||||
|
|
|
||||||
|
|
@ -23,7 +23,7 @@ use WebGUI::Exception;
|
||||||
use WebGUI::Utility ();
|
use WebGUI::Utility ();
|
||||||
use WebGUI::Session;
|
use WebGUI::Session;
|
||||||
use URI::URL;
|
use URI::URL;
|
||||||
use Scope::Guard;
|
use Scope::Guard qw(guard);
|
||||||
|
|
||||||
=head1 NAME
|
=head1 NAME
|
||||||
|
|
||||||
|
|
@ -304,21 +304,53 @@ sub exportAsHtml {
|
||||||
}
|
}
|
||||||
|
|
||||||
sub exportBranch {
|
sub exportBranch {
|
||||||
my $self = shift;
|
my ($self, $options, $reportSession) = @_;
|
||||||
my $options = shift;
|
my $i18n = $reportSession &&
|
||||||
my $reportSession = shift;
|
WebGUI::International->new($self->session, 'Asset');
|
||||||
|
|
||||||
my $depth = $options->{depth};
|
my $depth = $options->{depth};
|
||||||
my $indexFileName = $options->{indexFileName};
|
my $indexFileName = $options->{indexFileName};
|
||||||
my $extrasUploadAction = $options->{extrasUploadAction};
|
my $extrasUploadAction = $options->{extrasUploadAction};
|
||||||
my $rootUrlAction = $options->{rootUrlAction};
|
my $rootUrlAction = $options->{rootUrlAction};
|
||||||
my $exportedCount = 0;
|
my $report = $options->{report};
|
||||||
|
|
||||||
my $i18n;
|
unless ($report) {
|
||||||
if ( $reportSession ) {
|
if ($reportSession) {
|
||||||
$i18n = WebGUI::International->new($self->session, 'Asset');
|
# We got a report session and no report coderef, so we'll print
|
||||||
|
# messages out. NOTE: this is for backcompat, but I'm not sure we
|
||||||
|
# even need it any more. I think the only thing using it was the
|
||||||
|
# old iframe-based export status report. --frodwith
|
||||||
|
my %reports = (
|
||||||
|
'bad user privileges' => sub {
|
||||||
|
my $asset = shift;
|
||||||
|
my $url = $asset->getUrl;
|
||||||
|
$i18n->get('bad user privileges') . "\n$url"
|
||||||
|
},
|
||||||
|
'not exportable' => sub {
|
||||||
|
my $asset = shift;
|
||||||
|
my $fullPath = $asset->exportGetUrlAsPath;
|
||||||
|
"$fullPath skipped, not exportable<br />";
|
||||||
|
},
|
||||||
|
'exporting page' => sub {
|
||||||
|
my $asset = shift;
|
||||||
|
my $fullPath = $asset->exportGetUrlAsPath;
|
||||||
|
sprintf $i18n->get('exporting page'), $fullPath;
|
||||||
|
},
|
||||||
|
'collateral notes' => sub { pop },
|
||||||
|
'done' => sub { $i18n->get('done') },
|
||||||
|
);
|
||||||
|
$report = sub {
|
||||||
|
my ($asset, $key, @args) = @_;
|
||||||
|
my $code = $reports{$key};
|
||||||
|
my $message = $asset->$code();
|
||||||
|
$reportSession->output->print($message, @args);
|
||||||
|
};
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
$report = sub {};
|
||||||
|
}
|
||||||
}
|
}
|
||||||
|
my $exportedCount = 0;
|
||||||
|
|
||||||
my $exportAsset = sub {
|
my $exportAsset = sub {
|
||||||
my ( $assetId ) = @_;
|
my ( $assetId ) = @_;
|
||||||
|
|
@ -335,26 +367,18 @@ sub exportBranch {
|
||||||
|
|
||||||
# skip this asset if we can't view it as this user.
|
# skip this asset if we can't view it as this user.
|
||||||
unless( $asset->canView ) {
|
unless( $asset->canView ) {
|
||||||
if( $reportSession ) {
|
$asset->$report('bad user privileges');
|
||||||
my $message = sprintf( $i18n->get('bad user privileges') . "\n") . $asset->getUrl;
|
|
||||||
$reportSession->output->print($message);
|
|
||||||
}
|
|
||||||
next;
|
next;
|
||||||
}
|
}
|
||||||
|
|
||||||
# skip this asset if it's not exportable.
|
# skip this asset if it's not exportable.
|
||||||
unless ( $asset->exportCheckExportable ) {
|
unless ( $asset->exportCheckExportable ) {
|
||||||
if ( $reportSession ) {
|
$asset->$report('not exportable');
|
||||||
$reportSession->output->print("$fullPath skipped, not exportable<br />");
|
|
||||||
}
|
|
||||||
next;
|
next;
|
||||||
}
|
}
|
||||||
|
|
||||||
# tell the user which asset we're exporting.
|
# tell the user which asset we're exporting.
|
||||||
if ( $reportSession ) {
|
$asset->$report('exporting page');
|
||||||
my $message = sprintf $i18n->get('exporting page'), $fullPath;
|
|
||||||
$reportSession->output->print($message);
|
|
||||||
}
|
|
||||||
|
|
||||||
# try to write the file
|
# try to write the file
|
||||||
eval { $asset->exportWriteFile };
|
eval { $asset->exportWriteFile };
|
||||||
|
|
@ -364,9 +388,25 @@ sub exportBranch {
|
||||||
|
|
||||||
# next, tell the asset that we're exporting, so that it can export any
|
# next, tell the asset that we're exporting, so that it can export any
|
||||||
# of its collateral or other extra data.
|
# of its collateral or other extra data.
|
||||||
eval { $asset->exportAssetCollateral($asset->exportGetUrlAsPath, $options, $reportSession) };
|
{
|
||||||
if($@) {
|
# For backcompat we want to capture anything that
|
||||||
WebGUI::Error->throw(error => "failed to export asset collateral for URL " . $asset->getUrl . ": $@");
|
# exportAssetCollateral may have printed and report it to the
|
||||||
|
# coderef. We should get rid of this as soon as we're ready to
|
||||||
|
# break that api.
|
||||||
|
my $cs = $self->session->duplicate();
|
||||||
|
open my $handle, '>', \my $output;
|
||||||
|
$cs->output->setHandle($handle);
|
||||||
|
my $guard = guard {
|
||||||
|
close $handle;
|
||||||
|
$cs->var->end;
|
||||||
|
$cs->close();
|
||||||
|
$asset->$report('collateral notes', $output);
|
||||||
|
};
|
||||||
|
my $path = $asset->exportGetUrlAsPath;
|
||||||
|
eval { $asset->exportAssetCollateral($path, $options, $cs) };
|
||||||
|
if($@) {
|
||||||
|
WebGUI::Error->throw(error => "failed to export asset collateral for URL " . $asset->getUrl . ": $@");
|
||||||
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
# we exported this one successfully, so count it
|
# we exported this one successfully, so count it
|
||||||
|
|
@ -376,19 +416,12 @@ sub exportBranch {
|
||||||
$self->session->db->write( "UPDATE asset SET lastExportedAs = ? WHERE assetId = ?",
|
$self->session->db->write( "UPDATE asset SET lastExportedAs = ? WHERE assetId = ?",
|
||||||
[ $fullPath, $asset->getId ] );
|
[ $fullPath, $asset->getId ] );
|
||||||
|
|
||||||
$self->updateHistory("exported");
|
$asset->updateHistory('exported');
|
||||||
|
|
||||||
# tell the user we did this asset correctly
|
# tell the user we did this asset correctly
|
||||||
if ( $reportSession ) {
|
$asset->$report('done');
|
||||||
$reportSession->output->print($i18n->get('done'));
|
|
||||||
}
|
|
||||||
|
|
||||||
#use Devel::Cycle;
|
|
||||||
#warn "CHECKING on " . ref( $asset ) . ' ID: ' . $asset->getId . "\n";
|
|
||||||
#find_cycle( $asset );
|
|
||||||
};
|
};
|
||||||
|
|
||||||
|
|
||||||
my $assetIds = $self->exportGetDescendants(undef, $depth);
|
my $assetIds = $self->exportGetDescendants(undef, $depth);
|
||||||
foreach my $assetId ( @{$assetIds} ) {
|
foreach my $assetId ( @{$assetIds} ) {
|
||||||
$exportAsset->( $assetId );
|
$exportAsset->( $assetId );
|
||||||
|
|
@ -625,6 +658,57 @@ sub exportGetUrlAsPath {
|
||||||
|
|
||||||
#-------------------------------------------------------------------
|
#-------------------------------------------------------------------
|
||||||
|
|
||||||
|
=head2 exportInBackground
|
||||||
|
|
||||||
|
Intended to be called by WebGUI::BackgroundProcess. Runs exportAsHtml on the
|
||||||
|
specified asset and keeps a json structure as the status.
|
||||||
|
|
||||||
|
=cut
|
||||||
|
|
||||||
|
sub exportInBackground {
|
||||||
|
my ($process, $args) = @_;
|
||||||
|
my $self = WebGUI::Asset->new($process->session, delete $args->{assetId});
|
||||||
|
$args->{indexFileName} = delete $args->{index};
|
||||||
|
my %flat;
|
||||||
|
|
||||||
|
my $hashify; $hashify = sub {
|
||||||
|
my ($asset, $depth) = @_;
|
||||||
|
return if $depth < 1;
|
||||||
|
my $hash = { url => $asset->getUrl };
|
||||||
|
my $children = $asset->getLineage(['children'], { returnObjects => 1 });
|
||||||
|
$hash->{children} = [ map { $hashify->($_, $depth - 1) } @$children ];
|
||||||
|
$flat{$asset->getId} = $hash;
|
||||||
|
return $hash;
|
||||||
|
};
|
||||||
|
my $tree = $hashify->($self, $args->{depth});
|
||||||
|
my $last = $tree;
|
||||||
|
my %reports = (
|
||||||
|
'bad user privileges' => sub { shift->{badUserPrivileges} = 1 },
|
||||||
|
'not exportable' => sub { shift->{notExportable} = 1 },
|
||||||
|
'exporting page' => sub { shift->{current} = 1 },
|
||||||
|
'done' => sub {
|
||||||
|
my $hash = shift;
|
||||||
|
delete $last->{current};
|
||||||
|
$last = $hash;
|
||||||
|
$hash->{done} = 1;
|
||||||
|
},
|
||||||
|
'collateral notes' => sub {
|
||||||
|
my ($hash, $text) = @_;
|
||||||
|
$hash->{collateralNotes} = $text if $text;
|
||||||
|
},
|
||||||
|
);
|
||||||
|
$args->{report} = sub {
|
||||||
|
my ($asset, $key, @args) = @_;
|
||||||
|
my $code = $reports{$key};
|
||||||
|
my $hash = $flat{$asset->getId};
|
||||||
|
$code->($hash, @args);
|
||||||
|
$process->update(sub { JSON::encode_json($tree) });
|
||||||
|
};
|
||||||
|
$self->exportAsHtml($args);
|
||||||
|
}
|
||||||
|
|
||||||
|
#-------------------------------------------------------------------
|
||||||
|
|
||||||
=head2 exportSymlinkExtrasUploads ( [ session ] )
|
=head2 exportSymlinkExtrasUploads ( [ session ] )
|
||||||
|
|
||||||
Class or object method. Sets up the extras and uploads symlinks.
|
Class or object method. Sets up the extras and uploads symlinks.
|
||||||
|
|
@ -935,16 +1019,24 @@ Displays the export status page
|
||||||
=cut
|
=cut
|
||||||
|
|
||||||
sub www_exportStatus {
|
sub www_exportStatus {
|
||||||
my $self = shift;
|
my $self = shift;
|
||||||
return $self->session->privilege->insufficient() unless ($self->session->user->isInGroup(13));
|
my $session = $self->session;
|
||||||
my $i18n = WebGUI::International->new($self->session, "Asset");
|
return $session->privilege->insufficient
|
||||||
my $iframeUrl = $self->getUrl('func=exportGenerate');
|
unless $session->user->isInGroup(13);
|
||||||
foreach my $formVar (qw/index depth userId extrasUploadsAction rootUrlAction exportUrl/) {
|
my $form = $session->form;
|
||||||
$iframeUrl = $self->session->url->append($iframeUrl, $formVar . '=' . $self->session->form->process($formVar));
|
my @vars = qw(
|
||||||
}
|
index depth userId extrasUploadsAction rootUrlAction exportUrl
|
||||||
|
);
|
||||||
my $output = '<iframe src="' . $iframeUrl . '" title="' . $i18n->get('Page Export Status') . '" width="100%" height="500"></iframe>';
|
my $process = WebGUI::BackgroundProcess->start(
|
||||||
$self->getAdminConsole->render($output, $i18n->get('Page Export Status'), "Asset");
|
$session, 'WebGUI::Asset', 'exportInBackground', {
|
||||||
|
assetId => $self->getId,
|
||||||
|
map { $_ => scalar $form->get($_) } @vars
|
||||||
|
}
|
||||||
|
);
|
||||||
|
$process->setGroup(13);
|
||||||
|
my $pairs = $process->contentPairs('AssetExport');
|
||||||
|
$session->http->setRedirect($self->getUrl($pairs));
|
||||||
|
return 'redirect';
|
||||||
}
|
}
|
||||||
|
|
||||||
#-------------------------------------------------------------------
|
#-------------------------------------------------------------------
|
||||||
|
|
|
||||||
590
lib/WebGUI/BackgroundProcess.pm
Normal file
590
lib/WebGUI/BackgroundProcess.pm
Normal file
|
|
@ -0,0 +1,590 @@
|
||||||
|
package WebGUI::BackgroundProcess;
|
||||||
|
|
||||||
|
use warnings;
|
||||||
|
use strict;
|
||||||
|
|
||||||
|
use Config;
|
||||||
|
use POSIX;
|
||||||
|
use WebGUI::Session;
|
||||||
|
use WebGUI::Pluggable;
|
||||||
|
use JSON;
|
||||||
|
use Getopt::Long qw(GetOptionsFromArray);
|
||||||
|
use Time::HiRes qw(sleep);
|
||||||
|
|
||||||
|
=head1 NAME
|
||||||
|
|
||||||
|
WebGUI::BackgroundProcess
|
||||||
|
|
||||||
|
=head1 DESCRIPTION
|
||||||
|
|
||||||
|
Safely and portably spawn a long running process that you can check the
|
||||||
|
status of.
|
||||||
|
|
||||||
|
=head1 SYNOPSIS
|
||||||
|
|
||||||
|
package WebGUI::Some::Class;
|
||||||
|
|
||||||
|
sub doWork {
|
||||||
|
my ($process, $data) = @_;
|
||||||
|
$process->update("Starting...");
|
||||||
|
...
|
||||||
|
$process->update("About half way done...");
|
||||||
|
...
|
||||||
|
$process->update("Finished!");
|
||||||
|
}
|
||||||
|
|
||||||
|
sub www_doWork {
|
||||||
|
my $self = shift;
|
||||||
|
my $session = $self->session;
|
||||||
|
my $process = WebGUI::BackgroundProcess->start(
|
||||||
|
$session, 'WebGUI::Some::Class', 'doWork', { some => 'data' }
|
||||||
|
);
|
||||||
|
# See WebGUI::Content::BackgroundProcess
|
||||||
|
my $pairs = $process->contentPairs('DoWork');
|
||||||
|
$session->http->setRedirect($self->getUrl($pairs));
|
||||||
|
return 'redirect';
|
||||||
|
}
|
||||||
|
|
||||||
|
package WebGUI::Content::BackgroundProcess::DoWork;
|
||||||
|
|
||||||
|
sub handler {
|
||||||
|
my $process = shift;
|
||||||
|
my $session = $process->session;
|
||||||
|
return $session->style->userStyle($process->status);
|
||||||
|
|
||||||
|
# or better yet, an ajaxy page that polls.
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
=head1 LEGAL
|
||||||
|
|
||||||
|
-------------------------------------------------------------------
|
||||||
|
WebGUI is Copyright 2001-2009 Plain Black Corporation.
|
||||||
|
-------------------------------------------------------------------
|
||||||
|
Please read the legal notices (docs/legal.txt) and the license
|
||||||
|
(docs/license.txt) that came with this distribution before using
|
||||||
|
this software.
|
||||||
|
-------------------------------------------------------------------
|
||||||
|
http://www.plainblack.com info@plainblack.com
|
||||||
|
-------------------------------------------------------------------
|
||||||
|
|
||||||
|
=head1 METHODS
|
||||||
|
|
||||||
|
=cut
|
||||||
|
|
||||||
|
#-----------------------------------------------------------------
|
||||||
|
|
||||||
|
=head2 argv ($module, $subname, $data)
|
||||||
|
|
||||||
|
Produces an argv suitable for passing to exec (after the initial executable
|
||||||
|
name and perl switches) for running the given user routine with the supplied
|
||||||
|
data.
|
||||||
|
|
||||||
|
=cut
|
||||||
|
|
||||||
|
sub argv {
|
||||||
|
my ( $self, $module, $subname, $data ) = @_;
|
||||||
|
my $class = ref $self;
|
||||||
|
my $session = $self->session;
|
||||||
|
my $config = $session->config;
|
||||||
|
my $id = $self->getId;
|
||||||
|
return (
|
||||||
|
'--webguiRoot' => $config->getWebguiRoot,
|
||||||
|
'--configFile' => $config->getFilename,
|
||||||
|
'--sessionId' => $session->getId,
|
||||||
|
'--module' => $module,
|
||||||
|
'--subname' => $subname,
|
||||||
|
'--id' => $self->getId,
|
||||||
|
'--data' => JSON::encode_json($data),
|
||||||
|
);
|
||||||
|
} ## end sub argv
|
||||||
|
|
||||||
|
#-----------------------------------------------------------------
|
||||||
|
|
||||||
|
=head2 argvToHash ($argv)
|
||||||
|
|
||||||
|
Class method. Processes the passed array with GetOptions -- intended for use
|
||||||
|
from the exec() in start. Don't call unless you know what you're doing.
|
||||||
|
|
||||||
|
=cut
|
||||||
|
|
||||||
|
sub argvToHash {
|
||||||
|
my ( $class, $argv ) = @_;
|
||||||
|
my $hash = {};
|
||||||
|
GetOptionsFromArray( $argv, $hash,
|
||||||
|
'webguiRoot=s',
|
||||||
|
'configFile=s',
|
||||||
|
'sessionId=s',
|
||||||
|
'module=s',
|
||||||
|
'subname=s',
|
||||||
|
'id=s',
|
||||||
|
'data=s'
|
||||||
|
);
|
||||||
|
$hash->{data} = JSON::decode_json( $hash->{data} );
|
||||||
|
return $hash;
|
||||||
|
}
|
||||||
|
|
||||||
|
#-----------------------------------------------------------------
|
||||||
|
|
||||||
|
=head2 canView ($user?)
|
||||||
|
|
||||||
|
Returns whether the current user (or the user passed in, if there is one) has
|
||||||
|
permission to view the status of the background process. By default, only
|
||||||
|
admins can view, but see setGroup.
|
||||||
|
|
||||||
|
=cut
|
||||||
|
|
||||||
|
sub canView {
|
||||||
|
my $self = shift;
|
||||||
|
my $session = $self->session;
|
||||||
|
my $user = shift || $session->user;
|
||||||
|
$user = WebGUI::User->new( $session, $user )
|
||||||
|
unless eval { $user->isa('WebGUI::User') };
|
||||||
|
return 1 if $user->isAdmin;
|
||||||
|
my $group = $self->get('groupId');
|
||||||
|
return $group && $user->isInGroup($group);
|
||||||
|
}
|
||||||
|
|
||||||
|
#-------------------------------------------------------------------
|
||||||
|
|
||||||
|
=head2 contentPairs ($module, $pid)
|
||||||
|
|
||||||
|
Returns a bit of query string useful for redirecting to a
|
||||||
|
WebGUI::Content::BackgroundProcess plugin. $module should be the bit that
|
||||||
|
comes after WebGUI::Content::BackgroundProcess, e.g.
|
||||||
|
$process->contentPairs('Foo') should return something like
|
||||||
|
"op=background;module=Foo;pid=adlfjafo87ad9f78a7", which will get dispatched
|
||||||
|
to WebGUI::Content::BackgroundProcess::Foo::handler($process)
|
||||||
|
|
||||||
|
=cut
|
||||||
|
|
||||||
|
sub contentPairs {
|
||||||
|
my ( $self, $module ) = @_;
|
||||||
|
my $pid = $self->getId;
|
||||||
|
return "op=background;module=$module;pid=$pid";
|
||||||
|
}
|
||||||
|
|
||||||
|
#-----------------------------------------------------------------
|
||||||
|
|
||||||
|
=head2 create ( )
|
||||||
|
|
||||||
|
Creates a new BackgroundProcess object and inserts a blank row of data into
|
||||||
|
the db. You probably shouldn't call this -- see start().
|
||||||
|
|
||||||
|
=cut
|
||||||
|
|
||||||
|
sub create {
|
||||||
|
my ( $class, $session ) = @_;
|
||||||
|
my $id = $session->id->generate;
|
||||||
|
$session->db->setRow( $class->tableName, 'id', {}, $id );
|
||||||
|
bless { session => $session, id => $id };
|
||||||
|
}
|
||||||
|
|
||||||
|
#-----------------------------------------------------------------
|
||||||
|
|
||||||
|
=head2 delete ( )
|
||||||
|
|
||||||
|
Clean up the information for this process from the database.
|
||||||
|
|
||||||
|
=cut
|
||||||
|
|
||||||
|
sub delete {
|
||||||
|
my $self = shift;
|
||||||
|
my $db = $self->session->db;
|
||||||
|
my $tbl = $db->dbh->quote_identifier( $self->tableName );
|
||||||
|
$db->write( "DELETE FROM $tbl WHERE id = ?", [ $self->getId ] );
|
||||||
|
}
|
||||||
|
|
||||||
|
#-----------------------------------------------------------------
|
||||||
|
|
||||||
|
=head2 endTime ( )
|
||||||
|
|
||||||
|
Returns the epoch time indicating when the subroutine passed to run() finished
|
||||||
|
executing, or undef if it hasn't finished. Note that even if the sub passed
|
||||||
|
to run dies, an endTime will be recorded.
|
||||||
|
|
||||||
|
=cut
|
||||||
|
|
||||||
|
sub endTime { $_[0]->get('endTime') }
|
||||||
|
|
||||||
|
#-----------------------------------------------------------------
|
||||||
|
|
||||||
|
=head2 error ( $msg )
|
||||||
|
|
||||||
|
Call this to record an error status. You probably shouldn't, though -- just
|
||||||
|
dying from your subroutine will cause this to be set.
|
||||||
|
|
||||||
|
=cut
|
||||||
|
|
||||||
|
sub error { $_[0]->set( { error => $_[1] } ) }
|
||||||
|
|
||||||
|
#-----------------------------------------------------------------
|
||||||
|
|
||||||
|
=head2 finish ( )
|
||||||
|
|
||||||
|
Mark the process as being finished. This is called for you when your
|
||||||
|
subroutine is finished. If update() wasn't computed on the last call, it will
|
||||||
|
be computed now.
|
||||||
|
|
||||||
|
=cut
|
||||||
|
|
||||||
|
sub finish {
|
||||||
|
my $self = shift;
|
||||||
|
my %props = ( finished => 1 );
|
||||||
|
if ( my $calc = delete $self->{delay} ) {
|
||||||
|
$props{status} = $calc->();
|
||||||
|
$props{latch} = 0;
|
||||||
|
}
|
||||||
|
$props{endTime} = time();
|
||||||
|
$self->set( \%props );
|
||||||
|
}
|
||||||
|
|
||||||
|
#-----------------------------------------------------------------
|
||||||
|
|
||||||
|
=head2 get ( @keys )
|
||||||
|
|
||||||
|
Get data from the database record for this process (returned as a simple list,
|
||||||
|
not an arrayref). Valid keys are: id, status, error, startTime, endTime,
|
||||||
|
finished, groupId. They all have more specific accessors, but you can use
|
||||||
|
this to get several at once.
|
||||||
|
|
||||||
|
=cut
|
||||||
|
|
||||||
|
sub get {
|
||||||
|
my ( $self, @keys ) = @_;
|
||||||
|
my $db = $self->session->db;
|
||||||
|
my $dbh = $db->dbh;
|
||||||
|
my $tbl = $dbh->quote_identifier( $self->tableName );
|
||||||
|
my $key
|
||||||
|
= @keys
|
||||||
|
? join( ',', map { $dbh->quote_identifier($_) } @keys )
|
||||||
|
: '*';
|
||||||
|
my $id = $dbh->quote( $self->getId );
|
||||||
|
my @values = $db->quickArray("SELECT $key FROM $tbl WHERE id = $id");
|
||||||
|
return wantarray ? @values : $values[0];
|
||||||
|
}
|
||||||
|
|
||||||
|
#-----------------------------------------------------------------
|
||||||
|
|
||||||
|
=head2 getError ( )
|
||||||
|
|
||||||
|
If the process died, this will be set to stringified $@.
|
||||||
|
|
||||||
|
=cut
|
||||||
|
|
||||||
|
sub getError { $_[0]->get('error') }
|
||||||
|
|
||||||
|
#-----------------------------------------------------------------
|
||||||
|
|
||||||
|
=head2 getGroupId
|
||||||
|
|
||||||
|
Returns the group ID (not the actual WebGUI::Group) of users who are allowed
|
||||||
|
to view this process.
|
||||||
|
|
||||||
|
=cut
|
||||||
|
|
||||||
|
sub getGroupId {
|
||||||
|
my $id = $_[0]->get('groupId');
|
||||||
|
return $id || 3;
|
||||||
|
}
|
||||||
|
|
||||||
|
#-----------------------------------------------------------------
|
||||||
|
|
||||||
|
=head2 getId ( )
|
||||||
|
|
||||||
|
The unique id for this background process. Note: this is NOT the pid, but a
|
||||||
|
WebGUI guid.
|
||||||
|
|
||||||
|
=cut
|
||||||
|
|
||||||
|
sub getId { shift->{id} }
|
||||||
|
|
||||||
|
#-----------------------------------------------------------------
|
||||||
|
|
||||||
|
=head2 getStatus()
|
||||||
|
|
||||||
|
Signals the background process that it should report its next status, then
|
||||||
|
polls at $interval (can be fractional) seconds (default: .1) waiting for the
|
||||||
|
background process to claim that its status has been updated. Returns the
|
||||||
|
updated status. See setWait() for a way to change the interval (or disable
|
||||||
|
the waiting procedure entirely).
|
||||||
|
|
||||||
|
=cut
|
||||||
|
|
||||||
|
sub getStatus {
|
||||||
|
my $self = shift;
|
||||||
|
my $interval = $self->{interval};
|
||||||
|
if ($interval) {
|
||||||
|
$self->set( { latch => 1 } );
|
||||||
|
while (1) {
|
||||||
|
sleep $interval;
|
||||||
|
my ( $finished, $latch ) = $self->get( 'finished', 'latch' );
|
||||||
|
last if $finished || !$latch;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
return $self->get('status');
|
||||||
|
}
|
||||||
|
|
||||||
|
#-----------------------------------------------------------------
|
||||||
|
|
||||||
|
=head2 isFinished ( )
|
||||||
|
|
||||||
|
A simple flag indicating that background process is no longer running.
|
||||||
|
|
||||||
|
=cut
|
||||||
|
|
||||||
|
sub isFinished { $_[0]->get('finished') }
|
||||||
|
|
||||||
|
#-----------------------------------------------------------------
|
||||||
|
|
||||||
|
=head2 new ( $session, $id )
|
||||||
|
|
||||||
|
Returns an object capable of checking on the status of the background process
|
||||||
|
indicated by $id. Returns undef if there is no such process.
|
||||||
|
|
||||||
|
=cut
|
||||||
|
|
||||||
|
sub new {
|
||||||
|
my ( $class, $session, $id ) = @_;
|
||||||
|
my $db = $session->db;
|
||||||
|
my $tbl = $db->dbh->quote_identifier( $class->tableName );
|
||||||
|
my $sql = "SELECT COUNT(*) FROM $tbl WHERE id = ?";
|
||||||
|
my $exists = $db->quickScalar( $sql, [$id] );
|
||||||
|
return $exists
|
||||||
|
? bless( { session => $session, id => $id, interval => .1 }, $class )
|
||||||
|
: undef;
|
||||||
|
}
|
||||||
|
|
||||||
|
#-----------------------------------------------------------------
|
||||||
|
|
||||||
|
=head2 session ()
|
||||||
|
|
||||||
|
Get the WebGUI::Session this process was created with. Note: this is safe to
|
||||||
|
call in the child process, as it is a duplicated session (same session id) and
|
||||||
|
doesn't share any handles with the parent process.
|
||||||
|
|
||||||
|
=cut
|
||||||
|
|
||||||
|
sub session { $_[0]->{session} }
|
||||||
|
|
||||||
|
#-----------------------------------------------------------------
|
||||||
|
|
||||||
|
=head2 set ($properties)
|
||||||
|
|
||||||
|
Updates the database row with the properties given by the $properties hashref.
|
||||||
|
See get() for a list of valid keys.
|
||||||
|
|
||||||
|
=cut
|
||||||
|
|
||||||
|
sub set {
|
||||||
|
my ( $self, $values ) = @_;
|
||||||
|
my @keys = keys %$values;
|
||||||
|
return unless @keys;
|
||||||
|
|
||||||
|
my $db = $self->session->db;
|
||||||
|
my $dbh = $db->dbh;
|
||||||
|
my $tbl = $dbh->quote_identifier( $self->tableName );
|
||||||
|
my $sets = join(
|
||||||
|
',',
|
||||||
|
map {
|
||||||
|
my $ident = $dbh->quote_identifier($_);
|
||||||
|
my $value = $dbh->quote( $values->{$_} );
|
||||||
|
"$ident = $value";
|
||||||
|
} @keys
|
||||||
|
);
|
||||||
|
|
||||||
|
my $id = $dbh->quote( $self->getId );
|
||||||
|
$db->write("UPDATE $tbl SET $sets WHERE id = $id");
|
||||||
|
} ## end sub set
|
||||||
|
|
||||||
|
#-----------------------------------------------------------------
|
||||||
|
|
||||||
|
=head2 setGroup($groupId)
|
||||||
|
|
||||||
|
Allow the given group (in addition to admins) the ability to check on the
|
||||||
|
status of this process
|
||||||
|
|
||||||
|
=cut
|
||||||
|
|
||||||
|
sub setGroup {
|
||||||
|
my ( $self, $groupId ) = @_;
|
||||||
|
$groupId = eval { $groupId->getId } || $groupId;
|
||||||
|
$self->set( { groupId => $groupId } );
|
||||||
|
}
|
||||||
|
|
||||||
|
#-----------------------------------------------------------------
|
||||||
|
|
||||||
|
=head2 runCmd ($hashref)
|
||||||
|
|
||||||
|
Class method. Processes ARGV and passes it to runFromHash. Don't call this
|
||||||
|
unless you're the start() method.
|
||||||
|
|
||||||
|
=cut
|
||||||
|
|
||||||
|
sub runCmd {
|
||||||
|
my $class = shift;
|
||||||
|
$class->runFromHash( $class->argvToHash( \@ARGV ) );
|
||||||
|
}
|
||||||
|
|
||||||
|
#-----------------------------------------------------------------
|
||||||
|
|
||||||
|
=head2 runFromHash ($hashref)
|
||||||
|
|
||||||
|
Class method. Expects a hash of arguments describing what to run. Don't call
|
||||||
|
this unless you know what you're doing.
|
||||||
|
|
||||||
|
=cut
|
||||||
|
|
||||||
|
sub runFromHash {
|
||||||
|
my ( $class, $args ) = @_;
|
||||||
|
my $module = $args->{module};
|
||||||
|
WebGUI::Pluggable::load($module);
|
||||||
|
my $code = $module->can( $args->{subname} );
|
||||||
|
my $session = WebGUI::Session->open( $args->{webguiRoot}, $args->{configFile}, undef, undef, $args->{sessionId} );
|
||||||
|
|
||||||
|
my $self = $class->new( $session, $args->{id} );
|
||||||
|
$self->set( { startTime => time } );
|
||||||
|
eval { $self->$code( $args->{data} ) };
|
||||||
|
$self->error($@) if $@;
|
||||||
|
$self->finish();
|
||||||
|
}
|
||||||
|
|
||||||
|
#-----------------------------------------------------------------
|
||||||
|
|
||||||
|
=head2 setWait ( $interval )
|
||||||
|
|
||||||
|
Use this to control the pace at which getStatus will poll for updated
|
||||||
|
statuses. By default, this is a tenth of a second. If you set it to 0,
|
||||||
|
getStatus will still signal the background process for an update, but will
|
||||||
|
take whatever is currently recorded as the status and return immediately.
|
||||||
|
|
||||||
|
=cut
|
||||||
|
|
||||||
|
sub setWait { $_[0]->{interval} = $_[1] }
|
||||||
|
|
||||||
|
#-----------------------------------------------------------------
|
||||||
|
|
||||||
|
=head2 start ( $session, $module, $subname, $data )
|
||||||
|
|
||||||
|
Class method. The first thing this method does is daemonize (double-fork,
|
||||||
|
setsid, chdir /, umask 0, all that good stuff). It then executes
|
||||||
|
$module::subname in a fresh perl interpreter (exec'd $^X) with ($process,
|
||||||
|
$data) as its arguments. The only restriction on $data is that it be
|
||||||
|
serializable by JSON.
|
||||||
|
|
||||||
|
=head3 $0
|
||||||
|
|
||||||
|
The process name (as it appears in ps) will be set to webgui-background-$id,
|
||||||
|
where $id is the value returned by $process->getId. It thus won't look like a
|
||||||
|
modperl process to anyone monitoring the process table (wremonitor.pl, for
|
||||||
|
example).
|
||||||
|
|
||||||
|
=cut
|
||||||
|
|
||||||
|
sub start {
|
||||||
|
my ( $class, $session, $module, $subname, $data ) = @_;
|
||||||
|
my $self = $class->create($session);
|
||||||
|
my $id = $self->getId;
|
||||||
|
|
||||||
|
my $pid = fork();
|
||||||
|
die "Cannot fork: $!" unless defined $pid;
|
||||||
|
if ($pid) {
|
||||||
|
|
||||||
|
# The child process will fork again and exit immediately, so we can
|
||||||
|
# wait for it (and thus not have zombie processes).
|
||||||
|
waitpid( $pid, 0 );
|
||||||
|
|
||||||
|
return $self;
|
||||||
|
}
|
||||||
|
|
||||||
|
# We don't want destructors called, so POSIX exit on errors.
|
||||||
|
eval {
|
||||||
|
|
||||||
|
# detach from controlling terminal, get us into a new process group
|
||||||
|
die "Cannot become session leader: $!" if POSIX::setsid() < 0;
|
||||||
|
|
||||||
|
# Fork again so we never get a controlling terminal
|
||||||
|
$pid = fork();
|
||||||
|
die "Child cannot fork: $!" unless defined $pid;
|
||||||
|
|
||||||
|
# We don't want to call any destructors, as it would mess with the
|
||||||
|
# parent's mysql connection, etc.
|
||||||
|
POSIX::_exit(0) if $pid;
|
||||||
|
|
||||||
|
# We're now in the final target process. Standard daemon-y things...
|
||||||
|
$SIG{HUP} = 'IGNORE';
|
||||||
|
chdir '/';
|
||||||
|
umask 0;
|
||||||
|
|
||||||
|
# Forcibly close any open file descriptors that remain
|
||||||
|
my $max = POSIX::sysconf(&POSIX::_SC_OPEN_MAX) || 1024;
|
||||||
|
POSIX::close($_) for ( 0 .. $max );
|
||||||
|
|
||||||
|
# Get us some reasonable STD handles
|
||||||
|
my $null = '/dev/null';
|
||||||
|
open STDIN, '<', $null or die "Cannot read $null: $!";
|
||||||
|
open STDOUT, '>', $null or die "Cannot write $null: $!";
|
||||||
|
open STDERR, '>', $null or die "Cannot write $null: $!";
|
||||||
|
|
||||||
|
# Now we're ready to run the user's code.
|
||||||
|
my $perl = $Config{perlpath};
|
||||||
|
exec {$perl} (
|
||||||
|
"webgui-background-$id",
|
||||||
|
( map {"-I$_"} @INC ),
|
||||||
|
"-M$class", "-e$class->runCmd();",
|
||||||
|
'--', $self->argv( $module, $subname, $data )
|
||||||
|
) or POSIX::_exit(-1);
|
||||||
|
};
|
||||||
|
POSIX::_exit(-1) if ($@);
|
||||||
|
} ## end sub start
|
||||||
|
|
||||||
|
#-----------------------------------------------------------------
|
||||||
|
|
||||||
|
=head2 startTime ( )
|
||||||
|
|
||||||
|
Returns the time this process started running in epoch format.
|
||||||
|
|
||||||
|
=cut
|
||||||
|
|
||||||
|
sub startTime { $_[0]->get('startTime') }
|
||||||
|
|
||||||
|
#-----------------------------------------------------------------
|
||||||
|
|
||||||
|
=head2 tableName ( )
|
||||||
|
|
||||||
|
Class method: a constant, for convenience. The name of the table that process
|
||||||
|
data is stored in.
|
||||||
|
|
||||||
|
=cut
|
||||||
|
|
||||||
|
sub tableName {'BackgroundProcess'}
|
||||||
|
|
||||||
|
#-----------------------------------------------------------------
|
||||||
|
|
||||||
|
=head2 update ( $msg )
|
||||||
|
|
||||||
|
Set a new status for the background process. This can be anything, and will
|
||||||
|
overwrite the old status. JSON is recommended for complex statuses.
|
||||||
|
Optionally, $msg can be a subroutine that returns the new status -- if your
|
||||||
|
status may take a long time to compute, you should use this, as you may be
|
||||||
|
able to avoid computing some (or all) of your status updates, depending on how
|
||||||
|
often they're being asked for. See the getStatus method for details.
|
||||||
|
|
||||||
|
=cut
|
||||||
|
|
||||||
|
sub update {
|
||||||
|
my ( $self, $msg ) = @_;
|
||||||
|
if ( ref $msg eq 'CODE' ) {
|
||||||
|
if ( $self->get('latch') ) {
|
||||||
|
$msg = $msg->();
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
$self->{delay} = $msg;
|
||||||
|
return;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
delete $self->{delay};
|
||||||
|
$self->set( { latch => 0, status => $msg } );
|
||||||
|
}
|
||||||
|
|
||||||
|
1;
|
||||||
173
lib/WebGUI/BackgroundProcess/AssetExport.pm
Normal file
173
lib/WebGUI/BackgroundProcess/AssetExport.pm
Normal file
|
|
@ -0,0 +1,173 @@
|
||||||
|
package WebGUI::BackgroundProcess::AssetExport;
|
||||||
|
|
||||||
|
=head1 LEGAL
|
||||||
|
|
||||||
|
-------------------------------------------------------------------
|
||||||
|
WebGUI is Copyright 2001-2009 Plain Black Corporation.
|
||||||
|
-------------------------------------------------------------------
|
||||||
|
Please read the legal notices (docs/legal.txt) and the license
|
||||||
|
(docs/license.txt) that came with this distribution before using
|
||||||
|
this software.
|
||||||
|
-------------------------------------------------------------------
|
||||||
|
http://www.plainblack.com info@plainblack.com
|
||||||
|
-------------------------------------------------------------------
|
||||||
|
|
||||||
|
=cut
|
||||||
|
|
||||||
|
use strict;
|
||||||
|
use warnings;
|
||||||
|
|
||||||
|
=head1 NAME
|
||||||
|
|
||||||
|
WebGUI::BackgroundProcess::AssetExport
|
||||||
|
|
||||||
|
=head1 DESCRIPTION
|
||||||
|
|
||||||
|
Renders an admin console page that polls ::Status to draw a friendly graphical
|
||||||
|
representation of how an export is coming along.
|
||||||
|
|
||||||
|
=head1 SUBROUTINES
|
||||||
|
|
||||||
|
These subroutines are available from this package:
|
||||||
|
|
||||||
|
=cut
|
||||||
|
|
||||||
|
use Template;
|
||||||
|
|
||||||
|
my $template = <<'TEMPLATE';
|
||||||
|
<p>
|
||||||
|
Currently exporting <span id='current'></span>
|
||||||
|
(<span id='finished'></span>/<span id='total'></span>).<br />
|
||||||
|
<span id='elapsed'></span> seconds elapsed.
|
||||||
|
</p>
|
||||||
|
<ul id='tree'></ul>
|
||||||
|
[% MACRO yui(file) BLOCK %]
|
||||||
|
<script src="$extras/yui/build/$file"></script>
|
||||||
|
[% END %]
|
||||||
|
[% yui("yahoo/yahoo-min.js") %]
|
||||||
|
[% yui("json/json-min.js") %]
|
||||||
|
[% yui("event/event-min.js") %]
|
||||||
|
[% yui("connection/connection_core-min.js") %]
|
||||||
|
<script>
|
||||||
|
(function (statusUrl) {
|
||||||
|
var JSON = YAHOO.lang.JSON;
|
||||||
|
function error(msg) {
|
||||||
|
alert(msg);
|
||||||
|
}
|
||||||
|
function draw(data) {
|
||||||
|
var ul, old, finished = 0, total = 0, current;
|
||||||
|
function recurse(asset, node) {
|
||||||
|
var li = document.createElement('li'), txt, notes, ul, i;
|
||||||
|
|
||||||
|
total += 1;
|
||||||
|
|
||||||
|
txt = asset.url;
|
||||||
|
if (asset.current) {
|
||||||
|
li.className += 'current';
|
||||||
|
current = asset.url;
|
||||||
|
}
|
||||||
|
else if (asset.badUserPrivileges) {
|
||||||
|
li.className = 'error';
|
||||||
|
txt += ' (bad user privileges)';
|
||||||
|
finished += 1;
|
||||||
|
}
|
||||||
|
else if (asset.notExportable) {
|
||||||
|
li.className = 'error';
|
||||||
|
txt += ' (not exportable)';
|
||||||
|
finished += 1;
|
||||||
|
}
|
||||||
|
else if (asset.done) {
|
||||||
|
li.className = 'done';
|
||||||
|
finished += 1;
|
||||||
|
}
|
||||||
|
li.appendChild(document.createTextNode(txt));
|
||||||
|
if (asset.collateralNotes) {
|
||||||
|
notes = document.createElement('p');
|
||||||
|
notes.innerHTML = asset.collateralNotes;
|
||||||
|
li.appendChild(notes);
|
||||||
|
}
|
||||||
|
if (asset.children) {
|
||||||
|
ul = document.createElement('ul');
|
||||||
|
for (i = 0; i < asset.children.length; i += 1) {
|
||||||
|
recurse(asset.children[i], ul);
|
||||||
|
li.appendChild(ul);
|
||||||
|
}
|
||||||
|
}
|
||||||
|
node.appendChild(li);
|
||||||
|
}
|
||||||
|
ul = document.createElement('ul');
|
||||||
|
old = document.getElementById('tree');
|
||||||
|
ul.id = old.id;
|
||||||
|
recurse(JSON.parse(data.status), ul);
|
||||||
|
old.parentNode.replaceChild(ul, old);
|
||||||
|
document.getElementById('total').innerHTML = total;
|
||||||
|
document.getElementById('finished').innerHTML = finished;
|
||||||
|
document.getElementById('current').innerHTML = current || 'nothing';
|
||||||
|
document.getElementById('elapsed').innerHTML = data.elapsed;
|
||||||
|
}
|
||||||
|
function fetch() {
|
||||||
|
var callback = {
|
||||||
|
success: function (o) {
|
||||||
|
var data, status;
|
||||||
|
if (o.status != 200) {
|
||||||
|
error("Server returned bad response");
|
||||||
|
return;
|
||||||
|
}
|
||||||
|
data = JSON.parse(o.responseText);
|
||||||
|
if (data.error) {
|
||||||
|
error(data.error);
|
||||||
|
}
|
||||||
|
else if (data.finished) {
|
||||||
|
draw(data);
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
draw(data);
|
||||||
|
setTimeout(fetch, 1000);
|
||||||
|
}
|
||||||
|
},
|
||||||
|
failure: function (o) {
|
||||||
|
error("Could not communicate with server");
|
||||||
|
}
|
||||||
|
};
|
||||||
|
YAHOO.util.Connect.asyncRequest('GET', statusUrl, callback, null);
|
||||||
|
}
|
||||||
|
YAHOO.util.Event.onDOMReady(fetch);
|
||||||
|
}("$statusUrl"));
|
||||||
|
</script>
|
||||||
|
TEMPLATE
|
||||||
|
|
||||||
|
my $stylesheet = <<'STYLESHEET';
|
||||||
|
<style>
|
||||||
|
#tree li { color: black }
|
||||||
|
#tree li.current { color: cyan }
|
||||||
|
#tree li.error { color: red }
|
||||||
|
#tree li.done { color: green }
|
||||||
|
</style>
|
||||||
|
STYLESHEET
|
||||||
|
|
||||||
|
#-------------------------------------------------------------------
|
||||||
|
|
||||||
|
=head2 handler ( process )
|
||||||
|
|
||||||
|
See WebGUI::Operation::BackgroundProcess.
|
||||||
|
|
||||||
|
=cut
|
||||||
|
|
||||||
|
sub handler {
|
||||||
|
my $process = shift;
|
||||||
|
my $session = $process->session;
|
||||||
|
my $url = $session->url;
|
||||||
|
my $tt = Template->new( { INTERPOLATE => 1 } );
|
||||||
|
my %vars = (
|
||||||
|
statusUrl => $url->page( $process->contentPairs('Status') ),
|
||||||
|
extras => $session->url->extras,
|
||||||
|
);
|
||||||
|
$tt->process( \$template, \%vars, \my $content ) or die $tt->error;
|
||||||
|
|
||||||
|
my $console = WebGUI::AdminConsole->new( $process->session, 'assets' );
|
||||||
|
$session->style->setRawHeadTags($stylesheet);
|
||||||
|
my $i18n = WebGUI::International->new( $session, 'Asset' );
|
||||||
|
return $console->render( $content, $i18n->get('Page Export Status') );
|
||||||
|
} ## end sub handler
|
||||||
|
|
||||||
|
1;
|
||||||
84
lib/WebGUI/BackgroundProcess/Status.pm
Normal file
84
lib/WebGUI/BackgroundProcess/Status.pm
Normal file
|
|
@ -0,0 +1,84 @@
|
||||||
|
package WebGUI::BackgroundProcess::Status;
|
||||||
|
|
||||||
|
use JSON;
|
||||||
|
|
||||||
|
=head1 LEGAL
|
||||||
|
|
||||||
|
-------------------------------------------------------------------
|
||||||
|
WebGUI is Copyright 2001-2009 Plain Black Corporation.
|
||||||
|
-------------------------------------------------------------------
|
||||||
|
Please read the legal notices (docs/legal.txt) and the license
|
||||||
|
(docs/license.txt) that came with this distribution before using
|
||||||
|
this software.
|
||||||
|
-------------------------------------------------------------------
|
||||||
|
http://www.plainblack.com info@plainblack.com
|
||||||
|
-------------------------------------------------------------------
|
||||||
|
|
||||||
|
=cut
|
||||||
|
|
||||||
|
use strict;
|
||||||
|
use warnings;
|
||||||
|
|
||||||
|
=head1 NAME
|
||||||
|
|
||||||
|
WebGUI::BackgroundProcess::Status
|
||||||
|
|
||||||
|
=head1 DESCRIPTION
|
||||||
|
|
||||||
|
Returns a json response of the following form:
|
||||||
|
|
||||||
|
{
|
||||||
|
"finished" : true,
|
||||||
|
"elapsed" : 10,
|
||||||
|
"status" : "whatever is in the status field. Could be anything.",
|
||||||
|
"error" : "whatever is in the error field"
|
||||||
|
}
|
||||||
|
|
||||||
|
Note that if your status is JSON, you'll have to decode that seperately, so
|
||||||
|
something like:
|
||||||
|
|
||||||
|
decoded = JSON.parse(r.responseText);
|
||||||
|
status = JSON.parse(decoded.status);
|
||||||
|
|
||||||
|
Finished is obviously true or false. Notably, it will be true in the error
|
||||||
|
case: so to status.finished && !status.error means successful completion.
|
||||||
|
Error will only be present if the process died for some reason.
|
||||||
|
|
||||||
|
Status will always be present, mostly so you can see what the last status was
|
||||||
|
before it died.
|
||||||
|
|
||||||
|
Elapsed will be the number of seconds since the process started (or until the
|
||||||
|
process finished, if it is finished).
|
||||||
|
|
||||||
|
=head1 SUBROUTINES
|
||||||
|
|
||||||
|
These subroutines are available from this package:
|
||||||
|
|
||||||
|
=cut
|
||||||
|
|
||||||
|
#-------------------------------------------------------------------
|
||||||
|
|
||||||
|
=head2 handler ( process )
|
||||||
|
|
||||||
|
See the synopsis for what kind of response this generates.
|
||||||
|
|
||||||
|
=cut
|
||||||
|
|
||||||
|
sub handler {
|
||||||
|
my $process = shift;
|
||||||
|
my $status = $process->getStatus;
|
||||||
|
my ( $finished, $startTime, $endTime, $error ) = $process->get( 'finished', 'startTime', 'endTime', 'error' );
|
||||||
|
|
||||||
|
$endTime = time() unless $finished;
|
||||||
|
|
||||||
|
my %status = (
|
||||||
|
status => $status,
|
||||||
|
elapsed => ( $endTime - $startTime ),
|
||||||
|
finished => ( $finished ? \1 : \0 ),
|
||||||
|
);
|
||||||
|
$status{error} = $error if $finished;
|
||||||
|
$process->session->http->setMimeType('text/plain');
|
||||||
|
JSON::encode_json( \%status );
|
||||||
|
} ## end sub handler
|
||||||
|
|
||||||
|
1;
|
||||||
|
|
@ -76,6 +76,7 @@ Returns a hash reference containing operation and package names.
|
||||||
|
|
||||||
sub getOperations {
|
sub getOperations {
|
||||||
return {
|
return {
|
||||||
|
'background' => 'BackgroundProcess',
|
||||||
'killSession' => 'ActiveSessions',
|
'killSession' => 'ActiveSessions',
|
||||||
'viewActiveSessions' => 'ActiveSessions',
|
'viewActiveSessions' => 'ActiveSessions',
|
||||||
|
|
||||||
|
|
|
||||||
74
lib/WebGUI/Operation/BackgroundProcess.pm
Normal file
74
lib/WebGUI/Operation/BackgroundProcess.pm
Normal file
|
|
@ -0,0 +1,74 @@
|
||||||
|
package WebGUI::Operation::BackgroundProcess;
|
||||||
|
|
||||||
|
=head1 LEGAL
|
||||||
|
|
||||||
|
-------------------------------------------------------------------
|
||||||
|
WebGUI is Copyright 2001-2009 Plain Black Corporation.
|
||||||
|
-------------------------------------------------------------------
|
||||||
|
Please read the legal notices (docs/legal.txt) and the license
|
||||||
|
(docs/license.txt) that came with this distribution before using
|
||||||
|
this software.
|
||||||
|
-------------------------------------------------------------------
|
||||||
|
http://www.plainblack.com info@plainblack.com
|
||||||
|
-------------------------------------------------------------------
|
||||||
|
|
||||||
|
=cut
|
||||||
|
|
||||||
|
use strict;
|
||||||
|
use warnings;
|
||||||
|
|
||||||
|
use WebGUI::BackgroundProcess;
|
||||||
|
use WebGUI::Pluggable;
|
||||||
|
|
||||||
|
=head1 NAME
|
||||||
|
|
||||||
|
WebGUI::Operation::BackgroundProcess
|
||||||
|
|
||||||
|
=head1 DESCRIPTION
|
||||||
|
|
||||||
|
URL dispatching for WebGUI::BackgroundProcess monitoring
|
||||||
|
|
||||||
|
=head1 SUBROUTINES
|
||||||
|
|
||||||
|
These subroutines are available from this package:
|
||||||
|
|
||||||
|
=cut
|
||||||
|
|
||||||
|
#-------------------------------------------------------------------
|
||||||
|
|
||||||
|
=head2 handler ( session )
|
||||||
|
|
||||||
|
Dispatches to the proper module based on the module form parameter if op is
|
||||||
|
background. Returns insufficient privilege page if the user doesn't pass
|
||||||
|
canView on the process before dispatching.
|
||||||
|
|
||||||
|
=cut
|
||||||
|
|
||||||
|
sub www_background {
|
||||||
|
my $session = shift;
|
||||||
|
my $form = $session->form;
|
||||||
|
my $module = $form->get('module') || 'Status';
|
||||||
|
my $pid = $form->get('pid') || return undef;
|
||||||
|
|
||||||
|
my $process = WebGUI::BackgroundProcess->new( $session, $pid );
|
||||||
|
|
||||||
|
return $session->privilege->insufficient unless $process->canView;
|
||||||
|
|
||||||
|
my $log = $session->log;
|
||||||
|
|
||||||
|
unless ($process) {
|
||||||
|
$log->error("Tried to get info for nonexistent process $pid");
|
||||||
|
return undef;
|
||||||
|
}
|
||||||
|
|
||||||
|
my $output = eval { WebGUI::Pluggable::run( "WebGUI::BackgroundProcess::$module", 'handler', [$process] ); };
|
||||||
|
|
||||||
|
if ($@) {
|
||||||
|
$log->error($@);
|
||||||
|
return undef;
|
||||||
|
}
|
||||||
|
|
||||||
|
return $output;
|
||||||
|
} ## end sub www_background
|
||||||
|
|
||||||
|
1;
|
||||||
82
lib/WebGUI/Workflow/Activity/RemoveOldBackgroundProcesses.pm
Normal file
82
lib/WebGUI/Workflow/Activity/RemoveOldBackgroundProcesses.pm
Normal file
|
|
@ -0,0 +1,82 @@
|
||||||
|
package WebGUI::Workflow::Activity::RemoveOldBackgroundProcesses;
|
||||||
|
|
||||||
|
=head1 LEGAL
|
||||||
|
|
||||||
|
-------------------------------------------------------------------
|
||||||
|
WebGUI is Copyright 2001-2009 Plain Black Corporation.
|
||||||
|
-------------------------------------------------------------------
|
||||||
|
Please read the legal notices (docs/legal.txt) and the license
|
||||||
|
(docs/license.txt) that came with this distribution before using
|
||||||
|
this software.
|
||||||
|
-------------------------------------------------------------------
|
||||||
|
http://www.plainblack.com info@plainblack.com
|
||||||
|
-------------------------------------------------------------------
|
||||||
|
|
||||||
|
=cut
|
||||||
|
|
||||||
|
use warnings;
|
||||||
|
use strict;
|
||||||
|
|
||||||
|
use base 'WebGUI::Workflow::Activity';
|
||||||
|
|
||||||
|
use WebGUI::International;
|
||||||
|
use WebGUI::BackgroundProcess;
|
||||||
|
|
||||||
|
=head1 NAME
|
||||||
|
|
||||||
|
WebGUI::Workflow::Activity::RemoveOldBackgroundProcesses
|
||||||
|
|
||||||
|
=head1 DESCRIPTION
|
||||||
|
|
||||||
|
Remove background processes that are older than a configurable threshold.
|
||||||
|
|
||||||
|
=head1 METHODS
|
||||||
|
|
||||||
|
These methods are available from this class:
|
||||||
|
|
||||||
|
=cut
|
||||||
|
|
||||||
|
#-------------------------------------------------------------------
|
||||||
|
|
||||||
|
=head2 definition ( session, definition )
|
||||||
|
|
||||||
|
See WebGUI::Workflow::Activity::definition() for details.
|
||||||
|
|
||||||
|
=cut
|
||||||
|
|
||||||
|
sub definition {
|
||||||
|
my ( $class, $session, $definition ) = @_;
|
||||||
|
my $i18n = WebGUI::International->new( $session, 'Workflow_Activity_RemoveOldBackgroundProcesses' );
|
||||||
|
my %def = (
|
||||||
|
name => $i18n->get('activityName'),
|
||||||
|
properties => {
|
||||||
|
interval => {
|
||||||
|
fieldType => 'interval',
|
||||||
|
label => $i18n->get('interval'),
|
||||||
|
defaultValue => 60 * 60 * 24 * 7,
|
||||||
|
hoverHelp => $i18n->get('interval help')
|
||||||
|
}
|
||||||
|
}
|
||||||
|
);
|
||||||
|
push @$definition, \%def;
|
||||||
|
return $class->SUPER::definition( $session, $definition );
|
||||||
|
} ## end sub definition
|
||||||
|
|
||||||
|
#-------------------------------------------------------------------
|
||||||
|
|
||||||
|
=head2 execute ( [ object ] )
|
||||||
|
|
||||||
|
See WebGUI::Workflow::Activity::execute() for details.
|
||||||
|
|
||||||
|
=cut
|
||||||
|
|
||||||
|
sub execute {
|
||||||
|
my $self = shift;
|
||||||
|
my $db = $self->session->db;
|
||||||
|
my $tbl = $db->dbh->quote_identifier( WebGUI::BackgroundProcess->tableName );
|
||||||
|
my $time = time - $self->get('interval');
|
||||||
|
$db->write( "DELETE FROM $tbl WHERE endTime <= ?", [$time] );
|
||||||
|
return $self->COMPLETE;
|
||||||
|
}
|
||||||
|
|
||||||
|
1;
|
||||||
|
|
@ -0,0 +1,20 @@
|
||||||
|
package WebGUI::i18n::English::Workflow_Activity_RemoveOldBackgroundProcesses;
|
||||||
|
|
||||||
|
use strict;
|
||||||
|
|
||||||
|
our $I18N = {
|
||||||
|
'interval help' => {
|
||||||
|
message => 'How long do we wait after process completion before deleting it?',
|
||||||
|
lastUpdated => 1285358250,
|
||||||
|
},
|
||||||
|
'interval' => {
|
||||||
|
message => q|Interval|,
|
||||||
|
lastUpdated => 1285358250,
|
||||||
|
},
|
||||||
|
'activityName' => {
|
||||||
|
message => q|Remove Old Background Processes|,
|
||||||
|
lastUpdated => 1285358250,
|
||||||
|
},
|
||||||
|
};
|
||||||
|
|
||||||
|
1;
|
||||||
87
t/BackgroundProcess.t
Normal file
87
t/BackgroundProcess.t
Normal file
|
|
@ -0,0 +1,87 @@
|
||||||
|
# vim:syntax=perl
|
||||||
|
#-------------------------------------------------------------------
|
||||||
|
# WebGUI is Copyright 2001-2009 Plain Black Corporation.
|
||||||
|
#-------------------------------------------------------------------
|
||||||
|
# Please read the legal notices (docs/legal.txt) and the license
|
||||||
|
# (docs/license.txt) that came with this distribution before using
|
||||||
|
# this software.
|
||||||
|
#------------------------------------------------------------------
|
||||||
|
# http://www.plainblack.com info@plainblack.com
|
||||||
|
#------------------------------------------------------------------
|
||||||
|
|
||||||
|
# WebGUI::BackgroundProcess tests
|
||||||
|
|
||||||
|
use strict;
|
||||||
|
use warnings;
|
||||||
|
|
||||||
|
use FindBin;
|
||||||
|
use lib "$FindBin::Bin/lib";
|
||||||
|
use lib "$FindBin::Bin/../lib";
|
||||||
|
|
||||||
|
use Test::More;
|
||||||
|
use Test::Deep;
|
||||||
|
use Data::Dumper;
|
||||||
|
use JSON;
|
||||||
|
|
||||||
|
use WebGUI::Test;
|
||||||
|
use WebGUI::Session;
|
||||||
|
use WebGUI::BackgroundProcess;
|
||||||
|
|
||||||
|
my $session = WebGUI::Test->session;
|
||||||
|
my $class = 'WebGUI::BackgroundProcess';
|
||||||
|
my $testClass = 'WebGUI::Test::BackgroundProcess';
|
||||||
|
|
||||||
|
# test simplest (non-forking) case
|
||||||
|
|
||||||
|
my $process = $class->create($session);
|
||||||
|
my @argv = $process->argv( $testClass, 'simple', ['data'] );
|
||||||
|
my $hash = $class->argvToHash( \@argv );
|
||||||
|
|
||||||
|
is ref $hash, 'HASH', 'got hash from argv';
|
||||||
|
cmp_bag(
|
||||||
|
[ keys %$hash ],
|
||||||
|
[ qw(webguiRoot configFile sessionId id module subname data) ],
|
||||||
|
'argvToHash has the right keys'
|
||||||
|
);
|
||||||
|
|
||||||
|
my $now = time;
|
||||||
|
|
||||||
|
$class->runFromHash($hash);
|
||||||
|
ok $process->isFinished, 'finished';
|
||||||
|
my $error = $process->getError;
|
||||||
|
ok( !$error, 'no errors' ) or diag " Expected nothing, got: $error\n";
|
||||||
|
$process->setWait(0);
|
||||||
|
is $process->getStatus, 'data', 'proper status';
|
||||||
|
my $started = $process->startTime;
|
||||||
|
ok( ( $started >= $now ), 'sane startTime' );
|
||||||
|
ok( ( $process->endTime >= $started ), 'sane endTime' );
|
||||||
|
|
||||||
|
$process->delete;
|
||||||
|
|
||||||
|
note "Testing error case\n";
|
||||||
|
$process = $class->create($session);
|
||||||
|
@argv = $process->argv( $testClass, 'error', ['error'] );
|
||||||
|
$hash = $class->argvToHash( \@argv );
|
||||||
|
$class->runFromHash($hash);
|
||||||
|
ok $process->isFinished, 'finished';
|
||||||
|
is $process->getError, "error\n", 'has error code';
|
||||||
|
$process->setWait(0);
|
||||||
|
my $status = $process->getStatus;
|
||||||
|
ok( !$status, 'no discernable status' ) or diag $status;
|
||||||
|
ok( ( $process->endTime >= $started ), 'sane endTime' );
|
||||||
|
|
||||||
|
note "Testing with actual fork\n";
|
||||||
|
$process = $class->start( $session, $testClass, 'complex', ['data'] );
|
||||||
|
my $sleeping;
|
||||||
|
while ( !$process->isFinished && $sleeping++ < 10 ) {
|
||||||
|
sleep 1;
|
||||||
|
}
|
||||||
|
ok $process->isFinished, 'finished';
|
||||||
|
is $process->getStatus, 'baz', 'correct status'
|
||||||
|
or diag $process->getError . "\n";
|
||||||
|
|
||||||
|
$process->delete;
|
||||||
|
|
||||||
|
done_testing;
|
||||||
|
|
||||||
|
#vim:ft=perl
|
||||||
20
t/lib/WebGUI/Test/BackgroundProcess.pm
Normal file
20
t/lib/WebGUI/Test/BackgroundProcess.pm
Normal file
|
|
@ -0,0 +1,20 @@
|
||||||
|
package WebGUI::Test::BackgroundProcess;
|
||||||
|
|
||||||
|
sub simple {
|
||||||
|
my ( $self, $arr ) = @_;
|
||||||
|
$self->update( $arr->[0] );
|
||||||
|
}
|
||||||
|
|
||||||
|
sub error {
|
||||||
|
my ( $self, $arr ) = @_;
|
||||||
|
die "$arr->[0]\n";
|
||||||
|
}
|
||||||
|
|
||||||
|
sub complex {
|
||||||
|
my $self = shift;
|
||||||
|
$self->update( sub {'foo'} );
|
||||||
|
$self->update( sub {'bar'} );
|
||||||
|
$self->update( sub {'baz'} );
|
||||||
|
}
|
||||||
|
|
||||||
|
1;
|
||||||
Loading…
Add table
Add a link
Reference in a new issue