File Coverage

blib/lib/Nes.pm
Criterion Covered Total %
statement 449 1327 33.8
branch 45 292 15.4
condition 9 75 12.0
subroutine 71 180 39.4
pod 0 4 0.0
total 574 1878 30.5


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/\
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;