File Coverage

blib/lib/POE/Devel/ProcAlike/POEInfo.pm

Criterion	Covered	Total	%
statement	16	18	88.8
branch			n/a
condition			n/a
subroutine	6	6	100.0
pod			n/a
total	22	24	91.6

# Declare our package
package POE::Devel::ProcAlike::POEInfo;
use strict; use warnings;

# Initialize our version
use vars qw( $VERSION );
$VERSION = '0.02';

# Set our superclass
use base 'Filesys::Virtual::Async::inMemory';

# portable tools
use File::Spec;

# import the useful $poe_kernel
use POE;
use POE::API::Peek;
my $api = POE::API::Peek->new();
my $have_stats = 0;
my $have_eventprofile = 0;

sub new {
	# do we have stats available?
	eval { $have_stats = POE::Kernel::TRACE_STATISTICS() };
	if ( $@ ) {
		$have_stats = 0;
	}
	eval { $have_eventprofile = POE::Kernel::TRACE_PROFILE() };
	if ( $@ ) {
		$have_eventprofile = 0;
	} else {
		# do we have a new-enough POE to introspect the profile data?
		if ( ! $poe_kernel->can( 'stat_getprofile' ) ) {
			$have_eventprofile = 0;
		}
	}

	# make sure we set a readonly filesystem!
	return __PACKAGE__->SUPER::new(
		'readonly'	=> 1,
	);
}

#/kernel
#	# place for kernel stuff
#
#	id		# $poe_kernel->ID
#	is_running	# $api->is_kernel_running
#	which_loop	# $poe_kernel->poe_kernel_loop
#	safe_signals	# $api->get_safe_signals
#
#	active_session	# $poe_kernel->get_active_session->ID
#	active_event	# $poe_kernel->get_active_event
#
#	memory_size	# $api->kernel_memory_size
#	session_count	# $api->session_count
#	extref_count	# $api->extref_count
#	handle_count	# $api->handle_count
#	event_count	# $poe_kernel->get_event_count
#	next_event	# $poe_kernel->get_next_event_time
#
#	/statistics
#		# stats gathered via TRACE_STATISTICS if available
#
#		interval
#
#		blocked
#		blocked_seconds
#		idle_seconds
#		total_duration
#		user_events
#		user_seconds
#
#		avg_blocked
#		avg_blocked_seconds
#		avg_idle_seconds
#		avg_total_duration
#		avg_user_events
#		avg_user_seconds
#
#		derived_idle
#		derived_user
#		derived_blocked
#		derived_userload
#
#		event_profile
#
#	/eventqueue
#		# a place for the event queue data ( basically a dump of POE::Queue::Array ) - from $api->event_queue_dump()
#
#		/N
#			# N is the ID of event in the queue
#
#			id
#			index
#			priority
#			event
#			source
#			destination
#			type
#
#	/sessions
#		# place for all session info ( like /proc/pid ) - from $api->session_list
#
#		/id
#			# the id is the session ID
#
#			id			# $session->ID
#			type			# ref( $session )
#			memory_size		# $api->session_memory_size( $session )
#			extref_count		# $api->get_session_extref_count( $session )
#			handle_count		# $api->session_handle_count( $session )
#
#			events_to		# $api->event_count_to( $session )
#			events_from		# $api->event_count_from( $session )
#			event_profile		# $kernel->stat_getprofile( $session )
#
#			watched_signals		# $api->signals_watched_by_session( $session )
#			events			# $api->session_event_list( $session )
#			aliases			# $api->session_alias_list( $session )
#
#			heap			# Data::Dumper( $session->get_heap() )
my %fs = (
	'id'			=> $poe_kernel->ID . "\n",
	'is_running'		=> [ $api, 'is_kernel_running' ],
	'which_loop'		=> $poe_kernel->poe_kernel_loop . "\n",
	'safe_signals'		=> join( "\n", $api->get_safe_signals() ) . "\n",
	'active_session'	=> [ $poe_kernel, 'get_active_session', sub { $_[0]->ID } ],
	'active_event'		=> [ $poe_kernel, 'get_active_event' ],
#	'memory_size'		=> [ $api, 'kernel_memory_size' ],
	'session_count'		=> [ $api, 'session_count', sub { $_[0] - 1 } ],
	'extref_count'		=> [ $api, 'extref_count' ],
	'handle_count'		=> [ $api, 'handle_count' ],
	'event_count'		=> [ $poe_kernel, 'get_event_count' ],
	'next_event'		=> [ $poe_kernel, 'get_next_event_time' ],

	'statistics'		=> \&manage_statistics,

	'eventqueue'		=> \&manage_queue,

	'sessions'		=> \&manage_sessions,
);

# helper sub to keep track of stat variables
sub _get_statistics_metrics {
	my @stats;

	# do we have event profiling?
	if ( $have_eventprofile ) {
		push( @stats, 'event_profile' );
	}
	if ( $have_stats ) {
		push( @stats, qw( blocked blocked_seconds idle_seconds interval total_duration user_events user_seconds
			avg_blocked avg_blocked_seconds avg_idle_seconds avg_user_events avg_user_seconds
			derived_idle derived_user derived_blocked derived_userload
		) );
	}

	return \@stats;
}
sub _get_statistics_metric {
	my $metric = shift;

	# what metric?
	if ( $metric eq 'event_profile' ) {
		my %profile = $poe_kernel->stat_getprofile();

		# do we have stats?
		if ( keys %profile == 0 ) {
			return "\n";
		}

		my $data = '';
		foreach my $p ( keys %profile ) {
			$data .= $profile{ $p } . ":$p\n";
		}
		return $data;
	} else {
		my %average = $poe_kernel->stat_getdata();

		# do we have stats?
		if ( keys %average == 0 ) {
			return "\n";
		}

		# derived require calculations
		if ( $metric =~ /^derived/ ) {
			# Division by zero sucks.
			$average{'interval'}	||= 1;
			$average{'user_events'}	||= 1;

			if ( $metric eq 'derived_idle' ) {
				return sprintf( "%2.1f%%\n", 100 * $average{'avg_idle_seconds'} / $average{'interval'} );
			} elsif ( $metric eq 'derived_user' ) {
				return sprintf( "%2.1f%%\n", 100 * $average{'avg_user_seconds'} / $average{'interval'} );
			} elsif ( $metric eq 'derived_blocked' ) {
				return sprintf( "%2.1f%%\n", 100 * $average{'avg_blocked'} / $average{'user_events'} );
			} elsif ( $metric eq 'derived_userload' ) {
				return sprintf( "%2.1f%%\n", 100 * $average{'avg_user_events'} / $average{'interval'} );
			}
		} else {
			# simple hash access
			return $average{ $metric } . "\n";
		}
	}
}

sub manage_statistics {
	my( $type, @path ) = @_;

	# what's the operation?
	if ( $type eq 'readdir' ) {
		return _get_statistics_metrics();
	} elsif ( $type eq 'stat' ) {
		# set some default data
		my ($atime, $ctime, $mtime, $size, $modes);
		$atime = $ctime = $mtime = time();
		my ($dev, $ino, $rdev, $blocks, $gid, $uid, $nlink, $blksize) = ( 0, 0, 0, 1, (split( /\s+/, $) ))[0], $>, 1, 1024 );

		# trying to stat the dir or stuff inside it?
		if ( defined $path[0] ) {
			# is it a valid stat metric?
			if ( ! grep { $_ eq $path[0] } @{ _get_statistics_metrics() } or defined $path[1] ) {
				return;
			}

			# a file, munge the data
			$size = length( _get_statistics_metric( $path[0] ) );
			$modes = oct( '100644' );
		} else {
			# a directory, munge the data
			$size = 0;
			$modes = oct( '040755' );
			$nlink = 2;
		}

		# finally, return the darn data!
		return( [ $dev, $ino, $modes, $nlink, $uid, $gid, $rdev, $size, $atime, $mtime, $ctime, $blksize, $blocks ] );
	} elsif ( $type eq 'open' ) {
		# is it a valid stat metric?
		if ( ! grep { $_ eq $path[0] } @{ _get_statistics_metrics() } or defined $path[1] ) {
			return;
		}

		# return a scalar ref
		my $data = _get_statistics_metric( $path[0] );
		return \$data;
	}
}

# helper sub to simplify queue item processing
sub _get_queue_metrics {
	return [ qw( id index priority event source destination type ) ];
}
sub _get_queue_metric {
	my $queuedata = shift;
	my $metric = shift;

	# some metrics require manipulation
	if ( $metric eq 'source' or $metric eq 'destination' ) {
		if ( ref $queuedata->{ $metric } ) {
			return $queuedata->{ $metric }->ID . "\n";
		}
	}

	# simple hash access
	return $queuedata->{ $metric } . "\n";
}

sub manage_queue {
	my( $type, @path ) = @_;

	# what's the operation?
	if ( $type eq 'readdir' ) {
		# trying to read the root or the queue event itself?
		if ( defined $path[0] ) {
			return _get_queue_metrics();
		} else {
			# get the queue events
			my @queue = map { $_->{'ID'} } $api->event_queue_dump();
			return \@queue;
		}
	} elsif ( $type eq 'stat' ) {
		# set some default data
		my ($atime, $ctime, $mtime, $size, $modes);
		$atime = $ctime = $mtime = time();
		my ($dev, $ino, $rdev, $blocks, $gid, $uid, $nlink, $blksize) = ( 0, 0, 0, 1, (split( /\s+/, $) ))[0], $>, 1, 1024 );

		# get the data to start off
		my @queue = $api->event_queue_dump();

		# trying to stat the dir or stuff inside it?
		if ( defined $path[0] ) {
			# does the id exist?
			my @data = grep { $_->{'ID'} eq $path[0] } @queue;
			if ( ! @data ) {
				return;
			}

			# trying to stat the queue id or data inside it?
			if ( defined $path[1] ) {
				# is it a valid queue metric?
				if ( ! grep { $_ eq $path[1] } @{ _get_queue_metrics() } or defined $path[2] ) {
					return;
				}

				# a file, munge the data
				$size = length( _get_queue_metric( $data[0], $path[1] ) );
				$modes = oct( '100644' );
			} else {
				# a directory, munge the data
				$size = 0;
				$modes = oct( '040755' );
				$nlink = 2;
			}
		} else {
			# a directory, munge the data
			$size = 0;
			$modes = oct( '040755' );
			$nlink = 2 + scalar @queue;
		}

		# finally, return the darn data!
		return( [ $dev, $ino, $modes, $nlink, $uid, $gid, $rdev, $size, $atime, $mtime, $ctime, $blksize, $blocks ] );
	} elsif ( $type eq 'open' ) {
		# get the data to start off
		my @queue = $api->event_queue_dump();

		my @data = grep { $_->{'ID'} eq $path[0] } @queue;
		if ( ! @data or ! defined $path[1] ) {
			return;
		}

		# is it a valid queue metric?
		if ( ! grep { $_ eq $path[1] } @{ _get_queue_metrics() } or defined $path[2] ) {
			return;
		}

		# get the metric!
		my $data = _get_queue_metric( $data[0], $path[1] );
		return \$data;
	}
}

# helper sub to simplify session item processing
sub _get_sessions_metrics {
	my @stats;

	# removed memory_size, watched_signals due to complications
	push( @stats, qw( id type extref_count handle_count events_to events_from
		events aliases heap
	) );

	# do we have profiling?
	if ( $have_eventprofile ) {
		push( @stats, 'event_profile' );
	}

	return \@stats;
}
sub _get_sessions_metric {
	my $session = shift;
	my $metric = shift;

	# determine what to do
	if ( $metric eq 'id' ) {
		return $session->ID . "\n";
	} elsif ( $metric eq 'type' ) {
		return ref( $session ) . "\n";
	} elsif ( $metric eq 'memory_size' ) {
		return $api->session_memory_size( $session ) . "\n";
	} elsif ( $metric eq 'extref_count' ) {
		return $api->get_session_extref_count( $session ) . "\n";
	} elsif ( $metric eq 'handle_count' ) {
		return $api->session_handle_count( $session ) . "\n";
	} elsif ( $metric eq 'events_to' ) {
		return $api->event_count_to( $session ) . "\n";
	} elsif ( $metric eq 'events_from' ) {
		return $api->event_count_from( $session ) . "\n";
	} elsif ( $metric eq 'watched_signals' ) {
		return join( "\n", $api->signals_watched_by_session( $session ) ) . "\n";
	} elsif ( $metric eq 'events' ) {
		return join( "\n", $api->session_event_list( $session ) ) . "\n";
	} elsif ( $metric eq 'aliases' ) {
		return join( "\n", $api->session_alias_list( $session ) ) . "\n";
	} elsif ( $metric eq 'heap' ) {
		require Data::Dumper;

		# make sure we have "consistent" data
		no warnings;	# shutup "possible used only once" warning!
		local $Data::Dumper::Terse = 1;
		local $Data::Dumper::Sortkeys = 1;
		use warnings;

		return Data::Dumper::Dumper( $session->get_heap() );
	} elsif ( $metric eq 'event_profile' ) {
		my %profile = $poe_kernel->stat_getprofile( $session );

		# do we have stats?
		if ( keys %profile == 0 ) {
			return "\n";
		}

		my $data = '';
		foreach my $p ( keys %profile ) {
			$data .= $profile{ $p } . ":$p\n";
		}
		return $data;
	} else {
		die "unknown sessions metric: $metric\n";
	}
}

sub manage_sessions {
	my( $type, @path ) = @_;

	# what's the operation?
	if ( $type eq 'readdir' ) {
		# trying to read the root or the session itself?
		if ( defined $path[0] ) {
			return _get_sessions_metrics();
		} else {
			# get the sessions
			my @sessions = map { $_->ID } $api->session_list();
			return \@sessions;
		}
	} elsif ( $type eq 'stat' ) {
		# set some default data
		my ($atime, $ctime, $mtime, $size, $modes);
		$atime = $ctime = $mtime = time();
		my ($dev, $ino, $rdev, $blocks, $gid, $uid, $nlink, $blksize) = ( 0, 0, 0, 1, (split( /\s+/, $) ))[0], $>, 1, 1024 );

		# get the data to start off
		my @sessions = $api->session_list();

		# trying to stat the dir or stuff inside it?
		if ( defined $path[0] ) {
			# does the id exist?
			my @data = grep { $_->ID eq $path[0] } @sessions;
			if ( ! @data ) {
				return;
			}

			# trying to stat the session id or data inside it?
			if ( defined $path[1] ) {
				# is it a valid session metric?
				if ( ! grep { $_ eq $path[1] } @{ _get_sessions_metrics() } or defined $path[2] ) {
					return;
				}

				# a file, munge the data
				$size = length( _get_sessions_metric( $data[0], $path[1] ) );
				$modes = oct( '100644' );
			} else {
				# a directory, munge the data
				$size = 0;
				$modes = oct( '040755' );
				$nlink = 2;
			}
		} else {
			# a directory, munge the data
			$size = 0;
			$modes = oct( '040755' );
			$nlink = 2 + scalar @sessions;
		}

		# finally, return the darn data!
		return( [ $dev, $ino, $modes, $nlink, $uid, $gid, $rdev, $size, $atime, $mtime, $ctime, $blksize, $blocks ] );
	} elsif ( $type eq 'open' ) {
		# get the data to start off
		my @sessions = $api->session_list();

		my @data = grep { $_->ID eq $path[0] } @sessions;
		if ( ! @data or ! defined $path[1] ) {
			return;
		}

		# is it a valid session metric?
		if ( ! grep { $_ eq $path[1] } @{ _get_sessions_metrics() } or defined $path[2] ) {
			return;
		}

		# get the metric!
		my $data = _get_sessions_metric( $data[0], $path[1] );
		return \$data;
	}
}

# we cheat here and not implement a lot of stuff because we know the FUSE api never calls the "extra" APIs
# that ::Async provides. Furthermore, this is a read-only filesystem so we can skip even more APIs :)

# _rmtree

# _scandir

# _move

# _copy

# _load

sub _readdir {
	my( $self, $path ) = @_;

	if ( $path eq File::Spec->rootdir() ) {
		return [ keys %fs ];
	} else {
		# sanitize the path
		my @dirs = File::Spec->splitdir( $path );
		shift( @dirs ); # get rid of the root entry which is always '' for me
		return $fs{ $dirs[0] }->( 'readdir', @dirs[ 1 .. $#dirs ] );
	}
}

# _rmdir

# _mkdir

# _rename

# _mknod

# _unlink

# _chmod

# _truncate

# _chown

# _utime

# helper to process ARRAY fs type
sub _stat_arraymode {
	my $file = shift;

	my $method = $fs{ $file }->[1];
	my $data = $fs{ $file }->[0]->$method();

	# do we need to do more munging?
	if ( defined $fs{ $file }->[2] ) {
		$data = $fs{ $file }->[2]->( $data );
	}

	# all done!
	return $data . "\n";
}

sub _stat {
	my( $self, $path ) = @_;

	# stating the root?
	if ( $path eq File::Spec->rootdir() ) {
		my ($atime, $ctime, $mtime, $size, $modes);
		$atime = $ctime = $mtime = time();
		my ($dev, $ino, $rdev, $blocks, $gid, $uid, $nlink, $blksize) = ( 0, 0, 0, 1, (split( /\s+/, $) ))[0], $>, 1, 1024 );
		$size = 0;
		$modes = oct( '040755' );

		# count subdirs
		$nlink = 2 + grep { ref $fs{ $_ } and ref( $fs{ $_ } ) ne 'ARRAY' } keys %fs;

		return( [ $dev, $ino, $modes, $nlink, $uid, $gid, $rdev, $size, $atime, $mtime, $ctime, $blksize, $blocks ] );
	}

	# sanitize the path
	my @dirs = File::Spec->splitdir( $path );
	shift( @dirs ); # get rid of the root entry which is always '' for me
	if ( exists $fs{ $dirs[0] } ) {
		# arg, stat is a finicky beast!
		my $modes = oct( '100644' );
		my ($dev, $ino, $rdev, $blocks, $gid, $uid, $nlink, $blksize) = ( 0, 0, 0, 1, (split( /\s+/, $) ))[0], $>, 1, 1024 );
		my ($atime, $ctime, $mtime, $size);
		$atime = $ctime = $mtime = time();

		# directory or file?
		if ( ref $fs{ $dirs[0] } ) {
			# array or code?
			if ( ref( $fs{ $dirs[0] } ) eq 'ARRAY' ) {
				# array operation, do what the data tells us to do!
				$size = length( _stat_arraymode( $dirs[0] ) );
			} else {
				# trying to stat the dir or the subpath?
				return $fs{ $dirs[0] }->( 'stat', @dirs[ 1 .. $#dirs ] );
			}
		} else {
			# arg, stat is a finicky beast!
			$size = length( $fs{ $dirs[0] } );
		}

		# finally, return the darn data!
		return( [ $dev, $ino, $modes, $nlink, $uid, $gid, $rdev, $size, $atime, $mtime, $ctime, $blksize, $blocks ] );
	} else {
		return;
	}
}

# _write

sub _open {
	my( $self, $path ) = @_;

	# sanitize the path
	my @dirs = File::Spec->splitdir( $path );
	shift( @dirs ); # get rid of the root entry which is always '' for me
	if ( exists $fs{ $dirs[0] } ) {
		# directory or file?
		if ( ref $fs{ $dirs[0] } ) {
			# array or code?
			if ( ref( $fs{ $dirs[0] } ) eq 'ARRAY' ) {
				# array operation, do what the data tells us to do!
				my $data = _stat_arraymode( $dirs[0] );
				return \$data;
			} else {
				return $fs{ $dirs[0] }->( 'open', @dirs[ 1 .. $#dirs ] );
			}
		} else {
			# return a scalar ref
			return \$fs{ $dirs[0] };
		}
	} else {
		return;
	}
}

1;
__END__