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
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;
|
||||
Loading…
Add table
Add a link
Reference in a new issue