#!/usr/bin/perl

use strict;
use warnings;
use CGI;
use utf8;

my $base='../';
my $file=$base.'pid_file_%s.txt';
my $search=$base.'pid_file_*.txt';
my $sleep=5;

my $cgi=CGI->new();
$cgi->header(-type=>"text/html",-charset=>"UTF-8");

my $name=$ENV{SCRIPT_NAME} || $0;

my $action=$cgi->param('action') || 'list';

if($action eq 'start')
{
  # KindProzess erzeuegn
  local $SIG{CHLD}='IGNORE';
  my $pid=fork();

  # undef => fork funktionierte nicht
  if(!defined($pid))
  { printerror($cgi,'Konnte Fork nicht erzeugen!'); }
  # >0 => wir sind im Elternprozess
  elsif($pid!=0)
  {
    printhtml($cgi,"Prozess $pid erzeugt",<<"EOH");
PID:$pid<br>
Aktualisierung alle $sleep Sekunden<br>
<a href="$file">Zur Testseite</a><br>
<a href="$name?action=status&pid=$pid">Status Anzeigen</a><br>
<a href="$name">Zur &Uuml;bersicht</a>
EOH
  }
  # 0 => wir sind im Kindprozess
  else
  { runn_fork(sprintf($file,$$)); }
}
elsif($action eq 'stop')
{
  # Kindprozess stoppen
  my $pid=$cgi->param('pid');
  my $time=stop_process($cgi,sprintf($file,$pid),$pid);
  if($time>-1)
  {
    printhtml($cgi,"Prozess $pid Gestoppt",<<"EOH");
PID:$pid<br>
TIME: $time SEC<br>
<a href="$name">Zur &Uuml;bersicht</a>
EOH
  }
}
elsif($action eq 'status')
{
  # Status eines bekannten Prozesses anzeigen
  my $pid=$cgi->param('pid');
  print_status($cgi,$pid,sprintf($file,$pid));
}
elsif($action eq 'list')
{
  # Liste der überwachten Prozesse anzeigen
  print_list($cgi,glob($search))
}
else
{ printerror($cgi,'Unkennte Aktion!'); }
########################################################################

########################################################################
sub stop_process
{
  my $cgi=shift;
  my $file=shift;
  my $pid=shift;
  my $time=0;
  if(-f $file)
  {
    my @data=eval{local(@ARGV)=($file); <>};
    my ($t1,$t2)=(shift(@data),pop(@data));
    ($t1)=$t1=~/\((\d+)\)/;
    ($t2)=$t2=~/\((\d+)\)/;
    kill(15,$pid);
    if(unlink($file))
    {
      return 0 unless($t1 && $t2);
      return $t2-$t1;
    }
    else
    { printerror($cgi,"Kann $file nicht l&ouml;schen! ($!)"); }
  }
  else
  { printerror($cgi,"Datei $file existiert nicht!"); }
  return -1;
}

# Im Kindprozess ausführen
sub runn_fork
{
  my $file=shift;
  close(STDIN);
  close(STDERR);
  close(STDOUT);

  # Signale Überwachen
  local $SIG{TERM}=sub{
    # Programm beenden
    print2file($file,'SIGTERM');
    exit();
  };
  local $SIG{KILL}=sub{
    # Programm abbrechen
    print2file($file,'SIGKILL');
    exit();
  };
  local $SIG{XCPU}=sub{
    # Wegen ungenügender Prozssorleistung abbrechen
    print2file($file,'SIGXCPU');
    exit();
  };
  local $SIG{XFSZ}=sub{
    # Wegen Ungenügendem Speicherplatz (RAM/DISK)? abbrechen
    print2file($file,'SIGXFSZ');
    exit();
  };

  # datei anlegen
  if(open(my $fh,'>',$file))
  { close($fh); }
  print2file($file,'START') || exit;

  while(1)
  {
    #abbruch wenn die datei nicht mehr zu öffen ist oder nicht mehr existiert!
    print2file($file,'ALIVE') || exit;
    sleep(5);
  }
}

sub print2file
{
  use Fcntl ':flock';
  my $file=shift;
  my $cmd=shift || '';
  if($file && -f $file && open(my $fh,'>>',$file))
  {
    flock($fh, LOCK_EX);
    print $fh $cmd.": ".localtime()."  (".time.")\n";
    close($fh);
    return 1;
  }
  return 0;
}

########################################################################
sub print_list
{
  my $cgi=shift;
  my $list="\n";
  my $name=$ENV{SCRIPT_NAME} || $0;
  for my $file (@_)
  {
    my ($pid)=$file=~/(\d+)/;
    my $status=psstatus($pid);
    if($status eq 'STOPPED')
    {
      my $time=stop_process($cgi,$file,$pid);
      return if($time == -1);
      $list.=qq#          <li>$status: $pid TIME: $time SEC</li>\n#;
    }
    else
    { $list.=qq#          <li>$status: <a href="$file">$file</a> - <a href="$name?action=stop&pid=$pid">PROZESS STOPPEN</a> - <a href="$name?action=status&pid=$pid">PROZESS STATUS</a></li>\n#; }
  }
  my $ps=pslist();
  printhtml($cgi,'Fork List',<<EOH);
<a href="$name?action=start">Neuen Prozess erzeugen</a>
<ul>$list</ul>
<hr>
<pre>$ps</pre>
<br><a href="$name">weiter</a>
EOH
}

########################################################################
sub print_status
{
  my $cgi=shift;
  my $pid=shift;
  my $file=shift;
  my $data=eval{local ($/,@ARGV)=(undef,$file); <>} || '';
  my $status=psstatus($pid);
  my $name=$ENV{SCRIPT_NAME} || $0;
  printhtml($cgi,'Fork Status', <<EOH);
PID:$pid<br>
STATUS:$status<br>
<pre>$data</pre>
<a href="$name">weiter</a>
EOH
}

########################################################################
########################################################################

########################################################################
sub printerror
{
  my $cgi=shift;
  my $err='';
  my $name=$ENV{SCRIPT_NAME} || $0;
  $err.="<h3>MESSAGE</h3>\n<pre>\n$_\n</pre>\n" for(@_);
  printhtml($cgi,'ERROR',$err.qq#<br><a href="$name">weiter</a>#);
}

########################################################################
sub printhtml
{
  my $cgi=shift;
  my $title=shift || '';
  my $body=shift || '';
  my $unique='X';
  $unique.=chr(int(65+rand(25))) while(index($unique,$body)>-1);
  my %pre;
  my $cnt=0;
  while($body=~m!<pre>(.+?)</pre>!sgc)
  {
    my $val=$1;
    my $symbol=sprintf('%s%08u',$unique,$cnt);
    $pre{$symbol}=$val;
    $body=~s!\Q<pre>$val</pre>!$symbol!gs;
    $cnt++;
  }
  $body=~s/(^|\n)/$1    /gs;
  $body=~s!\s*($unique\d{8})!\n    <pre>$pre{$1}</pre>!g;
  if($cgi)
  { print $cgi->header(); }
  else
  { print "Content-Type: text/html\r\n\r\n"; }
  print <<"EOHTML";
<html>
  <head><title>$title</title></head>
  <body>
    <center><h1>$title</h1></center>
$body
  </body>
</html>
EOHTML

}

########################################################################
########################################################################

########################################################################
sub pslist
{
  my ($name)=($ENV{SCRIPT_NAME} || $0)=~m!/([^/]+)$!;
  my $cmd_f='/bin/ps';
  my $cmd_o='aux';
  if(-f $cmd_f)
  {
    my $cmd="$cmd_f $cmd_o";
    my @list=`$cmd`;
    if(@list)
    {
      my $ret=shift(@list);
      $ret.=join'',grep{/\Q$name/}@list;
      return $ret;
    }
    else
    {return qq(CAN'T CALL "$cmd" ($@))}
  }
  else
  { return qq(CAN'T find "$cmd_f"); }
}

########################################################################
sub psstatus
{
  my $pid=shift;
  my ($name)=($ENV{SCRIPT_NAME} || $0)=~m!/([^/]+)$!;
  if(-d "/proc")
  {
    if(-d "/proc/$pid")
    {
      my $cmdline=eval{local($/,@ARGV)=(undef,"/proc/$pid/cmdline"); <>};
      return 'RUNNING' if($cmdline=~/\Q$name/);
    }
    return 'STOPPED';
  }
  else
  {
    my $ret=kill(0,$pid);
    if(defined($ret))
    {
      my $data=eval{local($/,@ARGV)=(undef,sprintf($file,$pid)); <>};
      return 'RUNNING' if($ret && $data!~/SIG/);

      return 'STOPPED' if(!$ret && $data=~/SIG/);

      return 'POSSIBLE RUNNING (can\'t verify)' if($data!~/SIG/);
    }
  }
  return 'STATUS UNKOWN';
}