#!/usr/local/bin/perl
#
# $Id: shared.perl5,v 1.4 2001/11/18 12:20:46 abe Exp $
#
# shared.perl5 -- sample Perl 5 script to list processes that share
#		  file descriptors or files, using `lsof +ffn -F..."
#		  output
#
# Usage:	shared [fd|file]
#
# where:	fd to list file descriptors (default)
#
#		file to list files
#
# This script has been tested under perl version 5.001e.


# IMPORTANT DEFINITIONS
# =====================
#
# 1.  Set the interpreter line of this script to the local path of the
#     Perl5 executable.


# Copyright 1998 Purdue Research Foundation, West Lafayette, Indiana
# 47907.  All rights reserved.
#
# Written by Victor A. Abell <abe@purdue.edu>
#
# This software is not subject to any license of the American Telephone
# and Telegraph Company or the Regents of the University of California.
#
# Permission is granted to anyone to use this software for any purpose on
# any computer system, and to alter it and redistribute it freely, subject
# to the following restrictions:
#
# 1. Neither the authors nor Purdue University are responsible for any
#    consequences of the use of this software.
#
# 2. The origin of this software must not be misrepresented, either by
#    explicit claim or by omission.  Credit to the authors and Purdue
#    University must appear in documentation and sources.
#
# 3. Altered versions must be plainly marked as such, and must not be
#    misrepresented as being the original software.
#
# 4. This notice may not be removed or altered.

# Initialize variables.

$Access = $Devch = $Devn = $Fd = $Fsa = $Inode = $Lock =	# file
	  $Na = $Name = "";					# | descriptor
$Cmd = $Login = $Pgrp = $Pid = $Ppid = $Uid = "";		# process var.
$Fdst = 0;							# fd state
$Hdr = 0;							# header state
$Offset = $Proto = $Size = $State = $Stream = $Type = "";	# | variables
$Pidst = 0;							# process state
$Pn = "shared";

# Set path to lsof.

if (($LSOF = &isexec("../lsof")) eq "") {	# Try .. first
    if (($LSOF = &isexec("lsof")) eq "") {	# Then try . and $PATH
	print "can't execute $LSOF\n"; exit 1
    }
}

# Define print field constants.

$CmdTtl = "CMD";
$CmdW = length($CmdTtl);
$DevTtl = "DEVICE";
$DevW = length($DevTtl);
$FdTtl = "FD";
$FdW = length($FdTtl);
$InoTtl = "NODE";
$InoW = length($InoTtl);
$KeyTtl = "FILEADDR";
$KeyW = length($KeyTtl);
$PidTtl = "PID";
$PidW = length($PidTtl);
$PpidTtl = "PPID";
$PpidW = length(PpidTtl);

# Process one (optional) argument.

if ($#ARGV >= 0) {
    $err = 0;
    if ($#ARGV > 1) { $err = 1; }
    elsif ($ARGV[0] eq "fd") {
	$KeyTtl = "FILEADDR";
	$Shfd = 1;
	$Shfile = 0;
    } elsif ($ARGV[0] eq "file") {
	$KeyTtl = "NODEID";
	$Shfd = 0;
	$Shfile = 1;
    } else { $err = 1; }
    if ($err) { die "$Pn: usage [fd|file]\n"; }
    shift;
} else { $Shfd = 1; $Shfile = 0; }
$KeyW = length($KeyTtl);

# Open a pipe from lsof.

if (!open(LSOF_PIPE, "$LSOF -R +ffn -F0pcRDfFinN |")) {
    die "$Pn: can't open pipe to: $LSOF\n";
}

# Process the lsof output a line at a time, gathering the variables for
# processes and files.

while (<LSOF_PIPE>) {
    chop;
    @F = split('\0', $_, 999);
    if ($F[0] =~ /^p/) {

# A process set begins with a PID field whose ID character is `p'.

	if ($Fdst) { &End_fd }
	if ($Pidst) { &End_proc }
	foreach $i (0 .. ($#F - 1)) {

	    PROC: {
		if ($F[$i] =~ /^c(.*)/) { $Cmd = $1; last PROC }
		if ($F[$i] =~ /^g(.*)/) { $Pgrp = $1; last PROC }
		if ($F[$i] =~ /^p(.*)/) { $Pid = $1; last PROC }
		if ($F[$i] =~ /^u(.*)/) { $Uid = $1; last PROC }
		if ($F[$i] =~ /^L(.*)/) { $Login = $1; last PROC }
		if ($F[$i] =~ /^R(.*)/) { $Ppid = $1; last PROC }
		print "ERROR: unrecognized process field: \"$F[$i]\"\n";
	    }
	}
	$Pidst = 1;
	next;
    }

# A file descriptor set begins with a file descriptor field whose ID
# character is `f'.

    if ($F[0] =~ /^f/) {
	if ($Fdst) { &End_fd }
	foreach $i (0 .. ($#F - 1)) {

	    FD: {
		if ($F[$i] =~ /^a(.*)/) { $Access = $1; last FD; }
		if ($F[$i] =~ /^f(.*)/) { $Fd = $1; last FD; }
		if ($F[$i] =~ /^F(.*)/) { $Fsa = $1; last FD; }
		if ($F[$i] =~ /^l(.*)/) { $Lock = $1; last FD; }
		if ($F[$i] =~ /^t(.*)/) { $Type = $1; last FD; }
		if ($F[$i] =~ /^d(.*)/) { $Devch = $1; last FD; }
		if ($F[$i] =~ /^D(.*)/) { $Devn = $1; last FD; }
		if ($F[$i] =~ /^s(.*)/) { $Size = $1; last FD; }
		if ($F[$i] =~ /^o(.*)/) { $Offset = $1; last FD; }
		if ($F[$i] =~ /^i(.*)/) { $Inode = $1; last FD; }
		if ($F[$i] =~ /^P(.*)/) { $Proto = $1; last FD; }
		if ($F[$i] =~ /^S(.*)/) { $Stream = $1; last FD; }
		if ($F[$i] =~ /^T(.*)/) {
		    if ($State eq "") { $State = "(" . $1; }
		    else { $State = $State . " " . $1; }
		    last FD;
		}
		if ($F[$i] =~ /^n(.*)/) { $Name = $1; last FD; }
		if ($F[$i] =~ /^N(.*)/) { $Na = $1; last FD; }
		print "ERROR: unrecognized file set field: \"$F[$i]\"\n";
	    }
	}
	$Fdst = 1;
	next;
    }
    print "ERROR: unrecognized: \"$_\"\n";
}
close(LSOF_PIPE);
if ($Fdst) { &End_fd }
if ($Pidst) { &End_proc }

# List matching files or file descriptors.

for ($pass = 0; $pass < 2; $pass++) {
    foreach $key (sort keys(%Fds)) {
	@Praw = split(' ', $Fds{$key}, 999);
	if ($#Praw < 1) { next; }
	if ($Shfd) { @P = sort Sort_by_FD_and_PID @Praw; }
	else { @P = sort Sort_by_PID_and_FD @Praw; }

    # Accumulate and print blocks of (key, PID, FD) triplets.

	for ($i = 0; $i < $#P; $i++) {
	    if ($Shfile) {
		for ($n = 0; $n <= $#P; $n++) {
		    ($pid, $fd) = split(",", $P[$n], 999);
		    $PrtPid[$n] = $pid;
		    $PrtFd[$n] = $fd;
		}
		$i = $n;
	    } else {
		($pid, $fd) = split(",", $P[$i], 999);
		$PrtFd[0] = $fd;
		$PrtPid[0] = $pid;
		for ($n = 1; $i < $#P; $i++, $n++) {
		    ($nxtpid, $nxtfd) = split(",", $P[$i + 1], 999);
		    if ($fd ne $nxtfd) { last; }
		    $PrtFd[$n] = $nxtfd;
		    $PrtPid[$n] = $nxtpid;
		}
	    }
	    if ($n > 1) { &Print_block($key, $n, $pass); }
	}
    }
}
exit(0);


## End_fd() -- process end of file descriptor

sub End_fd {

    local ($key);

    if ($Fdst && $Pidst && $Pid ne "") {
	if ($Cmd ne "") { $Cmds{$Pid} = $Cmd; }
	if ($Ppid ne "") { $Ppids{$Pid} = $Ppid; }
	$key = $Shfd ? $Fsa : $Na;
	if ($key ne "") {
	    if (!defined($Fds{$key})) { $Fds{$key} = "$Pid,$Fd"; }
	    else { $Fds{$key} .= " $Pid,$Fd"; }
	    if ($Name ne "" && !defined($Name{$key})) { $Name{$key} = $Name }
	    if ($Inode ne "" && !defined($Inodes{$key})) {
		$Inodes{$key} = $Inode;
	    }
	    if ($Devn ne "" && !defined($Devns{$key})) {
		$Devns{$key} = $Devn;
	    }
	}
    }

# Clear variables.

    $Access = $Devch = $Devn = $Fd = $Fsa = $Inode = $Lock = "";
    $Na = $Name = $Offset = $Proto = $Size = $State = $Stream = $Type = "";
    $Fdst = 0;
}


## End_proc() -- process end of process

sub End_proc {

# Clear variables.

    $Cmd = $Login = $Pgrp = $Pid = $Ppid = $Uid = "";
    $Fdst = $Pidst = 0;
}


## Print_block() -- print a block of entries
#
# entry:
#
#	@_[0] = block's key
#	@_[1] = number of entries in the block
#	@_[2] = print pass status (1 == print)

sub Print_block {

    my ($key, $n, $pass) = @_;

    local ($fd, $i, $pid, $t, $tW);

    if ($pass) {
	if (!$Hdr) {
	    printf "%${KeyW}.${KeyW}s", $KeyTtl;
	    printf " %${PidW}.${PidW}s", $PidTtl;
	    printf " %${PpidW}.${PpidW}s", $PpidTtl;
	    printf " %-${CmdW}.${CmdW}s", $CmdTtl;
	    printf " %${FdW}.${FdW}s", $FdTtl;
	    printf " %${DevW}.${DevW}s", $DevTtl;
	    printf " %${InoW}.${InoW}s", $InoTtl;
	    printf " NAME\n";
	    $Hdr = 1;
	} else { print "\n"; }
    }

# Loop through block.  During a non-print pass, caclulate maximum field widths.

    for ($i = 0; $i < $n; $i++) {
	$fd = $PrtFd[$i];
	$pid = $PrtPid[$i];

    # Process key.

	if (!$pass) {
	    $tW = length(sprintf("%s", $key));
	    if ($tW > $KeyW) { $KeyW = $tW; }
	} else { printf "%s", $key; }

    # Process PID.

	if (!$pass) {
	    $tW = length(sprintf(" %s", $pid));
	    if ($tW > $PidW) { $PidW = $tW; }
	} else { printf " %${PidW}.${PidW}s", $pid; }

    # Process parent PID.

	$t = defined($Ppids{$pid}) ? $Ppids{$pid} : "";
	if (!$pass) {
	    $tW = length(sprintf(" %s", $t));
	    if ($tW > $PpidW) { $PpidW = $tW; }
	} else { printf " %${PpidW}.${PpidW}s", $t; }

    # Process command name.

	$t = defined($Cmds{$pid}) ? $Cmds{$pid} : "";
	if (!$pass) {
	    $tW = length(sprintf(" %s", $t));
	    if ($tW > $CmdW) { $CmdW = $tW; }
	} else { printf " %-${CmdW}.${CmdW}s", $t; }

    # Process file descriptor.

	if (!$pass) {
	    $tW = length(sprintf(" %s", $fd));
	    if ($tW > $FdW) { $FdW = $tW; }
	} else { printf " %${FdW}.${FdW}s", $fd; }

    # Process device number.

	$t = defined($Devns{$key}) ? $Devns{$key} : "";
	if (!$pass) {
	    $tW = length(sprintf(" %s", $t));
	    if ($tW > $DevW) { $DevW = $tW; }
	} else { printf " %${DevW}.${DevW}s", $t; }

    # Process node number.

	$t = defined($Inodes{$key}) ? $Inodes{$key} : $t;
	if (!$pass) {
	    $tW = length(sprintf (" %s", $t));
	    if ($tW > $InoW) { $InoW = $tW; }
	} else { printf " %${InoW}.${InoW}s", $t; }

    # Print name and line terminater, if this is a print pass.

	if ($pass) {
	    if (defined($Name{$key})) { print " $Name{$key}\n"; }
	    else { print "\n"; }
	}
    }
}


## Sort_by_FD_and_PID() -- sort (PID,FD) doublets by FD first, then PID

sub Sort_by_FD_and_PID {

    local ($pida, $pidb, $fda, $fdj, $rv);

    ($pida, $fda) = split(",", $a);
    ($pidb, $fdb) = split(",", $b);
    if ($fda < $fdb) { return(-1); }
    if ($fda > $fdb) { return(1); }
    if ($pida < $pidb) { return(-1); }
    if ($pida > $pidb) { return(1); }
    return(0);
}


## Sort_by_PID_and_FD() -- sort (PID,FD) doublets by PID first, then FD

sub Sort_by_PID_and_FD {

    local ($pida, $pidb, $fda, $fdj, $rv);

    ($pida, $fda) = split(",", $a);
    ($pidb, $fdb) = split(",", $b);
    if ($pida < $pidb) { return(-1); }
    if ($pida > $pidb) { return(1); }
    if ($fda < $fdb) { return(-1); }
    return(0);
    if ($fda > $fdb) { return(1); }
}


## isexec($path) -- is $path executable
#
# $path   = absolute or relative path to file to test for executabiity.
#	    Paths that begin with neither '/' nor '.' that arent't found as
#	    simple references are also tested with the path prefixes of the
#	    PATH environment variable.  

sub
isexec {
    my ($path) = @_;
    my ($i, @P, $PATH);

    $path =~ s/^\s+|\s+$//g;
    if ($path eq "") { return(""); }
    if (($path =~ m#^[\/\.]#)) {
	if (-x $path) { return($path); }
	return("");
    }
    $PATH = $ENV{PATH};
    @P = split(":", $PATH);
    for ($i = 0; $i <= $#P; $i++) {
	if (-x "$P[$i]/$path") { return("$P[$i]/$path"); }
    }
    return("");
}