line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
|
2
|
|
|
|
|
|
|
# ----------------------------------------------------------------------------- |
3
|
|
|
|
|
|
|
# |
4
|
|
|
|
|
|
|
# Nes by Skriptke |
5
|
|
|
|
|
|
|
# Copyright 2009 - 2010 Enrique Castañón |
6
|
|
|
|
|
|
|
# Licensed under the GNU GPL. |
7
|
|
|
|
|
|
|
# |
8
|
|
|
|
|
|
|
# CPAN: |
9
|
|
|
|
|
|
|
# http://search.cpan.org/dist/Nes/ |
10
|
|
|
|
|
|
|
# |
11
|
|
|
|
|
|
|
# Sample: |
12
|
|
|
|
|
|
|
# http://nes.sourceforge.net/ |
13
|
|
|
|
|
|
|
# |
14
|
|
|
|
|
|
|
# Repository: |
15
|
|
|
|
|
|
|
# http://github.com/Skriptke/nes |
16
|
|
|
|
|
|
|
# |
17
|
|
|
|
|
|
|
# Version 1.03 |
18
|
|
|
|
|
|
|
# |
19
|
|
|
|
|
|
|
# Nes.pm |
20
|
|
|
|
|
|
|
# |
21
|
|
|
|
|
|
|
# ----------------------------------------------------------------------------- |
22
|
|
|
|
|
|
|
|
23
|
3
|
|
|
3
|
|
79006
|
use strict; |
|
3
|
|
|
|
|
8
|
|
|
3
|
|
|
|
|
137
|
|
24
|
|
|
|
|
|
|
#use warnings; |
25
|
|
|
|
|
|
|
|
26
|
|
|
|
|
|
|
# cgi environment no defined in command line |
27
|
3
|
|
|
3
|
|
60
|
no warnings 'uninitialized'; |
|
3
|
|
|
|
|
4
|
|
|
3
|
|
|
|
|
574
|
|
28
|
|
|
|
|
|
|
|
29
|
|
|
|
|
|
|
our $VERSION = '1.03'; |
30
|
|
|
|
|
|
|
our $CRLF = "\015\012"; |
31
|
|
|
|
|
|
|
our $MAX_INTERACTIONS = 500; |
32
|
|
|
|
|
|
|
our $MOD_PERL = $ENV{'MOD_PERL'} || 0; |
33
|
|
|
|
|
|
|
our $MOD_PERL1 = $MOD_PERL =~ /mod_perl\/1/ || 0; |
34
|
|
|
|
|
|
|
our $MOD_PERL2 = $MOD_PERL =~ /mod_perl\/2/ || 0; |
35
|
|
|
|
|
|
|
|
36
|
3
|
|
|
3
|
|
5521
|
use Nes::Setting; |
|
3
|
|
|
|
|
10
|
|
|
3
|
|
|
|
|
95
|
|
37
|
3
|
|
|
3
|
|
7803
|
use Nes::Singleton; |
|
3
|
|
|
|
|
10
|
|
|
3
|
|
|
|
|
1302
|
|
38
|
|
|
|
|
|
|
|
39
|
|
|
|
|
|
|
{ |
40
|
|
|
|
|
|
|
|
41
|
|
|
|
|
|
|
package Nes; |
42
|
|
|
|
|
|
|
|
43
|
|
|
|
|
|
|
my %instance; |
44
|
|
|
|
|
|
|
|
45
|
|
|
|
|
|
|
sub new { |
46
|
10
|
|
|
10
|
0
|
20
|
my $class = shift; |
47
|
10
|
|
|
|
|
22
|
my $self = bless {}, $class; |
48
|
10
|
|
|
|
|
37
|
$self->{'previous'} = $class->get_obj(); |
49
|
10
|
|
|
|
|
19
|
$instance{$class} = $self; |
50
|
|
|
|
|
|
|
|
51
|
|
|
|
|
|
|
# utl::cleanup(\%instance) if $ENV{'MOD_PERL'}; |
52
|
|
|
|
|
|
|
|
53
|
10
|
|
|
|
|
32
|
$self->{'top_container'} = nes_top_container->get_obj(); |
54
|
10
|
|
|
|
|
37
|
$self->{'CFG'} = Nes::Setting->get_obj(); |
55
|
10
|
|
|
|
|
37
|
$self->{'cookies'} = nes_cookie->get_obj(); |
56
|
10
|
|
|
|
|
34
|
$self->{'session'} = nes_session->get_obj(); |
57
|
10
|
|
|
|
|
33
|
$self->{'query'} = nes_query->get_obj(); |
58
|
10
|
|
|
|
|
30
|
$self->{'container'} = nes_container->get_obj(); |
59
|
10
|
|
|
|
|
39
|
$self->{'register'} = nes_register->get_obj(); |
60
|
10
|
|
|
|
|
17
|
$self->{'nes'} = $self; |
61
|
10
|
|
|
|
|
16
|
$self->{'MAX_INTERACTIONS'} = $MAX_INTERACTIONS; |
62
|
|
|
|
|
|
|
|
63
|
10
|
|
|
|
|
16
|
return $self; |
64
|
|
|
|
|
|
|
} |
65
|
|
|
|
|
|
|
|
66
|
|
|
|
|
|
|
sub get_obj { |
67
|
74
|
|
|
74
|
0
|
90
|
my $self = shift; |
68
|
74
|
|
|
|
|
75
|
my $class = ref($self); |
69
|
|
|
|
|
|
|
|
70
|
74
|
50
|
|
|
|
146
|
$self = $instance{$self} if !$class; |
71
|
|
|
|
|
|
|
|
72
|
74
|
|
|
|
|
180
|
return $self; |
73
|
|
|
|
|
|
|
} |
74
|
|
|
|
|
|
|
|
75
|
|
|
|
|
|
|
sub forget { |
76
|
0
|
|
|
0
|
0
|
0
|
my $self = shift; |
77
|
0
|
|
|
|
|
0
|
my $class = ref($self); |
78
|
|
|
|
|
|
|
|
79
|
0
|
|
|
|
|
0
|
$instance{$class} = $self->{'previous'}; |
80
|
|
|
|
|
|
|
|
81
|
0
|
|
|
|
|
0
|
return $instance{$class}; |
82
|
|
|
|
|
|
|
} |
83
|
|
|
|
|
|
|
|
84
|
|
|
|
|
|
|
sub get_key { |
85
|
0
|
|
|
0
|
0
|
0
|
my $self = shift; |
86
|
0
|
|
|
|
|
0
|
my ($max) = @_; |
87
|
|
|
|
|
|
|
|
88
|
0
|
|
|
|
|
0
|
my @kletters = @{ $self->{'CFG'}{'kletters'} }; |
|
0
|
|
|
|
|
0
|
|
89
|
0
|
|
|
|
|
0
|
my @kletnum = @{ $self->{'CFG'}{'kletnum'} }; |
|
0
|
|
|
|
|
0
|
|
90
|
|
|
|
|
|
|
|
91
|
|
|
|
|
|
|
# siempre comienza por letra por si se usa como nombre de variable o campo |
92
|
0
|
|
|
|
|
0
|
my $key = $kletters[ int( rand( $#kletters + 1 ) ) ]; |
93
|
0
|
|
|
|
|
0
|
for ( 1 .. ( $max - 1 ) ) { |
94
|
0
|
|
|
|
|
0
|
$key .= $kletnum[ int( rand( $#kletnum + 1 ) ) ]; |
95
|
|
|
|
|
|
|
} |
96
|
|
|
|
|
|
|
|
97
|
0
|
|
|
|
|
0
|
return $key; |
98
|
|
|
|
|
|
|
} |
99
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
} |
101
|
|
|
|
|
|
|
|
102
|
|
|
|
|
|
|
|
103
|
|
|
|
|
|
|
{ |
104
|
|
|
|
|
|
|
|
105
|
|
|
|
|
|
|
package nes_tmp; |
106
|
3
|
|
|
3
|
|
29
|
use vars qw(@ISA); |
|
3
|
|
|
|
|
4
|
|
|
3
|
|
|
|
|
2890
|
|
107
|
|
|
|
|
|
|
@ISA = qw( Nes ); |
108
|
|
|
|
|
|
|
|
109
|
|
|
|
|
|
|
sub new { |
110
|
0
|
|
|
0
|
|
0
|
my $class = shift; |
111
|
0
|
|
|
|
|
0
|
my ($suffix,$name) = @_; |
112
|
0
|
|
|
|
|
0
|
my $self = $class->SUPER::new(); |
113
|
|
|
|
|
|
|
|
114
|
0
|
|
|
|
|
0
|
$self->{'suffix'} = $suffix; |
115
|
0
|
|
|
|
|
0
|
$self->{'tmp_suffix'} = $self->{'CFG'}{'tmp_suffix'}; |
116
|
0
|
|
|
|
|
0
|
$self->{'name'} = $self->get_name($name); |
117
|
0
|
|
|
|
|
0
|
$self->{'tmp_dir'} = $self->{'CFG'}{'tmp_dir'}; |
118
|
0
|
|
|
|
|
0
|
$self->{'file'} = $self->{'tmp_dir'}.'/'.$self->{'name'}; |
119
|
0
|
|
|
|
|
0
|
$self->{'expired'} = utl::expires_time($self->{'CFG'}{'tmp_clear'}); |
120
|
|
|
|
|
|
|
|
121
|
0
|
0
|
|
|
|
0
|
$self->clear_expired if $self->{'CFG'}{'tmp_clear'}; |
122
|
|
|
|
|
|
|
|
123
|
0
|
|
|
|
|
0
|
return $self; |
124
|
|
|
|
|
|
|
} |
125
|
|
|
|
|
|
|
|
126
|
|
|
|
|
|
|
sub clear_expired { |
127
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
128
|
|
|
|
|
|
|
|
129
|
|
|
|
|
|
|
# borra de vez en cuando los temporales ( 1 de cada rand x veces ) |
130
|
|
|
|
|
|
|
# si hay muchos puede ser lento, sólo será lento una de cada rand x veces |
131
|
0
|
0
|
|
|
|
0
|
return if 1 < (rand 100); |
132
|
|
|
|
|
|
|
|
133
|
|
|
|
|
|
|
# -------------------------------------------------------------------------- |
134
|
|
|
|
|
|
|
# si por error en el archivo de configuración se hace: tmp_dir = '/' |
135
|
|
|
|
|
|
|
# podía ser desastroso... de ahí tantas comprobaciones antes de borrar |
136
|
|
|
|
|
|
|
# Indicar 0 en tmp_clear del archivo de configuración para no borrar nunca. |
137
|
|
|
|
|
|
|
# -------------------------------------------------------------------------- |
138
|
|
|
|
|
|
|
|
139
|
|
|
|
|
|
|
# nos aseguramos que tmp_dir tiene valor |
140
|
|
|
|
|
|
|
# la ruta más corta es /tmp |
141
|
0
|
0
|
|
|
|
0
|
return if length $self->{'tmp_dir'} < 4; |
142
|
|
|
|
|
|
|
|
143
|
|
|
|
|
|
|
# nos aseguramos que tmp_suffix tiene valor |
144
|
0
|
0
|
|
|
|
0
|
return if length $self->{'tmp_suffix'} < 4; |
145
|
|
|
|
|
|
|
|
146
|
0
|
|
|
|
|
0
|
opendir(DIR,$self->{'tmp_dir'}); |
147
|
0
|
|
|
|
|
0
|
foreach my $file (readdir(DIR)) { |
148
|
0
|
0
|
|
|
|
0
|
if ( $file =~ /$self->{'tmp_suffix'}$/ ) { |
149
|
|
|
|
|
|
|
# nos aseguramos que sea un archivo temporal |
150
|
0
|
0
|
|
|
|
0
|
next if $file !~ /tmp/; |
151
|
0
|
|
|
|
|
0
|
my $last_mod = (stat ($self->{'tmp_dir'}.'/'.$file))[10]; |
152
|
0
|
0
|
|
|
|
0
|
unlink($self->{'tmp_dir'}.'/'.$file) if ( (time - $last_mod) > $self->{'expired'} ); |
153
|
|
|
|
|
|
|
} |
154
|
|
|
|
|
|
|
|
155
|
|
|
|
|
|
|
} |
156
|
0
|
|
|
|
|
0
|
closedir DIR; |
157
|
|
|
|
|
|
|
|
158
|
0
|
|
|
|
|
0
|
return; |
159
|
|
|
|
|
|
|
} |
160
|
|
|
|
|
|
|
|
161
|
|
|
|
|
|
|
sub save { |
162
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
163
|
0
|
|
|
|
|
0
|
my ($data) = @_; |
164
|
|
|
|
|
|
|
|
165
|
0
|
0
|
|
|
|
0
|
if ( ! -d $self->{'tmp_dir'} ) { |
166
|
0
|
|
|
|
|
0
|
my @level = split('/',$self->{'tmp_dir'}); |
167
|
0
|
|
|
|
|
0
|
my $dir; |
168
|
0
|
|
|
|
|
0
|
foreach my $this_level ( @level ) { |
169
|
0
|
|
|
|
|
0
|
$dir .= '/'.$this_level; |
170
|
0
|
0
|
|
|
|
0
|
mkdir $dir if ! -d $dir; |
171
|
0
|
0
|
|
|
|
0
|
if ( ! -d $dir ) { |
172
|
0
|
|
|
|
|
0
|
warn "Can't create tmp dir : $dir"; |
173
|
0
|
|
|
|
|
0
|
return; |
174
|
|
|
|
|
|
|
} |
175
|
|
|
|
|
|
|
} |
176
|
|
|
|
|
|
|
} |
177
|
|
|
|
|
|
|
|
178
|
0
|
0
|
|
|
|
0
|
open(my $fh,'>>',$self->{'file'}) or warn "Can't write tmp file : $self->{'file'}"; |
179
|
0
|
|
|
|
|
0
|
print $fh $data,"\n"; |
180
|
0
|
|
|
|
|
0
|
close $fh; |
181
|
|
|
|
|
|
|
|
182
|
0
|
|
|
|
|
0
|
return; |
183
|
|
|
|
|
|
|
} |
184
|
|
|
|
|
|
|
|
185
|
|
|
|
|
|
|
sub load { |
186
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
187
|
|
|
|
|
|
|
|
188
|
0
|
0
|
|
|
|
0
|
return if ! -e $self->{'file'}; |
189
|
|
|
|
|
|
|
|
190
|
0
|
0
|
|
|
|
0
|
open(my $fh, '<', $self->{'file'}) or warn "Can't read tmp file : $self->{'file'}"; |
191
|
0
|
|
|
|
|
0
|
my @data = <$fh>; |
192
|
0
|
|
|
|
|
0
|
chomp @data; |
193
|
0
|
|
|
|
|
0
|
close $fh; |
194
|
|
|
|
|
|
|
|
195
|
0
|
|
|
|
|
0
|
return @data; |
196
|
|
|
|
|
|
|
} |
197
|
|
|
|
|
|
|
|
198
|
|
|
|
|
|
|
sub clear { |
199
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
200
|
0
|
|
|
|
|
0
|
my ($data) = @_; |
201
|
|
|
|
|
|
|
|
202
|
0
|
0
|
|
|
|
0
|
return if ! -e $self->{'file'}; |
203
|
|
|
|
|
|
|
|
204
|
0
|
0
|
|
|
|
0
|
open(my $fh,'>',$self->{'file'}) or warn "Can't write tmp file : $self->{'file'} $!"; |
205
|
0
|
0
|
|
|
|
0
|
print $fh $data."\n" if $data; |
206
|
0
|
|
|
|
|
0
|
close $fh; |
207
|
|
|
|
|
|
|
|
208
|
0
|
|
|
|
|
0
|
return; |
209
|
|
|
|
|
|
|
} |
210
|
|
|
|
|
|
|
|
211
|
|
|
|
|
|
|
sub get_name { |
212
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
213
|
0
|
|
|
|
|
0
|
my ($name) = @_; |
214
|
|
|
|
|
|
|
|
215
|
0
|
|
|
|
|
0
|
my $remote = $ENV{'REMOTE_ADDR'}; |
216
|
0
|
0
|
0
|
|
|
0
|
$remote = $ENV{'HTTP_X_REMOTE_ADDR'} if $ENV{'HTTP_X_REMOTE_ADDR'} && ( !$remote || $remote =~ /^(127|192)\./); |
|
|
|
0
|
|
|
|
|
217
|
|
|
|
|
|
|
|
218
|
0
|
|
|
|
|
0
|
$name .= '.ip.'.$remote.$self->{'suffix'}.$self->{'tmp_suffix'}; |
219
|
|
|
|
|
|
|
|
220
|
0
|
|
|
|
|
0
|
return $name; |
221
|
|
|
|
|
|
|
} |
222
|
|
|
|
|
|
|
|
223
|
|
|
|
|
|
|
} |
224
|
|
|
|
|
|
|
|
225
|
|
|
|
|
|
|
{ |
226
|
|
|
|
|
|
|
|
227
|
|
|
|
|
|
|
package nes_register; |
228
|
3
|
|
|
3
|
|
46
|
use vars qw(@ISA); |
|
3
|
|
|
|
|
5
|
|
|
3
|
|
|
|
|
2997
|
|
229
|
|
|
|
|
|
|
@ISA = qw( Nes ); |
230
|
|
|
|
|
|
|
|
231
|
|
|
|
|
|
|
sub new { |
232
|
1
|
|
|
1
|
|
2
|
my $class = shift; |
233
|
1
|
|
|
|
|
14
|
my $self = $class->SUPER::new(); |
234
|
|
|
|
|
|
|
|
235
|
1
|
|
|
|
|
2
|
return $self; |
236
|
|
|
|
|
|
|
} |
237
|
|
|
|
|
|
|
|
238
|
|
|
|
|
|
|
sub set_data { |
239
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
240
|
0
|
|
|
|
|
0
|
my ($class, $name, $data) = @_; |
241
|
|
|
|
|
|
|
|
242
|
0
|
|
|
|
|
0
|
$self->{'data'}{$class}{$name} = $data; |
243
|
|
|
|
|
|
|
|
244
|
0
|
|
|
|
|
0
|
return; |
245
|
|
|
|
|
|
|
} |
246
|
|
|
|
|
|
|
|
247
|
|
|
|
|
|
|
sub get_data { |
248
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
249
|
0
|
|
|
|
|
0
|
my ($class, $name, $data) = @_; |
250
|
|
|
|
|
|
|
|
251
|
0
|
|
|
|
|
0
|
return $self->{'data'}{$class}{$name}; |
252
|
|
|
|
|
|
|
} |
253
|
|
|
|
|
|
|
|
254
|
|
|
|
|
|
|
sub tag { |
255
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
256
|
0
|
|
|
|
|
0
|
my ($class, $tag, $handler) = @_; |
257
|
|
|
|
|
|
|
|
258
|
0
|
|
|
|
|
0
|
$self->{'tag'}{$tag}{'handler'} = $handler; |
259
|
0
|
|
|
|
|
0
|
$self->{'obj'}{$class}{'tag'}{$tag} = $handler; |
260
|
|
|
|
|
|
|
|
261
|
0
|
|
|
|
|
0
|
return; |
262
|
|
|
|
|
|
|
} |
263
|
|
|
|
|
|
|
|
264
|
|
|
|
|
|
|
sub handler { |
265
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
266
|
0
|
|
|
|
|
0
|
my ($class, $name_handler, $handler) = @_; |
267
|
|
|
|
|
|
|
|
268
|
0
|
|
|
|
|
0
|
$self->{'obj'}{'handler'}{$class}{$name_handler} = $handler; |
269
|
|
|
|
|
|
|
|
270
|
0
|
|
|
|
|
0
|
return; |
271
|
|
|
|
|
|
|
} |
272
|
|
|
|
|
|
|
|
273
|
|
|
|
|
|
|
sub add_obj { |
274
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
275
|
0
|
|
|
|
|
0
|
my ($class, $name, $obj) = @_; |
276
|
|
|
|
|
|
|
|
277
|
0
|
|
|
|
|
0
|
my $cfg_file = $self->{'CFG'}{'plugin_top_dir'}.'/.'.$class.'.nes.cfg'; |
278
|
0
|
|
|
|
|
0
|
Nes::Setting->load_cfg($cfg_file); |
279
|
|
|
|
|
|
|
|
280
|
0
|
|
|
|
|
0
|
$self->{'obj'}{$class}{$name} = $obj; |
281
|
|
|
|
|
|
|
|
282
|
0
|
|
|
|
|
0
|
return $self; |
283
|
|
|
|
|
|
|
} |
284
|
|
|
|
|
|
|
|
285
|
|
|
|
|
|
|
sub get { |
286
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
287
|
0
|
|
|
|
|
0
|
my ($class, $name) = @_; |
288
|
|
|
|
|
|
|
|
289
|
0
|
|
|
|
|
0
|
return $self->{'obj'}{$class}{$name}; |
290
|
|
|
|
|
|
|
} |
291
|
|
|
|
|
|
|
|
292
|
|
|
|
|
|
|
sub get_tags { |
293
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
294
|
|
|
|
|
|
|
|
295
|
0
|
|
|
|
|
0
|
return keys %{ $self->{'tag'} }; |
|
0
|
|
|
|
|
0
|
|
296
|
|
|
|
|
|
|
} |
297
|
|
|
|
|
|
|
|
298
|
|
|
|
|
|
|
sub get_plugins { |
299
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
300
|
|
|
|
|
|
|
|
301
|
0
|
|
|
|
|
0
|
return keys %{ $self->{'obj'} }; |
|
0
|
|
|
|
|
0
|
|
302
|
|
|
|
|
|
|
} |
303
|
|
|
|
|
|
|
|
304
|
|
|
|
|
|
|
sub get_names { |
305
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
306
|
0
|
|
|
|
|
0
|
my ($class) = @_; |
307
|
|
|
|
|
|
|
|
308
|
0
|
|
|
|
|
0
|
return keys %{ $self->{'obj'}{$class} }; |
|
0
|
|
|
|
|
0
|
|
309
|
|
|
|
|
|
|
} |
310
|
|
|
|
|
|
|
|
311
|
|
|
|
|
|
|
sub get_tag_class { |
312
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
313
|
0
|
|
|
|
|
0
|
my ($tag) = @_; |
314
|
|
|
|
|
|
|
|
315
|
0
|
|
|
|
|
0
|
return $self->{'tag'}{$tag}{'class'}; |
316
|
|
|
|
|
|
|
} |
317
|
|
|
|
|
|
|
|
318
|
|
|
|
|
|
|
sub get_tag_handler { |
319
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
320
|
0
|
|
|
|
|
0
|
my ($tag) = @_; |
321
|
|
|
|
|
|
|
|
322
|
0
|
|
|
|
|
0
|
return \&{$self->{'tag'}{$tag}{'handler'}}; |
|
0
|
|
|
|
|
0
|
|
323
|
|
|
|
|
|
|
} |
324
|
|
|
|
|
|
|
|
325
|
|
|
|
|
|
|
sub get_handler { |
326
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
327
|
0
|
|
|
|
|
0
|
my ($class, $name_handler) = @_; |
328
|
|
|
|
|
|
|
|
329
|
0
|
|
|
|
|
0
|
return \&{$self->{'obj'}{'handler'}{$class}{$name_handler}}; |
|
0
|
|
|
|
|
0
|
|
330
|
|
|
|
|
|
|
} |
331
|
|
|
|
|
|
|
|
332
|
|
|
|
|
|
|
sub add_last_error { |
333
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
334
|
0
|
|
|
|
|
0
|
my ($class, $name, $error) = @_; |
335
|
|
|
|
|
|
|
|
336
|
0
|
|
|
|
|
0
|
$self->{'top_container'}->set_nes_env( 'nes_'.$class.'_'.$name.'_error_last', $error ); |
337
|
|
|
|
|
|
|
|
338
|
0
|
|
|
|
|
0
|
return; |
339
|
|
|
|
|
|
|
} |
340
|
|
|
|
|
|
|
|
341
|
|
|
|
|
|
|
sub add_fatal_error { |
342
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
343
|
0
|
|
|
|
|
0
|
my ($class, $name, $ok) = @_; |
344
|
|
|
|
|
|
|
|
345
|
0
|
|
|
|
|
0
|
$self->{'top_container'}->set_nes_env( 'nes_'.$class.'_'.$name.'_error_fatal', $ok ); |
346
|
|
|
|
|
|
|
|
347
|
0
|
|
|
|
|
0
|
return; |
348
|
|
|
|
|
|
|
} |
349
|
|
|
|
|
|
|
|
350
|
|
|
|
|
|
|
sub add_error { |
351
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
352
|
0
|
|
|
|
|
0
|
my ($class, $name, $type, $error) = @_; |
353
|
|
|
|
|
|
|
|
354
|
0
|
|
|
|
|
0
|
$self->{'top_container'}->set_nes_env( 'nes_'.$class.'_'.$name.'_error_'.$type, $error ); |
355
|
|
|
|
|
|
|
|
356
|
0
|
|
|
|
|
0
|
return; |
357
|
|
|
|
|
|
|
} |
358
|
|
|
|
|
|
|
|
359
|
|
|
|
|
|
|
sub add_env { |
360
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
361
|
0
|
|
|
|
|
0
|
my ($class, $name, $type, $value) = @_; |
362
|
|
|
|
|
|
|
|
363
|
0
|
|
|
|
|
0
|
$self->{'top_container'}->set_nes_env( 'nes_'.$class.'_'.$name.'_'.$type, $value ); |
364
|
|
|
|
|
|
|
|
365
|
0
|
|
|
|
|
0
|
return; |
366
|
|
|
|
|
|
|
} |
367
|
|
|
|
|
|
|
|
368
|
|
|
|
|
|
|
} |
369
|
|
|
|
|
|
|
|
370
|
|
|
|
|
|
|
|
371
|
|
|
|
|
|
|
{ |
372
|
|
|
|
|
|
|
|
373
|
|
|
|
|
|
|
# obsoleto, se mantiene por compatibilidad |
374
|
|
|
|
|
|
|
package nes_plugin; |
375
|
3
|
|
|
3
|
|
17
|
use vars qw(@ISA); |
|
3
|
|
|
|
|
5
|
|
|
3
|
|
|
|
|
1845
|
|
376
|
|
|
|
|
|
|
@ISA = qw( Nes ); |
377
|
|
|
|
|
|
|
|
378
|
|
|
|
|
|
|
my %instance = (); |
379
|
|
|
|
|
|
|
|
380
|
|
|
|
|
|
|
sub new { |
381
|
0
|
|
|
0
|
|
0
|
my $class = shift; |
382
|
0
|
|
|
|
|
0
|
my ( $obj_class, $name, $obj ) = @_; |
383
|
0
|
|
|
|
|
0
|
my $self = $class->SUPER::new(); |
384
|
|
|
|
|
|
|
|
385
|
|
|
|
|
|
|
# utl::cleanup(\%instance) if $ENV{'MOD_PERL'}; |
386
|
|
|
|
|
|
|
|
387
|
0
|
|
|
|
|
0
|
$self->{'plugin'} = $obj_class; |
388
|
0
|
|
|
|
|
0
|
$self->{'obj'}{$name} = $obj; |
389
|
|
|
|
|
|
|
|
390
|
0
|
|
|
|
|
0
|
my $cfg_file = $self->{'CFG'}{'plugin_top_dir'} . '/.' . $name . '.nes.cfg'; |
391
|
0
|
|
|
|
|
0
|
Nes::Setting->load_cfg($cfg_file); |
392
|
|
|
|
|
|
|
|
393
|
0
|
|
|
|
|
0
|
$instance{$obj_class} = $self; |
394
|
|
|
|
|
|
|
|
395
|
0
|
|
|
|
|
0
|
return $self; |
396
|
|
|
|
|
|
|
} |
397
|
|
|
|
|
|
|
|
398
|
|
|
|
|
|
|
# add object for this class |
399
|
|
|
|
|
|
|
sub add_obj { |
400
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
401
|
0
|
|
|
|
|
0
|
my ($name, $obj) = @_; |
402
|
|
|
|
|
|
|
|
403
|
0
|
|
|
|
|
0
|
$self->{'obj'}{$name} = $obj; |
404
|
|
|
|
|
|
|
|
405
|
0
|
|
|
|
|
0
|
return $obj; |
406
|
|
|
|
|
|
|
} |
407
|
|
|
|
|
|
|
|
408
|
|
|
|
|
|
|
sub add_last_error { |
409
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
410
|
0
|
|
|
|
|
0
|
my ($class, $name, $error) = @_; |
411
|
|
|
|
|
|
|
|
412
|
0
|
|
|
|
|
0
|
$self->{'top_container'}->set_nes_env( 'nes_'.$class.'_'.$name.'_error_last', $error ); |
413
|
|
|
|
|
|
|
|
414
|
0
|
|
|
|
|
0
|
return; |
415
|
|
|
|
|
|
|
} |
416
|
|
|
|
|
|
|
|
417
|
|
|
|
|
|
|
sub add_fatal_error { |
418
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
419
|
0
|
|
|
|
|
0
|
my ($class, $name, $ok) = @_; |
420
|
|
|
|
|
|
|
|
421
|
0
|
|
|
|
|
0
|
$self->{'top_container'}->set_nes_env( 'nes_'.$class.'_'.$name.'_error_fatal', $ok ); |
422
|
|
|
|
|
|
|
|
423
|
0
|
|
|
|
|
0
|
return; |
424
|
|
|
|
|
|
|
} |
425
|
|
|
|
|
|
|
|
426
|
|
|
|
|
|
|
sub add_error { |
427
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
428
|
0
|
|
|
|
|
0
|
my ($class, $name, $type, $error) = @_; |
429
|
|
|
|
|
|
|
|
430
|
0
|
|
|
|
|
0
|
$self->{'top_container'}->set_nes_env( 'nes_'.$class.'_'.$name.'_error_'.$type, $error ); |
431
|
|
|
|
|
|
|
|
432
|
0
|
|
|
|
|
0
|
return; |
433
|
|
|
|
|
|
|
} |
434
|
|
|
|
|
|
|
|
435
|
|
|
|
|
|
|
sub add_env { |
436
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
437
|
0
|
|
|
|
|
0
|
my ($class, $name, $type, $value) = @_; |
438
|
|
|
|
|
|
|
|
439
|
0
|
|
|
|
|
0
|
$self->{'top_container'}->set_nes_env( 'nes_'.$class.'_'.$name.'_'.$type, $value ); |
440
|
|
|
|
|
|
|
|
441
|
0
|
|
|
|
|
0
|
return; |
442
|
|
|
|
|
|
|
} |
443
|
|
|
|
|
|
|
|
444
|
|
|
|
|
|
|
sub get { |
445
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
446
|
0
|
|
|
|
|
0
|
my ($class, $name) = @_; |
447
|
|
|
|
|
|
|
|
448
|
0
|
0
|
|
|
|
0
|
return $instance{$class}->{'obj'}{$name} if $name; |
449
|
0
|
|
|
|
|
0
|
return $instance{$class}->{'obj'}{$class}; |
450
|
|
|
|
|
|
|
|
451
|
|
|
|
|
|
|
} |
452
|
|
|
|
|
|
|
|
453
|
|
|
|
|
|
|
sub get_obj { |
454
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
455
|
0
|
|
|
|
|
0
|
my ($class) = @_; |
456
|
|
|
|
|
|
|
|
457
|
0
|
0
|
|
|
|
0
|
return $instance{$class} if $class; |
458
|
0
|
|
|
|
|
0
|
return $self->SUPER::get_obj(); |
459
|
|
|
|
|
|
|
|
460
|
|
|
|
|
|
|
} |
461
|
|
|
|
|
|
|
|
462
|
|
|
|
|
|
|
} |
463
|
|
|
|
|
|
|
|
464
|
|
|
|
|
|
|
|
465
|
|
|
|
|
|
|
{ |
466
|
|
|
|
|
|
|
|
467
|
|
|
|
|
|
|
package nes_cookie; |
468
|
3
|
|
|
3
|
|
16
|
use vars qw(@ISA); |
|
3
|
|
|
|
|
11
|
|
|
3
|
|
|
|
|
2832
|
|
469
|
|
|
|
|
|
|
@ISA = qw( Nes ); |
470
|
|
|
|
|
|
|
|
471
|
|
|
|
|
|
|
sub new { |
472
|
2
|
|
|
2
|
|
3
|
my $class = shift; |
473
|
2
|
|
|
|
|
10
|
my $self = $class->SUPER::new(); |
474
|
|
|
|
|
|
|
|
475
|
2
|
|
|
|
|
9
|
$self->get_user_cookies(); |
476
|
|
|
|
|
|
|
|
477
|
2
|
|
|
|
|
3
|
return $self; |
478
|
|
|
|
|
|
|
} |
479
|
|
|
|
|
|
|
|
480
|
|
|
|
|
|
|
sub get_cookies { |
481
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
482
|
|
|
|
|
|
|
|
483
|
0
|
|
|
|
|
0
|
my @cookies; |
484
|
|
|
|
|
|
|
|
485
|
|
|
|
|
|
|
# primero las que borran, para no machacar las que valen |
486
|
0
|
|
|
|
|
0
|
foreach my $cookie ( keys %{ $self->{'c_set'} } ) { |
|
0
|
|
|
|
|
0
|
|
487
|
0
|
0
|
|
|
|
0
|
push( @cookies, $cookie ) if $cookie =~ /_delete$/; |
488
|
|
|
|
|
|
|
} |
489
|
0
|
|
|
|
|
0
|
foreach my $cookie ( keys %{ $self->{'c_set'} } ) { |
|
0
|
|
|
|
|
0
|
|
490
|
0
|
0
|
|
|
|
0
|
push( @cookies, $cookie ) if $cookie !~ /_delete$/; |
491
|
|
|
|
|
|
|
} |
492
|
|
|
|
|
|
|
|
493
|
0
|
|
|
|
|
0
|
return @cookies; |
494
|
|
|
|
|
|
|
} |
495
|
|
|
|
|
|
|
|
496
|
|
|
|
|
|
|
sub get { |
497
|
1
|
|
|
1
|
|
5
|
my $self = shift; |
498
|
1
|
|
|
|
|
2
|
my ( $name, $pass ) = @_; |
499
|
|
|
|
|
|
|
|
500
|
1
|
50
|
|
|
|
6
|
return if !$self->{'c_get'}{$name}; |
501
|
0
|
0
|
|
|
|
0
|
$pass = '' if !$pass; |
502
|
|
|
|
|
|
|
|
503
|
0
|
|
|
|
|
0
|
my $key = $self->{'CFG'}{'private_key'} . $pass; |
504
|
0
|
|
|
|
|
0
|
require Crypt::CBC; |
505
|
0
|
|
|
|
|
0
|
my $cipher = Crypt::CBC->new( |
506
|
|
|
|
|
|
|
-key => $key, |
507
|
|
|
|
|
|
|
-cipher => 'Blowfish' |
508
|
|
|
|
|
|
|
); |
509
|
0
|
|
|
|
|
0
|
my $text = ''; |
510
|
0
|
|
|
|
|
0
|
eval { $text = $cipher->decrypt_hex( $self->{'c_get'}{$name} ); }; |
|
0
|
|
|
|
|
0
|
|
511
|
|
|
|
|
|
|
|
512
|
0
|
|
|
|
|
0
|
return $text; |
513
|
|
|
|
|
|
|
} |
514
|
|
|
|
|
|
|
|
515
|
|
|
|
|
|
|
sub create { |
516
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
517
|
0
|
|
|
|
|
0
|
my ( $name, $value, $expiration, $path, $domain, $pass ) = @_; |
518
|
0
|
0
|
|
|
|
0
|
$pass = '' if !$pass; |
519
|
|
|
|
|
|
|
|
520
|
0
|
|
|
|
|
0
|
my $expires = &utl::expires($expiration); |
521
|
0
|
|
|
|
|
0
|
my $key = $self->{'CFG'}{'private_key'} . $pass; |
522
|
|
|
|
|
|
|
|
523
|
0
|
|
|
|
|
0
|
require Crypt::CBC; |
524
|
0
|
|
|
|
|
0
|
my $cipher = Crypt::CBC->new( |
525
|
|
|
|
|
|
|
-key => $key, |
526
|
|
|
|
|
|
|
-cipher => 'Blowfish' |
527
|
|
|
|
|
|
|
); |
528
|
|
|
|
|
|
|
|
529
|
0
|
|
|
|
|
0
|
$value = $cipher->encrypt_hex($value); |
530
|
0
|
0
|
|
|
|
0
|
$path = '/' if !$path; |
531
|
|
|
|
|
|
|
|
532
|
0
|
|
|
|
|
0
|
$self->{'c_set'}{$name} = "Set-Cookie: $name=$value; expires=$expires; path=$path; "; |
533
|
0
|
0
|
|
|
|
0
|
$self->{'c_set'}{$name} .= "domain=$domain; " if $domain; |
534
|
|
|
|
|
|
|
|
535
|
0
|
|
|
|
|
0
|
return; |
536
|
|
|
|
|
|
|
} |
537
|
|
|
|
|
|
|
|
538
|
|
|
|
|
|
|
sub del { |
539
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
540
|
0
|
|
|
|
|
0
|
my ($name,$path) = @_; |
541
|
0
|
0
|
|
|
|
0
|
$path = '/' if !$path; |
542
|
|
|
|
|
|
|
|
543
|
0
|
|
|
|
|
0
|
my $expires = &utl::expires('1s'); |
544
|
0
|
|
|
|
|
0
|
my $value = 'deleted'; |
545
|
|
|
|
|
|
|
|
546
|
0
|
|
|
|
|
0
|
$self->{'c_set'}{ $name . '_delete' } = "Set-Cookie: $name=$value; expires=$expires; path=$path; "; |
547
|
|
|
|
|
|
|
|
548
|
0
|
|
|
|
|
0
|
return; |
549
|
|
|
|
|
|
|
} |
550
|
|
|
|
|
|
|
|
551
|
|
|
|
|
|
|
sub get_user_cookies { |
552
|
2
|
|
|
2
|
|
3
|
my $self = shift; |
553
|
|
|
|
|
|
|
|
554
|
2
|
50
|
|
|
|
7
|
return if !$ENV{'HTTP_COOKIE'}; |
555
|
|
|
|
|
|
|
|
556
|
0
|
|
|
|
|
0
|
my @cookies = split( /[;,]\s*/, $ENV{'HTTP_COOKIE'} ); |
557
|
0
|
|
|
|
|
0
|
foreach my $cookie (@cookies) { |
558
|
0
|
|
|
|
|
0
|
my ( $key, $value ) = split( /=/, $cookie ); |
559
|
0
|
0
|
|
|
|
0
|
$value = '' if !$value; |
560
|
0
|
0
|
|
|
|
0
|
next if $value eq 'deleted'; |
561
|
0
|
|
|
|
|
0
|
$self->{'c_get'}{$key} = $value; |
562
|
|
|
|
|
|
|
} |
563
|
|
|
|
|
|
|
} |
564
|
|
|
|
|
|
|
|
565
|
|
|
|
|
|
|
sub out { |
566
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
567
|
|
|
|
|
|
|
|
568
|
0
|
|
|
|
|
0
|
my $cookies = ''; |
569
|
0
|
|
|
|
|
0
|
foreach my $cookie ( $self->get_cookies() ) { |
570
|
0
|
|
|
|
|
0
|
$cookies .= $self->{'c_set'}{$cookie}."\n"; |
571
|
|
|
|
|
|
|
} |
572
|
|
|
|
|
|
|
|
573
|
0
|
|
|
|
|
0
|
return $cookies; |
574
|
|
|
|
|
|
|
} |
575
|
|
|
|
|
|
|
|
576
|
|
|
|
|
|
|
sub get_c_get { |
577
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
578
|
|
|
|
|
|
|
|
579
|
0
|
|
|
|
|
0
|
my @cookies; |
580
|
|
|
|
|
|
|
|
581
|
0
|
|
|
|
|
0
|
foreach my $cookie ( keys %{ $self->{'c_get'} } ) { |
|
0
|
|
|
|
|
0
|
|
582
|
0
|
|
|
|
|
0
|
push( @cookies, $cookie ); |
583
|
|
|
|
|
|
|
} |
584
|
|
|
|
|
|
|
|
585
|
0
|
|
|
|
|
0
|
return @cookies; |
586
|
|
|
|
|
|
|
} |
587
|
|
|
|
|
|
|
|
588
|
|
|
|
|
|
|
} |
589
|
|
|
|
|
|
|
|
590
|
|
|
|
|
|
|
|
591
|
|
|
|
|
|
|
{ |
592
|
|
|
|
|
|
|
|
593
|
|
|
|
|
|
|
package nes_session; |
594
|
3
|
|
|
3
|
|
17
|
use vars qw(@ISA); |
|
3
|
|
|
|
|
16
|
|
|
3
|
|
|
|
|
3964
|
|
595
|
|
|
|
|
|
|
@ISA = qw( nes_cookie ); |
596
|
|
|
|
|
|
|
|
597
|
|
|
|
|
|
|
sub new { |
598
|
1
|
|
|
1
|
|
1
|
my $class = shift; |
599
|
1
|
|
|
|
|
5
|
my $self = $class->SUPER::new(); |
600
|
|
|
|
|
|
|
|
601
|
1
|
|
|
|
|
3
|
$self->{'session_prefix'} = $self->{'CFG'}{'session_prefix'}; |
602
|
1
|
|
|
|
|
2
|
$self->{'session_ok'} = 0; |
603
|
1
|
|
|
|
|
2
|
$self->{'user'} = ''; |
604
|
1
|
|
|
|
|
3
|
$self->get; |
605
|
|
|
|
|
|
|
|
606
|
1
|
|
|
|
|
2
|
return $self; |
607
|
|
|
|
|
|
|
} |
608
|
|
|
|
|
|
|
|
609
|
|
|
|
|
|
|
sub get { |
610
|
1
|
|
|
1
|
|
2
|
my $self = shift; |
611
|
1
|
|
50
|
|
|
11
|
my ($pass) = @_ || ''; |
612
|
|
|
|
|
|
|
|
613
|
1
|
|
|
|
|
3
|
my $key = $self->{'CFG'}{'private_key'} . $pass; |
614
|
1
|
|
|
|
|
7
|
$self->{'sess'} = $self->SUPER::get( $self->{'session_prefix'}, $key ); |
615
|
1
|
50
|
|
|
|
3
|
return if !$self->{'sess'}; |
616
|
|
|
|
|
|
|
|
617
|
0
|
|
|
|
|
0
|
my ( $session_name, $expire, $user, $refuse ) = split( /::/, $self->{'sess'} ); |
618
|
|
|
|
|
|
|
|
619
|
0
|
0
|
|
|
|
0
|
return if time > $expire; |
620
|
0
|
0
|
|
|
|
0
|
return if $session_name ne $self->{'session_prefix'}; |
621
|
|
|
|
|
|
|
|
622
|
0
|
|
|
|
|
0
|
$self->{'session_ok'} = 1; |
623
|
0
|
|
|
|
|
0
|
$self->{'user'} = $user; |
624
|
|
|
|
|
|
|
|
625
|
0
|
|
|
|
|
0
|
return $user; |
626
|
|
|
|
|
|
|
} |
627
|
|
|
|
|
|
|
|
628
|
|
|
|
|
|
|
sub create { |
629
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
630
|
0
|
|
|
|
|
0
|
my ( $user, $expiration, $pass ) = @_; |
631
|
0
|
0
|
|
|
|
0
|
$pass = '' if !$pass; |
632
|
|
|
|
|
|
|
|
633
|
0
|
|
|
|
|
0
|
my $key = $self->{'CFG'}{'private_key'} . $pass; |
634
|
0
|
|
|
|
|
0
|
my $expire = time + utl::expires_time( $expiration ); |
635
|
0
|
|
|
|
|
0
|
my $refuse = $self->get_key( 10 + int rand 10 ); |
636
|
0
|
|
|
|
|
0
|
my $value = $self->{'session_prefix'} . '::' . $expire . '::' . $user . '::' . $refuse; |
637
|
0
|
|
|
|
|
0
|
my $path = '/'; |
638
|
|
|
|
|
|
|
|
639
|
0
|
|
|
|
|
0
|
$self->{'cookies'}->create( $self->{'session_prefix'}, $value, $expiration, $path,'',$key ); |
640
|
|
|
|
|
|
|
|
641
|
0
|
|
|
|
|
0
|
return; |
642
|
|
|
|
|
|
|
} |
643
|
|
|
|
|
|
|
|
644
|
|
|
|
|
|
|
sub del { |
645
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
646
|
|
|
|
|
|
|
|
647
|
0
|
0
|
|
|
|
0
|
return if !$self->{'user'}; |
648
|
0
|
|
|
|
|
0
|
$self->{'cookies'}->del( $self->{'session_prefix'} ); |
649
|
|
|
|
|
|
|
|
650
|
0
|
|
|
|
|
0
|
return; |
651
|
|
|
|
|
|
|
} |
652
|
|
|
|
|
|
|
|
653
|
|
|
|
|
|
|
} |
654
|
|
|
|
|
|
|
|
655
|
|
|
|
|
|
|
|
656
|
|
|
|
|
|
|
{ # todo, add "" support |
657
|
|
|
|
|
|
|
|
658
|
|
|
|
|
|
|
package nes_query; |
659
|
3
|
|
|
3
|
|
28
|
use vars qw(@ISA); |
|
3
|
|
|
|
|
6
|
|
|
3
|
|
|
|
|
3280
|
|
660
|
|
|
|
|
|
|
@ISA = qw( Nes ); |
661
|
|
|
|
|
|
|
|
662
|
|
|
|
|
|
|
sub new { |
663
|
1
|
|
|
1
|
|
2
|
my $class = shift; |
664
|
1
|
|
|
|
|
4
|
my $self = $class->SUPER::new(); |
665
|
|
|
|
|
|
|
|
666
|
1
|
|
|
|
|
3
|
$self->{'q'} = {}; |
667
|
1
|
|
50
|
|
|
5
|
my $clength = $ENV{'CONTENT_LENGTH'} || 0; |
668
|
1
|
|
|
|
|
2
|
$self->{'save_buffer'} = 0; |
669
|
|
|
|
|
|
|
|
670
|
1
|
50
|
33
|
|
|
6
|
return $self if !$clength && !$ENV{'QUERY_STRING'}; |
671
|
|
|
|
|
|
|
|
672
|
0
|
|
|
|
|
0
|
require Nes::Minimal; |
673
|
0
|
0
|
0
|
|
|
0
|
$self->{'save_buffer'} = 1 if $self->{'top_container'}->{'php_wrapper'} && |
|
|
|
0
|
|
|
|
|
674
|
|
|
|
|
|
|
$clength > ($self->{'CFG'}{'tmp_upload'}*1024) && |
675
|
|
|
|
|
|
|
$self->{'CFG'}{'tmp_upload'}; |
676
|
0
|
|
|
|
|
0
|
Nes::Minimal::allow_hybrid_post_get(1); |
677
|
0
|
|
|
|
|
0
|
Nes::Minimal::max_read_size( $self->{'CFG'}{'max_post'}*1024 ); |
678
|
0
|
|
|
|
|
0
|
Nes::Minimal::use_tmp( $self->{'CFG'}{'tmp_upload'}*1024 ); |
679
|
0
|
|
|
|
|
0
|
Nes::Minimal::max_upload( $self->{'CFG'}{'max_upload'}*1024 ); |
680
|
0
|
0
|
|
|
|
0
|
Nes::Minimal::save_buffer(1) if $self->{'save_buffer'}; |
681
|
0
|
0
|
|
|
|
0
|
Nes::Minimal::sub_filter( \&utl::no_nes_remove ) if $self->{'top_container'}->{'php_wrapper'}; |
682
|
0
|
|
|
|
|
0
|
$self->{'CGI'} = Nes::Minimal->new; |
683
|
0
|
|
|
|
|
0
|
$self->set_query(); |
684
|
|
|
|
|
|
|
|
685
|
0
|
|
|
|
|
0
|
return $self; |
686
|
|
|
|
|
|
|
} |
687
|
|
|
|
|
|
|
|
688
|
|
|
|
|
|
|
sub set_query { |
689
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
690
|
|
|
|
|
|
|
|
691
|
0
|
|
|
|
|
0
|
foreach my $param ( $self->{'CGI'}->param() ) { |
692
|
0
|
|
|
|
|
0
|
$self->{'q'}{$param} = $self->{'CGI'}->param($param); |
693
|
|
|
|
|
|
|
} |
694
|
|
|
|
|
|
|
|
695
|
0
|
|
|
|
|
0
|
return; |
696
|
|
|
|
|
|
|
} |
697
|
|
|
|
|
|
|
|
698
|
|
|
|
|
|
|
sub param { |
699
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
700
|
0
|
|
|
|
|
0
|
my ($param) = @_; |
701
|
|
|
|
|
|
|
|
702
|
0
|
|
|
|
|
0
|
return $self->{'CGI'}->param($param); |
703
|
|
|
|
|
|
|
} |
704
|
|
|
|
|
|
|
|
705
|
|
|
|
|
|
|
# sub get_upload { |
706
|
|
|
|
|
|
|
# my $self = shift; |
707
|
|
|
|
|
|
|
# my ($param,$buffer) = @_; |
708
|
|
|
|
|
|
|
# |
709
|
|
|
|
|
|
|
# my $fh = $self->{'CGI'}->upload($param); |
710
|
|
|
|
|
|
|
# return if !$fh; |
711
|
|
|
|
|
|
|
# |
712
|
|
|
|
|
|
|
# return read($fh, $$buffer, 8192); |
713
|
|
|
|
|
|
|
# } |
714
|
|
|
|
|
|
|
|
715
|
|
|
|
|
|
|
sub get_upload_buffer { |
716
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
717
|
0
|
|
|
|
|
0
|
my ($param,$buffer) = @_; |
718
|
|
|
|
|
|
|
|
719
|
0
|
|
|
|
|
0
|
my $fh = $self->{'CGI'}->upload($param); |
720
|
0
|
0
|
|
|
|
0
|
return if !$fh; |
721
|
|
|
|
|
|
|
|
722
|
0
|
|
|
|
|
0
|
return read($fh, $$buffer, 8192); |
723
|
|
|
|
|
|
|
} |
724
|
|
|
|
|
|
|
|
725
|
|
|
|
|
|
|
sub get_upload_name { |
726
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
727
|
0
|
|
|
|
|
0
|
my ($param) = @_; |
728
|
|
|
|
|
|
|
|
729
|
0
|
|
|
|
|
0
|
return $self->{'CGI'}->param_filename($param); |
730
|
|
|
|
|
|
|
} |
731
|
|
|
|
|
|
|
|
732
|
|
|
|
|
|
|
sub get_upload_fh { |
733
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
734
|
0
|
|
|
|
|
0
|
my ($param) = @_; |
735
|
|
|
|
|
|
|
|
736
|
0
|
|
|
|
|
0
|
return $self->{'CGI'}->upload($param); |
737
|
|
|
|
|
|
|
} |
738
|
|
|
|
|
|
|
|
739
|
|
|
|
|
|
|
sub upload_is_tmp { |
740
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
741
|
0
|
|
|
|
|
0
|
my ($param) = @_; |
742
|
|
|
|
|
|
|
|
743
|
0
|
|
|
|
|
0
|
return $self->{'CGI'}->upload_is_tmp($param); |
744
|
|
|
|
|
|
|
} |
745
|
|
|
|
|
|
|
|
746
|
|
|
|
|
|
|
sub upload_max_size { |
747
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
748
|
|
|
|
|
|
|
|
749
|
0
|
|
|
|
|
0
|
return $self->{'CGI'}->upload_max_size(); |
750
|
|
|
|
|
|
|
} |
751
|
|
|
|
|
|
|
|
752
|
|
|
|
|
|
|
sub post_max_size { |
753
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
754
|
|
|
|
|
|
|
|
755
|
0
|
|
|
|
|
0
|
return $self->{'CGI'}->post_max_size(); |
756
|
|
|
|
|
|
|
} |
757
|
|
|
|
|
|
|
|
758
|
|
|
|
|
|
|
sub url_encode { |
759
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
760
|
0
|
|
|
|
|
0
|
my ($value) = @_; |
761
|
|
|
|
|
|
|
|
762
|
0
|
|
|
|
|
0
|
return $self->{'CGI'}->url_encode($value); |
763
|
|
|
|
|
|
|
} |
764
|
|
|
|
|
|
|
|
765
|
|
|
|
|
|
|
sub url_decode { |
766
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
767
|
0
|
|
|
|
|
0
|
my ($value) = @_; |
768
|
|
|
|
|
|
|
|
769
|
0
|
|
|
|
|
0
|
return $self->{'CGI'}->url_decode($value); |
770
|
|
|
|
|
|
|
} |
771
|
|
|
|
|
|
|
|
772
|
|
|
|
|
|
|
sub get_buffer { |
773
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
774
|
0
|
|
|
|
|
0
|
my $buffer; |
775
|
|
|
|
|
|
|
|
776
|
0
|
0
|
|
|
|
0
|
return if !$self->{'CGI'}; |
777
|
|
|
|
|
|
|
|
778
|
0
|
0
|
|
|
|
0
|
if ( $ENV{'REQUEST_METHOD'} ne 'GET' ) { |
779
|
0
|
0
|
|
|
|
0
|
return $buffer if $self->{'CGI'}->raw_saved(\$buffer, 8192); |
780
|
|
|
|
|
|
|
} |
781
|
0
|
|
|
|
|
0
|
return; |
782
|
|
|
|
|
|
|
|
783
|
|
|
|
|
|
|
} |
784
|
|
|
|
|
|
|
|
785
|
|
|
|
|
|
|
sub get_buffer_raw { |
786
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
787
|
|
|
|
|
|
|
|
788
|
0
|
0
|
|
|
|
0
|
return if !$self->{'CGI'}; |
789
|
|
|
|
|
|
|
|
790
|
0
|
0
|
|
|
|
0
|
if ( $ENV{'REQUEST_METHOD'} ne 'GET' ) { |
791
|
0
|
|
|
|
|
0
|
return $self->{'CGI'}->raw; |
792
|
|
|
|
|
|
|
} |
793
|
0
|
|
|
|
|
0
|
return; |
794
|
|
|
|
|
|
|
|
795
|
|
|
|
|
|
|
} |
796
|
|
|
|
|
|
|
|
797
|
|
|
|
|
|
|
sub get { |
798
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
799
|
0
|
|
|
|
|
0
|
my ($key) = @_; |
800
|
|
|
|
|
|
|
|
801
|
|
|
|
|
|
|
# return $self->{'CGI'}->param($key); |
802
|
0
|
|
|
|
|
0
|
return $self->{'q'}{$key}; |
803
|
|
|
|
|
|
|
} |
804
|
|
|
|
|
|
|
|
805
|
|
|
|
|
|
|
sub set { |
806
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
807
|
0
|
|
|
|
|
0
|
my ( $name, $value ) = @_; |
808
|
|
|
|
|
|
|
|
809
|
0
|
|
|
|
|
0
|
$self->{'q'}{$name} = $value; |
810
|
|
|
|
|
|
|
|
811
|
0
|
|
|
|
|
0
|
return; |
812
|
|
|
|
|
|
|
} |
813
|
|
|
|
|
|
|
|
814
|
|
|
|
|
|
|
sub del { |
815
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
816
|
0
|
|
|
|
|
0
|
my ( $name ) = @_; |
817
|
|
|
|
|
|
|
|
818
|
0
|
|
|
|
|
0
|
undef $self->{'q'}{$name}; |
819
|
|
|
|
|
|
|
|
820
|
0
|
|
|
|
|
0
|
return; |
821
|
|
|
|
|
|
|
} |
822
|
|
|
|
|
|
|
|
823
|
|
|
|
|
|
|
} |
824
|
|
|
|
|
|
|
|
825
|
|
|
|
|
|
|
|
826
|
|
|
|
|
|
|
{ |
827
|
|
|
|
|
|
|
|
828
|
|
|
|
|
|
|
package nes_top_container; |
829
|
3
|
|
|
3
|
|
18
|
use vars qw(@ISA); |
|
3
|
|
|
|
|
6
|
|
|
3
|
|
|
|
|
7818
|
|
830
|
|
|
|
|
|
|
@ISA = qw( Nes ); |
831
|
|
|
|
|
|
|
|
832
|
|
|
|
|
|
|
sub new { |
833
|
1
|
|
|
1
|
|
22
|
my $class = shift; |
834
|
1
|
|
|
|
|
11
|
my $self = $class->SUPER::new(); |
835
|
1
|
|
|
|
|
2
|
my ($file,$dir) = @_; |
836
|
|
|
|
|
|
|
|
837
|
|
|
|
|
|
|
# maximo de interactiones, para evitar un bucle infinito. |
838
|
1
|
|
|
|
|
2
|
$self->{'max_inter'} = $MAX_INTERACTIONS; |
839
|
|
|
|
|
|
|
|
840
|
1
|
50
|
|
|
|
6
|
$self->init($file,$dir) if $file; |
841
|
|
|
|
|
|
|
|
842
|
1
|
|
|
|
|
3
|
return $self; |
843
|
|
|
|
|
|
|
} |
844
|
|
|
|
|
|
|
|
845
|
|
|
|
|
|
|
sub init { |
846
|
1
|
|
|
1
|
|
1
|
my $self = shift; |
847
|
1
|
|
|
|
|
3
|
my ($file,$dir) = @_; |
848
|
|
|
|
|
|
|
|
849
|
1
|
|
|
|
|
2
|
$self->{'url'} = ''; |
850
|
1
|
|
|
|
|
3
|
$self->{'dir'} = $dir; |
851
|
1
|
|
|
|
|
2
|
$self->{'file'} = $file; |
852
|
|
|
|
|
|
|
|
853
|
1
|
|
|
|
|
4
|
$self->set_parent_dir( $self->{'dir'} ); |
854
|
|
|
|
|
|
|
|
855
|
1
|
|
|
|
|
3
|
$self->{'file'} =~ s/(.*[\\\/])/\//; |
856
|
1
|
|
|
|
|
3
|
$self->{'file'} = $self->{'dir'} . $self->{'file'}; |
857
|
|
|
|
|
|
|
|
858
|
1
|
50
|
|
|
|
6
|
$self->{'php_wrapper'} = 1 if $self->{'file'} =~ /php$/i; |
859
|
|
|
|
|
|
|
|
860
|
1
|
|
|
|
|
5
|
$self->{'query'} = nes_query->new(); |
861
|
1
|
|
|
|
|
4
|
$self->{'cookies'} = nes_cookie->new(); |
862
|
1
|
|
|
|
|
7
|
$self->{'session'} = nes_session->new(); |
863
|
1
|
|
|
|
|
4
|
$self->{'register'} = nes_register->new(); |
864
|
|
|
|
|
|
|
|
865
|
1
|
|
|
|
|
4
|
$self->init_nes_env(); |
866
|
1
|
|
|
|
|
3
|
$self->init_cgi_env(); |
867
|
|
|
|
|
|
|
|
868
|
1
|
|
|
|
|
5
|
$self->{'container'} = nes_container->new( $self->{'file'} ); |
869
|
|
|
|
|
|
|
|
870
|
1
|
|
|
|
|
2
|
return; |
871
|
|
|
|
|
|
|
} |
872
|
|
|
|
|
|
|
|
873
|
|
|
|
|
|
|
sub get_out { |
874
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
875
|
|
|
|
|
|
|
|
876
|
0
|
|
|
|
|
0
|
return $self->{'out'}; |
877
|
|
|
|
|
|
|
} |
878
|
|
|
|
|
|
|
|
879
|
|
|
|
|
|
|
sub get_session { |
880
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
881
|
|
|
|
|
|
|
|
882
|
0
|
|
|
|
|
0
|
return $self->{'session'}; |
883
|
|
|
|
|
|
|
} |
884
|
|
|
|
|
|
|
|
885
|
|
|
|
|
|
|
sub get_query { |
886
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
887
|
|
|
|
|
|
|
|
888
|
0
|
|
|
|
|
0
|
return $self->{'query'}; |
889
|
|
|
|
|
|
|
} |
890
|
|
|
|
|
|
|
|
891
|
|
|
|
|
|
|
sub get_file_path { |
892
|
1
|
|
|
1
|
|
2
|
my $self = shift; |
893
|
1
|
|
|
|
|
1
|
my ( $file ) = @_; |
894
|
|
|
|
|
|
|
|
895
|
1
|
|
|
|
|
3
|
my $parent_dir = $self->get_parent_dir(); |
896
|
1
|
|
|
|
|
4
|
$parent_dir =~ s/\/$//; |
897
|
1
|
|
|
|
|
2
|
my $this_dir = $file; |
898
|
1
|
|
|
|
|
9
|
$this_dir =~ s/[^\/]*$//; |
899
|
1
|
|
|
|
|
1
|
$this_dir =~ s/^\.\///; |
900
|
1
|
|
|
|
|
2
|
my $this_file = $file; |
901
|
1
|
|
|
|
|
5
|
$this_file =~ s/(.*)(\\|\/)//; |
902
|
|
|
|
|
|
|
|
903
|
1
|
|
|
|
|
1
|
my $file_path; |
904
|
|
|
|
|
|
|
|
905
|
1
|
50
|
|
|
|
4
|
if ( $this_dir =~ /^\// ) { |
906
|
1
|
|
|
|
|
2
|
$self->{'this_dir'} = $this_dir; |
907
|
1
|
|
|
|
|
2
|
$file_path = $file; |
908
|
|
|
|
|
|
|
} else { |
909
|
0
|
|
|
|
|
0
|
while ( $this_dir =~ s/^\.\.\/// ) { |
910
|
0
|
|
|
|
|
0
|
$parent_dir =~ s/\/[^\/]*$//; |
911
|
|
|
|
|
|
|
} |
912
|
0
|
|
|
|
|
0
|
$self->{'this_dir'} = $parent_dir.'/'.$this_dir; |
913
|
0
|
|
|
|
|
0
|
$file_path = $parent_dir.'/'.$this_dir.$this_file; |
914
|
|
|
|
|
|
|
} |
915
|
|
|
|
|
|
|
|
916
|
|
|
|
|
|
|
# Insecure dependency in require while running with -T switch at |
917
|
1
|
50
|
|
|
|
5
|
if ($file_path =~ /^([-\@\w.\\\/]+)$/) { |
918
|
1
|
|
|
|
|
2
|
$file_path = $1; |
919
|
|
|
|
|
|
|
} |
920
|
|
|
|
|
|
|
|
921
|
1
|
|
|
|
|
4
|
return $file_path; |
922
|
|
|
|
|
|
|
} |
923
|
|
|
|
|
|
|
|
924
|
|
|
|
|
|
|
sub get_dir { |
925
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
926
|
0
|
|
|
|
|
0
|
my ($file) = @_; |
927
|
|
|
|
|
|
|
|
928
|
0
|
|
|
|
|
0
|
my $dir = $file; |
929
|
0
|
|
|
|
|
0
|
$dir =~ s/(.*)(\\|\/).*/$1/; |
930
|
|
|
|
|
|
|
|
931
|
0
|
|
|
|
|
0
|
return $dir; |
932
|
|
|
|
|
|
|
} |
933
|
|
|
|
|
|
|
|
934
|
|
|
|
|
|
|
sub set_parent_dir { |
935
|
2
|
|
|
2
|
|
3
|
my $self = shift; |
936
|
2
|
|
|
|
|
2
|
my ($dir) = @_; |
937
|
|
|
|
|
|
|
|
938
|
2
|
|
|
|
|
3
|
$self->{'parent_dir'} = $dir; |
939
|
|
|
|
|
|
|
|
940
|
2
|
|
|
|
|
2
|
return $dir; |
941
|
|
|
|
|
|
|
} |
942
|
|
|
|
|
|
|
|
943
|
|
|
|
|
|
|
sub get_parent_dir { |
944
|
2
|
|
|
2
|
|
3
|
my $self = shift; |
945
|
|
|
|
|
|
|
|
946
|
2
|
|
|
|
|
4
|
return $self->{'parent_dir'}; |
947
|
|
|
|
|
|
|
} |
948
|
|
|
|
|
|
|
|
949
|
|
|
|
|
|
|
sub init_nes_env { |
950
|
1
|
|
|
1
|
|
1
|
my $self = shift; |
951
|
1
|
|
|
|
|
2
|
my ( $var, $value ) = @_; |
952
|
|
|
|
|
|
|
|
953
|
1
|
|
|
|
|
2
|
foreach my $key ( keys %{ $self->{'query'}->{'q'} } ) { |
|
1
|
|
|
|
|
4
|
|
954
|
0
|
|
|
|
|
0
|
my $name_env = 'q_' . $key; |
955
|
0
|
|
|
|
|
0
|
my $value = $self->{'query'}->{'q'}{$key}; |
956
|
0
|
|
|
|
|
0
|
$self->{'nes_env'}{$name_env} = $value; |
957
|
|
|
|
|
|
|
} |
958
|
|
|
|
|
|
|
|
959
|
1
|
|
|
|
|
2
|
foreach my $key ( keys %{ $self->{'CFG'} } ) { |
|
1
|
|
|
|
|
6
|
|
960
|
38
|
|
|
|
|
44
|
my $name_env = 'cfg_' . $key; |
961
|
38
|
|
|
|
|
40
|
my $value = $self->{'CFG'}->{$key}; |
962
|
38
|
100
|
|
|
|
64
|
$value = "@{$self->{'CFG'}->{$key}}" if ref $self->{'CFG'}->{$key} eq 'ARRAY'; |
|
7
|
|
|
|
|
18
|
|
963
|
38
|
100
|
|
|
|
64
|
$value = keys %{$self->{'CFG'}->{$key}} if ref $self->{'CFG'}->{$key} eq 'HASH'; |
|
1
|
|
|
|
|
3
|
|
964
|
38
|
|
|
|
|
92
|
$self->{'nes_env'}{$name_env} = $value; |
965
|
|
|
|
|
|
|
} |
966
|
|
|
|
|
|
|
|
967
|
1
|
|
|
|
|
7
|
( $self->{'nes_env'}{'nes_accept_language'} ) = split(/,/, $ENV{'HTTP_ACCEPT_LANGUAGE'}, 2); |
968
|
1
|
|
|
|
|
3
|
$self->{'nes_env'}{'nes_dir_self'} = $self->{'dir'}; |
969
|
1
|
|
|
|
|
2
|
$self->{'nes_env'}{'nes_this_dir'} = $self->{'dir'}; |
970
|
1
|
|
|
|
|
3
|
$self->{'nes_env'}{'nes_this_file'} = $self->{'file'}; |
971
|
1
|
|
|
|
|
7
|
$self->{'nes_env'}{'nes_ver'} = $VERSION; |
972
|
1
|
|
|
|
|
2
|
$self->{'nes_env'}{'nes_remote_ip'} = $ENV{'REMOTE_ADDR'}; |
973
|
1
|
0
|
0
|
|
|
4
|
$self->{'nes_env'}{'nes_remote_ip'} = $ENV{'HTTP_X_REMOTE_ADDR'} |
|
|
|
33
|
|
|
|
|
974
|
|
|
|
|
|
|
if $ENV{'HTTP_X_REMOTE_ADDR'} && ( !$ENV{'REMOTE_ADDR'} || $ENV{'REMOTE_ADDR'} =~ /^(127|192|169|10)\./); |
975
|
|
|
|
|
|
|
|
976
|
1
|
|
|
|
|
3
|
$self->{'nes_env'}{'nes_session_ok'} = $self->{'session'}->{'session_ok'}; |
977
|
1
|
|
|
|
|
2
|
$self->{'nes_env'}{'nes_session_user'} = $self->{'session'}->{'user'}; |
978
|
|
|
|
|
|
|
|
979
|
1
|
|
|
|
|
2
|
return; |
980
|
|
|
|
|
|
|
} |
981
|
|
|
|
|
|
|
|
982
|
|
|
|
|
|
|
sub init_cgi_env { |
983
|
1
|
|
|
1
|
|
2
|
my $self = shift; |
984
|
1
|
|
|
|
|
1
|
my ( $var, $value ) = @_; |
985
|
|
|
|
|
|
|
|
986
|
1
|
|
|
|
|
6
|
foreach my $key ( keys %ENV ) { |
987
|
22
|
|
|
|
|
24
|
my $name_env = 'env_' . $key; |
988
|
22
|
|
|
|
|
28
|
my $value = $ENV{$key}; |
989
|
22
|
|
|
|
|
65
|
$self->{'nes_env'}{$name_env} = $value; |
990
|
|
|
|
|
|
|
} |
991
|
|
|
|
|
|
|
|
992
|
1
|
|
|
|
|
3
|
return; |
993
|
|
|
|
|
|
|
} |
994
|
|
|
|
|
|
|
|
995
|
|
|
|
|
|
|
sub set_nes_env { |
996
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
997
|
0
|
|
|
|
|
0
|
my ( $var, $value ) = @_; |
998
|
|
|
|
|
|
|
|
999
|
0
|
|
|
|
|
0
|
$self->{'nes_env'}{$var} = $value; |
1000
|
|
|
|
|
|
|
|
1001
|
0
|
|
|
|
|
0
|
return; |
1002
|
|
|
|
|
|
|
} |
1003
|
|
|
|
|
|
|
|
1004
|
|
|
|
|
|
|
sub del_nes_env { |
1005
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
1006
|
0
|
|
|
|
|
0
|
my ( $var ) = @_; |
1007
|
|
|
|
|
|
|
|
1008
|
0
|
|
|
|
|
0
|
undef $self->{'nes_env'}{$var}; |
1009
|
|
|
|
|
|
|
|
1010
|
0
|
|
|
|
|
0
|
return; |
1011
|
|
|
|
|
|
|
} |
1012
|
|
|
|
|
|
|
|
1013
|
|
|
|
|
|
|
sub get_nes_env { |
1014
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
1015
|
0
|
|
|
|
|
0
|
my ($var) = @_; |
1016
|
|
|
|
|
|
|
|
1017
|
0
|
|
|
|
|
0
|
return $self->{'nes_env'}{$var}; |
1018
|
|
|
|
|
|
|
|
1019
|
0
|
|
|
|
|
0
|
return; |
1020
|
|
|
|
|
|
|
} |
1021
|
|
|
|
|
|
|
|
1022
|
|
|
|
|
|
|
} |
1023
|
|
|
|
|
|
|
|
1024
|
|
|
|
|
|
|
{ |
1025
|
|
|
|
|
|
|
|
1026
|
|
|
|
|
|
|
package nes_container; |
1027
|
3
|
|
|
3
|
|
24
|
use vars qw(@ISA); |
|
3
|
|
|
|
|
6
|
|
|
3
|
|
|
|
|
6123
|
|
1028
|
|
|
|
|
|
|
@ISA = qw( Nes ); |
1029
|
|
|
|
|
|
|
|
1030
|
|
|
|
|
|
|
sub new { |
1031
|
1
|
|
|
1
|
|
2
|
my $class = shift; |
1032
|
1
|
|
|
|
|
5
|
my $self = $class->SUPER::new(); |
1033
|
1
|
|
|
|
|
1
|
my ( $file ) = @_; |
1034
|
|
|
|
|
|
|
|
1035
|
1
|
|
|
|
|
4
|
$self->{'file_dir'} = $self->{'top_container'}->get_parent_dir(); |
1036
|
1
|
|
|
|
|
5
|
$self->{'file_name'} = $self->{'top_container'}->get_file_path($file); |
1037
|
|
|
|
|
|
|
|
1038
|
1
|
|
|
|
|
10
|
$self->{'top_container'}->set_parent_dir($self->{'top_container'}->{'this_dir'}); |
1039
|
|
|
|
|
|
|
|
1040
|
1
|
50
|
|
|
|
4
|
$self->{'top_container'}->{'max_inter'}-- || die "Possible infinite loop"; |
1041
|
1
|
|
|
|
|
4
|
$self->{'this_inter'} = $MAX_INTERACTIONS - $self->{'top_container'}->{'max_inter'}; |
1042
|
|
|
|
|
|
|
|
1043
|
1
|
|
|
|
|
3
|
$self->{'souce_types'}{'unknown'} = 'unknown'; |
1044
|
1
|
|
|
|
|
2
|
$self->{'souce_types'}{'html'} = 'html,htm,nhtm,nhtml'; |
1045
|
1
|
|
|
|
|
1
|
$self->{'souce_types'}{'nsql'} = 'nsql'; |
1046
|
1
|
|
|
|
|
2
|
$self->{'souce_types'}{'php'} = 'php'; |
1047
|
1
|
|
|
|
|
2
|
$self->{'souce_types'}{'perl'} = 'pl'; |
1048
|
1
|
|
|
|
|
2
|
$self->{'souce_types'}{'txt'} = 'txt'; |
1049
|
1
|
|
|
|
|
3
|
$self->{'souce_types'}{'bash'} = 'sh'; |
1050
|
1
|
|
|
|
|
2
|
$self->{'souce_types'}{'python'} = 'py'; |
1051
|
1
|
|
|
|
|
2
|
$self->{'souce_types'}{'js'} = 'njs,js'; |
1052
|
|
|
|
|
|
|
#$self->{'souce_types'}{'mail'} = 'eml'; |
1053
|
|
|
|
|
|
|
# ... |
1054
|
|
|
|
|
|
|
|
1055
|
1
|
|
|
|
|
4
|
$self->get_source(); # set @{$self->{'file_souce'}} |
1056
|
1
|
|
|
|
|
4
|
$self->set_out(); # set $self->{'file_script'}, $self->{'out'} |
1057
|
1
|
|
|
|
|
4
|
$self->get_type(); # set $self->{'type'}, $self->{'content_obj'} |
1058
|
1
|
|
|
|
|
4
|
$self->add_parent_tags(); # hereda los tags |
1059
|
|
|
|
|
|
|
|
1060
|
1
|
|
|
|
|
2
|
return $self; |
1061
|
|
|
|
|
|
|
} |
1062
|
|
|
|
|
|
|
|
1063
|
|
|
|
|
|
|
sub get_type { |
1064
|
1
|
|
|
1
|
|
2
|
my $self = shift; |
1065
|
|
|
|
|
|
|
|
1066
|
1
|
|
|
|
|
2
|
my $extension = $self->{'file_name'}; |
1067
|
1
|
|
|
|
|
7
|
$extension =~ s/(.*)\.([^\.]*)$/$2/; |
1068
|
|
|
|
|
|
|
|
1069
|
1
|
|
|
|
|
3
|
$self->{'type'} = 'unknown'; |
1070
|
1
|
|
|
|
|
1
|
foreach my $type ( keys %{ $self->{'souce_types'} } ) { |
|
1
|
|
|
|
|
5
|
|
1071
|
9
|
100
|
|
|
|
74
|
$self->{'type'} = $type if $self->{'souce_types'}{$type} =~ /[\,\s]?$extension[\,\s]?/i; |
1072
|
|
|
|
|
|
|
} |
1073
|
|
|
|
|
|
|
|
1074
|
1
|
50
|
|
|
|
5
|
if ( $self->{'type'} eq 'html' ) { |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
1075
|
1
|
|
|
|
|
7
|
$self->{'content_obj'} = nes_html->new( $self ); |
1076
|
|
|
|
|
|
|
|
1077
|
|
|
|
|
|
|
} elsif ( $self->{'type'} eq 'nsql' ) { |
1078
|
0
|
|
|
|
|
0
|
$self->{'content_obj'} = nes_nsql->new( $self ); |
1079
|
|
|
|
|
|
|
|
1080
|
|
|
|
|
|
|
} elsif ( $self->{'type'} eq 'php' ) { |
1081
|
0
|
|
|
|
|
0
|
$self->{'content_obj'} = nes_php->new( $self ); |
1082
|
|
|
|
|
|
|
|
1083
|
|
|
|
|
|
|
} elsif ( $self->{'type'} eq 'perl' ) { |
1084
|
0
|
|
|
|
|
0
|
$self->{'content_obj'} = nes_perl->new( $self ); |
1085
|
|
|
|
|
|
|
|
1086
|
|
|
|
|
|
|
} elsif ( $self->{'type'} eq 'txt' ) { |
1087
|
0
|
|
|
|
|
0
|
$self->{'content_obj'} = nes_txt->new( $self ); |
1088
|
|
|
|
|
|
|
|
1089
|
|
|
|
|
|
|
} elsif ( $self->{'type'} eq 'bash' ) { |
1090
|
0
|
|
|
|
|
0
|
$self->{'content_obj'} = nes_shell->new( $self ); |
1091
|
|
|
|
|
|
|
|
1092
|
|
|
|
|
|
|
} elsif ( $self->{'type'} eq 'python' ) { |
1093
|
0
|
|
|
|
|
0
|
$self->{'content_obj'} = nes_python->new( $self ); |
1094
|
|
|
|
|
|
|
|
1095
|
|
|
|
|
|
|
} elsif ( $self->{'type'} eq 'js' ) { |
1096
|
0
|
|
|
|
|
0
|
$self->{'content_obj'} = nes_js->new( $self ); |
1097
|
|
|
|
|
|
|
|
1098
|
|
|
|
|
|
|
} else { |
1099
|
0
|
|
|
|
|
0
|
$self->{'content_obj'} = nes_unknown->new( $self ); |
1100
|
|
|
|
|
|
|
} |
1101
|
|
|
|
|
|
|
|
1102
|
1
|
|
|
|
|
2
|
return; |
1103
|
|
|
|
|
|
|
} |
1104
|
|
|
|
|
|
|
|
1105
|
|
|
|
|
|
|
sub get_source { |
1106
|
1
|
|
|
1
|
|
2
|
my $self = shift; |
1107
|
|
|
|
|
|
|
|
1108
|
1
|
50
|
|
|
|
42
|
if ( open my $fh, '<', "$self->{'file_name'}" ) { |
1109
|
1
|
|
|
|
|
23
|
@{ $self->{'file_souce'} } = <$fh>; |
|
1
|
|
|
|
|
4
|
|
1110
|
1
|
|
|
|
|
7
|
chomp $self->{'file_souce'}[$#{$self->{'file_souce'}}]; |
|
1
|
|
|
|
|
2
|
|
1111
|
1
|
|
|
|
|
8
|
close $fh; |
1112
|
|
|
|
|
|
|
} else { |
1113
|
0
|
|
|
|
|
0
|
warn "couldn't open $self->{'file_name'}"; |
1114
|
0
|
|
|
|
|
0
|
$self->{'top_container'}->set_nes_env( 'nes_error_file_not_exist', $self->{'file_name'} ); |
1115
|
|
|
|
|
|
|
} |
1116
|
|
|
|
|
|
|
|
1117
|
1
|
|
|
|
|
4
|
return; |
1118
|
|
|
|
|
|
|
} |
1119
|
|
|
|
|
|
|
|
1120
|
|
|
|
|
|
|
sub add_tags { |
1121
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
1122
|
0
|
|
|
|
|
0
|
my (%tags) = @_; |
1123
|
|
|
|
|
|
|
|
1124
|
0
|
|
|
|
|
0
|
$self->{'content_obj'}->add_tags(%tags); |
1125
|
|
|
|
|
|
|
|
1126
|
0
|
|
|
|
|
0
|
return; |
1127
|
|
|
|
|
|
|
} |
1128
|
|
|
|
|
|
|
|
1129
|
|
|
|
|
|
|
sub add_parent_tags { |
1130
|
1
|
|
|
1
|
|
2
|
my $self = shift; |
1131
|
|
|
|
|
|
|
|
1132
|
1
|
|
|
|
|
62
|
foreach my $tag ( keys %{ $self->{'previous'}->{'content_obj'}->{'tags'} } ) { |
|
1
|
|
|
|
|
6
|
|
1133
|
0
|
|
|
|
|
0
|
$self->{'content_obj'}->{'tags'}{$tag} = $self->{'previous'}->{'content_obj'}->{'tags'}{$tag}; |
1134
|
|
|
|
|
|
|
} |
1135
|
|
|
|
|
|
|
|
1136
|
1
|
|
|
|
|
2
|
return; |
1137
|
|
|
|
|
|
|
} |
1138
|
|
|
|
|
|
|
|
1139
|
|
|
|
|
|
|
sub set_out_content { |
1140
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
1141
|
0
|
|
|
|
|
0
|
my ($out) = @_; |
1142
|
|
|
|
|
|
|
|
1143
|
0
|
|
|
|
|
0
|
$self->{'content_obj'}->set_out($out); |
1144
|
|
|
|
|
|
|
|
1145
|
0
|
|
|
|
|
0
|
return; |
1146
|
|
|
|
|
|
|
} |
1147
|
|
|
|
|
|
|
|
1148
|
|
|
|
|
|
|
sub get_out_content { |
1149
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
1150
|
|
|
|
|
|
|
|
1151
|
0
|
|
|
|
|
0
|
return $self->{'content_obj'}->{'out'}; |
1152
|
|
|
|
|
|
|
} |
1153
|
|
|
|
|
|
|
|
1154
|
|
|
|
|
|
|
sub set_tags { |
1155
|
1
|
|
|
1
|
|
280
|
my $self = shift; |
1156
|
1
|
|
|
|
|
3
|
my (%tags) = @_; |
1157
|
|
|
|
|
|
|
|
1158
|
1
|
|
|
|
|
8
|
$self->{'content_obj'}->set_tags(%tags); |
1159
|
|
|
|
|
|
|
|
1160
|
1
|
|
|
|
|
2
|
return; |
1161
|
|
|
|
|
|
|
} |
1162
|
|
|
|
|
|
|
|
1163
|
|
|
|
|
|
|
sub get_tag { |
1164
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
1165
|
0
|
|
|
|
|
0
|
my ($tag) = @_; |
1166
|
|
|
|
|
|
|
|
1167
|
0
|
|
|
|
|
0
|
return $self->{'content_obj'}->{'tags'}{$tag}; |
1168
|
|
|
|
|
|
|
} |
1169
|
|
|
|
|
|
|
|
1170
|
|
|
|
|
|
|
sub set_out { |
1171
|
1
|
|
|
1
|
|
1
|
my $self = shift; |
1172
|
|
|
|
|
|
|
|
1173
|
1
|
50
|
50
|
|
|
11
|
$self->{'file_nes_line'} = $self->{'file_souce'}[0] |
1174
|
|
|
|
|
|
|
if $self->{'file_souce'}[0] =~ /{:\s*NES/i || ''; |
1175
|
|
|
|
|
|
|
|
1176
|
1
|
|
|
|
|
7
|
my $interpret = nes_interpret->new(); |
1177
|
1
|
|
|
|
|
6
|
my @param = $interpret->replace_NES( $self->{'file_nes_line'} ); |
1178
|
|
|
|
|
|
|
|
1179
|
1
|
50
|
|
|
|
3
|
if ( $param[0] ) { |
1180
|
1
|
|
|
|
|
2
|
shift @{ $self->{'file_souce'} }; # eliminamos la primera linea |
|
1
|
|
|
|
|
2
|
|
1181
|
1
|
|
|
|
|
2
|
$self->{'script_ver'} = shift @param; |
1182
|
1
|
|
|
|
|
2
|
@{ $self->{'file_script'} } = @param; |
|
1
|
|
|
|
|
20
|
|
1183
|
|
|
|
|
|
|
} |
1184
|
|
|
|
|
|
|
|
1185
|
1
|
|
|
|
|
31
|
$self->{'out'} = ''; |
1186
|
1
|
|
|
|
|
7
|
foreach my $line (@{$self->{'file_souce'}}) { |
|
1
|
|
|
|
|
3
|
|
1187
|
11
|
|
|
|
|
15
|
$self->{'out'} .= $line; |
1188
|
|
|
|
|
|
|
} |
1189
|
|
|
|
|
|
|
|
1190
|
1
|
|
|
|
|
2
|
foreach my $script ( @{ $self->{'file_script'} } ) { |
|
1
|
|
|
|
|
3
|
|
1191
|
1
|
50
|
|
|
|
3
|
$script = 'none' if !$script; |
1192
|
1
|
50
|
|
|
|
4
|
next if $script eq 'none'; |
1193
|
|
|
|
|
|
|
} |
1194
|
|
|
|
|
|
|
|
1195
|
1
|
|
|
|
|
9
|
return; |
1196
|
|
|
|
|
|
|
} |
1197
|
|
|
|
|
|
|
|
1198
|
|
|
|
|
|
|
sub go { |
1199
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
1200
|
|
|
|
|
|
|
|
1201
|
0
|
|
|
|
|
0
|
$self->{'content_obj'}->go(); |
1202
|
0
|
|
|
|
|
0
|
$self->{'top_container'}->set_parent_dir($self->{'file_dir'}); |
1203
|
|
|
|
|
|
|
|
1204
|
0
|
|
|
|
|
0
|
return; |
1205
|
|
|
|
|
|
|
} |
1206
|
|
|
|
|
|
|
|
1207
|
|
|
|
|
|
|
sub interpret { |
1208
|
1
|
|
|
1
|
|
4
|
my $self = shift; |
1209
|
|
|
|
|
|
|
|
1210
|
1
|
|
|
|
|
5
|
$self->{'content_obj'}->interpret(); |
1211
|
|
|
|
|
|
|
|
1212
|
1
|
|
|
|
|
3
|
return; |
1213
|
|
|
|
|
|
|
} |
1214
|
|
|
|
|
|
|
|
1215
|
|
|
|
|
|
|
sub get_out { |
1216
|
2
|
|
|
2
|
|
1412
|
my $self = shift; |
1217
|
|
|
|
|
|
|
|
1218
|
2
|
|
|
|
|
12
|
return $self->{'content_obj'}->get_out(); |
1219
|
|
|
|
|
|
|
} |
1220
|
|
|
|
|
|
|
|
1221
|
|
|
|
|
|
|
sub out { |
1222
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
1223
|
|
|
|
|
|
|
|
1224
|
0
|
0
|
|
|
|
0
|
if ( ! $self->{'content_obj'}->{'is_binary'} ) { |
1225
|
0
|
|
|
|
|
0
|
while ( $self->{'content_obj'}->{'out'} =~ s/{:(\s*(\$|\*|\~|sql|\%|inc|\#|\&|nes).+?):}//gsio ) |
1226
|
|
|
|
|
|
|
{ |
1227
|
|
|
|
|
|
|
# impedir que los tags con error o no reemplazados aparezcan en la salida |
1228
|
|
|
|
|
|
|
} |
1229
|
|
|
|
|
|
|
} |
1230
|
|
|
|
|
|
|
|
1231
|
0
|
|
|
|
|
0
|
$self->{'content_obj'}->out(); |
1232
|
|
|
|
|
|
|
|
1233
|
0
|
|
|
|
|
0
|
return; |
1234
|
|
|
|
|
|
|
} |
1235
|
|
|
|
|
|
|
|
1236
|
|
|
|
|
|
|
} |
1237
|
|
|
|
|
|
|
|
1238
|
|
|
|
|
|
|
|
1239
|
|
|
|
|
|
|
{ |
1240
|
|
|
|
|
|
|
|
1241
|
|
|
|
|
|
|
package nes_content; |
1242
|
3
|
|
|
3
|
|
19
|
use vars qw(@ISA); |
|
3
|
|
|
|
|
11
|
|
|
3
|
|
|
|
|
4328
|
|
1243
|
|
|
|
|
|
|
@ISA = qw( Nes ); |
1244
|
|
|
|
|
|
|
|
1245
|
|
|
|
|
|
|
sub new { |
1246
|
1
|
|
|
1
|
|
2
|
my $class = shift; |
1247
|
1
|
|
|
|
|
5
|
my $self = $class->SUPER::new(); |
1248
|
1
|
|
|
|
|
2
|
my ($container) = @_; |
1249
|
|
|
|
|
|
|
|
1250
|
1
|
|
|
|
|
2
|
$self->{'container'} = $container; |
1251
|
1
|
|
|
|
|
2
|
$self->{'file_script'} = $self->{'container'}->{'file_script'}; |
1252
|
1
|
|
|
|
|
3
|
$self->{'out'} = $self->{'container'}->{'out'}; |
1253
|
|
|
|
|
|
|
|
1254
|
|
|
|
|
|
|
# default content type |
1255
|
1
|
|
|
|
|
2
|
$self->{'Content-type'} = "Content-type: text/html"; |
1256
|
1
|
|
|
|
|
3
|
$self->{'HTTP-status'} = "200 Ok"; |
1257
|
1
|
|
|
|
|
3
|
$self->{'X-Powered-By'} = "Nes/$VERSION"; |
1258
|
1
|
|
|
|
|
3
|
$self->{'TAG_HTTP-headers'} = ''; |
1259
|
|
|
|
|
|
|
|
1260
|
1
|
|
|
|
|
2
|
return $self; |
1261
|
|
|
|
|
|
|
} |
1262
|
|
|
|
|
|
|
|
1263
|
|
|
|
|
|
|
sub add_tags { |
1264
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
1265
|
0
|
|
|
|
|
0
|
my %tags; |
1266
|
0
|
|
|
|
|
0
|
(%tags) = @_; |
1267
|
|
|
|
|
|
|
|
1268
|
0
|
|
|
|
|
0
|
foreach my $tag ( keys %tags ) { |
1269
|
0
|
|
|
|
|
0
|
$self->{'tags'}{$tag} = $tags{$tag}; |
1270
|
|
|
|
|
|
|
} |
1271
|
|
|
|
|
|
|
|
1272
|
0
|
|
|
|
|
0
|
$self->{'TAG_HTTP-headers'} = $self->{'tags'}{'HTTP-headers'}; |
1273
|
0
|
|
|
|
|
0
|
$self->{'tags'}{'HTTP-headers'} = undef; |
1274
|
|
|
|
|
|
|
|
1275
|
0
|
|
|
|
|
0
|
return; |
1276
|
|
|
|
|
|
|
} |
1277
|
|
|
|
|
|
|
|
1278
|
|
|
|
|
|
|
sub set_tags { |
1279
|
1
|
|
|
1
|
|
1
|
my $self = shift; |
1280
|
1
|
|
|
|
|
2
|
my %tags; |
1281
|
1
|
|
|
|
|
2
|
(%tags) = @_; |
1282
|
|
|
|
|
|
|
|
1283
|
1
|
|
|
|
|
2
|
foreach my $tag ( keys %tags ) { |
1284
|
1
|
|
|
|
|
4
|
$self->{'tags'}{$tag} = $tags{$tag}; |
1285
|
|
|
|
|
|
|
} |
1286
|
|
|
|
|
|
|
|
1287
|
1
|
|
|
|
|
4
|
$self->{'TAG_HTTP-headers'} = $self->{'tags'}{'HTTP-headers'}; |
1288
|
1
|
|
|
|
|
2
|
$self->{'tags'}{'HTTP-headers'} = undef; |
1289
|
|
|
|
|
|
|
|
1290
|
1
|
|
|
|
|
2
|
return; |
1291
|
|
|
|
|
|
|
} |
1292
|
|
|
|
|
|
|
|
1293
|
|
|
|
|
|
|
sub interpret { |
1294
|
1
|
|
|
1
|
|
2
|
my $self = shift; |
1295
|
1
|
|
|
|
|
2
|
my %tags; |
1296
|
|
|
|
|
|
|
|
1297
|
1
|
|
|
|
|
4
|
$self->{'interpret'} = nes_interpret->new( $self->{'out'} ); |
1298
|
1
|
|
|
|
|
2
|
$self->{'out'} = $self->{'interpret'}->go( %{ $self->{'tags'} } ); |
|
1
|
|
|
|
|
6
|
|
1299
|
|
|
|
|
|
|
|
1300
|
1
|
|
|
|
|
2
|
return; |
1301
|
|
|
|
|
|
|
} |
1302
|
|
|
|
|
|
|
|
1303
|
|
|
|
|
|
|
sub get_out { |
1304
|
2
|
|
|
2
|
|
4
|
my $self = shift; |
1305
|
|
|
|
|
|
|
|
1306
|
2
|
|
|
|
|
8
|
return $self->{'out'}; |
1307
|
|
|
|
|
|
|
} |
1308
|
|
|
|
|
|
|
|
1309
|
|
|
|
|
|
|
sub set_out { |
1310
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
1311
|
0
|
|
|
|
|
0
|
my ($out) = @_; |
1312
|
|
|
|
|
|
|
|
1313
|
0
|
|
|
|
|
0
|
$self->{'out'} = $out; |
1314
|
|
|
|
|
|
|
|
1315
|
0
|
|
|
|
|
0
|
return; |
1316
|
|
|
|
|
|
|
} |
1317
|
|
|
|
|
|
|
|
1318
|
|
|
|
|
|
|
sub go_plugin_first { |
1319
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
1320
|
|
|
|
|
|
|
|
1321
|
0
|
|
|
|
|
0
|
my $self_file = $self->{'container'}->{'file_name'}; |
1322
|
0
|
|
|
|
|
0
|
my $top_file = $self->{'top_container'}->{'file'}; |
1323
|
|
|
|
|
|
|
|
1324
|
0
|
0
|
|
|
|
0
|
if ( $self_file eq $top_file ) { |
1325
|
0
|
|
|
|
|
0
|
foreach my $plugin ( @{$self->{'CFG'}{'auto_load_plugin_top_first'}} ) { |
|
0
|
|
|
|
|
0
|
|
1326
|
0
|
|
|
|
|
0
|
my $interpret = nes_interpret->new( $plugin ); |
1327
|
0
|
|
|
|
|
0
|
$plugin = $interpret->go( %{ $self->{'tags'} } ); |
|
0
|
|
|
|
|
0
|
|
1328
|
0
|
|
|
|
|
0
|
$self->do_script( $plugin ); |
1329
|
|
|
|
|
|
|
} |
1330
|
|
|
|
|
|
|
} |
1331
|
|
|
|
|
|
|
|
1332
|
0
|
|
|
|
|
0
|
foreach my $plugin ( @{$self->{'CFG'}{'auto_load_plugin_all_first'}} ) { |
|
0
|
|
|
|
|
0
|
|
1333
|
0
|
|
|
|
|
0
|
my $interpret = nes_interpret->new( $plugin ); |
1334
|
0
|
|
|
|
|
0
|
$plugin = $interpret->go( %{ $self->{'tags'} } ); |
|
0
|
|
|
|
|
0
|
|
1335
|
0
|
|
|
|
|
0
|
$self->do_script( $plugin ); |
1336
|
|
|
|
|
|
|
} |
1337
|
|
|
|
|
|
|
|
1338
|
0
|
|
|
|
|
0
|
return; |
1339
|
|
|
|
|
|
|
} |
1340
|
|
|
|
|
|
|
|
1341
|
|
|
|
|
|
|
sub go_plugin_last { |
1342
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
1343
|
|
|
|
|
|
|
|
1344
|
0
|
|
|
|
|
0
|
my $self_file = $self->{'container'}->{'file_name'}; |
1345
|
0
|
|
|
|
|
0
|
my $top_file = $self->{'top_container'}->{'file'}; |
1346
|
|
|
|
|
|
|
|
1347
|
0
|
0
|
|
|
|
0
|
if ( $self_file eq $top_file ) { |
1348
|
0
|
|
|
|
|
0
|
foreach my $plugin ( @{$self->{'CFG'}{'auto_load_plugin_top_last'}} ) { |
|
0
|
|
|
|
|
0
|
|
1349
|
0
|
|
|
|
|
0
|
my $interpret = nes_interpret->new( $plugin ); |
1350
|
0
|
|
|
|
|
0
|
$plugin = $interpret->go( %{ $self->{'tags'} } ); |
|
0
|
|
|
|
|
0
|
|
1351
|
0
|
|
|
|
|
0
|
$self->do_script( $plugin ); |
1352
|
|
|
|
|
|
|
} |
1353
|
|
|
|
|
|
|
} |
1354
|
|
|
|
|
|
|
|
1355
|
0
|
|
|
|
|
0
|
foreach my $plugin ( @{$self->{'CFG'}{'auto_load_plugin_all_last'}} ) { |
|
0
|
|
|
|
|
0
|
|
1356
|
0
|
|
|
|
|
0
|
my $interpret = nes_interpret->new( $plugin ); |
1357
|
0
|
|
|
|
|
0
|
$plugin = $interpret->go( %{ $self->{'tags'} } ); |
|
0
|
|
|
|
|
0
|
|
1358
|
0
|
|
|
|
|
0
|
$self->do_script( $plugin ); |
1359
|
|
|
|
|
|
|
} |
1360
|
|
|
|
|
|
|
|
1361
|
0
|
|
|
|
|
0
|
return; |
1362
|
|
|
|
|
|
|
} |
1363
|
|
|
|
|
|
|
|
1364
|
|
|
|
|
|
|
sub go { |
1365
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
1366
|
|
|
|
|
|
|
|
1367
|
0
|
|
|
|
|
0
|
$self->go_plugin_first(); |
1368
|
|
|
|
|
|
|
|
1369
|
0
|
|
|
|
|
0
|
foreach my $script ( @{ $self->{'file_script'} } ) { |
|
0
|
|
|
|
|
0
|
|
1370
|
0
|
0
|
|
|
|
0
|
if ( $script eq 'none' ) { |
1371
|
0
|
|
|
|
|
0
|
do { |
1372
|
0
|
|
|
|
|
0
|
my $nes_obj = Nes::Singleton->new(); |
1373
|
0
|
|
|
|
|
0
|
$nes_obj->out(); |
1374
|
|
|
|
|
|
|
}; |
1375
|
0
|
|
|
|
|
0
|
next; |
1376
|
|
|
|
|
|
|
} |
1377
|
0
|
0
|
|
|
|
0
|
if ( $script ) { |
1378
|
0
|
|
|
|
|
0
|
$self->do_script( $script ); |
1379
|
|
|
|
|
|
|
} |
1380
|
|
|
|
|
|
|
} |
1381
|
|
|
|
|
|
|
|
1382
|
0
|
|
|
|
|
0
|
$self->go_plugin_last(); |
1383
|
|
|
|
|
|
|
|
1384
|
0
|
|
|
|
|
0
|
return; |
1385
|
|
|
|
|
|
|
} |
1386
|
|
|
|
|
|
|
|
1387
|
|
|
|
|
|
|
sub do_script { |
1388
|
|
|
|
|
|
|
|
1389
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
1390
|
0
|
|
|
|
|
0
|
my ($script) = @_; |
1391
|
|
|
|
|
|
|
|
1392
|
0
|
|
|
|
|
0
|
$script = $self->{'top_container'}->get_file_path( $script ); |
1393
|
|
|
|
|
|
|
|
1394
|
0
|
|
|
|
|
0
|
my $script_dir = $script; |
1395
|
0
|
|
|
|
|
0
|
$script_dir =~ s/(.*)(\\|\/).*/$1/; |
1396
|
0
|
0
|
|
|
|
0
|
push( @INC, $script_dir ) if !$self->{'top_container'}->{'in_inc'}->{$script_dir}; |
1397
|
0
|
|
|
|
|
0
|
$self->{'top_container'}->{'in_inc'}->{$script_dir} = 1; |
1398
|
|
|
|
|
|
|
|
1399
|
0
|
|
|
|
|
0
|
my $return = do $script; |
1400
|
0
|
0
|
|
|
|
0
|
unless ($return) { |
1401
|
|
|
|
|
|
|
|
1402
|
|
|
|
|
|
|
# mod_perl muestra un error cuando se usa exit |
1403
|
0
|
0
|
|
|
|
0
|
return if $@ =~ /ModPerl::Util::exit/; |
1404
|
|
|
|
|
|
|
|
1405
|
0
|
0
|
|
|
|
0
|
warn "couldn't parse $script: $@" if $@; |
1406
|
0
|
0
|
|
|
|
0
|
warn "couldn't do $script: $!" unless defined $return; |
1407
|
0
|
0
|
|
|
|
0
|
warn "couldn't run $script" unless $return; |
1408
|
|
|
|
|
|
|
} |
1409
|
|
|
|
|
|
|
|
1410
|
0
|
|
|
|
|
0
|
return; |
1411
|
|
|
|
|
|
|
} |
1412
|
|
|
|
|
|
|
|
1413
|
|
|
|
|
|
|
sub out { |
1414
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
1415
|
|
|
|
|
|
|
|
1416
|
0
|
|
|
|
|
0
|
print $self->{'cookies'}->out; |
1417
|
0
|
|
|
|
|
0
|
print "X-Powered-By: $self->{'X-Powered-By'}\n"; |
1418
|
|
|
|
|
|
|
# print "Status: $self->{'HTTP-status'}\n" if !$self->{'tags'}{'HTTP-headers'}; |
1419
|
0
|
|
0
|
|
|
0
|
print $self->{'TAG_HTTP-headers'} || $self->{'Content-type'}."\n\n"; |
1420
|
0
|
|
|
|
|
0
|
print $self->{'out'}; |
1421
|
|
|
|
|
|
|
|
1422
|
|
|
|
|
|
|
} |
1423
|
|
|
|
|
|
|
|
1424
|
|
|
|
|
|
|
sub location { |
1425
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
1426
|
0
|
|
|
|
|
0
|
my ($location, $status) = @_; |
1427
|
0
|
0
|
|
|
|
0
|
$status = "302 Found" if !$status; |
1428
|
|
|
|
|
|
|
|
1429
|
0
|
|
|
|
|
0
|
print $self->{'cookies'}->out; |
1430
|
0
|
|
|
|
|
0
|
print "X-Powered-By: $self->{'X-Powered-By'}\n"; |
1431
|
0
|
|
|
|
|
0
|
print "Status: $status\n"; |
1432
|
0
|
|
|
|
|
0
|
print "Location: $location\n\n"; |
1433
|
0
|
|
|
|
|
0
|
exit; |
1434
|
|
|
|
|
|
|
} |
1435
|
|
|
|
|
|
|
|
1436
|
|
|
|
|
|
|
} |
1437
|
|
|
|
|
|
|
|
1438
|
|
|
|
|
|
|
{ |
1439
|
|
|
|
|
|
|
|
1440
|
|
|
|
|
|
|
package nes_html; |
1441
|
3
|
|
|
3
|
|
18
|
use vars qw(@ISA); |
|
3
|
|
|
|
|
5
|
|
|
3
|
|
|
|
|
377
|
|
1442
|
|
|
|
|
|
|
@ISA = qw( nes_content ); |
1443
|
|
|
|
|
|
|
|
1444
|
|
|
|
|
|
|
sub new { |
1445
|
1
|
|
|
1
|
|
2
|
my $class = shift; |
1446
|
1
|
|
|
|
|
2
|
my ( $container ) = @_; |
1447
|
1
|
|
|
|
|
9
|
my $self = $class->SUPER::new($container); |
1448
|
|
|
|
|
|
|
|
1449
|
1
|
|
|
|
|
2
|
$self->{'Content-type'} = "Content-type: text/html"; |
1450
|
|
|
|
|
|
|
|
1451
|
1
|
|
|
|
|
2
|
return $self; |
1452
|
|
|
|
|
|
|
} |
1453
|
|
|
|
|
|
|
|
1454
|
|
|
|
|
|
|
} |
1455
|
|
|
|
|
|
|
|
1456
|
|
|
|
|
|
|
|
1457
|
|
|
|
|
|
|
{ |
1458
|
|
|
|
|
|
|
|
1459
|
|
|
|
|
|
|
package nes_nsql; |
1460
|
3
|
|
|
3
|
|
18
|
use vars qw(@ISA); |
|
3
|
|
|
|
|
5
|
|
|
3
|
|
|
|
|
494
|
|
1461
|
|
|
|
|
|
|
@ISA = qw( nes_content ); |
1462
|
|
|
|
|
|
|
|
1463
|
|
|
|
|
|
|
sub new { |
1464
|
0
|
|
|
0
|
|
0
|
my $class = shift; |
1465
|
0
|
|
|
|
|
0
|
my ( $container ) = @_; |
1466
|
0
|
|
|
|
|
0
|
my $self = $class->SUPER::new($container); |
1467
|
|
|
|
|
|
|
|
1468
|
|
|
|
|
|
|
# @{ $self->{'file_script'} } = @scripts; |
1469
|
0
|
|
|
|
|
0
|
$self->{'Content-type'} = "Content-type: text/html"; |
1470
|
|
|
|
|
|
|
|
1471
|
0
|
|
|
|
|
0
|
return $self; |
1472
|
|
|
|
|
|
|
} |
1473
|
|
|
|
|
|
|
|
1474
|
|
|
|
|
|
|
} |
1475
|
|
|
|
|
|
|
|
1476
|
|
|
|
|
|
|
|
1477
|
|
|
|
|
|
|
{ |
1478
|
|
|
|
|
|
|
|
1479
|
|
|
|
|
|
|
package nes_txt; |
1480
|
3
|
|
|
3
|
|
14
|
use vars qw(@ISA); |
|
3
|
|
|
|
|
6
|
|
|
3
|
|
|
|
|
382
|
|
1481
|
|
|
|
|
|
|
@ISA = qw( nes_content ); |
1482
|
|
|
|
|
|
|
|
1483
|
|
|
|
|
|
|
sub new { |
1484
|
0
|
|
|
0
|
|
0
|
my $class = shift; |
1485
|
0
|
|
|
|
|
0
|
my ( $container ) = @_; |
1486
|
0
|
|
|
|
|
0
|
my $self = $class->SUPER::new($container); |
1487
|
|
|
|
|
|
|
|
1488
|
|
|
|
|
|
|
# @{ $self->{'file_script'} } = @scripts; |
1489
|
0
|
|
|
|
|
0
|
$self->{'Content-type'} = "Content-type: text/plain"; |
1490
|
|
|
|
|
|
|
|
1491
|
0
|
|
|
|
|
0
|
return $self; |
1492
|
|
|
|
|
|
|
} |
1493
|
|
|
|
|
|
|
|
1494
|
|
|
|
|
|
|
} |
1495
|
|
|
|
|
|
|
|
1496
|
|
|
|
|
|
|
|
1497
|
|
|
|
|
|
|
{ |
1498
|
|
|
|
|
|
|
|
1499
|
|
|
|
|
|
|
package nes_perl; |
1500
|
3
|
|
|
3
|
|
15
|
use vars qw(@ISA); |
|
3
|
|
|
|
|
4
|
|
|
3
|
|
|
|
|
724
|
|
1501
|
|
|
|
|
|
|
@ISA = qw( nes_content ); |
1502
|
|
|
|
|
|
|
|
1503
|
|
|
|
|
|
|
sub new { |
1504
|
0
|
|
|
0
|
|
0
|
my $class = shift; |
1505
|
0
|
|
|
|
|
0
|
my ( $container ) = @_; |
1506
|
0
|
|
|
|
|
0
|
my $self = $class->SUPER::new($container); |
1507
|
|
|
|
|
|
|
|
1508
|
|
|
|
|
|
|
# @{ $self->{'file_script'} } = @scripts; |
1509
|
0
|
|
|
|
|
0
|
$self->{'Content-type'} = "Content-type: text/html"; |
1510
|
|
|
|
|
|
|
|
1511
|
0
|
|
|
|
|
0
|
return $self; |
1512
|
|
|
|
|
|
|
} |
1513
|
|
|
|
|
|
|
|
1514
|
|
|
|
|
|
|
sub go { |
1515
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
1516
|
|
|
|
|
|
|
|
1517
|
0
|
0
|
|
|
|
0
|
$self->SUPER::go() if @{ $self->{'file_script'} }; |
|
0
|
|
|
|
|
0
|
|
1518
|
|
|
|
|
|
|
|
1519
|
0
|
|
|
|
|
0
|
require IO::String; |
1520
|
0
|
|
|
|
|
0
|
my $out; |
1521
|
0
|
|
|
|
|
0
|
my $str_fh = IO::String->new($out); |
1522
|
0
|
|
|
|
|
0
|
my $old_fh = select($str_fh); |
1523
|
|
|
|
|
|
|
|
1524
|
0
|
|
|
|
|
0
|
eval $self->{'out'}; |
1525
|
|
|
|
|
|
|
|
1526
|
0
|
0
|
|
|
|
0
|
select($old_fh) if defined $old_fh; |
1527
|
|
|
|
|
|
|
|
1528
|
0
|
|
|
|
|
0
|
$self->{'out'} = $out; |
1529
|
|
|
|
|
|
|
|
1530
|
0
|
|
|
|
|
0
|
return; |
1531
|
|
|
|
|
|
|
|
1532
|
|
|
|
|
|
|
} |
1533
|
|
|
|
|
|
|
|
1534
|
|
|
|
|
|
|
} |
1535
|
|
|
|
|
|
|
|
1536
|
|
|
|
|
|
|
|
1537
|
|
|
|
|
|
|
{ |
1538
|
|
|
|
|
|
|
|
1539
|
|
|
|
|
|
|
package nes_shell; |
1540
|
3
|
|
|
3
|
|
17
|
use vars qw(@ISA); |
|
3
|
|
|
|
|
5
|
|
|
3
|
|
|
|
|
1237
|
|
1541
|
|
|
|
|
|
|
@ISA = qw( nes_content ); |
1542
|
|
|
|
|
|
|
|
1543
|
|
|
|
|
|
|
sub new { |
1544
|
0
|
|
|
0
|
|
0
|
my $class = shift; |
1545
|
0
|
|
|
|
|
0
|
my ( $container ) = @_; |
1546
|
0
|
|
|
|
|
0
|
my $self = $class->SUPER::new($container); |
1547
|
|
|
|
|
|
|
|
1548
|
|
|
|
|
|
|
# @{ $self->{'file_script'} } = @scripts; |
1549
|
0
|
|
|
|
|
0
|
$self->{'Content-type'} = "Content-type: text/html"; |
1550
|
|
|
|
|
|
|
|
1551
|
0
|
|
|
|
|
0
|
return ($self); |
1552
|
|
|
|
|
|
|
} |
1553
|
|
|
|
|
|
|
|
1554
|
|
|
|
|
|
|
sub go { |
1555
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
1556
|
|
|
|
|
|
|
|
1557
|
0
|
0
|
|
|
|
0
|
$self->SUPER::go() if @{ $self->{'file_script'} }; |
|
0
|
|
|
|
|
0
|
|
1558
|
|
|
|
|
|
|
|
1559
|
0
|
0
|
|
|
|
0
|
if ( $MOD_PERL ) { |
1560
|
|
|
|
|
|
|
|
1561
|
0
|
|
|
|
|
0
|
require IPC::Run; |
1562
|
|
|
|
|
|
|
# IPC::Open2/Open3 no funcionan con mod_perl |
1563
|
|
|
|
|
|
|
|
1564
|
0
|
|
|
|
|
0
|
local $| = 1; |
1565
|
0
|
|
|
|
|
0
|
my @command = ( $self->{'CFG'}{'shell_cline'} ); |
1566
|
0
|
|
|
|
|
0
|
my ( $writer, $reader, $error ); |
1567
|
0
|
|
|
|
|
0
|
my $h = IPC::Run::start (\@command, \$writer, \$reader, \$error, IPC::Run::timeout( 10 )); |
1568
|
0
|
|
0
|
|
|
0
|
$writer = $self->{'out'} || "\n"; |
1569
|
0
|
|
|
|
|
0
|
IPC::Run::pump $h; |
1570
|
0
|
|
|
|
|
0
|
IPC::Run::finish $h; |
1571
|
0
|
|
|
|
|
0
|
$self->{'out'} = $reader; |
1572
|
|
|
|
|
|
|
|
1573
|
|
|
|
|
|
|
} else { |
1574
|
|
|
|
|
|
|
|
1575
|
0
|
|
|
|
|
0
|
require IPC::Open3; |
1576
|
0
|
|
|
|
|
0
|
my ( $writer, $reader, $error ); |
1577
|
0
|
|
|
|
|
0
|
my $pid = IPC::Open3::open3( $writer, $reader, $error, "$self->{'CFG'}{'shell_cline'}" ); |
1578
|
0
|
|
|
|
|
0
|
print $writer $self->{'out'}; |
1579
|
0
|
|
|
|
|
0
|
close $writer; |
1580
|
0
|
|
|
|
|
0
|
$self->{'out'} = ''; |
1581
|
0
|
|
|
|
|
0
|
while (<$reader>) { |
1582
|
0
|
|
|
|
|
0
|
$self->{'out'} .= $_; |
1583
|
|
|
|
|
|
|
} |
1584
|
0
|
|
|
|
|
0
|
close $reader; |
1585
|
0
|
|
|
|
|
0
|
waitpid( $pid, 0 ); |
1586
|
|
|
|
|
|
|
|
1587
|
|
|
|
|
|
|
} |
1588
|
|
|
|
|
|
|
|
1589
|
0
|
|
|
|
|
0
|
return; |
1590
|
|
|
|
|
|
|
} |
1591
|
|
|
|
|
|
|
|
1592
|
|
|
|
|
|
|
} |
1593
|
|
|
|
|
|
|
|
1594
|
|
|
|
|
|
|
|
1595
|
|
|
|
|
|
|
{ |
1596
|
|
|
|
|
|
|
|
1597
|
|
|
|
|
|
|
package nes_php; |
1598
|
3
|
|
|
3
|
|
16
|
use vars qw(@ISA); |
|
3
|
|
|
|
|
5
|
|
|
3
|
|
|
|
|
3247
|
|
1599
|
|
|
|
|
|
|
@ISA = qw( nes_content ); |
1600
|
|
|
|
|
|
|
|
1601
|
|
|
|
|
|
|
sub new { |
1602
|
0
|
|
|
0
|
|
0
|
my $class = shift; |
1603
|
0
|
|
|
|
|
0
|
my ( $container ) = @_; |
1604
|
0
|
|
|
|
|
0
|
my $self = $class->SUPER::new($container); |
1605
|
|
|
|
|
|
|
|
1606
|
|
|
|
|
|
|
# @{ $self->{'file_script'} } = @scripts; |
1607
|
0
|
|
|
|
|
0
|
$self->{'Content-type'} = "Content-type: text/html"; |
1608
|
0
|
|
|
|
|
0
|
$self->{'is_binary'} = 0; |
1609
|
0
|
|
|
|
|
0
|
$self->{'file_name'} = $self->{'container'}->{'file_name'}; |
1610
|
|
|
|
|
|
|
|
1611
|
0
|
|
|
|
|
0
|
$self->{'php_wrapper'} = 0; |
1612
|
0
|
0
|
|
|
|
0
|
$self->{'php_wrapper'} = 1 if $self->{'file_name'} eq $self->{'top_container'}->{'file'}; |
1613
|
|
|
|
|
|
|
|
1614
|
|
|
|
|
|
|
# damos soporte a include PHP al método GET |
1615
|
0
|
|
|
|
|
0
|
$self->{'start_script'} = ''."\n"; |
1616
|
|
|
|
|
|
|
|
1617
|
0
|
|
|
|
|
0
|
return ($self); |
1618
|
|
|
|
|
|
|
} |
1619
|
|
|
|
|
|
|
|
1620
|
|
|
|
|
|
|
sub go { |
1621
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
1622
|
|
|
|
|
|
|
|
1623
|
0
|
0
|
|
|
|
0
|
$self->SUPER::go() if !$self->{'php_wrapper'}; |
1624
|
|
|
|
|
|
|
|
1625
|
0
|
|
|
|
|
0
|
my $cline = $self->{'CFG'}{'php_cline'}; |
1626
|
0
|
0
|
|
|
|
0
|
$cline = $self->{'CFG'}{'php_cgi_cline'} if $self->{'php_wrapper'}; |
1627
|
|
|
|
|
|
|
|
1628
|
0
|
0
|
0
|
|
|
0
|
if ( $self->{'php_wrapper'} || $MOD_PERL ) { |
1629
|
|
|
|
|
|
|
# por seguridad |
1630
|
0
|
|
|
|
|
0
|
require Env::C; |
1631
|
0
|
|
|
|
|
0
|
foreach (keys %ENV) { |
1632
|
0
|
|
|
|
|
0
|
my $var = $ENV{$_}; |
1633
|
0
|
|
|
|
|
0
|
utl::no_nes_remove(\$var); |
1634
|
0
|
|
|
|
|
0
|
Env::C::setenv( $_, $var ); |
1635
|
|
|
|
|
|
|
} |
1636
|
|
|
|
|
|
|
} |
1637
|
|
|
|
|
|
|
|
1638
|
|
|
|
|
|
|
|
1639
|
0
|
0
|
|
|
|
0
|
if ( $MOD_PERL ) { |
1640
|
|
|
|
|
|
|
|
1641
|
0
|
|
|
|
|
0
|
local $| = 1; |
1642
|
0
|
|
|
|
|
0
|
require IPC::Run; |
1643
|
|
|
|
|
|
|
|
1644
|
0
|
|
|
|
|
0
|
my @command = split(' ', $cline ); |
1645
|
0
|
|
|
|
|
0
|
my ( $writer, $reader, $error ); |
1646
|
0
|
|
|
|
|
0
|
my $h = IPC::Run::start (\@command, \$writer, \$reader, \$error, IPC::Run::timeout( 30 )); |
1647
|
|
|
|
|
|
|
|
1648
|
0
|
0
|
|
|
|
0
|
if ( $self->{'php_wrapper'} ) { |
1649
|
0
|
0
|
|
|
|
0
|
if ( $ENV{'REQUEST_METHOD'} ne 'GET' ) { |
1650
|
0
|
0
|
|
|
|
0
|
if ( $self->{'query'}->{'save_buffer'} ) { |
1651
|
|
|
|
|
|
|
# todo: es posible que esto consuma mucha memoria en POST grandes |
1652
|
|
|
|
|
|
|
# $writer .= $buffer; sin IPC::Run::pump, pero haciendo pump da |
1653
|
|
|
|
|
|
|
# errores en mod_perl, comprobar |
1654
|
0
|
|
|
|
|
0
|
while ( my $buffer = $self->{'query'}->get_buffer ) { |
1655
|
0
|
|
|
|
|
0
|
$writer .= $buffer; |
1656
|
|
|
|
|
|
|
} |
1657
|
|
|
|
|
|
|
} else { |
1658
|
0
|
|
|
|
|
0
|
$writer = $self->{'query'}->get_buffer_raw; |
1659
|
|
|
|
|
|
|
} |
1660
|
|
|
|
|
|
|
} |
1661
|
|
|
|
|
|
|
} else { |
1662
|
|
|
|
|
|
|
# include PHP no soporta el metodo POST, de momento |
1663
|
0
|
|
|
|
|
0
|
$writer = $self->{'start_script'}.$self->{'out'}; |
1664
|
|
|
|
|
|
|
} |
1665
|
|
|
|
|
|
|
|
1666
|
0
|
|
|
|
|
0
|
IPC::Run::pump $h; |
1667
|
0
|
|
|
|
|
0
|
IPC::Run::finish $h; |
1668
|
0
|
|
|
|
|
0
|
$self->{'out'} = $reader; |
1669
|
0
|
0
|
|
|
|
0
|
warn $error if $error; |
1670
|
|
|
|
|
|
|
|
1671
|
|
|
|
|
|
|
} else { |
1672
|
|
|
|
|
|
|
|
1673
|
0
|
|
|
|
|
0
|
require IPC::Open3; |
1674
|
0
|
|
|
|
|
0
|
my ( $writer, $reader, $error, $out_error ); |
1675
|
0
|
|
|
|
|
0
|
my $pid = IPC::Open3::open3( $writer, $reader, $error, $cline ); |
1676
|
|
|
|
|
|
|
|
1677
|
0
|
|
|
|
|
0
|
binmode $writer; |
1678
|
0
|
|
|
|
|
0
|
binmode $reader; |
1679
|
|
|
|
|
|
|
|
1680
|
0
|
0
|
|
|
|
0
|
if ( $self->{'php_wrapper'} ) { |
1681
|
0
|
0
|
|
|
|
0
|
if ( $ENV{'REQUEST_METHOD'} ne 'GET' ) { |
1682
|
0
|
0
|
|
|
|
0
|
if ( $self->{'query'}->{'save_buffer'} ) { |
1683
|
0
|
|
|
|
|
0
|
while ( my $buffer = $self->{'query'}->get_buffer ) { |
1684
|
0
|
|
|
|
|
0
|
print $writer $buffer; |
1685
|
|
|
|
|
|
|
} |
1686
|
|
|
|
|
|
|
} else { |
1687
|
0
|
|
|
|
|
0
|
print $writer $self->{'query'}->get_buffer_raw; |
1688
|
|
|
|
|
|
|
} |
1689
|
|
|
|
|
|
|
} |
1690
|
|
|
|
|
|
|
} else { |
1691
|
|
|
|
|
|
|
# include PHP no soporta el metodo POST |
1692
|
0
|
|
|
|
|
0
|
print $writer $self->{'start_script'}.$self->{'out'}; |
1693
|
|
|
|
|
|
|
} |
1694
|
0
|
|
|
|
|
0
|
close $writer; |
1695
|
|
|
|
|
|
|
|
1696
|
0
|
|
|
|
|
0
|
my $buffer; |
1697
|
0
|
|
|
|
|
0
|
$self->{'out'} = ''; |
1698
|
0
|
|
|
|
|
0
|
while ( read($reader, $buffer, 8190) ) { |
1699
|
0
|
|
|
|
|
0
|
$self->{'out'} .= $buffer; |
1700
|
|
|
|
|
|
|
} |
1701
|
0
|
|
|
|
|
0
|
close $reader; |
1702
|
0
|
|
|
|
|
0
|
waitpid( $pid, 0 ); |
1703
|
|
|
|
|
|
|
} |
1704
|
|
|
|
|
|
|
|
1705
|
0
|
0
|
|
|
|
0
|
if ( $self->{'php_wrapper'} ) { |
1706
|
0
|
|
|
|
|
0
|
( $self->{'HTTP-headers'}, $self->{'out'} ) = split(/$CRLF$CRLF/, $self->{'out'},2); |
1707
|
0
|
|
|
|
|
0
|
$self->{'is_binary'} = $self->{'HTTP-headers'} !~ /Content-Type: text/is; |
1708
|
0
|
0
|
|
|
|
0
|
$self->SUPER::go() if !$self->{'is_binary'}; |
1709
|
|
|
|
|
|
|
} |
1710
|
|
|
|
|
|
|
|
1711
|
0
|
|
|
|
|
0
|
return; |
1712
|
|
|
|
|
|
|
} |
1713
|
|
|
|
|
|
|
|
1714
|
|
|
|
|
|
|
sub out { |
1715
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
1716
|
|
|
|
|
|
|
|
1717
|
0
|
|
|
|
|
0
|
binmode STDOUT; |
1718
|
0
|
|
|
|
|
0
|
print $self->{'cookies'}->out; |
1719
|
0
|
|
|
|
|
0
|
print "X-Powered-By: $self->{'X-Powered-By'}\n"; |
1720
|
|
|
|
|
|
|
# print "Status: $self->{'HTTP-status'}\n" if !$self->{'tags'}{'HTTP-headers'}; |
1721
|
|
|
|
|
|
|
# print $self->{'TAG_HTTP-headers'} || $self->{'Content-type'}."\n\n"; |
1722
|
0
|
0
|
|
|
|
0
|
print $self->{'HTTP-headers'}."\n\n" if !$self->{'TAG_HTTP-headers'}; |
1723
|
0
|
|
|
|
|
0
|
print $self->{'out'}; |
1724
|
|
|
|
|
|
|
|
1725
|
|
|
|
|
|
|
} |
1726
|
|
|
|
|
|
|
|
1727
|
|
|
|
|
|
|
} |
1728
|
|
|
|
|
|
|
|
1729
|
|
|
|
|
|
|
|
1730
|
|
|
|
|
|
|
{ |
1731
|
|
|
|
|
|
|
|
1732
|
|
|
|
|
|
|
package nes_python; |
1733
|
3
|
|
|
3
|
|
17
|
use vars qw(@ISA); |
|
3
|
|
|
|
|
5
|
|
|
3
|
|
|
|
|
1370
|
|
1734
|
|
|
|
|
|
|
@ISA = qw( nes_content ); |
1735
|
|
|
|
|
|
|
|
1736
|
|
|
|
|
|
|
sub new { |
1737
|
0
|
|
|
0
|
|
0
|
my $class = shift; |
1738
|
0
|
|
|
|
|
0
|
my ( $container ) = @_; |
1739
|
0
|
|
|
|
|
0
|
my $self = $class->SUPER::new($container); |
1740
|
|
|
|
|
|
|
|
1741
|
|
|
|
|
|
|
# @{ $self->{'file_script'} } = @scripts; |
1742
|
0
|
|
|
|
|
0
|
$self->{'Content-type'} = "Content-type: text/html"; |
1743
|
0
|
|
|
|
|
0
|
$self->{'file_name'} = $self->{'container'}->{'file_name'}; |
1744
|
|
|
|
|
|
|
# $self->{'file_name'} = $file_name; |
1745
|
|
|
|
|
|
|
|
1746
|
0
|
|
|
|
|
0
|
return ($self); |
1747
|
|
|
|
|
|
|
} |
1748
|
|
|
|
|
|
|
|
1749
|
|
|
|
|
|
|
sub go { |
1750
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
1751
|
|
|
|
|
|
|
|
1752
|
0
|
0
|
|
|
|
0
|
$self->SUPER::go() if @{ $self->{'file_script'} }; |
|
0
|
|
|
|
|
0
|
|
1753
|
|
|
|
|
|
|
|
1754
|
0
|
|
|
|
|
0
|
my $cline = $self->{'CFG'}{'python_cline'}; |
1755
|
0
|
|
|
|
|
0
|
my @command = ( $cline ); |
1756
|
|
|
|
|
|
|
|
1757
|
0
|
0
|
|
|
|
0
|
if ( $MOD_PERL ) { |
1758
|
|
|
|
|
|
|
|
1759
|
0
|
|
|
|
|
0
|
require IPC::Run; |
1760
|
|
|
|
|
|
|
# IPC::Open2/Open3 no funcionan con mod_perl |
1761
|
|
|
|
|
|
|
# *** php_cgi no funciona con IPC::Run |
1762
|
|
|
|
|
|
|
|
1763
|
0
|
|
|
|
|
0
|
local $| = 1; |
1764
|
0
|
|
|
|
|
0
|
my ( $writer, $reader, $error ); |
1765
|
0
|
|
|
|
|
0
|
my $h = IPC::Run::start (\@command, \$writer, \$reader, \$error, IPC::Run::timeout( 10 )); |
1766
|
0
|
|
0
|
|
|
0
|
$writer = $self->{'out'} || "\n"; |
1767
|
0
|
|
|
|
|
0
|
IPC::Run::pump $h; |
1768
|
0
|
|
|
|
|
0
|
IPC::Run::finish $h; |
1769
|
0
|
|
|
|
|
0
|
$self->{'out'} = $reader; |
1770
|
|
|
|
|
|
|
|
1771
|
|
|
|
|
|
|
} else { |
1772
|
|
|
|
|
|
|
|
1773
|
0
|
|
|
|
|
0
|
require IPC::Open2; |
1774
|
0
|
|
|
|
|
0
|
my ( $reader, $writer ); |
1775
|
0
|
|
|
|
|
0
|
my $pid = IPC::Open2::open2( $reader, $writer, "@command" ); |
1776
|
0
|
|
|
|
|
0
|
print $writer $self->{'out'}; |
1777
|
0
|
|
|
|
|
0
|
close $writer; |
1778
|
0
|
|
|
|
|
0
|
$self->{'out'} = ''; |
1779
|
0
|
|
|
|
|
0
|
while (<$reader>) { |
1780
|
0
|
|
|
|
|
0
|
$self->{'out'} .= $_; |
1781
|
|
|
|
|
|
|
} |
1782
|
0
|
|
|
|
|
0
|
close $reader; |
1783
|
0
|
|
|
|
|
0
|
waitpid( $pid, 0 ); |
1784
|
|
|
|
|
|
|
|
1785
|
|
|
|
|
|
|
} |
1786
|
|
|
|
|
|
|
|
1787
|
0
|
|
|
|
|
0
|
return; |
1788
|
|
|
|
|
|
|
} |
1789
|
|
|
|
|
|
|
|
1790
|
|
|
|
|
|
|
} |
1791
|
|
|
|
|
|
|
|
1792
|
|
|
|
|
|
|
{ |
1793
|
|
|
|
|
|
|
|
1794
|
|
|
|
|
|
|
package nes_js; |
1795
|
3
|
|
|
3
|
|
19
|
use vars qw(@ISA); |
|
3
|
|
|
|
|
5
|
|
|
3
|
|
|
|
|
382
|
|
1796
|
|
|
|
|
|
|
@ISA = qw( nes_content ); |
1797
|
|
|
|
|
|
|
|
1798
|
|
|
|
|
|
|
sub new { |
1799
|
0
|
|
|
0
|
|
0
|
my $class = shift; |
1800
|
0
|
|
|
|
|
0
|
my ( $container ) = @_; |
1801
|
0
|
|
|
|
|
0
|
my $self = $class->SUPER::new($container); |
1802
|
|
|
|
|
|
|
|
1803
|
0
|
|
|
|
|
0
|
$self->{'Content-type'} = "Content-type: text/javascript"; |
1804
|
|
|
|
|
|
|
|
1805
|
0
|
|
|
|
|
0
|
return $self; |
1806
|
|
|
|
|
|
|
} |
1807
|
|
|
|
|
|
|
|
1808
|
|
|
|
|
|
|
} |
1809
|
|
|
|
|
|
|
|
1810
|
|
|
|
|
|
|
# lo intenta como si fuese un archivo de texto plano |
1811
|
|
|
|
|
|
|
{ |
1812
|
|
|
|
|
|
|
|
1813
|
|
|
|
|
|
|
package nes_unknown; |
1814
|
3
|
|
|
3
|
|
16
|
use vars qw(@ISA); |
|
3
|
|
|
|
|
5
|
|
|
3
|
|
|
|
|
432
|
|
1815
|
|
|
|
|
|
|
@ISA = qw( nes_content ); |
1816
|
|
|
|
|
|
|
|
1817
|
|
|
|
|
|
|
sub new { |
1818
|
0
|
|
|
0
|
|
0
|
my $class = shift; |
1819
|
0
|
|
|
|
|
0
|
my ($container) = @_; |
1820
|
0
|
|
|
|
|
0
|
my $self = $class->SUPER::new($container); |
1821
|
|
|
|
|
|
|
|
1822
|
0
|
|
|
|
|
0
|
$self->{'Content-type'} = "Content-type: text/plain"; |
1823
|
|
|
|
|
|
|
|
1824
|
0
|
|
|
|
|
0
|
return ($self); |
1825
|
|
|
|
|
|
|
} |
1826
|
|
|
|
|
|
|
|
1827
|
|
|
|
|
|
|
} |
1828
|
|
|
|
|
|
|
|
1829
|
|
|
|
|
|
|
|
1830
|
|
|
|
|
|
|
{ |
1831
|
|
|
|
|
|
|
|
1832
|
|
|
|
|
|
|
package nes_interpret; |
1833
|
3
|
|
|
3
|
|
16
|
use vars qw(@ISA); |
|
3
|
|
|
|
|
6
|
|
|
3
|
|
|
|
|
954
|
|
1834
|
|
|
|
|
|
|
@ISA = qw( Nes ); |
1835
|
|
|
|
|
|
|
|
1836
|
|
|
|
|
|
|
sub new { |
1837
|
3
|
|
|
3
|
|
16
|
my $class = shift; |
1838
|
3
|
|
|
|
|
5
|
my ($out) = @_; |
1839
|
3
|
|
|
|
|
20
|
my $self = $class->SUPER::new(); |
1840
|
|
|
|
|
|
|
|
1841
|
3
|
|
|
|
|
7
|
$self->{'tag_start'} = '{:'; |
1842
|
3
|
|
|
|
|
6
|
$self->{'tag_end'} = ':}'; |
1843
|
3
|
|
|
|
|
22
|
$self->{'pre_start'} = '〈'; |
1844
|
3
|
|
|
|
|
4
|
$self->{'pre_end'} = '〉'; |
1845
|
|
|
|
|
|
|
|
1846
|
3
|
|
|
|
|
7
|
$self->{'tag_nes'} = 'NES'; |
1847
|
|
|
|
|
|
|
|
1848
|
3
|
|
|
|
|
7
|
$self->{'tag_var'} = '\$'; |
1849
|
3
|
|
|
|
|
10
|
$self->{'tag_env'} = '\*'; |
1850
|
3
|
|
|
|
|
7
|
$self->{'tag_expre'} = '\~'; |
1851
|
3
|
|
|
|
|
5
|
$self->{'tag_tpl'} = '\@'; |
1852
|
3
|
|
|
|
|
8
|
$self->{'tag_sql'} = 'sql'; |
1853
|
3
|
|
|
|
|
5
|
$self->{'tag_hash'} = '\%'; |
1854
|
3
|
|
|
|
|
6
|
$self->{'tag_field'} = '\@\$'; |
1855
|
3
|
|
|
|
|
7
|
$self->{'tag_include'} = 'include'; |
1856
|
3
|
|
|
|
|
6
|
$self->{'tag_comment'} = '\#'; |
1857
|
3
|
|
|
|
|
6
|
$self->{'tag_plugin'} = '\&'; |
1858
|
|
|
|
|
|
|
|
1859
|
3
|
|
|
|
|
5
|
$self->{'pre_subs_start'} = ':〉:'; |
1860
|
3
|
|
|
|
|
6
|
$self->{'pre_subs_end'} = ':◊:'; |
1861
|
|
|
|
|
|
|
|
1862
|
3
|
|
|
|
|
11
|
$self->{'out'} = $out; |
1863
|
3
|
100
|
|
|
|
22
|
$self->preformat() if $out; |
1864
|
|
|
|
|
|
|
|
1865
|
|
|
|
|
|
|
# banderas para eliminar de las variables código malicioso |
1866
|
3
|
|
|
|
|
8
|
$self->{'security_options'}{'no_sql'} = 0; |
1867
|
3
|
|
|
|
|
6
|
$self->{'security_options'}{'no_html'} = 1; |
1868
|
3
|
|
|
|
|
13
|
$self->{'security_options'}{'no_br'} = 0; |
1869
|
3
|
|
|
|
|
7
|
$self->{'security_options'}{'no_nes'} = 1; |
1870
|
|
|
|
|
|
|
|
1871
|
3
|
|
|
|
|
9
|
return $self; |
1872
|
|
|
|
|
|
|
} |
1873
|
|
|
|
|
|
|
|
1874
|
|
|
|
|
|
|
sub preformat { |
1875
|
2
|
|
|
2
|
|
4
|
my $self = shift; |
1876
|
|
|
|
|
|
|
|
1877
|
2
|
|
|
|
|
3
|
my $reg_block; |
1878
|
|
|
|
|
|
|
my $reg_param; |
1879
|
0
|
|
|
|
|
0
|
my $reg_tag; |
1880
|
0
|
|
|
|
|
0
|
my $all_tag; |
1881
|
0
|
|
|
|
|
0
|
my $reg_tag_plugin; |
1882
|
0
|
|
|
|
|
0
|
my $param_bracket; |
1883
|
0
|
|
|
|
|
0
|
my $comment; |
1884
|
|
|
|
|
|
|
|
1885
|
3
|
|
|
3
|
|
16
|
no warnings; |
|
3
|
|
|
|
|
6
|
|
|
3
|
|
|
|
|
158
|
|
1886
|
3
|
|
|
3
|
|
16
|
use re 'eval'; |
|
3
|
|
|
|
|
10
|
|
|
3
|
|
|
|
|
13795
|
|
1887
|
|
|
|
|
|
|
$reg_block = qr/ |
1888
|
|
|
|
|
|
|
( |
1889
|
2
|
|
|
|
|
13
|
$self->{'pre_start'} |
1890
|
|
|
|
|
|
|
(?> |
1891
|
|
|
|
|
|
|
(?> [^$self->{'pre_start'}$self->{'pre_end'}]+ ) |
1892
|
|
|
|
|
|
|
| |
1893
|
|
|
|
|
|
|
(??{$reg_block}) |
1894
|
|
|
|
|
|
|
)* |
1895
|
|
|
|
|
|
|
$self->{'pre_end'} |
1896
|
|
|
|
|
|
|
) |
1897
|
|
|
|
|
|
|
( ?) |
1898
|
2
|
|
|
|
|
126
|
/ix; |
1899
|
|
|
|
|
|
|
|
1900
|
|
|
|
|
|
|
$param_bracket = qr/ |
1901
|
|
|
|
|
|
|
( |
1902
|
|
|
|
|
|
|
\( # parametros con paréntesis |
1903
|
|
|
|
|
|
|
(?> |
1904
|
|
|
|
|
|
|
(?> [^\(\)]+ ) |
1905
|
|
|
|
|
|
|
| |
1906
|
|
|
|
|
|
|
(??{$param_bracket}) |
1907
|
|
|
|
|
|
|
)* |
1908
|
|
|
|
|
|
|
\) |
1909
|
|
|
|
|
|
|
| |
1910
|
|
|
|
|
|
|
[^\(\)]\S* # o sin paréntesis |
1911
|
|
|
|
|
|
|
) |
1912
|
2
|
|
|
|
|
18
|
/ix; |
1913
|
|
|
|
|
|
|
|
1914
|
2
|
|
|
|
|
183
|
$reg_tag = qr/ |
1915
|
|
|
|
|
|
|
^\s*$self->{'pre_start'}\s* |
1916
|
|
|
|
|
|
|
( |
1917
|
|
|
|
|
|
|
$self->{'tag_var'} | |
1918
|
|
|
|
|
|
|
$self->{'tag_env'} | |
1919
|
|
|
|
|
|
|
$self->{'tag_expre'} | |
1920
|
|
|
|
|
|
|
$self->{'tag_tpl'} | |
1921
|
|
|
|
|
|
|
$self->{'tag_sql'} | |
1922
|
|
|
|
|
|
|
$self->{'tag_field'} | |
1923
|
|
|
|
|
|
|
$self->{'tag_hash'} | |
1924
|
|
|
|
|
|
|
$self->{'tag_plugin'} | |
1925
|
|
|
|
|
|
|
$self->{'tag_include'} |
1926
|
|
|
|
|
|
|
)\s* |
1927
|
|
|
|
|
|
|
$param_bracket |
1928
|
|
|
|
|
|
|
(.*) |
1929
|
|
|
|
|
|
|
\s*$self->{'pre_end'}\s*$ |
1930
|
|
|
|
|
|
|
/isx; |
1931
|
|
|
|
|
|
|
|
1932
|
2
|
|
|
|
|
119
|
$reg_tag_plugin = qr{(?six) |
1933
|
|
|
|
|
|
|
^\s*$self->{'pre_start'}\s* |
1934
|
|
|
|
|
|
|
$self->{'tag_plugin'} |
1935
|
|
|
|
|
|
|
\s* |
1936
|
|
|
|
|
|
|
(\S+) # tag del plugin |
1937
|
|
|
|
|
|
|
\s* |
1938
|
|
|
|
|
|
|
$param_bracket # parametros |
1939
|
|
|
|
|
|
|
(.*) # code |
1940
|
|
|
|
|
|
|
$self->{'pre_end'}\s*$ |
1941
|
|
|
|
|
|
|
}; |
1942
|
|
|
|
|
|
|
|
1943
|
|
|
|
|
|
|
$comment = qr/ |
1944
|
|
|
|
|
|
|
( |
1945
|
1
|
|
|
|
|
6
|
$self->{'pre_start'}\s*$self->{'tag_comment'} |
1946
|
|
|
|
|
|
|
(?> |
1947
|
|
|
|
|
|
|
(?> [^$self->{'pre_start'}$self->{'pre_end'}]+ ) |
1948
|
|
|
|
|
|
|
| |
1949
|
|
|
|
|
|
|
(??{$reg_block}) |
1950
|
|
|
|
|
|
|
)* |
1951
|
|
|
|
|
|
|
$self->{'pre_end'} |
1952
|
|
|
|
|
|
|
) |
1953
|
|
|
|
|
|
|
( ?)(\s*) |
1954
|
2
|
|
|
|
|
91
|
/ix; |
1955
|
|
|
|
|
|
|
|
1956
|
2
|
|
|
|
|
11
|
$self->{'blocks'} = $reg_block; |
1957
|
2
|
|
|
|
|
6
|
$self->{'block_tag'} = $reg_tag; |
1958
|
2
|
|
|
|
|
3
|
$self->{'block_plugin'} = $reg_tag_plugin; |
1959
|
2
|
|
|
|
|
9
|
$self->{'param_bracket'} = $param_bracket; |
1960
|
2
|
|
|
|
|
3
|
$self->{'block_comment'} = $comment; |
1961
|
|
|
|
|
|
|
|
1962
|
2
|
|
|
|
|
26
|
$self->{'out'} =~ s/$self->{'pre_start'}/$self->{'pre_subs_start'}/g; |
1963
|
2
|
|
|
|
|
16
|
$self->{'out'} =~ s/$self->{'pre_end'}/$self->{'pre_subs_end'}/g; |
1964
|
|
|
|
|
|
|
|
1965
|
2
|
|
|
|
|
28
|
$self->{'out'} =~ s/$self->{'tag_start'}/$self->{'pre_start'}/g; |
1966
|
2
|
|
|
|
|
20
|
$self->{'out'} =~ s/$self->{'tag_end'}/$self->{'pre_end'}/g; |
1967
|
|
|
|
|
|
|
|
1968
|
|
|
|
|
|
|
# elimina los comentarios, eliminándolos aquí ahorramos CPU |
1969
|
2
|
|
|
|
|
16
|
$self->{'out'} =~ s/$self->{'block_comment'}//g; |
1970
|
|
|
|
|
|
|
|
1971
|
2
|
|
|
|
|
6
|
return; |
1972
|
|
|
|
|
|
|
} |
1973
|
|
|
|
|
|
|
|
1974
|
|
|
|
|
|
|
sub clear_tags { |
1975
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
1976
|
|
|
|
|
|
|
|
1977
|
0
|
|
|
|
|
0
|
$self->{'out'} =~ s/$self->{'blocks'}//g; |
1978
|
|
|
|
|
|
|
|
1979
|
|
|
|
|
|
|
# $self->{'out'} =~ s/$self->{'pre_start'}/$self->{'tag_start'}/g; |
1980
|
|
|
|
|
|
|
# $self->{'out'} =~ s/$self->{'pre_end'}/$self->{'tag_end'}/g; |
1981
|
|
|
|
|
|
|
# |
1982
|
|
|
|
|
|
|
# $self->{'out'} =~ s/$self->{'pre_subs_start'}/$self->{'pre_start'}/g; |
1983
|
|
|
|
|
|
|
# $self->{'out'} =~ s/$self->{'pre_subs_end'}/$self->{'pre_end'}/g; |
1984
|
|
|
|
|
|
|
|
1985
|
0
|
|
|
|
|
0
|
return; |
1986
|
|
|
|
|
|
|
} |
1987
|
|
|
|
|
|
|
|
1988
|
|
|
|
|
|
|
sub postformat { |
1989
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
1990
|
0
|
|
|
|
|
0
|
my ($out) = @_; |
1991
|
|
|
|
|
|
|
|
1992
|
0
|
|
|
|
|
0
|
$out =~ s/$self->{'pre_start'}/$self->{'tag_start'}/g; |
1993
|
0
|
|
|
|
|
0
|
$out =~ s/$self->{'pre_end'}/$self->{'tag_end'}/g; |
1994
|
|
|
|
|
|
|
|
1995
|
0
|
|
|
|
|
0
|
$out =~ s/$self->{'pre_subs_start'}/$self->{'pre_start'}/g; |
1996
|
0
|
|
|
|
|
0
|
$out =~ s/$self->{'pre_subs_end'}/$self->{'pre_end'}/g; |
1997
|
|
|
|
|
|
|
|
1998
|
0
|
|
|
|
|
0
|
return $out; |
1999
|
|
|
|
|
|
|
} |
2000
|
|
|
|
|
|
|
|
2001
|
|
|
|
|
|
|
sub postformat2 { |
2002
|
2
|
|
|
2
|
|
5
|
my $self = shift; |
2003
|
|
|
|
|
|
|
|
2004
|
2
|
|
|
|
|
25
|
$self->{'out'} =~ s/$self->{'pre_start'}/$self->{'tag_start'}/g; |
2005
|
2
|
|
|
|
|
24
|
$self->{'out'} =~ s/$self->{'pre_end'}/$self->{'tag_end'}/g; |
2006
|
|
|
|
|
|
|
|
2007
|
2
|
|
|
|
|
19
|
$self->{'out'} =~ s/$self->{'pre_subs_start'}/$self->{'pre_start'}/g; |
2008
|
2
|
|
|
|
|
18
|
$self->{'out'} =~ s/$self->{'pre_subs_end'}/$self->{'pre_end'}/g; |
2009
|
|
|
|
|
|
|
|
2010
|
2
|
|
|
|
|
6
|
return; |
2011
|
|
|
|
|
|
|
} |
2012
|
|
|
|
|
|
|
|
2013
|
|
|
|
|
|
|
sub go { |
2014
|
2
|
|
|
2
|
|
13
|
my $self = shift; |
2015
|
2
|
|
|
|
|
6
|
my (%tags) = @_; |
2016
|
|
|
|
|
|
|
|
2017
|
2
|
|
|
|
|
7
|
foreach my $tag ( keys %tags ) { |
2018
|
3
|
|
|
|
|
11
|
$self->{'tags'}{$tag} = $tags{$tag}; |
2019
|
|
|
|
|
|
|
} |
2020
|
|
|
|
|
|
|
|
2021
|
2
|
|
50
|
|
|
14
|
while ( $self->{'out'} =~ s/$self->{'blocks'}/$self->replace_block($1,($2 || ''),($3 || ''))/e ) { |
|
2
|
|
50
|
|
|
37
|
|
2022
|
|
|
|
|
|
|
|
2023
|
|
|
|
|
|
|
# con los "$space" se "intenta" dejar el HTML como estaba sin huecos |
2024
|
|
|
|
|
|
|
# $self->replace_block($1).$2.$3.$4 No funciona, $1... pierden su valor |
2025
|
|
|
|
|
|
|
# cuando vuelven de la función |
2026
|
|
|
|
|
|
|
# $2.$3.$4$self->replace_block($1) Sí funcionaría, curiosamente? |
2027
|
|
|
|
|
|
|
} |
2028
|
|
|
|
|
|
|
|
2029
|
2
|
|
|
|
|
9
|
$self->postformat2; |
2030
|
2
|
|
|
|
|
10
|
return $self->{'out'}; |
2031
|
|
|
|
|
|
|
} |
2032
|
|
|
|
|
|
|
|
2033
|
|
|
|
|
|
|
sub param_block { |
2034
|
3
|
|
|
3
|
|
6
|
my $self = shift; |
2035
|
3
|
|
|
|
|
6
|
my ($params,$skip_inclusion) = @_; |
2036
|
|
|
|
|
|
|
|
2037
|
3
|
50
|
|
|
|
8
|
return if !$params; |
2038
|
|
|
|
|
|
|
|
2039
|
|
|
|
|
|
|
# los parámetros pueden tener estos formatos: |
2040
|
|
|
|
|
|
|
# parámetro: |
2041
|
|
|
|
|
|
|
# sin paréntesis, sin comomillas, sin espacios, un sólo parámetro |
2042
|
|
|
|
|
|
|
# (parámetro,parámetro): |
2043
|
|
|
|
|
|
|
# con paréntesis, sin espacios, con o sin comillas, uno o más parámetros |
2044
|
|
|
|
|
|
|
# separados por comas |
2045
|
|
|
|
|
|
|
# ('parámetro uno','parámetro,dos'): |
2046
|
|
|
|
|
|
|
# comillas necesarias cuando hay espacios o comas en los parámetros. |
2047
|
|
|
|
|
|
|
# ('parámetro \'uno'): |
2048
|
|
|
|
|
|
|
# las comillas requieren barra invertida |
2049
|
|
|
|
|
|
|
# las comillas dobles no se utilizan, se reservan para su uso en futuras |
2050
|
|
|
|
|
|
|
# versiones, requieren barra invertida. |
2051
|
|
|
|
|
|
|
|
2052
|
|
|
|
|
|
|
# 1.02.2 soporte para dobles comillas en parámetros: |
2053
|
|
|
|
|
|
|
# ("parámetro \"uno\"", "parámetro 'dos'"): |
2054
|
|
|
|
|
|
|
|
2055
|
3
|
|
|
|
|
11
|
$params =~ s/^\s*\(//; |
2056
|
3
|
|
|
|
|
6
|
$params =~ s/\)\s*$//; |
2057
|
3
|
|
|
|
|
4
|
my @param; |
2058
|
3
|
|
|
|
|
6
|
my $this = ''; |
2059
|
3
|
|
|
|
|
29
|
while ( $params =~ s/\s*"([^\"\\]*(?:\\.[^\"\\]*)*)"\s*,?|\s*'([^\'\\]*(?:\\.[^\'\\]*)*)'\s*,?|\s*([^,\s]+)\s*,?|\s*,// ) { |
2060
|
3
|
|
|
|
|
10
|
$this = $+; |
2061
|
3
|
50
|
|
|
|
11
|
$this =~ s/\\'/'/g if $this; |
2062
|
3
|
50
|
|
|
|
8
|
$this =~ s/\\"/"/g if $this; |
2063
|
|
|
|
|
|
|
|
2064
|
3
|
50
|
|
|
|
10
|
if ( !$skip_inclusion ) { # Permite la inclusión en los parámetros |
2065
|
3
|
50
|
|
|
|
23
|
if ($this =~ /$self->{'pre_start'}/) { |
2066
|
0
|
|
|
|
|
0
|
my $interpret = nes_interpret->new( $self->postformat($this) ); |
2067
|
0
|
|
|
|
|
0
|
$this = $interpret->go( %{ $self->{'tags'} } ); |
|
0
|
|
|
|
|
0
|
|
2068
|
|
|
|
|
|
|
} |
2069
|
3
|
50
|
|
|
|
22
|
if ($this =~ /$self->{'tag_start'}/) { |
2070
|
0
|
|
|
|
|
0
|
my $interpret = nes_interpret->new( $this ); |
2071
|
0
|
|
|
|
|
0
|
$this = $interpret->go( %{ $self->{'tags'} } ); |
|
0
|
|
|
|
|
0
|
|
2072
|
|
|
|
|
|
|
} |
2073
|
|
|
|
|
|
|
} |
2074
|
|
|
|
|
|
|
|
2075
|
3
|
|
|
|
|
18
|
push @param, $this; |
2076
|
|
|
|
|
|
|
} |
2077
|
|
|
|
|
|
|
|
2078
|
3
|
|
|
|
|
21
|
return @param; |
2079
|
|
|
|
|
|
|
} |
2080
|
|
|
|
|
|
|
|
2081
|
|
|
|
|
|
|
sub replace_block { |
2082
|
2
|
|
|
2
|
|
3
|
my $self = shift; |
2083
|
2
|
|
|
|
|
23
|
my ( $block, $space1, $space2 ) = @_; |
2084
|
2
|
|
|
|
|
20
|
my ( $tag, $params, $code ) = $block =~ /$self->{'block_tag'}/; |
2085
|
2
|
|
|
|
|
4
|
my $out; |
2086
|
|
|
|
|
|
|
|
2087
|
2
|
50
|
|
|
|
153
|
if ( $tag =~ /^$self->{'tag_expre'}$/ ) { |
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
2088
|
|
|
|
|
|
|
|
2089
|
0
|
|
|
|
|
0
|
$out = $self->replace_expre( $code, $params ); |
2090
|
|
|
|
|
|
|
|
2091
|
|
|
|
|
|
|
} elsif ( $tag =~ /^$self->{'tag_tpl'}$/ ) { |
2092
|
|
|
|
|
|
|
|
2093
|
0
|
|
|
|
|
0
|
$out = $self->replace_tpl( $code, $self->param_block($params) ); |
2094
|
|
|
|
|
|
|
|
2095
|
|
|
|
|
|
|
} elsif ( $tag =~ /^$self->{'tag_sql'}$/ ) { |
2096
|
|
|
|
|
|
|
|
2097
|
0
|
|
|
|
|
0
|
$out = $self->replace_nsql( $code, $self->param_block($params,1) ); |
2098
|
|
|
|
|
|
|
|
2099
|
|
|
|
|
|
|
} elsif ( $tag =~ /^$self->{'tag_hash'}$/ ) { |
2100
|
|
|
|
|
|
|
|
2101
|
0
|
|
|
|
|
0
|
$out = $self->replace_hash( $code, $self->param_block($params) ); |
2102
|
|
|
|
|
|
|
|
2103
|
|
|
|
|
|
|
} elsif ( $tag =~ /^$self->{'tag_include'}$/ ) { |
2104
|
|
|
|
|
|
|
|
2105
|
0
|
|
|
|
|
0
|
$out = $self->replace_ind( $self->param_block($params) ); |
2106
|
|
|
|
|
|
|
|
2107
|
|
|
|
|
|
|
} elsif ( $tag =~ /^$self->{'tag_var'}$/ ) { |
2108
|
|
|
|
|
|
|
|
2109
|
2
|
|
|
|
|
10
|
$out = $self->replace_var( $self->param_block($params) ); |
2110
|
|
|
|
|
|
|
|
2111
|
|
|
|
|
|
|
} elsif ( $tag =~ /^$self->{'tag_env'}$/ ) { |
2112
|
|
|
|
|
|
|
|
2113
|
0
|
|
|
|
|
0
|
$out = $self->replace_env( $self->param_block($params) ); |
2114
|
|
|
|
|
|
|
|
2115
|
|
|
|
|
|
|
} elsif ( $tag =~ /^$self->{'tag_plugin'}$/ ) { |
2116
|
|
|
|
|
|
|
|
2117
|
0
|
|
|
|
|
0
|
$out = $self->replace_plugin( $block, $space1, $space2 ); |
2118
|
|
|
|
|
|
|
|
2119
|
|
|
|
|
|
|
} else { |
2120
|
|
|
|
|
|
|
|
2121
|
|
|
|
|
|
|
# si no conoce el tag lo deja como estaba |
2122
|
0
|
|
|
|
|
0
|
$block =~ s/(^\s*)($self->{'pre_start'})/$1$self->{'tag_start'}/g; |
2123
|
0
|
|
|
|
|
0
|
$block =~ s/($self->{'pre_end'})(\s*$)/$self->{'tag_end'}$2/g; |
2124
|
|
|
|
|
|
|
|
2125
|
0
|
|
|
|
|
0
|
return $block; |
2126
|
|
|
|
|
|
|
} |
2127
|
|
|
|
|
|
|
|
2128
|
2
|
|
|
|
|
8
|
$out .= $space1; |
2129
|
2
|
|
|
|
|
26
|
return $out; |
2130
|
|
|
|
|
|
|
} |
2131
|
|
|
|
|
|
|
|
2132
|
|
|
|
|
|
|
sub security { |
2133
|
2
|
|
|
2
|
|
4
|
my $self = shift; |
2134
|
2
|
|
|
|
|
11
|
my ($value, @security_options) = @_; |
2135
|
|
|
|
|
|
|
|
2136
|
2
|
50
|
|
|
|
19
|
return $value if $value =~ /^\d*$/; |
2137
|
|
|
|
|
|
|
|
2138
|
2
|
|
|
|
|
6
|
my $tmp_no_html = $self->{'security_options'}{'no_html'}; |
2139
|
2
|
|
|
|
|
6
|
my $tmp_no_nes = $self->{'security_options'}{'no_nes'}; |
2140
|
2
|
|
|
|
|
5
|
my $tmp_no_br = $self->{'security_options'}{'no_br'}; |
2141
|
2
|
|
|
|
|
5
|
my $tmp_no_sql = $self->{'security_options'}{'no_sql'}; |
2142
|
|
|
|
|
|
|
|
2143
|
2
|
|
|
|
|
20
|
my @yes_tag; |
2144
|
2
|
|
|
|
|
5
|
foreach my $key ( @security_options ) { |
2145
|
0
|
|
|
|
|
0
|
my $val = 1; |
2146
|
0
|
0
|
|
|
|
0
|
if ($key =~ /^yes_tag_(.*)/) { |
2147
|
0
|
|
|
|
|
0
|
push(@yes_tag, $1); |
2148
|
|
|
|
|
|
|
} else { |
2149
|
0
|
0
|
|
|
|
0
|
$val = 0 if $key =~ /^yes_/i; |
2150
|
0
|
|
|
|
|
0
|
$key =~ s/^yes_/no_/; |
2151
|
0
|
|
|
|
|
0
|
$self->{'security_options'}{$key} = $val; |
2152
|
|
|
|
|
|
|
} |
2153
|
|
|
|
|
|
|
} |
2154
|
2
|
50
|
|
|
|
10
|
push(@yes_tag, 'br') if !$self->{'security_options'}{'no_br'}; |
2155
|
|
|
|
|
|
|
|
2156
|
2
|
50
|
|
|
|
15
|
$value = utl::quote($value) if $self->{'security_options'}{'no_sql'}; |
2157
|
2
|
50
|
|
|
|
14
|
$value = utl::no_nes($value) if $self->{'security_options'}{'no_nes'}; |
2158
|
2
|
50
|
|
|
|
20
|
$value = utl::no_html( $value, @yes_tag ) if $self->{'security_options'}{'no_html'}; |
2159
|
|
|
|
|
|
|
|
2160
|
2
|
|
|
|
|
6
|
$self->{'security_options'}{'no_html'} = $tmp_no_html; |
2161
|
2
|
|
|
|
|
5
|
$self->{'security_options'}{'no_nes'} = $tmp_no_nes; |
2162
|
2
|
|
|
|
|
5
|
$self->{'security_options'}{'no_br'} = $tmp_no_br; |
2163
|
2
|
|
|
|
|
4
|
$self->{'security_options'}{'no_sql'} = $tmp_no_sql; |
2164
|
|
|
|
|
|
|
|
2165
|
2
|
|
|
|
|
9
|
return $value; |
2166
|
|
|
|
|
|
|
} |
2167
|
|
|
|
|
|
|
|
2168
|
|
|
|
|
|
|
sub replace_NES { |
2169
|
1
|
|
|
1
|
|
2
|
my $self = shift; |
2170
|
1
|
|
|
|
|
2
|
my ($block) = @_; |
2171
|
|
|
|
|
|
|
|
2172
|
1
|
50
|
|
|
|
17
|
return if !$block =~ /$self->{'tag_start'}\s*$self->{'tag_nes'}/; |
2173
|
|
|
|
|
|
|
|
2174
|
1
|
|
|
|
|
26
|
my $tagnes = qr{(?ix) |
2175
|
|
|
|
|
|
|
$self->{'tag_start'}\s*$self->{'tag_nes'} |
2176
|
|
|
|
|
|
|
\s*([^\s]*)\s* # vesión |
2177
|
|
|
|
|
|
|
(.*) # parametros |
2178
|
|
|
|
|
|
|
\s* |
2179
|
|
|
|
|
|
|
$self->{'tag_end'} |
2180
|
|
|
|
|
|
|
}; |
2181
|
|
|
|
|
|
|
|
2182
|
1
|
|
|
|
|
8
|
my ( $version, $params ) = $block =~ /$tagnes/; |
2183
|
1
|
|
|
|
|
4
|
my @param = $self->param_block($params); |
2184
|
|
|
|
|
|
|
|
2185
|
1
|
|
|
|
|
2
|
unshift( @param, $version ); |
2186
|
|
|
|
|
|
|
|
2187
|
1
|
|
|
|
|
5
|
return @param; |
2188
|
|
|
|
|
|
|
} |
2189
|
|
|
|
|
|
|
|
2190
|
|
|
|
|
|
|
sub replace_var { |
2191
|
2
|
|
|
2
|
|
5
|
my $self = shift; |
2192
|
2
|
|
|
|
|
5
|
my ($var, @security_options) = @_; |
2193
|
|
|
|
|
|
|
|
2194
|
2
|
|
|
|
|
12
|
return $self->security( $self->{'tags'}{$var}, @security_options ); |
2195
|
|
|
|
|
|
|
} |
2196
|
|
|
|
|
|
|
|
2197
|
|
|
|
|
|
|
sub replace_expre { |
2198
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
2199
|
0
|
|
|
|
|
0
|
my ( $code, $expre ) = @_; |
2200
|
|
|
|
|
|
|
|
2201
|
0
|
|
|
|
|
0
|
$expre =~ s/\$/:-:var:-:/g; |
2202
|
0
|
|
|
|
|
0
|
$expre =~ s/\*/:-:env:-:/g; |
2203
|
|
|
|
|
|
|
|
2204
|
0
|
|
|
|
|
0
|
my $nodef = undef; |
2205
|
0
|
|
|
|
|
0
|
my %vars; |
2206
|
0
|
|
|
|
|
0
|
my $reg = qr{(?x) ((:-:var:-:|:-:env:-:)\s*(\w*)) }; |
2207
|
|
|
|
|
|
|
|
2208
|
0
|
|
|
|
|
0
|
while ( $expre =~ /$reg/ ) { |
2209
|
0
|
|
|
|
|
0
|
my $tvar = $1; |
2210
|
0
|
|
|
|
|
0
|
my $tag = $2; |
2211
|
0
|
|
|
|
|
0
|
my $var = $3; |
2212
|
0
|
0
|
|
|
|
0
|
if ( $tag =~ /^:-:var:-:$/ ) { |
2213
|
|
|
|
|
|
|
|
2214
|
0
|
0
|
|
|
|
0
|
if ( defined $self->{'tags'}{$var} ) { |
2215
|
0
|
|
|
|
|
0
|
$vars{$var} = $self->{'tags'}{$var}; |
2216
|
0
|
|
|
|
|
0
|
$expre =~ s/$reg/\$vars\{\'$var\'\}/; |
2217
|
0
|
|
|
|
|
0
|
next; |
2218
|
|
|
|
|
|
|
} else { |
2219
|
0
|
|
|
|
|
0
|
$expre =~ s/$reg/\$nodef/; |
2220
|
0
|
|
|
|
|
0
|
next; |
2221
|
|
|
|
|
|
|
} |
2222
|
|
|
|
|
|
|
|
2223
|
|
|
|
|
|
|
} |
2224
|
0
|
0
|
|
|
|
0
|
if ( $tag =~ /^:-:env:-:$/ ) { |
2225
|
|
|
|
|
|
|
|
2226
|
0
|
0
|
|
|
|
0
|
if ( defined $self->{'top_container'}->{'nes_env'}{$var} ) { |
2227
|
0
|
|
|
|
|
0
|
$vars{$var} = $self->{'top_container'}->{'nes_env'}{$var}; |
2228
|
0
|
|
|
|
|
0
|
$expre =~ s/$reg/\$vars\{\'$var\'\}/; |
2229
|
0
|
|
|
|
|
0
|
next; |
2230
|
|
|
|
|
|
|
} else { |
2231
|
0
|
|
|
|
|
0
|
$expre =~ s/$reg/\$nodef/; |
2232
|
0
|
|
|
|
|
0
|
next; |
2233
|
|
|
|
|
|
|
} |
2234
|
|
|
|
|
|
|
|
2235
|
|
|
|
|
|
|
} |
2236
|
|
|
|
|
|
|
} |
2237
|
|
|
|
|
|
|
|
2238
|
0
|
0
|
|
|
|
0
|
return $code if ( eval $expre ); |
2239
|
0
|
|
|
|
|
0
|
return ''; |
2240
|
|
|
|
|
|
|
} |
2241
|
|
|
|
|
|
|
|
2242
|
|
|
|
|
|
|
sub replace_ind { |
2243
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
2244
|
0
|
|
|
|
|
0
|
my (@param) = @_; |
2245
|
|
|
|
|
|
|
|
2246
|
0
|
|
|
|
|
0
|
my $file = shift @param; |
2247
|
|
|
|
|
|
|
|
2248
|
0
|
|
|
|
|
0
|
my $obj_name = $file; |
2249
|
0
|
|
|
|
|
0
|
$obj_name =~ s/.*\///; |
2250
|
0
|
|
|
|
|
0
|
$obj_name =~ s/\.[^\.]*$//; |
2251
|
|
|
|
|
|
|
|
2252
|
0
|
0
|
|
|
|
0
|
unless ( $file ) { |
2253
|
0
|
|
|
|
|
0
|
warn "Void include in $self->{'container'}->{'file_name'}"; |
2254
|
0
|
|
|
|
|
0
|
return ''; |
2255
|
|
|
|
|
|
|
} |
2256
|
|
|
|
|
|
|
|
2257
|
0
|
|
|
|
|
0
|
my $count = 0; |
2258
|
0
|
|
|
|
|
0
|
$self->{'top_container'}->set_nes_env( 'q_obj_param_' . $count, $obj_name ); |
2259
|
0
|
|
|
|
|
0
|
$self->{'query'}->set( 'obj_param_' . $count, $obj_name ); |
2260
|
0
|
|
|
|
|
0
|
foreach my $this (@param) { |
2261
|
0
|
|
|
|
|
0
|
$count++; |
2262
|
0
|
|
|
|
|
0
|
$self->{'top_container'}->set_nes_env( 'q_' . $obj_name . '_param_' . $count, $this ); |
2263
|
0
|
|
|
|
|
0
|
$self->{'query'}->set( $obj_name . '_param_' . $count, $this ); |
2264
|
|
|
|
|
|
|
} |
2265
|
|
|
|
|
|
|
|
2266
|
0
|
|
|
|
|
0
|
my $container = nes_container->new($file); |
2267
|
0
|
|
|
|
|
0
|
$container->go(); |
2268
|
|
|
|
|
|
|
|
2269
|
0
|
|
|
|
|
0
|
$count = 0; |
2270
|
0
|
|
|
|
|
0
|
$self->{'top_container'}->del_nes_env( 'q_obj_param_' . $count ); |
2271
|
0
|
|
|
|
|
0
|
$self->{'query'}->del( 'obj_param_' . $count ); |
2272
|
0
|
|
|
|
|
0
|
foreach my $this (@param) { |
2273
|
0
|
|
|
|
|
0
|
$count++; |
2274
|
0
|
|
|
|
|
0
|
$self->{'top_container'}->del_nes_env( 'q_' . $obj_name . '_param_' . $count ); |
2275
|
0
|
|
|
|
|
0
|
$self->{'query'}->del( $obj_name . '_param_' . $count ); |
2276
|
|
|
|
|
|
|
} |
2277
|
|
|
|
|
|
|
|
2278
|
0
|
|
|
|
|
0
|
my $out = $container->get_out(); |
2279
|
0
|
|
|
|
|
0
|
$container->forget(); |
2280
|
|
|
|
|
|
|
|
2281
|
0
|
|
|
|
|
0
|
return $out; |
2282
|
|
|
|
|
|
|
} |
2283
|
|
|
|
|
|
|
|
2284
|
|
|
|
|
|
|
sub replace_hash { |
2285
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
2286
|
0
|
|
|
|
|
0
|
my ( $code, $name_hash ) = @_; |
2287
|
0
|
|
|
|
|
0
|
$name_hash =~ s/\s*//g; |
2288
|
|
|
|
|
|
|
|
2289
|
0
|
0
|
|
|
|
0
|
if ( $name_hash =~ /$self->{'tag_field'}/ ) { |
2290
|
0
|
|
|
|
|
0
|
$code =~ s/\s*(.+?)\.(\S*)\s*/$self->security($self->{'tags'}{$1}{$2})/egi; |
|
0
|
|
|
|
|
0
|
|
2291
|
0
|
|
|
|
|
0
|
return $code; |
2292
|
|
|
|
|
|
|
} |
2293
|
|
|
|
|
|
|
|
2294
|
0
|
|
|
|
|
0
|
my %hash = %{ $self->{'tags'}{$name_hash} }; |
|
0
|
|
|
|
|
0
|
|
2295
|
|
|
|
|
|
|
|
2296
|
0
|
|
|
|
|
0
|
my $out_code; |
2297
|
0
|
|
|
|
|
0
|
foreach my $key ( keys %hash ) { |
2298
|
0
|
|
|
|
|
0
|
my $tmp_code = $code; |
2299
|
0
|
|
|
|
|
0
|
$tmp_code =~ s/$self->{'pre_start'}\s*$self->{'tag_field'}\s*($name_hash\._name)\s*$self->{'pre_end'}/$self->security($key)/egi; |
|
0
|
|
|
|
|
0
|
|
2300
|
0
|
|
|
|
|
0
|
$tmp_code =~ s/$self->{'pre_start'}\s*$self->{'tag_field'}\s*($name_hash\._value)\s*$self->{'pre_end'}/$self->security($hash{$key})/egi; |
|
0
|
|
|
|
|
0
|
|
2301
|
0
|
|
|
|
|
0
|
$out_code .= $tmp_code; |
2302
|
|
|
|
|
|
|
} |
2303
|
|
|
|
|
|
|
|
2304
|
0
|
|
|
|
|
0
|
return $out_code; |
2305
|
|
|
|
|
|
|
} |
2306
|
|
|
|
|
|
|
|
2307
|
|
|
|
|
|
|
sub replace_nsql { |
2308
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
2309
|
0
|
|
|
|
|
0
|
my ( $code, $sql ) = @_; |
2310
|
|
|
|
|
|
|
|
2311
|
0
|
0
|
|
|
|
0
|
return if $sql !~ /^SELECT/; |
2312
|
|
|
|
|
|
|
|
2313
|
0
|
|
|
|
|
0
|
my $tmp_no_html = $self->{'security_options'}{'no_html'}; |
2314
|
0
|
|
|
|
|
0
|
my $tmp_no_nes = $self->{'security_options'}{'no_nes'}; |
2315
|
0
|
|
|
|
|
0
|
my $tmp_no_br = $self->{'security_options'}{'no_br'}; |
2316
|
0
|
|
|
|
|
0
|
my $tmp_no_sql = $self->{'security_options'}{'no_sql'}; |
2317
|
|
|
|
|
|
|
|
2318
|
0
|
0
|
|
|
|
0
|
if ( $sql =~ /$self->{'pre_start'}/ ) { |
2319
|
0
|
|
|
|
|
0
|
my $interpret = nes_interpret->new( $self->postformat($sql) ); |
2320
|
0
|
|
|
|
|
0
|
$interpret->{'security_options'}{'no_sql'} = 1; |
2321
|
0
|
|
|
|
|
0
|
$sql = $interpret->go( %{ $self->{'tags'} } ); |
|
0
|
|
|
|
|
0
|
|
2322
|
|
|
|
|
|
|
} |
2323
|
|
|
|
|
|
|
|
2324
|
0
|
|
|
|
|
0
|
my $name = $self->{'CFG'}{'DB_base'}; |
2325
|
0
|
|
|
|
|
0
|
my $user = $self->{'CFG'}{'DB_user'}; |
2326
|
0
|
|
|
|
|
0
|
my $pass = $self->{'CFG'}{'DB_pass'}; |
2327
|
0
|
|
|
|
|
0
|
my $driver = $self->{'CFG'}{'DB_driver'}; |
2328
|
0
|
|
|
|
|
0
|
my $host = $self->{'CFG'}{'DB_host'}; |
2329
|
0
|
|
|
|
|
0
|
my $port = $self->{'CFG'}{'DB_port'}; |
2330
|
|
|
|
|
|
|
|
2331
|
0
|
|
|
|
|
0
|
require Nes::DB; |
2332
|
0
|
|
|
|
|
0
|
my $obj_name = $self->{'query'}->{'q'}{'obj_param_0'}; |
2333
|
0
|
0
|
|
|
|
0
|
if ( $self->{'container'}->{'type'} eq 'nsql' ) { |
2334
|
0
|
|
0
|
|
|
0
|
$name = $self->{'query'}->{'q'}{ $obj_name . '_param_1' } || $self->{'CFG'}{'DB_base'}; |
2335
|
0
|
|
0
|
|
|
0
|
$user = $self->{'query'}->{'q'}{ $obj_name . '_param_2' } || $self->{'CFG'}{'DB_user'}; |
2336
|
0
|
|
0
|
|
|
0
|
$pass = $self->{'query'}->{'q'}{ $obj_name . '_param_3' } || $self->{'CFG'}{'DB_pass'}; |
2337
|
0
|
|
0
|
|
|
0
|
$driver = $self->{'query'}->{'q'}{ $obj_name . '_param_4' } || $self->{'CFG'}{'DB_driver'}; |
2338
|
0
|
|
0
|
|
|
0
|
$host = $self->{'query'}->{'q'}{ $obj_name . '_param_5' } || $self->{'CFG'}{'DB_host'}; |
2339
|
0
|
|
0
|
|
|
0
|
$port = $self->{'query'}->{'q'}{ $obj_name . '_param_6' } || $self->{'CFG'}{'DB_port'}; |
2340
|
|
|
|
|
|
|
} |
2341
|
|
|
|
|
|
|
|
2342
|
0
|
|
|
|
|
0
|
my $base = Nes::DB->new( $name, $user, $pass, $driver, $host, $port ); |
2343
|
0
|
|
|
|
|
0
|
my @result = $base->sen_select($sql); |
2344
|
|
|
|
|
|
|
|
2345
|
0
|
|
|
|
|
0
|
$self->{'top_container'}->set_nes_env( 'DBnes_error_last_error', $base->{'errstr'} ); |
2346
|
0
|
|
|
|
|
0
|
$self->{'top_container'}->set_nes_env( 'DBnes_rows', $base->{'rows'} ); |
2347
|
|
|
|
|
|
|
|
2348
|
0
|
|
|
|
|
0
|
$self->{'security_options'}{'no_nes'} = 1; |
2349
|
0
|
|
|
|
|
0
|
$self->{'security_options'}{'no_html'} = 1; |
2350
|
|
|
|
|
|
|
|
2351
|
0
|
|
|
|
|
0
|
my $out_code; |
2352
|
0
|
|
|
|
|
0
|
foreach my $reg (@result) { |
2353
|
0
|
|
|
|
|
0
|
my $tmp_code = $code; |
2354
|
0
|
|
|
|
|
0
|
$tmp_code =~ s/$self->{'pre_start'}\s*$self->{'tag_field'}\s*($self->{'param_bracket'})\s*$self->{'pre_end'}/$self->replace_field($reg,'\S*',$1)/egi; |
|
0
|
|
|
|
|
0
|
|
2355
|
0
|
|
|
|
|
0
|
$out_code .= $tmp_code; |
2356
|
|
|
|
|
|
|
} |
2357
|
|
|
|
|
|
|
|
2358
|
0
|
|
|
|
|
0
|
$self->{'security_options'}{'no_html'} = $tmp_no_html; |
2359
|
0
|
|
|
|
|
0
|
$self->{'security_options'}{'no_nes'} = $tmp_no_nes; |
2360
|
0
|
|
|
|
|
0
|
$self->{'security_options'}{'no_br'} = $tmp_no_br; |
2361
|
0
|
|
|
|
|
0
|
$self->{'security_options'}{'no_sql'} = $tmp_no_sql; |
2362
|
|
|
|
|
|
|
|
2363
|
0
|
|
|
|
|
0
|
return $out_code; |
2364
|
|
|
|
|
|
|
} |
2365
|
|
|
|
|
|
|
|
2366
|
|
|
|
|
|
|
sub replace_tpl { |
2367
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
2368
|
0
|
|
|
|
|
0
|
my ( $code, $name ) = @_; |
2369
|
|
|
|
|
|
|
|
2370
|
0
|
|
|
|
|
0
|
my $out_code; |
2371
|
0
|
|
|
|
|
0
|
foreach my $reg ( @{ $self->{'tags'}{$name} } ) { |
|
0
|
|
|
|
|
0
|
|
2372
|
0
|
|
|
|
|
0
|
my $tmp_code = $code; |
2373
|
0
|
|
|
|
|
0
|
$tmp_code =~ s/$self->{'pre_start'}\s*$self->{'tag_field'}\s*($self->{'param_bracket'})\s*$self->{'pre_end'}/$self->replace_field($reg,$name,$1)/egi; |
|
0
|
|
|
|
|
0
|
|
2374
|
0
|
|
|
|
|
0
|
$out_code .= $tmp_code; |
2375
|
|
|
|
|
|
|
} |
2376
|
|
|
|
|
|
|
|
2377
|
0
|
|
|
|
|
0
|
return $out_code; |
2378
|
|
|
|
|
|
|
} |
2379
|
|
|
|
|
|
|
|
2380
|
|
|
|
|
|
|
sub replace_field { |
2381
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
2382
|
0
|
|
|
|
|
0
|
my ( $reg, $name, $params ) = @_; |
2383
|
0
|
|
|
|
|
0
|
my @param = $self->param_block($params); |
2384
|
|
|
|
|
|
|
|
2385
|
0
|
|
|
|
|
0
|
my $var = shift @param; |
2386
|
0
|
|
|
|
|
0
|
$var =~ s/$name\.//; |
2387
|
|
|
|
|
|
|
|
2388
|
0
|
|
|
|
|
0
|
return $self->security($reg->{$var},@param); |
2389
|
|
|
|
|
|
|
} |
2390
|
|
|
|
|
|
|
|
2391
|
|
|
|
|
|
|
sub replace_env { |
2392
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
2393
|
0
|
|
|
|
|
0
|
my ($var, @security_options) = @_; |
2394
|
|
|
|
|
|
|
|
2395
|
0
|
|
|
|
|
0
|
my $tmp_no_html = $self->{'security_options'}{'no_html'}; |
2396
|
0
|
|
|
|
|
0
|
my $tmp_no_nes = $self->{'security_options'}{'no_nes'}; |
2397
|
|
|
|
|
|
|
|
2398
|
|
|
|
|
|
|
# comportamiento por defecto: |
2399
|
0
|
0
|
|
|
|
0
|
$self->{'security_options'}{'no_html'} = 1 if $var =~ /^q_/; |
2400
|
0
|
0
|
|
|
|
0
|
$self->{'security_options'}{'no_nes'} = 1 if $var =~ /^q_/; |
2401
|
|
|
|
|
|
|
|
2402
|
0
|
|
|
|
|
0
|
$var = $self->security( $self->{'top_container'}->get_nes_env($var), @security_options ); |
2403
|
|
|
|
|
|
|
|
2404
|
0
|
|
|
|
|
0
|
$self->{'security_options'}{'no_html'} = $tmp_no_html; |
2405
|
0
|
|
|
|
|
0
|
$self->{'security_options'}{'no_nes'} = $tmp_no_nes; |
2406
|
|
|
|
|
|
|
|
2407
|
0
|
|
|
|
|
0
|
return $var; |
2408
|
|
|
|
|
|
|
} |
2409
|
|
|
|
|
|
|
|
2410
|
|
|
|
|
|
|
sub replace_plugin { |
2411
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
2412
|
0
|
|
|
|
|
0
|
my ( $block, $space1, $space2 ) = @_; |
2413
|
0
|
|
|
|
|
0
|
my ( $tag, $params, $code ) = $block =~ /$self->{'block_plugin'}/; |
2414
|
0
|
|
|
|
|
0
|
my $out; |
2415
|
0
|
|
|
|
|
0
|
my ( @register_tags ) = $self->{'register'}->get_tags(); |
2416
|
|
|
|
|
|
|
|
2417
|
0
|
|
|
|
|
0
|
foreach my $tag_plugin ( @register_tags ) { |
2418
|
0
|
0
|
|
|
|
0
|
if ( $tag =~ /^$tag_plugin$/i ) { |
2419
|
0
|
|
|
|
|
0
|
my $handler = $self->{'register'}->get_tag_handler($tag_plugin); |
2420
|
0
|
0
|
|
|
|
0
|
if ( !$handler ) { |
2421
|
0
|
|
|
|
|
0
|
warn "No handler for plugin Tag: $tag_plugin "; |
2422
|
0
|
|
|
|
|
0
|
next; |
2423
|
|
|
|
|
|
|
} |
2424
|
0
|
|
|
|
|
0
|
$out = $handler->( $code,$self->param_block($params) ); |
2425
|
0
|
|
|
|
|
0
|
return $out; |
2426
|
|
|
|
|
|
|
} |
2427
|
|
|
|
|
|
|
} |
2428
|
|
|
|
|
|
|
|
2429
|
0
|
|
|
|
|
0
|
return ''; |
2430
|
|
|
|
|
|
|
} |
2431
|
|
|
|
|
|
|
|
2432
|
|
|
|
|
|
|
} |
2433
|
|
|
|
|
|
|
|
2434
|
|
|
|
|
|
|
|
2435
|
|
|
|
|
|
|
{ |
2436
|
|
|
|
|
|
|
|
2437
|
|
|
|
|
|
|
package utl; |
2438
|
|
|
|
|
|
|
|
2439
|
|
|
|
|
|
|
sub get_file_path { |
2440
|
|
|
|
|
|
|
|
2441
|
3
|
|
|
3
|
|
3077
|
use FindBin qw($Bin $Script); |
|
3
|
|
|
|
|
3653
|
|
|
3
|
|
|
|
|
760
|
|
2442
|
0
|
|
0
|
0
|
|
0
|
my $file = $ENV{'PATH_TRANSLATED'} || $ENV{'SCRIPT_FILENAME'} || "$Bin\\$Script"; |
2443
|
|
|
|
|
|
|
|
2444
|
0
|
|
|
|
|
0
|
return $file; |
2445
|
|
|
|
|
|
|
} |
2446
|
|
|
|
|
|
|
|
2447
|
|
|
|
|
|
|
sub get_file_dir { |
2448
|
|
|
|
|
|
|
|
2449
|
3
|
|
|
3
|
|
24
|
use FindBin qw($Bin $Script); |
|
3
|
|
|
|
|
41
|
|
|
3
|
|
|
|
|
531
|
|
2450
|
2
|
|
33
|
2
|
|
28
|
my $dir = $ENV{'PATH_TRANSLATED'} || $ENV{'SCRIPT_FILENAME'} || "$Bin\\$Script"; |
2451
|
2
|
|
|
|
|
16
|
$dir =~ s/(.*)(\\|\/).*/$1/; |
2452
|
|
|
|
|
|
|
|
2453
|
2
|
|
|
|
|
7
|
return $dir; |
2454
|
|
|
|
|
|
|
} |
2455
|
|
|
|
|
|
|
|
2456
|
|
|
|
|
|
|
sub get_root_dir { |
2457
|
|
|
|
|
|
|
|
2458
|
3
|
|
|
3
|
|
19
|
use FindBin '$Bin'; |
|
3
|
|
|
|
|
6
|
|
|
3
|
|
|
|
|
1914
|
|
2459
|
2
|
|
|
2
|
|
29
|
my ($root_dir) = split( "$ENV{'PATH_INFO'}", $ENV{'PATH_TRANSLATED'} ); |
2460
|
2
|
|
33
|
|
|
10
|
my $dir = $root_dir || $Bin; # en entornos no cgi da el directorio en el que se ejecuta el script o directorio de trabajo |
2461
|
2
|
|
|
|
|
6
|
$dir =~ s/[\/\\]$//; |
2462
|
|
|
|
|
|
|
|
2463
|
2
|
|
|
|
|
6
|
return $dir; |
2464
|
|
|
|
|
|
|
} |
2465
|
|
|
|
|
|
|
|
2466
|
|
|
|
|
|
|
sub expires { |
2467
|
0
|
|
|
0
|
|
0
|
my ($expire) = @_; |
2468
|
|
|
|
|
|
|
|
2469
|
0
|
|
|
|
|
0
|
my (@MON) = qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/; |
2470
|
0
|
|
|
|
|
0
|
my (@WDAY) = qw/Sun Mon Tue Wed Thu Fri Sat/; |
2471
|
0
|
|
|
|
|
0
|
my (%formt) = ( |
2472
|
|
|
|
|
|
|
's' => 1, |
2473
|
|
|
|
|
|
|
'm' => 60, |
2474
|
|
|
|
|
|
|
'h' => 60 * 60, |
2475
|
|
|
|
|
|
|
'd' => 60 * 60 * 24, |
2476
|
|
|
|
|
|
|
'M' => 60 * 60 * 24 * 30, |
2477
|
|
|
|
|
|
|
'y' => 60 * 60 * 24 * 365 |
2478
|
|
|
|
|
|
|
); |
2479
|
|
|
|
|
|
|
|
2480
|
0
|
|
|
|
|
0
|
$expire =~ /(\-?\d*)(.)/; |
2481
|
0
|
|
|
|
|
0
|
my $second = $1; |
2482
|
0
|
|
|
|
|
0
|
my $factor = $2; |
2483
|
0
|
|
|
|
|
0
|
my $time = time + ( $second * $formt{$factor} ); |
2484
|
0
|
|
|
|
|
0
|
my ( $sec, $min, $hour, $mday, $mon, $year, $wday ) = gmtime($time); |
2485
|
0
|
|
|
|
|
0
|
$year += 1900; |
2486
|
|
|
|
|
|
|
|
2487
|
0
|
|
|
|
|
0
|
return sprintf( "%s, %02d-%s-%04d %02d:%02d:%02d GMT", $WDAY[$wday], $mday, $MON[$mon], $year, $hour, $min, $sec ); |
2488
|
|
|
|
|
|
|
} |
2489
|
|
|
|
|
|
|
|
2490
|
|
|
|
|
|
|
sub expires_time { |
2491
|
0
|
|
|
0
|
|
0
|
my ($expire) = @_; |
2492
|
|
|
|
|
|
|
|
2493
|
0
|
|
|
|
|
0
|
my (%formt) = ( |
2494
|
|
|
|
|
|
|
's' => 1, |
2495
|
|
|
|
|
|
|
'm' => 60, |
2496
|
|
|
|
|
|
|
'h' => 60 * 60, |
2497
|
|
|
|
|
|
|
'd' => 60 * 60 * 24, |
2498
|
|
|
|
|
|
|
'M' => 60 * 60 * 24 * 30, |
2499
|
|
|
|
|
|
|
'y' => 60 * 60 * 24 * 365 |
2500
|
|
|
|
|
|
|
); |
2501
|
|
|
|
|
|
|
|
2502
|
0
|
|
|
|
|
0
|
$expire =~ /(\-?\d*)(.)/; |
2503
|
0
|
|
0
|
|
|
0
|
my $second = $1 || 0; |
2504
|
0
|
|
0
|
|
|
0
|
my $factor = $2 || 's'; |
2505
|
0
|
|
|
|
|
0
|
my $time = $second * $formt{$factor}; |
2506
|
|
|
|
|
|
|
|
2507
|
0
|
|
|
|
|
0
|
return $time; |
2508
|
|
|
|
|
|
|
} |
2509
|
|
|
|
|
|
|
|
2510
|
|
|
|
|
|
|
sub escape { |
2511
|
0
|
|
|
0
|
|
0
|
my $string = shift; |
2512
|
|
|
|
|
|
|
|
2513
|
0
|
|
|
|
|
0
|
$string =~ s/(.)/'%'.sprintf("%X", ord($1))/ge; |
|
0
|
|
|
|
|
0
|
|
2514
|
|
|
|
|
|
|
|
2515
|
0
|
|
|
|
|
0
|
return $string; |
2516
|
|
|
|
|
|
|
} |
2517
|
|
|
|
|
|
|
|
2518
|
|
|
|
|
|
|
sub js_escape { |
2519
|
0
|
|
|
0
|
|
0
|
my $string = shift; |
2520
|
|
|
|
|
|
|
|
2521
|
3
|
|
|
3
|
|
124229
|
use Encode qw(encode FB_PERLQQ); |
|
3
|
|
|
|
|
107628
|
|
|
3
|
|
|
|
|
3545
|
|
2522
|
0
|
|
|
|
|
0
|
$string =~ s{([\x00-\x29\x2C\x3A-\x40\x5B-\x5E\x60\x7B-\x7F])} |
2523
|
0
|
|
|
|
|
0
|
{'%' . uc(unpack('H2', $1))}eg; # XXX JavaScript compatible |
2524
|
0
|
|
|
0
|
|
0
|
$string = encode( 'ascii', $string, sub { sprintf '%%u%04X', $_[0] } ); |
|
0
|
|
|
|
|
0
|
|
2525
|
|
|
|
|
|
|
|
2526
|
0
|
|
|
|
|
0
|
return $string; |
2527
|
|
|
|
|
|
|
} |
2528
|
|
|
|
|
|
|
|
2529
|
|
|
|
|
|
|
sub js_unescape { |
2530
|
0
|
|
|
0
|
|
0
|
my $escaped = shift; |
2531
|
|
|
|
|
|
|
|
2532
|
0
|
|
|
|
|
0
|
$escaped =~ s/%u([0-9a-f]+)/chr(hex($1))/eig; |
|
0
|
|
|
|
|
0
|
|
2533
|
0
|
|
|
|
|
0
|
$escaped =~ s/%([0-9a-f]{2})/chr(hex($1))/eig; |
|
0
|
|
|
|
|
0
|
|
2534
|
|
|
|
|
|
|
|
2535
|
0
|
|
|
|
|
0
|
return $escaped; |
2536
|
|
|
|
|
|
|
} |
2537
|
|
|
|
|
|
|
|
2538
|
|
|
|
|
|
|
sub quote { |
2539
|
0
|
|
|
0
|
|
0
|
my ($value) = @_; |
2540
|
|
|
|
|
|
|
|
2541
|
0
|
|
|
|
|
0
|
require DBI; |
2542
|
|
|
|
|
|
|
|
2543
|
0
|
|
|
|
|
0
|
return DBD::_::db->quote($value); |
2544
|
|
|
|
|
|
|
} |
2545
|
|
|
|
|
|
|
|
2546
|
|
|
|
|
|
|
sub no_html { |
2547
|
2
|
|
|
2
|
|
9
|
my ( $value, @yes_tag ) = @_; |
2548
|
|
|
|
|
|
|
|
2549
|
2
|
50
|
|
|
|
18
|
return if !$value; |
2550
|
|
|
|
|
|
|
|
2551
|
2
|
|
|
|
|
4
|
my $tags = ''; |
2552
|
2
|
|
|
|
|
4
|
foreach my $tag (@yes_tag) { |
2553
|
2
|
|
|
|
|
10
|
$tags .= '\/?'.$tag.'\W|'; |
2554
|
|
|
|
|
|
|
} |
2555
|
2
|
|
|
|
|
10
|
$tags =~ s/\|$//; |
2556
|
|
|
|
|
|
|
|
2557
|
2
|
50
|
|
|
|
6
|
if (!$tags) { |
2558
|
0
|
|
|
|
|
0
|
$value =~ s/\</sg; |
2559
|
0
|
|
|
|
|
0
|
$value =~ s/\>/>/sg; |
2560
|
|
|
|
|
|
|
} else { |
2561
|
2
|
|
|
|
|
65
|
while ( $value =~ s/\<((?!$tags)[^\>\<]*)\>/<$1>/sig ) {} |
2562
|
|
|
|
|
|
|
} |
2563
|
|
|
|
|
|
|
|
2564
|
2
|
|
|
|
|
6
|
return $value; |
2565
|
|
|
|
|
|
|
} |
2566
|
|
|
|
|
|
|
|
2567
|
|
|
|
|
|
|
sub no_nes { |
2568
|
2
|
|
|
2
|
|
6
|
my ($value) = @_; |
2569
|
|
|
|
|
|
|
|
2570
|
2
|
50
|
|
|
|
8
|
return if !$value; |
2571
|
|
|
|
|
|
|
|
2572
|
2
|
|
|
|
|
24
|
my $tags = qr/ |
2573
|
|
|
|
|
|
|
\{: |
2574
|
|
|
|
|
|
|
( |
2575
|
|
|
|
|
|
|
\s* |
2576
|
|
|
|
|
|
|
(\$|\*|\~|sql|\%|inc|\#|\&|nes) |
2577
|
|
|
|
|
|
|
(.+?) |
2578
|
|
|
|
|
|
|
) |
2579
|
|
|
|
|
|
|
:\} |
2580
|
|
|
|
|
|
|
/six; |
2581
|
|
|
|
|
|
|
|
2582
|
2
|
|
|
|
|
18
|
while ( $value =~ s/$tags/{:$1:}/go ) {} |
2583
|
|
|
|
|
|
|
|
2584
|
2
|
|
|
|
|
10
|
return $value; |
2585
|
|
|
|
|
|
|
} |
2586
|
|
|
|
|
|
|
|
2587
|
|
|
|
|
|
|
sub no_nes_remove { |
2588
|
0
|
|
|
0
|
|
|
my ($data) = @_; |
2589
|
|
|
|
|
|
|
|
2590
|
0
|
|
|
|
|
|
my $start = '(\{|\%7B)(\:|\%3A)'; |
2591
|
0
|
|
|
|
|
|
my $end = '(?:\:|\%3A)(?:\%7D|\})'; |
2592
|
|
|
|
|
|
|
|
2593
|
0
|
|
|
|
|
|
$$data =~ s/$start/{_/gis; |
2594
|
0
|
|
|
|
|
|
$$data =~ s/$end/_}/gis; |
2595
|
|
|
|
|
|
|
|
2596
|
0
|
|
|
|
|
|
return; |
2597
|
|
|
|
|
|
|
} |
2598
|
|
|
|
|
|
|
|
2599
|
|
|
|
|
|
|
sub cleanup { |
2600
|
0
|
|
|
0
|
|
|
my (@vars) = @_; |
2601
|
|
|
|
|
|
|
|
2602
|
0
|
0
|
|
|
|
|
if ( $MOD_PERL2 ) { |
2603
|
0
|
|
|
|
|
|
require Apache2::RequestUtil; |
2604
|
0
|
|
|
|
|
|
require Apache2::RequestIO; |
2605
|
0
|
|
|
|
|
|
require APR::Pool; |
2606
|
0
|
|
|
|
|
|
Apache2::RequestUtil->request->pool->cleanup_register(\&utl::cleanup_callback, @vars); |
2607
|
|
|
|
|
|
|
|
2608
|
|
|
|
|
|
|
} |
2609
|
|
|
|
|
|
|
|
2610
|
0
|
0
|
|
|
|
|
if ( $MOD_PERL1 ) { |
2611
|
0
|
|
|
|
|
|
require Apache; |
2612
|
0
|
|
|
|
|
|
Apache->request->register_cleanup(\&utl::cleanup_callback, @vars); |
2613
|
|
|
|
|
|
|
} |
2614
|
|
|
|
|
|
|
|
2615
|
0
|
|
|
|
|
|
return 1; |
2616
|
|
|
|
|
|
|
} |
2617
|
|
|
|
|
|
|
|
2618
|
|
|
|
|
|
|
sub cleanup_callback { |
2619
|
0
|
|
|
0
|
|
|
my (@vars) = @_; |
2620
|
|
|
|
|
|
|
|
2621
|
0
|
|
|
|
|
|
foreach my $var (@vars) { |
2622
|
0
|
|
|
|
|
|
my $ref = ref $var; |
2623
|
0
|
0
|
0
|
|
|
|
undef $$var if $ref eq 'SCALAR' || $ref eq 'REF' ; |
2624
|
0
|
0
|
|
|
|
|
undef %$var if $ref eq 'HASH'; |
2625
|
0
|
0
|
|
|
|
|
undef @$var if $ref eq 'ARRAY'; |
2626
|
|
|
|
|
|
|
} |
2627
|
|
|
|
|
|
|
|
2628
|
0
|
|
|
|
|
|
return 1; |
2629
|
|
|
|
|
|
|
} |
2630
|
|
|
|
|
|
|
|
2631
|
|
|
|
|
|
|
} |
2632
|
|
|
|
|
|
|
|
2633
|
|
|
|
|
|
|
|
2634
|
|
|
|
|
|
|
|
2635
|
|
|
|
|
|
|
|
2636
|
|
|
|
|
|
|
1; |