root/trunk/lib/Mungo.pm

Revision 2, 6.2 kB (checked in by jesus, 7 years ago)

Initial import from Theo's private repository. From here on out it is open to the world.

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 use Apache;
10 use Apache::Constants qw( OK NOT_FOUND );
11 use MIME::Base64 qw/encode_base64/;
12 use Data::Dumper;
13 use Digest::MD5 qw/md5_hex/;
14 use Mungo::Request;
15 use Mungo::Response;
16
17 use vars qw/$VERSION
18             $DEFAULT_POST_BLOCK $DEFAULT_POST_MAX_SIZE
19             $DEFAULT_POST_MAX_PART $DEFAULT_POST_MAX_IN_MEMORY/;
20
21 my $SVN_VERSION = 0;
22 $SVN_VERSION = $1 if(q$LastChangedRevision: 301 $ =~ /(\d+)/);
23 $VERSION = "1.0.0.${SVN_VERSION}";
24
25 $DEFAULT_POST_BLOCK = 1024*32;          # 32k
26 $DEFAULT_POST_MAX_SIZE = 0;             # unlimited post size
27 $DEFAULT_POST_MAX_PART = 0;             # and part size
28 $DEFAULT_POST_MAX_IN_MEMORY = 1024*128; # 128k
29
30 sub new {
31   my ($class, $r) = @_;
32   my $self = $r->pnotes(__PACKAGE__);
33   return $self if($self);
34   $self = bless {
35     'Apache::Request' => $r,
36   }, $class;
37   $r->pnotes(__PACKAGE__, $self);
38   return $self;
39 }
40 sub DESTROY { }
41 sub cleanse {
42   my $self = shift;
43   $self->Response()->cleanse();
44   $self->Request()->cleanse();
45   delete $self->{'Apache::Request'};
46 }
47
48 # Axiomatic "I am myself"
49 sub Server { return $_[0]; }
50 sub Request { return Mungo::Request->new($_[0]); }
51 sub Response { return Mungo::Response->new($_[0]); }
52
53 sub URLEncode {
54   my $self = shift;
55   my $s = shift;
56   $s =~ s/([^a-zA-Z0-9])/sprintf("%%%02x", ord($1))/eg;
57   return $s;
58 }
59
60 sub filename2packagename {
61   my ($self, $filename) = @_;
62   my $type = ref $self;
63   $type =~ s/::(?:File|Mem)Page::[^:]+$//;
64   my $pkg = $type . "::FilePage::" . encode_base64($filename);
65   $pkg =~ s/(\s|=*$)//gs;
66   return $pkg;
67 }
68 sub contents2packagename {
69   my($self, $contents) = @_;
70   my $type = ref $self;
71   $type =~ s/::(?:File|Mem)Page::[^:]+$//;
72   return $type . "::MemPage::" . md5_hex($$contents);
73 }
74 sub include_mem {
75   my $self = shift;
76   my $contents = shift;
77   my $pkg = $self->contents2packagename($contents);
78
79   unless(UNIVERSAL::can($pkg, 'content')) {
80     return unless $self->packagize($pkg, $contents);
81     # The packagize was successful, make content do __content
82     eval "*".$pkg."::content = \\&".$pkg."::__content;";
83   }
84   my %copy = %$self;
85   my $page = bless \%copy, $pkg;
86   $page->content(@_);
87 }
88 sub include_file {
89   my $self = shift;
90   my $filename = shift;
91   if($filename !~ /^\//) {
92     my $dir = $self->{'Apache::Request'}->filename;
93     $dir =~ s/[^\/]+$//;
94     $filename = "$dir$filename";
95   }
96   my $pkg = $self->filename2packagename($filename);
97   my ($inode, $mtime);
98   if($self->{'Apache::Request'}->dir_config('StatINC')) {
99     ($inode, $mtime) = (stat($filename))[1,9];
100   }
101   unless(UNIVERSAL::can($pkg, 'content') &&
102          $inode == eval "\$${pkg}::Mungo_inode" &&
103          $mtime == eval "\$${pkg}::Mungo_mtime") {
104     my $contents;
105     my $ifile = IO::File->new("<$filename");
106     die "$!: $filename" unless $ifile;
107     {
108       local $/ = undef;
109       $contents = <$ifile>;
110     }
111     return unless $self->packagize($pkg, \$contents);
112     # The packagize was successful, make content do __content
113     eval "*${pkg}::content = \\&${pkg}::__content";
114     # Track what we just compiled
115     eval "\$${pkg}::Mungo_inode = $inode";
116     eval "\$${pkg}::Mungo_mtime = $mtime";
117   }
118   my %copy = %$self;
119   my $page = bless \%copy, $pkg;
120   $page->content(@_);
121 }
122 sub packagize {
123   my $self = shift;
124   my $pkg = shift;
125   my $contents = shift;
126   my $expr = convertStringToExpression($contents);
127   my $type = ref $self;
128   $type =~ s/::(?:File|Mem)Page::[^:]+$//;
129
130   # We build a package with a __content method.  Why?
131   # If this fails miserably, there is still a possibility that
132   # UNIVERSAL::can($pkg, 'content') will be true, so we make __content
133   # and if it all works out, we *$pkg::content = \&$pkg::__content
134
135   my $preamble = "package $pkg;" . q^
136     use vars qw/@ISA $Mungo_inode $Mungo_mtime/;
137     @ISA = qw/^. $type . q^/;
138     sub __content {
139       my $self = shift;
140       my $Request = $self->Request();
141       my $Response = $self->Response();
142       my $Server = $self->Server();
143 ^;
144   my $postamble = q^
145     }
146     1;
147     ^;
148   eval $preamble . $expr . $postamble;
149   if($@) {
150      print "ERROR:<br><pre>$@</pre>\n\n";
151      print "PRE PARSE:<br>\n";
152      my $outer_line = 1;
153      my $inner_line = 1;
154      (my $numbered_preamble = $preamble) =~
155        s/^/sprintf("[%4d]       ", $outer_line++)/emg;
156      print qq^<pre style="color: #999">$numbered_preamble</pre>\n^;
157      (my $numbered_contents = $$contents) =~
158        s/^/sprintf("[%4d] %4d: ", $outer_line++, $inner_line++)/emg;
159      print "<pre>$numbered_contents</pre>\n";
160      (my $numbered_postamble = $postamble) =~
161        s/^/sprintf("[%4d]       ", $outer_line++)/emg;
162      print qq^<pre style="color: #999">$numbered_postamble</pre>\n\n^;
163      return 0;
164   }
165   return 1;
166 }
167
168 sub handler($$) {
169   my ($self, $r) = @_;
170   # Short circuit if we can't fine the file.
171   return NOT_FOUND if(! -r $r->filename);
172
173   $self = $self->new($r) unless(ref $self);
174   $self->Response()->start();
175   $main::Request = $self->Request();
176   $main::Response = $self->Response();
177   $main::Server = $self->Server();
178   eval {
179     $self->Response()->Include($r->filename);
180   };
181   if($@) {
182     # If it isn't too late, make this an internal server error
183     eval { $self->Response()->{Status} = 500; };
184     # print out the error to the logs
185     print STDERR $@ if($@);
186   }
187  MUNGO_HANDLER_FINISH:
188   $self->Response()->finish();
189
190   $self->cleanse();
191   undef $main::Request;
192   undef $main::Response;
193   undef $main::Server;
194  
195   undef $self;
196   return &OK;
197 }
198
199 sub convertStringToExpression {
200   my $string_ref = shift;
201   my $string = $$string_ref;
202   sub __string_as_print {
203     return '' unless(length($_[0]));
204     my $s = Dumper($_[0]);
205     substr($s, 0, 7) = 'print';
206     return $s;
207   }
208   # The first is needed b/c variable with look-behind assertions don't work
209   my $tmp;
210   ($tmp = $string) =~ s/^/# /mg;
211   $string =~ s/^(.*?)(?=<%|$)/__string_as_print($1)/se;
212   # Replace non-code
213   $string =~ s/(?<=%>)(?!<%)(.*?)(?=<%|$)/__string_as_print($1)/seg;
214   # fixup code
215   $string =~ s/
216                 <%(=?)(.*?)%>
217               /
218               $1 ?
219                 "print $2;" :           # This is <%= ... %>
220                 "$2;"                   # This is <% ... %>
221               /sexg;
222   return $string;
223 }
224
225 1;
Note: See TracBrowser for help on using the browser.