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
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
|
# test
package Eval::Context ;
use strict ;
use warnings ;
use Data::TreeDumper ;
use Test::More ;
use Data::Dumper ;
#----------------------------------------------------------
package main ;
use strict ;
use warnings ;
use Data::TreeDumper ;
use Test::Exception ;
use Test::Warn;
#~ use Test::NoWarnings qw(had_no_warnings);
use Test::More 'no_plan';
use Test::Block qw($Plan);
use Eval::Context ;
$|++;
{
local $Plan = {'Default SAFE in constructor' => 1} ;
my $context = new Eval::Context(SAFE => {}) ;
throws_ok
{
$context->eval( CODE => 'eval "1 + 1" ;') ;
} qr/'eval "string"' trapped by operation mask/, 'unsafe code, using default safe' ;
}
{
local $Plan = {'Default SAFE in eval' => 1} ;
my $context = new Eval::Context() ;
throws_ok
{
$context->eval( CODE => 'eval "1 + 1" ;', SAFE => {}) ;
} qr/'eval "string"' trapped by operation mask/, 'unsafe code' ;
}
{
local $Plan = {'Invalid SAFE definition' => 1} ;
throws_ok
{
my $context = new Eval::Context(SAFE => 1) ;
$context->eval(CODE => '') ;
} qr/Invalid Option 'SAFE' definition/, 'Invalid SAFE definition' ;
}
{
local $Plan = {'SAFE options' => 5} ;
my $context = new Eval::Context() ;
throws_ok
{
$context->eval
(
SAFE =>{PRE_CODE => "use Xyzzy::This_Module_SHOULD_Not_Exist;\n1;\n"},
CODE => '',
) ;
} qr~Can't locate Xyzzy/This_Module_SHOULD_Not_Exist.pm~, 'PRE_SAFE_CODE error';
lives_ok
{
$context->eval
(
SAFE =>{PRE_CODE => "use Data::TreeDumper;\n\n"},
CODE => 'my $x = DumpTree({A => 1}) ;',
) ;
} 'PRE_SAFE_CODE' ;
throws_ok
{
my $output = $context->eval
(
CODE => '$x = 1 ;',
SAFE => {}
) ;
} qr/Global symbol "\$x" requires explicit package/, 'use strict by default' ;
lives_ok
{
$context->eval
(
CODE => '$x = 1 ;',
SAFE =>{ USE_STRICT => 0 },
) ;
} 'USE_STRICT' ;
lives_ok
{
my $compartment = new Safe('ABC') ;
$compartment->permit('entereval') ;
$context->eval(PACKAGE => 'ABC', CODE => 'eval "1 + 1" ;', SAFE => {COMPARTMENT => $compartment}) ;
} 'COMPARTMENT' ;
}
{
local $Plan = {'SAFE PRE_CODE in same package' => 2} ;
my $context = new Eval::Context(PACKAGE => 'TEST', SAFE => {}) ;
my $output = $context->eval(CODE => 'my $x = 1; __PACKAGE__ ;') ;
is($output, 'main', 'first eval package') ;
$output = $context->eval
(
SAFE =>{PRE_CODE => "use Data::TreeDumper;\n\n"},
CODE => 'DumpTree({A => 1}) ;',
) ;
is($output,<<EOT,'Test STDOUT') or diag DumpTree $context ;
`- A = 1 [S1]
EOT
}
{
# test if access to caller side functions is possible in safe
local $Plan = {'multiple evaluations in the same SAFE' => 2} ;
my $get_117 = sub{117} ;
my $result = new Eval::Context(PACKAGE => 'TEST')
->eval(SAFE => {}, CODE => 'get_117() ;', INSTALL_SUBS => {get_117 => $get_117}) ;
is($result, 117, 'sub pushed into safe context') ;
my $get_118 = sub{118} ;
$result = new Eval::Context(PACKAGE => 'TEST')
->eval(SAFE => {}, CODE => 'get_118() ;', INSTALL_SUBS => {get_118 => $get_118}) ;
is($result, 118, 'new sub pushed into same safe context') ;
}
{
#~ # test if access to persistent saving functions on eval side
local $Plan = {'SAFE access to persistent functions' => 1} ;
my $context = new Eval::Context
(
EVAL_SIDE_PERSISTENT_VARIABLES =>
{
CATEGORY => 'TEST',
SAVE => { NAME => 'SavePersistent', VALIDATOR => sub{}, },
GET => { NAME => 'GetPersistent', VALIDATOR => sub {}},
},
SAFE => {},
) ;
$context->eval(CODE => 'my $variable = 24 ; SavePersistent(\'$variable\', $variable) ;') ;
my $output = $context->eval(CODE => 'my $variable = GetPersistent(\'$variable\') ;') ;
is($output, 24, 'access to persistent functionality') or diag DumpTree $context ;
}
{
local $Plan = {'SAFE caller context' => 6} ;
my $context = new Eval::Context
(
SAFE => {},
) ;
lives_ok
{
$context->eval(CODE => '$variable', INSTALL_VARIABLES => [ ['$variable', 42] ]) ;
} 'void context' ;
lives_ok
{
my $output = $context->eval(CODE => '$variable', INSTALL_VARIABLES => [ ['$variable', 42] ]) ;
is($output, 42, 'right value in scalar context') ;
} 'scalar context' ;
lives_ok
{
my @output = $context->eval(CODE => '$variable', INSTALL_VARIABLES => [ ['$variable', 42] ]) ;
is_deeply(\@output, [42], 'right value in array context') ;
} 'array context' ;
throws_ok
{
$context->eval(CODE => 'die "died withing safe"',) ;
} qr/died withing safe/, 'die within a safe' ;
}
{
local $Plan = {'SAFE and croak' => 3} ;
my $context = new Eval::Context
(
SAFE =>
{
PRE_CODE => 'use Carp ;',
},
) ;
my $output = $context->eval(CODE => '$variable', INSTALL_VARIABLES => [ ['$variable', 42] ]) ;
is($output, 42, 'right value in scalar context') ;
throws_ok
{
# Eval context returns the code as an error, make sure the error is not part of the code
$context->eval(CODE => "my \$error = 'this_i' . 's_the_croak_message';\ncroak(\$error) ;",) ;
} qr/this_is_the_croak_message/, 'croak within a safe' ;
#~ diag DumpTree $context ;
#~ diag $@ ;
throws_ok
{
# Eval context returns the code as an error, make sure the error is not part of the code
$context->eval(CODE => 'my $error = "this_i" . "s_the_die_message"; die $error ;',) ;
} qr/this_is_the_die_message/, 'die within a safe while using Carp' ;
#~ diag $@ ;
}
|
