File Coverage

blib/lib/Sys/Statgrab.pm

Criterion	Covered	Total	%
statement	27	69	39.1
branch	2	4	50.0
condition	0	24	0.0
subroutine	8	8	100.0
pod			n/a
total	37	105	35.2

package Sys::Statgrab;

$VERSION = 0.01;

use strict;
use warnings;

use constant STATGRAB_CONSTANTS => qw(
	SG_ERROR_ASPRINTF
	SG_ERROR_DEVSTAT_GETDEVS
	SG_ERROR_DEVSTAT_SELECTDEVS
	SG_ERROR_ENOENT
	SG_ERROR_GETIFADDRS
	SG_ERROR_GETMNTINFO
	SG_ERROR_GETPAGESIZE
	SG_ERROR_KSTAT_DATA_LOOKUP
	SG_ERROR_KSTAT_LOOKUP
	SG_ERROR_KSTAT_OPEN
	SG_ERROR_KSTAT_READ
	SG_ERROR_KVM_GETSWAPINFO
	SG_ERROR_KVM_OPENFILES
	SG_ERROR_MALLOC
	SG_ERROR_NONE
	SG_ERROR_OPEN
	SG_ERROR_OPENDIR
	SG_ERROR_PARSE
	SG_ERROR_SETEGID
	SG_ERROR_SETEUID
	SG_ERROR_SETMNTENT
	SG_ERROR_SOCKET
	SG_ERROR_SWAPCTL
	SG_ERROR_SYSCONF
	SG_ERROR_SYSCTL
	SG_ERROR_SYSCTLBYNAME
	SG_ERROR_SYSCTLNAMETOMIB
	SG_ERROR_UNAME
	SG_ERROR_UNSUPPORTED
	SG_ERROR_XSW_VER_MISMATCH
	SG_IFACE_DUPLEX_FULL
	SG_IFACE_DUPLEX_HALF
	SG_IFACE_DUPLEX_UNKNOWN
	SG_PROCESS_STATE_RUNNING
	SG_PROCESS_STATE_SLEEPING
	SG_PROCESS_STATE_STOPPED
	SG_PROCESS_STATE_UNKNOWN
	SG_PROCESS_STATE_ZOMBIE
);
use constant STATGRAB_BASE_FUNCTIONS => qw(
	get_error drop_privileges
	get_host_info
	get_cpu_stats get_cpu_stats_diff get_cpu_percents
	get_disk_io_stats get_disk_io_stats_diff
	get_fs_stats
	get_load_stats
	get_mem_stats
	get_swap_stats
	get_network_io_stats get_network_io_stats_diff
	get_network_iface_stats
	get_page_stats get_page_stats_diff
	get_user_stats
	get_process_stats
);
use constant STATGRAB_SORT_FUNCTIONS => qw(
	sort_procs_by_name
	sort_procs_by_pid
	sort_procs_by_uid
	sort_procs_by_gid
	sort_procs_by_size
	sort_procs_by_res
	sort_procs_by_cpu
	sort_procs_by_time
);

BEGIN {
	use Exporter ();
	use vars		qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
	@ISA			= qw(Exporter);
	@EXPORT			= (STATGRAB_CONSTANTS, STATGRAB_BASE_FUNCTIONS, STATGRAB_SORT_FUNCTIONS);
	@EXPORT_OK		= (STATGRAB_CONSTANTS, STATGRAB_BASE_FUNCTIONS, STATGRAB_SORT_FUNCTIONS);
	%EXPORT_TAGS	= ( 'all' => [ STATGRAB_CONSTANTS, STATGRAB_BASE_FUNCTIONS, STATGRAB_SORT_FUNCTIONS ] );

	if ($^O eq 'cygwin') {
		require Unix::Statgrab;
		import Unix::Statgrab (STATGRAB_CONSTANTS);

		# Natively supported by Statgrab (>= 0.8) on cygwin
		*drop_privileges = *drop_privileges = \&Unix::Statgrab::drop_privileges;
		*get_host_info = *get_host_info = \&Unix::Statgrab::get_host_info;
		*get_cpu_stats = *get_cpu_stats = \&Unix::Statgrab::get_cpu_stats;
		*get_cpu_stats_diff = *get_cpu_stats_diff = \&Unix::Statgrab::get_cpu_stats_diff;
		*get_cpu_percents = *get_cpu_percents = \&Unix::Statgrab::get_cpu_percents;
		*get_mem_stats = *get_mem_stats = \&Unix::Statgrab::get_mem_stats;
		*get_swap_stats = *get_swap_stats = \&Unix::Statgrab::get_swap_stats;
		*get_page_stats = *get_page_stats = \&Unix::Statgrab::get_page_stats;
		*get_page_stats_diff = *get_page_stats_diff = \&Unix::Statgrab::get_page_stats_diff;
		*get_user_stats = *get_user_stats = \&Unix::Statgrab::get_user_stats;

		# Known as not supported by Statgrab (<= 0.13, at least) on cygwin
		*get_disk_io_stats = *get_disk_io_stats = sub { return Unix::Statgrab::get_disk_io_stats(@_) || Sys::Statgrab::Cygwin::sg_disk_io_stats->new(); };
		*get_disk_io_stats_diff = *get_disk_io_stats_diff = sub { return Unix::Statgrab::get_disk_io_stats_diff(@_) || Sys::Statgrab::Cygwin::sg_disk_io_stats->new('diff'); };
		*get_fs_stats = *get_fs_stats = sub { return Unix::Statgrab::get_fs_stats(@_) || Sys::Statgrab::Cygwin::sg_fs_stats->new(); };
		*get_load_stats = *get_load_stats = sub { return Unix::Statgrab::get_load_stats(@_) || Sys::Statgrab::Cygwin::sg_load_stats->new(); };
		*get_network_io_stats = *get_network_io_stats = sub { return Unix::Statgrab::get_network_io_stats(@_) || Sys::Statgrab::Cygwin::sg_network_io_stats->new(); };
		*get_network_io_stats_diff = *get_network_io_stats_diff = sub { return Unix::Statgrab::get_network_io_stats_diff(@_) || Sys::Statgrab::Cygwin::sg_network_io_stats->new('diff'); };
		*get_network_iface_stats = *get_network_iface_stats = sub { return Unix::Statgrab::get_network_iface_stats(@_) || Sys::Statgrab::Cygwin::sg_network_iface_stats->new(); };
		*get_process_stats = *get_process_stats = sub { return Unix::Statgrab::get_process_stats(@_) || Sys::Statgrab::Cygwin::sg_process_stats->new(); };

		*sort_procs_by_name = \&Sys::Statgrab::Cygwin::sg_process_stats::_sort_procs_by_name;
		*sort_procs_by_pid = \&Sys::Statgrab::Cygwin::sg_process_stats::_sort_procs_by_pid;
		*sort_procs_by_uid = \&Sys::Statgrab::Cygwin::sg_process_stats::_sort_procs_by_uid;
		*sort_procs_by_gid = \&Sys::Statgrab::Cygwin::sg_process_stats::_sort_procs_by_gid;
		*sort_procs_by_size = \&Sys::Statgrab::Cygwin::sg_process_stats::_sort_procs_by_size;
		*sort_procs_by_res = \&Sys::Statgrab::Cygwin::sg_process_stats::_sort_procs_by_res;
		*sort_procs_by_cpu = \&Sys::Statgrab::Cygwin::sg_process_stats::_sort_procs_by_cpu;
		*sort_procs_by_time = \&Sys::Statgrab::Cygwin::sg_process_stats::_sort_procs_by_time;
	}
	elsif ($^O eq 'MSWin32')
	{
		die "$^O not yet supported by ".__PACKAGE__;
		require Unix::Statgrab;
		import Unix::Statgrab (STATGRAB_CONSTANTS);
		require Win32::Process::Info;
		import Unix::Statgrab (STATGRAB_CONSTANTS);

	}
	else {
		require Unix::Statgrab;
		import Unix::Statgrab (STATGRAB_CONSTANTS, STATGRAB_BASE_FUNCTIONS, STATGRAB_SORT_FUNCTIONS);
	}
}


package Sys::Statgrab::Cygwin::sg_disk_io_stats;
use strict;
use warnings;

sub new {
	my $type = shift;
	my $class = ref($type) || $type;
	my $diff = 1 if shift;

	warn "get_disk_io_stats not yet implemented";
	return undef;
}

package Sys::Statgrab::Cygwin::sg_fs_stats;
use strict;
use warnings;

sub new {
	my $type = shift;
	my $class = ref($type) || $type;

	warn "get_fs_stats not yet implemented";
	return undef;
}

package Sys::Statgrab::Cygwin::sg_load_stats;
use strict;
use warnings;

sub new {
	my $type = shift;
	my $class = ref($type) || $type;

	warn "get_load_stats not yet implemented";
	return undef;
}

package Sys::Statgrab::Cygwin::sg_network_io_stats;
use strict;
use warnings;

sub new {
	my $type = shift;
	my $class = ref($type) || $type;
	my $diff = 1 if shift;

	warn "get_network_io_stats not yet implemented";
	return undef;
}

package Sys::Statgrab::Cygwin::sg_network_iface_stats;
use strict;
use warnings;

sub new {
	my $type = shift;
	my $class = ref($type) || $type;

	warn "get_network_iface_stats not yet implemented";
	return undef;
}

package Sys::Statgrab::Cygwin::sg_process_stats;
use strict;
use warnings;

use constant SORT_METHOD_PREFIX => '_sort_procs_by_';
use constant SORT_METHODS => qw(
	name
	pid
	uid
	gid
	size
	res
	cpu
	time
);

sub new {
	my $type = shift;
	my $class = ref($type) || $type;

	### generate process stat objects ###
	my @procs;
	opendir(PROCDIR, '/proc') || die "Can't read dir /proc: $!";
	push @procs, Sys::Statgrab::Cygwin::sg_process_stats::all_procs->new($_) foreach grep(/^\d+$/o, (readdir(PROCDIR)));
	closedir PROCDIR;

	### optimization for pcpu stat ###
	my %cpu_map;
	my @line;
	if (open(IPCCMD, "procps -e -opid -opcpu |")) {
		foreach my $l () {
			$l =~ s/^\s+//o;
			@line = split(/\s+/o, $l);
			chomp @line;
			$cpu_map{$line[0]} = $line[1];
		}
		close IPCCMD;
		foreach my $proc (@procs) {
			$proc->{cpu_percent} = $cpu_map{$proc->{pid}};
		}
	}
	else {
		warn "Can't obtain cpu_percent stats: Can't execute procps: $!";
	}

	return bless(\@procs, $class);
}

sub all_procs {
	my $self = shift;
	return @{$self};
}

sub sort_by {
	my $self = shift;
	my $meth = shift;
	die "Usage: ".__PACKAGE__."::sort_by(obj, meth)" unless defined $meth;

	my $regex = quotemeta $meth;
	my $sort_method = SORT_METHOD_PREFIX.$meth;
	@{$self} = sort $sort_method @{$self} if grep(/^$regex$/, SORT_METHODS);
	return $self;
}

sub _sort_procs_by_name ($$) { shift->proc_name cmp shift->proc_name }
sub _sort_procs_by_pid ($$) { shift->pid <=> shift->pid }
sub _sort_procs_by_uid ($$) { shift->uid <=> shift->uid }
sub _sort_procs_by_gid ($$) { shift->gid <=> shift->gid }
sub _sort_procs_by_size ($$) { shift->proc_size <=> shift->proc_size }
sub _sort_procs_by_res ($$) { shift->proc_resident <=> shift->proc_resident }
sub _sort_procs_by_cpu ($$) { shift->cpu_percent <=> shift->cpu_percent }
sub _sort_procs_by_time ($$) { shift->time_spent <=> shift->time_spent }

package Sys::Statgrab::Cygwin::sg_process_stats::all_procs;
use strict;
use warnings;

our $AUTOLOAD;

sub new {
	my $type = shift;
	my $class = ref($type) || $type;
	my $pid = shift;

	my $o = bless(\$pid, $class);
	my $self = {
		proc_name		=> $o->_proc_name,
		proc_title		=> $o->_proc_title,
		pid				=> $o->_pid,
		parent_pid		=> $o->_parent_pid,
		pgid			=> $o->_pgid,
		uid				=> $o->_uid,
		euid			=> $o->_euid,
		gid				=> $o->_gid,
		egid			=> $o->_egid,
		proc_size		=> $o->_proc_size,
		proc_resident	=> $o->_proc_resident,
		time_spent		=> $o->_time_spent,
		cpu_percent		=> undef,	#efficiently calculated later by caller class
		nice			=> $o->_nice,
		state			=> $o->_state,
	};
	return bless($self, $class);
}

sub AUTOLOAD {	#read-only
	my $self = shift;
	my $class = ref($self) || $self;
	my $name = $AUTOLOAD;
	$name =~ s/.*://o;   # strip fully-qualified portion
	no strict 'refs';
	Carp::confess "Can't access '$name' field in class $class" unless (exists $self->{$name});
	return $self->{$name};
}
sub DESTROY {}
sub CLONE {}

sub _proc_name {
	my $self = shift;
	return Sys::Statgrab::Util::get_hash_value("/proc/${$self}/status", ':', 'Name', 1);
}
sub _proc_title {
	my $self = shift;
	my $cmdline = Sys::Statgrab::Util::get_value("/proc/${$self}/cmdline");
	$cmdline =~ s/\x0/ /go;
	return $cmdline;
}
sub _pid {
	my $self = shift;
	return ${$self};
}
sub _parent_pid {
	my $self = shift;
	return Sys::Statgrab::Util::get_value("/proc/${$self}/ppid");
}
sub _pgid {
	my $self = shift;
	return Sys::Statgrab::Util::get_value("/proc/${$self}/pgid");
}
sub _uid {
	my $self = shift;
	return Sys::Statgrab::Util::get_value("/proc/${$self}/uid");
}
sub _euid { return _uid(@_); }	#bug: is euid accessable on cygwin?
sub _gid {
	my $self = shift;
	return Sys::Statgrab::Util::get_value("/proc/${$self}/gid");
}
sub _egid { return _gid(@_); }	#bug: is egid accessable on cygwin?
sub _proc_size {	#note: approximated to nearest unit (default is kB)
	my $self = shift;
	my @size = split(/ /, Sys::Statgrab::Util::get_hash_value("/proc/${$self}/status", ':', 'VmSize', 1));
	return $size[0] * (lc $size[1] eq 'kb' ? 1000 : lc $size[1] eq 'mb' ? 1000000 : lc $size[1] eq 'gb' ? 1000000000 : 1);
}
sub _proc_resident {	#note: approximated to nearest unit (default is kB)
	my $self = shift;
	my @rss = split(/ /, Sys::Statgrab::Util::get_hash_value("/proc/${$self}/status", ':', 'VmRSS', 1));
	return $rss[0] * (lc $rss[1] eq 'kb' ? 1000 : lc $rss[1] eq 'mb' ? 1000000 : lc $rss[1] eq 'gb' ? 1000000000 : 1);
}
sub _time_spent {
	my $self = shift;
	my ($utime, $stime) = (split(/ /, Sys::Statgrab::Util::get_value("/proc/${$self}/stat")))[13..14];
	return $utime + $stime;
}
sub _cpu_percent {	#note: using more efficient method
	my $self = shift;
	return Sys::Statgrab::Util::get_procps_value(${$self}, 'pcpu');
	return undef;
}
sub _nice {
	my $self = shift;
#	return Sys::Statgrab::Util::get_procps_value(${$self}, 'ni');
	return (split(/ /, Sys::Statgrab::Util::get_value("/proc/${$self}/stat")))[18];
}
sub _state {
	my $self = shift;
	my $state = (split(/ /, Sys::Statgrab::Util::get_value("/proc/${$self}/stat")))[2];
#	return $state eq 'R' ? Sys::Statgrab::SG_PROCESS_STATE_RUNNING
#		: $state eq 'S' ? Sys::Statgrab::SG_PROCESS_STATE_SLEEPING
#		: $state eq 'T' ? Sys::Statgrab::SG_PROCESS_STATE_STOPPED
#		: $state eq 'Z' ? Sys::Statgrab::SG_PROCESS_STATE_ZOMBIE	#kludge: not sure if this is the correct letter
#		: Sys::Statgrab::SG_PROCESS_STATE_UNKNOWN
}

package Sys::Statgrab::Util;

use strict;
use warnings;

sub get_value ($) {
	my $file = shift;
	open(PROCFILE, "<$file") || die "Can't open file $file";
	my @line = ;
	close PROCFILE;
	chomp @line;
	return $line[0];
}

sub get_array_index ($$$) {
	my $file = shift;
	my $delimiter = shift;
	my $idx = shift;
	open(PROCFILE, "<$file") || die "Can't open file $file";
	my @line = split(/\s*$delimiter\s*/, );
	close PROCFILE;
	chomp @line;
	return $line[$idx];
}

sub get_hash_value ($$$;$) {
	my $file = shift;
	my $delimiter = shift;
	my $key = shift;
	my $idx = shift;
	open(PROCFILE, "<$file") || die "Can't open file $file";
	my @line;
	while (@line = split(/\s*$delimiter\s*/, )) {
		last if $line[0] eq $key;
	}
	chomp @line;
	close PROCFILE;
	return defined $idx ? $line[$idx] : wantarray ? @line : $line[1];
}

sub get_procps_value ($$) {
	my $pid = shift;
	my $format = shift;
	if (open(IPCCMD, "procps -e -opid -o$format |")) {
		my @line;
		foreach my $l () {
			$l =~ s/^\s+//o;
			@line = split(/\s+/o, $l);
			last if $line[0] eq $pid;
		}
		close IPCCMD;
		chomp @line;
		return $line[1];
	}
	else {
		warn "Can't obtain cpu_percent stats: Can't execute procps: $!";
		return undef;
	}
}

1;

__END__