← Back to branch summary

~ubuntu-branches/debian/sid/libembperl-perl/sid

« back to all changes in this revision

Viewing changes to Embperl/Syntax/SSI.pm

  • Committer: Bazaar Package Importer
  • Author(s): Angus Lees
  • Date: 2004-02-15 14:23:39 UTC
  • Revision ID: james.westby@ubuntu.com-20040215142339-n21gqf7mx9tmyb8d
Tags: upstream-2.0b10
Import upstream version 2.0b10

Show diffs side-by-side

added added

removed removed

Lines of Context:
Embperl/Syntax/SSI.pm
 
1
 
 
2
###################################################################################
 
3
#
 
4
#   Embperl - Copyright (c) 1997-2004 Gerald Richter / ECOS
 
5
#
 
6
#   You may distribute under the terms of either the GNU General Public
 
7
#   License or the Artistic License, as specified in the Perl README file.
 
8
#
 
9
#   THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR
 
10
#   IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
 
11
#   WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
 
12
#
 
13
#   $Id: SSI.pm,v 1.3 2004/01/23 06:50:57 richter Exp $
 
14
#
 
15
###################################################################################
 
16
 
 
17
package Embperl::Syntax::SSI ;
 
18
 
 
19
use Embperl::Syntax qw{:types} ;
 
20
use Embperl::Syntax::HTML ;
 
21
use File::Basename;
 
22
 
 
23
BEGIN { 
 
24
    local $^W = 0 ;
 
25
    require POSIX ;
 
26
 
 
27
    eval "use Apache::Constants qw(:common OPT_INCNOEXEC);" ;
 
28
    } ;
 
29
 
 
30
use strict ;
 
31
use vars qw{@ISA} ;
 
32
 
 
33
@ISA = qw(Embperl::Syntax::HTML) ;
 
34
 
 
35
 
 
36
###################################################################################
 
37
#
 
38
#   Methods
 
39
#
 
40
###################################################################################
 
41
 
 
42
# ---------------------------------------------------------------------------------
 
43
#
 
44
#   Create new Syntax Object
 
45
#
 
46
# ---------------------------------------------------------------------------------
 
47
 
 
48
 
 
49
sub new
 
50
 
 
51
    {
 
52
    my $class = shift ;
 
53
 
 
54
    my $self = Embperl::Syntax::HTML::new ($class) ;
 
55
 
 
56
    if (!$self -> {-ssiInit})
 
57
        {
 
58
        $self -> {-ssiInit} = 1 ;    
 
59
        Init ($self) ;
 
60
        }
 
61
 
 
62
    return $self ;
 
63
    }
 
64
 
 
65
 
 
66
 
 
67
###################################################################################
 
68
#
 
69
#   Definitions for SSI HTML tags
 
70
#
 
71
###################################################################################
 
72
 
 
73
sub Init
 
74
 
 
75
    {
 
76
    my ($self) = @_ ;
 
77
 
 
78
    $self -> AddInitCode (undef, 'Embperl::Syntax::SSI::InitSSI($_[0], $req_rec);', undef) ;
 
79
 
 
80
    $self -> AddComment ('#echo', ['var', 'encoding'], undef, undef, { perlcode => '_ep_rp(%$x%, $ENV{%&*\'var%}) ;' } ) ;
 
81
    $self -> AddComment ('#printenv', undef, undef, undef, { perlcode => '_ep_rp(%$x%, join ("\\\\<br\\\\>\n", map { "$_ = $ENV{$_}" } keys %ENV)) ;' } ) ;
 
82
    $self -> AddComment ('#config', ['errmsg', 'sizefmt', 'timefmt'], undef, undef,  
 
83
                            {   perlcode => [
 
84
                                            '$_ep_ssi_errmsg  = %&*\'errmsg% ;',
 
85
                                            '$_ep_ssi_sizefmt = %&*\'sizefmt% ;',
 
86
                                            '$_ep_ssi_timefmt = %&*\'timefmt% ;',
 
87
                                            ],
 
88
                              removenode => 1 
 
89
                                             } ) ;
 
90
 
 
91
    $self -> AddComment ('#exec', ['cgi', 'cmd'], undef, undef, 
 
92
                            { perlcode => [
 
93
                                        '_ep_rp(%$x%, Embperl::Syntax::SSI::exec (%&\'cmd%, %&\'cgi%)) ;',
 
94
                                        ] } ) ;
 
95
 
 
96
    $self -> AddComment ('#fsize', ['file', 'virtual'], undef, undef, 
 
97
                            { perlcode => [
 
98
                                        '_ep_rp(%$x%, Embperl::Syntax::SSI::fsize ($_ep_ssi_sizefmt, %&\'file%, %&\'virtual%)) ;',
 
99
                                        ] } ) ;
 
100
    $self -> AddComment ('#flastmod', ['file', 'virtual'], undef, undef, 
 
101
                            { perlcode => [
 
102
                                        '_ep_rp(%$x%, Embperl::Syntax::SSI::flastmod ($_ep_ssi_timefmt, %&\'file%, %&\'virtual%)) ;',
 
103
                                        ] } ) ;
 
104
 
 
105
    $self -> AddComment ('#include', ['file', 'virtual'], undef, undef, 
 
106
                            { perlcode => [
 
107
                                        '_ep_rp(%$x%, Embperl::Syntax::SSI::include (%&\'file%, %&\'virtual%)) ;',
 
108
                                        ] } ) ;
 
109
    $self -> AddComment ('#set', ['var', 'value'], undef, undef, 
 
110
                            { perlcode   => '%&value%',
 
111
                              compiletimeperlcode => '$Embperl::req -> component -> code (q{$ENV{%&*\'var%} = "} . Embperl::Syntax::SSI::InterpretVars (%&\'value%) . \'";\') ;',
 
112
                              removenode => 1 
 
113
                                         } ) ;
 
114
    $self -> AddComment ('#if', ['expr'], undef, undef, 
 
115
                            { perlcode   => '%&\'expr%',
 
116
                              compiletimeperlcode => '$Embperl::req -> component -> code (q{if (} . Embperl::Syntax::SSI::InterpretVars (%&\'expr%) . \') {\') ;',
 
117
                                removenode  => 10,
 
118
                                mayjump     => 1,
 
119
                                stackname   => 'ssicmd',
 
120
                                'push'      => 'if',
 
121
                            } ) ;
 
122
    $self -> AddComment ('#elif', ['expr'], undef, undef, 
 
123
                            { perlcode   => '%&\'expr%',
 
124
                              compiletimeperlcode => '$Embperl::req -> component -> code (\'} elsif (\' . Embperl::Syntax::SSI::InterpretVars (%&\'expr%) . \') {\') ;',
 
125
                            removenode => 10,
 
126
                            mayjump     => 1,
 
127
                            stackname   => 'ssicmd',
 
128
                            stackmatch  => 'if',
 
129
                            'push'      => 'if',
 
130
                            } ) ;
 
131
    $self -> AddComment ('#else', undef, undef, undef, 
 
132
                            { perlcode   => '} else {',
 
133
                            removenode => 10,
 
134
                            mayjump     => 1,
 
135
                            stackname   => 'ssicmd',
 
136
                            stackmatch  => 'if',
 
137
                            'push'      => 'if',
 
138
                            } ) ;
 
139
    $self -> AddComment ('#endif', undef, undef, undef, 
 
140
                            { perlcode   => '} ;',
 
141
                            removenode => 10,
 
142
                            mayjump     => 1,
 
143
                            stackname   => 'ssicmd',
 
144
                            stackmatch  => 'if',
 
145
                            } ) ;
 
146
    my $tag = $self -> AddComment ('#syntax', ['type'], undef, undef, 
 
147
                { 
 
148
                compiletimeperlcode => '$Embperl::req -> component -> syntax  (Embperl::Syntax::GetSyntax(%&\'type%, $Embperl::req -> component -> syntax -> name));', 
 
149
                removenode => 3,
 
150
                },
 
151
                 ) ;
 
152
    my $ptcode = '$Embperl::req -> component -> syntax (Embperl::Syntax::GetSyntax(\'%%\', $Embperl::req -> component -> syntax -> name)) ;' ;
 
153
    
 
154
    if (!$self -> {-ssiAssignAttrType})
 
155
        {
 
156
        $self -> {-ssiAssignAttrType}     = $self -> CloneHash ($self -> {-htmlAssignAttr}) ;
 
157
        }
 
158
    $tag -> {inside}{type}{'follow'} = $self -> {-ssiAssignAttrType} ;
 
159
    $self -> {-ssiAssignAttrType}{Assign}{follow}{'Attribut ""'}{parsetimeperlcode} = $ptcode ;
 
160
    $self -> {-ssiAssignAttrType}{Assign}{follow}{'Attribut \'\''}{parsetimeperlcode} = $ptcode ;
 
161
    $self -> {-ssiAssignAttrType}{Assign}{follow}{'Attribut alphanum'}{parsetimeperlcode} = $ptcode ;
 
162
 
 
163
 
 
164
    }
 
165
 
 
166
 
 
167
###################################################################################
 
168
#
 
169
#   SSI Implementation
 
170
#
 
171
###################################################################################
 
172
 
 
173
# ---------------------------------------------------------------------------------
 
174
#
 
175
#   Init SSI
 
176
#
 
177
# ---------------------------------------------------------------------------------
 
178
 
 
179
sub InitSSI
 
180
    {
 
181
    my $fn ;
 
182
 
 
183
    $ENV{DATE_GMT}      = gmtime ;
 
184
    $ENV{DATE_LOCAL}    = localtime ;
 
185
    $ENV{DOCUMENT_NAME} = basename ($fn = $Embperl::req -> component -> sourcefile) ;
 
186
    $ENV{DOCUMENT_URI}  = $Embperl::req -> apache_req?$Embperl::req -> apache_req -> uri:'' ;
 
187
    $ENV{LAST_MODIFIED} = format_time('', (stat ($fn))[9]) ;
 
188
    }
 
189
     
 
190
 
 
191
# ---------------------------------------------------------------------------------
 
192
#
 
193
#   Interpolate vars inside string
 
194
#
 
195
# ---------------------------------------------------------------------------------
 
196
 
 
197
 
 
198
sub InterpretVars
 
199
 
 
200
    {
 
201
    my $val = shift ;
 
202
    my $esc = shift ;
 
203
    $val =~ s/\$(\w)([a-zA-Z0-9_]*)/\$ENV{'$1$2'}/g ;
 
204
    $val =~ s/\$\{(\w)([a-zA-Z0-9_]*?)\}/\$ENV{'$1$2'}/g ;
 
205
    $val =~ s/\'/\\\'/g if ($esc) ;
 
206
    return $val ;
 
207
    }
 
208
 
 
209
# ---------------------------------------------------------------------------------
 
210
#
 
211
#   Find a file
 
212
#
 
213
# ---------------------------------------------------------------------------------
 
214
 
 
215
sub find_file 
 
216
    {
 
217
    my ($fn, $virt) = @_;
 
218
    my $req;
 
219
 
 
220
    if (!defined ($Embperl::req -> apache_req))
 
221
        {
 
222
        if ($fn)
 
223
            {
 
224
            if ($fn !~ m#/|\\#)
 
225
                {
 
226
                return $Embperl::req -> component -> cwd . '/' . $fn ;
 
227
                }
 
228
            else
 
229
                {
 
230
                return $fn ;
 
231
                }
 
232
            }
 
233
        return $Embperl::req -> component -> sourcefile if (!$virt) ;
 
234
 
 
235
        my $filename = $virt;
 
236
        
 
237
        #die "Cannot use 'virtual' without mod_perl" if ($virt) ;
 
238
 
 
239
        if ($filename && ($filename =~ /^\//)) {
 
240
                $filename = $ENV{DOCUMENT_ROOT} . $filename;
 
241
        }
 
242
        return $filename;
 
243
        }
 
244
 
 
245
    if ($fn) 
 
246
        {
 
247
        my $req = $Embperl::req -> apache_req -> lookup_file (InterpretVars ($fn)) ;
 
248
        return $req -> filename ;
 
249
        }
 
250
    if ($virt) 
 
251
        {
 
252
        my $req = $Embperl::req -> apache_req -> lookup_uri (InterpretVars ($virt)) ;
 
253
        return $req -> filename ;
 
254
        }
 
255
    else
 
256
        {
 
257
        return $Embperl::req -> component -> sourcefile ;
 
258
        }
 
259
    }
 
260
 
 
261
 
 
262
# ---------------------------------------------------------------------------------
 
263
#
 
264
#   Format time
 
265
#
 
266
# ---------------------------------------------------------------------------------
 
267
 
 
268
sub time_args 
 
269
 
 
270
    {
 
271
    # This routine must respect the caller's wantarray() context.
 
272
    my ($time, $zone) = @_;
 
273
    return $zone =~ /GMT/ ? gmtime($time) : localtime($time);
 
274
    }
 
275
 
 
276
 
 
277
sub format_time 
 
278
  {
 
279
  my ($format, $time, $tzone) = @_;
 
280
  return ($format ? 
 
281
          POSIX::strftime($format, time_args($time, $tzone)) :
 
282
          scalar time_args($time, $tzone));
 
283
  }
 
284
 
 
285
 
 
286
 
 
287
 
 
288
# ---------------------------------------------------------------------------------
 
289
#
 
290
#   Output fsize
 
291
#
 
292
# ---------------------------------------------------------------------------------
 
293
 
 
294
 
 
295
 
 
296
sub fsize
 
297
   
 
298
    { 
 
299
    my ($fmt, $fn, $virt) = @_;
 
300
    
 
301
    my $size = -s find_file($fn, $virt) ;
 
302
    
 
303
    $fmt ||= 'abbrev' ;
 
304
 
 
305
    if ($fmt eq 'bytes')
 
306
         {
 
307
         return $size;
 
308
         }
 
309
    elsif ($fmt eq 'abbrev') 
 
310
        {
 
311
        return "   0k" unless $size;
 
312
        return "   1k" if $size < 1024;
 
313
        return sprintf("%4dk", ($size + 512)/1024) if $size < 1048576;
 
314
        return sprintf("%4.1fM", $size/1048576.0)  if $size < 103809024;
 
315
        return sprintf("%4dM", ($size + 524288)/1048576);
 
316
        } 
 
317
    else 
 
318
        {
 
319
        die "Unrecognized size format '$fmt'" ;
 
320
        }
 
321
    }
 
322
 
 
323
# ---------------------------------------------------------------------------------
 
324
#
 
325
#   Output flastmod
 
326
#
 
327
# ---------------------------------------------------------------------------------
 
328
 
 
329
sub flastmod 
 
330
    {
 
331
    my($fmt, $fn, $virt) = @_;
 
332
    
 
333
    return format_time($fmt, (stat (find_file($fn, $virt)))[9])
 
334
    }
 
335
 
 
336
# ---------------------------------------------------------------------------------
 
337
#
 
338
#   Include
 
339
#
 
340
# ---------------------------------------------------------------------------------
 
341
 
 
342
sub include {
 
343
        my($fn, $virt) = @_;
 
344
                                
 
345
        local $/ = undef ;
 
346
 
 
347
        my $type = "SSI"; # adding Embperl to syntax results in errors I can't figure out...
 
348
        my $filename = $virt;
 
349
 
 
350
        if ($fn) {
 
351
                $type = "Text";
 
352
                $filename = $fn;
 
353
        }
 
354
        elsif ($virt) {
 
355
                if ($filename && ($filename =~ /^\//)) {
 
356
                        $filename = $ENV{DOCUMENT_ROOT} . "/$filename";
 
357
                }
 
358
        }
 
359
        else {
 
360
                warn "Nothing to #include... need file or virtual";
 
361
                return "";
 
362
        }
 
363
 
 
364
        my $output = "";
 
365
        Embperl::Req::ExecuteComponent({inputfile=>$filename, output=>\$output, syntax=>$type});
 
366
 
 
367
        local $Embperl::escmode = 0 ;
 
368
        return $output;
 
369
}
 
370
 
 
371
# ---------------------------------------------------------------------------------
 
372
#
 
373
#   Exec
 
374
#
 
375
# ---------------------------------------------------------------------------------
 
376
 
 
377
 
 
378
sub exec 
 
379
    {
 
380
    my($cmd, $cgi) = @_;
 
381
 
 
382
    if (!defined (&Apache::request))
 
383
        {
 
384
        return scalar `$cmd` if ($cmd) ;
 
385
        die "Cannot use 'cgi' without mod_perl" ;
 
386
        }
 
387
 
 
388
    my $r = $Embperl::req -> apache_req ;
 
389
    my $filename = $r->filename;
 
390
    
 
391
    die ("httpd: exec used but not allowed in $filename") if ($r->allow_options & &OPT_INCNOEXEC) ;
 
392
    
 
393
    return scalar `$cmd` if ($cmd) ;
 
394
    
 
395
    die ("No 'cmd' or 'cgi' argument given to #exec") if (!$cgi) ;
 
396
 
 
397
    die ("'cgi' as argument to #exec not implemented yet") ;
 
398
 
 
399
    # Okay, we're doing <!--#exec cgi=...>
 
400
    my $rr = $r->lookup_uri($cgi);
 
401
    die("Error including cgi: subrequest returned status '" . $rr->status . "', not 200") if ($rr->status != 200);
 
402
    
 
403
    # Pass through our own path_info and query_string (does this work?)
 
404
    $rr->path_info( $r->path_info );
 
405
    $rr->args( scalar $r->args );
 
406
    $rr->content_type("application/x-httpd-cgi");
 
407
    &_set_VAR($rr, 'DOCUMENT_URI', $r->uri);
 
408
    
 
409
    my $status = $rr->run;
 
410
    return '';
 
411
    }
 
412
 
 
413
 
 
414
1; 
 
415
 
 
416
__END__
 
417
 
 
418
=pod
 
419
 
 
420
=head1 NAME
 
421
 
 
422
SSI syntax module for Embperl 
 
423
 
 
424
=head1 SYNOPSIS
 
425
 
 
426
 [$ syntax SSI $]
 
427
 
 
428
 DATE_GMT:       <!-- #echo  var='DATE_GMT' -->
 
429
 DATE_LOCAL:    <!-- #echo  var='DATE_LOCAL' --> 
 
430
 DOCUMENT_NAME: <!-- #echo  var='DOCUMENT_NAME' -->
 
431
 DOCUMENT_URI:  <!-- #echo  var='DOCUMENT_URI' -->
 
432
 LAST_MODIFIED: <!-- #echo  var='LAST_MODIFIED' -->
 
433
 
 
434
 
 
435
=head1 DESCRIPTION
 
436
 
 
437
The module make Embperl understand the following SSI tags. See
 
438
Apaches mod_include (or Apache::SSI) for a description, what they
 
439
do.
 
440
 
 
441
=over 4
 
442
 
 
443
=item * config
 
444
 
 
445
=item * echo
 
446
 
 
447
=item * exec
 
448
 
 
449
=item * fsize
 
450
 
 
451
=item * flastmod
 
452
 
 
453
=item * include
 
454
 
 
455
=item * printenv
 
456
 
 
457
=item * set
 
458
 
 
459
=item * if
 
460
 
 
461
=item * elif
 
462
 
 
463
=item * else
 
464
 
 
465
=item * endif
 
466
 
 
467
=item * syntax
 
468
 
 
469
The syntax SSI is non standard and is used to change the syntax once you are
 
470
in SSI syntax. It looks like
 
471
 
 
472
  <!--#syntax type="Embperl" -->
 
473
 
 
474
=back
 
475
 
 
476
 
 
477
=head1 Author
 
478
 
 
479
Gerald Richter <richter@dev.ecos.de>
 
480
 
 
481
Some ideas and parts of the code are taken from Apache::SSI by Ken Williams. 
 
482
 
 
483
=head1 See Also
 
484
 
 
485
Embperl::Syntax, Embperl::Syntax::HTML
 
486
 
 
487
=cut
 
488
 
 
489
 
 
490
 
 
491
# ---------------------------------------------------------------------------------
 
492
#
 
493
#   Perl
 
494
#
 
495
# ---------------------------------------------------------------------------------
 
496
 
 
497
 
 
498
 
 
499
sub perl 
 
500
    {
 
501
    my($self, $args, $margs) = @_;
 
502
 
 
503
    my ($pass_r, @arg1, @arg2, $sub) = (1);
 
504
    {
 
505
        my @a;
 
506
        while (@a = splice(@$margs, 0, 2)) {
 
507
            $a[1] =~ s/\\(.)/$1/gs;
 
508
            if (lc $a[0] eq 'sub') {
 
509
                $sub = $a[1];
 
510
            } elsif (lc $a[0] eq 'arg') {
 
511
                push @arg1, $a[1];
 
512
            } elsif (lc $a[0] eq 'args') {
 
513
                push @arg1, split(/,/, $a[1]);
 
514
            } elsif (lc $a[0] eq 'pass_request') {
 
515
                $pass_r = 0 if lc $a[1] eq 'no';
 
516
            } elsif ($a[0] =~ s/^-//) {
 
517
                push @arg2, @a;
 
518
            } else { # Any unknown get passed as key-value pairs
 
519
                push @arg2, @a;
 
520
            }
 
521
        }
 
522
    }
 
523
 
 
524
    warn "sub is $sub, args are @arg1 & @arg2" if $debug;
 
525
    my $subref;
 
526
    if ( $sub =~ /^\s*sub\s/ ) {     # for <!--#perl sub="sub {print ++$Access::Cnt }" -->
 
527
        $subref = eval($sub);
 
528
        if ($@) {
 
529
            $self->error("Perl eval of '$sub' failed: $@") if $self->{_r};
 
530
            warn("Perl eval of '$sub' failed: $@") unless $self->{_r};  # For offline mode
 
531
        }
 
532
        return $self->error("sub=\"sub ...\" didn't return a reference") unless ref $subref;
 
533
    } else {             # for <!--#perl sub="package::subr" -->
 
534
        no strict('refs');
 
535
        $subref = (defined &{$sub} ? \&{$sub} :
 
536
                   defined &{"${sub}::handler"} ? \&{"${sub}::handler"} : 
 
537
                   \&{"main::$sub"});
 
538
    }
 
539
    
 
540
    $pass_r = 0 if $self->{_r} and lc $self->{_r}->dir_config('SSIPerlPass_Request') eq 'no';
 
541
    unshift @arg1, $self->{_r} if $pass_r;
 
542
    warn "sub is $subref, args are @arg1 & @arg2" if $debug;
 
543
    return scalar &{ $subref }(@arg1, @arg2);
 
544
}
 
545
 
 
546
 
 
547
1 ;
 
548
 
 
549
 
 
550