From 79de38dc4af2cc5ad95dd7d79792d6f7340c18d2 Mon Sep 17 00:00:00 2001 From: Paul Driver Date: Mon, 20 Sep 2010 11:45:21 -0700 Subject: [PATCH 01/16] WebGUI::BackgroundProcess (used now by AssetExport) --- docs/upgrades/upgrade_7.10.1-7.10.2.pl | 45 +- lib/WebGUI/AssetExportHtml.pm | 176 ++++-- lib/WebGUI/BackgroundProcess.pm | 590 ++++++++++++++++++ lib/WebGUI/BackgroundProcess/AssetExport.pm | 173 +++++ lib/WebGUI/BackgroundProcess/Status.pm | 84 +++ lib/WebGUI/Operation.pm | 1 + lib/WebGUI/Operation/BackgroundProcess.pm | 74 +++ .../Activity/RemoveOldBackgroundProcesses.pm | 82 +++ ...w_Activity_RemoveOldBackgroundProcesses.pm | 20 + t/BackgroundProcess.t | 87 +++ t/lib/WebGUI/Test/BackgroundProcess.pm | 20 + 11 files changed, 1309 insertions(+), 43 deletions(-) create mode 100644 lib/WebGUI/BackgroundProcess.pm create mode 100644 lib/WebGUI/BackgroundProcess/AssetExport.pm create mode 100644 lib/WebGUI/BackgroundProcess/Status.pm create mode 100644 lib/WebGUI/Operation/BackgroundProcess.pm create mode 100644 lib/WebGUI/Workflow/Activity/RemoveOldBackgroundProcesses.pm create mode 100644 lib/WebGUI/i18n/English/Workflow_Activity_RemoveOldBackgroundProcesses.pm create mode 100644 t/BackgroundProcess.t create mode 100644 t/lib/WebGUI/Test/BackgroundProcess.pm 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; From c8fd0b56edad9610420b35bdd7cdbe4f678bb1bb Mon Sep 17 00:00:00 2001 From: Paul Driver Date: Tue, 28 Sep 2010 11:01:43 -0700 Subject: [PATCH 02/16] Implemented Graham's fork-at-startup idea --- lib/WebGUI/BackgroundProcess.pm | 348 ++++++++++++++++++-------------- sbin/preload.perl | 42 ++-- t/BackgroundProcess.t | 61 ++++-- 3 files changed, 263 insertions(+), 188 deletions(-) diff --git a/lib/WebGUI/BackgroundProcess.pm b/lib/WebGUI/BackgroundProcess.pm index 25f02f141..3a633240d 100644 --- a/lib/WebGUI/BackgroundProcess.pm +++ b/lib/WebGUI/BackgroundProcess.pm @@ -3,12 +3,12 @@ package WebGUI::BackgroundProcess; use warnings; use strict; -use Config; +use JSON; use POSIX; +use Config; +use IO::Pipe; use WebGUI::Session; use WebGUI::Pluggable; -use JSON; -use Getopt::Long qw(GetOptionsFromArray); use Time::HiRes qw(sleep); =head1 NAME @@ -74,58 +74,6 @@ status of. #----------------------------------------------------------------- -=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 @@ -168,8 +116,8 @@ sub contentPairs { =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(). +Internal class method. Creates a new BackgroundProcess object and inserts a +blank row of data into the db. =cut @@ -177,11 +125,73 @@ sub create { my ( $class, $session ) = @_; my $id = $session->id->generate; $session->db->setRow( $class->tableName, 'id', {}, $id ); - bless { session => $session, id => $id }; + bless { session => $session, id => $id }, $class; } #----------------------------------------------------------------- +=head2 daemonize ( $stdin, $sub ) + +Internal lass method. Runs the given $sub in daemon, and prints $stdin to its +stdin. + +=cut + +sub daemonize { + my ( $class, $stdin, $sub ) = @_; + 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; + } + + 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 + my $worker = IO::Pipe->new; + my $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. + if ($pid) { + $worker->writer; + $worker->printflush($stdin); + POSIX::_exit(0); + } + + # We're now in the final target process. STDIN should be whatever the + # parent printed to us, and all output should go to /dev/null. + $worker->reader(); + open STDIN, '<&', $worker or die "Cannot dup stdin: $!"; + open STDOUT, '>', '/dev/null' or die "Cannot write /dev/null: $!"; + open STDERR, '>&', \*STDOUT or die "Cannot dup stdout: $!"; + + # Standard daemon-y things... + $SIG{HUP} = 'IGNORE'; + chdir '/'; + umask 0; + + # Forcibly close any non-std open file descriptors that remain + my $max = POSIX::sysconf(&POSIX::_SC_OPEN_MAX) || 1024; + POSIX::close($_) for ( $^F .. $max ); + + # Do whatever we're supposed to do + &$sub(); + }; + + POSIX::_exit(-1) if ($@); +} ## end sub daemonize + +#----------------------------------------------------------------- + =head2 delete ( ) Clean up the information for this process from the database. @@ -241,12 +251,36 @@ sub finish { #----------------------------------------------------------------- +=head2 forkAndExec ($request) + +Internal method. Forks and execs a new perl process to run $request. This is +used as a fallback if the master daemon runner is not working. + +=cut + +sub forkAndExec { + my ( $self, $request ) = @_; + my $id = $self->getId; + my $class = ref $self; + $class->daemonize( + JSON::encode_json($request), + sub { + exec { $Config{perlpath} } + ( "webgui-background-$id", ( map {"-I$_"} @INC ), "-M$class", "-e$class->runCmd();", ) + or die "Could not exec: $!"; + } + ); +} + +#----------------------------------------------------------------- + =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. +this to get several at once if you're very careful. You should probably use +the accessors, though, since some of them have extra logic. =cut @@ -327,6 +361,42 @@ sub getStatus { #----------------------------------------------------------------- +=head2 init ( ) + +Spawn a master process from which background processes will fork. The intent +is for this to be called once at server startup time, after you've preloaded +modules and before you start listening for requests. Returns a filehandle that +can be used to print requests to the master process, and which you almost +certainly shouldn't use (it's mostly for testing). + +=cut + +my $pipe; + +sub init { + my $class = shift; + $pipe = IO::Pipe->new; + + my $pid = fork(); + die "Cannot fork: $!" unless defined $pid; + + if ($pid) { + $pipe->writer; + return $pipe; + } + + $0 = 'webgui-background-master'; + $pipe->reader; + local $/ = "\x{0}"; + while ( my $request = $pipe->getline ) { + chomp $request; + $class->daemonize( $request, sub { $class->runCmd } ); + } + exit 0; +} ## end sub init + +#----------------------------------------------------------------- + =head2 isFinished ( ) A simple flag indicating that background process is no longer running. @@ -378,24 +448,9 @@ See get() for a list of valid keys. 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 + my %row = ( id => $self->getId, %$values ); + $self->session->db->setRow( $self->tableName, 'id', \%row ); +} #----------------------------------------------------------------- @@ -414,43 +469,91 @@ sub setGroup { #----------------------------------------------------------------- -=head2 runCmd ($hashref) +=head2 request ($module, $subname, $data) -Class method. Processes ARGV and passes it to runFromHash. Don't call this -unless you're the start() method. +Internal method. Generates a hashref suitable for passing to runRequest. + +=cut + +sub request { + 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 => $data, + }; +} ## end sub request + +#----------------------------------------------------------------- + +=head2 runCmd () + +Internal class method. Decodes json off of stdin and passes it to runRequest. =cut sub runCmd { my $class = shift; - $class->runFromHash( $class->argvToHash( \@ARGV ) ); + my $slurp = do { local $/; }; + $class->runRequest( JSON::decode_json($slurp) ); + exit 0; } #----------------------------------------------------------------- -=head2 runFromHash ($hashref) +=head2 runRequest ($hashref) -Class method. Expects a hash of arguments describing what to run. Don't call -this unless you know what you're doing. +Internal class method. Expects a hash of arguments describing what to run. =cut -sub runFromHash { +sub runRequest { 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 ( $root, $config, $sid ) = @{$args}{qw(webguiRoot configFile sessionId)}; + my $session = WebGUI::Session->open( $root, $config, undef, undef, $sid ); my $self = $class->new( $session, $args->{id} ); $self->set( { startTime => time } ); - eval { $self->$code( $args->{data} ) }; + eval { + my ( $module, $subname, $data ) = @{$args}{qw(module subname data)}; + WebGUI::Pluggable::run( $module, $subname, [ $self, $data ] ); + }; $self->error($@) if $@; $self->finish(); } #----------------------------------------------------------------- +=head2 sendRequestToMaster ($request) + +Internal method. Attempts to send a request to the master daemon runner. +Returns 1 on success and 0 on failure. + +=cut + +sub sendRequestToMaster { + my ( $self, $request ) = @_; + my $json = JSON::encode_json($request); + eval { + die 'pipe' unless $pipe && $pipe->isa('IO::Handle'); + local $SIG{PIPE} = sub { die 'pipe' }; + $pipe->printflush("$json\x{0}") or die 'pipe'; + }; + return 1 unless $@; + undef $pipe; + $self->session->log->error('Problems talking to master daemon process. Please restart the web server.'); + return 0; +} + +#----------------------------------------------------------------- + =head2 setWait ( $interval ) Use this to control the pace at which getStatus will poll for updated @@ -466,16 +569,14 @@ 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, +Class method. Executes $module::subname in a background thread 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 +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). @@ -484,59 +585,10 @@ example). 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 + my $request = $self->request( $module, $subname, $data ); + $self->sendRequestToMaster($request) or $self->forkAndExec($request); + return $self; +} #----------------------------------------------------------------- diff --git a/sbin/preload.perl b/sbin/preload.perl index 4e54f6820..abc4e8c54 100644 --- a/sbin/preload.perl +++ b/sbin/preload.perl @@ -17,19 +17,6 @@ unshift @INC, grep { } } readLines($webguiRoot."/sbin/preload.custom"); -#---------------------------------------- -# Logger -#---------------------------------------- -require Log::Log4perl; -Log::Log4perl->init( $webguiRoot."/etc/log.conf" ); - -#---------------------------------------- -# Database connectivity. -#---------------------------------------- -#require Apache::DBI; # Uncomment if you want to enable connection pooling. Not recommended on servers with many sites, or those using db slaves. -require DBI; -DBI->install_driver("mysql"); # Change to match your database driver. - #---------------------------------------- # WebGUI modules. #---------------------------------------- @@ -48,6 +35,29 @@ WebGUI::Pluggable::findAndLoad( "WebGUI", } ); +#---------------------------------------- +# Preload all site configs. +#---------------------------------------- +WebGUI::Config->loadAllConfigs($webguiRoot); + +#---------------------------------------- +# WebGUI::BackgroundProcess initialization +#---------------------------------------- +WebGUI::BackgroundProcess->init(); + +#---------------------------------------- +# Logger +#---------------------------------------- +require Log::Log4perl; +Log::Log4perl->init( $webguiRoot."/etc/log.conf" ); + +#---------------------------------------- +# Database connectivity. +#---------------------------------------- +#require Apache::DBI; # Uncomment if you want to enable connection pooling. Not recommended on servers with many sites, or those using db slaves. +require DBI; +DBI->install_driver("mysql"); # Change to match your database driver. + require APR::Request::Apache2; require Apache2::Cookie; require Apache2::ServerUtil; @@ -64,12 +74,6 @@ $| = 1; print "\nStarting WebGUI ".$WebGUI::VERSION."\n"; -#---------------------------------------- -# Preload all site configs. -#---------------------------------------- -WebGUI::Config->loadAllConfigs($webguiRoot); - - # reads lines from a file into an array, trimming white space and ignoring commented lines sub readLines { my $file = shift; diff --git a/t/BackgroundProcess.t b/t/BackgroundProcess.t index 7cb332fe0..96d10929f 100644 --- a/t/BackgroundProcess.t +++ b/t/BackgroundProcess.t @@ -27,26 +27,25 @@ use WebGUI::Test; use WebGUI::Session; use WebGUI::BackgroundProcess; -my $session = WebGUI::Test->session; my $class = 'WebGUI::BackgroundProcess'; my $testClass = 'WebGUI::Test::BackgroundProcess'; +my $pipe = $class->init(); +my $session = WebGUI::Test->session; # test simplest (non-forking) case my $process = $class->create($session); -my @argv = $process->argv( $testClass, 'simple', ['data'] ); -my $hash = $class->argvToHash( \@argv ); +my $request = $process->request( $testClass, 'simple', ['data'] ); -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' + [ keys %$request ], + [qw(webguiRoot configFile sessionId id module subname data)], + 'request hash has the right keys' ); my $now = time; -$class->runFromHash($hash); +$class->runRequest($request); ok $process->isFinished, 'finished'; my $error = $process->getError; ok( !$error, 'no errors' ) or diag " Expected nothing, got: $error\n"; @@ -60,9 +59,8 @@ $process->delete; note "Testing error case\n"; $process = $class->create($session); -@argv = $process->argv( $testClass, 'error', ['error'] ); -$hash = $class->argvToHash( \@argv ); -$class->runFromHash($hash); +$request = $process->request( $testClass, 'error', ['error'] ); +$class->runRequest($request); ok $process->isFinished, 'finished'; is $process->getError, "error\n", 'has error code'; $process->setWait(0); @@ -70,17 +68,38 @@ 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"; +my $forkCount = 0; +my $forkAndExec = $class->can('forkAndExec'); +my $replace = sub { + my $self = shift; + $forkCount++; + $self->$forkAndExec(@_); +}; -$process->delete; +{ + no strict 'refs'; + no warnings 'redefine'; + *{ $class . '::forkAndExec' } = $replace; +} + +sub backgroundTest { + note "$_[0]\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; +} +backgroundTest('talk to background'); +is $forkCount, 0, 'we did not fork'; +close $pipe; +backgroundTest('On-demand fork'); +is $forkCount, 1, 'we did fork'; done_testing; From f2e0a4f667cab3a680a4d7de146ce519d1de6100 Mon Sep 17 00:00:00 2001 From: Paul Driver Date: Tue, 28 Sep 2010 12:56:26 -0700 Subject: [PATCH 03/16] Rename to WebGUI::Fork --- docs/upgrades/upgrade_7.10.1-7.10.2.pl | 20 ++--- lib/WebGUI/AssetExportHtml.pm | 18 +++-- lib/WebGUI/{BackgroundProcess.pm => Fork.pm} | 76 +++++++++---------- .../AssetExport.pm | 6 +- .../{BackgroundProcess => Fork}/Status.pm | 4 +- lib/WebGUI/Operation.pm | 2 +- .../{BackgroundProcess.pm => Fork.pm} | 20 ++--- ...ckgroundProcesses.pm => RemoveOldForks.pm} | 12 +-- ...pm => Workflow_Activity_RemoveOldForks.pm} | 4 +- sbin/preload.perl | 4 +- t/{BackgroundProcess.t => Fork.t} | 8 +- .../Test/{BackgroundProcess.pm => Fork.pm} | 2 +- 12 files changed, 88 insertions(+), 88 deletions(-) rename lib/WebGUI/{BackgroundProcess.pm => Fork.pm} (85%) rename lib/WebGUI/{BackgroundProcess => Fork}/AssetExport.pm (97%) rename lib/WebGUI/{BackgroundProcess => Fork}/Status.pm (96%) rename lib/WebGUI/Operation/{BackgroundProcess.pm => Fork.pm} (72%) rename lib/WebGUI/Workflow/Activity/{RemoveOldBackgroundProcesses.pm => RemoveOldForks.pm} (84%) rename lib/WebGUI/i18n/English/{Workflow_Activity_RemoveOldBackgroundProcesses.pm => Workflow_Activity_RemoveOldForks.pm} (70%) rename t/{BackgroundProcess.t => Fork.t} (94%) rename t/lib/WebGUI/Test/{BackgroundProcess.pm => Fork.pm} (87%) 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 9f4bb75c6..e7044997d 100644 --- a/docs/upgrades/upgrade_7.10.1-7.10.2.pl +++ b/docs/upgrades/upgrade_7.10.1-7.10.2.pl @@ -31,21 +31,21 @@ my $quiet; # this line required my $session = start(); # this line required # upgrade functions go here -addBackgroundProcessTable($session); -installBackgroundProcessCleanup($session); +addForkTable($session); +installForkCleanup($session); finish($session); # this line required #---------------------------------------------------------------------------- # Creates a new table for tracking background processes -sub addBackgroundProcessTable { +sub addForkTable { my $session = shift; my $db = $session->db; - my $sth = $db->dbh->table_info('', '', 'BackgroundProcess', 'TABLE'); + my $sth = $db->dbh->table_info('', '', 'Fork', 'TABLE'); return if ($sth->fetch); - print "\tAdding BackgroundProcess table..." unless $quiet; + print "\tAdding Fork table..." unless $quiet; my $sql = q{ - CREATE TABLE BackgroundProcess ( + CREATE TABLE Fork ( id CHAR(22), groupId CHAR(22), status LONGTEXT, @@ -64,16 +64,16 @@ sub addBackgroundProcessTable { #---------------------------------------------------------------------------- # install a workflow to clean up old background processes -sub installBackgroundProcessCleanup { +sub installForkCleanup { my $session = shift; - print "\tInstalling Background Process Cleanup workflow..." unless $quiet; - my $class = 'WebGUI::Workflow::Activity::RemoveOldBackgroundProcesses'; + print "\tInstalling Fork Cleanup workflow..." unless $quiet; + my $class = 'WebGUI::Workflow::Activity::RemoveOldForks'; $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'); + $a->set(title => 'Remove Old Forks'); }; print "DONE!\n" unless $quiet; } diff --git a/lib/WebGUI/AssetExportHtml.pm b/lib/WebGUI/AssetExportHtml.pm index f5673f7db..3f1d951f7 100644 --- a/lib/WebGUI/AssetExportHtml.pm +++ b/lib/WebGUI/AssetExportHtml.pm @@ -658,14 +658,14 @@ sub exportGetUrlAsPath { #------------------------------------------------------------------- -=head2 exportInBackground +=head2 exportInFork -Intended to be called by WebGUI::BackgroundProcess. Runs exportAsHtml on the +Intended to be called by WebGUI::Fork. Runs exportAsHtml on the specified asset and keeps a json structure as the status. =cut -sub exportInBackground { +sub exportInFork { my ($process, $args) = @_; my $self = WebGUI::Asset->new($process->session, delete $args->{assetId}); $args->{indexFileName} = delete $args->{index}; @@ -685,12 +685,12 @@ sub exportInBackground { my %reports = ( 'bad user privileges' => sub { shift->{badUserPrivileges} = 1 }, 'not exportable' => sub { shift->{notExportable} = 1 }, - 'exporting page' => sub { shift->{current} = 1 }, - 'done' => sub { + 'done' => sub { shift->{done} = 1 }, + 'exporting page' => sub { my $hash = shift; + $hash->{current} = 1; delete $last->{current}; $last = $hash; - $hash->{done} = 1; }, 'collateral notes' => sub { my ($hash, $text) = @_; @@ -705,6 +705,8 @@ sub exportInBackground { $process->update(sub { JSON::encode_json($tree) }); }; $self->exportAsHtml($args); + delete $last->{current}; + $process->update(JSON::encode_json($tree)); } #------------------------------------------------------------------- @@ -1027,8 +1029,8 @@ sub www_exportStatus { my @vars = qw( index depth userId extrasUploadsAction rootUrlAction exportUrl ); - my $process = WebGUI::BackgroundProcess->start( - $session, 'WebGUI::Asset', 'exportInBackground', { + my $process = WebGUI::Fork->start( + $session, 'WebGUI::Asset', 'exportInFork', { assetId => $self->getId, map { $_ => scalar $form->get($_) } @vars } diff --git a/lib/WebGUI/BackgroundProcess.pm b/lib/WebGUI/Fork.pm similarity index 85% rename from lib/WebGUI/BackgroundProcess.pm rename to lib/WebGUI/Fork.pm index 3a633240d..9776f89fd 100644 --- a/lib/WebGUI/BackgroundProcess.pm +++ b/lib/WebGUI/Fork.pm @@ -1,4 +1,4 @@ -package WebGUI::BackgroundProcess; +package WebGUI::Fork; use warnings; use strict; @@ -13,7 +13,7 @@ use Time::HiRes qw(sleep); =head1 NAME -WebGUI::BackgroundProcess +WebGUI::Fork =head1 DESCRIPTION @@ -36,16 +36,16 @@ status of. sub www_doWork { my $self = shift; my $session = $self->session; - my $process = WebGUI::BackgroundProcess->start( + my $process = WebGUI::Fork->start( $session, 'WebGUI::Some::Class', 'doWork', { some => 'data' } ); - # See WebGUI::Content::BackgroundProcess + # See WebGUI::Operation::Fork my $pairs = $process->contentPairs('DoWork'); $session->http->setRedirect($self->getUrl($pairs)); return 'redirect'; } - package WebGUI::Content::BackgroundProcess::DoWork; + package WebGUI::Operation::Fork::DoWork; sub handler { my $process = shift; @@ -77,8 +77,8 @@ status of. =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. +permission to view the status of the fork. By default, only admins can view, +but see setGroup. =cut @@ -98,25 +98,24 @@ sub canView { =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) +WebGUI::Operation::Fork plugin. $module should be the bit that comes after +WebGUI::Operation::Fork, e.g. $process->contentPairs('Foo') should return +something like "op=fork;module=Foo;pid=adlfjafo87ad9f78a7", which will +get dispatched to WebGUI::Operation::Fork::Foo::handler($process) =cut sub contentPairs { my ( $self, $module ) = @_; my $pid = $self->getId; - return "op=background;module=$module;pid=$pid"; + return "op=fork;module=$module;pid=$pid"; } #----------------------------------------------------------------- =head2 create ( ) -Internal class method. Creates a new BackgroundProcess object and inserts a +Internal class method. Creates a new Fork object and inserts a blank row of data into the db. =cut @@ -266,7 +265,7 @@ sub forkAndExec { JSON::encode_json($request), sub { exec { $Config{perlpath} } - ( "webgui-background-$id", ( map {"-I$_"} @INC ), "-M$class", "-e$class->runCmd();", ) + ( "webgui-fork-$id", ( map {"-I$_"} @INC ), "-M$class", "-e$class->runCmd();", ) or die "Could not exec: $!"; } ); @@ -295,7 +294,7 @@ sub get { : '*'; my $id = $dbh->quote( $self->getId ); my @values = $db->quickArray("SELECT $key FROM $tbl WHERE id = $id"); - return wantarray ? @values : $values[0]; + return (@values > 1) ? @values : $values[0]; } #----------------------------------------------------------------- @@ -326,8 +325,7 @@ sub getGroupId { =head2 getId ( ) -The unique id for this background process. Note: this is NOT the pid, but a -WebGUI guid. +The unique id for this fork. Note: this is NOT the pid, but a WebGUI guid. =cut @@ -337,11 +335,11 @@ 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). +Signals the fork that it should report its next status, then polls at +$interval (can be fractional) seconds (default: .1) waiting for the fork 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 @@ -363,7 +361,7 @@ sub getStatus { =head2 init ( ) -Spawn a master process from which background processes will fork. The intent +Spawn a master process from which Forks will fork(). The intent is for this to be called once at server startup time, after you've preloaded modules and before you start listening for requests. Returns a filehandle that can be used to print requests to the master process, and which you almost @@ -385,7 +383,7 @@ sub init { return $pipe; } - $0 = 'webgui-background-master'; + $0 = 'webgui-fork-master'; $pipe->reader; local $/ = "\x{0}"; while ( my $request = $pipe->getline ) { @@ -399,7 +397,7 @@ sub init { =head2 isFinished ( ) -A simple flag indicating that background process is no longer running. +A simple flag indicating that the fork is no longer running. =cut @@ -409,8 +407,8 @@ 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. +Returns an object capable of checking on the status of the fork indicated by +$id. Returns undef if there is no such process. =cut @@ -558,8 +556,8 @@ sub sendRequestToMaster { 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. +getStatus will still signal the fork for an update, but will take whatever is +currently recorded as the status and return immediately. =cut @@ -569,13 +567,13 @@ sub setWait { $_[0]->{interval} = $_[1] } =head2 start ( $session, $module, $subname, $data ) -Class method. Executes $module::subname in a background thread with ($process, +Class method. Executes $module::subname in a forked process 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, +The process name (as it appears in ps) will be set to webgui-fork-$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). @@ -609,18 +607,18 @@ data is stored in. =cut -sub tableName {'BackgroundProcess'} +sub tableName {'Fork'} #----------------------------------------------------------------- =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. +Set a new status for the fork. 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 diff --git a/lib/WebGUI/BackgroundProcess/AssetExport.pm b/lib/WebGUI/Fork/AssetExport.pm similarity index 97% rename from lib/WebGUI/BackgroundProcess/AssetExport.pm rename to lib/WebGUI/Fork/AssetExport.pm index e3b5f7ffe..e7440d888 100644 --- a/lib/WebGUI/BackgroundProcess/AssetExport.pm +++ b/lib/WebGUI/Fork/AssetExport.pm @@ -1,4 +1,4 @@ -package WebGUI::BackgroundProcess::AssetExport; +package WebGUI::Fork::AssetExport; =head1 LEGAL @@ -19,7 +19,7 @@ use warnings; =head1 NAME -WebGUI::BackgroundProcess::AssetExport +WebGUI::Fork::AssetExport =head1 DESCRIPTION @@ -149,7 +149,7 @@ STYLESHEET =head2 handler ( process ) -See WebGUI::Operation::BackgroundProcess. +See WebGUI::Operation::Fork. =cut diff --git a/lib/WebGUI/BackgroundProcess/Status.pm b/lib/WebGUI/Fork/Status.pm similarity index 96% rename from lib/WebGUI/BackgroundProcess/Status.pm rename to lib/WebGUI/Fork/Status.pm index fba674a9d..06c2ebd3b 100644 --- a/lib/WebGUI/BackgroundProcess/Status.pm +++ b/lib/WebGUI/Fork/Status.pm @@ -1,4 +1,4 @@ -package WebGUI::BackgroundProcess::Status; +package WebGUI::Fork::Status; use JSON; @@ -21,7 +21,7 @@ use warnings; =head1 NAME -WebGUI::BackgroundProcess::Status +WebGUI::Fork::Status =head1 DESCRIPTION diff --git a/lib/WebGUI/Operation.pm b/lib/WebGUI/Operation.pm index 444582270..7c9a9204b 100644 --- a/lib/WebGUI/Operation.pm +++ b/lib/WebGUI/Operation.pm @@ -76,7 +76,7 @@ Returns a hash reference containing operation and package names. sub getOperations { return { - 'background' => 'BackgroundProcess', + 'fork' => 'Fork', 'killSession' => 'ActiveSessions', 'viewActiveSessions' => 'ActiveSessions', diff --git a/lib/WebGUI/Operation/BackgroundProcess.pm b/lib/WebGUI/Operation/Fork.pm similarity index 72% rename from lib/WebGUI/Operation/BackgroundProcess.pm rename to lib/WebGUI/Operation/Fork.pm index ec2e2bf37..a0b2ccdfc 100644 --- a/lib/WebGUI/Operation/BackgroundProcess.pm +++ b/lib/WebGUI/Operation/Fork.pm @@ -1,4 +1,4 @@ -package WebGUI::Operation::BackgroundProcess; +package WebGUI::Operation::Fork; =head1 LEGAL @@ -17,16 +17,16 @@ package WebGUI::Operation::BackgroundProcess; use strict; use warnings; -use WebGUI::BackgroundProcess; +use WebGUI::Fork; use WebGUI::Pluggable; =head1 NAME -WebGUI::Operation::BackgroundProcess +WebGUI::Operation::Fork =head1 DESCRIPTION -URL dispatching for WebGUI::BackgroundProcess monitoring +URL dispatching for WebGUI::Fork monitoring =head1 SUBROUTINES @@ -39,18 +39,18 @@ These subroutines are available from this package: =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. +fork. Returns insufficient privilege page if the user doesn't pass canView on +the process before dispatching. =cut -sub www_background { +sub www_fork { 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 ); + my $process = WebGUI::Fork->new( $session, $pid ); return $session->privilege->insufficient unless $process->canView; @@ -61,7 +61,7 @@ sub www_background { return undef; } - my $output = eval { WebGUI::Pluggable::run( "WebGUI::BackgroundProcess::$module", 'handler', [$process] ); }; + my $output = eval { WebGUI::Pluggable::run( "WebGUI::Fork::$module", 'handler', [$process] ); }; if ($@) { $log->error($@); @@ -69,6 +69,6 @@ sub www_background { } return $output; -} ## end sub www_background +} ## end sub www_fork 1; diff --git a/lib/WebGUI/Workflow/Activity/RemoveOldBackgroundProcesses.pm b/lib/WebGUI/Workflow/Activity/RemoveOldForks.pm similarity index 84% rename from lib/WebGUI/Workflow/Activity/RemoveOldBackgroundProcesses.pm rename to lib/WebGUI/Workflow/Activity/RemoveOldForks.pm index fd06e118a..209d29341 100644 --- a/lib/WebGUI/Workflow/Activity/RemoveOldBackgroundProcesses.pm +++ b/lib/WebGUI/Workflow/Activity/RemoveOldForks.pm @@ -1,4 +1,4 @@ -package WebGUI::Workflow::Activity::RemoveOldBackgroundProcesses; +package WebGUI::Workflow::Activity::RemoveOldForks; =head1 LEGAL @@ -20,15 +20,15 @@ use strict; use base 'WebGUI::Workflow::Activity'; use WebGUI::International; -use WebGUI::BackgroundProcess; +use WebGUI::Fork; =head1 NAME -WebGUI::Workflow::Activity::RemoveOldBackgroundProcesses +WebGUI::Workflow::Activity::RemoveOldForks =head1 DESCRIPTION -Remove background processes that are older than a configurable threshold. +Remove forks that are older than a configurable threshold. =head1 METHODS @@ -46,7 +46,7 @@ See WebGUI::Workflow::Activity::definition() for details. sub definition { my ( $class, $session, $definition ) = @_; - my $i18n = WebGUI::International->new( $session, 'Workflow_Activity_RemoveOldBackgroundProcesses' ); + my $i18n = WebGUI::International->new( $session, 'Workflow_Activity_RemoveOldForks' ); my %def = ( name => $i18n->get('activityName'), properties => { @@ -73,7 +73,7 @@ See WebGUI::Workflow::Activity::execute() for details. sub execute { my $self = shift; my $db = $self->session->db; - my $tbl = $db->dbh->quote_identifier( WebGUI::BackgroundProcess->tableName ); + my $tbl = $db->dbh->quote_identifier( WebGUI::Fork->tableName ); my $time = time - $self->get('interval'); $db->write( "DELETE FROM $tbl WHERE endTime <= ?", [$time] ); return $self->COMPLETE; diff --git a/lib/WebGUI/i18n/English/Workflow_Activity_RemoveOldBackgroundProcesses.pm b/lib/WebGUI/i18n/English/Workflow_Activity_RemoveOldForks.pm similarity index 70% rename from lib/WebGUI/i18n/English/Workflow_Activity_RemoveOldBackgroundProcesses.pm rename to lib/WebGUI/i18n/English/Workflow_Activity_RemoveOldForks.pm index 01ee9fc03..c93ebe4d2 100644 --- a/lib/WebGUI/i18n/English/Workflow_Activity_RemoveOldBackgroundProcesses.pm +++ b/lib/WebGUI/i18n/English/Workflow_Activity_RemoveOldForks.pm @@ -1,4 +1,4 @@ -package WebGUI::i18n::English::Workflow_Activity_RemoveOldBackgroundProcesses; +package WebGUI::i18n::English::Workflow_Activity_RemoveOldForks; use strict; @@ -12,7 +12,7 @@ our $I18N = { lastUpdated => 1285358250, }, 'activityName' => { - message => q|Remove Old Background Processes|, + message => q|Remove Old Forks|, lastUpdated => 1285358250, }, }; diff --git a/sbin/preload.perl b/sbin/preload.perl index abc4e8c54..0adbef505 100644 --- a/sbin/preload.perl +++ b/sbin/preload.perl @@ -41,9 +41,9 @@ WebGUI::Pluggable::findAndLoad( "WebGUI", WebGUI::Config->loadAllConfigs($webguiRoot); #---------------------------------------- -# WebGUI::BackgroundProcess initialization +# WebGUI::Fork initialization #---------------------------------------- -WebGUI::BackgroundProcess->init(); +WebGUI::Fork->init(); #---------------------------------------- # Logger diff --git a/t/BackgroundProcess.t b/t/Fork.t similarity index 94% rename from t/BackgroundProcess.t rename to t/Fork.t index 96d10929f..8e9d51909 100644 --- a/t/BackgroundProcess.t +++ b/t/Fork.t @@ -9,7 +9,7 @@ # http://www.plainblack.com info@plainblack.com #------------------------------------------------------------------ -# WebGUI::BackgroundProcess tests +# WebGUI::Fork tests use strict; use warnings; @@ -25,10 +25,10 @@ use JSON; use WebGUI::Test; use WebGUI::Session; -use WebGUI::BackgroundProcess; +use WebGUI::Fork; -my $class = 'WebGUI::BackgroundProcess'; -my $testClass = 'WebGUI::Test::BackgroundProcess'; +my $class = 'WebGUI::Fork'; +my $testClass = 'WebGUI::Test::Fork'; my $pipe = $class->init(); my $session = WebGUI::Test->session; diff --git a/t/lib/WebGUI/Test/BackgroundProcess.pm b/t/lib/WebGUI/Test/Fork.pm similarity index 87% rename from t/lib/WebGUI/Test/BackgroundProcess.pm rename to t/lib/WebGUI/Test/Fork.pm index 51912b2dc..ff86fbfed 100644 --- a/t/lib/WebGUI/Test/BackgroundProcess.pm +++ b/t/lib/WebGUI/Test/Fork.pm @@ -1,4 +1,4 @@ -package WebGUI::Test::BackgroundProcess; +package WebGUI::Test::Fork; sub simple { my ( $self, $arr ) = @_; From ea607eb4c9213c57dec20c789d48b9217f89b57f Mon Sep 17 00:00:00 2001 From: Paul Driver Date: Wed, 29 Sep 2010 12:54:38 -0700 Subject: [PATCH 04/16] Minor code cleanup on Fork.pm --- lib/WebGUI/Fork.pm | 40 ++++++++++++++++++---------------------- 1 file changed, 18 insertions(+), 22 deletions(-) diff --git a/lib/WebGUI/Fork.pm b/lib/WebGUI/Fork.pm index 9776f89fd..09b26473c 100644 --- a/lib/WebGUI/Fork.pm +++ b/lib/WebGUI/Fork.pm @@ -89,8 +89,7 @@ sub canView { $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); + return $user->isInGroup( $self->getGroupId ); } #------------------------------------------------------------------- @@ -186,7 +185,7 @@ sub daemonize { &$sub(); }; - POSIX::_exit(-1) if ($@); + POSIX::_exit( $@ ? -1 : 0 ); } ## end sub daemonize #----------------------------------------------------------------- @@ -199,9 +198,7 @@ Clean up the information for this process from the database. 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 ] ); + $self->session->db->deleteRow( $self->tableName, 'id', $self->getId ); } #----------------------------------------------------------------- @@ -261,12 +258,13 @@ sub forkAndExec { my ( $self, $request ) = @_; my $id = $self->getId; my $class = ref $self; + my $json = JSON::encode_json($request); + my @inc = map {"-I$_"} @INC; + my @argv = ( "webgui-fork-$id", @inc, "-M$class", "-e$class->runCmd()" ); $class->daemonize( - JSON::encode_json($request), + $json, sub { - exec { $Config{perlpath} } - ( "webgui-fork-$id", ( map {"-I$_"} @INC ), "-M$class", "-e$class->runCmd();", ) - or die "Could not exec: $!"; + exec { $Config{perlpath} } @argv or die "Could not exec: $!"; } ); } @@ -294,7 +292,7 @@ sub get { : '*'; my $id = $dbh->quote( $self->getId ); my @values = $db->quickArray("SELECT $key FROM $tbl WHERE id = $id"); - return (@values > 1) ? @values : $values[0]; + return ( @values > 1 ) ? @values : $values[0]; } #----------------------------------------------------------------- @@ -335,18 +333,17 @@ sub getId { shift->{id} } =head2 getStatus() -Signals the fork that it should report its next status, then polls at -$interval (can be fractional) seconds (default: .1) waiting for the fork to -claim that its status has been updated. Returns the updated status. See +Signals the fork that it should report its next status, then polls at a +configurable, fractional interval (default: .1 seconds) waiting for the fork +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) { + my $self = shift; + if ( my $interval = $self->{interval} ) { $self->set( { latch => 1 } ); while (1) { sleep $interval; @@ -388,7 +385,9 @@ sub init { local $/ = "\x{0}"; while ( my $request = $pipe->getline ) { chomp $request; - $class->daemonize( $request, sub { $class->runCmd } ); + eval { + $class->daemonize( $request, sub { $class->runCmd } ); + }; } exit 0; } ## end sub init @@ -475,10 +474,8 @@ Internal method. Generates a hashref suitable for passing to runRequest. sub request { 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, @@ -488,7 +485,7 @@ sub request { id => $self->getId, data => $data, }; -} ## end sub request +} #----------------------------------------------------------------- @@ -502,7 +499,6 @@ sub runCmd { my $class = shift; my $slurp = do { local $/; }; $class->runRequest( JSON::decode_json($slurp) ); - exit 0; } #----------------------------------------------------------------- From e238f72278f3b90a9690c592f9dc836ccfb2edee Mon Sep 17 00:00:00 2001 From: Paul Driver Date: Mon, 4 Oct 2010 10:09:23 -0700 Subject: [PATCH 05/16] www_copy and www_pasteList Forkified --- docs/changelog/7.x.x.txt | 3 + docs/gotcha.txt | 2 + docs/upgrades/upgrade_7.10.1-7.10.2.pl | 1 + lib/WebGUI/Asset.pm | 31 ++ lib/WebGUI/AssetBranch.pm | 35 ++- lib/WebGUI/AssetClipboard.pm | 276 +++++++++++------- lib/WebGUI/AssetExportHtml.pm | 61 ++-- lib/WebGUI/Fork.pm | 56 +++- .../Fork/{AssetExport.pm => ProgressTree.pm} | 132 +++++---- lib/WebGUI/ProgressTree.pm | 172 +++++++++++ lib/WebGUI/VersionTag.pm | 51 +++- sbin/testEnvironment.pl | 1 + 12 files changed, 605 insertions(+), 216 deletions(-) rename lib/WebGUI/Fork/{AssetExport.pm => ProgressTree.pm} (50%) create mode 100644 lib/WebGUI/ProgressTree.pm diff --git a/docs/changelog/7.x.x.txt b/docs/changelog/7.x.x.txt index 30a36ce60..889226c90 100644 --- a/docs/changelog/7.x.x.txt +++ b/docs/changelog/7.x.x.txt @@ -1,6 +1,9 @@ 7.10.3 7.10.2 + - Added WebGUI::Fork api + - Moved html export to Fork + - Moved clipboard functions to Fork - fixed #11884: Editing Templates impossible / Code editor not loaded - recommitted ukplayer. Removal broke Matrix. Licencing information was available but overlooked. - fixed #11883: Wiki "Add page" link does not encode special chars diff --git a/docs/gotcha.txt b/docs/gotcha.txt index 25f6e89cd..e79db5162 100644 --- a/docs/gotcha.txt +++ b/docs/gotcha.txt @@ -19,6 +19,8 @@ save you many hours of grief. is in WebGUI again. Licencing information was overlooked. An upgrade to 7.10.1 will break the Matrix. This is fixed now. + * WebGUI now depends on Monkey::Patch for sanely scoped monkeypatching. + 7.10.1 -------------------------------------------------------------------- * WebGUI now depends on PerlIO::eol, for doing line ending translation. 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 e7044997d..410288491 100644 --- a/docs/upgrades/upgrade_7.10.1-7.10.2.pl +++ b/docs/upgrades/upgrade_7.10.1-7.10.2.pl @@ -47,6 +47,7 @@ sub addForkTable { my $sql = q{ CREATE TABLE Fork ( id CHAR(22), + userId CHAR(22), groupId CHAR(22), status LONGTEXT, error TEXT, diff --git a/lib/WebGUI/Asset.pm b/lib/WebGUI/Asset.pm index 34194743b..4c86c7353 100644 --- a/lib/WebGUI/Asset.pm +++ b/lib/WebGUI/Asset.pm @@ -37,6 +37,9 @@ use WebGUI::HTML; use WebGUI::HTMLForm; use WebGUI::Keyword; use WebGUI::ProgressBar; +use WebGUI::ProgressTree; +use Monkey::Patch; +use WebGUI::Fork; use WebGUI::Search::Index; use WebGUI::TabForm; use WebGUI::Utility; @@ -2555,6 +2558,34 @@ sub setSize { $self->{_properties}{assetSize} = $size; } +#------------------------------------------------------------------- + +=head2 setState ( $state ) + +Updates the asset table with the new state of the asset. + +=cut + +sub setState { + my ($self, $state) = @_; + my $sql = q{ + UPDATE asset + SET state = ?, + stateChangedBy = ?, + stateChanged = ? + WHERE assetId = ? + }; + $self->session->db->write( + $sql, [ + $state, + $self->session->user->userId, + time, + $self->getId, + ] + ); + $self->{_properties}->{state} = $state; + $self->purgeCache; +} #------------------------------------------------------------------- diff --git a/lib/WebGUI/AssetBranch.pm b/lib/WebGUI/AssetBranch.pm index f13a13daf..3de109fc5 100644 --- a/lib/WebGUI/AssetBranch.pm +++ b/lib/WebGUI/AssetBranch.pm @@ -46,13 +46,26 @@ Duplicates this asset and the entire subtree below it. Returns the root of the If true, then only children, and not descendants, will be duplicated. +=head3 $state + +Set this to "clipboard" if you want the resulting asset to be on the clipboard +(rather than published) when we're done. + =cut sub duplicateBranch { - my $self = shift; - my $childrenOnly = shift; + my ($self, $childrenOnly, $state) = @_; + my $session = $self->session; + my $log = $session->log; + my $clipboard = $state && $state =~ /^clipboard/; + + my $newAsset = $self->duplicate( + { skipAutoCommitWorkflows => 1, + skipNotification => 1, + state => $state, + } + ); - my $newAsset = $self->duplicate({skipAutoCommitWorkflows=>1,skipNotification=>1}); # Correctly handle positions for Layout assets my $contentPositions = $self->get("contentPositions"); my $assetsToHide = $self->get("assetsToHide"); @@ -66,7 +79,21 @@ sub duplicateBranch { next; } last unless $child; - my $newChild = $childrenOnly ? $child->duplicate({skipAutoCommitWorkflows=>1, skipNotification=>1}) : $child->duplicateBranch; + my $newChild; + if ($childrenOnly) { + $newChild = $child->duplicate( + { skipAutoCommitWorkflows => 1, + skipNotification => 1, + state => $clipboard && 'clipboard-limbo', + } + ); + } + elsif($clipboard) { + $newChild = $child->duplicateBranch(0, 'clipboard-limbo'); + } + else { + $newChild = $child->duplicateBranch; + } $newChild->setParent($newAsset); my ($oldChildId, $newChildId) = ($child->getId, $newChild->getId); $contentPositions =~ s/\Q${oldChildId}\E/${newChildId}/g if ($contentPositions); diff --git a/lib/WebGUI/AssetClipboard.pm b/lib/WebGUI/AssetClipboard.pm index dc1ddf8d9..2bb5c7609 100644 --- a/lib/WebGUI/AssetClipboard.pm +++ b/lib/WebGUI/AssetClipboard.pm @@ -49,6 +49,55 @@ sub canPaste { return $self->validParent($self->session); ##Lazy call to a class method } +#------------------------------------------------------------------- + +=head2 copyInBackground ( $process, $args ) + +WebGUI::Fork method called by www_copy + +=cut + +sub copyInBackground { + my ($process, $args) = @_; + my $session = $process->session; + my $asset = WebGUI::Asset->new($session, $args->{assetId}); + my @pedigree = ('self'); + my $childrenOnly = 0; + if ($args->{childrenOnly}) { + $childrenOnly = 1; + push @pedigree, 'children'; + } + else { + push @pedigree, 'descendants'; + } + my $ids = $asset->getLineage(\@pedigree); + my $tree = WebGUI::ProgressTree->new($session, $ids); + my $patch = Monkey::Patch::patch_class 'WebGUI::Asset', 'duplicate', sub { + my $duplicate = shift; + my $self = shift; + my $id = $self->getId; + my $asset = eval { $self->$duplicate(@_) }; + my $e = $@; + if ($e) { + $tree->note($id, $e); + $tree->failure($id, 'Died'); + } + else { + $tree->success($id); + } + $process->update(sub { $tree->json }); + die $e if $e; + return $asset; + }; + my $newAsset = $asset->duplicateBranch($childrenOnly, 'clipboard'); + $newAsset->update({ title => $newAsset->getTitle . ' (copy)'}); + if ($args->{commit}) { + my $tag = WebGUI::VersionTag->getWorking($session); + $tag->requestCommit(); + } +} + + #------------------------------------------------------------------- =head2 cut ( ) @@ -97,6 +146,10 @@ A hash reference of options that can modify how this method works. Assets that normally autocommit their workflows (like CS Posts, and Wiki Pages) won't if this is true. +=head4 state + +A state for the duplicated asset (defaults to 'published') + =cut sub duplicate { @@ -132,6 +185,10 @@ sub duplicate { keywords => $keywords, } ); + if (my $state = $options->{state}) { + $newAsset->setState($state); + } + return $newAsset; } @@ -218,11 +275,12 @@ sub paste { my $i18n=WebGUI::International->new($session, 'Asset'); $outputSub->(sprintf $i18n->get('pasting %s'), $pastedAsset->getTitle) if defined $outputSub; if ($self->getId eq $pastedAsset->get("parentId") || $pastedAsset->setParent($self)) { - $pastedAsset->publish(['clipboard','clipboard-limbo']); # Paste only clipboard items - $pastedAsset->updateHistory("pasted to parent ".$self->getId); - # Update lineage in search index. - my $assetIter = $pastedAsset->getLineageIterator(['self', 'descendants']); + my $assetIter = $pastedAsset->getLineageIterator( + ['self', 'descendants'], { + statesToInclude => ['clipboard','clipboard-limbo'] + } + ); while ( 1 ) { my $asset; eval { $asset = $assetIter->() }; @@ -233,15 +291,67 @@ sub paste { last unless $asset; $outputSub->(sprintf $i18n->get('indexing %s'), $pastedAsset->getTitle) if defined $outputSub; + $asset->setState('published'); $asset->indexContent(); } - + $pastedAsset->updateHistory("pasted to parent ".$self->getId); return 1; } return 0; } +#------------------------------------------------------------------- + +=head2 pasteInBackground ( ) + +WebGUI::Fork method called by www_pasteList + +=cut + +sub pasteInBackground { + my ($process, $args) = @_; + my $session = $process->session; + my $self = WebGUI::Asset->new($session, $args->{assetId}); + my @roots = grep { $_ && $_->canEdit } + map { WebGUI::Asset->newPending($session, $_) } + @{ $args->{list} }; + + my @ids; + for my $r (@roots) { + my $these = $r->getLineage( + ['self', 'descendants'], { + statesToInclude => ['clipboard', 'clipboard-limbo'] + } + ); + push(@ids, @$these); + } + + my $tree = WebGUI::ProgressTree->new($session, \@ids); + my $patch = Monkey::Patch::patch_class( + 'WebGUI::Asset', 'indexContent', sub { + my $indexContent = shift; + my $self = shift; + my $id = $self->getId; + $tree->focus($id); + my $ret = eval { $self->$indexContent(@_) }; + my $e = $@; + if ($e) { + $tree->note($id, $e); + $tree->failure($id, 'Died'); + } + else { + $tree->success($id); + } + $process->update(sub { $tree->json }); + die $e if $e; + return $ret; + } + ); + $self->paste($_->getId) for @roots; +} + + #------------------------------------------------------------------- =head2 www_copy ( ) @@ -255,89 +365,54 @@ If with children/descendants is selected, a progress bar will be rendered. sub www_copy { my $self = shift; my $session = $self->session; + my $http = $session->http; + my $redir = $self->getParent->getUrl; return $session->privilege->insufficient unless $self->canEdit; my $with = $session->form->get('with'); + my %args; if ($with eq 'children') { - $self->_wwwCopyChildren; + $args{childrenOnly} = 1; } - elsif ($with eq 'descendants') { - $self->_wwwCopyDescendants; + elsif ($with ne 'descendants') { + my $newAsset = $self->duplicate({ + skipAutoCommitWorkflows => 1, + state => 'clipboard' + } + ); + $newAsset->update({ title => $newAsset->getTitle . ' (copy)'}); + my $result = WebGUI::VersionTag->autoCommitWorkingIfEnabled( + $session, { + allowComments => 1, + returnUrl => $redir, + } + ); + $http->setRedirect($redir) unless $result eq 'redirect'; + return 'redirect'; } - else { - $self->_wwwCopySingle; + + my $tag = WebGUI::VersionTag->getWorking($session); + if ($tag->canAutoCommit) { + $args{commit} = 1; + unless ($session->setting->get('skipCommitComments')) { + $redir = $tag->autoCommitUrl($redir); + } } -} -#------------------------------------------------------------------- -sub _wwwCopyChildren { shift->_wwwCopyProgress(1) } - -#------------------------------------------------------------------- -sub _wwwCopyDescendants { shift->_wwwCopyProgress(0) } - -#------------------------------------------------------------------- -sub _wwwCopyFinish { - my ($self, $newAsset) = @_; - my $session = $self->session; - my $i18n = WebGUI::International->new($session, 'Asset'); - my $title = sprintf("%s (%s)", $self->getTitle, $i18n->get('copy')); - $newAsset->update({ title => $title }); - $newAsset->cut; - my $result = WebGUI::VersionTag->autoCommitWorkingIfEnabled( - $session, { - allowComments => 1, - returnUrl => $self->getUrl, + $args{assetId} = $self->getId; + my $process = WebGUI::Fork->start( + $session, 'WebGUI::Asset', 'copyInBackground', \%args + ); + my $i18n = WebGUI::International->new($session, 'Asset'); + my $pairs = $process->contentPairs( + 'ProgressTree', { + title => $i18n->get('Copy Assets'), + icon => 'assets', + proceed => $redir } ); - my $redirect = $result eq 'redirect'; - $session->asset($self->getContainer) unless $redirect; - return $redirect; -} - -#------------------------------------------------------------------- -sub _wwwCopyProgress { - my ($self, $childrenOnly) = @_; - my $session = $self->session; - my $i18n = WebGUI::International->new($session, 'Asset'); - - # This could potentially time out, so we'll render a progress bar. - my $pb = WebGUI::ProgressBar->new($session); - my @stack; - - return $pb->run( - title => $i18n->get('Copy Assets'), - icon => $session->url->extras('adminConsole/assets.gif'), - code => sub { - my $bar = shift; - my $newAsset = $self->duplicateBranch($childrenOnly); - $bar->update($i18n->get('cut')); - my $redirect = $self->_wwwCopyFinish($newAsset); - return $redirect ? $self->getUrl : $self->getContainer->getUrl; - }, - wrap => { - 'WebGUI::Asset::duplicateBranch' => sub { - my ($bar, $original, $asset, @args) = @_; - push(@stack, $asset->getTitle); - my $ret = $asset->$original(@args); - pop(@stack); - return $ret; - }, - 'WebGUI::Asset::duplicate' => sub { - my ($bar, $original, $asset, @args) = @_; - my $name = join '/', @stack, $asset->getTitle; - $bar->update($name); - return $asset->$original(@args); - }, - } - ); -} - -#------------------------------------------------------------------- -sub _wwwCopySingle { - my $self = shift; - my $newAsset = $self->duplicate({skipAutoCommitWorkflows => 1}); - my $redirect = $self->_wwwCopyFinish($newAsset); - return $redirect ? undef : $self->getContainer->www_view; + $http->setRedirect($self->getUrl($pairs)); + return 'redirect'; } #------------------------------------------------------------------- @@ -363,9 +438,8 @@ sub www_copyList { foreach my $assetId ($session->form->param("assetId")) { my $asset = WebGUI::Asset->newByDynamicClass($session,$assetId); if ($asset->canEdit) { - my $newAsset = $asset->duplicate({skipAutoCommitWorkflows => 1}); + my $newAsset = $asset->duplicate({skipAutoCommitWorkflows => 1, state => 'clipboard'}); $newAsset->update({ title=>$newAsset->getTitle.' (copy)'}); - $newAsset->cut; } } if ($self->session->form->process("proceed") ne "") { @@ -503,7 +577,7 @@ sub www_duplicateList { foreach my $assetId ($session->form->param("assetId")) { my $asset = WebGUI::Asset->newByDynamicClass($session,$assetId); if ($asset->canEdit) { - my $newAsset = $asset->duplicate({skipAutoCommitWorkflows => 1, }); + my $newAsset = $asset->duplicate({skipAutoCommitWorkflows => 1}); $newAsset->update({ title=>$newAsset->getTitle.' (copy)'}); } } @@ -657,25 +731,29 @@ sub www_pasteList { my $self = shift; my $session = $self->session; return $session->privilege->insufficient() unless $self->canEdit && $session->form->validToken; - my $form = $session->form; - my $pb = WebGUI::ProgressBar->new($session); - ##Need to store the list of assetIds for the status subroutine - my @assetIds = $form->param('assetId'); - ##Need to set the URL that should be displayed when it is done - my $i18n = WebGUI::International->new($session, 'Asset'); - $pb->start($i18n->get('Paste Assets'), $session->url->extras('adminConsole/assets.gif')); - ASSET: foreach my $clipId (@assetIds) { - next ASSET unless $clipId; - my $pasteAsset = WebGUI::Asset->newPending($session, $clipId); - if (! $pasteAsset && $pasteAsset->canEdit) { - $pb->update(sprintf $i18n->get('skipping %s'), $pasteAsset->getTitle); - next ASSET; - } - $self->paste($clipId, sub {$pb->update(@_);}); - } - return $pb->finish( ($form->param('proceed') eq 'manageAssets') ? $self->getUrl('op=assetManager') : $self->getUrl ); -} + my $form = $session->form; + my $process = WebGUI::Fork->start( + $session, 'WebGUI::Asset', 'pasteInBackground', { + assetId => $self->getId, + list => [ $form->get('assetId') ], + } + ); + + my $redir = $self->getUrl( + ($form->get('proceed') eq 'manageAssets') ? 'op=assetManager' : () + ); + my $i18n = WebGUI::International->new($session, 'Asset'); + my $pairs = $process->contentPairs( + 'ProgressTree', { + title => $i18n->get('Paste Assets'), + icon => 'assets', + proceed => $redir, + } + ); + $session->http->setRedirect($self->getUrl($pairs)); + return 'redirect'; +} 1; diff --git a/lib/WebGUI/AssetExportHtml.pm b/lib/WebGUI/AssetExportHtml.pm index 3f1d951f7..9bccdd535 100644 --- a/lib/WebGUI/AssetExportHtml.pm +++ b/lib/WebGUI/AssetExportHtml.pm @@ -24,6 +24,7 @@ use WebGUI::Utility (); use WebGUI::Session; use URI::URL; use Scope::Guard qw(guard); +use WebGUI::ProgressTree; =head1 NAME @@ -400,7 +401,7 @@ sub exportBranch { close $handle; $cs->var->end; $cs->close(); - $asset->$report('collateral notes', $output); + $asset->$report('collateral notes', $output) if $output; }; my $path = $asset->exportGetUrlAsPath; eval { $asset->exportAssetCollateral($path, $options, $cs) }; @@ -666,48 +667,33 @@ specified asset and keeps a json structure as the status. =cut sub exportInFork { - my ($process, $args) = @_; - my $self = WebGUI::Asset->new($process->session, delete $args->{assetId}); + my ( $process, $args ) = @_; + my $session = $process->session; + my $self = WebGUI::Asset->new( $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 $assetIds = $self->exportGetDescendants( undef, $args->{depth} ); + my $tree = WebGUI::ProgressTree->new( $session, $assetIds ); my %reports = ( - 'bad user privileges' => sub { shift->{badUserPrivileges} = 1 }, - 'not exportable' => sub { shift->{notExportable} = 1 }, - 'done' => sub { shift->{done} = 1 }, - 'exporting page' => sub { - my $hash = shift; - $hash->{current} = 1; - delete $last->{current}; - $last = $hash; + 'done' => sub { $tree->success(shift) }, + 'exporting page' => sub { $tree->focus(shift) }, + 'collateral notes' => sub { $tree->note(@_) }, + 'bad user privileges' => sub { + $tree->failure( shift, 'Bad User Privileges' ); }, - 'collateral notes' => sub { - my ($hash, $text) = @_; - $hash->{collateralNotes} = $text if $text; + 'not exportable' => sub { + $tree->failure( shift, 'Not Exportable' ); }, ); $args->{report} = sub { - my ($asset, $key, @args) = @_; + my ( $asset, $key, @args ) = @_; my $code = $reports{$key}; - my $hash = $flat{$asset->getId}; - $code->($hash, @args); - $process->update(sub { JSON::encode_json($tree) }); + $code->( $asset->getId, @args ); + $process->update( sub { $tree->json } ); }; $self->exportAsHtml($args); - delete $last->{current}; - $process->update(JSON::encode_json($tree)); -} + $tree->focus(undef); + $process->update( $tree->json ); +} ## end sub exportInFork #------------------------------------------------------------------- @@ -1036,7 +1022,12 @@ sub www_exportStatus { } ); $process->setGroup(13); - my $pairs = $process->contentPairs('AssetExport'); + my $i18n = WebGUI::International->new( $session, 'Asset' ); + my $pairs = $process->contentPairs('ProgressTree', { + icon => 'assets', + title => $i18n->get('Page Export Status'), + } + ); $session->http->setRedirect($self->getUrl($pairs)); return 'redirect'; } diff --git a/lib/WebGUI/Fork.pm b/lib/WebGUI/Fork.pm index 09b26473c..954bdc2d7 100644 --- a/lib/WebGUI/Fork.pm +++ b/lib/WebGUI/Fork.pm @@ -88,41 +88,59 @@ sub canView { my $user = shift || $session->user; $user = WebGUI::User->new( $session, $user ) unless eval { $user->isa('WebGUI::User') }; - return 1 if $user->isAdmin; - return $user->isInGroup( $self->getGroupId ); + return + $user->isAdmin + || $user->userId eq $self->getUserId + || $user->isInGroup( $self->getGroupId ); } #------------------------------------------------------------------- -=head2 contentPairs ($module, $pid) +=head2 contentPairs ($module, $pid, $extra) Returns a bit of query string useful for redirecting to a WebGUI::Operation::Fork plugin. $module should be the bit that comes after WebGUI::Operation::Fork, e.g. $process->contentPairs('Foo') should return something like "op=fork;module=Foo;pid=adlfjafo87ad9f78a7", which will -get dispatched to WebGUI::Operation::Fork::Foo::handler($process) +get dispatched to WebGUI::Operation::Fork::Foo::handler($process). + +$extra is an optional hashref that will add further parameters onto the list +of pairs, e.g. { foo => 'bar' } becomes ';foo=bar' =cut sub contentPairs { - my ( $self, $module ) = @_; - my $pid = $self->getId; - return "op=fork;module=$module;pid=$pid"; -} + my ( $self, $module, $extra ) = @_; + my $url = $self->session->url; + my $pid = $self->getId; + my %params = ( + op => 'fork', + module => $module, + pid => $self->getId, + $extra ? %$extra : () + ); + return join( + ';', + map { + my $k = $_; + join( '=', map { $url->escape($_) } ( $k, $params{$k} ) ); + } keys %params + ); +} ## end sub contentPairs #----------------------------------------------------------------- =head2 create ( ) -Internal class method. Creates a new Fork object and inserts a -blank row of data into the db. +Internal class method. Creates a new Fork object inserts it into the db. =cut sub create { my ( $class, $session ) = @_; my $id = $session->id->generate; - $session->db->setRow( $class->tableName, 'id', {}, $id ); + my %data = ( userId => $session->user->userId ); + $session->db->setRow( $class->tableName, 'id', \%data, $id ); bless { session => $session, id => $id }, $class; } @@ -275,9 +293,9 @@ sub forkAndExec { 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 if you're very careful. You should probably use -the accessors, though, since some of them have extra logic. +finished, groupId, userId. They all have more specific accessors, but you can +use this to get several at once if you're very careful. You should probably +use the accessors, though, since some of them have extra logic. =cut @@ -356,6 +374,16 @@ sub getStatus { #----------------------------------------------------------------- +=head2 getUserId + +Returns the userId of the user who initiated this Fork. + +=cut + +sub getUserId { $_[0]->get('userId') } + +#----------------------------------------------------------------- + =head2 init ( ) Spawn a master process from which Forks will fork(). The intent diff --git a/lib/WebGUI/Fork/AssetExport.pm b/lib/WebGUI/Fork/ProgressTree.pm similarity index 50% rename from lib/WebGUI/Fork/AssetExport.pm rename to lib/WebGUI/Fork/ProgressTree.pm index e7440d888..7a51e0e9c 100644 --- a/lib/WebGUI/Fork/AssetExport.pm +++ b/lib/WebGUI/Fork/ProgressTree.pm @@ -1,4 +1,4 @@ -package WebGUI::Fork::AssetExport; +package WebGUI::Fork::ProgressTree; =head1 LEGAL @@ -19,12 +19,12 @@ use warnings; =head1 NAME -WebGUI::Fork::AssetExport +WebGUI::Fork::ProgressTree =head1 DESCRIPTION Renders an admin console page that polls ::Status to draw a friendly graphical -representation of how an export is coming along. +representation of how progress on a tree of assets is coming along. =head1 SUBROUTINES @@ -33,77 +33,99 @@ These subroutines are available from this package: =cut use Template; +use HTML::Entities; +use JSON; my $template = <<'TEMPLATE';

-Currently exporting +

+
+
+
+
+Current asset: (/).
seconds elapsed. -

    -[% MACRO yui(file) BLOCK %] - -[% END %] +[% MACRO inc(file) BLOCK %][% END %] +[% MACRO yui(file) BLOCK %][% inc("yui/build/$file") %][% END %] [% yui("yahoo/yahoo-min.js") %] [% yui("json/json-min.js") %] [% yui("event/event-min.js") %] [% yui("connection/connection_core-min.js") %] +[% inc("underscore/underscore-min.js") %] TEMPLATE my $stylesheet = <<'STYLESHEET'; STYLESHEET @@ -157,17 +185,21 @@ sub handler { my $process = shift; my $session = $process->session; my $url = $session->url; + my $form = $session->form; my $tt = Template->new( { INTERPOLATE => 1 } ); my %vars = ( - statusUrl => $url->page( $process->contentPairs('Status') ), - extras => $session->url->extras, + params => JSON::encode_json( { + statusUrl => $url->page( $process->contentPairs('Status') ), + redirect => scalar $form->get('proceed'), + } + ), + extras => $url->extras, ); $tt->process( \$template, \%vars, \my $content ) or die $tt->error; - my $console = WebGUI::AdminConsole->new( $process->session, 'assets' ); + my $console = WebGUI::AdminConsole->new( $session, $form->get('icon') ); $session->style->setRawHeadTags($stylesheet); - my $i18n = WebGUI::International->new( $session, 'Asset' ); - return $console->render( $content, $i18n->get('Page Export Status') ); + return $console->render( $content, encode_entities( $form->get('title') ) ); } ## end sub handler 1; diff --git a/lib/WebGUI/ProgressTree.pm b/lib/WebGUI/ProgressTree.pm new file mode 100644 index 000000000..079907ba5 --- /dev/null +++ b/lib/WebGUI/ProgressTree.pm @@ -0,0 +1,172 @@ +package WebGUI::ProgressTree; + +use warnings; +use strict; + +=head1 NAME + +WebGUI::ProgressTree + +=head1 DESCRIPTION + +Helper functions for maintaining a JSON represtentation of the progress of an +operation that modifies a tree of assets. See WebGUI::Fork::ProgressTree for a +status page that renders this. + +=head1 SYNOPSIS + + my $tree = WebGUI::ProgressTree->new($session, \@assetIds); + $tree->success($assetId); + $tree->failure($assetId, $reason); + $tree->note($assetId, 'something about this one...'); + +=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 new ($session, $assetIds) + +Constructs new tree object for tracking the progress of $assetIds. + +=cut + +sub new { + my ( $class, $session, $assetIds ) = @_; + my $db = $session->db; + my $dbh = $db->dbh; + my $set = join( ',', map { $dbh->quote($_) } @$assetIds ); + my $sql = qq{ + SELECT a.assetId, a.parentId, d.url + FROM asset a INNER JOIN assetData d ON a.assetId = d.assetId + WHERE a.assetId IN ($set) + ORDER BY a.lineage ASC, d.revisionDate DESC + }; + my $sth = $db->read($sql); + my ( %flat, @roots ); + + while ( my $asset = $sth->hashRef ) { + my ( $id, $parentId ) = delete @{$asset}{ 'assetId', 'parentId' }; + + # We'll get back multiple rows for each asset, but the first one is + # the latest. Skip the others. + next if $flat{$id}; + $flat{$id} = $asset; + if ( my $parent = $flat{$parentId} ) { + push( @{ $parent->{children} }, $asset ); + } + else { + push( @roots, $asset ); + } + } + my $self = { + session => $session, + tree => \@roots, + flat => \%flat, + }; + bless $self, $class; +} ## end sub new + +#------------------------------------------------------------------- + +=head2 success ($assetId) + +Whatever we were doing to $assetId succeeded. Woohoo! + +=cut + +sub success { + my ( $self, $assetId ) = @_; + $self->{flat}->{$assetId}->{success} = 1; +} + +#------------------------------------------------------------------- + +=head2 failure ($assetId, $reason) + +Whatever we were doing to $assetId didn't work for $reason. Aww. + +=cut + +sub failure { + my ( $self, $assetId, $reason ) = @_; + $self->{flat}->{$assetId}->{failure} = $reason; +} + +#------------------------------------------------------------------- + +=head2 note ($assetId, $note) + +Add some extra text. WebGUI::Fork::ProgressTree displays these as paragraphs +under the node for this asset. + +=cut + +sub note { + my ( $self, $assetId, $note ) = @_; + push( @{ $self->{flat}->{$assetId}->{notes} }, $note ); +} + +#------------------------------------------------------------------- + +=head2 focus ($assetId) + +Make a note that this is the asset that we are currently doing something with. + +=cut + +sub focus { + my ( $self, $assetId ) = @_; + if ( my $last = delete $self->{last} ) { + delete $last->{focus}; + } + if ($assetId) { + my $focus = $self->{last} = $self->{flat}->{$assetId}; + $focus->{focus} = 1; + } +} + +#------------------------------------------------------------------- + +=head2 tree + +A hashy representation of the status of this tree of assets. + +=cut + +sub tree { $_[0]->{tree} } + +#------------------------------------------------------------------- + +=head2 json + +$self->tree encoded as json. + +=cut + +sub json { JSON::encode_json( $_[0]->tree ) } + +#------------------------------------------------------------------- + +=head2 session + +The WebGUI::Session this progress tree is associated with. + +=cut + +sub session { $_[0]->{session} } + +1; diff --git a/lib/WebGUI/VersionTag.pm b/lib/WebGUI/VersionTag.pm index cc5b8afb5..eba44462a 100644 --- a/lib/WebGUI/VersionTag.pm +++ b/lib/WebGUI/VersionTag.pm @@ -37,6 +37,23 @@ These methods are available from this class: =cut +#------------------------------------------------------------------- + +=head2 autoCommitUrl ( $base ) + +Returns the url autoCommitWorkingIfEnabled would redirect to if it were going +to. + +=cut + +sub autoCommitUrl { + my $self = shift; + my $session = $self->session; + my $url = $session->url; + my $base = shift || $url->page; + my $id = $self->getId; + return $url->append($base, "op=commitVersionTag;tagId=$id"); +} #------------------------------------------------------------------- @@ -75,25 +92,13 @@ sub autoCommitWorkingIfEnabled { return undef unless $versionTag; - #Auto commit is no longer determined from autoRequestCommit - - # auto commit assets - # save and commit button and site wide auto commit work the same - # Do not auto commit if tag is system wide tag or tag belongs to someone else - if ( - $options->{override} - || ( $class->getVersionTagMode($session) eq q{autoCommit} - && ! $versionTag->get(q{isSiteWide}) - && $versionTag->get(q{createdBy}) eq $session->user()->userId() - ) - ) { + if ($options->{override} || $versionTag->canAutoCommit) { if ($session->setting->get("skipCommitComments") || !$options->{allowComments}) { $versionTag->requestCommit; return 'commit'; } else { - my $url = $options->{returnUrl} || $session->url->page; - $url = $session->url->append($url, "op=commitVersionTag;tagId=" . $versionTag->getId); + my $url = $versionTag->autoCommitUrl($options->{returnUrl}); $session->http->setRedirect($url); return 'redirect'; } @@ -103,6 +108,24 @@ sub autoCommitWorkingIfEnabled { #------------------------------------------------------------------- +=head2 canAutoCommit + +Returns true if we would autocommit this tag without an override. + +=cut + +sub canAutoCommit { + my $self = shift; + my $session = $self->session; + my $class = ref $self; + my $mode = $class->getVersionTagMode($session); + return $mode eq 'autoCommit' + && !$self->get('isSiteWide') + && $self->get('createdBy') eq $session->user->userId; +} + +#------------------------------------------------------------------- + =head2 clearWorking ( ) Makes it so this tag is no longer the working tag for any user. diff --git a/sbin/testEnvironment.pl b/sbin/testEnvironment.pl index 3572dafc9..f550d4da8 100755 --- a/sbin/testEnvironment.pl +++ b/sbin/testEnvironment.pl @@ -145,6 +145,7 @@ checkModule("CHI", "0.34" ); checkModule('IO::Socket::SSL', ); checkModule('Net::Twitter', "3.13006" ); checkModule('PerlIO::eol', "0.14" ); +checkModule('Monkey::Patch', '0.3' ); failAndExit("Required modules are missing, running no more checks.") if $missingModule; From 895ce3791785f20460ef1a4a7a4600fb71ed4189 Mon Sep 17 00:00:00 2001 From: Paul Driver Date: Mon, 4 Oct 2010 15:51:23 -0700 Subject: [PATCH 06/16] Move trash functions to Fork --- docs/changelog/7.x.x.txt | 1 + lib/WebGUI/Asset.pm | 48 +++++++++ lib/WebGUI/Asset/Template.pm | 2 +- lib/WebGUI/AssetClipboard.pm | 132 +++++++++++------------ lib/WebGUI/AssetExportHtml.pm | 21 ++-- lib/WebGUI/AssetTrash.pm | 196 +++++++++++++++++++++++----------- lib/WebGUI/Fork.pm | 8 +- 7 files changed, 257 insertions(+), 151 deletions(-) diff --git a/docs/changelog/7.x.x.txt b/docs/changelog/7.x.x.txt index 889226c90..2ccd67b87 100644 --- a/docs/changelog/7.x.x.txt +++ b/docs/changelog/7.x.x.txt @@ -4,6 +4,7 @@ - Added WebGUI::Fork api - Moved html export to Fork - Moved clipboard functions to Fork + - Moved trash functions to Fork - fixed #11884: Editing Templates impossible / Code editor not loaded - recommitted ukplayer. Removal broke Matrix. Licencing information was available but overlooked. - fixed #11883: Wiki "Add page" link does not encode special chars diff --git a/lib/WebGUI/Asset.pm b/lib/WebGUI/Asset.pm index 4c86c7353..b1d1a15bc 100644 --- a/lib/WebGUI/Asset.pm +++ b/lib/WebGUI/Asset.pm @@ -835,6 +835,54 @@ sub fixUrlFromParent { return $url; } +#------------------------------------------------------------------- + +=head2 forkWithProgressTree ($args) + +Kicks off a WebGUI::Fork running $method with $args (from the args hashref) +and redirects to a ProgressTree status page to show the progress. The +following arguments are required in $args: + +=head3 method + +The name of the WebGUI::Asset method to call + +=head3 args + +The arguments to pass that method (see WebGUI::Fork) + +=head3 title + +An key in Asset's i18n hash for the title of the rendered console page + +=head3 redirect + +The full url to redirect to after the fork has finished. + +=cut + +sub forkWithProgressTree { + my ( $self, $args ) = @_; + my $session = $self->session; + + my $process = WebGUI::Fork->start( $session, 'WebGUI::Asset', $args->{method}, $args->{args} ); + + if ( my $groupId = $args->{groupId} ) { + $process->setGroup($groupId); + } + + my $method = $session->form->get('proceed') || 'manageTrash'; + my $i18n = WebGUI::International->new( $session, 'Asset' ); + my $pairs = $process->contentPairs( + 'ProgressTree', { + title => $i18n->get( $args->{title} ), + icon => 'assets', + proceed => $args->{redirect} || '', + } + ); + $session->http->setRedirect( $self->getUrl($pairs) ); + return 'redirect'; +} ## end sub forkWithProgressTree #------------------------------------------------------------------- diff --git a/lib/WebGUI/Asset/Template.pm b/lib/WebGUI/Asset/Template.pm index 265d8a278..7749bc0a3 100644 --- a/lib/WebGUI/Asset/Template.pm +++ b/lib/WebGUI/Asset/Template.pm @@ -212,7 +212,7 @@ copy. sub duplicate { my $self = shift; - my $newTemplate = $self->SUPER::duplicate; + my $newTemplate = $self->SUPER::duplicate(@_); $newTemplate->update({isDefault => 0}); if ( my $storageId = $self->get('storageIdExample') ) { my $newStorage = WebGUI::Storage->get( $self->session, $storageId )->copy; diff --git a/lib/WebGUI/AssetClipboard.pm b/lib/WebGUI/AssetClipboard.pm index 2bb5c7609..52b4c98aa 100644 --- a/lib/WebGUI/AssetClipboard.pm +++ b/lib/WebGUI/AssetClipboard.pm @@ -51,13 +51,13 @@ sub canPaste { #------------------------------------------------------------------- -=head2 copyInBackground ( $process, $args ) +=head2 copyInFork ( $process, $args ) WebGUI::Fork method called by www_copy =cut -sub copyInBackground { +sub copyInFork { my ($process, $args) = @_; my $session = $process->session; my $asset = WebGUI::Asset->new($session, $args->{assetId}); @@ -72,23 +72,26 @@ sub copyInBackground { } my $ids = $asset->getLineage(\@pedigree); my $tree = WebGUI::ProgressTree->new($session, $ids); - my $patch = Monkey::Patch::patch_class 'WebGUI::Asset', 'duplicate', sub { - my $duplicate = shift; - my $self = shift; - my $id = $self->getId; - my $asset = eval { $self->$duplicate(@_) }; - my $e = $@; - if ($e) { - $tree->note($id, $e); - $tree->failure($id, 'Died'); + my $patch = Monkey::Patch::patch_class( + 'WebGUI::Asset', 'duplicate', sub { + my $duplicate = shift; + my $self = shift; + my $id = $self->getId; + $tree->focus($id); + my $asset = eval { $self->$duplicate(@_) }; + my $e = $@; + if ($e) { + $tree->note($id, $e); + $tree->failure($id, 'Died'); + } + else { + $tree->success($id); + } + $process->update(sub { $tree->json }); + die $e if $e; + return $asset; } - else { - $tree->success($id); - } - $process->update(sub { $tree->json }); - die $e if $e; - return $asset; - }; + ); my $newAsset = $asset->duplicateBranch($childrenOnly, 'clipboard'); $newAsset->update({ title => $newAsset->getTitle . ' (copy)'}); if ($args->{commit}) { @@ -303,53 +306,50 @@ sub paste { #------------------------------------------------------------------- -=head2 pasteInBackground ( ) +=head2 pasteInFork ( ) WebGUI::Fork method called by www_pasteList =cut -sub pasteInBackground { - my ($process, $args) = @_; +sub pasteInFork { + my ( $process, $args ) = @_; my $session = $process->session; - my $self = WebGUI::Asset->new($session, $args->{assetId}); + my $self = WebGUI::Asset->new( $session, $args->{assetId} ); my @roots = grep { $_ && $_->canEdit } - map { WebGUI::Asset->newPending($session, $_) } - @{ $args->{list} }; + map { WebGUI::Asset->newPending( $session, $_ ) } @{ $args->{list} }; - my @ids; - for my $r (@roots) { - my $these = $r->getLineage( - ['self', 'descendants'], { - statesToInclude => ['clipboard', 'clipboard-limbo'] - } - ); - push(@ids, @$these); - } + my @ids = map { + my $list + = $_->getLineage( [ 'self', 'descendants' ], { statesToInclude => [ 'clipboard', 'clipboard-limbo' ] } ); + @$list; + } @roots; - my $tree = WebGUI::ProgressTree->new($session, \@ids); + my $tree = WebGUI::ProgressTree->new( $session, \@ids ); my $patch = Monkey::Patch::patch_class( - 'WebGUI::Asset', 'indexContent', sub { + 'WebGUI::Asset', + 'indexContent', + sub { my $indexContent = shift; my $self = shift; my $id = $self->getId; $tree->focus($id); my $ret = eval { $self->$indexContent(@_) }; - my $e = $@; + my $e = $@; if ($e) { - $tree->note($id, $e); - $tree->failure($id, 'Died'); + $tree->note( $id, $e ); + $tree->failure( $id, 'Died' ); } else { $tree->success($id); } - $process->update(sub { $tree->json }); + $process->update( sub { $tree->json } ); die $e if $e; return $ret; } ); - $self->paste($_->getId) for @roots; -} + $self->paste( $_->getId ) for @roots; +} ## end sub pasteInFork #------------------------------------------------------------------- @@ -400,19 +400,13 @@ sub www_copy { } $args{assetId} = $self->getId; - my $process = WebGUI::Fork->start( - $session, 'WebGUI::Asset', 'copyInBackground', \%args - ); - my $i18n = WebGUI::International->new($session, 'Asset'); - my $pairs = $process->contentPairs( - 'ProgressTree', { - title => $i18n->get('Copy Assets'), - icon => 'assets', - proceed => $redir + $self->forkWithProgressTree({ + title => 'Copy Assets', + redirect => $redir, + method => 'copyInFork', + args => \%args } ); - $http->setRedirect($self->getUrl($pairs)); - return 'redirect'; } #------------------------------------------------------------------- @@ -730,30 +724,24 @@ the Asset Manager. sub www_pasteList { my $self = shift; my $session = $self->session; + my $form = $session->form; return $session->privilege->insufficient() unless $self->canEdit && $session->form->validToken; - my $form = $session->form; - my $process = WebGUI::Fork->start( - $session, 'WebGUI::Asset', 'pasteInBackground', { - assetId => $self->getId, - list => [ $form->get('assetId') ], + $self->forkWithProgressTree( { + title => 'Paste Assets', + redirect => $self->getUrl( + $form->get('proceed') eq 'manageAssets' + ? 'op=assetManager' + : () + ), + method => 'pasteInFork', + args => { + assetId => $self->getId, + list => [ $form->get('assetId') ], + } } ); - - my $redir = $self->getUrl( - ($form->get('proceed') eq 'manageAssets') ? 'op=assetManager' : () - ); - my $i18n = WebGUI::International->new($session, 'Asset'); - my $pairs = $process->contentPairs( - 'ProgressTree', { - title => $i18n->get('Paste Assets'), - icon => 'assets', - proceed => $redir, - } - ); - $session->http->setRedirect($self->getUrl($pairs)); - return 'redirect'; -} +} ## end sub www_pasteList 1; diff --git a/lib/WebGUI/AssetExportHtml.pm b/lib/WebGUI/AssetExportHtml.pm index 9bccdd535..160ab19b4 100644 --- a/lib/WebGUI/AssetExportHtml.pm +++ b/lib/WebGUI/AssetExportHtml.pm @@ -1015,21 +1015,16 @@ sub www_exportStatus { my @vars = qw( index depth userId extrasUploadsAction rootUrlAction exportUrl ); - my $process = WebGUI::Fork->start( - $session, 'WebGUI::Asset', 'exportInFork', { - assetId => $self->getId, - map { $_ => scalar $form->get($_) } @vars + $self->forkWithProgressTree({ + title => 'Page Export Status', + method => 'exportInFork', + groupId => 13, + args => { + assetId => $self->getId, + map { $_ => scalar $form->get($_) } @vars + } } ); - $process->setGroup(13); - my $i18n = WebGUI::International->new( $session, 'Asset' ); - my $pairs = $process->contentPairs('ProgressTree', { - icon => 'assets', - title => $i18n->get('Page Export Status'), - } - ); - $session->http->setRedirect($self->getUrl($pairs)); - return 'redirect'; } #------------------------------------------------------------------- diff --git a/lib/WebGUI/AssetTrash.pm b/lib/WebGUI/AssetTrash.pm index f6c7110a5..c44e22f8f 100644 --- a/lib/WebGUI/AssetTrash.pm +++ b/lib/WebGUI/AssetTrash.pm @@ -200,6 +200,63 @@ sub purge { return 1; } +#------------------------------------------------------------------- + +=head2 purgeInFork + +WebGUI::Fork method called by www_purgeList + +=cut + +sub purgeInFork { + my ( $process, $list ) = @_; + my $session = $process->session; + my @roots = grep { $_ && $_->canEdit } + map { WebGUI::Asset->newPending( $session, $_ ) } @$list; + + my @ids = map { + my $list = $_->getLineage( + [ 'self', 'descendants' ], { + statesToInclude => [qw(published clipboard clipboard-limbo trash trash-limbo)], + statusToInclude => [qw(approved archived pending)], + } + ); + @$list; + } @roots; + + my $tree = WebGUI::ProgressTree->new( $session, \@ids ); + my $patch = Monkey::Patch::patch_class( + 'WebGUI::Asset', + 'purge', + sub { + my ( $purge, $self, $options ) = @_; + my $id = $self->getId; + my $zero = ''; + $tree->focus($id); + $options ||= {}; + local $options->{outputSub} = sub { $zero .= $_[0] }; + my $ret = eval { $self->$purge($options) }; + my $e = $@; + $tree->focus($id); + + if ($e) { + $tree->failure( $id, 'Died' ); + $tree->note( $id, $e ); + } + elsif ( !$ret ) { + $tree->failure( $id, 'Failed' ); + $tree->note( $id, $zero ); + } + else { + $tree->success($id); + } + $process->update( sub { $tree->json } ); + die $e if $e; + return $ret; + } + ); + $_->purge for @roots; +} ## end sub purgeInFork #------------------------------------------------------------------- @@ -246,7 +303,15 @@ sub trash { return undef; } - my $assetIter = $self->getLineageIterator(['self','descendants']); + my $assetIter = $self->getLineageIterator( + ['self','descendants'], { + statesToInclude => [qw(published clipboard clipboard-limbo trash trash-limbo)], + statusToInclude => [qw(approved archived pending)], + } + ); + my $rootId = $self->getId; + my $db = $session->db; + $db->beginTransaction; while ( 1 ) { my $asset; eval { $asset = $assetIter->() }; @@ -263,7 +328,9 @@ sub trash { $outputSub->($i18n->get('Clearing cache')); $asset->purgeCache; $asset->updateHistory("trashed"); + $asset->setState($asset->getId eq $rootId ? 'trash' : 'trash-limbo'); } + $db->commit; # Trash any shortcuts to this asset my $shortcuts @@ -273,16 +340,6 @@ sub trash { $shortcut->trash({ outputSub => $outputSub, }); } - # Raw database work is more efficient than $asset->update - my $db = $session->db; - $db->beginTransaction; - $outputSub->($i18n->get('Clearing asset tables')); - $db->write("update asset set state='trash-limbo' where lineage like ?",[$self->get("lineage").'%']); - $db->write("update asset set state='trash', stateChangedBy=?, stateChanged=? where assetId=?",[$session->user->userId, time(), $self->getId]); - $db->commit; - - # Update ourselves since we didn't use update() - $self->{_properties}{state} = "trash"; return 1; } @@ -315,7 +372,7 @@ sub _invokeWorkflowOnExportedFiles { =head2 www_delete -Moves self to trash, returns www_view() method of Container or Parent if canEdit. +Moves self to trash in fork, redirects to Container or Parent if canEdit. Otherwise returns AdminConsole rendered insufficient privilege. =cut @@ -325,13 +382,18 @@ sub www_delete { return $self->session->privilege->insufficient() unless ($self->canEdit && $self->canEditIfLocked); return $self->session->privilege->vitalComponent() if $self->get('isSystem'); return $self->session->privilege->vitalComponent() if (isIn($self->getId, $self->session->setting->get("defaultPage"), $self->session->setting->get("notFoundPage"))); - $self->trash; + my $asset = $self->getContainer; if ($self->getId eq $asset->getId) { $asset = $self->getParent; } - $self->session->asset($asset); - return $asset->www_view; + $self->forkWithProgressTree({ + title => 'Delete Assets', + redirect => $asset->getUrl, + method => 'trashInFork', + args => [ $self->getId ], + } + ); } #------------------------------------------------------------------- @@ -343,35 +405,57 @@ Checks to see if a valid CSRF token was received. If not, then it returns insuf Moves list of assets to trash, checking each to see if the user canEdit, and canEditIfLocked. Returns the user to manageTrash, or to the screen set by the form variable C. - =cut -sub www_deleteList { - my $self = shift; - my $session = $self->session; - my $pb = WebGUI::ProgressBar->new($session); - my $i18n = WebGUI::International->new($session, 'Asset'); - my $form = $session->form; - my @assetIds = $form->param('assetId'); - $pb->start($i18n->get('Delete Assets'), $session->url->extras('adminConsole/assets.gif')); - return $self->session->privilege->insufficient() unless $session->form->validToken; - ASSETID: foreach my $assetId (@assetIds) { - my $asset = eval { WebGUI::Asset->newPending($session,$assetId); }; - if ($@) { - $pb->update(sprintf $i18n->get('Error getting asset with assetId %s'), $assetId); - next ASSETID; - } - if (! ($asset->canEdit && $asset->canEditIfLocked) ) { - $pb->update(sprintf $i18n->get('You cannot edit the asset %s, skipping'), $asset->getTitle); - } - else { - $asset->trash({outputSub => sub { $pb->update(@_); } }); - } - } - my $method = ($session->form->process("proceed")) ? $session->form->process('proceed') : 'manageTrash'; - $pb->finish($self->getUrl('func='.$method)); -} +sub trashInFork { + my ( $process, $list ) = @_; + my $session = $process->session; + my @roots = grep { $_->canEdit && $_->canEditIfLocked } + map { + eval { WebGUI::Asset->newPending( $session, $_ ) } + } @$list; + my @ids = map { + my $list = $_->getLineage( + [ 'self', 'descendants' ], { + statesToInclude => [qw(published clipboard clipboard-limbo trash trash-limbo)], + statusToInclude => [qw(approved archived pending)], + } + ); + @$list; + } @roots; + + my $tree = WebGUI::ProgressTree->new( $session, \@ids ); + my $patch = Monkey::Patch::patch_class( + 'WebGUI::Asset', + 'setState', + sub { + my ( $setState, $self, $state ) = @_; + my $id = $self->getId; + $tree->focus($id); + my $ret = $self->$setState($state); + $tree->success($id); + $process->update(sub { $tree->json }); + return $ret; + } + ); + $_->trash() for @roots; +} ## end sub trashInFork + +sub www_deleteList { + my $self = shift; + my $session = $self->session; + my $form = $session->form; + return $session->privilege->insufficient() unless $session->form->validToken; + my $method = $form->get('proceed') || 'manageTrash'; + $self->forkWithProgressTree({ + title => 'Delete Assets', + redirect => $self->getUrl("func=$method"), + method => 'trashInFork', + args => [ $form->get('assetId') ], + } + ); +} ## end sub www_deleteList #------------------------------------------------------------------- @@ -478,29 +562,17 @@ Returns insufficient privileges unless the submitted form passes the validToken sub www_purgeList { my $self = shift; my $session = $self->session; + my $form = $session->form; return $session->privilege->insufficient() unless $session->form->validToken; - my $pb = WebGUI::ProgressBar->new($session); - my $i18n = WebGUI::International->new($session, 'Asset'); - $pb->start($i18n->get('purge'), $session->url->extras('adminConsole/assets.gif')); - - ASSETID: foreach my $id ($session->form->param("assetId")) { - my $asset = eval { WebGUI::Asset->newPending($session,$id); }; - if ($@) { - $pb->update(sprintf $i18n->get('Error getting asset with assetId %s'), $id); - next ASSETID; + my $method = $form->get('proceed') || 'manageTrash'; + $method .= ';systemTrash=1' if $form->get('systemTrash'); + $self->forkWithProgressTree({ + title => 'purge', + redirect => $self->getUrl("func=$method"), + method => 'purgeInFork', + args => [ $form->get('assetId') ], } - if (! $asset->canEdit) { - $pb->update(sprintf $i18n->get('You cannot edit the asset %s, skipping'), $asset->getTitle); - } - else { - $asset->purge({outputSub => sub { $pb->update(@_); } }); - } - } - my $method = ($session->form->process("proceed")) ? $session->form->process('proceed') : 'manageTrash'; - if ($session->form->process('systemTrash') ) { - $method .= ';systemTrash=1'; - } - $pb->finish($self->getUrl('func='.$method)); + ); } #------------------------------------------------------------------- diff --git a/lib/WebGUI/Fork.pm b/lib/WebGUI/Fork.pm index 954bdc2d7..babcf0c5a 100644 --- a/lib/WebGUI/Fork.pm +++ b/lib/WebGUI/Fork.pm @@ -278,11 +278,11 @@ sub forkAndExec { my $class = ref $self; my $json = JSON::encode_json($request); my @inc = map {"-I$_"} @INC; - my @argv = ( "webgui-fork-$id", @inc, "-M$class", "-e$class->runCmd()" ); + my @argv = (@inc, "-M$class", "-e$class->runCmd()" ); $class->daemonize( $json, sub { - exec { $Config{perlpath} } @argv or die "Could not exec: $!"; + exec ($Config{perlpath}, @argv) or die "Could not exec: $!"; } ); } @@ -541,8 +541,10 @@ sub runRequest { my ( $class, $args ) = @_; my ( $root, $config, $sid ) = @{$args}{qw(webguiRoot configFile sessionId)}; my $session = WebGUI::Session->open( $root, $config, undef, undef, $sid ); - my $self = $class->new( $session, $args->{id} ); + my $id = $args->{id}; + my $self = $class->new( $session, $id ); $self->set( { startTime => time } ); + $0 = "webgui-fork-$id"; eval { my ( $module, $subname, $data ) = @{$args}{qw(module subname data)}; WebGUI::Pluggable::run( $module, $subname, [ $self, $data ] ); From 04fa1ca7945d4ebbb688436782ef092e2e734074 Mon Sep 17 00:00:00 2001 From: Paul Driver Date: Wed, 6 Oct 2010 08:51:27 -0700 Subject: [PATCH 07/16] VersionTag rollback moved to Fork --- lib/WebGUI/Asset.pm | 12 ++- lib/WebGUI/AssetClipboard.pm | 6 +- lib/WebGUI/AssetExportHtml.pm | 3 +- lib/WebGUI/AssetTrash.pm | 9 ++- lib/WebGUI/Fork.pm | 5 +- lib/WebGUI/Fork/ProgressBar.pm | 126 +++++++++++++++++++++++++++++ lib/WebGUI/Fork/ProgressTree.pm | 111 ++++++------------------- lib/WebGUI/Operation/VersionTag.pm | 74 +++++++++++++++-- 8 files changed, 241 insertions(+), 105 deletions(-) create mode 100644 lib/WebGUI/Fork/ProgressBar.pm diff --git a/lib/WebGUI/Asset.pm b/lib/WebGUI/Asset.pm index b1d1a15bc..20651535d 100644 --- a/lib/WebGUI/Asset.pm +++ b/lib/WebGUI/Asset.pm @@ -837,7 +837,7 @@ sub fixUrlFromParent { #------------------------------------------------------------------- -=head2 forkWithProgressTree ($args) +=head2 forkWithStatusPage ($args) Kicks off a WebGUI::Fork running $method with $args (from the args hashref) and redirects to a ProgressTree status page to show the progress. The @@ -851,6 +851,10 @@ The name of the WebGUI::Asset method to call The arguments to pass that method (see WebGUI::Fork) +=head3 plugin + +The WebGUI::Operation::Fork plugin to render (e.g. ProgressTree) + =head3 title An key in Asset's i18n hash for the title of the rendered console page @@ -861,7 +865,7 @@ The full url to redirect to after the fork has finished. =cut -sub forkWithProgressTree { +sub forkWithStatusPage { my ( $self, $args ) = @_; my $session = $self->session; @@ -874,7 +878,7 @@ sub forkWithProgressTree { my $method = $session->form->get('proceed') || 'manageTrash'; my $i18n = WebGUI::International->new( $session, 'Asset' ); my $pairs = $process->contentPairs( - 'ProgressTree', { + $args->{plugin}, { title => $i18n->get( $args->{title} ), icon => 'assets', proceed => $args->{redirect} || '', @@ -882,7 +886,7 @@ sub forkWithProgressTree { ); $session->http->setRedirect( $self->getUrl($pairs) ); return 'redirect'; -} ## end sub forkWithProgressTree +} ## end sub forkWithStatusPage #------------------------------------------------------------------- diff --git a/lib/WebGUI/AssetClipboard.pm b/lib/WebGUI/AssetClipboard.pm index 52b4c98aa..3185fd9de 100644 --- a/lib/WebGUI/AssetClipboard.pm +++ b/lib/WebGUI/AssetClipboard.pm @@ -400,7 +400,8 @@ sub www_copy { } $args{assetId} = $self->getId; - $self->forkWithProgressTree({ + $self->forkWithStatusPage({ + plugin => 'ProgressTree', title => 'Copy Assets', redirect => $redir, method => 'copyInFork', @@ -727,7 +728,8 @@ sub www_pasteList { my $form = $session->form; return $session->privilege->insufficient() unless $self->canEdit && $session->form->validToken; - $self->forkWithProgressTree( { + $self->forkWithStatusPage( { + plugin => 'ProgressTree', title => 'Paste Assets', redirect => $self->getUrl( $form->get('proceed') eq 'manageAssets' diff --git a/lib/WebGUI/AssetExportHtml.pm b/lib/WebGUI/AssetExportHtml.pm index 160ab19b4..dca2f5b53 100644 --- a/lib/WebGUI/AssetExportHtml.pm +++ b/lib/WebGUI/AssetExportHtml.pm @@ -1015,7 +1015,8 @@ sub www_exportStatus { my @vars = qw( index depth userId extrasUploadsAction rootUrlAction exportUrl ); - $self->forkWithProgressTree({ + $self->forkWithStatusPage({ + plugin => 'ProgressTree', title => 'Page Export Status', method => 'exportInFork', groupId => 13, diff --git a/lib/WebGUI/AssetTrash.pm b/lib/WebGUI/AssetTrash.pm index c44e22f8f..f097db9b3 100644 --- a/lib/WebGUI/AssetTrash.pm +++ b/lib/WebGUI/AssetTrash.pm @@ -387,7 +387,8 @@ sub www_delete { if ($self->getId eq $asset->getId) { $asset = $self->getParent; } - $self->forkWithProgressTree({ + $self->forkWithStatusPage({ + plugin => 'ProgressTree', title => 'Delete Assets', redirect => $asset->getUrl, method => 'trashInFork', @@ -448,7 +449,8 @@ sub www_deleteList { my $form = $session->form; return $session->privilege->insufficient() unless $session->form->validToken; my $method = $form->get('proceed') || 'manageTrash'; - $self->forkWithProgressTree({ + $self->forkWithStatusPage({ + plugin => 'ProgressTree', title => 'Delete Assets', redirect => $self->getUrl("func=$method"), method => 'trashInFork', @@ -566,7 +568,8 @@ sub www_purgeList { return $session->privilege->insufficient() unless $session->form->validToken; my $method = $form->get('proceed') || 'manageTrash'; $method .= ';systemTrash=1' if $form->get('systemTrash'); - $self->forkWithProgressTree({ + $self->forkWithStatusPage({ + plugin => 'ProgressTree', title => 'purge', redirect => $self->getUrl("func=$method"), method => 'purgeInFork', diff --git a/lib/WebGUI/Fork.pm b/lib/WebGUI/Fork.pm index babcf0c5a..0c3f62dc0 100644 --- a/lib/WebGUI/Fork.pm +++ b/lib/WebGUI/Fork.pm @@ -355,7 +355,7 @@ Signals the fork that it should report its next status, then polls at a configurable, fractional interval (default: .1 seconds) waiting for the fork 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). +entirely). We will only wait for a maximum of 100 intervals. =cut @@ -363,7 +363,8 @@ sub getStatus { my $self = shift; if ( my $interval = $self->{interval} ) { $self->set( { latch => 1 } ); - while (1) { + my $maxWait; + while ($maxWait++ < 100) { sleep $interval; my ( $finished, $latch ) = $self->get( 'finished', 'latch' ); last if $finished || !$latch; diff --git a/lib/WebGUI/Fork/ProgressBar.pm b/lib/WebGUI/Fork/ProgressBar.pm new file mode 100644 index 000000000..312ddc299 --- /dev/null +++ b/lib/WebGUI/Fork/ProgressBar.pm @@ -0,0 +1,126 @@ +package WebGUI::Fork::ProgressBar; + +=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::Fork::ProgressBar + +=head1 DESCRIPTION + +Renders an admin console page that polls ::Status to draw a simple progress +bar along with some kind of message. + +=head1 SUBROUTINES + +These subroutines are available from this package: + +=cut + +use Template; +use HTML::Entities; +use JSON; + +my $template = <<'TEMPLATE'; +

    +
    +

    Time elapsed: seconds.

    + +TEMPLATE + +#------------------------------------------------------------------- + +=head2 handler ( process ) + +See WebGUI::Operation::Fork. + +=cut + +sub handler { renderBar( shift, $template ) } + +#------------------------------------------------------------------- + +=head2 renderBar ( process, template ) + +Renders $template, passing a "params" variable to it that is JSON of a +statusUrl to poll and a page to redirect to. Includes WebGUI.Fork.redirect, +poll, and ProgressBar js and CSS (as well as all their YUI dependancies), and +puts the whole template inside an adminConsole rendered based off some form +parameters. + +=cut + +sub renderBar { + my ( $process, $template ) = @_; + my $session = $process->session; + my $url = $session->url; + my $form = $session->form; + my $style = $session->style; + my $tt = Template->new; + my %vars = ( + params => JSON::encode_json( { + statusUrl => $url->page( $process->contentPairs('Status') ), + redirect => scalar $form->get('proceed'), + } + ), + ); + $tt->process( \$template, \%vars, \my $content ) or die $tt->error; + + my $console = WebGUI::AdminConsole->new( $session, $form->get('icon') ); + $style->setLink( $url->extras("Fork/ProgressBar.css"), { rel => 'stylesheet' } ); + $style->setScript( $url->extras("$_.js") ) + for ( ( + map {"yui/build/$_"} + qw( + yahoo/yahoo-min + dom/dom-min + json/json-min + event/event-min + connection/connection_core-min + ) + ), + 'Fork/ProgressBar', + 'Fork/poll', + 'Fork/redirect' + ); + return $console->render( $content, encode_entities( $form->get('title') ) ); +} ## end sub renderBar + +1; diff --git a/lib/WebGUI/Fork/ProgressTree.pm b/lib/WebGUI/Fork/ProgressTree.pm index 7a51e0e9c..46146119e 100644 --- a/lib/WebGUI/Fork/ProgressTree.pm +++ b/lib/WebGUI/Fork/ProgressTree.pm @@ -35,42 +35,18 @@ These subroutines are available from this package: use Template; use HTML::Entities; use JSON; +use WebGUI::Fork::ProgressBar; my $template = <<'TEMPLATE'; -

    -

    -
    -
    -
    -
    +
    Current asset: (/).
    seconds elapsed.
      -[% MACRO inc(file) BLOCK %][% END %] -[% MACRO yui(file) BLOCK %][% inc("yui/build/$file") %][% END %] -[% yui("yahoo/yahoo-min.js") %] -[% yui("json/json-min.js") %] -[% yui("event/event-min.js") %] -[% yui("connection/connection_core-min.js") %] -[% inc("underscore/underscore-min.js") %] TEMPLATE my $stylesheet = <<'STYLESHEET';