tests/processhelp.pm

   1 #***************************************************************************
   2 #                                  _   _ ____  _
   3 #  Project                     ___| | | |  _ \| |
   4 #                             / __| | | | |_) | |
   5 #                            | (__| |_| |  _ <| |___
   6 #                             \___|\___/|_| \_\_____|
   7 #
   8 # Copyright (C) Daniel Stenberg, <daniel@haxx.se>, et al.
   9 #
  10 # This software is licensed as described in the file COPYING, which
  11 # you should have received as part of this distribution. The terms
  12 # are also available at https://curl.se/docs/copyright.html.
  13 #
  14 # You may opt to use, copy, modify, merge, publish, distribute and/or sell
  15 # copies of the Software, and permit persons to whom the Software is
  16 # furnished to do so, under the terms of the COPYING file.
  17 #
  18 # This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY
  19 # KIND, either express or implied.
  20 #
  21 # SPDX-License-Identifier: curl
  22 #
  23 ###########################################################################
  24
  25 package processhelp;
  26
  27 use strict;
  28 use warnings;
  29
  30 BEGIN {
  31     use base qw(Exporter);
  32
  33     our @EXPORT = qw(
  34         portable_sleep
  35         pidfromfile
  36         pidexists
  37         pidwait
  38         processexists
  39         killpid
  40         killsockfilters
  41         killallsockfilters
  42         set_advisor_read_lock
  43         clear_advisor_read_lock
  44     );
  45
  46     # portable sleeping needs Time::HiRes
  47     eval {
  48         no warnings "all";
  49         require Time::HiRes;
  50     };
  51     # portable sleeping falls back to native Sleep on Win32
  52     eval {
  53         no warnings "all";
  54         require Win32;
  55     }
  56 }
  57
  58 use serverhelp qw(
  59     servername_id
  60     mainsockf_pidfilename
  61     datasockf_pidfilename
  62     );
  63
  64 use pathhelp qw(
  65     os_is_win
  66     );
  67
  68 #######################################################################
  69 # portable_sleep uses Time::HiRes::sleep if available and falls back
  70 # to the classic approach of using select(undef, undef, undef, ...).
  71 # even though that one is not portable due to being implemented using
  72 # select on Windows: https://perldoc.perl.org/perlport.html#select
  73 # Therefore it uses Win32::Sleep on Windows systems instead.
  74 #
  75 sub portable_sleep {
  76     my ($seconds) = @_;
  77
  78     if($Time::HiRes::VERSION) {
  79         Time::HiRes::sleep($seconds);
  80     }
  81     elsif (os_is_win()) {
  82         Win32::Sleep($seconds*1000);
  83     }
  84     else {
  85         select(undef, undef, undef, $seconds);
  86     }
  87 }
  88
  89 #######################################################################
  90 # pidfromfile returns the pid stored in the given pidfile.  The value
  91 # of the returned pid will never be a negative value. It will be zero
  92 # on any file related error or if a pid can not be extracted from the
  93 # given file.
  94 #
  95 sub pidfromfile {
  96     my $pidfile = $_[0];
  97     my $pid = 0;
  98
  99     if(-f $pidfile && -s $pidfile && open(my $pidfh, "<", "$pidfile")) {
 100         $pid = 0 + <$pidfh>;
 101         close($pidfh);
 102         $pid = 0 if($pid < 0);
 103     }
 104     return $pid;
 105 }
 106
 107 #######################################################################
 108 # pidexists checks if a process with a given pid exists and is alive.
 109 # This will return the positive pid if the process exists and is alive.
 110 # This will return the negative pid if the process exists differently.
 111 # This will return 0 if the process could not be found.
 112 #
 113 sub pidexists {
 114     my $pid = $_[0];
 115
 116     if($pid > 0) {
 117         # verify if currently existing Windows process
 118         if ($pid > 65536 && os_is_win()) {
 119             $pid -= 65536;
 120             if($^O ne 'MSWin32') {
 121                 my $filter = "PID eq $pid";
 122                 my $result = `tasklist -fi \"$filter\" 2>nul`;
 123                 if(index($result, "$pid") != -1) {
 124                     return -$pid;
 125                 }
 126                 return 0;
 127             }
 128         }
 129
 130         # verify if currently existing and alive
 131         if(kill(0, $pid)) {
 132             return $pid;
 133         }
 134     }
 135
 136     return 0;
 137 }
 138
 139 #######################################################################
 140 # pidterm asks the process with a given pid to terminate gracefully.
 141 #
 142 sub pidterm {
 143     my $pid = $_[0];
 144
 145     if($pid > 0) {
 146         # request the process to quit
 147         if ($pid > 65536 && os_is_win()) {
 148             $pid -= 65536;
 149             if($^O ne 'MSWin32') {
 150                 my $filter = "PID eq $pid";
 151                 my $result = `tasklist -fi \"$filter\" 2>nul`;
 152                 if(index($result, "$pid") != -1) {
 153                     system("taskkill -fi \"$filter\" >nul 2>&1");
 154                 }
 155                 return;
 156             }
 157         }
 158
 159         # signal the process to terminate
 160         kill("TERM", $pid);
 161     }
 162 }
 163
 164 #######################################################################
 165 # pidkill kills the process with a given pid mercilessly and forcefully.
 166 #
 167 sub pidkill {
 168     my $pid = $_[0];
 169
 170     if($pid > 0) {
 171         # request the process to quit
 172         if ($pid > 65536 && os_is_win()) {
 173             $pid -= 65536;
 174             if($^O ne 'MSWin32') {
 175                 my $filter = "PID eq $pid";
 176                 my $result = `tasklist -fi \"$filter\" 2>nul`;
 177                 if(index($result, "$pid") != -1) {
 178                     system("taskkill -f -fi \"$filter\" >nul 2>&1");
 179                     # Windows XP Home compatibility
 180                     system("tskill $pid >nul 2>&1");
 181                 }
 182                 return;
 183             }
 184         }
 185
 186         # signal the process to terminate
 187         kill("KILL", $pid);
 188     }
 189 }
 190
 191 #######################################################################
 192 # pidwait waits for the process with a given pid to be terminated.
 193 #
 194 sub pidwait {
 195     my $pid = $_[0];
 196     my $flags = $_[1];
 197
 198     # check if the process exists
 199     if ($pid > 65536 && os_is_win()) {
 200         if($flags == &WNOHANG) {
 201             return pidexists($pid)?0:$pid;
 202         }
 203         while(pidexists($pid)) {
 204             portable_sleep(0.01);
 205         }
 206         return $pid;
 207     }
 208
 209     # wait on the process to terminate
 210     return waitpid($pid, $flags);
 211 }
 212
 213 #######################################################################
 214 # processexists checks if a process with the pid stored in the given
 215 # pidfile exists and is alive. This will return 0 on any file related
 216 # error or if a pid can not be extracted from the given file. When a
 217 # process with the same pid as the one extracted from the given file
 218 # is currently alive this returns that positive pid. Otherwise, when
 219 # the process is not alive, will return the negative value of the pid.
 220 #
 221 sub processexists {
 222     use POSIX ":sys_wait_h";
 223     my $pidfile = $_[0];
 224
 225     # fetch pid from pidfile
 226     my $pid = pidfromfile($pidfile);
 227
 228     if($pid > 0) {
 229         # verify if currently alive
 230         if(pidexists($pid)) {
 231             return $pid;
 232         }
 233         else {
 234             # get rid of the certainly invalid pidfile
 235             unlink($pidfile) if($pid == pidfromfile($pidfile));
 236             # reap its dead children, if not done yet
 237             pidwait($pid, &WNOHANG);
 238             # negative return value means dead process
 239             return -$pid;
 240         }
 241     }
 242     return 0;
 243 }
 244
 245 #######################################################################
 246 # killpid attempts to gracefully stop processes in the given pid list
 247 # with a SIGTERM signal and SIGKILLs those which haven't died on time.
 248 #
 249 sub killpid {
 250     my ($verbose, $pidlist) = @_;
 251     use POSIX ":sys_wait_h";
 252     my @requested;
 253     my @signalled;
 254     my @reapchild;
 255
 256     # The 'pidlist' argument is a string of whitespace separated pids.
 257     return if(not defined($pidlist));
 258
 259     # Make 'requested' hold the non-duplicate pids from 'pidlist'.
 260     @requested = split(' ', $pidlist);
 261     return if(not @requested);
 262     if(scalar(@requested) > 2) {
 263         @requested = sort({$a <=> $b} @requested);
 264     }
 265     for(my $i = scalar(@requested) - 2; $i >= 0; $i--) {
 266         if($requested[$i] == $requested[$i+1]) {
 267             splice @requested, $i+1, 1;
 268         }
 269     }
 270
 271     # Send a SIGTERM to processes which are alive to gracefully stop them.
 272     foreach my $tmp (@requested) {
 273         chomp $tmp;
 274         if($tmp =~ /^(\d+)$/) {
 275             my $pid = $1;
 276             if($pid > 0) {
 277                 if(pidexists($pid)) {
 278                     print("RUN: Process with pid $pid signalled to die\n")
 279                         if($verbose);
 280                     pidterm($pid);
 281                     push @signalled, $pid;
 282                 }
 283                 else {
 284                     print("RUN: Process with pid $pid already dead\n")
 285                         if($verbose);
 286                     # if possible reap its dead children
 287                     pidwait($pid, &WNOHANG);
 288                     push @reapchild, $pid;
 289                 }
 290             }
 291         }
 292     }
 293
 294     # Allow all signalled processes five seconds to gracefully die.
 295     if(@signalled) {
 296         my $twentieths = 5 * 20;
 297         while($twentieths--) {
 298             for(my $i = scalar(@signalled) - 1; $i >= 0; $i--) {
 299                 my $pid = $signalled[$i];
 300                 if(!pidexists($pid)) {
 301                     print("RUN: Process with pid $pid gracefully died\n")
 302                         if($verbose);
 303                     splice @signalled, $i, 1;
 304                     # if possible reap its dead children
 305                     pidwait($pid, &WNOHANG);
 306                     push @reapchild, $pid;
 307                 }
 308             }
 309             last if(not scalar(@signalled));
 310             portable_sleep(0.05);
 311         }
 312     }
 313
 314     # Mercilessly SIGKILL processes still alive.
 315     if(@signalled) {
 316         foreach my $pid (@signalled) {
 317             if($pid > 0) {
 318                 print("RUN: Process with pid $pid forced to die with SIGKILL\n")
 319                     if($verbose);
 320                 pidkill($pid);
 321                 # if possible reap its dead children
 322                 pidwait($pid, &WNOHANG);
 323                 push @reapchild, $pid;
 324             }
 325         }
 326     }
 327
 328     # Reap processes dead children for sure.
 329     if(@reapchild) {
 330         foreach my $pid (@reapchild) {
 331             if($pid > 0) {
 332                 pidwait($pid, 0);
 333             }
 334         }
 335     }
 336 }
 337
 338 #######################################################################
 339 # killsockfilters kills sockfilter processes for a given server.
 340 #
 341 sub killsockfilters {
 342     my ($piddir, $proto, $ipvnum, $idnum, $verbose, $which) = @_;
 343     my $server;
 344     my $pidfile;
 345     my $pid;
 346
 347     return if($proto !~ /^(ftp|imap|pop3|smtp)$/);
 348
 349     die "unsupported sockfilter: $which"
 350         if($which && ($which !~ /^(main|data)$/));
 351
 352     $server = servername_id($proto, $ipvnum, $idnum) if($verbose);
 353
 354     if(!$which || ($which eq 'main')) {
 355         $pidfile = mainsockf_pidfilename($piddir, $proto, $ipvnum, $idnum);
 356         $pid = processexists($pidfile);
 357         if($pid > 0) {
 358             printf("* kill pid for %s-%s => %d\n", $server,
 359                 ($proto eq 'ftp')?'ctrl':'filt', $pid) if($verbose);
 360             pidkill($pid);
 361             pidwait($pid, 0);
 362         }
 363         unlink($pidfile) if(-f $pidfile);
 364     }
 365
 366     return if($proto ne 'ftp');
 367
 368     if(!$which || ($which eq 'data')) {
 369         $pidfile = datasockf_pidfilename($piddir, $proto, $ipvnum, $idnum);
 370         $pid = processexists($pidfile);
 371         if($pid > 0) {
 372             printf("* kill pid for %s-data => %d\n", $server,
 373                 $pid) if($verbose);
 374             pidkill($pid);
 375             pidwait($pid, 0);
 376         }
 377         unlink($pidfile) if(-f $pidfile);
 378     }
 379 }
 380
 381 #######################################################################
 382 # killallsockfilters kills sockfilter processes for all servers.
 383 #
 384 sub killallsockfilters {
 385     my ($piddir, $verbose) = @_;
 386
 387     for my $proto (('ftp', 'imap', 'pop3', 'smtp')) {
 388         for my $ipvnum (('4', '6')) {
 389             for my $idnum (('1', '2')) {
 390                 killsockfilters($piddir, $proto, $ipvnum, $idnum, $verbose);
 391             }
 392         }
 393     }
 394 }
 395
 396
 397 sub set_advisor_read_lock {
 398     my ($filename) = @_;
 399
 400     my $fileh;
 401     if(open($fileh, ">", "$filename") && close($fileh)) {
 402         return;
 403     }
 404     printf "Error creating lock file $filename error: $!\n";
 405 }
 406
 407
 408 sub clear_advisor_read_lock {
 409     my ($filename) = @_;
 410
 411     if(-f $filename) {
 412         unlink($filename);
 413     }
 414 }
 415
 416
 417 1;