1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
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;
|