InfoMagic Source Code 1993 July/THE_SOURCE_CODE_CD_ROM.iso/languages/perl/scripts-osu/snoop.shar

Internet Message Format | 1991-02-11 | 10.6 KB

Path: tut.cis.ohio-state.edu!VAX1.CC.UAKRON.EDU!mcs.kent.edu!usenet.ins.cwru.edu!gatech!mcnc!uvaarpa!mmdf
From: [e-mail] (Ted Stefanik)
Newsgroups: comp.lang.perl
Subject: Here's a poor man's "remote perl debugger"
Message-ID: <[e-mail]>
Date: 12 Feb 91 18:12:25 GMT
Sender: [e-mail] (Uvaarpa Mail System)
Reply-To: [e-mail]
Organization: The Internet
Lines: 276

This year at the X Technical Conference, a paper called Tcl/Tk was presented.
Tcl is "an embeddable command language intended for interactive applicaitons."
One of the interesting things about Tcl is its send command, "which allows any
[Tcl] application to invoke arbitrary Tcl operations in any other application."
The send command "allows applications to work together so that a collection
of small reusable programs can be used to solve problems that previously
would have required a single monolithic application."

I was intrigued by this feature, particulary after seeing it demonstrated in an
Tk/X11 interface control-panel application which was used to interactively tune
another running application.  So... I implemented the beginnings of a send
feature for Perl, in hopeful anticipation of an X11 interface for Perl.

Until then, I have found this feature quite useful anyway!  We have several
long-running (2+ CPU hour) data manipulation scripts written in Perl, and it is
nice to keep tabs on them, and sometimes debug them.  This would be great to
debug daemons, too.  A send-like feature serves as a poor man's remote
debugger or attach feature.  Therefore I named the package "snoop".

The shar (included herein) file includes three items:
   1) snoop.pl - The snoop package
   2) snoopme  - A sample application willing to be snooped on
   3) snoop    - A simple snooper.

For an example of how it works, try the following commands:

   snoopme
   snoop snoopme
   $inc += 20;
   ^C

Caveats:
   1) The sample application does not invoke snoop() with the issolate feature;
      therefore any snooper can modify the application in any way.  If this
      scares you, be sure to invoke snoop with the issolate argument set true.

   2) The snoop package requires socket IPC.  Systems without sockets are out
      of luck (and I don't know how to implement it in System V IPC).

   3) The snoop package uses a fcntl(F_ASYNC) which causes the IPC socket
      generate a SIGIO signal when a new connection is ready.  (If your
      application alreay uses SIGIO, snoop will probably not work.)

   4) The code to save and restore the application's context around snoop
      events was stolen from perldb.  I have no idea if it is all that is
      necessary and sufficient to preserve context, but it seems to work.

   5) The snoop package was developed and tested on a DECStation 2100 with
      Ultrix 3.1 and Perl 3.044.  Your mileage may vary.

   6) You have the right to freely copy and distribute this code (but if you
      do it in a wildly profitable way, throw some crumbs to the author!)

   7) Because it is free, snoop has no warranty, either expressed or implied.

   8) Security: What security?  When X11-Perl comes around, I'll probably
      include the "magic cookie" security and a more appropriate mechanism
      to name the target.  Until then, you better trust the other users or
      add some mechanism to authenticate the snoopers.

#--------------------------------CUT HERE-------------------------------------
#! /bin/sh
#
# This is a shell archive.  Save this into a file, edit it
# and delete all lines above this comment.  Then give this
# file to sh by executing the command "sh file".  The files
# will be extracted into the current directory owned by
# you with default permissions.
#
# The files contained herein are:
#
# -rwxr-x---  1 ted           172 Feb 12 12:05 snoop
# -rw-r--r--  1 ted          5304 Feb 12 12:16 snoop.pl
# -rwxr-x---  1 ted           195 Feb 12 12:05 snoopme
#
echo 'x - snoop'
if test -f snoop; then echo 'shar: not overwriting snoop'; else
sed 's/^X//' << '________This_Is_The_END________' > snoop
X#!/usr/local/gbin/perl
X
Xrequire 'snoop.pl';
X
X@names = @ARGV;
Xundef @ARGV;
X
Xwhile (<>)
X{
X   @result = &snoop($_, @names);
X   print "The answer is: @result\n\n";
X}
X
Xexit(0);
________This_Is_The_END________
if test `wc -l < snoop` -ne 14; then
    echo 'shar: snoop was damaged during transit (should have been 14 bytes)'
fi
fi        ; : end of overwriting check
echo 'x - snoop.pl'
if test -f snoop.pl; then echo 'shar: not overwriting snoop.pl'; else
sed 's/^X//' << '________This_Is_The_END________' > snoop.pl
X#
X# snoop.pl allows a process to send perl commands to another for evaluation
X#
X# By Ted Stefanik ([e-mail])
X#    February 12, 1991
X#
X
Xpackage SNOOP;
X
Xrequire 'sys/socket.ph';
Xrequire 'fcntl.ph';
X
X
Xsub main'snoopon
X{
X   local($isolate,                                  # Issolate snoops with fork
X         @names) = @_;                              # Socket address name(s)
X
X   local($filename, $line);
X   ($package, $filename, $line) = caller;           # Grab $package for correct
X                                                    #   context during snoops
X
X   local($addr);                                    # Make socket address,
X   ($sock, $addr) = &makeaddr(@names);              #   then open master socket
X
X   socket(S, &AF_UNIX,&SOCK_STREAM,&PF_UNSPEC) || die("socket: $!\n");
X   (! -e $sock || unlink($sock))               || die("unlink \"$sock\"\n");
X   bind(S, $addr)                              || die("bind($sock): $!\n");
X   fcntl(S, &F_SETFL, &FASYNC + 0)             || die("fcntl(FASYNC): $!\n");
X   fcntl(S, &F_SETOWN, $$ + 0)                 || die("fcntl(F_SETOWN): $!\n");
X   listen(S, 5)                                || die("bind: $!\n");
X
X   $sv = '';                                        # Set up bit vector for
X   vec($sv, fileno(S), 1) = 1;                      #   catch's select
X
X   $snoopbyfork = $isolate;
X   $SIG{'IO'} = "SNOOP'catch";                      # Catch new connections
X
X   return(undef);
X}
X
Xsub main'snoopoff
X{
X   unlink($sock)                               || die("unlink($sock): $!\n");
X   return(undef);
X}
X
Xsub main'snoop
X{
X   local($request,                                  # The snooping command
X         @names) = @_;                              # Socket address name(s)
X
X   local($sock, $addr) = &makeaddr(@names);
X
X#  local(*S);                                       # Can't due to Perl bug???
X   socket(S, &AF_UNIX,&SOCK_STREAM,&PF_UNSPEC) || die("socket: $!\n");
X   setsockopt(S, &SOL_SOCKET, &SO_LINGER, undef);   # Open a connection socket,
X   local($oldfh) = select(S);                       #   set to linger on close
X   $| = 1;                                          #   and unbuffered I/O
X   select($oldfh);
X
X   connect(S, $addr)                           || die("connect($sock): $!\n");
X   send(S, $request, 0)                        || die("send(snoop): $!\n");
X   send(S, "__SOCKETEND__\n", 0)               || die("send(EOF): $!\n");
X
X   local(@result) = <S>;                            # Get the reply
X   close(S);
X   return (@result);                                #   and return it
X}
X
X
Xsub catch
X{
X   local(@saved) = ($_, $@, $!, $[, $,, $/, $\);    # Save context
X                                                    #   (Stolen from perldb)
X   local($sig) = @_;                                # Make sure we caught the
X   die("Erroneously caught a SIG$sig\n")            #   correct signal
X      if ($sig != "IO");
X
X   local($j);
X   return (undef)                                   # Make sure the signal
X      if (select($j=$sv, $j=$sv, $j=$sv, 0) == 0);  #   came from master
X
X   &docatch()                                       # Handle the signal
X      if (!$snoopbyfork || fork() == 0);            #   (maybe fork first)
X
X   ($_, $@, $!, $[, $,, $/, $\) = @saved;           # Restore context
X
X   return(undef);
X}
X
Xsub docatch
X{
X   $[ = 0; $, = ""; $/ = "\n"; $\ = "";
X
X   local($usercontext) = '($_, $@, $!, $[, $,, $/, $\) = @saved;' .
X      "package $package;";
X
X   accept(NS,S) || die("accept: $!\n");             # Open new connection
X   setsockopt(S, &SOL_SOCKET, &SO_LINGER, undef);   #   set to linger on close
X   local($oldfh) = select(NS);                      #   and unbuffered I/O
X   $| = 1;
X   select($oldfh);
X
X   undef $command;                                  # Receive command from
X   NSloop: while(<NS>)                              #   socket connection
X   {                                                #   until the hack EOF mark
X      last NSloop
X         if ($_ eq "__SOCKETEND__\n");
X      $command .=  $_;
X   }
X
X   $result = eval("$usercontext $command");         # Evaluate the command in
X   $result = $@                                     #   snoopon() caller's pkg
X      if ($@ ne '');                                #   with current context
X
X   send(NS, $result, 0);                            # Send the results back
X   close(NS);
X
X   kill(9, $$)                                      # Exit just hangs???
X      if ($snoopbyfork);
X
X   return(undef);
X}
X
Xsub makeaddr
X{
X   local(@names) = @_;                              # Take a list of names
X   local($sock, $addr);                             #   and convert it to a
X                                                    #   file system socket
X   $sock="/tmp/";                                   #   address located in
X                                                    #   /tmp.  The names are
X   foreach $name (@names)                           #   joined with ".",
X   {                                                #   and have any "/"s
X      $name =~ s|/|!|go;                            #   converted to "!".
X      $sock .= "$name.";
X   }
X
X   $addr = pack('Sa*', &AF_UNIX, $sock);            # An address suitable for
X                                                    #   use with bind(2).
X   return ($sock, $addr);
X}
X
X1;
________This_Is_The_END________
if test `wc -l < snoop.pl` -ne 144; then
    echo 'shar: snoop.pl was damaged during transit (should have been 144 bytes)'
fi
fi        ; : end of overwriting check
echo 'x - snoopme'
if test -f snoopme; then echo 'shar: not overwriting snoopme'; else
sed 's/^X//' << '________This_Is_The_END________' > snoopme
X#!/usr/local/gbin/perl
X
Xrequire 'snoop.pl';
X
X&snoopon(0, $0);
X$SIG{'INT'} = "done";
X
Xwhile(1)
X{
X   print "Dum dee dum... " . $inc++ . "\n";
X   sleep(1);
X}
X
Xsub done
X{
X   &snoopoff;
X   exit(0);
X}
________This_Is_The_END________
if test `wc -l < snoopme` -ne 18; then
    echo 'shar: snoopme was damaged during transit (should have been 18 bytes)'
fi
fi        ; : end of overwriting check
exit 0