Code

check_smtp: Abort on missing/unexpected greeting
[nagiosplug.git] / tools / p1.pl
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 #
13  use strict;
14  use vars '%Cache';
15  use Symbol qw(delete_package);
18 package 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  
26 use strict;
27 # Perl before 5.6 does not seem to have warnings.pm ???
28 #use warnings;
29 use IO::File;
31 sub 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 }
37 sub PRINT {
38         my $self = shift;
39         my $handle = $self -> {FH};
40         print $handle join("",@_);
41 }
43 sub PRINTF {
44         my $self = shift;
45         my $fmt = shift;
46         my $handle = $self -> {FH};
47         printf $handle ($fmt,@_);
48 }
50 sub CLOSE {
51         my $self = shift;
52         my $handle = $self -> {FH};
53         close $handle;
54 }
56  package Embed::Persistent;
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;
64      # Dress it up as a real package name
65      $string =~ s|/|::|g;
66      return "Embed::" . $string;
67  }
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;
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         }
113         #cache it unless we're cleaning out each time
114         $Cache{$package}{mtime} = $mtime unless $delete;
116      }
117  }
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;
128      tie (*STDOUT, 'OutputTrap', $tmpfname);
130      my @a = split(/ /,$ar);
131      
132      eval {$res = $package->hndlr(@a);};
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  }
151  1;