[code-review] RFC: Persistence glue for Nagios.

--liOOAslEiF7prFVr
Content-Type: text/plain; charset=us-ascii
Content-Disposition: inline

Dear Ladies and Gentlemen,

Your comments about the attached Perl that adds to the persistent 
interpreter example in perlembed are very welcom. This code is loaded 
and parsed by calls to Perl from the host program (checks.c in Nagios).

The bad bits are mine; the good comes from somewhere else.

One obvious shortcoming is debug/verbose info: all I could think of was
adding print STDERR where required and commenting them to remove the
performance hit. There should be a means to select verbose output at 
code load time.

Some design notes, which will be added as POD.

This code attempts to 

. utilise an embedded Perl interpreter to accelerate Perl code that
Nagios runs. Such code includes 'Nagios plugins' and 'Nagios utility
code'.

. to trap any plugin errors at severity warning or greater (to alert the 
developer about unsafe practises and to eliminate 'fails first run but 
Ok thereafter' behaviour) and to log those errors. 

. reduce attempts to run code that contains errors.

. for use with Perl 5.005_04 to 5.8.x.

Notes.

1 Nagios is a 'network/service monitor' (http:/www.Nagios.ORG) that
schedules 'plugins' to check the state of a service or device. (Nagios
accepts the plugins findings and manages the notification, escalation,
logging, timeout, retry as well as doing the scheduling and providing a
web interface).

Plugins are code like

#!/usr/bin/perl -w

# check the service somehow eg simulating a transaction.

print 'Ok. blurfl service responded normally.'
exit $status{OK};

In other words, plugins check the service, print a line of something 
meaningfull for the person responsible, and inform Nag of the result 
with a numeric exit code.


2 Nagios can use Perl for other functions such as 'event handlers' and
notification. Unlike plugins, that code may not explicitly call exit and
it may not print any output.

Thank you,

Yours sincerely.


-- 
------------------------------------------------------------------------
Stanley Hopcroft
------------------------------------------------------------------------

'...No man is an island, entire of itself; every man is a piece of the
continent, a part of the main. If a clod be washed away by the sea,
Europe is the less, as well as if a promontory were, as well as if a
manor of thy friend's or of thine own were. Any man's death diminishes
me, because I am involved in mankind; and therefore never send to know
for whom the bell tolls; it tolls for thee...'

from Meditation 17, J Donne.

--liOOAslEiF7prFVr
Content-Type: application/x-perl
Content-Disposition: attachment; filename="p1_in_mem.pl"

 package Embed::Persistent;

#
# Hacked version of p1.pl distributed with Nagios 1.0
#
# Only major changes are that STDOUT is redirected to a scalar
# by means of a tied filehandle so that it can be returned to Nagios
# without the need for a syscall to read()
#

use strict ;
use vars '%Cache' ;
use Text::ParseWords qw(parse_line) ;

my $debug = 0 ;

BEGIN {
	no strict 'refs' ;
	my $epn_stderr_log = '/usr/local/nagios/var/epn_in_mem.log' ;
	my $indirect_fh = 'ErrorTrap::NEWSTDERR' ;
	open $indirect_fh, ">> $epn_stderr_log"
		or die "Can't open '$epn_stderr_log' for append: $!" ;
}

package OutputTrap;

#
# Methods for use by tied STDOUT in embedded PERL module.
#
# Simply ties STDOUT to a scalar and emulates serial semantics.
#
 
sub TIEHANDLE {
	my ($class) = @_;
        my $me ;
	bless \$me, $class;
}

sub PRINT {
	my $self = shift;
	$$self .= join("",@_);
}

sub PRINTF {
	my $self = shift;
	my $fmt = shift;
	$$self .= sprintf($fmt,@_);
}

sub READLINE {
	my $self = shift;
	# Perl code other than plugins may print nothing; in this case return "(No output!)\n".
	return(defined $$self ? $$self : "(No output!)\n");
}

sub CLOSE {
	my $self = shift;
}

package ErrorTrap;

#
# Methods for use by tied STDERR in embedded PERL module.
#
#
 
sub TIEHANDLE {
	my ($class) = @_;
	open STDERR,     '>>& NEWSTDERR'
		or die "Can't re-open STDERR as file in append mode: $!" ;
        bless { FH => *STDERR{IO} }, $class;
}

sub PRINT {
	my $self = shift;
	my $handle = $self->{FH} ;
	print $handle join("", @_);
}

sub PRINTF {
	my $self = shift;
	my $fmt = shift;
	my $handle = $self->{FH} ;
	printf $handle ($fmt, @_);
}

sub CLOSE {
	my $self = shift;
	close $self->{FH} ;
}

package Embed::Persistent;

sub valid_package_name {
	my($string) = @_;
	$string =~ s/([^A-Za-z0-9\/])/sprintf("_%2x",unpack("C",$1))/eg;
	# second pass only for words starting with a digit
	$string =~ s|/(\d)|sprintf("/_%2x",unpack("C",$1))|eg;
	
	# Dress it up as a real package name
	$string =~ s|/|::|g;
	return "Embed::" . $string;
 }

# Perl 5.005_03 only traps warnings for errors classed by perldiag
# as Fatal (eg 'Global symbol """"%s"""" requires explicit package name').
# Therefore treat all warnings as fatal.

sub throw_exception {
	my $warn = shift ;
	return if $warn =~ /^Subroutine CORE::GLOBAL::exit redefined/ ;
	# print STDERR " ... throw_exception: calling die $warn\n" ;
	die $warn ;
}

sub eval_file {
	my $filename = shift;
	my $delete = shift;

	tie (*STDERR, 'ErrorTrap');
	
	my $pn = substr($filename, rindex($filename,"/")+1);
	my $package = valid_package_name($pn);
	my $mtime = -M $filename ;
	if ( defined $Cache{$package}{mtime} &&
	     $Cache{$package}{mtime} <= $mtime) {
		# we have compiled this subroutine already,
		# it has not been updated on disk, nothing left to do
		# print STDERR "(I) \$mtime: $mtime, \$Cache{$package}{mtime}: '$Cache{$package}{mtime}' - already compiled $package->hndlr.\n";
	}
	else {
		# print STDERR "(I) \$mtime: $mtime, \$Cache{$package}{mtime}: '$Cache{$package}{mtime}' - Compiling or recompiling \$filename: $filename.\n" ;
		local *FH;
		# FIXME - error handling
		open FH, $filename or die "'$filename' $!";
		local($/) = undef;
		my $sub = <FH>;
		close FH;
		# cater for routines that expect to get args without progname
		# and for those using @ARGV
		$sub = qq(\nshift(\@_);\n\@ARGV=\@_;\nlocal \$^W=1;\n$sub) ;

		# cater for scripts that have embedded EOF symbols (__END__)
		$sub =~ s/__END__/\;}\n__END__/;

		# wrap the code into a subroutine inside our unique package
		my $eval = qq{
			package main;
			use subs 'CORE::GLOBAL::exit';
			sub CORE::GLOBAL::exit { die "ExitTrap: \$_[0] ($package)"; }
			package $package; sub hndlr { $sub }
			};
		$Cache{$package}{plugin_error} = 0 ;
		# suppress warning display.
		local $SIG{__WARN__} = \&throw_exception ;
		{
			# hide our variables within this block
			my ($filename, $mtime, $package, $sub);
			eval $eval;
		}
		# $@ is set for any warning and error. This guarantees that the plugin will not be run.
		if ($@) {
			# Log eval'd text of plugin.
			# Correct the line number of the error by removing the lines added (the subroutine prologue) by Embed::eval_file.
			# $@ =~ s/line (\d+)\.\n/'line ' . ($1 - 8) . ".\n"/ge ;
			my $i = 1 ;
			$eval =~ s/^/sprintf('%10d  ', $i++)/meg ;
			print STDERR '[', time(), ']', qq( **ePN '$pn' error '$@' in text "\n$eval"\n) ;
			$Cache{$package}{plugin_error} = $@ ;
        		$Cache{$package}{mtime} = $mtime unless $delete;
			# If the compilation fails, leave nothing behind that may affect subsequent compilations.
			die;
		
		}

        	#cache it unless we're cleaning out each time
        	$Cache{$package}{mtime} = $mtime unless $delete;

	}
}

sub run_package {
	my $filename = shift;
	my $delete = shift;
	my $tmpfname = shift;
	my $ar = shift;
	my $pn = substr($filename, rindex($filename,"/")+1);
	my $package = valid_package_name($pn);
	my $res = 3;

	# debug
	# use Data::Dumper ;
	# print STDERR Data::Dumper->Dump([\%Cache], [qw(%Cache)]) ;
	# debug 

	tie (*STDOUT, 'OutputTrap');

	my @a = &parse_line('\s+', 0, $ar) ;

	if ( $Cache{$package}{plugin_error} ) {
		# print STDOUT '**ePN', " '$pn' ", $Cache{$package}{plugin_error}, "\n" ;
		untie *STDOUT;
		# return unknown
		# print STDERR " ... eval failed in eval_file, run_package returning (3, **ePN '$pn' '$Cache{$package}{plugin_error}'\\n)\n" ;
		return (3, '**ePN' . " '$pn' " . $Cache{$package}{plugin_error} . "\n") ;
	}
     
	local $SIG{__WARN__} = \&throw_exception ;
	eval { $package->hndlr(@a); };

	if ($@) {
		if ($@ =~ /^ExitTrap:  /) {
			# For normal plugin exit the  ExitTrap string is set by the 
			# redefined CORE::GLOBAL::exit sub calling die to return a string =~ /^ExitTrap: -?\d+ $package/
			# However, there is only _one_ exit sub so the last plugin to be compiled sets _its_
			# package name.
			$res = 0;
		} else {
              		# get return code (which may be negative)
			if ($@ =~ /^ExitTrap: (-?\d+)/) {
				$res = $1;
			} else {
				# run time error/abnormal plugin termination; exit was not called in plugin
				# return unknown
				$res = 3;
				
				chomp $@ ;
				# correct line number reported by eval for the prologue added by eval_file
				$@ =~ s/(\d+)\.$/($1 - 8)/e ;
				print STDOUT '**ePN', " '$pn' ",  $@, "\n" ;
				# Don't run it again until the plugin is recompiled (clearing $Cache{$package}{plugin_error})
				# Note that the plugin should be handle any run time errors (such as timeouts)
				# that may occur in service checking.

				# FIXME - doesn't work under both 5.005 and 5.8.0. The cached value of plugin error is reset somehow.
				# $Cache{$package}{plugin_error} = $@ ;
			}
		}
	}
	# !!
	my $plugin_output = <STDOUT> ;
	untie *STDOUT;
	# print STDERR " ... run_package returning ('$res', '$plugin_output')\n" ;
	return ($res, $plugin_output) ;
}

1;

--liOOAslEiF7prFVr--