File Coverage

blib/lib/Proc/ProcessTable/InfoString.pm

Criterion	Covered	Total	%
statement	11	88	12.5
branch	0	54	0.0
condition	0	12	0.0
subroutine	4	6	66.6
pod	2	2	100.0
total	17	162	10.4

package Proc::ProcessTable::InfoString;

use 5.006;
use strict;
use warnings;
use Term::ANSIColor;

=head1 NAME

Proc::ProcessTable::InfoString - Greats a PS like stat string showing various symbolic represenation of various flags/state as well as the wchan.

=head1 VERSION

Version 0.0.1

=cut

our $VERSION = '0.0.1';


=head1 SYNOPSIS

Quick summary of what the module does.

Perhaps a little code snippet.

    use Proc::ProcessTable::InfoString;
    use Proc::ProcessTable;

    my $is = Proc::ProcessTable::InfoString->new();

    my $p = Proc::ProcessTable->new( 'cache_ttys' => 1 );
    my $pt = $p->table;

    foreach my $proc ( @{ $pt } ){
        print $proc->pid.' '.$is->info( $proc )."\n";
    }

The mapping for the left side of the output is as below.

   States  Description
   Z       Zombie
   S       Sleep
   W       Wait
   R       Run

   Flags   Description
   O       Swapped Output
   E       Exiting
   s       Session Leader
   L       POSIX lock advisory
   +       has controlling terminal
   X       traced by a debugger
   F       being forked

=head1 METHODS

=head2 new

This initiates the object.

One argument is taken and that is a optional hash reference.

=head3 args hash

This will be passed to L.

If not specified, no ANSI color codes are used.

The return string is terminated by a ANSI color reset character.

=head4 flags_color

The color to use for the flags section of the string.

=head4 wchan_color

The color to use for the wait channel section of the string.

=cut

sub new {
	my %args;
	if (defined($_[1])) {
		%args= %{$_[1]};
	}

	my $self = {
				};
	bless $self;

	my @args_feed=(
				   'flags_color',
				   'wchan_color',
				   );

	foreach my $feed ( @args_feed ){
		$self->{$feed}=$args{$feed};
	}

	return $self;
}

=head2 info

=cut

sub info {
	my $self=$_[0];
	my $proc=$_[1];

	# make sure we got the required bits for proceeding
	if (
		( ! defined( $proc ) ) ||
		( ref( $proc ) ne 'Proc::ProcessTable::Process' )
		){
		return '';
	}
	my %flags;
	$flags{is_session_leader}=0;
	$flags{is_being_forked}=0;
	$flags{working_on_exiting}=0;
	$flags{has_controlling_terminal}=0;
	$flags{is_locked}=0;
	$flags{traced_by_debugger}=0;
	$flags{is_stopped}=0;
	$flags{is_kern_proc}=0;
	$flags{posix_advisory_lock}=0;

	if ( $^O =~ /freebsd/ ) {
		if ( hex($proc->flags) & 0x00002 ) {
			$flags{controlling_tty_active}=1;
		}
		if ( hex($proc->flags) & 0x00000002 ) {
			$flags{is_session_leader}=1;
		}
		#if ( hex($proc->flags) &  ){$flags{is_being_forked}=1; }
		if ( hex($proc->flags) & 0x02000 ) {
			$flags{working_on_exiting}=1;
		}
		if ( hex($proc->flags) & 0x00002 ) {
			$flags{has_controlling_terminal}=1;
		}
		if ( hex($proc->flags) & 0x00000004 ) {
			$flags{is_locked}=1;
		}
		if ( hex($proc->flags) & 0x00800 ) {
			$flags{traced_by_debugger}=1;
		}
		if ( hex($proc->flags) & 0x00001 ) {
			$flags{posix_advisory_lock}=1;
		}
	}

	my $info=$proc->{state};
	if (
		$info eq 'sleep'
		) {
		$info='S';
	} elsif (
			 $info eq 'zombie'
			 ) {
		$info='Z';
	} elsif (
			 $info eq 'wait'
			 ) {
		$info='W';
	} elsif (
			 $info eq 'run'
			 ) {
		$info='R';
	}

	#add initial color if needed
	if ( defined( $self->{flags_color} ) ){
		$info=color( $self->{flags_color} ).$info;
	}

	#checks if it is swapped out
	if (
		( $proc->{state} ne 'zombie' ) &&
		( $proc->{rss} == '0' ) &&
		( $flags{is_kern_proc} == '0' )
		) {
		$info=$info.'O';
	}

	#handles the various flags
	if ( $flags{working_on_exiting} ) {
		$info=$info.'E';
	}
	if ( $flags{is_session_leader} ) {
		$info=$info.'s';
	}
	if ( $flags{is_locked} || $flags{posix_advisory_lock} ) {
		$info=$info.'L';
	}
	if ( $flags{has_controlling_terminal} ) {
		$info=$info.'+';
	}
	if ( $flags{is_being_forked} ) {
		$info=$info.'F';
	}
	if ( $flags{traced_by_debugger} ) {
		$info=$info.'X';
	}

	# adds the initial color reset if needed
	if ( defined( $self->{flags_color} ) ){
		$info=$info.color( 'reset' );
	}
	$info=$info.' ';


	# adds the second color if needed
	if ( defined( $self->{wchan_color} ) ){
		$info=$info.color( $self->{wchan_color} );
	}

	# adds the wait channel
	if ( $^O =~ /linux/ ) {
		my $wchan='';
		if ( -e '/proc/'.$proc->{pid}.'/wchan') {
			open( my $wchan_fh, '<', '/proc/'.$proc->{pid}.'/wchan' );
			$wchan=readline( $wchan_fh );
			close( $wchan_fh );
		}
		$info=$info.$wchan;
	} else {
		$info=$info.$proc->{wchan};
	}

	# adds the second color reset if needed
	if ( defined( $self->{wchan_color} ) ){
		$info=$info.color( 'reset' );
	}

	return $info;
}

=head1 AUTHOR

Zane C. Bowers-Hadley, C<<  >>

=head1 BUGS

Please report any bugs or feature requests to C, or through
the web interface at L.  I will be notified, and then you'll
automatically be notified of progress on your bug as I make changes.




=head1 SUPPORT

You can find documentation for this module with the perldoc command.

    perldoc Proc::ProcessTable::InfoString


You can also look for information at:

=over 4

=item * RT: CPAN's request tracker (report bugs here)

L

=item * AnnoCPAN: Annotated CPAN documentation

L

=item * CPAN Ratings

L

=item * Search CPAN

L

=item * Repository

L

=back


=head1 ACKNOWLEDGEMENTS


=head1 LICENSE AND COPYRIGHT

This software is Copyright (c) 2019 by Zane C. Bowers-Hadley.

This is free software, licensed under:

  The Artistic License 2.0 (GPL Compatible)


=cut

1; # End of Proc::ProcessTable::InfoString