#!/usr/bin/perl

# lets you run strace from within any program
# Copyright Quoll Technology 2001
# Author: Leon Harris
# Version: 0.1
# Released under GPL.
# For documentation, run pod2text|less

=head1 NAME

Strace Listener

=head1 SYNOPSIS

strace_listener

=head1 DESCRIPTION

B<Strace Listener> listens to a fifo and accepts commands that 
control the starting and stopping of logging of system calls.
It can tell you useful information such as where your program
is blocking on reading a file, if your program can't find a file
it is expecting, and generally just what the hell your program 
thinks it is doing at a library level. Strace Listener is 
particularly helpful with an application server such as RedHats
B<Interchange>, where it can let you use a familiar and loved 
debugging tool (strace). Strace is the sys admins friend - and 
now you can start it from within scripting languages.


=head1 PROTOCOL DESCRIPTION 
B<Strace Listener> has a very simple protocol, consisting of 
4 commands - B<C<START STOP STATUS QUIT>> 
B<C<START>> and B<C<STOP>> require the PID of the process to start 
and stop monitoring. B<C<STATUS>> and B<C<QUIT>> require no further 
arguments. In the next version of this program, a log target 
(file or syslog) and a text message may also be passed to 
control the destination of the log and to label the log respectively.
A command may be no more than 127 characters long, and may not 
contain the metacharacters B<;|&*^\> . 


=head1 USAGE

=head2 Starting The Server

To start listening, simply run B<strace_logger>. One way to do 
this in interchanges init scripts is to add the line

C<  debug)
        echo -n "Starting interchange in debug mode: "
        daemon interchange || strace_logger
        echo
        touch /var/lock/subsys/interchange
        ;;
>

to /etc/rc.d/init.d/interchange


=head2 Starting strace within a program

When you get to a portion of code you wish to debug, you can tell 
B<strace_listener> to strace the program.

In perl, this is done by


C<
open STRHANDLE, "E<gt>/tmp/strcfifo";
print STRHANDLE "start $$";
close (STRHANDLE); 
>

In B<interchange>, add the following UserTag to your usertags directory


B<stracestart>:



UserTag stracestart Documentation <<EOD

This tags tells the strace_listener to start strace (1)

for the current process.

Options:
Currently there are no options.

Example:
  [stracestart]

See Also:
  [stracestop]

EOD

UserTag stracestart Routine <<EOR

sub {

my $PID=$$;

open (STRHANDLE, "> /tmp/strcfifo");

print STRHANDLE "start $PID \n";

::logGlobal("started strace on $PID");

close (STRHANDLE);

return "<pre>$@</pre>" if $@;

return " watching pid $PID";

}

EOR



B<stracestop>:


UserTag stracestop Documentation <<EOD

This tags tells the strace_listener to stop strace (1)

for the current process.

Options:

Currently there are no options.

Example:

  [stracestop]

Bugs:
  currently, this works best if stracestart and stracestop are

  close together - interchange is funny with pids. Next version

  will either read from a file, set a global variable or otherwise

  overcome this.

See Also: [stracestart]

EOD

UserTag stracestop Routine <<EOR

sub {

my $PID=$$;

open (STRHANDLE, "> /tmp/strcfifo");

print STRHANDLE "close $PID\n";

close STRHANDLE;

return "<pre>$@</pre>" if $@;

return $PID;

}

EOR

=end text


=cut

use locale;

print "my pid is $$\n";
# apoptosis, not necrosis
$SIG{INT} = $SIG{TERM} = $SIG{HUP}= \&reap_all;
$SIG{CHILD}='IGNORE';
my $fifo="/tmp/strcfifo";
local %children;

sub fifo_exists {
# return code logic is opposite of usual success/failure model
   ($fifo)=@_;
   if  ( -p $fifo ) {print "is_fifo\n" &&return (1)};
   print "is_not_fifo\n" && return (0);
}

sub open_fifo {
my  ($fifo)=@_;
  open(CMDFIFO, "< $fifo") or die "cant open strace command pipe: $! $fifo\n";
}

sub get_cmd {
while ( <CMDFIFO> ) {
  return ($_);
 }
}

sub validate_cmd {
  my $line=$_;

  # line is less than 128 chars
  # has no dodgy punctuation

  if ( length $line > 127  or  $line =~ m/[;&^|\\]/ ) {
     return (1);
    }
  return (0);
}

sub parse_cmd {

  my @tokens=split / /, $_;
  die "invalid number of arguments in command" if ( $#tokens > 3 );

  $tokens[0]=uc($tokens[0]);
# check for valid pid

  my $rc=getpgrp $tokens[1];
if ($rc != -1) {
# PID exists, check for start and stop  


  if ( $tokens[0] eq "START")  {
    print "$tokens[0]";
    &start_strace(@tokens);
    undef @tokens;
    return (0);
   }

  elsif ($tokens[0] eq "STOP") {
    print "$tokens[0]";
    &stop_strace(@tokens);
    undef @tokens;
    return (0);
   }
}

# these options don't require valid PIDS
  if ($tokens[0] eq "STATUS") {
    print "$$ listening on $fifo\n";

    while ( ($target,$pid)= each(%children) ) {
      print "strace child process $pid listening to process $target\n";
     }
    undef @tokens;
    return (0);
   }

  elsif ($tokens[0] eq "QUIT") {
    &reap_all;
   }

  else {
    #command unrecognised
    undef @tokens;
    return (0);
   }
}

sub start_strace {
@args=@_;

    if ( ! $children{$args[1]} ) {

$logfile="/tmp/stracelog".$args[1];
open LOGFILE, "> $logfile";
open STDOUT, ">&LOGFILE";
open STDERR, ">&LOGFILE";
$kidpid=open STRACELOG, "/usr/bin/strace  -p $args[1] | " or die "strace failed to open";

      $children{$args[1]}=$kidpid;
     }
    else {
      print " Process $args[1] is already being watched by strace pid $children{$tokens[1]} \n";
      return (1);
        }

}


sub stop_strace {

@arg=@_;
print "killing $arg[1]\n";
kill 15,  $arg[1];
delete($children{$args[1]});
print "stopping $arg[1]\n";

}




sub reap_all {

while (($pid,$kid) = each(%children )) {
  kill 15 => $kid;
 }
 close(CMDFIFO) && print "fifo closed properly\n";
print "cleaning up\n";
exit;
}


#####MAIN#####
if ( &fifo_exists($fifo)  && &open_fifo($fifo) ) {
#&open_fifo($fifo); 
 while (1) {

    $line=&get_cmd;
    &validate_cmd($line) ;
    &parse_cmd($line);
    undef $line;
   }

  &reap_all;   
 }