#!/usr/bin/env perl

# tps version 2.41 (2019-02-12)
#
# Copyright (C) 1996-2019 Vincent Lefevre <vincent@vinc17.net>
#
# This program is free software; you may redistribute it
# and/or modify it under the same terms as Perl itself.
#
# History:
# 2.41 (2019-02-12): Fixed a regression with option ":u" and tree output.
# 2.40 (2019-02-04): Support usernames with a "+" (e.g. for exim4).
# 2.39 (2018-05-29): Under UTF-8 locales, use Unicode line-drawing characters.
# 2.38 (2010-08-18): Avoid incorrect tail (at least under Linux).
# 2.37 (2006-12-18): No longer assume that enacs is defined.
# 2.36 (2006-03-10): If a color number is preceded by a dot, then it affects
#                    the background color instead of the foreground color.
# 2.35 (2006-03-10): Added color for stopped processes (under Linux).
# 2.34 (2005-08-21): Added darwin support.
# 2.33 (2004-08-22): Fix: "-" is allowed in user names.
# 2.32 (2004-04-30): Fix: reversed zombie condition.
# 2.31 (2004-04-30): Support new process state codes under Linux.
# 2.30 (2004-03-05): Nicer code.
# 2.29 (2001-09-29): ...

use strict;

sub sortsub { $a <=> $b }

my $ostype = $ENV{'OSTYPE'} || `uname`;
my ($bsd,$darwin,$linux,$sysv,@ps);
if ($ENV{'TPSCMD'} =~ /^(\w+):(.+)/)
  { $bsd = $1 eq 'BSD';
    $darwin = $1 eq 'Darwin';
    $linux = $1 eq 'Linux';
    $sysv = $1 eq 'SysV';
    $bsd || $darwin || $linux || $sysv or die "tps: unknown OS type\n";
    @ps = ($2); }
elsif ($ostype =~ /linux/i)
  { @ps = ('ps', '-w'); $linux = 1; }
elsif ($ostype =~ /^osf/i)
  { @ps = 'ps'; }
elsif ($ostype =~ /^darwin/i)
  { @ps = 'ps'; $darwin = 1; }
else
  { my %OS = ('f' => 0, 'x' => 1);
    open PS, 'ps -? 2>&1 |' or die "tps: can't exec ps\n";
    while (<PS>)
      { /^usage: ps \[ -\w*(f|x)\w* \]/ and $bsd = $OS{$1} }
    close PS;
    defined $bsd or die "tps: ps not found\n";
    @ps = 'ps'; }

my ($a,$b,$c,$d,$f,$i,$n,$p,$r,$st,$t,$u,$term,$cterm);
foreach (@ARGV)
  { /^:/ or push(@ps,$_), next;
    /^:a$/ and $a = 1, next;                          # all processes
    /^:b([=+]?\.?\d*)$/ and $b = $1, next;            # bold (command name)
    /^:c(\d*)$/ and $c = $1 || ($ENV{TERM} ne '' ?
        `tput cols` : 80), next;                      # columns
    /^:d([=+]?\.?\d*)$/ and $d = $1, next;            # <defunct> color
    /^:f([\040-\377]*)$/ and $f = $1, next;           # open file
    /^:i([:=+]?\d*)$/ and $i = $1, next;              # indent
    /^:n([=+]?\.?\d*)$/ and $n = $1, next;            # pid color if niced
    /^:p([=+]?\.?\d*)$/ and $p = $1, next;            # pid color
    /^:r(\d+)$/ and $r = $1, next;                    # root process
    /^:s([=+]?\.?\d*)$/ and $st = $1, next;           # pid color if stopped
    /^:t$/ and $t = 1, next;                          # tail
    /^:u(\w+|-)$/ and $u = $1, next;                  # user
    /^:T(.*)$/ and $term = $1, next;                  # terminal (default)
    die "tps: illegal option $_\n"; }

if ($ENV{TERM} eq '' && $term ne '')
  { $ENV{TERM} = $term }

if ($ENV{TERM} ne '')
  { $cterm = $ENV{COLORTERM} ne '' || `tput colors` > 1 }

my $psrx;
if ($bsd)
  {
    if ($a)
      { push @ps, '-agx' }
    elsif ($u =~ /\w/)
      { push @ps, '-a' }
    push @ps, '-lww';
    $psrx = '\\d+'.('\\s+(\\d+)'x3).('\\s+\\d+'x2).'\\s+(\\d+).*?\\d:\\d\\d';
  }
elsif ($darwin)
  {
    if (defined $u)
      { push @ps, '-U', $u eq '-' ? $ENV{USER} : $u }
    elsif ($a)
      { push @ps, '-A' }
    push @ps, '-ww', '-o "user pid ppid nice command"';
    $psrx = '([-\\w]+)\\s+(\\d+)\\s+(\\d+)\\s*([-\\w]*)';
  }
else
  {
    if (defined $u)
      { push @ps, '-u', $u eq '-' ? $ENV{USER} : $u }
    elsif ($a)
      { push @ps, '-e' }
    if ($linux)
      { push @ps, '-o "user pid ppid nice stat args"' }
    else
      { push @ps, '-o "user pid ppid nice args"' }
    $psrx = '(\S+)\\s+(\\d+)\\s+(\\d+)\\s*([-\\w]*)';
   }

my $nicebase = $ostype =~ /solaris/i ? 20 : 0;
my (%user,%ppid,%nice,%cmdn,%defunct,%stopped);
open PS, "@ps|" or die "tps: can't exec @ps\n";
while (<PS>)
  {
    my ($user,$pid,$ppid,$nice,$cmdn) = /^\s*$psrx\s*(.*)/ or next;
    $user{$pid} = sprintf '%8s ',
        $user =~ /^\d+$/ ? (getpwuid $user)[0] : $user
      unless (defined $u);
    $ppid{$pid} = $ppid;
    $nice{$pid} = $nice > $nicebase if ($n ne '');
    if ($linux && $cmdn =~ s/^(\S+)\s+//)
      {
        $defunct{$pid} = index($1,'Z') >= 0;
        $stopped{$pid} = index($1,'T') >= 0;
      }
    $cmdn{$pid} = $cmdn ne '' ? $cmdn : '<defunct>';
    $cmdn{$pid} =~ s:(?<!\S)[-0-9A-Za-z./]*/::g if ($t);
  }
close PS;

my %mark;
if ($f ne '')
  {
    my $pid = open FUSER, '-|';
    defined $pid or die "tps: can't fork: $!\n";
    unless ($pid)
      {
        close STDERR;
        exec 'fuser', $f;
        print "failed";
        die;
      }
    my $fuser = do { local $/; <FUSER> };
    close FUSER;
    $fuser =~ /failed/ and die "tps: exec fuser failed\n";
    foreach ($fuser =~ /(\d+)/g)
      { $mark{$_} = '*' }
  }

if ($r)
  {
    my $pid;
    foreach $pid (keys %ppid)
      {
        my $tmpid = $pid;
        while ($tmpid != $r)
          {
            ($tmpid = $ppid{$tmpid}) and next;
            delete $user{$pid};
            delete $ppid{$pid};
            delete $nice{$pid};
            delete $cmdn{$pid};
            last;
          }
      }
  }

my ($b0,$b1) = &style($b);
my ($d0,$d1) = &style($d);
my ($n0,$n1) = &style($n);
my ($p0,$p1) = &style($p);
my ($s0,$s1) = &style($st);
my ($i0,$i1,%acs);

if (substr($i,0,1) eq ':')
  { $i = substr($i,1) + 0 }
else
  {
    ($i0,$i1) = &style($i);
    $i = '';
    if ($ENV{LC_CHARMAP} =~ /^utf-?8$/i ||
        $ENV{LC_CTYPE} =~ /\.utf-?8$/i)
      {
        %acs = ('-' => '─', '|' => '│', '`' => '└', '+' => '├');
      }
    elsif ($ENV{TERM} ne '')
      {
        # Note: don't assume that enacs is defined (e.g., it is no
        # longer defined in xterm/xterm-xfree86 under Debian).
        system 'tput', 'enacs';
        my $smacs = `tput smacs`;
        unless ($?)
          {
            my $rmacs = `tput rmacs`;
            %acs = ('-' => $smacs.'q'.$rmacs,
                    '|' => $smacs.'x'.$rmacs,
                    '`' => $smacs.'m'.$rmacs,
                    '+' => $smacs.'t'.$rmacs);
          }
      }
  }

my (@root,%children);
foreach (sort sortsub keys %ppid)
  { push @{$_ > 0 && defined $ppid{$ppid{$_}} ?
      $children{$ppid{$_}} : \@root}, $_ }

my $level = 0;
&proc('',@root);

sub proc
  {
    my $is = shift;
    my $k = @_ or return;
    foreach (sort sortsub @_)
      {
        my ($it,$s,$cmdn);
        $level and $it = --$k ? '| ' : '  ';
        $s = $user{$_} . ( $level && $i eq '' ? $is.($k ? '+' : '`'). '-> '
                                              : ' 'x($i*$level) );
        my $ls1 = length $s;
        my $pid = $_.$mark{$_};
        $s .= "$pid  ";
        my $ls2 = length $s;
        my ($c0,$c1);
        if ($b ne '')
          {
            "$cmdn{$_} " =~
             m{^((\S*/)?(sh|csh|tcsh|bash|ksh|zsh|perl)\s+(-\S*\s+)*(\S+=("[^"]*"|'[^']*'|\S)+\s+)*)?(\[[^]]*]|\S*)}o
              or die "tps: internal error (process $_)\n";
            if (length $7)
              {
                $c0 = $ls2 + length $1;
                $c1 = length $7;
              }
            else
              {
                $cmdn{$_} =~ m{^(\S+)}o
                  or die "tps: internal error (process $_)\n";
                $c0 = $ls2;
                $c1 = length $1;
              }
          }
        $s .= $cmdn{$_};
        $c and $s = substr $s, 0, $c;
        my @s;
        @s = $defunct{$_} || $cmdn{$_} eq '<defunct>' ?
               ($d ne '' ? ($d0,$d1) : ()) :
               ($b ne '' ? ($b0,$b1) : ())
          and length $s > $c0
          and $s = substr($s,0,$c0).
                   $s[0].substr($s,$c0,$c1).$s[1].
                   substr($s,$c0+$c1);
        # Note: The "stopped" color has the precedence.
        $p ne '' && length $s > $ls1
          and $s = substr($s,0,$ls1).
                   ($nice{$_} ? $n0 : $p0).
                   ($stopped{$_} ? $s0 : '').
                   substr($s,$ls1,length $pid).
                   ($stopped{$_} ? $s1 : '').
                   ($nice{$_} ? $n1 : $p1).
                   substr($s,$ls2-2);
        if ($i eq '')
          { my $k = $u ? 0 : 8;
            my $x = substr($s,$k,$ls1-$k);
            $x =~ s/[|`+].*/$i0$&$i1/;
            $x =~ s/[-|`+]/$acs{$&}/g if (%acs);
            $s = substr($s,0,$k).$x.substr($s,$ls1); }
        print "$s\n";
        $level++;
        &proc($is.$it,@{$children{$_}});
        $level--;
      }
  }

sub style
  { $_[0] eq '' and return (undef, undef);
    $_[0] =~ /^([=+]?)(\.?)(\d*)$/ or die;
    my $style;
    $1 eq '+' || $1 eq '=' && $cterm and $style = `tput bold`;
    my $tc = $2 ? 'setab' : 'setaf';
    $3 ne '' && $cterm and $style .= `tput $tc $3`;
    return ($style, `tput sgr0`); }

# $Id: tps 115772 2019-02-12 17:27:37Z vinc17/zira $