home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / languages / perl / scripts-convex / pt.shar / pt / pt.pl < prev    next >
Encoding:
Text File  |  1993-05-26  |  6.1 KB  |  258 lines
  1. #
  2. # pt -- print process tree
  3. #     Tom Christiansen <tchrist@convex.com>
  4. #       version 1.0, Tuesday Jun 30 18:29:49 CDT 1992
  5. #    
  6. #    Modification History
  7. #    version 1.1, Wed Jul  1 14:58:54 CDT 1992
  8. #        Chop long lines to winsize unless -w supplied
  9. #        Add -a for all procs irrespective of platform
  10. #        Changed parse bailout to warning
  11. #        Added Configure script
  12. #        Numerous hacks to deal with various braindead
  13. #        vendors garbled ps output
  14. #        
  15. #
  16. # run ps and display process hierarchy indented
  17. # under parents.
  18. #
  19. # Options:
  20. #     [-l level]    limits level of children printed
  21. #     [-i indent]    change indent level from default
  22. #    [-w]         allow lines to be as long as you want.
  23. #
  24. # 
  25.  
  26.  
  27. # don't use require so that it runs on ancient versions of perl
  28.     # require 'getopts.pl';
  29.     $file = 'getopts.pl';
  30.     $return = do $file;
  31.     die "couldn't parse $file: $@" if $@;
  32.     die "couldn't do $file: $!" unless defined $return;
  33.     die "couldn't run $file" unless $return;
  34.  
  35. $VERSION = '1.1';
  36. $AUTHOR = 'tchrist@convex.com';
  37.  
  38. $| = 1;
  39.  
  40. #$$# $PS = "ps";            # a path to ps, usually /bin
  41. #$$# $TIOCGWINSZ = 0x40087468;           # should be require sys/ioctl.ph
  42. #$$# $DEATH_STAR = 0;            # ARGS: ps -el, not ps wwaxl
  43. #$$# $FLAG_WIDTH = 7;
  44. #$$# $FIRST_SPLIT = '^(\s*[\da-fA-F]+)\s*([\-\d]+)\s+(\d+)\s+(\d+)';
  45.  
  46. die "Didn't you run Configure?"
  47.     unless 4 == grep(defined,$PS,$TIOCGWINSZ,$DEATH_STAR,$FLAG_WIDTH);
  48.  
  49. $indent = 2;               # reset via -i switch
  50.  
  51. $debug = 0;
  52.  
  53.  
  54. ########################################################
  55.  
  56. if ($DEATH_STAR) {
  57.     $PS_ARGS = "-l"; 
  58.     $EVERYBODY = "e";
  59. } else {
  60.     $PS_ARGS = "xlww";
  61.     $EVERYBODY = "a";
  62. }
  63.  
  64. ########################################################
  65.  
  66. $maxlevel = 10_000_000;  # reset via -l switch
  67.  
  68. sub usage {
  69.     local($msg) = shift;
  70.     print STDERR "$0: $msg\n" if $msg;
  71.     die <<EOF;
  72. usage: $0 [-a] [-d] [-w] [ps args] [pid list]
  73.         (version: $VERSION   author: $AUTHOR)
  74.  
  75.     -w     wide output (don't trunc at winsize)
  76.     -a    all processes, not just mine
  77.     -d    print out debugging information
  78. EOF
  79. } 
  80.  
  81. &Getopts('dl:i:wa') || &usage();
  82.  
  83. $maxlevel = $opt_l if $opt_l;
  84. $indent = $opt_i if $opt_i;
  85. $wide = $opt_w;
  86. $debug = $opt_d;
  87.  
  88. while (defined($_ = shift)) {  # curse pid 0
  89.     if (/^(\d+)$/) {
  90.     $pids{$1}++;
  91.     $pids++;  # needed for ancient perl, who can't do if %pids
  92.     } else {
  93.     $PS_ARGS .= "$_ ";
  94.     }
  95. } 
  96.  
  97. $wide || &getwin;
  98.  
  99. $PS_ARGS =~ s/^(-?)/${1}${EVERYBODY}/ if $pids || $opt_a;
  100.  
  101. $ps = "$PS $PS_ARGS";
  102.  
  103. print "opening pipe to $ps\n" if $debug;
  104.  
  105. open(PS, "$ps |") || die "can't fork: $!";
  106. <PS>; # header
  107.  
  108. printf("%-8s %5s %8s %7s %s\n", 'USER', "PID", "TTY", "TIME","COMMAND");
  109.  
  110. while (<PS>) {
  111.     ($flags, $uid, $pid, $ppid) = /$FIRST_SPLIT/o;
  112.     ($tty, $time, $secs, $command) = /(\S+)\s*(\d+:\d+(\.\d\d)?)\s+(.*)/;
  113.  
  114.     unless (grep(defined,$uid,$pid,$ppid,$tty,$time,$command) == 6) {
  115.     warn "skipping unparsable line from ps:\n$_";
  116.     $oops++;
  117.     next;
  118.     }
  119.  
  120.     if ($debug) {
  121.     print <<EOF;
  122. flags are <$flags>, uid is <$uid>, pid is <$pid>, ppid is <$ppid>
  123. tty is <$tty>, time is <$time>, command is <$command>
  124.  
  125. EOF
  126.     } 
  127.  
  128.     # incredibly disgusting hack should FLAGS and UID collide
  129.     # why oh why must vendors be so damn sysadmin-hostile?
  130.     # don't they understand we have to parse this stuff??
  131.     #     maybe should try $flags =~ /^\s/ here as well?
  132.     # i give no guarantees that this works.
  133.     if (!$DEATH_STAR && length($flags) > $FLAG_WIDTH  &&
  134.           (($ppid == 0 && $pid > 10 && $uid) 
  135.           || 
  136.       length($flags) > 2+$FLAG_WIDTH))
  137.     {
  138.     print "hack 1\n" if $debug;
  139.     $ppid = $pid;
  140.     $pid = $uid;
  141.     $uid = substr($flags, 
  142.                       $FLAG_WIDTH + 1 - (substr($flags,0,1) eq ' ' ||
  143.                                     length($flags > $FLAG_WIDTH + 2)),
  144.               10);
  145.     substr($flags, -length($uid), 10) = '';
  146.  
  147.     # hold on to your lunch, folks...
  148.     if (!defined $id{$uid}) {
  149.         $extra = substr($flags,-1,1);
  150.         $uid = $extra . $uid if defined $id{$extra.$uid};
  151.     } 
  152.     } 
  153.  
  154.     # stupid hack should PPID and CP collide
  155.     if ($ppid > 32_000 && $pid < 32_000) {
  156.     print "hack 2\n" if $debug;
  157.     $ppid = substr($ppid,0,length($pid));
  158.     }
  159.  
  160.     # stupid hack should TT and TIME collide
  161.     if (length($tty) > 2 && $tty =~ /:/) {
  162.     print "hack 3\n" if $debug;
  163.     $time = substr($tty, 2, 10) . $time;
  164.     $tty = substr($tty,0,2);
  165.     } 
  166.  
  167.     $lines{$pid} = sprintf("%-8s %5d %8s %7s#%s\n", 
  168.         &id($uid), $pid, $tty, $time, $command);
  169.     unless ($pid == $ppid) {
  170.     $parent{$pid} = $ppid;
  171.     $children{$ppid} .= "$pid ";
  172.     }
  173. } 
  174. if (!close(PS)) {
  175.     warn "\"$ps\" exited badly!\n";
  176.     $oops++;
  177. }
  178.  
  179. @pids = keys %pids;
  180. if (@pids) {
  181.     foreach $pid (@pids) {
  182.     &save_the_children($pid);
  183.     &save_our_parent($pid);
  184.     } 
  185.     %lines = %nlines;
  186. } 
  187.  
  188. sub bynum { $a - $b; } 
  189.  
  190. # find the heads of the chains...
  191. @pids = grep(!defined $lines{$parent{$_}},keys %lines);
  192.  
  193. for $pid (sort bynum @pids) {
  194.     &children($pid); 
  195. } 
  196.  
  197. exit($oops != 0);
  198.  
  199. sub children {
  200.     local($pid) = $_[0];
  201.     local($_) = $lines{$pid};
  202.     substr($_, index($_, '#'), 1) = ' ' x (1+ $indent * $level);
  203.     if (!$wide && length() > $cols) {
  204.     substr($_, $cols, 10_000) = "\n";
  205.     } 
  206.     print;
  207.     if ($level++ < $maxlevel) {
  208.     local(@kids) = split(' ',$children{$pid});
  209.     for $pid (@kids) {
  210.         &children($pid);
  211.     }
  212.     } 
  213.     $level--;
  214. } 
  215.  
  216. sub id {
  217.     local($id) = shift;
  218.     $id{$id} = (getpwuid($id))[0] || "($id)" unless defined $id{$id};
  219.     $id{$id};
  220. } 
  221.  
  222. sub save_the_children {
  223.     local($parent) = shift;
  224.     foreach $kid (split(' ',$children{$parent})) {
  225.     &save_the_children($kid);
  226.     } 
  227.     &keepline($parent);
  228. } 
  229.     
  230. sub save_our_parent {
  231.     local($kid) = shift;
  232.     local($dad) = $parent{$kid};
  233.  
  234.     &keepline($kid);
  235.  
  236.     if ($dad || $dad eq '0') { # beware $dad == 0
  237.     &save_our_parent($dad);
  238.     }
  239. } 
  240.  
  241. sub keepline {
  242.     $nlines{$_[0]}  = $lines{$_[0]} 
  243.     unless defined $nlines{$_[0]};
  244. } 
  245.  
  246.  
  247. sub getwin {
  248.     local($winsize);
  249.     # is someone can get SS_DC_TIOCSWINSZ on MIPS working, tell me
  250.     if ($TIOCGWINSZ && ioctl(STDERR, $TIOCGWINSZ, $winsize)) {
  251.         ($rows, $cols) = unpack('S4', $winsize);
  252.     } else {
  253.         $cols = $ENV{'COLUMNS'} || ($ENV{'TERMCAP'} =~ /:co#(\d+):/)[0];
  254.     }
  255.     $cols = 80 unless $cols;
  256.     print "cols are $cols\n" if $debug;
  257. }
  258.