diff --git a/Proc-ProcessTable-InfoString/Makefile.PL b/Proc-ProcessTable-InfoString/Makefile.PL index c95fe26..a618252 100644 --- a/Proc-ProcessTable-InfoString/Makefile.PL +++ b/Proc-ProcessTable-InfoString/Makefile.PL @@ -4,25 +4,25 @@ use warnings; use ExtUtils::MakeMaker; my %WriteMakefileArgs = ( - NAME => 'Proc::ProcessTable::InfoString', - AUTHOR => q{Zane C. Bowers-Hadley }, - VERSION_FROM => 'lib/Proc/ProcessTable/InfoString.pm', - ABSTRACT_FROM => 'lib/Proc/ProcessTable/InfoString.pm', - LICENSE => 'artistic_2', - MIN_PERL_VERSION => '5.006', - CONFIGURE_REQUIRES => { - 'ExtUtils::MakeMaker' => '0', - }, - TEST_REQUIRES => { - 'Test::More' => '0', - }, - PREREQ_PM => { - #'ABC' => '1.6', - #'Foo::Bar::Module' => '5.0401', - }, - dist => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', }, - clean => { FILES => 'Proc-ProcessTable-InfoString-*' }, -); + NAME => 'Proc::ProcessTable::InfoString', + AUTHOR => q{Zane C. Bowers-Hadley }, + VERSION_FROM => 'lib/Proc/ProcessTable/InfoString.pm', + ABSTRACT_FROM => 'lib/Proc/ProcessTable/InfoString.pm', + LICENSE => 'artistic_2', + MIN_PERL_VERSION => '5.006', + CONFIGURE_REQUIRES => { + 'ExtUtils::MakeMaker' => '0', + }, + TEST_REQUIRES => { + 'Test::More' => '0', + }, + PREREQ_PM => { + 'Term::ANSIColor' => '4.06', + 'Proc::ProcessTable' => '0.59', + }, + dist => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', }, + clean => { FILES => 'Proc-ProcessTable-InfoString-*' }, + ); # Compatibility with old versions of ExtUtils::MakeMaker unless (eval { ExtUtils::MakeMaker->VERSION('6.64'); 1 }) { @@ -36,10 +36,10 @@ unless (eval { ExtUtils::MakeMaker->VERSION('6.55_03'); 1 }) { } delete $WriteMakefileArgs{CONFIGURE_REQUIRES} - unless eval { ExtUtils::MakeMaker->VERSION('6.52'); 1 }; +unless eval { ExtUtils::MakeMaker->VERSION('6.52'); 1 }; delete $WriteMakefileArgs{MIN_PERL_VERSION} - unless eval { ExtUtils::MakeMaker->VERSION('6.48'); 1 }; +unless eval { ExtUtils::MakeMaker->VERSION('6.48'); 1 }; delete $WriteMakefileArgs{LICENSE} - unless eval { ExtUtils::MakeMaker->VERSION('6.31'); 1 }; +unless eval { ExtUtils::MakeMaker->VERSION('6.31'); 1 }; WriteMakefile(%WriteMakefileArgs); diff --git a/Proc-ProcessTable-InfoString/lib/Proc/ProcessTable/InfoString.pm b/Proc-ProcessTable-InfoString/lib/Proc/ProcessTable/InfoString.pm index 13b2100..a860917 100644 --- a/Proc-ProcessTable-InfoString/lib/Proc/ProcessTable/InfoString.pm +++ b/Proc-ProcessTable-InfoString/lib/Proc/ProcessTable/InfoString.pm @@ -3,18 +3,19 @@ package Proc::ProcessTable::InfoString; use 5.006; use strict; use warnings; +use Term::ANSIColor; =head1 NAME -Proc::ProcessTable::InfoString - The great new Proc::ProcessTable::InfoString! +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.01 +Version 0.0.1 =cut -our $VERSION = '0.01'; +our $VERSION = '0.0.1'; =head1 SYNOPSIS @@ -24,29 +25,200 @@ Quick summary of what the module does. Perhaps a little code snippet. use Proc::ProcessTable::InfoString; + use Proc::ProcessTable; - my $foo = Proc::ProcessTable::InfoString->new(); - ... + my $is = Proc::ProcessTable::InfoString->new(); -=head1 EXPORT + my $p = Proc::ProcessTable->new( 'cache_ttys' => 1 ); + my $pt = $p->table; -A list of functions that can be exported. You can delete this section -if you don't export anything, such as for a purely object-oriented module. + foreach my $proc ( @{ $pt } ){ + print $proc->pid.' '.$is->info( $proc )."\n"; + } -=head1 SUBROUTINES/METHODS +=head1 METHODS -=head2 function1 +=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 function1 { +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 function2 +=head2 info =cut -sub function2 { +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