root/branches/1.0/lib/Mungo.pm

Revision 20, 7.3 kB (checked in by jesus, 6 years ago)

set the version for release

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