diff --git a/docs/upgrades/upgrade_7.10.1-7.10.2.pl b/docs/upgrades/upgrade_7.10.1-7.10.2.pl
index d2f49d9fc..9f4bb75c6 100644
--- a/docs/upgrades/upgrade_7.10.1-7.10.2.pl
+++ b/docs/upgrades/upgrade_7.10.1-7.10.2.pl
@@ -22,7 +22,7 @@ use Getopt::Long;
use WebGUI::Session;
use WebGUI::Storage;
use WebGUI::Asset;
-
+use List::Util qw(first);
my $toVersion = '7.10.2';
my $quiet; # this line required
@@ -31,9 +31,52 @@ my $quiet; # this line required
my $session = start(); # this line required
# upgrade functions go here
+addBackgroundProcessTable($session);
+installBackgroundProcessCleanup($session);
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
diff --git a/lib/WebGUI/AssetExportHtml.pm b/lib/WebGUI/AssetExportHtml.pm
index edc634760..f5673f7db 100644
--- a/lib/WebGUI/AssetExportHtml.pm
+++ b/lib/WebGUI/AssetExportHtml.pm
@@ -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
";
+ },
+ '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
");
- }
+ $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 = '';
- $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';
}
#-------------------------------------------------------------------
diff --git a/lib/WebGUI/BackgroundProcess.pm b/lib/WebGUI/BackgroundProcess.pm
new file mode 100644
index 000000000..25f02f141
--- /dev/null
+++ b/lib/WebGUI/BackgroundProcess.pm
@@ -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;
diff --git a/lib/WebGUI/BackgroundProcess/AssetExport.pm b/lib/WebGUI/BackgroundProcess/AssetExport.pm
new file mode 100644
index 000000000..e3b5f7ffe
--- /dev/null
+++ b/lib/WebGUI/BackgroundProcess/AssetExport.pm
@@ -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';
+
+Currently exporting
+(/).
+ seconds elapsed.
+
+
+[% MACRO yui(file) BLOCK %]
+
+[% END %]
+[% yui("yahoo/yahoo-min.js") %]
+[% yui("json/json-min.js") %]
+[% yui("event/event-min.js") %]
+[% yui("connection/connection_core-min.js") %]
+
+TEMPLATE
+
+my $stylesheet = <<'STYLESHEET';
+
+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;
diff --git a/lib/WebGUI/BackgroundProcess/Status.pm b/lib/WebGUI/BackgroundProcess/Status.pm
new file mode 100644
index 000000000..fba674a9d
--- /dev/null
+++ b/lib/WebGUI/BackgroundProcess/Status.pm
@@ -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;
diff --git a/lib/WebGUI/Operation.pm b/lib/WebGUI/Operation.pm
index 4c102fb75..444582270 100644
--- a/lib/WebGUI/Operation.pm
+++ b/lib/WebGUI/Operation.pm
@@ -76,6 +76,7 @@ Returns a hash reference containing operation and package names.
sub getOperations {
return {
+ 'background' => 'BackgroundProcess',
'killSession' => 'ActiveSessions',
'viewActiveSessions' => 'ActiveSessions',
diff --git a/lib/WebGUI/Operation/BackgroundProcess.pm b/lib/WebGUI/Operation/BackgroundProcess.pm
new file mode 100644
index 000000000..ec2e2bf37
--- /dev/null
+++ b/lib/WebGUI/Operation/BackgroundProcess.pm
@@ -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;
diff --git a/lib/WebGUI/Workflow/Activity/RemoveOldBackgroundProcesses.pm b/lib/WebGUI/Workflow/Activity/RemoveOldBackgroundProcesses.pm
new file mode 100644
index 000000000..fd06e118a
--- /dev/null
+++ b/lib/WebGUI/Workflow/Activity/RemoveOldBackgroundProcesses.pm
@@ -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;
diff --git a/lib/WebGUI/i18n/English/Workflow_Activity_RemoveOldBackgroundProcesses.pm b/lib/WebGUI/i18n/English/Workflow_Activity_RemoveOldBackgroundProcesses.pm
new file mode 100644
index 000000000..01ee9fc03
--- /dev/null
+++ b/lib/WebGUI/i18n/English/Workflow_Activity_RemoveOldBackgroundProcesses.pm
@@ -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;
diff --git a/t/BackgroundProcess.t b/t/BackgroundProcess.t
new file mode 100644
index 000000000..7cb332fe0
--- /dev/null
+++ b/t/BackgroundProcess.t
@@ -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
diff --git a/t/lib/WebGUI/Test/BackgroundProcess.pm b/t/lib/WebGUI/Test/BackgroundProcess.pm
new file mode 100644
index 000000000..51912b2dc
--- /dev/null
+++ b/t/lib/WebGUI/Test/BackgroundProcess.pm
@@ -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;