#!/usr/local/bin/perl4
#
# pt -- print process tree
# 	Tom Christiansen <tchrist@convex.com>
#       version 1.0, Tuesday Jun 30 18:29:49 CDT 1992
#	
#    Modification History
#	version 1.1, Wed Jul  1 14:58:54 CDT 1992
#	    Chop long lines to winsize unless -w supplied
#	    Add -a for all procs irrespective of platform
#	    Changed parse bailout to warning
#	    Added Configure script
#	    Numerous hacks to deal with various braindead
#		vendors garbled ps output
#		
#
# run ps and display process hierarchy indented
# under parents.
#
# Options:
# 	[-l level]	limits level of children printed
# 	[-i indent]	change indent level from default
#	[-w] 		allow lines to be as long as you want.
#
# 


# don't use require so that it runs on ancient versions of perl
    # require 'getopts.pl';
    $file = 'getopts.pl';
    $return = do $file;
    die "couldn't parse $file: $@" if $@;
    die "couldn't do $file: $!" unless defined $return;
    die "couldn't run $file" unless $return;

$VERSION = '1.1';
$AUTHOR = 'tchrist@convex.com';

$| = 1;

$PS = "/bin/ps";			# a path to ps, usually /bin
$TIOCGWINSZ = 0x40087468;       	# should be require sys/ioctl.ph
$DEATH_STAR = 0;			# ARGS: ps -el, not ps wwaxl
$FLAG_WIDTH = 7;
$FIRST_SPLIT = '^(\s*[\da-fA-F]+)\s*([\-\d]+)\s+(\d+)\s+(\d+)';

die "Didn't you run Configure?"
	unless 4 == grep(defined,$PS,$TIOCGWINSZ,$DEATH_STAR,$FLAG_WIDTH);

$indent = 2;  			 # reset via -i switch

$debug = 0;


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

if ($DEATH_STAR) {
    $PS_ARGS = "-l"; 
    $EVERYBODY = "e";
} else {
    $PS_ARGS = "xlww";
    $EVERYBODY = "a";
}

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

$maxlevel = 10_000_000;  # reset via -l switch

sub usage {
    local($msg) = shift;
    print STDERR "$0: $msg\n" if $msg;
    die <<EOF;
usage: $0 [-a] [-d] [-w] [ps args] [pid list]
	    (version: $VERSION   author: $AUTHOR)

	-w 	wide output (don't trunc at winsize)
	-a	all processes, not just mine
	-d	print out debugging information
EOF
} 

&Getopts('dl:i:wa') || &usage();

$maxlevel = $opt_l if $opt_l;
$indent = $opt_i if $opt_i;
$wide = $opt_w;
$debug = $opt_d;

while (defined($_ = shift)) {  # curse pid 0
    if (/^(\d+)$/) {
	$pids{$1}++;
	$pids++;  # needed for ancient perl, who can't do if %pids
    } else {
	$PS_ARGS .= "$_ ";
    }
} 

$wide || &getwin;

$PS_ARGS =~ s/^(-?)/${1}${EVERYBODY}/ if $pids || $opt_a;

$ps = "$PS $PS_ARGS";

print "opening pipe to $ps\n" if $debug;

open(PS, "$ps |") || die "can't fork: $!";
<PS>; # header

printf("%-8s %5s %8s %7s %s\n", 'USER', "PID", "TTY", "TIME","COMMAND");

while (<PS>) {
    ($flags, $uid, $pid, $ppid) = /$FIRST_SPLIT/o;
    ($tty, $time, $secs, $command) = /(\S+)\s*(\d+:\d+(\.\d\d)?)\s+(.*)/;

    unless (grep(defined,$uid,$pid,$ppid,$tty,$time,$command) == 6) {
	warn "skipping unparsable line from ps:\n$_";
	$oops++;
	next;
    }

    if ($debug) {
	print <<EOF;
flags are <$flags>, uid is <$uid>, pid is <$pid>, ppid is <$ppid>
tty is <$tty>, time is <$time>, command is <$command>

EOF
    } 

    # incredibly disgusting hack should FLAGS and UID collide
    # why oh why must vendors be so damn sysadmin-hostile?
    # don't they understand we have to parse this stuff??
    # 	maybe should try $flags =~ /^\s/ here as well?
    # i give no guarantees that this works.
    if (!$DEATH_STAR && length($flags) > $FLAG_WIDTH  &&
          (($ppid == 0 && $pid > 10 && $uid) 
	      || 
	  length($flags) > 2+$FLAG_WIDTH))
    {
	print "hack 1\n" if $debug;
	$ppid = $pid;
	$pid = $uid;
	$uid = substr($flags, 
                      $FLAG_WIDTH + 1 - (substr($flags,0,1) eq ' ' ||
                                    length($flags > $FLAG_WIDTH + 2)),
		      10);
	substr($flags, -length($uid), 10) = '';

	# hold on to your lunch, folks...
	if (!defined $id{$uid}) {
	    $extra = substr($flags,-1,1);
	    $uid = $extra . $uid if defined $id{$extra.$uid};
	} 
    } 

    # stupid hack should PPID and CP collide
    if ($ppid > 32_000 && $pid < 32_000) {
	print "hack 2\n" if $debug;
	$ppid = substr($ppid,0,length($pid));
    }

    # stupid hack should TT and TIME collide
    if (length($tty) > 2 && $tty =~ /:/) {
	print "hack 3\n" if $debug;
	$time = substr($tty, 2, 10) . $time;
	$tty = substr($tty,0,2);
    } 

    $lines{$pid} = sprintf("%-8s %5d %8s %7s#%s\n", 
		&id($uid), $pid, $tty, $time, $command);
    unless ($pid == $ppid) {
	$parent{$pid} = $ppid;
	$children{$ppid} .= "$pid ";
    }
} 
if (!close(PS)) {
    warn "\"$ps\" exited badly!\n";
    $oops++;
}

@pids = keys %pids;
if (@pids) {
    foreach $pid (@pids) {
	&save_the_children($pid);
	&save_our_parent($pid);
    } 
    %lines = %nlines;
} 

sub bynum { $a - $b; } 

# find the heads of the chains...
@pids = grep(!defined $lines{$parent{$_}},keys %lines);

for $pid (sort bynum @pids) {
    &children($pid); 
} 

exit($oops != 0);

sub children {
    local($pid) = $_[0];
    local($_) = $lines{$pid};
    substr($_, index($_, '#'), 1) = ' ' x (1+ $indent * $level);
    if (!$wide && length() > $cols) {
	substr($_, $cols, 10_000) = "\n";
    } 
    print;
    if ($level++ < $maxlevel) {
	local(@kids) = split(' ',$children{$pid});
	for $pid (@kids) {
	    &children($pid);
	}
    } 
    $level--;
} 

sub id {
    local($id) = shift;
    $id{$id} = (getpwuid($id))[0] || "($id)" unless defined $id{$id};
    $id{$id};
} 

sub save_the_children {
    local($parent) = shift;
    foreach $kid (split(' ',$children{$parent})) {
	&save_the_children($kid);
    } 
    &keepline($parent);
} 
    
sub save_our_parent {
    local($kid) = shift;
    local($dad) = $parent{$kid};

    &keepline($kid);

    if ($dad || $dad eq '0') { # beware $dad == 0
	&save_our_parent($dad);
    }
} 

sub keepline {
    $nlines{$_[0]}  = $lines{$_[0]} 
	unless defined $nlines{$_[0]};
} 


sub getwin {
    local($winsize);
    # is someone can get SS_DC_TIOCSWINSZ on MIPS working, tell me
    if ($TIOCGWINSZ && ioctl(STDERR, $TIOCGWINSZ, $winsize)) {
        ($rows, $cols) = unpack('S4', $winsize);
    } else {
        $cols = $ENV{'COLUMNS'} || ($ENV{'TERMCAP'} =~ /:co#(\d+):/)[0];
    }
    $cols = 80 unless $cols;
    print "cols are $cols\n" if $debug;
}