summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--tools/README8
-rw-r--r--tools/mini_epn.c153
-rw-r--r--tools/p1.pl151
3 files changed, 312 insertions, 0 deletions
diff --git a/tools/README b/tools/README
new file mode 100644
index 0000000..2279afc
--- /dev/null
+++ b/tools/README
@@ -0,0 +1,8 @@
1$Id$
2The tools subdirectory contains anciliary files that can be used to configure
3or test the plugins.
4
51. setup - used to get the configuration initialized after a CVS download
62. tango -
73. mini_epn/p1.pl - used to test perl plugins for functionality under embedded
8 perl
diff --git a/tools/mini_epn.c b/tools/mini_epn.c
new file mode 100644
index 0000000..cd67538
--- /dev/null
+++ b/tools/mini_epn.c
@@ -0,0 +1,153 @@
1/*
2 *
3 * MINI_EPN.C - Mini Embedded Perl Nagios
4 * Contributed by Stanley Hopcroft
5 * Modified by Douglas Warner
6 * Last Modified: 05/02/2002
7 *
8 * $Id$
9 *
10 * This is a sample mini embedded Perl interpreter (hacked out checks.c and
11 * perlembed) for use in testing Perl plugins.
12 *
13 * It can be compiled with the following command (see 'man perlembed' for
14 * more info):
15 *
16 * gcc -omini_epn mini_epn.c `perl -MExtUtils::Embed -e ccopts -e ldopts`
17 *
18 * NOTES: The compiled binary needs to be in the same directory as the p1.pl
19 * file supplied with Nagios (or vice versa)
20 * When using mini_epn to test perl scripts, you must place positional
21 * arguments immediately after the file/script and before any arguments
22 * processed by Getopt
23 *
24 */
25
26
27#include <EXTERN.h>
28#include <perl.h>
29#include <fcntl.h>
30#include <string.h>
31
32/* include PERL xs_init code for module and C library support */
33
34#if defined(__cplusplus)
35#define is_cplusplus
36#endif
37
38#ifdef is_cplusplus
39extern "C" {
40#endif
41
42#define NO_XSLOCKS
43#include <XSUB.h>
44
45#ifdef is_cplusplus
46}
47# ifndef EXTERN_C
48# define EXTERN_C extern "C"
49# endif
50#else
51# ifndef EXTERN_C
52# define EXTERN_C extern
53# endif
54#endif
55
56
57EXTERN_C void xs_init _((void));
58
59EXTERN_C void boot_DynaLoader _((CV* cv));
60
61EXTERN_C void xs_init(void)
62{
63 char *file = __FILE__;
64 dXSUB_SYS;
65
66 /* DynaLoader is a special case */
67 newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
68}
69
70
71static PerlInterpreter *perl = NULL;
72
73
74int main(int argc, char **argv, char **env)
75{
76 char *embedding[] = { "", "p1.pl" };
77 char plugin_output[1024];
78 char buffer[512];
79 char tmpfname[32];
80 char fname[32];
81 char *args[] = {"","0", "", "", NULL };
82 FILE *fp;
83
84 const int command_line_size = 160;
85 char command_line[command_line_size];
86 char *ap ;
87 int exitstatus;
88 int pclose_result;
89#ifdef THREADEDPERL
90 dTHX;
91#endif
92 dSP;
93
94 if ((perl=perl_alloc())==NULL) {
95 snprintf(buffer,sizeof(buffer),"Error: Could not allocate memory for embedded Perl interpreter!\n");
96 buffer[sizeof(buffer)-1]='\x0';
97 printf("%s\n", buffer);
98 exit(1);
99 }
100 perl_construct(perl);
101 exitstatus=perl_parse(perl,xs_init,2,embedding,NULL);
102 if (!exitstatus) {
103
104 exitstatus=perl_run(perl);
105
106 while(printf("Enter file name: ") && fgets(command_line, command_line_size, stdin)) {
107
108 /* call the subroutine, passing it the filename as an argument */
109
110 command_line[strlen(command_line) -1] = '\0';
111
112 strncpy(fname,command_line,strcspn(command_line," "));
113 fname[strcspn(command_line," ")] = '\x0';
114 args[0] = fname ;
115 args[3] = command_line + strlen(fname) + 1 ;
116
117 /* generate a temporary filename to which stdout can be redirected. */
118 sprintf(tmpfname,"/tmp/embedded%d",getpid());
119 args[2] = tmpfname;
120
121 /* call our perl interpreter to compile and optionally cache the command */
122 perl_call_argv("Embed::Persistent::eval_file", G_DISCARD | G_EVAL, args);
123
124 perl_call_argv("Embed::Persistent::run_package", G_DISCARD | G_EVAL, args);
125
126 /* check return status */
127 if(SvTRUE(ERRSV)){
128 pclose_result=-2;
129 printf("embedded perl ran %s with error %s\n",fname,SvPV(ERRSV,PL_na));
130 }
131
132 /* read back stdout from script */
133 fp=fopen(tmpfname, "r");
134
135 /* default return string in case nothing was returned */
136 strcpy(plugin_output,"(No output!)");
137
138 fgets(plugin_output,sizeof(plugin_output)-1,fp);
139 plugin_output[sizeof(plugin_output)-1]='\x0';
140 fclose(fp);
141 unlink(tmpfname);
142 printf("embedded perl plugin output was %d,%s\n",pclose_result, plugin_output);
143
144 }
145
146 }
147
148
149 PL_perl_destruct_level = 0;
150 perl_destruct(perl);
151 perl_free(perl);
152 exit(exitstatus);
153}
diff --git a/tools/p1.pl b/tools/p1.pl
new file mode 100644
index 0000000..2788dbf
--- /dev/null
+++ b/tools/p1.pl
@@ -0,0 +1,151 @@
1 package Embed::Persistent;
2#
3# Hacked version of the sample code from the perlembedded doco.
4#
5# Only major changes are to separate the compiling and cacheing from
6# the execution so that the cache can be kept in "non-volatile" parent
7# process while the execution is done from "volatile" child processes
8# and that STDOUT is redirected to a file by means of a tied filehandle
9# so that it can be returned to NetSaint in the same way as for
10# commands executed via the normal popen method.
11#
12
13 use strict;
14 use vars '%Cache';
15 use Symbol qw(delete_package);
16
17
18package OutputTrap;
19#
20# Methods for use by tied STDOUT in embedded PERL module.
21#
22# Simply redirects STDOUT to a temporary file associated with the
23# current child/grandchild process.
24#
25
26use strict;
27# Perl before 5.6 does not seem to have warnings.pm ???
28#use warnings;
29use IO::File;
30
31sub TIEHANDLE {
32 my ($class, $fn) = @_;
33 my $handle = new IO::File "> $fn" or die "Cannot open embedded work filei $!\n";
34 bless { FH => $handle, Value => 0}, $class;
35}
36
37sub PRINT {
38 my $self = shift;
39 my $handle = $self -> {FH};
40 print $handle join("",@_);
41}
42
43sub PRINTF {
44 my $self = shift;
45 my $fmt = shift;
46 my $handle = $self -> {FH};
47 printf $handle ($fmt,@_);
48}
49
50sub CLOSE {
51 my $self = shift;
52 my $handle = $self -> {FH};
53 close $handle;
54}
55
56 package Embed::Persistent;
57
58 sub valid_package_name {
59 my($string) = @_;
60 $string =~ s/([^A-Za-z0-9\/])/sprintf("_%2x",unpack("C",$1))/eg;
61 # second pass only for words starting with a digit
62 $string =~ s|/(\d)|sprintf("/_%2x",unpack("C",$1))|eg;
63
64 # Dress it up as a real package name
65 $string =~ s|/|::|g;
66 return "Embed::" . $string;
67 }
68
69 sub eval_file {
70 my $filename = shift;
71 my $delete = shift;
72 my $pn = substr($filename, rindex($filename,"/")+1);
73 my $package = valid_package_name($pn);
74 my $mtime = -M $filename;
75 if(defined $Cache{$package}{mtime}
76 &&
77 $Cache{$package}{mtime} <= $mtime)
78 {
79 # we have compiled this subroutine already,
80 # it has not been updated on disk, nothing left to do
81 #print STDERR "already compiled $package->hndlr\n";
82 }
83 else {
84 local *FH;
85 open FH, $filename or die "open '$filename' $!";
86 local($/) = undef;
87 my $sub = <FH>;
88 close FH;
89 # cater for routines that expect to get args without prgname
90 # and for those using @ARGV
91 $sub = "shift(\@_);\n\@ARGV=\@_;\n" . $sub;
92
93 # cater for scripts that have embedded EOF symbols (__END__)
94 $sub =~ s/__END__/\;}\n__END__/;
95
96 #wrap the code into a subroutine inside our unique package
97 my $eval = qq{
98 package main;
99 use subs 'CORE::GLOBAL::exit';
100 sub CORE::GLOBAL::exit { die "ExitTrap: \$_[0] ($package)"; }
101 package $package; sub hndlr { $sub; }
102 };
103 {
104 # hide our variables within this block
105 my($filename,$mtime,$package,$sub);
106 eval $eval;
107 }
108 if ($@){
109 print STDERR $@."\n";
110 die;
111 }
112
113 #cache it unless we're cleaning out each time
114 $Cache{$package}{mtime} = $mtime unless $delete;
115
116 }
117 }
118
119 sub run_package {
120 my $filename = shift;
121 my $delete = shift;
122 my $tmpfname = shift;
123 my $ar = shift;
124 my $pn = substr($filename, rindex($filename,"/")+1);
125 my $package = valid_package_name($pn);
126 my $res = 0;
127
128 tie (*STDOUT, 'OutputTrap', $tmpfname);
129
130 my @a = split(/ /,$ar);
131
132 eval {$res = $package->hndlr(@a);};
133
134 if ($@){
135 if ($@ =~ /^ExitTrap: /) {
136 $res = 0;
137 } else {
138 # get return code (which may be negative)
139 if ($@ =~ /^ExitTrap: (-?\d+)/) {
140 $res = $1;
141 } else {
142 $res = 2;
143 print STDERR "<".$@.">\n";
144 }
145 }
146 }
147 untie *STDOUT;
148 return $res;
149 }
150
151 1;