2
# Copyright (C) 2004-2006 MySQL AB
4
# This program is free software; you can redistribute it and/or modify
5
# it under the terms of the GNU General Public License as published by
6
# the Free Software Foundation; version 2 of the License.
8
# This program is distributed in the hope that it will be useful,
9
# but WITHOUT ANY WARRANTY; without even the implied warranty of
10
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
11
# GNU General Public License for more details.
13
# You should have received a copy of the GNU General Public License
14
# along with this program; if not, write to the Free Software
15
# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
17
# This is a library file used by the Perl version of mysql-test-run,
18
# and is part of the translation of the Bourne shell script with the
25
use POSIX qw(WNOHANG SIGHUP);
27
sub mtr_run ($$$$$$;$);
28
sub mtr_spawn ($$$$$$;$);
29
sub mtr_check_stop_servers ($);
30
sub mtr_kill_leftovers ();
31
sub mtr_wait_blocking ($);
32
sub mtr_record_dead_children ();
33
sub mtr_ndbmgm_start($$);
34
sub mtr_mysqladmin_start($$$);
36
sub sleep_until_file_created ($$$);
37
sub mtr_kill_processes ($);
38
sub mtr_ping_with_timeout($);
39
sub mtr_ping_port ($);
42
sub spawn_impl ($$$$$$$);
44
##############################################################################
46
# Execute an external command
48
##############################################################################
50
sub mtr_run ($$$$$$;$) {
52
my $arg_list_t= shift;
56
my $pid_file= shift; # Not used
57
my $spawn_opts= shift;
59
return spawn_impl($path,$arg_list_t,'run',$input,$output,$error,
63
sub mtr_run_test ($$$$$$;$) {
65
my $arg_list_t= shift;
69
my $pid_file= shift; # Not used
70
my $spawn_opts= shift;
72
return spawn_impl($path,$arg_list_t,'test',$input,$output,$error,
76
sub mtr_spawn ($$$$$$;$) {
78
my $arg_list_t= shift;
82
my $pid_file= shift; # Not used
83
my $spawn_opts= shift;
85
return spawn_impl($path,$arg_list_t,'spawn',$input,$output,$error,
91
sub spawn_impl ($$$$$$$) {
93
my $arg_list_t= shift;
98
my $spawn_opts= shift;
100
if ( $::opt_script_debug )
104
mtr_debug("STDIN $input") if $input;
105
mtr_debug("STDOUT $output") if $output;
106
mtr_debug("STDERR $error") if $error;
107
mtr_debug("$mode: $path ", join(" ",@$arg_list_t));
108
mtr_debug("spawn options:");
111
foreach my $key (sort keys %{$spawn_opts})
113
mtr_debug(" - $key: $spawn_opts->{$key}");
124
mtr_error("Can't spawn with empty \"path\"") unless defined $path;
131
if ( ! defined $pid )
133
if ( $! == $!{EAGAIN} ) # See "perldoc Errno"
135
mtr_warning("Got EAGAIN from fork(), sleep 1 second and redo");
140
mtr_error("$path ($pid) can't be forked, error: $!");
146
select(STDOUT) if $::glob_win32_perl;
147
return spawn_parent_impl($pid,$mode,$path);
151
# Child, redirect output and exec
153
$SIG{INT}= 'DEFAULT'; # Parent do some stuff, we don't
155
my $log_file_open_mode = '>';
157
if ($spawn_opts and $spawn_opts->{'append_log_file'})
159
$log_file_open_mode = '>>';
164
if ( $::glob_win32_perl )
166
# Don't redirect stdout on ActiveState perl since this is
167
# just another thread in the same process.
169
elsif ( ! open(STDOUT,$log_file_open_mode,$output) )
171
mtr_child_error("can't redirect STDOUT to \"$output\": $!");
177
if ( !$::glob_win32_perl and $output eq $error )
179
if ( ! open(STDERR,">&STDOUT") )
181
mtr_child_error("can't dup STDOUT: $!");
186
if ( ! open(STDERR,$log_file_open_mode,$error) )
188
mtr_child_error("can't redirect STDERR to \"$error\": $!");
195
if ( ! open(STDIN,"<",$input) )
197
mtr_child_error("can't redirect STDIN to \"$input\": $!");
201
if ( ! exec($path,@$arg_list_t) )
203
mtr_child_error("failed to execute \"$path\": $!");
205
mtr_error("Should never come here 1!");
207
mtr_error("Should never come here 2!");
209
mtr_error("Should never come here 3!");
213
sub spawn_parent_impl {
218
if ( $mode eq 'run' or $mode eq 'test' )
220
if ( $mode eq 'run' )
222
# Simple run of command, wait blocking for it to return
223
my $ret_pid= waitpid($pid,0);
224
if ( $ret_pid != $pid )
226
# The "simple" waitpid has failed, print debug info
227
# and try to handle the error
228
mtr_warning("waitpid($pid, 0) returned $ret_pid " .
229
"when waiting for '$path', error: '$!'");
230
if ( $ret_pid == -1 )
232
# waitpid returned -1, that would indicate the process
233
# no longer exist and waitpid couldn't wait for it.
236
mtr_error("Error handling failed");
239
return mtr_process_exit_status($?);
243
# We run mysqltest and wait for it to return. But we try to
244
# catch dying mysqld processes as well.
246
# We do blocking waitpid() until we get the return from the
247
# "mysqltest" call. But if a mysqld process dies that we
248
# started, we take this as an error, and kill mysqltest.
252
my $saved_exit_value;
253
my $ret_pid; # What waitpid() returns
255
while ( ($ret_pid= waitpid(-1,0)) != -1 )
257
# Someone terminated, don't know who. Collect
258
# status info first before $? is lost,
259
# but not $exit_value, this is flagged from
261
my $timer_name= mtr_timer_timeout($::glob_timers, $ret_pid);
264
if ( $timer_name eq "suite" )
267
# FIXME we should only give up the suite, not all of the run?
269
mtr_error("Test suite timeout");
271
elsif ( $timer_name eq "testcase" )
273
$saved_exit_value= 63; # Mark as timeout
274
kill(9, $pid); # Kill mysqltest
275
next; # Go on and catch the termination
279
if ( $ret_pid == $pid )
281
# We got termination of mysqltest, we are done
282
$exit_value= mtr_process_exit_status($?);
286
# One of the child processes died, unless this was expected
287
# mysqltest should be killed and test aborted
289
check_expected_crash_and_restart($ret_pid);
292
if ( $ret_pid != $pid )
294
# We terminated the waiting because a "mysqld" process died.
295
# Kill the mysqltest process.
296
mtr_verbose("Kill mysqltest because another process died");
299
$ret_pid= waitpid($pid,0);
301
if ( $ret_pid != $pid )
303
mtr_error("$path ($pid) got lost somehow");
307
return $saved_exit_value || $exit_value;
312
# We spawned a process we don't wait for
318
# ----------------------------------------------------------------------
319
# We try to emulate how an Unix shell calculates the exit code
320
# ----------------------------------------------------------------------
322
sub mtr_process_exit_status {
323
my $raw_status= shift;
325
if ( $raw_status & 127 )
327
return ($raw_status & 127) + 128; # Signal num + 128
331
return $raw_status >> 8; # Exit code
336
##############################################################################
338
# Kill processes left from previous runs
340
##############################################################################
343
# Kill all processes(mysqld, ndbd, ndb_mgmd and im) that would conflict with
345
# Make sure to remove the PID file, if any.
346
# kill IM manager first, else it will restart the servers
347
sub mtr_kill_leftovers () {
349
mtr_report("Killing Possible Leftover Processes");
350
mtr_debug("mtr_kill_leftovers(): started.");
355
foreach my $srv (@{$::master}, @{$::slave})
357
mtr_debug(" - mysqld " .
358
"(pid: $srv->{pid}; " .
359
"pid file: '$srv->{path_pid}'; " .
360
"socket: '$srv->{path_sock}'; ".
361
"port: $srv->{port})");
363
my $pid= mtr_mysqladmin_start($srv, "shutdown", 20);
365
# Save the pid of the mysqladmin process
366
$admin_pids{$pid}= 1;
369
pid => $srv->{'pid'},
370
pidfile => $srv->{'path_pid'},
371
sockfile => $srv->{'path_sock'},
372
port => $srv->{'port'},
374
$srv->{'pid'}= 0; # Assume we are done with it
377
if ( ! $::opt_skip_ndbcluster )
380
foreach my $cluster (@{$::clusters})
383
# Don't shut down a "running" cluster
384
next if $cluster->{'use_running'};
386
mtr_debug(" - cluster " .
387
"(pid: $cluster->{pid}; " .
388
"pid file: '$cluster->{path_pid})");
390
my $pid= mtr_ndbmgm_start($cluster, "shutdown");
392
# Save the pid of the ndb_mgm process
393
$admin_pids{$pid}= 1;
396
pid => $cluster->{'pid'},
397
pidfile => $cluster->{'path_pid'}
400
$cluster->{'pid'}= 0; # Assume we are done with it
402
foreach my $ndbd (@{$cluster->{'ndbds'}})
404
mtr_debug(" - ndbd " .
405
"(pid: $ndbd->{pid}; " .
406
"pid file: '$ndbd->{path_pid})");
409
pid => $ndbd->{'pid'},
410
pidfile => $ndbd->{'path_pid'},
412
$ndbd->{'pid'}= 0; # Assume we are done with it
417
# Wait for all the admin processes to complete
418
mtr_wait_blocking(\%admin_pids);
420
# If we trusted "mysqladmin --shutdown_timeout= ..." we could just
421
# terminate now, but we don't (FIXME should be debugged).
422
# So we try again to ping and at least wait the same amount of time
423
# mysqladmin would for all to die.
425
mtr_ping_with_timeout(\@kill_pids);
427
# We now have tried to terminate nice. We have waited for the listen
428
# port to be free, but can't really tell if the mysqld process died
429
# or not. We now try to find the process PID from the PID file, and
430
# send a kill to that process. Note that Perl let kill(0,@pids) be
431
# a way to just return the numer of processes the kernel can send
432
# signals to. So this can be used (except on Cygwin) to determine
433
# if there are processes left running that we cound out might exists.
435
# But still after all this work, all we know is that we have
438
# We scan the "var/run/" directory for other process id's to kill
440
my $rundir= "$::opt_vardir/run";
442
mtr_debug("Processing PID files in directory '$rundir'...");
446
opendir(RUNDIR, $rundir)
447
or mtr_error("can't open directory \"$rundir\": $!");
451
while ( my $elem= readdir(RUNDIR) )
453
# Only read pid from files that end with .pid
454
if ( $elem =~ /.*[.]pid$/)
456
my $pidfile= "$rundir/$elem";
460
mtr_debug("Processing PID file: '$pidfile'...");
462
my $pid= mtr_get_pid_from_file($pidfile);
464
mtr_debug("Got pid: $pid from file '$pidfile'");
466
if ( $::glob_cygwin_perl or kill(0, $pid) )
468
mtr_debug("There is process with pid $pid -- scheduling for kill.");
469
push(@pids, $pid); # We know (cygwin guess) it exists
473
mtr_debug("There is no process with pid $pid -- skipping.");
479
mtr_warning("Found non pid file $elem in $rundir")
480
if -f "$rundir/$elem";
488
mtr_debug("Killing the following processes with PID files: " .
489
join(' ', @pids) . "...");
493
if ( $::glob_cygwin_perl )
495
# We have no (easy) way of knowing the Cygwin controlling
496
# process, in the PID file we only have the Windows process id.
497
system("kill -f " . join(" ",@pids)); # Hope for the best....
498
mtr_debug("Sleep 5 seconds waiting for processes to die");
503
my $retries= 10; # 10 seconds
506
mtr_debug("Sending SIGKILL to pids: " . join(' ', @pids));
508
mtr_report("Sleep 1 second waiting for processes to die");
509
sleep(1) # Wait one second
510
} while ( $retries-- and kill(0, @pids) );
512
if ( kill(0, @pids) ) # Check if some left
514
mtr_warning("can't kill process(es) " . join(" ", @pids));
523
mtr_debug("Directory for PID files ($rundir) does not exist.");
526
# We may have failed everything, but we now check again if we have
527
# the listen ports free to use, and if they are free, just go for it.
529
mtr_debug("Checking known mysqld servers...");
531
foreach my $srv ( @kill_pids )
533
if ( defined $srv->{'port'} and mtr_ping_port($srv->{'port'}) )
535
mtr_warning("can't kill old process holding port $srv->{'port'}");
539
mtr_debug("mtr_kill_leftovers(): finished.");
544
# Check that all processes in "spec" are shutdown gracefully
545
# else kill them off hard
547
sub mtr_check_stop_servers ($) {
550
# Return if no processes are defined
553
mtr_verbose("mtr_check_stop_servers");
555
# ----------------------------------------------------------------------
556
# Wait until servers in "spec" has stopped listening
557
# to their ports or timeout occurs
558
# ----------------------------------------------------------------------
559
mtr_ping_with_timeout(\@$spec);
561
# ----------------------------------------------------------------------
562
# Use waitpid() nonblocking for a little while, to see how
563
# many process's will exit sucessfully.
564
# This is the normal case.
565
# ----------------------------------------------------------------------
566
my $wait_counter= 50; # Max number of times to redo the loop
567
foreach my $srv ( @$spec )
569
my $pid= $srv->{'pid'};
573
$ret_pid= waitpid($pid,&WNOHANG);
574
if ($ret_pid == $pid)
576
mtr_verbose("Caught exit of process $ret_pid");
579
elsif ($ret_pid == 0)
581
mtr_verbose("Process $pid is still alive");
582
if ($wait_counter-- > 0)
584
# Give the processes more time to exit
585
select(undef, undef, undef, (0.1));
591
mtr_warning("caught exit of unknown child $ret_pid");
596
# ----------------------------------------------------------------------
597
# The processes that haven't yet exited need to
598
# be killed hard, put them in "kill_pids" hash
599
# ----------------------------------------------------------------------
601
foreach my $srv ( @$spec )
603
my $pid= $srv->{'pid'};
606
# Server is still alive, put it in list to be hard killed
607
if ($::glob_win32_perl)
609
# Kill the real process if it's known
610
$pid= $srv->{'real_pid'} if ($srv->{'real_pid'});
614
# Write a message to the process's error log (if it has one)
615
# that it's being killed hard.
616
if ( defined $srv->{'errfile'} )
618
mtr_tofile($srv->{'errfile'}, "Note: Forcing kill of process $pid\n");
620
mtr_warning("Forcing kill of process $pid");
625
# Server is dead, remove the pidfile if it exists
627
# Race, could have been removed between test with -f
628
# and the unlink() below, so better check again with -f
629
if ( -f $srv->{'pidfile'} and ! unlink($srv->{'pidfile'}) and
630
-f $srv->{'pidfile'} )
632
mtr_error("can't remove $srv->{'pidfile'}");
637
if ( ! keys %kill_pids )
639
# All processes has exited gracefully
643
mtr_kill_processes(\%kill_pids);
645
# ----------------------------------------------------------------------
646
# All processes are killed, cleanup leftover files
647
# ----------------------------------------------------------------------
650
foreach my $srv ( @$spec )
654
# Server has been hard killed, clean it's resources
655
foreach my $file ($srv->{'pidfile'}, $srv->{'sockfile'})
657
# Know it is dead so should be no race, careful anyway
658
if ( defined $file and -f $file and ! unlink($file) and -f $file )
661
mtr_warning("couldn't delete $file");
665
if ($::glob_win32_perl and $srv->{'real_pid'})
667
# Wait for the pseudo pid - if the real_pid was known
668
# the pseudo pid has not been waited for yet, wai blocking
669
# since it's "such a simple program"
670
mtr_verbose("Wait for pseudo process $srv->{'pid'}");
671
my $ret_pid= waitpid($srv->{'pid'}, 0);
672
mtr_verbose("Pseudo process $ret_pid died");
680
# There where errors killing processes
681
# do one last attempt to ping the servers
682
# and if they can't be pinged, assume they are dead
683
if ( ! mtr_ping_with_timeout( \@$spec ) )
685
mtr_error("we could not kill or clean up all processes");
689
mtr_verbose("All ports were free, continuing");
696
# Wait for all the process in the list to terminate
697
sub mtr_wait_blocking($) {
698
my $admin_pids= shift;
701
# Return if no processes defined
702
return if ! %$admin_pids;
704
mtr_verbose("mtr_wait_blocking");
706
# Wait for all the started processes to exit
707
# As mysqladmin is such a simple program, we trust it to terminate itself.
708
# I.e. we wait blocking, and wait for them all before we go on.
709
foreach my $pid (keys %{$admin_pids})
711
my $ret_pid= waitpid($pid,0);
716
# Start "mysqladmin <command>" for a specific mysqld
717
sub mtr_mysqladmin_start($$$) {
720
my $adm_shutdown_tmo= shift;
723
mtr_init_args(\$args);
725
mtr_add_arg($args, "--no-defaults");
726
mtr_add_arg($args, "--user=%s", $::opt_user);
727
mtr_add_arg($args, "--password=");
728
mtr_add_arg($args, "--silent");
729
if ( -e $srv->{'path_sock'} )
731
mtr_add_arg($args, "--socket=%s", $srv->{'path_sock'});
733
if ( $srv->{'port'} )
735
mtr_add_arg($args, "--port=%s", $srv->{'port'});
737
mtr_add_arg($args, "--connect_timeout=5");
739
# Shutdown time must be high as slave may be in reconnect
740
mtr_add_arg($args, "--shutdown_timeout=$adm_shutdown_tmo");
741
mtr_add_arg($args, "$command");
742
my $pid= mtr_spawn($::exe_drizzleadmin, $args,
744
{ append_log_file => 1 });
745
mtr_verbose("mtr_mysqladmin_start, pid: $pid");
750
# Start "ndb_mgm shutdown" for a specific cluster, it will
751
# shutdown all data nodes and leave the ndb_mgmd running
752
sub mtr_ndbmgm_start($$) {
758
mtr_init_args(\$args);
760
mtr_add_arg($args, "--no-defaults");
761
mtr_add_arg($args, "--core");
762
mtr_add_arg($args, "--try-reconnect=1");
763
mtr_add_arg($args, "--ndb_connectstring=%s", $cluster->{'connect_string'});
764
mtr_add_arg($args, "-e");
765
mtr_add_arg($args, "$command");
767
my $pid= mtr_spawn($::exe_ndb_mgm, $args,
768
"", "/dev/null", "/dev/null", "",
770
mtr_verbose("mtr_ndbmgm_start, pid: $pid");
776
# Ping all servers in list, exit when none of them answers
777
# or when timeout has passed
778
sub mtr_ping_with_timeout($) {
780
my $timeout= 200; # 20 seconds max
781
my $res= 1; # If we just fall through, we are done
782
# in the sense that the servers don't
783
# listen to their ports any longer
785
mtr_debug("Waiting for mysqld servers to stop...");
790
foreach my $srv ( @$spec )
792
$res= 1; # We are optimistic
793
if ( $srv->{'pid'} and defined $srv->{'port'} )
795
if ( mtr_ping_port($srv->{'port'}) )
797
mtr_verbose("waiting for process $srv->{'pid'} to stop ".
798
"using port $srv->{'port'}");
800
# Millisceond sleep emulated with select
801
select(undef, undef, undef, (0.1));
807
# Process was not using port
811
last; # If we got here, we are done
816
mtr_debug("mtr_ping_with_timeout(): All mysqld instances are down.");
820
mtr_report("mtr_ping_with_timeout(): At least one server is alive.");
828
# Loop through our list of processes and look for and entry
829
# with the provided pid
830
# Set the pid of that process to 0 if found
832
sub mark_process_dead($)
836
foreach my $mysqld (@{$::master}, @{$::slave})
838
if ( $mysqld->{'pid'} eq $ret_pid )
840
mtr_verbose("$mysqld->{'type'} $mysqld->{'idx'} exited, pid: $ret_pid");
846
foreach my $cluster (@{$::clusters})
848
if ( $cluster->{'pid'} eq $ret_pid )
850
mtr_verbose("$cluster->{'name'} cluster ndb_mgmd exited, pid: $ret_pid");
851
$cluster->{'pid'}= 0;
855
foreach my $ndbd (@{$cluster->{'ndbds'}})
857
if ( $ndbd->{'pid'} eq $ret_pid )
859
mtr_verbose("$cluster->{'name'} cluster ndbd exited, pid: $ret_pid");
865
mtr_warning("mark_process_dead couldn't find an entry for pid: $ret_pid");
870
# Loop through our list of processes and look for and entry
871
# with the provided pid, if found check for the file indicating
872
# expected crash and restart it.
874
sub check_expected_crash_and_restart($)
878
foreach my $mysqld (@{$::master}, @{$::slave})
880
if ( $mysqld->{'pid'} eq $ret_pid )
882
mtr_verbose("$mysqld->{'type'} $mysqld->{'idx'} exited, pid: $ret_pid");
885
# Check if crash expected and restart if it was
886
my $expect_file= "$::opt_vardir/tmp/" . "$mysqld->{'type'}" .
887
"$mysqld->{'idx'}" . ".expect";
888
if ( -f $expect_file )
890
mtr_verbose("Crash was expected, file $expect_file exists");
891
mysqld_start($mysqld, $mysqld->{'start_opts'},
892
$mysqld->{'start_slave_master_info'});
893
unlink($expect_file);
900
foreach my $cluster (@{$::clusters})
902
if ( $cluster->{'pid'} eq $ret_pid )
904
mtr_verbose("$cluster->{'name'} cluster ndb_mgmd exited, pid: $ret_pid");
905
$cluster->{'pid'}= 0;
907
# Check if crash expected and restart if it was
908
my $expect_file= "$::opt_vardir/tmp/ndb_mgmd_" . "$cluster->{'type'}" .
910
if ( -f $expect_file )
912
mtr_verbose("Crash was expected, file $expect_file exists");
913
ndbmgmd_start($cluster);
914
unlink($expect_file);
919
foreach my $ndbd (@{$cluster->{'ndbds'}})
921
if ( $ndbd->{'pid'} eq $ret_pid )
923
mtr_verbose("$cluster->{'name'} cluster ndbd exited, pid: $ret_pid");
926
# Check if crash expected and restart if it was
927
my $expect_file= "$::opt_vardir/tmp/ndbd_" . "$cluster->{'type'}" .
928
"$ndbd->{'idx'}" . ".expect";
929
if ( -f $expect_file )
931
mtr_verbose("Crash was expected, file $expect_file exists");
932
ndbd_start($cluster, $ndbd->{'idx'},
933
$ndbd->{'start_extra_args'});
934
unlink($expect_file);
941
if ($::instance_manager->{'spawner_pid'} eq $ret_pid)
946
mtr_warning("check_expected_crash_and_restart couldn't find an entry for pid: $ret_pid");
950
##############################################################################
952
# The operating system will keep information about dead children,
953
# we read this information here, and if we have records the process
954
# is alive, we mark it as dead.
956
##############################################################################
958
sub mtr_record_dead_children () {
963
# Wait without blockinng to see if any processes had died
964
# -1 or 0 means there are no more procesess to wait for
965
while ( ($ret_pid= waitpid(-1,&WNOHANG)) != 0 and $ret_pid != -1)
967
mtr_warning("mtr_record_dead_children: $ret_pid");
968
mark_process_dead($ret_pid);
971
return $process_died;
975
# This causes terminating processes to not become zombies, avoiding
976
# the need for (or possibility of) explicit waitpid().
977
$SIG{CHLD}= 'IGNORE';
979
# On some platforms (Linux, QNX, OSX, ...) there is potential race
980
# here. If a process terminated before setting $SIG{CHLD} (but after
981
# any attempt to waitpid() it), it will still be a zombie. So we
982
# have to handle any such process here.
984
while(($pid= waitpid(-1, &WNOHANG)) != 0 and $pid != -1)
986
mtr_warning("start_reap_all pid: $pid");
987
mark_process_dead($pid);
992
$SIG{CHLD}= 'DEFAULT';
996
sub mtr_ping_port ($) {
999
mtr_verbose("mtr_ping_port: $port");
1001
my $remote= "localhost";
1002
my $iaddr= inet_aton($remote);
1005
mtr_error("can't find IP number for $remote");
1007
my $paddr= sockaddr_in($port, $iaddr);
1008
my $proto= getprotobyname('tcp');
1009
if ( ! socket(SOCK, PF_INET, SOCK_STREAM, $proto) )
1011
mtr_error("can't create socket: $!");
1014
mtr_debug("Pinging server (port: $port)...");
1016
if ( connect(SOCK, $paddr) )
1018
close(SOCK); # FIXME check error?
1019
mtr_verbose("USED");
1024
mtr_verbose("FREE");
1029
##############################################################################
1031
# Wait for a file to be created
1033
##############################################################################
1035
# FIXME check that the pidfile contains the expected pid!
1037
sub sleep_until_file_created ($$$) {
1041
my $sleeptime= 100; # Milliseconds
1042
my $loops= ($timeout * 1000) / $sleeptime;
1044
for ( my $loop= 1; $loop <= $loops; $loop++ )
1051
# Check if it died after the fork() was successful
1052
if ( $pid != 0 && waitpid($pid,&WNOHANG) == $pid )
1054
mtr_warning("Process $pid died");
1058
mtr_debug("Sleep $sleeptime milliseconds waiting for $pidfile");
1060
# Print extra message every 60 seconds
1061
my $seconds= ($loop * $sleeptime) / 1000;
1062
if ( $seconds > 1 and int($seconds * 10) % 600 == 0 )
1064
my $left= $timeout - $seconds;
1065
mtr_warning("Waited $seconds seconds for $pidfile to be created, " .
1066
"still waiting for $left seconds...");
1069
# Millisceond sleep emulated with select
1070
select(undef, undef, undef, ($sleeptime/1000));
1077
sub mtr_kill_processes ($) {
1080
mtr_verbose("mtr_kill_processes (" . join(" ", keys %{$pids}) . ")");
1082
foreach my $pid (keys %{$pids})
1087
mtr_warning("Trying to kill illegal pid: $pid");
1091
my $signaled_procs= kill(9, $pid);
1092
if ($signaled_procs == 0)
1094
# No such process existed, assume it's killed
1095
mtr_verbose("killed $pid(no such process)");
1099
my $ret_pid= waitpid($pid,0);
1100
if ($ret_pid == $pid)
1102
mtr_verbose("killed $pid(got the pid)");
1104
elsif ($ret_pid == -1)
1106
mtr_verbose("killed $pid(got -1)");
1110
mtr_verbose("done killing processes");
1114
##############################################################################
1116
# When we exit, we kill off all children
1118
##############################################################################
1122
mtr_timer_stop_all($::glob_timers);
1123
local $SIG{HUP} = 'IGNORE';
1124
# ToDo: Signalling -$$ will only work if we are the process group
1125
# leader (in fact on QNX it will signal our session group leader,
1126
# which might be Do-compile or Pushbuild, causing tests to be
1127
# aborted). So we only do it if we are the group leader. We might
1128
# set ourselves as the group leader at startup (with
1129
# POSIX::setpgrp(0,0)), but then care must be needed to always do
1130
# proper child process cleanup.
1131
POSIX::kill(SIGHUP, -$$) if !$::glob_win32_perl and $$ == getpgrp();
1136
###########################################################################
added
removed
tests/lib/mtr_process.pl
