check_hpjd: linter fixes
[monitoring-plugins.git] / tools / p1.pl
blob9cbe6dc09cb7be9d177b10705b96d4fb925ea17e
1 package Embed::Persistent;
3 # Hacked version of the sample code from the perlembedded doco.
5 # Only major changes are to separate the compiling and caching 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.
13 use strict;
14 use vars '%Cache';
15 use Symbol qw(delete_package);
18 package OutputTrap;
20 # Methods for use by tied STDOUT in embedded PERL module.
22 # Simply redirects STDOUT to a temporary file associated with the
23 # current child/grandchild process.
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;
37 sub PRINT {
38 my $self = shift;
39 my $handle = $self -> {FH};
40 print $handle join("",@_);
43 sub PRINTF {
44 my $self = shift;
45 my $fmt = shift;
46 my $handle = $self -> {FH};
47 printf $handle ($fmt,@_);
50 sub CLOSE {
51 my $self = shift;
52 my $handle = $self -> {FH};
53 close $handle;
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;
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}
77 $Cache{$package}{mtime} <= $mtime)
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";
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__/;
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; }
104 # hide our variables within this block
105 my($filename,$mtime,$package,$sub);
106 eval $eval;
108 if ($@){
109 print STDERR $@."\n";
110 die;
113 #cache it unless we're cleaning out each time
114 $Cache{$package}{mtime} = $mtime unless $delete;
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);
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";
147 untie *STDOUT;
148 return $res;