cleanup the resturn to prevent pointless stderr

Net-Connection-lsof/Changes

@@ -1,5 +1,31 @@
 Revision history for Net-Connection-lsof
 
-0.01    Date/time
-        First version, released on an unsuspecting world.
+0.3.0	 2023-06-01/13:15
+		 - Redirect stderr to dev null to prevent pointless warning about kern diffferences from lsof.
+
+0.2.0	 2019-08-16/16:40
+		 - WChan support added to Linux.
+
+0.1.1	 2019-08-13/06:00
+		 - Only call sysctl on BSD.
+
+0.1.0	 2019-08-12/05:45
+		 - Add support for process information.
+
+0.0.3	 2019-08-09/07:30
+		 - Add a work around for on some Linux systems
+		   where lsof will exit 1 upon successful completion,
+		   such as Debian 9.
+
+0.0.2	 2019-07-28/21:45
+		 - Properly set uid_resolve.
+		 - Actually remove ) from state now.
+		 - Properly set if it is 4 or 6 on the protocol.
+
+0.0.1	 2019-07-28/21:10
+		 - Some versions of lsof shipped with some linux
+		   distros don't support +c so don't use that option.
+
+0.0.0	 2019-07-28/06:40
+		 - Initial release.
 

Net-Connection-lsof/Makefile.PL

@@ -17,7 +17,8 @@ my %WriteMakefileArgs = (
 										   'Test::More' => '0',
 										   },
 						 PREREQ_PM => {
-									   'Net::Connection' => '0.0.0',
+									   'Net::Connection' => '0.2.0',
+									   'Proc::ProcessTable' => '0.59',
 									   },
 						 dist  => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', },
 						 clean => { FILES => 'Net-Connection-lsof-*' },

Net-Connection-lsof/lib/Net/Connection/lsof.pm

@@ -1,9 +1,11 @@
+
 package Net::Connection::lsof;
 
 use 5.006;
 use strict;
 use warnings;
 use Net::Connection;
+use Proc::ProcessTable;
 require Exporter;
 
 our @ISA = qw(Exporter);
@@ -15,11 +17,11 @@ Net::Connection::lsof - This uses lsof to generate a array of Net::Connection ob
 
 =head1 VERSION
 
-Version 0.0.0
+Version 0.3.0
 
 =cut
 
-our $VERSION = '0.0.0';
+our $VERSION = '0.3.0';
 
 
 =head1 SYNOPSIS
@@ -41,7 +43,7 @@ our $VERSION = '0.0.0';
 
 =head2 lsof_to_nc_objects
 
-This runs 'lsof -i UDP -i TCP -n -l +c 19 -P' and parses the output
+This runs 'lsof -i UDP -i TCP -n -l -P' and parses the output
 returns a array of L<Net::Connection> objects. If a non-zero exit code is
 returned, it will die.
 
@@ -66,6 +68,12 @@ Defaults to 1.
 
 Attempt to resolve the UID to a username.
 
+Defaults to 1.
+
+=head4 proc_info
+
+Add assorted process information to the objects.
+
 Defaults to 1.
 
     my @objects;
@@ -88,19 +96,49 @@ sub lsof_to_nc_objects{
 	if ( !defined( $func_args{uid_resolve} ) ){
 		$func_args{uid_resolve}=1;
 	}
+	if ( !defined( $func_args{proc_info} ) ){
+		$func_args{proc_info}=1;
+	}
 
-	my $output_raw=`lsof -i UDP -i TCP -n -l +c 19 -P`;
-	if ( $? ne 0 ){
-		die('"lsof -i UDP -i TCP -n -l +c 19 -P" exited with a non-zero value');
+	my $output_raw=`lsof -i UDP -i TCP -n -l -P 2> /dev/null`;
+	if (
+		( $? ne 0 ) &&
+		(
+		 ( $^O =~ /linux/ ) &&
+		 ( $? ne 256 )
+		 )
+		){
+		die('"lsof -i UDP -i TCP -n -l -P" exited with a non-zero value or in the case of some linux distros a non-1 value');
 	}
 	my @output_lines=split(/\n/, $output_raw);
 
 	my @nc_objects;
 
+	# process info caches
+	my %pid_proc;
+	my %pid_pctmem;
+	my %pid_pctcpu;
+	my %pid_wchan;
+	my %pid_start;
+
+	my $proc_table;
+	my $physmem;
+	if ( $func_args{proc_info} ){
+		my $pt=Proc::ProcessTable->new;
+		$proc_table=$pt->table;
+		if ( $^O =~ /bsd/ ){
+			$physmem=`/sbin/sysctl -a hw.physmem`;
+			chomp( $physmem );
+			$physmem=~s/^.*\: //;
+		}
+	}
+
 	my $line_int=1;
 	while ( defined( $output_lines[$line_int] ) ){
-		my $command=substr $output_lines[$line_int], 0, 19;
-		my $line=substr $output_lines[$line_int], 19;
+		my $command=substr $output_lines[$line_int], 0, 9;
+		my $line=substr $output_lines[$line_int], 10;
+
+		$line=~s/^[\t ]*//;
 
 		my @line_split=split(/[\ \t]+/, $line );
 
@@ -109,9 +147,10 @@ sub lsof_to_nc_objects{
 				  uid=>$line_split[1],
 				  ports=>$func_args{ports},
 				  ptrs=>$func_args{ptrs},
+				  uid_resolve=>$func_args{uid_resolve},
 				  };
 
-		my $type=$line_split[2];
+		my $type=$line_split[3];
 		my $mode=$line_split[6];
 		my $name=$line_split[7];
 
@@ -120,7 +159,7 @@ sub lsof_to_nc_objects{
 		if ( $type =~ /6/ ){
 			$proto='6';
 		}elsif( $type =~ /4/ ){
-			$proto='6';
+			$proto='4';
 		}
 		if ( $mode =~ /[Uu][Dd][Pp]/ ){
 			$proto='udp'.$proto;
@@ -163,7 +202,73 @@ sub lsof_to_nc_objects{
 		$args->{state}='';
 		if ( defined( $line_split[8] ) ){
 			$args->{state}=$line_split[8];
-			$args->{state}=~s/[\(\)]//;
+			$args->{state}=~s/[\(\)]//g;
+		}
+
+		#
+		# put together process info if requested
+		#
+		if ( $func_args{proc_info} ){
+			if ( defined( $pid_proc{ $args->{pid} } ) ){
+				$args->{proc}=$pid_proc{ $args->{pid} };
+				$args->{wchan}=$pid_wchan{ $args->{pid} };
+				$args->{pctmem}=$pid_pctmem{ $args->{pid} };
+				$args->{pctcpu}=$pid_pctcpu{ $args->{pid} };
+				$args->{pid_start}=$pid_start{ $args->{pid} };
+			}else{
+				my $loop=1;
+				my $proc_int=0;
+				while(
+					  defined( $proc_table->[ $proc_int ] ) &&
+					  $loop
+					  ){
+
+					# matched
+					if ( $proc_table->[ $proc_int ]->{pid} eq $args->{pid} ){
+						# exit the loop
+						$loop = 0;
+
+						# fetch and save the proc info
+						if ( $proc_table->[ $proc_int ]->cmndline =~ /^$/ ){
+							# kernel proc
+							$args->{proc}='['.$proc_table->[ $proc_int ]->{fname}.']';
+						}else{
+							# non-kernel proc
+							$args->{proc}=$proc_table->[ $proc_int ]->{cmndline};
+						}
+						$pid_proc{ $args->{pid} }=$args->{proc};
+
+						# linux has shit wchan reporting and apparently if you want more than
+						# the address you need to use the ass backwards /proc
+						if ( $^O =~ /linux/ ){
+							if ( -e '/proc/'.$args->{pid}.'/wchan'){
+								open( my $wchan_fh, '<', '/proc/'.$args->{pid}.'/wchan' );
+								$args->{wchan}=readline( $wchan_fh );
+								close( $wchan_fh );
+								$pid_wchan{ $args->{pid} }=$args->{wchan};
+							}
+						}else{
+							$args->{wchan}=$proc_table->[ $proc_int ]->{wchan};
+							$pid_wchan{ $args->{pid} }=$args->{wchan};
+						}
+
+						$args->{pid_start}=$proc_table->[ $proc_int ]->{pid_start};
+						$pid_start{ $args->{pid} }=$args->{pid_start};
+
+						$args->{pctcpu}=$proc_table->[ $proc_int ]->{pctcpu};
+						$pid_pctcpu{ $args->{pid} }=$args->{pctcpu};
+
+						if ($^O =~ /bsd/){
+							$args->{pctmem}= (( $proc_table->[ $proc_int ]->{rssize} * 1024 * 4 ) / $physmem) * 100;
+						}else{
+							$args->{pctmem}=$proc_table->[ $proc_int ]->{pctmem};
+						}
+						$pid_pctmem{ $args->{pid} }=$args->{pctmem};
+					}
+
+					$proc_int++;
+				}
+			}
 		}
 
 		push( @nc_objects, Net::Connection->new( $args ) );
@@ -202,14 +307,6 @@ You can also look for information at:
 
 L<https://rt.cpan.org/NoAuth/Bugs.html?Dist=Net-Connection-lsof>
 
-=item * AnnoCPAN: Annotated CPAN documentation
-
-L<http://annocpan.org/dist/Net-Connection-lsof>
-
-=item * CPAN Ratings
-
-L<https://cpanratings.perl.org/d/Net-Connection-lsof>
-
 =item * Search CPAN
 
 L<https://metacpan.org/release/Net-Connection-lsof>

Net-Connection-lsof/t/lsof.t

@@ -11,8 +11,14 @@ BEGIN {
 }
 
 
-my $output_raw=`lsof -i UDP -i TCP -n -l +c 19 -P`;
-if ( $? eq 0 ){
+my $output_raw=`lsof -i UDP -i TCP -n -l -P 2> /dev/null`;
+if (
+	( $? eq 0 ) ||
+	(
+	 ( $^O =~ /linux/ ) &&
+	 ( $? eq 256 )
+	 )
+	){
 	$extra_tests++;
 	my $worked=0;
 	eval{