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
|
|
@ -23,7 +23,7 @@ use WebGUI::Exception;
|
|||
use WebGUI::Utility ();
|
||||
use WebGUI::Session;
|
||||
use URI::URL;
|
||||
use Scope::Guard;
|
||||
use Scope::Guard qw(guard);
|
||||
|
||||
=head1 NAME
|
||||
|
||||
|
|
@ -304,21 +304,53 @@ sub exportAsHtml {
|
|||
}
|
||||
|
||||
sub exportBranch {
|
||||
my $self = shift;
|
||||
my $options = shift;
|
||||
my $reportSession = shift;
|
||||
my ($self, $options, $reportSession) = @_;
|
||||
my $i18n = $reportSession &&
|
||||
WebGUI::International->new($self->session, 'Asset');
|
||||
|
||||
my $depth = $options->{depth};
|
||||
my $indexFileName = $options->{indexFileName};
|
||||
my $extrasUploadAction = $options->{extrasUploadAction};
|
||||
my $rootUrlAction = $options->{rootUrlAction};
|
||||
my $exportedCount = 0;
|
||||
my $report = $options->{report};
|
||||
|
||||
my $i18n;
|
||||
if ( $reportSession ) {
|
||||
$i18n = WebGUI::International->new($self->session, 'Asset');
|
||||
unless ($report) {
|
||||
if ($reportSession) {
|
||||
# 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 ( $assetId ) = @_;
|
||||
|
|
@ -335,26 +367,18 @@ sub exportBranch {
|
|||
|
||||
# skip this asset if we can't view it as this user.
|
||||
unless( $asset->canView ) {
|
||||
if( $reportSession ) {
|
||||
my $message = sprintf( $i18n->get('bad user privileges') . "\n") . $asset->getUrl;
|
||||
$reportSession->output->print($message);
|
||||
}
|
||||
$asset->$report('bad user privileges');
|
||||
next;
|
||||
}
|
||||
|
||||
# skip this asset if it's not exportable.
|
||||
unless ( $asset->exportCheckExportable ) {
|
||||
if ( $reportSession ) {
|
||||
$reportSession->output->print("$fullPath skipped, not exportable<br />");
|
||||
}
|
||||
$asset->$report('not exportable');
|
||||
next;
|
||||
}
|
||||
|
||||
# tell the user which asset we're exporting.
|
||||
if ( $reportSession ) {
|
||||
my $message = sprintf $i18n->get('exporting page'), $fullPath;
|
||||
$reportSession->output->print($message);
|
||||
}
|
||||
$asset->$report('exporting page');
|
||||
|
||||
# try to write the file
|
||||
eval { $asset->exportWriteFile };
|
||||
|
|
@ -364,9 +388,25 @@ sub exportBranch {
|
|||
|
||||
# next, tell the asset that we're exporting, so that it can export any
|
||||
# of its collateral or other extra data.
|
||||
eval { $asset->exportAssetCollateral($asset->exportGetUrlAsPath, $options, $reportSession) };
|
||||
if($@) {
|
||||
WebGUI::Error->throw(error => "failed to export asset collateral for URL " . $asset->getUrl . ": $@");
|
||||
{
|
||||
# For backcompat we want to capture anything that
|
||||
# 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
|
||||
|
|
@ -376,19 +416,12 @@ sub exportBranch {
|
|||
$self->session->db->write( "UPDATE asset SET lastExportedAs = ? WHERE assetId = ?",
|
||||
[ $fullPath, $asset->getId ] );
|
||||
|
||||
$self->updateHistory("exported");
|
||||
$asset->updateHistory('exported');
|
||||
|
||||
# tell the user we did this asset correctly
|
||||
if ( $reportSession ) {
|
||||
$reportSession->output->print($i18n->get('done'));
|
||||
}
|
||||
|
||||
#use Devel::Cycle;
|
||||
#warn "CHECKING on " . ref( $asset ) . ' ID: ' . $asset->getId . "\n";
|
||||
#find_cycle( $asset );
|
||||
$asset->$report('done');
|
||||
};
|
||||
|
||||
|
||||
my $assetIds = $self->exportGetDescendants(undef, $depth);
|
||||
foreach my $assetId ( @{$assetIds} ) {
|
||||
$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 ] )
|
||||
|
||||
Class or object method. Sets up the extras and uploads symlinks.
|
||||
|
|
@ -935,16 +1019,24 @@ Displays the export status page
|
|||
=cut
|
||||
|
||||
sub www_exportStatus {
|
||||
my $self = shift;
|
||||
return $self->session->privilege->insufficient() unless ($self->session->user->isInGroup(13));
|
||||
my $i18n = WebGUI::International->new($self->session, "Asset");
|
||||
my $iframeUrl = $self->getUrl('func=exportGenerate');
|
||||
foreach my $formVar (qw/index depth userId extrasUploadsAction rootUrlAction exportUrl/) {
|
||||
$iframeUrl = $self->session->url->append($iframeUrl, $formVar . '=' . $self->session->form->process($formVar));
|
||||
}
|
||||
|
||||
my $output = '<iframe src="' . $iframeUrl . '" title="' . $i18n->get('Page Export Status') . '" width="100%" height="500"></iframe>';
|
||||
$self->getAdminConsole->render($output, $i18n->get('Page Export Status'), "Asset");
|
||||
my $self = shift;
|
||||
my $session = $self->session;
|
||||
return $session->privilege->insufficient
|
||||
unless $session->user->isInGroup(13);
|
||||
my $form = $session->form;
|
||||
my @vars = qw(
|
||||
index depth userId extrasUploadsAction rootUrlAction exportUrl
|
||||
);
|
||||
my $process = WebGUI::BackgroundProcess->start(
|
||||
$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 {
|
||||
return {
|
||||
'background' => 'BackgroundProcess',
|
||||
'killSession' => '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;
|
||||
Loading…
Add table
Add a link
Reference in a new issue