#!/usr/bin/perl

use strict;
use warnings;

$^O =~ m/MSWIN/i or die "\nTHIS DEMO REQUIRES WINDOWS.\n";

my $PERL_EXEC = "TINYPERL.EXE";
my $PERL_DIR = "C:\\BIN\\PERL\\";  # If you put anything here, it must
+ end with a backslash.
my $USE_PERL_SWITCHES = "-I C:\\BIN\\PERL\\LIB";
my $SELF_ID = 'PROC' . int(rand() * 9999999);
my $AM_I_CHILD = (join('', @ARGV) =~ m/CHILD/i);
my $CHILDREN = 0;
my @PID_NO;
my @PID_ID;
my @PID_T;
ENUM('ALREADY EXISTING');

for (;;)
{
  print("\n\tI AM " . ($AM_I_CHILD ? "A CHILD" : "THE PARENT"), " PROC
+ESS.\n");
  print "\n\tMY IDENTITY      : $SELF_ID";
  print "\n\tTHE CURRENT TIME : " . localtime();
  print "\n\tTHE VALUE OF \$0  : $0";
  print "\n\tMY ARGUMENTS     : @ARGV";
  print "\n\tCHILD PROCS      : $CHILDREN";
  print "\n\tCURRENT DIR      : ", `CD`;
  print "\n\tHERE IS A LIST OF PERL PROCESSES CURRENTLY RUNNING:\n";
  for (my $i = 0; $i < @PID_NO; $i++)
  { print "\n\t\t PID: ", $PID_NO[$i], "\t", $PID_ID[$i], "\tstarted: 
+", (time - $PID_T[$i]), ' sec. ago'; }
  print "\n\n";
  print "\n\tTYPE \"S <PID>\" TO STOP A CHILD PROCESS.";
  print "\n\tTYPE \"N\" TO START A NEW PROCESS.";
  print "\n\tTYPE \"L\" TO STOP ALL MY CHILD PROCESSES.";
  print "\n\tTYPE \"X\" TO EXIT THIS PROCESS ONLY.";
  print "\n\tTYPE \"E\" TO END THIS PROCESS (AND ALL CHILD PROCESSES).
+";
  print "\n\tTYPE \"A\" TO KILL ALL PERL PROCESS IN MEMORY (OTHERS AS 
+WELL).";
  print "\n\n\t> ";
  $a = <STDIN>;
  if ($a =~ m/X/i) { exit(); }
  if ($a =~ m/N/i) { FORK(); }
  if ($a =~ m/S/i) { STOP_ONE_CHILD($a); }
  if ($a =~ m/L/i) { KILLALL_CHILD(); }
  if ($a =~ m/E/i) { KILLALL_CHILD(); exit; }
  if ($a =~ m/A/i) { KILLALL_PERL(); exit; }
  system('CLS');
  ENUM('OTHER NEW');  # All perl processes started by child processes
                      # will be labeled as "OTHER" and will not be
                      # considered a "direct relative" of this process
+.
}

sub ENUM
{
  my $ADD = shift;
  my $LIST = uc(`tasklist`);
  for (my $i = 0; $i < length($LIST); $i++)
  {
    my $P = index($LIST, uc($PERL_EXEC), $i);
    if ($P < 0) { last; }
    my $PID = substr($LIST, $P + 28, 5);
    $i = $P + 30;

    $PID =~ tr|0-9||cd;  # Keep digits only
    # Look up PID in our database
    my $FOUND = 0;
    foreach (@PID_NO) { if ($PID eq $_) { $FOUND = 1; last; }}
    if ($FOUND == 0)
    {
      push(@PID_NO, $PID);
      push(@PID_ID, $ADD);
      push(@PID_T, time);
    }
  }
  # If there is only one process running, then that's myself.
  if (@PID_ID == 1) { @PID_ID = ('SELF'); }
}

sub STOP_ONE_CHILD
{
  my $USER_INPUT = shift;
  $USER_INPUT =~ tr|0-9||cd;  # Keep digits only.
  my $MYCHILD = 0;
  for (my $i = 0; $i < @PID_NO; $i++)
  {
    if ($USER_INPUT eq $PID_NO[$i] && $PID_ID[$i] eq 'CHILD')
    { $MYCHILD = 1; last; }
  }
  if ($MYCHILD) { system("TASKKILL /F /PID $USER_INPUT"); }
}

sub KILLALL_CHILD
{
  my $CMD = '';
  for (my $i = 0; $i < @PID_NO; $i++)
  {
    if ($PID_ID[$i] eq 'CHILD')
    {
      $CMD .= ' /PID ' . $PID_NO[$i];
      $PID_ID[$i] = 'STOPPED BY PARENT';
    }
  }
  if (length($CMD)) { system("TASKKILL /F $CMD"); }
}

sub KILLALL_PERL
{
  for (my $i = 0; $i < @PID_NO; $i++)
  { system("TASKKILL /F /IM $PERL_EXEC"); }
}

sub FORK
{
  system("START $PERL_DIR$PERL_EXEC $USE_PERL_SWITCHES $0 CHILD $SELF_
+ID");
  $CHILDREN++;
  ENUM('CHILD');
}
[download]

2023-04-04 Reparented by Athanasius.