[Nagiosplug-checkins] CVS: nagiosplug/tools README,NONE,1.1 mini_epn.c,NONE,1.1 p1.pl,NONE,1.1

[Subhendu Ghosh]

Update of /cvsroot/nagiosplug/nagiosplug/tools
In directory usw-pr-cvs1:/tmp/cvs-serv7474

Added Files:
	README mini_epn.c p1.pl 
Log Message:
updated mini_epn and p1.pl added to plugins distribution

--- NEW FILE ---
$Id: README,v 1.1 2002/05/02 16:22:13 sghosh Exp $
The tools subdirectory contains anciliary files that can be used to configure
or test the plugins.

1. setup - used to get the configuration initialized after a CVS download
2. tango -
3. mini_epn/p1.pl - used to test perl plugins for functionality under embedded
   perl

--- NEW FILE ---
/* 
 *
 *  MINI_EPN.C - Mini Embedded Perl Nagios
 *  Contributed by Stanley Hopcroft
 *  Modified by Douglas Warner
 *  Last Modified: 05/02/2002
 *
 *  $Id: mini_epn.c,v 1.1 2002/05/02 16:22:13 sghosh Exp $
 *
 *  This is a sample mini embedded Perl interpreter (hacked out checks.c and 
 *  perlembed) for use in testing Perl plugins. 
 *
 *  It can be compiled with the following command (see 'man perlembed' for 
 *  more info):
 *
 *  gcc -omini_epn mini_epn.c `perl -MExtUtils::Embed -e ccopts -e ldopts`
 *
 *  NOTES:  The compiled binary needs to be in the same directory as the p1.pl
 *  file supplied with Nagios (or vice versa)
 *  When using mini_epn to test perl scripts, you must place positional
 *  arguments immediately after the file/script and before any arguments
 *  processed by Getopt
 *
 */


#include <EXTERN.h>
#include <perl.h>
#include <fcntl.h>
#include <string.h>

/* include PERL xs_init code for module and C library support */

#if defined(__cplusplus)
#define is_cplusplus
#endif

#ifdef is_cplusplus
extern "C" {
#endif

#define NO_XSLOCKS
#include <XSUB.h>

#ifdef is_cplusplus
}
#  ifndef EXTERN_C
#    define EXTERN_C extern "C"
#  endif
#else
#  ifndef EXTERN_C
#    define EXTERN_C extern
#  endif
#endif
 

EXTERN_C void xs_init _((void));

EXTERN_C void boot_DynaLoader _((CV* cv));

EXTERN_C void xs_init(void)
{
	char *file = __FILE__;
	dXSUB_SYS;

	/* DynaLoader is a special case */
	newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
}


static PerlInterpreter *perl = NULL;


int main(int argc, char **argv, char **env)
{
	char *embedding[] = { "", "p1.pl" };
	char plugin_output[1024];
	char buffer[512];
	char tmpfname[32];
	char fname[32];
	char *args[] = {"","0", "", "", NULL };
	FILE *fp;

	const int command_line_size = 160;
	char command_line[command_line_size];
	char *ap ;
	int exitstatus;
	int pclose_result;
#ifdef THREADEDPERL
	dTHX;
#endif
	dSP; 

	if ((perl=perl_alloc())==NULL) {
		snprintf(buffer,sizeof(buffer),"Error: Could not allocate memory for embedded Perl interpreter!\n");
		buffer[sizeof(buffer)-1]='\x0';
		printf("%s\n", buffer);
		exit(1);
	}
	perl_construct(perl);
	exitstatus=perl_parse(perl,xs_init,2,embedding,NULL);
	if (!exitstatus) {

		exitstatus=perl_run(perl);

		while(printf("Enter file name: ") && fgets(command_line, command_line_size, stdin)) {

			/* call the subroutine, passing it the filename as an argument */

			command_line[strlen(command_line) -1] = '\0';

			strncpy(fname,command_line,strcspn(command_line," "));
			fname[strcspn(command_line," ")] = '\x0';
			args[0] = fname ;
			args[3] = command_line + strlen(fname) + 1 ;

			/* generate a temporary filename to which stdout can be redirected. */
			sprintf(tmpfname,"/tmp/embedded%d",getpid());
			args[2] = tmpfname;

			/* call our perl interpreter to compile and optionally cache the command */
			perl_call_argv("Embed::Persistent::eval_file", G_DISCARD | G_EVAL, args);

			perl_call_argv("Embed::Persistent::run_package", G_DISCARD | G_EVAL, args);
			
			/* check return status  */
			if(SvTRUE(ERRSV)){
				pclose_result=-2;
				printf("embedded perl ran %s with error %s\n",fname,SvPV(ERRSV,PL_na));
			}
			
			/* read back stdout from script */
			fp=fopen(tmpfname, "r");
			
			/* default return string in case nothing was returned */
			strcpy(plugin_output,"(No output!)");
			
			fgets(plugin_output,sizeof(plugin_output)-1,fp);
			plugin_output[sizeof(plugin_output)-1]='\x0';
			fclose(fp);
			unlink(tmpfname);    
			printf("embedded perl plugin output was %d,%s\n",pclose_result, plugin_output);

		}

	}

	
	PL_perl_destruct_level = 0;
	perl_destruct(perl);
	perl_free(perl);
	exit(exitstatus);
}

--- NEW FILE ---
 package Embed::Persistent;
#
# Hacked version of the sample code from the perlembedded doco.
#
# Only major changes are to separate the compiling and cacheing from 
# the execution so that the cache can be kept in "non-volatile" parent
# process while the execution is done from "volatile" child processes
# and that STDOUT is redirected to a file by means of a tied filehandle
# so that it can be returned to NetSaint in the same way as for
# commands executed via the normal popen method.
#

 use strict;
 use vars '%Cache';
 use Symbol qw(delete_package);


package OutputTrap;
#
# Methods for use by tied STDOUT in embedded PERL module.
#
# Simply redirects STDOUT to a temporary file associated with the
# current child/grandchild process.
#
 
use strict;
# Perl before 5.6 does not seem to have warnings.pm ???
#use warnings;
use IO::File;

sub TIEHANDLE {
	my ($class, $fn) = @_;
	my $handle = new IO::File "> $fn" or die "Cannot open embedded work filei $!\n";
	bless { FH => $handle, Value => 0}, $class;
}

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

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

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

 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;
 }

 sub eval_file {
     my $filename = shift;
     my $delete = shift;
     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 "already compiled $package->hndlr\n";
     }
     else {
        local *FH;
        open FH, $filename or die "open '$filename' $!";
        local($/) = undef;
        my $sub = <FH>;
        close FH;
	# cater for routines that expect to get args without prgname
	# and for those using @ARGV
	$sub = "shift(\@_);\n\@ARGV=\@_;\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; }
                };
        {
            # hide our variables within this block
            my($filename,$mtime,$package,$sub);
            eval $eval;
        }
	if ($@){
		print STDERR $@."\n";
		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 = 0;

     tie (*STDOUT, 'OutputTrap', $tmpfname);

     my @a = split(/ /,$ar);
     
     eval {$res = $package->hndlr(@a);};

     if ($@){
		if ($@ =~ /^ExitTrap:  /) {
			$res = 0;
		} else {
              # get return code (which may be negative)
			if ($@ =~ /^ExitTrap: (-?\d+)/) {
				$res = $1;
			} else {
				$res = 2;
				print STDERR "<".$@.">\n";
			}
		}
     }
     untie *STDOUT;
     return $res;
 }

 1;