line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Proc::PersistentControl; # -*-perl-*- |
2
|
|
|
|
|
|
|
# |
3
|
|
|
|
|
|
|
# Author: Michael Staats 2014 |
4
|
|
|
|
|
|
|
# |
5
|
|
|
|
|
|
|
# $Id: PersistentControl.pm 742 2015-08-07 13:30:38Z michael $ |
6
|
|
|
|
|
|
|
# |
7
|
|
|
|
|
|
|
|
8
|
|
|
|
|
|
|
=head1 NAME |
9
|
|
|
|
|
|
|
|
10
|
|
|
|
|
|
|
Proc::PersistentControl - Start and Control Background Processes ("jobs", process groups) |
11
|
|
|
|
|
|
|
|
12
|
|
|
|
|
|
|
=head1 SYNOPSIS |
13
|
|
|
|
|
|
|
|
14
|
|
|
|
|
|
|
use Proc::PersistentControl; |
15
|
|
|
|
|
|
|
|
16
|
|
|
|
|
|
|
my $controller = Proc::PersistentControl->new(); |
17
|
|
|
|
|
|
|
|
18
|
|
|
|
|
|
|
my $Proc = |
19
|
|
|
|
|
|
|
$controller->StartProc({ [ timeout => 42, psynctime => 5, |
20
|
|
|
|
|
|
|
Key => 'Value', ... ] }, |
21
|
|
|
|
|
|
|
"runme args"); |
22
|
|
|
|
|
|
|
|
23
|
|
|
|
|
|
|
my @Procs = $controller->ProcList(['Key', 'Value']); |
24
|
|
|
|
|
|
|
|
25
|
|
|
|
|
|
|
my @Procs = $controller->RipeList(); |
26
|
|
|
|
|
|
|
|
27
|
|
|
|
|
|
|
my $alive = $Proc->IsAlive(); |
28
|
|
|
|
|
|
|
|
29
|
|
|
|
|
|
|
my $ripe = $Proc->IsRipe(); |
30
|
|
|
|
|
|
|
|
31
|
|
|
|
|
|
|
my $info = $Proc->Info(); |
32
|
|
|
|
|
|
|
|
33
|
|
|
|
|
|
|
my $info = $Proc->Reap(); |
34
|
|
|
|
|
|
|
|
35
|
|
|
|
|
|
|
$Proc->Kill(); |
36
|
|
|
|
|
|
|
|
37
|
|
|
|
|
|
|
=head1 DESCRIPTION |
38
|
|
|
|
|
|
|
|
39
|
|
|
|
|
|
|
WARNING: This module (and its pod) is beta. |
40
|
|
|
|
|
|
|
|
41
|
|
|
|
|
|
|
The method that is used by this module is calling for race conditions all |
42
|
|
|
|
|
|
|
over the place... Since version 1.0 most of these should be found. But there |
43
|
|
|
|
|
|
|
will still be bugs. |
44
|
|
|
|
|
|
|
|
45
|
|
|
|
|
|
|
This module creates background processes and allows to track |
46
|
|
|
|
|
|
|
them from multiple invocations of a perl program, i. e. not only |
47
|
|
|
|
|
|
|
from the parent. |
48
|
|
|
|
|
|
|
|
49
|
|
|
|
|
|
|
This is done in quite a KISS way: Information about background |
50
|
|
|
|
|
|
|
processes is stored in one directory per started process. |
51
|
|
|
|
|
|
|
|
52
|
|
|
|
|
|
|
Special care is taken so that killing processes will also kill |
53
|
|
|
|
|
|
|
all child processes (i. e. grandchildren). |
54
|
|
|
|
|
|
|
|
55
|
|
|
|
|
|
|
A timeout for the processes can be specified. |
56
|
|
|
|
|
|
|
|
57
|
|
|
|
|
|
|
This module works on Unix and Windows. On Windows, Win32, Win32::Process |
58
|
|
|
|
|
|
|
and Win32::Job is required. |
59
|
|
|
|
|
|
|
|
60
|
|
|
|
|
|
|
This module is intended to be as simple as possible. It should have as |
61
|
|
|
|
|
|
|
few other modules as prerequisites as possible, only modules |
62
|
|
|
|
|
|
|
that are likely to be installed in a "typical" perl installation (i. e. |
63
|
|
|
|
|
|
|
core modules, or "standard" Win32 modules on Windows). It should be |
64
|
|
|
|
|
|
|
usable on any Unix with the perl that comes with the OS. |
65
|
|
|
|
|
|
|
|
66
|
|
|
|
|
|
|
The intended typical use cases of this module are things like programs |
67
|
|
|
|
|
|
|
that need to start and control "a few" background processes (something |
68
|
|
|
|
|
|
|
like max. 10 per minute or so), but consistently over multiple invocations |
69
|
|
|
|
|
|
|
of the program (like when they are scheduled by cron). |
70
|
|
|
|
|
|
|
Probably not a busy web server that needs to start hundreds of CGI |
71
|
|
|
|
|
|
|
processes per second. |
72
|
|
|
|
|
|
|
|
73
|
|
|
|
|
|
|
=head1 The Controller Object, Process objects, and their Methods |
74
|
|
|
|
|
|
|
|
75
|
|
|
|
|
|
|
=head2 Methods for the controller object |
76
|
|
|
|
|
|
|
|
77
|
|
|
|
|
|
|
=over 4 |
78
|
|
|
|
|
|
|
|
79
|
|
|
|
|
|
|
=item Proc::PersistentControl->new([directory => $dir]); |
80
|
|
|
|
|
|
|
|
81
|
|
|
|
|
|
|
Creates a controller object using $dir as place to store the persistent |
82
|
|
|
|
|
|
|
process information. If 'directory' is not specified, a directory |
83
|
|
|
|
|
|
|
called "ProcPersCtrl" will be created in "/var/tmp/$>" (Unix with /var/tmp), |
84
|
|
|
|
|
|
|
or in File::Spec->tmpdir() . "/$>" (Unix without /var/tmp), or in |
85
|
|
|
|
|
|
|
File::Spec->tmpdir() (Windows). (Note that tmpdir() is not tempdir(), |
86
|
|
|
|
|
|
|
i. e. the directory will always be the same. For certain values |
87
|
|
|
|
|
|
|
of 'always'.) |
88
|
|
|
|
|
|
|
|
89
|
|
|
|
|
|
|
Note that preferring /var/tmp over tmpdir() allows information to survive |
90
|
|
|
|
|
|
|
a reboot on systems where /tmp is a tmpfs or similar. (This does not mean that |
91
|
|
|
|
|
|
|
your jobs will survive a reboot (they won't), and also the controller |
92
|
|
|
|
|
|
|
information might be corrupt if a reboot (or crash, or kill -9) kills your |
93
|
|
|
|
|
|
|
processes the hard way). |
94
|
|
|
|
|
|
|
|
95
|
|
|
|
|
|
|
=item $controller->StartProc({ [ timeout => 42, BLA => 'bla', ... ] }, |
96
|
|
|
|
|
|
|
"runme args"); |
97
|
|
|
|
|
|
|
|
98
|
|
|
|
|
|
|
=item $controller->StartProc({ [ timeout => 42, BLA => 'bla', ... ] }, |
99
|
|
|
|
|
|
|
"runme", "arg1", "arg2", ...); |
100
|
|
|
|
|
|
|
|
101
|
|
|
|
|
|
|
Start the program "runme" with command line arguments, optionally specifying |
102
|
|
|
|
|
|
|
a timeout after which the program will be killed. Other key-value pairs in |
103
|
|
|
|
|
|
|
the options are user defined only and can be retrieved via the Info() and |
104
|
|
|
|
|
|
|
Reap() methods, and be used to find processes by key-value pairs with the |
105
|
|
|
|
|
|
|
ProcList() method. Keys must not start with underscore, these are used |
106
|
|
|
|
|
|
|
internally (but will also be returned by Info() etc). |
107
|
|
|
|
|
|
|
|
108
|
|
|
|
|
|
|
The program can be a "binary/excutable" that is in the $PATH (%PATH%), |
109
|
|
|
|
|
|
|
or a "script". |
110
|
|
|
|
|
|
|
Just try. Unix magic "#!" will also work under Windows (and even more...). |
111
|
|
|
|
|
|
|
|
112
|
|
|
|
|
|
|
This method returns an object of class Proc::PersistentControl::Proc which |
113
|
|
|
|
|
|
|
has the methods described further below. |
114
|
|
|
|
|
|
|
|
115
|
|
|
|
|
|
|
Since the internal information of the controller is stored in the filesystem, |
116
|
|
|
|
|
|
|
you can just terminate your program that uses the controller, start a new one |
117
|
|
|
|
|
|
|
later (giving the same directory to new()) and use all the methods described |
118
|
|
|
|
|
|
|
below. (But see Reap(), which destroys information). |
119
|
|
|
|
|
|
|
|
120
|
|
|
|
|
|
|
=item $controller->ProcList(['Key', 'Value']) |
121
|
|
|
|
|
|
|
|
122
|
|
|
|
|
|
|
Returns a list of Proc::PersistentControl::Proc objects that are |
123
|
|
|
|
|
|
|
under control of the controller object. |
124
|
|
|
|
|
|
|
If a Key-Value pair is given, only processes with this Key-Value |
125
|
|
|
|
|
|
|
pair in their options are returned (see StartProc()). |
126
|
|
|
|
|
|
|
|
127
|
|
|
|
|
|
|
=item $controller->RipeList() |
128
|
|
|
|
|
|
|
|
129
|
|
|
|
|
|
|
Returns a list of Proc::PersistentControl::Proc objects that are |
130
|
|
|
|
|
|
|
under control of the controller object and have terminated, i. e. |
131
|
|
|
|
|
|
|
are ready for reaping. |
132
|
|
|
|
|
|
|
|
133
|
|
|
|
|
|
|
=back |
134
|
|
|
|
|
|
|
|
135
|
|
|
|
|
|
|
=head2 Methods for process objects |
136
|
|
|
|
|
|
|
|
137
|
|
|
|
|
|
|
=over 4 |
138
|
|
|
|
|
|
|
|
139
|
|
|
|
|
|
|
=item $Proc->IsAlive() |
140
|
|
|
|
|
|
|
|
141
|
|
|
|
|
|
|
Returns true if $Proc is still running. |
142
|
|
|
|
|
|
|
|
143
|
|
|
|
|
|
|
=item $Proc->IsRipe() |
144
|
|
|
|
|
|
|
|
145
|
|
|
|
|
|
|
equivalent to "not $Proc->IsAlive()" |
146
|
|
|
|
|
|
|
|
147
|
|
|
|
|
|
|
=item $Proc->Info() |
148
|
|
|
|
|
|
|
|
149
|
|
|
|
|
|
|
Returns a reference to hash that contains information about a process. |
150
|
|
|
|
|
|
|
|
151
|
|
|
|
|
|
|
Usage: |
152
|
|
|
|
|
|
|
|
153
|
|
|
|
|
|
|
sub type { |
154
|
|
|
|
|
|
|
print "$_[0]:\n"; |
155
|
|
|
|
|
|
|
open(T, $_[0]); |
156
|
|
|
|
|
|
|
print while (); |
157
|
|
|
|
|
|
|
close(T); |
158
|
|
|
|
|
|
|
} |
159
|
|
|
|
|
|
|
|
160
|
|
|
|
|
|
|
sub printInfo { |
161
|
|
|
|
|
|
|
my $r = shift; |
162
|
|
|
|
|
|
|
foreach my $k (keys(%$r)) { |
163
|
|
|
|
|
|
|
my $v = $r->{$k}; |
164
|
|
|
|
|
|
|
print "$k=$v\n"; |
165
|
|
|
|
|
|
|
} |
166
|
|
|
|
|
|
|
type($r->{_dir} . '/STDOUT'); |
167
|
|
|
|
|
|
|
type($r->{_dir} . '/STDERR'); |
168
|
|
|
|
|
|
|
} |
169
|
|
|
|
|
|
|
|
170
|
|
|
|
|
|
|
printInfo($Proc->Info()); |
171
|
|
|
|
|
|
|
|
172
|
|
|
|
|
|
|
=item $Proc->Reap() |
173
|
|
|
|
|
|
|
|
174
|
|
|
|
|
|
|
Returns the process object's "Info()" information if $Proc->IsRipe(). |
175
|
|
|
|
|
|
|
|
176
|
|
|
|
|
|
|
The reaped information will be DESTROY'd after the process |
177
|
|
|
|
|
|
|
object goes out of scope. So make sure you use/copy the information |
178
|
|
|
|
|
|
|
before that. |
179
|
|
|
|
|
|
|
(Reap it and eat it before it gets bad). |
180
|
|
|
|
|
|
|
|
181
|
|
|
|
|
|
|
=item $Proc->Kill() |
182
|
|
|
|
|
|
|
|
183
|
|
|
|
|
|
|
Kills the operating system process(es) that belong to $Proc. |
184
|
|
|
|
|
|
|
Should also kill grandchildren. |
185
|
|
|
|
|
|
|
|
186
|
|
|
|
|
|
|
=back |
187
|
|
|
|
|
|
|
|
188
|
|
|
|
|
|
|
=head1 BUGS |
189
|
|
|
|
|
|
|
|
190
|
|
|
|
|
|
|
The "make test" tests could be more detailed (but check out the |
191
|
|
|
|
|
|
|
examples, too.) |
192
|
|
|
|
|
|
|
|
193
|
|
|
|
|
|
|
If you use controller objects with the same directory in parallel, be |
194
|
|
|
|
|
|
|
aware that Reap() will reap anything it can. If two calls to Reap() for |
195
|
|
|
|
|
|
|
the same process intersect, the result is unpredictable. So just don't |
196
|
|
|
|
|
|
|
do that, call Reap() only in one of the programs. Other behaviour when |
197
|
|
|
|
|
|
|
using one directory with more than one controller at the same time |
198
|
|
|
|
|
|
|
is considered to be a feature. |
199
|
|
|
|
|
|
|
|
200
|
|
|
|
|
|
|
Using this module might interfere with your code if it also installs |
201
|
|
|
|
|
|
|
signal handlers, wait()s, etc. So don't do that. |
202
|
|
|
|
|
|
|
|
203
|
|
|
|
|
|
|
The method to store information about the processes should use a more |
204
|
|
|
|
|
|
|
structured data format (like Persistent::File or so, but no more pre-reqs |
205
|
|
|
|
|
|
|
should be added). |
206
|
|
|
|
|
|
|
|
207
|
|
|
|
|
|
|
=head1 Examples |
208
|
|
|
|
|
|
|
|
209
|
|
|
|
|
|
|
Examples should be available in the Proc/PersistentControl/example |
210
|
|
|
|
|
|
|
directory (depending on your installation). |
211
|
|
|
|
|
|
|
|
212
|
|
|
|
|
|
|
=head1 AUTHOR |
213
|
|
|
|
|
|
|
|
214
|
|
|
|
|
|
|
Michael Staats, Emichael.staats@gmx.euE |
215
|
|
|
|
|
|
|
|
216
|
|
|
|
|
|
|
=head1 COPYRIGHT AND LICENSE |
217
|
|
|
|
|
|
|
|
218
|
|
|
|
|
|
|
Copyright (C) 2014 by Michael Staats |
219
|
|
|
|
|
|
|
|
220
|
|
|
|
|
|
|
This library is free software; you can redistribute it and/or modify |
221
|
|
|
|
|
|
|
it under the same terms as Perl itself, either Perl version 5.14.2 or, |
222
|
|
|
|
|
|
|
at your option, any later version of Perl 5 you may have available. |
223
|
|
|
|
|
|
|
|
224
|
|
|
|
|
|
|
=cut |
225
|
|
|
|
|
|
|
|
226
|
|
|
|
|
|
|
require Exporter; |
227
|
7
|
|
|
7
|
|
13252533
|
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); |
|
7
|
|
|
|
|
14
|
|
|
7
|
|
|
|
|
623
|
|
228
|
|
|
|
|
|
|
|
229
|
|
|
|
|
|
|
@ISA = qw(Exporter); |
230
|
|
|
|
|
|
|
|
231
|
|
|
|
|
|
|
$VERSION = '1.4'; |
232
|
|
|
|
|
|
|
|
233
|
7
|
|
|
7
|
|
42
|
use strict; |
|
7
|
|
|
|
|
7
|
|
|
7
|
|
|
|
|
210
|
|
234
|
7
|
|
|
7
|
|
35
|
use File::Path qw(mkpath rmtree); # legacy interface, works with older perls |
|
7
|
|
|
|
|
42
|
|
|
7
|
|
|
|
|
469
|
|
235
|
7
|
|
|
7
|
|
35
|
use File::Spec; |
|
7
|
|
|
|
|
7
|
|
|
7
|
|
|
|
|
147
|
|
236
|
7
|
|
|
7
|
|
7434
|
use File::Temp 'tempdir'; # also old behaviour, we need the dir permanently |
|
7
|
|
|
|
|
155785
|
|
|
7
|
|
|
|
|
406
|
|
237
|
7
|
|
|
7
|
|
5145
|
use POSIX ":sys_wait_h"; |
|
7
|
|
|
|
|
54341
|
|
|
7
|
|
|
|
|
42
|
|
238
|
7
|
|
|
7
|
|
9639
|
use Carp; |
|
7
|
|
|
|
|
7
|
|
|
7
|
|
|
|
|
693
|
|
239
|
|
|
|
|
|
|
|
240
|
|
|
|
|
|
|
BEGIN { |
241
|
7
|
50
|
|
7
|
|
26488
|
if ($^O =~ /^MSWin/) { |
242
|
0
|
|
|
|
|
0
|
require Win32; Win32->import(); |
|
0
|
|
|
|
|
0
|
|
243
|
0
|
|
|
|
|
0
|
require Win32::Process; Win32::Process->import(); |
|
0
|
|
|
|
|
0
|
|
244
|
|
|
|
|
|
|
} |
245
|
|
|
|
|
|
|
} |
246
|
|
|
|
|
|
|
|
247
|
|
|
|
|
|
|
###################################################################### |
248
|
|
|
|
|
|
|
# the new() method for the controller object |
249
|
|
|
|
|
|
|
# |
250
|
|
|
|
|
|
|
my $_debugfh = undef; # quick and dirty global var... |
251
|
|
|
|
|
|
|
|
252
|
|
|
|
|
|
|
sub new { |
253
|
7
|
|
|
7
|
1
|
1379
|
my $class = shift; |
254
|
7
|
|
|
|
|
28
|
my %opthash = @_; |
255
|
|
|
|
|
|
|
|
256
|
7
|
|
50
|
|
|
63
|
$opthash{nannyname} ||= 'ppc-nanny'; |
257
|
7
|
|
50
|
|
|
35
|
$opthash{closefdmax} ||= 12; |
258
|
|
|
|
|
|
|
|
259
|
7
|
|
|
|
|
42
|
my $self = { _opts => \%opthash }; |
260
|
7
|
|
|
|
|
14
|
$self->{sdir} = $opthash{directory}; |
261
|
7
|
50
|
|
|
|
35
|
if (not $self->{sdir}) { |
262
|
7
|
50
|
|
|
|
42
|
if ($^O !~ /^MSWin/) { |
263
|
|
|
|
|
|
|
$self->{sdir} = |
264
|
7
|
50
|
|
|
|
490
|
((-d '/var/tmp') ? '/var/tmp' : File::Spec->tmpdir()) . |
265
|
|
|
|
|
|
|
"/$>/ProcPersCtrl"; |
266
|
|
|
|
|
|
|
} else { |
267
|
|
|
|
|
|
|
$self->{sdir} = |
268
|
0
|
|
|
|
|
0
|
Win32::GetLongPathName(File::Spec->tmpdir()) . "\\ProcPersCtrl"; |
269
|
|
|
|
|
|
|
#File::Spec->tmpdir() . "\\ProcPersCtrl"; |
270
|
|
|
|
|
|
|
} |
271
|
|
|
|
|
|
|
} |
272
|
|
|
|
|
|
|
|
273
|
7
|
|
|
|
|
21
|
my $sdir = $self->{sdir}; |
274
|
7
|
50
|
|
|
|
14
|
eval { mkpath($sdir) unless (-d $sdir); }; |
|
7
|
|
|
|
|
38565436
|
|
275
|
7
|
50
|
|
|
|
259
|
croak "'$sdir' is not a directory and could not mkpath() it: $!\n" |
276
|
|
|
|
|
|
|
if (not -d $sdir); |
277
|
|
|
|
|
|
|
|
278
|
7
|
50
|
|
|
|
70
|
if ($opthash{debug}) { |
279
|
0
|
|
|
|
|
0
|
my $file = $sdir . '/debug.out'; |
280
|
0
|
|
|
|
|
0
|
my $size = (stat($file))[7]; |
281
|
0
|
0
|
0
|
|
|
0
|
if ($size and $size > 102400) { |
282
|
0
|
|
|
|
|
0
|
rename($file, $file . '.old'); |
283
|
|
|
|
|
|
|
} |
284
|
0
|
0
|
|
|
|
0
|
open($_debugfh, '>>', $file) || |
285
|
|
|
|
|
|
|
carp "Cannot append to $file: $!"; |
286
|
0
|
|
|
|
|
0
|
select((select($_debugfh), $|=1)[0]); |
287
|
0
|
|
|
|
|
0
|
eval { require Time::HiRes; }; |
|
0
|
|
|
|
|
0
|
|
288
|
0
|
0
|
|
|
|
0
|
if ($@) { |
289
|
0
|
|
|
|
|
0
|
print $_debugfh "No Time::HiRes ($@), sorry...\n"; |
290
|
|
|
|
|
|
|
} |
291
|
|
|
|
|
|
|
} |
292
|
|
|
|
|
|
|
|
293
|
7
|
|
|
|
|
42
|
my $rdir = $sdir . '/reaped'; |
294
|
7
|
50
|
33
|
|
|
336
|
if (-e $rdir and not -d $rdir) { |
295
|
0
|
|
|
|
|
0
|
carp "'$rdir' exists and is not a directory...\n"; |
296
|
0
|
|
|
|
|
0
|
unlink($rdir); |
297
|
|
|
|
|
|
|
} |
298
|
7
|
50
|
|
|
|
189
|
if (not -d $rdir) { |
299
|
7
|
50
|
|
|
|
1428
|
mkpath($rdir) or croak "Could not mkpath('$rdir'): $!\n"; |
300
|
|
|
|
|
|
|
} |
301
|
|
|
|
|
|
|
|
302
|
7
|
|
|
|
|
42
|
bless $self, $class; |
303
|
7
|
|
|
|
|
70
|
return $self; |
304
|
|
|
|
|
|
|
} |
305
|
|
|
|
|
|
|
|
306
|
|
|
|
|
|
|
sub debug { |
307
|
132
|
50
|
|
132
|
0
|
788
|
return undef unless $_debugfh; |
308
|
0
|
|
|
|
|
0
|
my $clf = (caller(1))[3]; |
309
|
0
|
|
0
|
|
|
0
|
$clf ||= (caller())[1]; |
310
|
|
|
|
|
|
|
|
311
|
0
|
|
|
|
|
0
|
my $msg = join(' ', @_); |
312
|
0
|
0
|
|
|
|
0
|
$msg .= "\n" unless ($msg =~ /\n$/); |
313
|
0
|
0
|
|
|
|
0
|
my $ts = $INC{'Time/HiRes.pm'} ? Time::HiRes::time() : time(); |
314
|
0
|
|
|
|
|
0
|
print $_debugfh $ts, ' ', $$, ' ', $clf, ': ', $msg; |
315
|
0
|
|
|
|
|
0
|
return 1; |
316
|
|
|
|
|
|
|
} |
317
|
|
|
|
|
|
|
|
318
|
|
|
|
|
|
|
###################################################################### |
319
|
|
|
|
|
|
|
# system dependent stuff |
320
|
|
|
|
|
|
|
|
321
|
|
|
|
|
|
|
sub _pid_alive($) { |
322
|
3
|
|
|
3
|
|
9
|
my $pid = shift; |
323
|
|
|
|
|
|
|
|
324
|
3
|
|
|
|
|
11
|
debug($pid); |
325
|
|
|
|
|
|
|
|
326
|
3
|
50
|
33
|
|
|
54
|
return 0 if (not $pid or $pid <= 0); |
327
|
|
|
|
|
|
|
|
328
|
3
|
50
|
|
|
|
33
|
if ($^O !~ /^MSWin/) { |
329
|
3
|
|
|
|
|
42
|
my $ret = kill(0, $pid); |
330
|
3
|
|
|
|
|
27
|
debug("returning $ret"); |
331
|
3
|
|
|
|
|
40
|
return $ret |
332
|
|
|
|
|
|
|
} |
333
|
|
|
|
|
|
|
|
334
|
|
|
|
|
|
|
# Windows |
335
|
0
|
|
|
|
|
0
|
my $process; |
336
|
0
|
0
|
|
|
|
0
|
if (Win32::Process::Open($process, $pid, 0)) { |
337
|
0
|
|
|
|
|
0
|
debug("Win32::Process::Open ok"); |
338
|
0
|
|
|
|
|
0
|
my $RC; |
339
|
0
|
|
|
|
|
0
|
$process->GetExitCode($RC); |
340
|
0
|
|
|
|
|
0
|
debug("Win32 GetExitCode RC=$RC"); |
341
|
0
|
0
|
|
|
|
0
|
if ($RC == Win32::Process::STILL_ACTIVE()) { |
342
|
0
|
|
|
|
|
0
|
debug("returning 1"); |
343
|
0
|
|
|
|
|
0
|
return 1; |
344
|
|
|
|
|
|
|
} |
345
|
|
|
|
|
|
|
} |
346
|
0
|
|
|
|
|
0
|
debug("returning 0"); |
347
|
0
|
|
|
|
|
0
|
return 0; |
348
|
|
|
|
|
|
|
} |
349
|
|
|
|
|
|
|
|
350
|
|
|
|
|
|
|
# Using these two variables looks like a bug: it seems they |
351
|
|
|
|
|
|
|
# are re-used for new children. But they aren't, the are |
352
|
|
|
|
|
|
|
# only used in the fork()ed child, and this forks only one |
353
|
|
|
|
|
|
|
# grandchild. |
354
|
|
|
|
|
|
|
|
355
|
|
|
|
|
|
|
my $_unix_grandch_pid; |
356
|
|
|
|
|
|
|
my $_unix_grandch_dir; |
357
|
|
|
|
|
|
|
|
358
|
|
|
|
|
|
|
sub _unix_intr_sighandler { |
359
|
0
|
|
|
0
|
|
0
|
my $sig = shift; |
360
|
0
|
|
|
|
|
0
|
$SIG{INT} = 'IGNORE'; |
361
|
0
|
|
|
|
|
0
|
$SIG{QUIT} = 'IGNORE'; |
362
|
0
|
|
|
|
|
0
|
$SIG{TERM} = 'IGNORE'; |
363
|
|
|
|
|
|
|
|
364
|
0
|
0
|
|
|
|
0
|
if ($_unix_grandch_pid) { |
365
|
0
|
|
|
|
|
0
|
carp "$0:ProcPersCtrl:$$: Caught SIG$sig, killing '$_unix_grandch_pid'...\n"; |
366
|
0
|
|
|
|
|
0
|
_unix_kill($_unix_grandch_pid); # calls the CHLD handler... |
367
|
|
|
|
|
|
|
} |
368
|
0
|
|
|
|
|
0
|
exit(0); |
369
|
|
|
|
|
|
|
} |
370
|
|
|
|
|
|
|
|
371
|
|
|
|
|
|
|
sub _unix_chld_sighandler { |
372
|
3
|
|
|
3
|
|
14
|
my $child; |
373
|
3
|
|
|
|
|
215
|
while (($child = waitpid(-1, WNOHANG)) > 0) { |
374
|
3
|
|
|
|
|
71
|
my $RC = $? >> 8; |
375
|
3
|
|
|
|
|
94
|
debug("Child $child died with RC=$RC (my grandchild $_unix_grandch_pid)"); |
376
|
3
|
50
|
|
|
|
25
|
if ($child == $_unix_grandch_pid) { |
377
|
|
|
|
|
|
|
# this is what we have been waiting for |
378
|
3
|
|
|
|
|
11
|
$_unix_grandch_pid = undef; |
379
|
3
|
|
|
|
|
21
|
debug("Writing rc and endtime to $_unix_grandch_dir"); |
380
|
3
|
50
|
|
|
|
595
|
open(RC, '>', $_unix_grandch_dir . "/RC=$RC") or |
381
|
|
|
|
|
|
|
carp "Could not write $_unix_grandch_dir/RC=$RC: $!"; |
382
|
3
|
|
|
|
|
35
|
close(RC); |
383
|
3
|
50
|
|
|
|
222
|
open(I, '>>', $_unix_grandch_dir . "/info") or |
384
|
|
|
|
|
|
|
carp "Could not append to $_unix_grandch_dir/info: $!"; |
385
|
3
|
|
|
|
|
101
|
print I "_endtime=", time(), "\n"; |
386
|
3
|
|
|
|
|
107
|
close(I); |
387
|
|
|
|
|
|
|
} |
388
|
|
|
|
|
|
|
} |
389
|
3
|
|
|
|
|
400627
|
$SIG{CHLD} = \&_unix_chld_sighandler; # ... sysV |
390
|
|
|
|
|
|
|
} |
391
|
|
|
|
|
|
|
|
392
|
|
|
|
|
|
|
sub _unix_spawn { |
393
|
15
|
|
|
15
|
|
42
|
my $pdir = shift; |
394
|
15
|
|
|
|
|
34
|
my $opt = shift; |
395
|
15
|
|
|
|
|
100
|
my @cmd = @_; |
396
|
|
|
|
|
|
|
|
397
|
15
|
|
|
|
|
110
|
debug("called with $pdir for $cmd[0] ..."); |
398
|
|
|
|
|
|
|
|
399
|
15
|
|
|
|
|
359
|
$SIG{CHLD} = 'IGNORE'; # for now |
400
|
|
|
|
|
|
|
|
401
|
15
|
|
|
|
|
25661
|
my $childpid = fork(); |
402
|
15
|
50
|
|
|
|
745
|
croak "Cannot fork(): $!\n" if (not defined $childpid); |
403
|
|
|
|
|
|
|
|
404
|
15
|
100
|
|
|
|
447
|
if ($childpid == 0) { |
405
|
6
|
|
|
|
|
1460
|
debug("I'm the new child for $opt->{nannyname} $cmd[0] ..."); |
406
|
|
|
|
|
|
|
# child |
407
|
|
|
|
|
|
|
# fill the info directory, |
408
|
|
|
|
|
|
|
|
409
|
6
|
50
|
|
|
|
2434
|
open(I, '>', $pdir . '/info') or croak "Cannot write '$pdir/info': $!\n"; |
410
|
6
|
|
|
|
|
102
|
my $start = time(); |
411
|
6
|
|
|
|
|
428
|
print I "_starttime=$start\n"; |
412
|
6
|
|
|
|
|
282
|
print I "_cmd=", join(",", map { s/([,\\])/\\$1/g; s/\n/\\n/g; $_ } |
|
6
|
|
|
|
|
296
|
|
|
6
|
|
|
|
|
176
|
|
|
6
|
|
|
|
|
80
|
|
413
|
|
|
|
|
|
|
my @tmp = @cmd), "\n"; |
414
|
6
|
|
|
|
|
364
|
foreach my $o (keys(%$opt)) { |
415
|
28
|
|
|
|
|
148
|
my $v = $opt->{$o}; |
416
|
28
|
|
|
|
|
86
|
$v =~ s/\n/\\n/sg; |
417
|
28
|
|
|
|
|
58
|
$v =~ s/\r/\\r/sg; |
418
|
28
|
|
|
|
|
136
|
print I "$o=$v\n"; |
419
|
|
|
|
|
|
|
} |
420
|
6
|
|
|
|
|
818
|
close(I); |
421
|
|
|
|
|
|
|
|
422
|
6
|
|
|
|
|
964
|
open(STDIN, '/dev/null'); |
423
|
6
|
50
|
|
|
|
930
|
open(STDOUT, '>', $pdir . '/STDOUT') or |
424
|
|
|
|
|
|
|
croak "Cannot write '$pdir/STDOUT': $!\n"; |
425
|
6
|
50
|
|
|
|
702
|
open(STDERR, '>', $pdir . '/STDERR') or |
426
|
|
|
|
|
|
|
croak "Cannot write '$pdir/STDERR': $!\n"; |
427
|
|
|
|
|
|
|
|
428
|
6
|
50
|
|
|
|
164
|
if ($opt->{_closefdmax} >= 3) { |
429
|
6
|
|
|
|
|
184
|
for (my $fd = 3; $fd <= $opt->{_closefdmax}; $fd++) { |
430
|
60
|
50
|
33
|
|
|
652
|
POSIX::close($fd) |
431
|
|
|
|
|
|
|
unless ($_debugfh and $fd == fileno($_debugfh)); |
432
|
|
|
|
|
|
|
} |
433
|
|
|
|
|
|
|
} |
434
|
|
|
|
|
|
|
|
435
|
6
|
|
|
|
|
120
|
$_unix_grandch_dir = $pdir; |
436
|
|
|
|
|
|
|
|
437
|
6
|
|
|
|
|
458
|
$0 = $opt->{nannyname} . ' ' . join(' ', @cmd); |
438
|
|
|
|
|
|
|
|
439
|
6
|
|
|
|
|
288
|
$SIG{CHLD} = \&_unix_chld_sighandler; |
440
|
|
|
|
|
|
|
|
441
|
6
|
|
|
|
|
11120
|
$_unix_grandch_pid = fork(); # fork again for grandchild |
442
|
6
|
100
|
|
|
|
564
|
if ($_unix_grandch_pid == 0) { |
443
|
3
|
|
|
|
|
359
|
debug("I'm the new grandchild for $cmd[0] ..."); |
444
|
|
|
|
|
|
|
#grandchild |
445
|
3
|
|
|
|
|
237
|
$SIG{CHLD} = 'DEFAULT'; |
446
|
3
|
|
|
|
|
378
|
setpgrp(0, 0); |
447
|
|
|
|
|
|
|
# Sometimes (esp. on AIX) it seems that the following exec |
448
|
|
|
|
|
|
|
# can terminate before $_unix_grandch_pid is set in the |
449
|
|
|
|
|
|
|
# parent, which is bad since the sighandler checks it... |
450
|
|
|
|
|
|
|
# so wait for the pid file |
451
|
3
|
|
100
|
|
|
159
|
my $psynctime = $opt->{psynctime} || 10; |
452
|
3
|
|
|
|
|
29
|
my $waited = 0; |
453
|
3
|
|
|
|
|
186
|
debug("waiting max $psynctime s for 'start' file"); |
454
|
3
|
|
|
|
|
63
|
for (my $nwait = 1; $nwait < 10 * $psynctime; $nwait++) { |
455
|
3
|
50
|
|
|
|
543
|
last if (-e $pdir . "/pstart"); |
456
|
0
|
|
|
|
|
0
|
$waited++; |
457
|
0
|
|
|
|
|
0
|
select(undef, undef, undef, 0.1); |
458
|
|
|
|
|
|
|
} |
459
|
3
|
|
|
|
|
1051
|
unlink($pdir . "/pstart"); |
460
|
3
|
|
|
|
|
139
|
debug("waited " . (0.1 * $waited) . " s for 'start' file"); |
461
|
3
|
|
|
|
|
699
|
open(STA, '>', $pdir . "/start"); print STA time(), "\n"; close(STA); |
|
3
|
|
|
|
|
159
|
|
|
3
|
|
|
|
|
349
|
|
462
|
3
|
0
|
|
|
|
0
|
if (not exec(@cmd)) { |
463
|
0
|
|
|
|
|
0
|
open(FA, '>', $pdir . "/fail"); print FA "$!\n"; close(FA); |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
464
|
0
|
|
|
|
|
0
|
unlink($pdir . "/start"); |
465
|
0
|
|
|
|
|
0
|
croak "Could not exec(", join(', ', @cmd), ")\n"; |
466
|
|
|
|
|
|
|
} |
467
|
|
|
|
|
|
|
} |
468
|
3
|
50
|
|
|
|
92
|
croak "Cannot fork(): $!\n" if (not defined $_unix_grandch_pid); |
469
|
|
|
|
|
|
|
|
470
|
3
|
|
|
|
|
522
|
$SIG{INT} = \&_unix_term_sighandler; |
471
|
3
|
|
|
|
|
105
|
$SIG{TERM} = \&_unix_term_sighandler; |
472
|
3
|
|
|
|
|
59
|
$SIG{QUIT} = \&_unix_term_sighandler; |
473
|
|
|
|
|
|
|
|
474
|
3
|
|
|
|
|
543
|
open(PID, '>', $pdir . "/pid=$_unix_grandch_pid"); close(PID); |
|
3
|
|
|
|
|
44
|
|
475
|
3
|
|
|
|
|
345
|
open(STA, '>', $pdir . "/pstart"); print STA time(), "\n"; close(STA); |
|
3
|
|
|
|
|
140
|
|
|
3
|
|
|
|
|
196
|
|
476
|
3
|
|
|
|
|
125
|
debug("child says: \$_unix_grandch_pid = $_unix_grandch_pid " . |
477
|
|
|
|
|
|
|
"for $cmd[0] ..."); |
478
|
|
|
|
|
|
|
|
479
|
3
|
100
|
|
|
|
72
|
my $timeout = $opt->{timeout} ? int($opt->{timeout}) : 86400000; |
480
|
3
|
|
|
|
|
13
|
my $maxtime = time + $timeout; |
481
|
|
|
|
|
|
|
|
482
|
|
|
|
|
|
|
# $_unix_grandch_pid will be set to undef in the sighandler... |
483
|
|
|
|
|
|
|
# well, sometimes it seems it doesn't (some perls on some AIX, eg.) |
484
|
|
|
|
|
|
|
# so we also test with kill(0, ...) |
485
|
3
|
|
|
|
|
144
|
debug("Before wait loop for $cmd[0] ..."); |
486
|
3
|
|
66
|
|
|
355
|
while ($_unix_grandch_pid and kill(0, $_unix_grandch_pid) and time < $maxtime) { |
|
|
|
100
|
|
|
|
|
487
|
3
|
|
|
|
|
21
|
my $remain = $maxtime - time; |
488
|
|
|
|
|
|
|
# check each min to avoid race condition, see below |
489
|
3
|
100
|
|
|
|
17
|
$remain = 60 if ($remain > 60); |
490
|
3
|
|
|
|
|
349
|
debug("Waiting for grandchild... sleep($remain) at " |
491
|
|
|
|
|
|
|
. scalar(localtime)); |
492
|
3
|
50
|
|
|
|
7829995
|
sleep($remain) # will be interrupted by SIGCHLD, this is what we want |
493
|
|
|
|
|
|
|
# but if the sighandler jumps in exactly HERE |
494
|
|
|
|
|
|
|
# we still have a race cond. |
495
|
|
|
|
|
|
|
# That's why we sleep at most 60 s |
496
|
|
|
|
|
|
|
if ($_unix_grandch_pid); # just to be sure... |
497
|
|
|
|
|
|
|
} |
498
|
3
|
|
|
|
|
217
|
debug("after wait loop for $cmd[0] ... at " . scalar(localtime)); |
499
|
3
|
100
|
66
|
|
|
55
|
if ($_unix_grandch_pid and kill(0, $_unix_grandch_pid)) { |
500
|
1
|
|
|
|
|
771
|
carp "ProcPersCtrl:$$: Child $_unix_grandch_pid is alive after $timeout s, killing it\n"; |
501
|
1
|
50
|
|
|
|
396
|
open(I, '>>', $pdir . '/info') or |
502
|
|
|
|
|
|
|
croak "Cannot append to '$pdir/info': $!\n"; |
503
|
1
|
|
|
|
|
12
|
print I "_timed_out=1\n"; |
504
|
1
|
|
|
|
|
47
|
close(I); |
505
|
1
|
|
|
|
|
9
|
_unix_kill($_unix_grandch_pid); |
506
|
|
|
|
|
|
|
} |
507
|
3
|
|
|
|
|
631
|
exit(0); |
508
|
|
|
|
|
|
|
} |
509
|
|
|
|
|
|
|
# parent |
510
|
9
|
|
|
|
|
1232
|
debug("parent says: child $childpid"); |
511
|
9
|
|
|
|
|
306
|
return $childpid; |
512
|
|
|
|
|
|
|
} |
513
|
|
|
|
|
|
|
|
514
|
|
|
|
|
|
|
sub _win_spawn { |
515
|
0
|
|
|
0
|
|
0
|
my $pdir = shift; |
516
|
0
|
|
|
|
|
0
|
my $opt = shift; |
517
|
0
|
|
|
|
|
0
|
my @cmd = @_; |
518
|
|
|
|
|
|
|
|
519
|
|
|
|
|
|
|
# find the helper script |
520
|
0
|
|
|
|
|
0
|
my $module_path = $INC{'Proc/PersistentControl.pm'}; |
521
|
0
|
|
|
|
|
0
|
$module_path =~ s|(.*)[/\\].*|$1|; |
522
|
0
|
|
|
|
|
0
|
my $helper = '"' . $module_path . '/PersistentControl/winjob.pl' . '"'; |
523
|
|
|
|
|
|
|
|
524
|
|
|
|
|
|
|
# construct args the DOS way, hopefully... |
525
|
0
|
|
|
|
|
0
|
my $Arg = 'perl ' . $helper . " "; |
526
|
0
|
0
|
|
|
|
0
|
$Arg .= ' -d ' if ($_debugfh); |
527
|
0
|
0
|
|
|
|
0
|
my $timeout = $opt->{timeout} ? $opt->{timeout} : 0; |
528
|
0
|
0
|
|
|
|
0
|
$Arg .= " -t $timeout " if ($timeout > 0); |
529
|
|
|
|
|
|
|
# Try to escape "" in cmd. |
530
|
|
|
|
|
|
|
# Will work in simple cases... |
531
|
0
|
|
|
|
|
0
|
s/\"/\\\"/g foreach (@cmd); |
532
|
|
|
|
|
|
|
# contruct final command |
533
|
0
|
|
|
|
|
0
|
$Arg .= "\"$pdir\" \"" . join('" "', @cmd) . '"'; |
534
|
|
|
|
|
|
|
|
535
|
0
|
|
|
|
|
0
|
debug("perl \$Arg = '$Arg'"); |
536
|
|
|
|
|
|
|
|
537
|
|
|
|
|
|
|
# launch windows process (helper script, in background) |
538
|
0
|
|
|
|
|
0
|
my $process; |
539
|
0
|
0
|
|
|
|
0
|
Win32::Process::Create($process, $^X, $Arg, 0, 0, '.') or |
540
|
|
|
|
|
|
|
croak "Cannot Win32::Process::Create(): $!\n"; |
541
|
|
|
|
|
|
|
|
542
|
0
|
|
|
|
|
0
|
my $childpid = $process->GetProcessID(); |
543
|
|
|
|
|
|
|
|
544
|
0
|
|
|
|
|
0
|
debug("\$childpid = $childpid"); |
545
|
|
|
|
|
|
|
|
546
|
0
|
0
|
|
|
|
0
|
open(I, '>', $pdir . '/info') or croak "Cannot write '$pdir/info': $!\n"; |
547
|
0
|
|
|
|
|
0
|
my $start = time(); |
548
|
0
|
|
|
|
|
0
|
print I "_starttime=$start\n"; |
549
|
0
|
|
|
|
|
0
|
print I "_cmd=", join(",", map { s/([,\\])/\\$1/g; s/\n/\\n/g; $_ } |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
550
|
|
|
|
|
|
|
my @tmp = @cmd), "\n"; |
551
|
0
|
|
|
|
|
0
|
foreach my $o (keys(%$opt)) { |
552
|
0
|
|
|
|
|
0
|
my $v = $opt->{$o}; |
553
|
0
|
|
|
|
|
0
|
$v =~ s/\n/\\n/sg; |
554
|
0
|
|
|
|
|
0
|
$v =~ s/\r/\\r/sg; |
555
|
0
|
|
|
|
|
0
|
print I "$o=$v\n"; |
556
|
|
|
|
|
|
|
} |
557
|
0
|
|
|
|
|
0
|
close(I); |
558
|
|
|
|
|
|
|
|
559
|
0
|
|
|
|
|
0
|
return $childpid; |
560
|
|
|
|
|
|
|
} |
561
|
|
|
|
|
|
|
|
562
|
|
|
|
|
|
|
sub _unix_kill { |
563
|
2
|
|
|
2
|
|
21
|
my @pids = @_; |
564
|
2
|
|
|
|
|
6
|
my @ret; |
565
|
2
|
|
|
|
|
19
|
foreach my $p (@pids) { |
566
|
2
|
|
|
|
|
11
|
debug("killing $p"); |
567
|
|
|
|
|
|
|
# first the process group if we have one |
568
|
2
|
100
|
66
|
|
|
200724
|
kill(-15, $p) and |
569
|
|
|
|
|
|
|
(select(undef, undef, undef, 0.2), kill -3, $p) and |
570
|
|
|
|
|
|
|
(select(undef, undef, undef, 0.4), kill -9, $p); |
571
|
|
|
|
|
|
|
# then a single process |
572
|
2
|
50
|
33
|
|
|
98
|
kill( 15, $p) and |
573
|
|
|
|
|
|
|
(select(undef, undef, undef, 0.2), kill 3, $p) and |
574
|
|
|
|
|
|
|
(select(undef, undef, undef, 0.4), kill 9, $p); |
575
|
2
|
50
|
|
|
|
39
|
push(@ret, $p) unless (kill(0, $p)); |
576
|
|
|
|
|
|
|
} |
577
|
2
|
|
|
|
|
30
|
return @ret; |
578
|
|
|
|
|
|
|
} |
579
|
|
|
|
|
|
|
|
580
|
|
|
|
|
|
|
sub _win_kill { |
581
|
0
|
|
|
0
|
|
0
|
my @pids = @_; |
582
|
0
|
|
|
|
|
0
|
foreach my $p (@pids) { |
583
|
0
|
|
|
|
|
0
|
my $exitcode = 130; |
584
|
0
|
|
|
|
|
0
|
debug("killing $p"); |
585
|
0
|
|
|
|
|
0
|
Win32::Process::KillProcess($p, $exitcode); |
586
|
|
|
|
|
|
|
} |
587
|
0
|
|
|
|
|
0
|
return @pids; |
588
|
|
|
|
|
|
|
} |
589
|
|
|
|
|
|
|
|
590
|
|
|
|
|
|
|
###################################################################### |
591
|
|
|
|
|
|
|
# internal functions |
592
|
|
|
|
|
|
|
|
593
|
|
|
|
|
|
|
sub _UID_alive($$) { |
594
|
10
|
|
|
10
|
|
26
|
my $sdir = shift; |
595
|
10
|
|
|
|
|
19
|
my $UID = shift; |
596
|
|
|
|
|
|
|
|
597
|
10
|
|
|
|
|
34
|
my $pdir = $sdir . '/' . $UID; |
598
|
10
|
|
|
|
|
17
|
my $pid; |
599
|
|
|
|
|
|
|
my $RC; |
600
|
|
|
|
|
|
|
|
601
|
10
|
|
|
|
|
488
|
opendir(D, $pdir); |
602
|
10
|
|
|
|
|
271
|
while ($_ = readdir(D)) { |
603
|
77
|
100
|
|
|
|
297
|
$pid = $1 if (m/^pid=(\d+)/); |
604
|
77
|
100
|
|
|
|
352
|
$RC = $1 if (m/^RC=(\d+)/); |
605
|
|
|
|
|
|
|
} |
606
|
10
|
|
|
|
|
144
|
closedir(D); |
607
|
10
|
100
|
|
|
|
122
|
return defined($RC) ? 0 : _pid_alive($pid); |
608
|
|
|
|
|
|
|
} |
609
|
|
|
|
|
|
|
|
610
|
|
|
|
|
|
|
sub _get_all_uids { |
611
|
0
|
|
|
0
|
|
0
|
my $sdir = shift; |
612
|
0
|
|
|
|
|
0
|
my @ret; |
613
|
|
|
|
|
|
|
|
614
|
0
|
0
|
|
|
|
0
|
opendir(D, $sdir) or croak "Cannot opendir '$sdir': $!\n"; |
615
|
0
|
|
|
|
|
0
|
while (my $d = readdir(D)) { |
616
|
0
|
0
|
0
|
|
|
0
|
if ($d =~ m/^PPC-/ and -f "$sdir/$d/info") { |
617
|
0
|
|
|
|
|
0
|
push(@ret, $d); |
618
|
0
|
|
|
|
|
0
|
debug("found job info dir \"$d\""); |
619
|
|
|
|
|
|
|
} |
620
|
|
|
|
|
|
|
} |
621
|
0
|
|
|
|
|
0
|
closedir(D); |
622
|
0
|
|
|
|
|
0
|
debug("returning " . join(' ', @ret)); |
623
|
0
|
|
|
|
|
0
|
return @ret; |
624
|
|
|
|
|
|
|
} |
625
|
|
|
|
|
|
|
|
626
|
|
|
|
|
|
|
sub _get_pid_by_uid { |
627
|
1
|
|
|
1
|
|
6
|
my $sdir = shift; |
628
|
1
|
|
|
|
|
4
|
my $UID = shift; |
629
|
|
|
|
|
|
|
|
630
|
1
|
|
|
|
|
10
|
debug("in $sdir $UID"); |
631
|
1
|
|
|
|
|
6
|
my $pdir = $sdir . '/' . $UID; |
632
|
1
|
|
|
|
|
3
|
my $pid; |
633
|
1
|
50
|
|
|
|
65
|
if (opendir(DD, $pdir)) { |
634
|
1
|
|
|
|
|
14
|
while (my $f = readdir(DD)) { |
635
|
7
|
|
|
|
|
37
|
debug("read $f"); |
636
|
7
|
100
|
|
|
|
68
|
$pid = $1 if ($f =~ m/pid=(\d+)$/); |
637
|
|
|
|
|
|
|
} |
638
|
1
|
|
|
|
|
12
|
closedir(DD); |
639
|
1
|
50
|
|
|
|
17
|
carp "Could not find pid file in $pdir\n" unless ($pid); |
640
|
|
|
|
|
|
|
} else { |
641
|
0
|
|
|
|
|
0
|
carp "Can't opendir $pdir for $UID\n"; |
642
|
|
|
|
|
|
|
} |
643
|
1
|
|
|
|
|
9
|
debug("returning $pid"); |
644
|
1
|
|
|
|
|
5
|
return ($pid); |
645
|
|
|
|
|
|
|
} |
646
|
|
|
|
|
|
|
|
647
|
|
|
|
|
|
|
sub _get_info_by_uid { |
648
|
2
|
|
|
2
|
|
6
|
my $sdir = shift; |
649
|
2
|
|
|
|
|
5
|
my $UID = shift; |
650
|
|
|
|
|
|
|
|
651
|
2
|
|
|
|
|
2
|
my %ret; |
652
|
|
|
|
|
|
|
|
653
|
2
|
|
|
|
|
7
|
my $pdir = $sdir . '/' . $UID; |
654
|
2
|
|
|
|
|
5
|
my $infofile = $pdir . '/info'; |
655
|
|
|
|
|
|
|
|
656
|
2
|
50
|
|
|
|
96
|
open(I, $infofile) or return undef; |
657
|
|
|
|
|
|
|
|
658
|
2
|
|
|
|
|
40
|
while () { |
659
|
17
|
|
|
|
|
24
|
chomp; |
660
|
17
|
50
|
|
|
|
163
|
$ret{$1} = $2 if (m/([^=]+)=(.*)/); |
661
|
|
|
|
|
|
|
} |
662
|
2
|
|
|
|
|
18
|
close(I); |
663
|
|
|
|
|
|
|
|
664
|
2
|
|
|
|
|
7
|
$ret{_dir} = $pdir; |
665
|
2
|
50
|
|
|
|
11
|
$ret{_dir} =~ s|/|\\|g if ($^O =~ /^MSWin/); # cosmetics, also works without |
666
|
|
|
|
|
|
|
|
667
|
2
|
|
100
|
|
|
14
|
my $rctryt = $ret{psynctime} || 10; |
668
|
|
|
|
|
|
|
|
669
|
2
|
|
|
|
|
4
|
my $pidalive = 0; |
670
|
2
|
|
|
|
|
7
|
debug("waiting max $rctryt s for 'RC' file"); |
671
|
2
|
|
|
|
|
13
|
for (my $ntry = 0; $ntry < 10 * $rctryt; $ntry++, select(undef, undef, undef, 0.1)) { |
672
|
|
|
|
|
|
|
# try a few times, just in case this function is called |
673
|
|
|
|
|
|
|
# after the process has terminated but before RC could be written |
674
|
|
|
|
|
|
|
# nevertheless it's still a race condition... |
675
|
2
|
|
|
|
|
11
|
debug("try " . ($ntry + 1) . " to get RC in $pdir"); |
676
|
2
|
50
|
|
|
|
48
|
opendir(D, $pdir) or croak "cannot opendir $pdir: $!"; |
677
|
2
|
|
|
|
|
15
|
while ($_ = readdir(D)) { |
678
|
16
|
|
|
|
|
33
|
debug("readdir() gives: $_"); |
679
|
16
|
100
|
|
|
|
41
|
$ret{_pid} = $1 if (m/^pid=(\d+)/); |
680
|
16
|
100
|
|
|
|
120
|
$ret{_RC} = $1 if (m/^RC=(\d+)/); |
681
|
|
|
|
|
|
|
} |
682
|
2
|
|
|
|
|
10
|
closedir(D); |
683
|
2
|
50
|
|
|
|
19
|
last if (exists($ret{_RC})); # found ret code, fine |
684
|
0
|
0
|
|
|
|
0
|
if ($ret{_pid}) { |
685
|
0
|
|
|
|
|
0
|
$pidalive = _pid_alive($ret{_pid}); |
686
|
0
|
0
|
|
|
|
0
|
last if ($pidalive); # still alive, also ok |
687
|
|
|
|
|
|
|
} |
688
|
0
|
|
|
|
|
0
|
debug("No RC found in $pdir although process is dead..."); |
689
|
|
|
|
|
|
|
} |
690
|
|
|
|
|
|
|
|
691
|
2
|
50
|
|
|
|
6
|
if (exists($ret{_RC})) { |
692
|
2
|
|
|
|
|
6
|
$ret{_alive} = 0; |
693
|
|
|
|
|
|
|
} else { |
694
|
0
|
0
|
|
|
|
0
|
if ($pidalive) { |
695
|
0
|
|
|
|
|
0
|
$ret{_alive} = 1; |
696
|
|
|
|
|
|
|
} else { |
697
|
|
|
|
|
|
|
# no RC and not alive => terminated the hard way... |
698
|
0
|
|
|
|
|
0
|
$ret{_alive} = 0; |
699
|
0
|
|
|
|
|
0
|
debug("Could not determine RC, setting it to 130"); |
700
|
0
|
|
|
|
|
0
|
carp "Could not determine return code of job in $pdir, " . |
701
|
|
|
|
|
|
|
"setting it to 130"; |
702
|
0
|
|
|
|
|
0
|
$ret{_RC} = 130; |
703
|
0
|
|
|
|
|
0
|
open(RC, '>', $pdir . '/RC=130'); close(RC); |
|
0
|
|
|
|
|
0
|
|
704
|
|
|
|
|
|
|
} |
705
|
|
|
|
|
|
|
} |
706
|
|
|
|
|
|
|
|
707
|
7
|
|
|
7
|
|
42
|
no warnings "uninitialized"; |
|
7
|
|
|
|
|
21
|
|
|
7
|
|
|
|
|
8470
|
|
708
|
2
|
|
|
|
|
15
|
debug("\$ret{_RC} = $ret{_RC} \$ret{_dir} = $ret{_dir} " . |
709
|
|
|
|
|
|
|
"\$ret{_pid} = $ret{_pid} \$ret{TAG} = $ret{TAG}"); |
710
|
|
|
|
|
|
|
|
711
|
2
|
|
|
|
|
9
|
return \%ret; |
712
|
|
|
|
|
|
|
} |
713
|
|
|
|
|
|
|
|
714
|
|
|
|
|
|
|
sub _make_uid_list { |
715
|
|
|
|
|
|
|
# return a uid list for @in IDs |
716
|
0
|
|
|
0
|
|
0
|
my $sdir = shift; |
717
|
0
|
|
|
|
|
0
|
my @in = @_; |
718
|
0
|
|
|
|
|
0
|
my @out; |
719
|
|
|
|
|
|
|
|
720
|
0
|
|
|
|
|
0
|
debug("in: ", join('-', @in)); |
721
|
|
|
|
|
|
|
|
722
|
|
|
|
|
|
|
# empty input, return all UIDS |
723
|
0
|
0
|
|
|
|
0
|
if (not $in[0]) { |
724
|
0
|
|
|
|
|
0
|
@out = _get_all_uids($sdir); |
725
|
|
|
|
|
|
|
} else { |
726
|
|
|
|
|
|
|
# otherwise: return UIDS for input ids |
727
|
0
|
|
|
|
|
0
|
foreach my $UID (@in) { |
728
|
0
|
|
|
|
|
0
|
my $pdir = $sdir . '/' . $UID; |
729
|
0
|
0
|
|
|
|
0
|
push(@out, $UID) if (-f $pdir . '/info'); |
730
|
|
|
|
|
|
|
} |
731
|
|
|
|
|
|
|
} |
732
|
0
|
|
|
|
|
0
|
debug("out: ", join('-', @out)); |
733
|
0
|
|
|
|
|
0
|
return @out; |
734
|
|
|
|
|
|
|
} |
735
|
|
|
|
|
|
|
|
736
|
|
|
|
|
|
|
###################################################################### |
737
|
|
|
|
|
|
|
# Proc::PersistentControl object methods, actually all of them return |
738
|
|
|
|
|
|
|
# objects of class Proc::PersistentControl::Proc |
739
|
|
|
|
|
|
|
|
740
|
|
|
|
|
|
|
sub StartProc { |
741
|
|
|
|
|
|
|
# this is one of the "new" method for |
742
|
|
|
|
|
|
|
# Proc::PersistentControl::Proc |
743
|
|
|
|
|
|
|
|
744
|
15
|
|
|
15
|
1
|
669
|
my $self = shift; |
745
|
15
|
|
|
|
|
54
|
my $opt = shift; |
746
|
15
|
|
|
|
|
85
|
my @cmd = @_; |
747
|
|
|
|
|
|
|
|
748
|
15
|
|
|
|
|
200
|
my $sdir = $self->{sdir}; |
749
|
|
|
|
|
|
|
|
750
|
15
|
|
|
|
|
56
|
my $w = "Invalid option to StartProc(): Option should not"; |
751
|
15
|
|
|
|
|
158
|
foreach my $o (keys(%$opt)) { |
752
|
27
|
50
|
|
|
|
216
|
carp "$w contain '='" if ($o =~ m/=/); |
753
|
27
|
50
|
|
|
|
168
|
carp "$w start with '_'" if ($o =~ m/^_/); |
754
|
|
|
|
|
|
|
} |
755
|
|
|
|
|
|
|
|
756
|
15
|
|
|
|
|
142
|
debug("command '" . join(' ', @cmd) . "'"); |
757
|
|
|
|
|
|
|
|
758
|
|
|
|
|
|
|
# create a directory for process information |
759
|
15
|
|
|
|
|
620
|
my $psd = tempdir('PPC-XXXX', DIR => $sdir); |
760
|
15
|
50
|
33
|
|
|
11788
|
croak "Cannot make tempdir: $!" unless ($psd and -d $psd); |
761
|
|
|
|
|
|
|
|
762
|
15
|
|
|
|
|
201
|
$psd =~ m/.*(PPC-.*)/; |
763
|
15
|
|
|
|
|
162
|
my $UID = $1; |
764
|
|
|
|
|
|
|
|
765
|
15
|
|
|
|
|
59
|
$opt->{_PPCUID} = $UID; |
766
|
15
|
|
33
|
|
|
170
|
$opt->{nannyname} ||= $self->{_opts}->{nannyname}; |
767
|
15
|
|
|
|
|
44
|
$opt->{_closefdmax} = $self->{_opts}->{closefdmax}; |
768
|
|
|
|
|
|
|
|
769
|
15
|
50
|
|
|
|
147
|
($^O !~ /^MSWin/) ? |
770
|
|
|
|
|
|
|
_unix_spawn($psd, $opt, @cmd) : |
771
|
|
|
|
|
|
|
_win_spawn( $psd, $opt, @cmd); |
772
|
|
|
|
|
|
|
|
773
|
9
|
|
|
|
|
500
|
my $Proc = { |
774
|
|
|
|
|
|
|
_PPCUID => $UID, |
775
|
|
|
|
|
|
|
_controller => $self |
776
|
|
|
|
|
|
|
}; |
777
|
|
|
|
|
|
|
|
778
|
9
|
|
100
|
|
|
349
|
my $psynctime = $opt->{psynctime} || 10; |
779
|
9
|
|
|
|
|
43
|
my $waited = 0; |
780
|
9
|
|
|
|
|
69
|
for (my $nwait = 1; $nwait < 10 * $psynctime; $nwait++) { |
781
|
18
|
100
|
66
|
|
|
3534
|
last if (-e $psd . "/start" or -e $psd . "/fail"); |
782
|
9
|
|
|
|
|
503
|
$waited++; |
783
|
9
|
|
|
|
|
905615
|
select(undef, undef, undef, 0.1); |
784
|
|
|
|
|
|
|
} |
785
|
9
|
|
|
|
|
712
|
debug("waited " . (0.1 * $waited) . " s for 'start/fail' file"); |
786
|
9
|
50
|
|
|
|
505
|
if (-e $psd . "/fail") { |
|
|
50
|
|
|
|
|
|
787
|
0
|
0
|
|
|
|
0
|
open(FA, $psd . "/fail") or die "Cannot read $psd/fail: $!\n"; |
788
|
0
|
|
|
|
|
0
|
my $st = ; |
789
|
0
|
|
|
|
|
0
|
close(FA); |
790
|
0
|
|
|
|
|
0
|
carp "StartProc could not start child process $cmd[0]: $st"; |
791
|
0
|
|
|
|
|
0
|
return undef; |
792
|
|
|
|
|
|
|
} elsif (-e $psd . "/start") { |
793
|
9
|
|
|
|
|
266
|
bless $Proc, 'Proc::PersistentControl::Proc'; |
794
|
9
|
|
|
|
|
2383
|
debug("returning Proc object for $UID, pid file " . |
795
|
|
|
|
|
|
|
(glob($psd . '/pid=*'))[0]); |
796
|
9
|
|
|
|
|
648
|
return $Proc; |
797
|
|
|
|
|
|
|
} else { |
798
|
0
|
|
|
|
|
0
|
carp "StartProc could not start child process after " . |
799
|
|
|
|
|
|
|
(0.1 * $waited) . " s\n"; |
800
|
0
|
|
|
|
|
0
|
return undef; |
801
|
|
|
|
|
|
|
} |
802
|
|
|
|
|
|
|
} |
803
|
|
|
|
|
|
|
|
804
|
|
|
|
|
|
|
sub ProcList { |
805
|
|
|
|
|
|
|
# this is also a "new" method for |
806
|
|
|
|
|
|
|
# Proc::PersistentControl::Proc |
807
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
808
|
0
|
|
|
|
|
0
|
my $key = shift; |
809
|
0
|
|
|
|
|
0
|
my $val = shift; |
810
|
|
|
|
|
|
|
|
811
|
0
|
|
|
|
|
0
|
my @ret; |
812
|
|
|
|
|
|
|
|
813
|
0
|
|
|
|
|
0
|
debug("called from " . join('-', caller())); |
814
|
|
|
|
|
|
|
|
815
|
0
|
|
|
|
|
0
|
my @uidlist = _make_uid_list($self->{sdir}); |
816
|
|
|
|
|
|
|
|
817
|
0
|
|
|
|
|
0
|
UID: foreach my $UID (@uidlist) { |
818
|
0
|
|
|
|
|
0
|
my $i = _get_info_by_uid($self->{sdir}, $UID); |
819
|
0
|
0
|
|
|
|
0
|
next UID unless ($i); |
820
|
0
|
0
|
0
|
|
|
0
|
next UID if ($key and $i->{$key} ne $val); |
821
|
|
|
|
|
|
|
|
822
|
0
|
|
|
|
|
0
|
my $Proc = { |
823
|
|
|
|
|
|
|
_PPCUID => $UID, |
824
|
|
|
|
|
|
|
_controller => $self |
825
|
|
|
|
|
|
|
}; |
826
|
0
|
|
|
|
|
0
|
bless $Proc, 'Proc::PersistentControl::Proc'; |
827
|
0
|
|
|
|
|
0
|
push(@ret, $Proc); |
828
|
|
|
|
|
|
|
} |
829
|
0
|
|
|
|
|
0
|
return(@ret); |
830
|
|
|
|
|
|
|
} |
831
|
|
|
|
|
|
|
|
832
|
|
|
|
|
|
|
sub RipeList { |
833
|
|
|
|
|
|
|
# another "new" method for |
834
|
|
|
|
|
|
|
# Proc::PersistentControl::Proc |
835
|
|
|
|
|
|
|
|
836
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
837
|
0
|
|
|
|
|
0
|
my @ret; |
838
|
|
|
|
|
|
|
|
839
|
0
|
|
|
|
|
0
|
debug("called from " . join('-', caller())); |
840
|
|
|
|
|
|
|
|
841
|
0
|
|
|
|
|
0
|
my @uidlist = _make_uid_list($self->{sdir}); |
842
|
|
|
|
|
|
|
|
843
|
0
|
|
|
|
|
0
|
foreach my $UID (@uidlist) { |
844
|
0
|
|
|
|
|
0
|
debug("checking $UID"); |
845
|
0
|
0
|
|
|
|
0
|
if (not _UID_alive($self->{sdir}, $UID)) { |
846
|
0
|
|
|
|
|
0
|
my $Proc = { |
847
|
|
|
|
|
|
|
_PPCUID => $UID, |
848
|
|
|
|
|
|
|
_controller => $self |
849
|
|
|
|
|
|
|
}; |
850
|
0
|
|
|
|
|
0
|
bless $Proc, 'Proc::PersistentControl::Proc'; |
851
|
0
|
|
|
|
|
0
|
push(@ret, $Proc); |
852
|
0
|
|
|
|
|
0
|
debug("$UID not alive, ready for reaping"); |
853
|
|
|
|
|
|
|
} |
854
|
|
|
|
|
|
|
} |
855
|
0
|
|
|
|
|
0
|
return(@ret); |
856
|
|
|
|
|
|
|
} |
857
|
|
|
|
|
|
|
|
858
|
|
|
|
|
|
|
###################################################################### |
859
|
|
|
|
|
|
|
###################################################################### |
860
|
|
|
|
|
|
|
|
861
|
|
|
|
|
|
|
package Proc::PersistentControl::Proc; |
862
|
7
|
|
|
7
|
|
5943
|
use File::Copy; |
|
7
|
|
|
|
|
16275
|
|
|
7
|
|
|
|
|
441
|
|
863
|
7
|
|
|
7
|
|
35
|
use File::Path qw(mkpath rmtree); # legacy interface, works with older perls |
|
7
|
|
|
|
|
7
|
|
|
7
|
|
|
|
|
322
|
|
864
|
7
|
|
|
7
|
|
35
|
use Carp; |
|
7
|
|
|
|
|
14
|
|
|
7
|
|
|
|
|
5754
|
|
865
|
|
|
|
|
|
|
|
866
|
|
|
|
|
|
|
sub _getUID { |
867
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
868
|
0
|
|
|
|
|
0
|
return $self->{_PPCUID}; |
869
|
|
|
|
|
|
|
} |
870
|
|
|
|
|
|
|
|
871
|
|
|
|
|
|
|
sub Kill { |
872
|
1
|
|
|
1
|
|
1000262
|
my $self = shift; |
873
|
|
|
|
|
|
|
|
874
|
1
|
|
|
|
|
33
|
Proc::PersistentControl::debug("called from " . join('-', caller())); |
875
|
|
|
|
|
|
|
|
876
|
|
|
|
|
|
|
return undef unless (Proc::PersistentControl::_UID_alive( |
877
|
|
|
|
|
|
|
$self->{_controller}->{sdir}, |
878
|
1
|
50
|
|
|
|
15
|
$self->{_PPCUID})); |
879
|
|
|
|
|
|
|
|
880
|
|
|
|
|
|
|
my $pid = Proc::PersistentControl::_get_pid_by_uid( |
881
|
|
|
|
|
|
|
$self->{_controller}->{sdir}, |
882
|
1
|
|
|
|
|
21
|
$self->{_PPCUID}); |
883
|
|
|
|
|
|
|
|
884
|
1
|
50
|
|
|
|
20
|
my @ret = ($^O !~ /^MSWin/) ? |
885
|
|
|
|
|
|
|
Proc::PersistentControl::_unix_kill(($pid)) : |
886
|
|
|
|
|
|
|
Proc::PersistentControl::_win_kill( ($pid)); |
887
|
|
|
|
|
|
|
|
888
|
|
|
|
|
|
|
# wait max 1 sec until process has finished and info is written |
889
|
1
|
|
|
|
|
10
|
for (my $nwait = 0; $nwait < 10; $nwait++) { |
890
|
1
|
50
|
|
|
|
11
|
last if (not $self->IsAlive()); |
891
|
0
|
|
|
|
|
0
|
Proc::PersistentControl::debug("Process not dead after Kill() ($nwait)..."); |
892
|
0
|
|
|
|
|
0
|
select(undef, undef, undef, 0.1); |
893
|
|
|
|
|
|
|
} |
894
|
1
|
50
|
|
|
|
5
|
carp "Something is strange, Kill()ed process seems to be still alive..." |
895
|
|
|
|
|
|
|
if ($self->IsAlive()); |
896
|
|
|
|
|
|
|
|
897
|
1
|
|
|
|
|
6
|
return $ret[0]; |
898
|
|
|
|
|
|
|
} |
899
|
|
|
|
|
|
|
|
900
|
|
|
|
|
|
|
sub Info { |
901
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
902
|
|
|
|
|
|
|
|
903
|
0
|
|
|
|
|
0
|
Proc::PersistentControl::debug("called from " . join('-', caller())); |
904
|
|
|
|
|
|
|
|
905
|
|
|
|
|
|
|
return Proc::PersistentControl::_get_info_by_uid( |
906
|
|
|
|
|
|
|
$self->{_controller}->{sdir}, |
907
|
0
|
|
|
|
|
0
|
$self->{_PPCUID}); |
908
|
|
|
|
|
|
|
} |
909
|
|
|
|
|
|
|
|
910
|
|
|
|
|
|
|
sub IsAlive { |
911
|
9
|
|
|
9
|
|
1001239
|
my $self = shift; |
912
|
|
|
|
|
|
|
|
913
|
|
|
|
|
|
|
return Proc::PersistentControl::_UID_alive( |
914
|
|
|
|
|
|
|
$self->{_controller}->{sdir}, |
915
|
9
|
|
|
|
|
96
|
$self->{_PPCUID}); |
916
|
|
|
|
|
|
|
} |
917
|
|
|
|
|
|
|
|
918
|
|
|
|
|
|
|
sub IsRipe { |
919
|
3
|
|
|
3
|
|
6
|
my $self = shift; |
920
|
3
|
|
|
|
|
11
|
return not $self->IsAlive(); |
921
|
|
|
|
|
|
|
} |
922
|
|
|
|
|
|
|
|
923
|
|
|
|
|
|
|
sub Reap { |
924
|
2
|
|
|
2
|
|
114
|
my $self = shift; |
925
|
|
|
|
|
|
|
|
926
|
2
|
|
|
|
|
18
|
Proc::PersistentControl::debug("called from " . join('-', caller())); |
927
|
|
|
|
|
|
|
|
928
|
2
|
50
|
|
|
|
15
|
return undef unless ($self->IsRipe()); |
929
|
|
|
|
|
|
|
|
930
|
2
|
|
|
|
|
6
|
my $sdir = $self->{_controller}->{sdir}; |
931
|
2
|
|
|
|
|
7
|
my $UID = $self->{_PPCUID}; |
932
|
|
|
|
|
|
|
|
933
|
2
|
|
|
|
|
29
|
my $source = $sdir . '/' . $UID; |
934
|
2
|
|
|
|
|
7
|
my $target = $sdir . '/reaped/' . $UID; |
935
|
|
|
|
|
|
|
|
936
|
2
|
50
|
|
|
|
49
|
if (not -d $target) { |
937
|
2
|
0
|
33
|
|
|
247
|
rename($source, $target) or |
|
|
|
33
|
|
|
|
|
|
|
|
0
|
|
|
|
|
938
|
|
|
|
|
|
|
move($source, $target) or |
939
|
|
|
|
|
|
|
# sometimes (on windows) the dir seems to be "locked" |
940
|
|
|
|
|
|
|
# also after process termination etc. |
941
|
|
|
|
|
|
|
(Proc::PersistentControl::debug("rename/1st move($source, $target) failed, trying again"), |
942
|
|
|
|
|
|
|
select(undef, undef, undef, 0.2), |
943
|
|
|
|
|
|
|
move($source, $target)) or |
944
|
|
|
|
|
|
|
(Proc::PersistentControl::debug("2nd move($source, $target) failed, trying again"), |
945
|
|
|
|
|
|
|
select(undef, undef, undef, 0.8), |
946
|
|
|
|
|
|
|
move($source, $target)) or |
947
|
|
|
|
|
|
|
(Proc::PersistentControl::debug("3rd move($source, $target) failed")); |
948
|
|
|
|
|
|
|
# do not check return value of move |
949
|
|
|
|
|
|
|
# this is unreliable, maybe (on windows...) |
950
|
2
|
50
|
|
|
|
261
|
carp "Cannot move('$source', '$target'): $!\n" unless (-d $target); |
951
|
|
|
|
|
|
|
} else { |
952
|
|
|
|
|
|
|
### Reap called twice??? |
953
|
0
|
|
|
|
|
0
|
carp "Reap: '$target' already exists, Reap() called twice?\n" |
954
|
|
|
|
|
|
|
} |
955
|
2
|
|
|
|
|
13
|
return Proc::PersistentControl::_get_info_by_uid($sdir . '/reaped', $UID); |
956
|
|
|
|
|
|
|
} |
957
|
|
|
|
|
|
|
|
958
|
|
|
|
|
|
|
###################################################################### |
959
|
|
|
|
|
|
|
sub DESTROY { |
960
|
6
|
|
|
6
|
|
134
|
my $self = shift; |
961
|
|
|
|
|
|
|
|
962
|
6
|
|
|
|
|
151
|
my $pdir = $self->{_controller}->{sdir} . '/reaped/' . $self->{_PPCUID}; |
963
|
|
|
|
|
|
|
|
964
|
6
|
100
|
|
|
|
338
|
if (-d $pdir) { |
965
|
2
|
50
|
|
|
|
3565
|
rmtree($pdir) or |
966
|
|
|
|
|
|
|
carp "Could not rmtree($pdir): $!"; |
967
|
|
|
|
|
|
|
} |
968
|
6
|
|
|
|
|
817
|
return 1; |
969
|
|
|
|
|
|
|
} |
970
|
|
|
|
|
|
|
|
971
|
|
|
|
|
|
|
1; |