File Coverage

blib/lib/Unix/Lsof.pm

Criterion	Covered	Total	%
statement	26	107	24.3
branch	1	42	2.3
condition	1	12	8.3
subroutine	8	16	50.0
pod	2	2	100.0
total	38	179	21.2

package Unix::Lsof;

use 5.008;
use version; our $VERSION = qv('0.1.0');

use warnings;
use strict;
use IPC::Run3;
use Unix::Lsof::Result;

use base qw(Exporter);

our @EXPORT    = qw(lsof);
our @EXPORT_OK = qw(parse_lsof_output);

our %op_field = (
    a => q(access mode),
    c => q(command name),
    C => q(structure share count),
    d => q(device character code),
    D => q(major/minor device number),
    f => q(file descriptor),
    F => q(structure address),
    g => q(process group id),
    G => q(flags),
    i => q(inode number),
    k => q(link count),
    K => q(task id),
    l => q(lock status),
    L => q(login name),
    n => q(file name),
    N => q(node identifier),
    o => q(file offset),
    p => q(process id),
    P => q(protocol name),
    r => q(raw device number),
    R => q(parent pid),
    s => q(file size),
    S => q(stream module and device names),
    t => q(file type),
    T => q(tcp/tpi info),
    u => q(user id),
    z => q(zone name),
    Z => q(selinux security context),

);

our %tcptpi_field = (
                     QR => q(read queue size),
                     QS => q(send queue size),
                     SO => q(socket options and values),
                     SS => q(socket states),
                     ST => q(connection state),
                     TF => q(TCP flags and values),
                     WR => q(window read size),
                     WW => q(window write size),
                     );

my (%opt,$err);

sub lsof {
    my @arg = @_;

    $err = undef;
    _parse_opt (\@arg);

    # TODO: split arguments if only one argument is passed, so that a shell
    # line can be used as-is

    $opt{binary} ||= _find_binary() || _idie("Cannot find lsof binary");

    if ( ! -e $opt{binary} ) {
        _idie("Cannot find lsof binary: $!");
    }
    if ( !-x $opt{binary} || !-f $opt{binary} ) {
        _idie("$opt{binary} is not an executable binary: $!");
    }

    my $out="";

    eval { run3( [ $opt{binary}, "-F0", @arg ], \undef, \$out, \$err ); };

    if ($@) {
        $err = $err ? $@ . $err : $@;
    }

    my $parsed = _parse_lsof_output( $out );

    if (wantarray) {
        return ( $parsed, $err );
    } else {
        return Unix::Lsof::Result->_new( $parsed, $err, $out,\%opt );
    }
}

sub _idie {
    my $message = shift;
    if ( $opt{suppress_errors} ) {
        $err .= $message;
    } else {
        die $message;
    }
}

sub _iwarn {
    my $message = shift;
    if ( $opt{suppress_errors} ) {
        $err .= $message;
    } else {
        warn $message;
    }
}

sub _parse_opt {
    my $arg = shift;
    # set options to defaults
    %opt = (
            binary          => undef,
            tcp_tpi_parse   => "full",
            suppress_errors => 0,
        );

    if ( ref $arg->[-1] eq ref {} ) {
        my $manopt = pop @$arg;
        for my $k (keys %opt) {
            if (exists $manopt->{$k}) {
                $opt{$k} = $manopt->{$k};
            }
        }
    }
}

sub _find_binary {
#    return if (!$ENV{PATH});
    my @path = split( ":", $ENV{PATH} );
    my $bin;
  PATHLOOP:
    for my $p (@path) {
        if ( -f $p . "/lsof" && -x _ ) {
            $bin = $p . "/lsof";
            last PATHLOOP;
        }
    }
    return $bin;
}

# This is a stub for now. Constructing lsof arguments is a little
# tricky and will be done conclusively later
sub _construct_parameters {
    my $options = shift;
    my @cmd_line;
    my %translate = (
        pid  => "-p",
        file => undef
    );
    for my $arg ( keys %{$options} ) {
        if ( exists $translate{$arg} ) {
            push @cmd_line, $translate{$arg} if ( defined $translate{$arg} );
        } else {
            push @cmd_line, $options->{$arg};
        }
    }
    return scalar @cmd_line ? @cmd_line : undef;
}

sub _parse_lsof_output {
    my $out = shift;
    my ( %result, $pid, $previous );
    my @output = split (/\000\012/, $out);
    for my $line (@output) {
        $line =~ s/^[\s\0]*//;
        my @elements = split( "\0", $line );
        my ($ident,$content) = ( $elements[0] =~ m/^(\w)(.*)$/ );
        if ( !$ident ) {
            _idie("Can't parse line $line, identifier missing");
        } elsif ($ident eq "p") {
            $pid = $content;
            $result{$pid} = _parseelements( \@elements );
            $previous = $ident;
        } elsif ( $ident eq "f" ) {
            push @{ $result{$pid}{files} }, _parseelements( \@elements );
            $previous = $ident;
        } else {
            _idie("Can't parse line $line, operator field $ident is not valid");
        }

    }

    return \%result;
}

sub parse_lsof_output {
    my @args = @_;
    $err = undef;
    if (ref($args[0]) eq ref([])) {
        my $str = join("\000\012",@{$args[0]});
        return _parse_lsof_output($str);
    } else {
        return _parse_lsof_output($args[0]);
    }
}

sub _parseelements {
    my $elements = shift;

    my %result;
    while ( my $elem = shift @$elements ) {
        my ( $fident, $content ) = ( $elem =~ /^(.)(.*)$/ );
        next if !$fident;
        # Specialised handling of TCP/TPI info, since that field
        # contains multiple pieces of data
        if ($fident eq "T") {
            if ($opt{tcp_tpi_parse} eq "array") {
                push @{$result{ $op_field{$fident} } },$content;
            } else {
                my ($fi,$fc) = split(/=/,$content);
                my $key = $opt{tcp_tpi_parse} eq "part" ? $fi : $tcptpi_field{$fi};
                $result{ $op_field{$fident} }{ $key } = $fc;
            }
        } else {
#            warn $fident. " - ".$op_field{$fident}." - ".$content;
            $result{ $op_field{$fident} } = $content;
#            exit;
        }
    }
    return \%result;
}

1;    # Magic true value required at end of module
__END__