updated mini_epn and p1.pl added to plugins distribution

git-svn-id: https://nagiosplug.svn.sourceforge.net/svnroot/nagiosplug/nagiosplug/trunk@20 f882894a-f735-0410-b71e-b25c423dba1c

diff --git a/tools/README b/tools/README
new file mode 100644 (file)
index 0000000..2279afc
--- /dev/null
+++ b/tools/README
@@ -0,0 +1,8 @@
+$Id$
+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

diff --git a/tools/mini_epn.c b/tools/mini_epn.c
new file mode 100644 (file)
index 0000000..cd67538
--- /dev/null
+++ b/tools/mini_epn.c
@@ -0,0 +1,153 @@
+/* 
+ *
+ *  MINI_EPN.C - Mini Embedded Perl Nagios
+ *  Contributed by Stanley Hopcroft
+ *  Modified by Douglas Warner
+ *  Last Modified: 05/02/2002
+ *
+ *  $Id$
+ *
+ *  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);
+}

diff --git a/tools/p1.pl b/tools/p1.pl
new file mode 100644 (file)
index 0000000..2788dbf
--- /dev/null
+++ b/tools/p1.pl
@@ -0,0 +1,151 @@
+ 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("",@_);
+}
+
+sub PRINTF {
+       my $self = shift;
+       my $fmt = shift;
+       my $handle = $self -> {FH};
+       printf $handle ($fmt,@_);
+}
+
+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;