code all now works
This commit is contained in:
parent
d4330ef6ad
commit
e193318d20
|
@ -4,25 +4,25 @@ use warnings;
|
|||
use ExtUtils::MakeMaker;
|
||||
|
||||
my %WriteMakefileArgs = (
|
||||
NAME => 'Proc::ProcessTable::InfoString',
|
||||
AUTHOR => q{Zane C. Bowers-Hadley <vvelox@vvelox.net>},
|
||||
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 <vvelox@vvelox.net>},
|
||||
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);
|
||||
|
|
|
@ -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<Term::ANSIColor>.
|
||||
|
||||
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
|
||||
|
|
Loading…
Reference in New Issue