root/trunk/lib/Mungo.pm

Revision 17, 7.4 kB (checked in by jesus, 6 years ago)

first whack at resolving mod_perl2 support. refs #8

Line 
1 package Mungo;
2
3 # Copyright (c) 2007 OmniTI Computer Consulting, Inc. All rights reserved.
4 # For information on licensing see:
5 #   https://labs.omniti.com/mungo/trunk/LICENSE
6
7 use strict;
8 use IO::File;
9 eval "
10   use Apache2::RequestRec;
11   use Apache2::RequestUtil;
12   use Apache2::Const qw ( OK NOT_FOUND );
13 ";
14 if($@) {
15   print STDERR "mod_perl2 not found: $@";
16   eval "
17     use Apache;
18     use Apache::Constants qw( OK NOT_FOUND );
19   ";
20   die $@ if $@;
21 }
22 use MIME::Base64 qw/encode_base64 decode_base64/;
23 use Data::Dumper;
24 use Digest::MD5 qw/md5_hex/;
25 use Mungo::Request;
26 use Mungo::Response;
27 use Mungo::Error;
28 use HTML::Entities;
29
30 use vars qw/$VERSION
31             $DEFAULT_POST_BLOCK $DEFAULT_POST_MAX_SIZE
32             $DEFAULT_POST_MAX_PART $DEFAULT_POST_MAX_IN_MEMORY/;
33
34 my $SVN_VERSION = 0;
35 $SVN_VERSION = $1 if(q$LastChangedRevision: 301 $ =~ /(\d+)/);
36 $VERSION = "1.0.0.${SVN_VERSION}";
37
38 $DEFAULT_POST_BLOCK = 1024*32;          # 32k
39 $DEFAULT_POST_MAX_SIZE = 0;             # unlimited post size
40 $DEFAULT_POST_MAX_PART = 0;             # and part size
41 $DEFAULT_POST_MAX_IN_MEMORY = 1024*128; # 128k
42
43 sub MungoDie {
44   my $i = 0;
45   my @callstack;
46   while(my @callinfo = caller($i++)) {
47     push @callstack, \@callinfo;
48   }
49   die Mungo::Error->new({ error => shift, callstack => \@callstack });
50 }
51
52 sub new {
53   my ($class, $r) = @_;
54   my $self = $r->pnotes(__PACKAGE__);
55   return $self if($self);
56   $self = bless {
57     'Apache::Request' => $r,
58   }, $class;
59   $r->pnotes(__PACKAGE__, $self);
60   return $self;
61 }
62 sub DESTROY { }
63 sub cleanse {
64   my $self = shift;
65   $self->Response()->cleanse();
66   $self->Request()->cleanse();
67   delete $self->{'Apache::Request'};
68 }
69
70 # Axiomatic "I am myself"
71 sub Server { return $_[0]; }
72 sub Request { return Mungo::Request->new($_[0]); }
73 sub Response { return Mungo::Response->new($_[0]); }
74
75 sub URLEncode {
76   my $self = shift;
77   my $s = shift;
78   $s =~ s/([^a-zA-Z0-9])/sprintf("%%%02x", ord($1))/eg;
79   return $s;
80 }
81 sub URLDecode {
82   my $self = shift;
83   my $s = shift;
84   $s =~ s/%([a-fA-F0-9]{2})/chr(hex($1))/eg;
85   return $s;
86 }
87 sub demangle_name {
88   my $self = shift;
89   my $name = shift;
90   if($name =~ /Mungo::FilePage::([^:]+)::__content/) {
91     my $filename = decode_base64($1);
92     my $r = $self->{'Apache::Request'};
93     if(UNIVERSAL::can($r, 'document_root')) {
94       my $base = $r->document_root();
95       $filename =~ s/^$base//;
96     }
97     $name = "Mungo::FilePage($filename)";
98   }
99   elsif($name =~ /Mungo::MemPage::([^:]+)::__content/) {
100     $name = 'Mungo::MemPage(ANON)';
101   }
102   return $name;
103 }
104
105 sub filename2packagename {
106   my ($self, $filename) = @_;
107   my $type = ref $self;
108   $type =~ s/::(?:File|Mem)Page::[^:]+$//;
109   my $pkg = $type . "::FilePage::" . encode_base64($filename);
110   $pkg =~ s/(\s|=*$)//gs;
111   return $pkg;
112 }
113 sub contents2packagename {
114   my($self, $contents) = @_;
115   my $type = ref $self;
116   $type =~ s/::(?:File|Mem)Page::[^:]+$//;
117   return $type . "::MemPage::" . md5_hex($$contents);
118 }
119 sub include_mem {
120   my $self = shift;
121   my $contents = shift;
122   my $pkg = $self->contents2packagename($contents);
123
124   unless(UNIVERSAL::can($pkg, 'content')) {
125     return unless $self->packagize($pkg, $contents);
126     # The packagize was successful, make content do __content
127     eval "*".$pkg."::content = \\&".$pkg."::__content;";
128   }
129   my %copy = %$self;
130   my $page = bless \%copy, $pkg;
131   $page->content(@_);
132 }
133 sub include_file {
134   my $self = shift;
135   my $filename = shift;
136   if($filename !~ /^\//) {
137     my $dir = $self->{'Apache::Request'}->filename;
138     $dir =~ s/[^\/]+$//;
139     $filename = "$dir$filename";
140   }
141   my $pkg = $self->filename2packagename($filename);
142   my ($inode, $mtime);
143   if($self->{'Apache::Request'}->dir_config('StatINC')) {
144     ($inode, $mtime) = (stat($filename))[1,9];
145   }
146   unless(UNIVERSAL::can($pkg, 'content') &&
147          $inode == eval "\$${pkg}::Mungo_inode" &&
148          $mtime == eval "\$${pkg}::Mungo_mtime") {
149     my $contents;
150     my $ifile = IO::File->new("<$filename");
151     die "$!: $filename" unless $ifile;
152     {
153       local $/ = undef;
154       $contents = <$ifile>;
155     }
156     return unless $self->packagize($pkg, \$contents);
157     # The packagize was successful, make content do __content
158     eval "*${pkg}::content = \\&${pkg}::__content";
159     # Track what we just compiled
160     eval "\$${pkg}::Mungo_inode = $inode";
161     eval "\$${pkg}::Mungo_mtime = $mtime";
162   }
163   my %copy = %$self;
164   my $page = bless \%copy, $pkg;
165   $page->content(@_);
166 }
167 sub packagize {
168   my $self = shift;
169   my $pkg = shift;
170   my $contents = shift;
171   my $expr = convertStringToExpression($contents);
172   my $type = ref $self;
173   $type =~ s/::(?:File|Mem)Page::[^:]+$//;
174
175   # We build a package with a __content method.  Why?
176   # If this fails miserably, there is still a possibility that
177   # UNIVERSAL::can($pkg, 'content') will be true, so we make __content
178   # and if it all works out, we *$pkg::content = \&$pkg::__content
179
180   my $preamble = "package $pkg;" . q^
181     use vars qw/@ISA $Mungo_inode $Mungo_mtime/;
182     @ISA = qw/^. $type . q^/;
183     sub __content {
184       my $self = shift;
185       my $Request = $self->Request();
186       my $Response = $self->Response();
187       my $Server = $self->Server();
188 ^;
189   my $postamble = q^
190     }
191     1;
192     ^;
193
194   # Set these before we attempt to compile so that if there is an error,
195   # we can get access to the code from somewhere else.
196   eval "\$${pkg}::Mungo_preamble = \$preamble;";
197   eval "\$${pkg}::Mungo_postamble = \$postamble;";
198   eval "\$${pkg}::Mungo_contents = \$contents;";
199
200   eval $preamble . $expr . $postamble;
201   if($@) {
202     my $error = $@;
203     if(ref $error ne 'HASH') {
204       my $i = 0;
205       my @callstack;
206       while(my @callinfo = caller($i++)) {
207         push @callstack, \@callinfo;
208       }
209       $error = { error => $error, callstack => \@callstack };
210     }
211     my ($line) = ($error->{error} =~ /line (\d+)/m);
212     unshift @{$error->{callstack}},
213       [
214         $pkg, '(ASP include)', $line
215       ];
216     local $SIG{__DIE__} = undef;
217     die $error;
218   }
219   return 1;
220 }
221
222 sub handler($$) {
223   my ($self, $r) = @_;
224   if (ref $self eq 'Apache2::RequestRec') {
225     $r = $self;
226     $self = __PACKAGE__;
227   }
228   # Short circuit if we can't fine the file.
229   return NOT_FOUND() if(! -r $r->filename);
230
231   $self = $self->new($r) unless(ref $self);
232   $self->Response()->start();
233   $main::Request = $self->Request();
234   $main::Response = $self->Response();
235   $main::Server = $self->Server();
236   local $SIG{__DIE__} = \&Mungo::MungoDie;
237   eval {
238     $self->Response()->Include($r->filename);
239   };
240   if($@) {
241     # print out the error to the logs
242     print STDERR $@ if($@);
243     # If it isn't too late, make this an internal server error
244     eval { $self->Response()->{Status} = 500; };
245   }
246  MUNGO_HANDLER_FINISH:
247   $self->Response()->finish();
248
249   $self->cleanse();
250   undef $main::Request;
251   undef $main::Response;
252   undef $main::Server;
253  
254   undef $self;
255   return &OK;
256 }
257
258 sub convertStringToExpression {
259   my $string_ref = shift;
260   my $string = $$string_ref;
261   sub __string_as_print {
262     return '' unless(length($_[0]));
263     my $s = Dumper($_[0]);
264     substr($s, 0, 7) = 'print';
265     return $s;
266   }
267   # The first is needed b/c variable with look-behind assertions don't work
268   my $tmp;
269   ($tmp = $string) =~ s/^/# /mg;
270   $string =~ s/^(.*?)(?=<%|$)/__string_as_print($1)/se;
271   # Replace non-code
272   $string =~ s/(?<=%>)(?!<%)(.*?)(?=<%|$)/__string_as_print($1)/seg;
273   # fixup code
274   $string =~ s/
275                 <%(=?)(.*?)%>
276               /
277               $1 ?
278                 "print $2;" :           # This is <%= ... %>
279                 "$2;"                   # This is <% ... %>
280               /sexg;
281   return $string;
282 }
283
284 1;
Note: See TracBrowser for help on using the browser.