File Coverage

blib/lib/App/Switchman.pm
Criterion Covered Total %
statement 31 33 93.9
branch n/a
condition n/a
subroutine 11 11 100.0
pod n/a
total 42 44 95.4


line stmt bran cond sub pod time code
1             package App::Switchman;
2              
3             our $VERSION = '1.14';
4              
5             =head1 NAME
6              
7             App::Switchman
8              
9             =head1 DESCRIPTION
10              
11             switchman's internals
12              
13             =cut
14              
15 3     3   2035 use strict;
  3         6  
  3         66  
16 3     3   13 use warnings;
  3         5  
  3         90  
17              
18 3     3   13 use File::Basename qw(basename);
  3         8  
  3         217  
19 3     3   3187 use Getopt::Long qw(GetOptionsFromArray);
  3         33650  
  3         16  
20 3     3   1462 use JSON;
  3         16054  
  3         23  
21 3     3   2840 use Linux::MemInfo;
  3         12431  
  3         204  
22 3     3   2774 use List::MoreUtils qw(part uniq);
  3         40484  
  3         31  
23 3     3   2293 use List::Util qw(max);
  3         6  
  3         358  
24 3     3   2732 use Log::Dispatch;
  3         45266  
  3         143  
25 3     3   1709 use Moo;
  3         14747  
  3         29  
26 3     3   4147 use Net::ZooKeeper qw(:acls :errors :events :node_flags);
  0            
  0            
27             use Net::ZooKeeper::Semaphore;
28             use Pod::Usage;
29             use POSIX qw(strftime);
30             use Scalar::Util qw(blessed);
31             use Sys::CPU;
32             use Sys::Hostname::FQDN qw(fqdn);
33             use Sys::SigAction qw(set_sig_handler);
34              
35              
36             our $DEFAULT_CONFIG_PATH ||= "/etc/switchman.conf";
37             our $LOCKS_PATH ||= 'locks';
38             our $QUEUES_PATH ||= 'queues';
39             our $SEMAPHORES_PATH ||= 'semaphores';
40              
41              
42             has command => (is => 'ro', required => 1);
43             has data_read_len => (
44             is => 'ro',
45             isa => sub {die "bad data_read_len: $_[0]" if defined $_[0] && $_[0] !~ m{^[0-9]+$}},
46             default => sub {65535},
47             );
48             has do_get_lock => (is => 'ro', default => 1);
49             has group => (is => 'ro');
50             has leases => (is => 'ro');
51             has lock_path => (
52             is => 'ro',
53             lazy => 1,
54             builder => sub {join '/', $_[0]->prefix, $LOCKS_PATH, $_[0]->lockname},
55             );
56             has lock_watch => (
57             is => 'ro',
58             lazy => 1,
59             builder => sub {$_[0]->zkh->watch},
60             );
61             has lockname => (
62             is => 'ro',
63             isa => sub {
64             die "lockname is too long: $_[0]" if length($_[0]) > 512;
65             die "lockname must not contain '/'" if index($_[0], '/') != -1;
66             },
67             required => 1,
68             );
69             has log => (is => 'ro', lazy => 1, builder => 1);
70             has logfile => (is => 'ro');
71             has loglevel => (is => 'ro');
72             has prefix => (
73             is => 'ro',
74             isa => sub {die "bad prefix: $_[0]" unless $_[0] =~ m{^(?:/[^/]+)+$}},
75             required => 1,
76             );
77             has prefix_data => (is => 'rw');
78             has prefix_data_watch => (
79             is => 'ro',
80             lazy => 1,
81             builder => sub {$_[0]->zkh->watch},
82             );
83             has queue_positions => (
84             is => 'ro',
85             default => sub {+{}},
86             );
87             has resources_wait_timeout => (
88             is => 'ro',
89             isa => sub {die "bad resources_wait_timeout: $_[0]" if defined $_[0] && $_[0] !~ m{^[0-9]+$}},
90             default => sub {0},
91             );
92             has termination_timeout => (
93             is => 'ro',
94             isa => sub {die "bad termination_timeout: $_[0]" if defined $_[0] && $_[0] !~ m{^\d+$}},
95             default => sub {10},
96             );
97             has zkh => (
98             is => 'rw',
99             lazy => 1,
100             builder => sub {Net::ZooKeeper->new($_[0]->zkhosts)},
101             );
102             has zkhosts => (is => 'ro', required => 1);
103              
104              
105             sub BUILDARGS
106             {
107             my $class = shift;
108             my $arguments = shift;
109              
110             return $arguments if ref $arguments eq 'HASH';
111             die "Bad constructor arguments: hashref or arrayref expected" unless ref $arguments eq 'ARRAY';
112              
113             my %options = (do_get_lock => 1);
114             my $config_path;
115             my $leases = {};
116             GetOptionsFromArray(
117             $arguments,
118             'c|config=s' => \$config_path,
119             'g|group=s' => \$options{group},
120             'h|help' => \&usage,
121             'lease=s' => $leases,
122             'lockname=s' => \$options{lockname},
123             'v|version' => \&version,
124             'lock!' => \$options{do_get_lock},
125             ) or die "Couldn't parse options, see $0 -h for help\n";
126              
127             die "No command provided" unless @$arguments;
128             $options{lockname} ||= basename($arguments->[0]);
129             $options{command} = [@$arguments];
130              
131             $options{leases} = {};
132             for my $resource (keys %$leases) {
133             my ($count, $total) = split /:/, _process_resource_macro($leases->{$resource}), 2;
134             $options{leases}->{_process_resource_macro($resource)} = {
135             count => eval $count,
136             total => eval $total,
137             };
138             }
139              
140             if (!$config_path && -f $DEFAULT_CONFIG_PATH) {
141             $config_path = $DEFAULT_CONFIG_PATH;
142             }
143             die "$DEFAULT_CONFIG_PATH is absent and --config is missing, see $0 -h for help\n" unless $config_path;
144             my $config = _get_and_check_config($config_path);
145             for my $key (qw/data_read_len logfile loglevel prefix resources_wait_timeout termination_timeout zkhosts/) {
146             next unless exists $config->{$key};
147             $options{$key} = $config->{$key};
148             }
149              
150             return \%options;
151             }
152              
153              
154             sub _build_log
155             {
156             my $self = shift;
157              
158             return Log::Dispatch->new(
159             outputs => [
160             [
161             'Screen',
162             min_level => $ENV{DEBUG} ? 'debug' : 'warning',
163             stderr => 1,
164             newline => 1,
165             ],
166             $self->logfile ? [
167             'File',
168             min_level => $self->loglevel || 'info',
169             filename => $self->logfile,
170             mode => '>>',
171             newline => 1,
172             binmode => ':encoding(UTF-8)',
173             format => '[%d] [%p] %m at %F line %L%n',
174             ] : (),
175             ],
176             callbacks => sub {my %p = @_; return join "\t", strftime("%Y-%m-%d %H:%M:%S", localtime(time)), "[$$]", $p{message};},
177             );
178             }
179              
180              
181             =head1 METHODS
182              
183             =head2 acquire_semaphore
184              
185             Acquires semaphore for a given resource
186              
187             =cut
188              
189             sub acquire_semaphore
190             {
191             my $self = shift;
192             my $resource = shift;
193              
194             $self->log->debug(sprintf "Trying to acquire semaphore %s", $resource);
195              
196             return Net::ZooKeeper::Semaphore->new(
197             count => $self->leases->{$resource}->{count},
198             data => _node_data(),
199             path => $self->prefix."/$SEMAPHORES_PATH/$resource",
200             total => $self->leases->{$resource}->{total},
201             zkh => $self->zkh,
202             );
203             }
204              
205              
206             =head2 get_group_hosts
207              
208             Returns an arrayref of hosts included int the given group
209              
210             =cut
211              
212             sub get_group_hosts
213             {
214             my $self = shift;
215             my $groups = shift;
216             my $group = shift;
217             my $seen = shift || {$group => 1};
218              
219             my $items = $groups->{$group} or $self->_error(sprintf "Group <%s> is not described", $group);
220             $items = [$items] unless ref $items eq 'ARRAY';
221             my ($subgroups, $hosts) = part {exists $groups->{$_} ? 0 : 1} @$items;
222             for my $subgroup (@$subgroups) {
223             next if $seen->{$subgroup};
224             $seen->{$subgroup} = 1;
225             push @$hosts, @{$self->get_group_hosts($groups, $subgroup, $seen)};
226             }
227             return [uniq @$hosts];
228             }
229              
230              
231             =head2 get_lock
232              
233             Creates a named lock in ZooKeeper
234             Returns undef is lock already exists, otherwise returns true and sets lock_watch
235              
236             =cut
237              
238             sub get_lock
239             {
240             my $self = shift;
241              
242             my $lock_path = $self->zkh->create($self->lock_path, _node_data(),
243             acl => ZOO_OPEN_ACL_UNSAFE,
244             flags => ZOO_EPHEMERAL,
245             );
246             if (my $error = $self->zkh->get_error) {
247             if ($error == ZNODEEXISTS) {
248             return undef;
249             } else {
250             $self->_error(sprintf("Could not acquire lock %s: %s", $self->lockname, $self->zkh->str_error));
251             }
252             }
253             $self->log->debug(sprintf "Lock <%s> taken", $self->lock_path);
254             return $self->zkh->exists($lock_path, watch => $self->lock_watch);
255             }
256              
257              
258             =head2 get_queue_path
259              
260             Returns queue path for a given resource
261              
262             =cut
263              
264             sub get_queue_path
265             {
266             my $self = shift;
267             my $resource = shift;
268              
269             return $self->prefix."/$QUEUES_PATH/$resource";
270             }
271              
272              
273             =head2 get_resources
274              
275             Returns resource names listed in ZooKeeper
276             Macros are processed
277              
278             =cut
279              
280             sub get_resources
281             {
282             my $self = shift;
283              
284             $self->load_prefix_data;
285             return map {_process_resource_macro($_)} @{$self->prefix_data->{resources}};
286             }
287              
288              
289             =head2 is_group_serviced
290              
291             Determines if execution is allowed on the current host
292              
293             =cut
294              
295             sub is_group_serviced
296             {
297             my $self = shift;
298              
299             $self->load_prefix_data;
300             my $hosts = $self->get_group_hosts($self->prefix_data->{groups}, $self->group);
301             my $fqdn = fqdn();
302             my $is_serviced = grep {$fqdn eq $_} @$hosts;
303             return $is_serviced;
304             }
305              
306              
307             =head2 is_task_in_queue
308              
309             Checks if task is already queue up for a given resource
310              
311             =cut
312              
313             sub is_task_in_queue
314             {
315             my $self = shift;
316             my $resource = shift;
317              
318             my $re = quotemeta($self->lockname).'-\d+';
319             my $is_in_queue = scalar grep {$_ =~ /^$re$/} $self->zkh->get_children($self->get_queue_path($resource));
320             if ($self->zkh->get_error && $self->zkh->get_error != ZNONODE) {
321             $self->_error("Could not check queue for <$resource>: ".$self->zkh->str_error);
322             }
323             $self->log->debug(sprintf "Check if task <%s> already queued up for resource <%s>: %s", $self->lockname, $resource, ($is_in_queue ? 'true' : 'false'));
324             return $is_in_queue;
325             }
326              
327              
328             =head2 leave_queues
329              
330             Leaves all resource queues
331              
332             =cut
333              
334             sub leave_queues
335             {
336             my $self = shift;
337              
338             for my $resource (keys %{$self->queue_positions}) {
339             my $position = $self->queue_positions->{$resource};
340             $self->log->debug(sprintf "Delete from queue %s", $position);
341             $self->zkh->delete($position);
342             if ($self->zkh->get_error) {
343             $self->_error("Could not delete <$position>: ".$self->zkh->str_error);
344             }
345             delete $self->queue_positions->{$resource};
346             }
347             }
348              
349              
350             =head2 load_prefix_data
351              
352             Loads data from prefix znode
353             Sets prefix_data_watch
354              
355             =cut
356              
357             sub load_prefix_data
358             {
359             my $self = shift;
360              
361             my $json_data = $self->zkh->get($self->prefix, watch => $self->prefix_data_watch);
362             if ($self->zkh->get_error) {
363             $self->_error("Could not get data: ".$self->zkh->str_error);
364             }
365              
366             my (%data, $prefix_data);
367             if ($json_data) {
368             $prefix_data = eval {from_json($json_data)};
369             if (!$prefix_data || $@) {
370             $self->_error("Could not decode data: $@");
371             } elsif (ref $prefix_data ne 'HASH') {
372             $self->_error("Bad prefix data: hashref expected");
373             }
374             if ($prefix_data->{resources} && ref $prefix_data->{resources} ne 'ARRAY') {
375             $self->_error("Bad prefix data: resources should be an array");
376             }
377             if ($prefix_data->{groups} && ref $prefix_data->{groups} ne 'HASH') {
378             $self->_error("Bad prefix data: groups should be a hash");
379             }
380             }
381              
382             $data{resources} = $prefix_data->{resources} || [];
383             $data{groups} = $prefix_data->{groups} || {};
384              
385             $self->prefix_data(\%data);
386             }
387              
388              
389             =head2 prepare_zknodes
390              
391             Ensures existence of subnodes we use
392              
393             =cut
394              
395             sub prepare_zknodes
396             {
397             my $self = shift;
398             my $nodes = shift;
399              
400             for my $path (@$nodes) {
401             unless ($self->zkh->exists($path)) {
402             my $error = $self->zkh->get_error;
403             if ($error && $error != ZNONODE) {
404             $self->_error("Failed to check $path existence: ".$self->zkh->str_error);
405             }
406             $self->log->debug("Create $path");
407             $self->zkh->create($path, _node_data(),
408             acl => ZOO_OPEN_ACL_UNSAFE,
409             ) or $self->_error("Failed to prepare $path: ".$self->zkh->str_error);
410             }
411             }
412             }
413              
414              
415             =head2 queue_up
416              
417             Puts task in queue for resource
418             Returns queue item path
419              
420             =cut
421              
422             sub queue_up
423             {
424             my $self = shift;
425             my $resource = shift;
426              
427             my $queue_path = $self->get_queue_path($resource);
428             $self->prepare_zknodes([$queue_path]);
429             my $item_path = $self->zkh->create(sprintf("%s/%s-", $queue_path, $self->lockname), _node_data(),
430             acl => ZOO_OPEN_ACL_UNSAFE,
431             flags => (ZOO_EPHEMERAL | ZOO_SEQUENCE),
432             );
433             if ($self->zkh->get_error) {
434             $self->_error(sprintf("Could not push task <%s> in queue for <%s>: %s", $self->lockname, $resource, $self->zkh->str_error));
435             } else {
436             $self->log->debug(sprintf "Added task in queue for <%s>: <%s>", $resource, $item_path);
437             }
438             $self->queue_positions->{$resource} = $item_path;
439             return $item_path;
440             }
441              
442              
443             =head2 run
444              
445             Application loop
446             Never returns
447              
448             =cut
449              
450             sub run
451             {
452             my $self = shift;
453              
454             # check connection and try and reconnect in case of a failure
455             for (1 .. 10) {
456             if (!$self->zkh) {
457             $self->log->debug("NetZooKeeper initialization failed");
458             } else {
459             $self->zkh->exists($self->prefix);
460             if (!$self->zkh->get_error || $self->zkh->get_error == ZNONODE) {
461             last;
462             }
463             }
464             $self->log->debug("Trying to reconnect");
465             $self->zkh(Net::ZooKeeper->new($self->zkhosts));
466             }
467              
468             if (!$self->zkh) {
469             $self->_error("Failed to connect to ZooKeeper");
470             }
471              
472             $self->zkh->{data_read_len} = $self->data_read_len;
473              
474             $self->prepare_zknodes([$self->prefix, map {$self->prefix."/$_"} ($LOCKS_PATH, $QUEUES_PATH, $SEMAPHORES_PATH)]);
475              
476             if ($self->group && !$self->is_group_serviced) {
477             $self->log->debug(sprintf "Group <%s> is not serviced at the moment", $self->group);
478             exit;
479             }
480              
481             if ($self->do_get_lock && $self->zkh->exists($self->lock_path, watch => $self->lock_watch)) {
482             $self->log->info(sprintf "Lock %s already exists", $self->lock_path);
483             exit;
484             }
485              
486             my %known_resources = map {$_ => 1} $self->get_resources;
487             if (my @unknown_resources = grep {!exists $known_resources{$_}} keys %{$self->leases}) {
488             $self->_error("Unknown resources: ".join(', ', @unknown_resources));
489             }
490              
491             my $alarm_handler_guard;
492             if ($self->resources_wait_timeout) {
493             $alarm_handler_guard = set_sig_handler('ALRM', sub {
494             local *__ANON__ = 'timed_out_resources_waiting_handler';
495             $self->_error("Reached timeout while waiting for resources");
496             }, {safe => 0});
497             alarm($self->resources_wait_timeout);
498             }
499              
500             my @resources = grep {exists $self->leases->{$_}} $self->get_resources;
501             for my $resource (@resources) {
502             if ($self->is_task_in_queue($resource)) {
503             exit;
504             } else {
505             $self->queue_up($resource);
506             }
507             }
508              
509             my @semaphores = ();
510              
511             for my $resource (@resources) {
512             $self->wait_in_queue($resource);
513             # try to acquire a semaphore until success
514             while (1) {
515             if ($self->lock_watch->{state}) {
516             $self->log->info(sprintf "Lock watch received %s while waiting for $resource semaphore, we exit", $self->lock_watch->{event});
517             exit;
518             }
519             my $semaphore = $self->acquire_semaphore($resource);
520             if ($semaphore) {
521             $self->log->debug(sprintf "Semaphore <%s> acquired", $resource);
522             push @semaphores, $semaphore;
523             last;
524             }
525             sleep 1;
526             }
527             }
528              
529             $self->log->debug("All resources acquired");
530              
531             $self->leave_queues;
532             alarm(0);
533              
534             if ($self->do_get_lock && !$self->get_lock) {
535             $self->log->info(sprintf "Lock %s already exists", $self->lockname);
536             exit;
537             }
538              
539             # We want to exit right after our child dies
540             $SIG{CHLD} = sub {
541             my $pid = wait;
542             my $exit_code = $? >> 8;
543             $self->log->warn("Child $pid exited with $exit_code") if $exit_code;
544             # THE exit
545             exit $exit_code;
546             };
547              
548             my $CHILD;
549              
550             # If we suddenly die, we won't leave our child alone
551             # Otherwise the process will be active and not holding the lock
552             $SIG{__DIE__} = sub {
553             my $msg = shift;
554             chomp $msg;
555             if ($CHILD && kill 0 => $CHILD) {
556             $self->log->warn("Parent is terminating abnormally ($msg), killing child $CHILD");
557             kill 9 => $CHILD or $self->log->warn("Failed to KILL $CHILD");
558             }
559             };
560             $SIG{TERM} = $SIG{INT} = sub {
561             my $signame = shift;
562             warn "Parent received SIG$signame, terminating child $CHILD\n";
563             if (kill $signame => $CHILD) {
564             warn "Sent SIG$signame to $CHILD\n";
565             sleep 1; # wait for process cleanup
566             }
567             if (kill 0 => $CHILD) {
568             warn "Failed to $signame $CHILD\n";
569             } else {
570             exit;
571             }
572             };
573              
574             $CHILD = $self->run_command_in_background;
575              
576             while (1) {
577             if ($self->lock_watch->{state}) {
578             $self->log->warn("It's not secure to proceed, lock watch received ".$self->lock_watch->{event});
579             $self->_stop_child($CHILD);
580             last;
581             }
582             if ($self->group && $self->prefix_data_watch->{state}) {
583             unless ($self->is_group_serviced) {
584             $self->log->info(sprintf "Group <%s> is not serviced by the current host anymore", $self->group);
585             $self->_stop_child($CHILD);
586             last;
587             }
588             }
589             sleep 1;
590             }
591             }
592              
593              
594             =head2 run_command_in_background
595              
596             Execs command
597              
598             =cut
599              
600             sub run_command_in_background
601             {
602             my $self = shift;
603              
604             my $command = join(' ', @{$self->command});
605             $self->log->info("Executing <$command>");
606              
607             my $child = fork();
608             if (!defined $child) {
609             $self->_error("Could not fork");
610             } elsif (!$child) {
611             exec(@{$self->command}) or $self->_error("Failed to exec <$command>: $!");
612             } else {
613             return $child
614             }
615             }
616              
617              
618             =head2 usage
619              
620             Shows help and exits
621              
622             =cut
623              
624             sub usage
625             {
626             pod2usage(-exitval => 1, -verbose => 99, -sections => [qw(USAGE DESCRIPTION EXAMPLES), 'SEE ALSO', 'COPYRIGHT AND LICENSE']);
627             }
628              
629              
630             =head2 version
631              
632             Shows version info and exits
633              
634             =cut
635              
636             sub version
637             {
638             print "switchman $VERSION\n";
639             pod2usage(-exitval => 1, -verbose => 99, -sections => ['COPYRIGHT AND LICENSE']);
640             }
641              
642              
643             =head2 wait_in_queue
644              
645             Waits in queue for a given resource
646              
647             =cut
648              
649             sub wait_in_queue
650             {
651             my $self = shift;
652             my $resource = shift;
653              
654             my $queue_path = $self->prefix."/$QUEUES_PATH/$resource";
655             my $queue_position = $self->queue_positions->{$resource} or $self->_error("queue position for <$resource> is not initialized");
656             my ($position) = $queue_position =~ /-(\d+)$/;
657              
658             while (1) {
659             $self->log->debug(sprintf "Wait in queue cycle for %s", $queue_position);
660             my @items = $self->zkh->get_children($queue_path);
661             if ($self->zkh->get_error) {
662             $self->_error("Could not get items in queue $queue_path: ".$self->zkh->str_error);
663             }
664             my %positions;
665             for my $item (@items) {
666             if ($item =~ /-(\d+)$/) {
667             $positions{$1} = $item;
668             } else {
669             $self->_error("Unexpected item <$item> in queue $queue_path");
670             }
671             }
672              
673             if (!exists $positions{$position}) {
674             $self->log->debug(sprintf "Our position <%s> does not exists in queue. Queue items: %s.", $position, join(', ', @items));
675             $self->_error("Lost position <$position> in queue $queue_path");
676             }
677              
678             my @prior_pos = grep {$_ < $position} keys %positions;
679             last if !@prior_pos;
680              
681             my $neighbour = max @prior_pos;
682             my $neighbour_watch = $self->zkh->watch();
683             my $neighbour_exists = $self->zkh->exists("$queue_path/$positions{$neighbour}", watch => $neighbour_watch);
684             if (($self->zkh->get_error) && $self->zkh->get_error != ZNONODE) {
685             $self->_error("Could not check $positions{$neighbour} existence: ".$self->zkh->str_error);
686             }
687             if ($neighbour_exists) {
688             $self->log->debug(sprintf 'Wait for changing %s state (%d items before us)', $positions{$neighbour}, scalar(@prior_pos));
689             $neighbour_watch->wait;
690             }
691             }
692             $self->log->debug(sprintf "Waited %s", $queue_position);
693             }
694              
695              
696             sub _error
697             {
698             my $self = shift;
699             my $message = shift;
700              
701             @_ = ($self->log, level => 'critical', message => $message);
702             my $class = blessed $self->log;
703             no strict 'refs';
704             goto &{"${class}::log_and_croak"};
705             }
706              
707              
708             sub _get_and_check_config
709             {
710             my $config_path = shift;
711              
712             open my $config_file, '<:encoding(UTF-8)', $config_path or die "Failed to open <$config_path>";
713             my $config_json = do {local $/; <$config_file>};
714             close $config_file;
715             $config_json =~ s/(?:^\s*|\s*$)//gm;
716             my $config = from_json($config_json);
717             die "zkhosts is not defined in $config_path\n" unless $config->{zkhosts};
718             die "zk chroot is not supported in older versions, use prefix in $config_path\n" if $config->{zkhosts} =~ m!/\w+!;
719             die "prefix is not defined in $config_path\n" unless $config->{prefix};
720              
721             return $config;
722             }
723              
724              
725             sub _node_data
726             {
727             return fqdn()." $$";
728             }
729              
730              
731             sub _process_resource_macro
732             {
733             my $string = shift;
734              
735             my %mem_info = Linux::MemInfo::get_mem_info();
736             my %expand = (
737             CPU => Sys::CPU::cpu_count(),
738             FQDN => fqdn(),
739             MEMMB => int($mem_info{MemTotal} / 1024),
740             );
741             my $re = join '|', keys %expand;
742             $string =~ s/($re)/$expand{$1}/eg;
743             return $string;
744             }
745              
746              
747             sub _stop_child
748             {
749             my $self = shift;
750             my $pid = shift;
751              
752             kill TERM => $pid or die "Failed to TERM $pid";
753             # give some time to terminate gracefully
754             for (1 .. $self->termination_timeout) {
755             return unless kill 0 => $pid;
756             sleep 1;
757             }
758             # ran out of patience
759             kill KILL => $pid or die "Failed to KILL $pid";
760             }
761              
762             1;
763              
764             __END__