/[meteor]/googlecode.com/svn/trunk/Meteor/Document.pm
This is repository of my old source code which isn't updated any more. Go to git.rot13.org for current projects!
ViewVC logotype

Contents of /googlecode.com/svn/trunk/Meteor/Document.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 12 - (show annotations)
Thu Dec 14 16:58:18 2006 UTC (12 years, 7 months ago) by knops.gerd
File size: 5735 byte(s)
• Simplify check for valid path names. The old check was triggering a bug in perl (Attempt to free unreferenced scalar) that would eventually lead to a crash. 

1 #!/usr/bin/perl -w
2 ###############################################################################
3 # Meteor
4 # An HTTP server for the 2.0 web
5 # Copyright (c) 2006 contributing authors
6 #
7 # Subscriber.pm
8 #
9 # Description:
10 # Cache and serve static documents
11 #
12 ###############################################################################
13 #
14 # This program is free software; you can redistribute it and/or modify it
15 # under the terms of the GNU General Public License as published by the Free
16 # Software Foundation; either version 2 of the License, or (at your option)
17 # any later version.
18 #
19 # This program is distributed in the hope that it will be useful, but WITHOUT
20 # ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
21 # FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
22 # more details.
23 #
24 # You should have received a copy of the GNU General Public License along
25 # with this program; if not, write to the Free Software Foundation, Inc.,
26 # 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
27 #
28 # For more information visit www.meteorserver.org
29 #
30 ###############################################################################
31
32 package Meteor::Document;
33 ###############################################################################
34 # Configuration
35 ###############################################################################
36
37 use strict;
38
39 our %Documents=();
40
41 ###############################################################################
42 # Class methods
43 ###############################################################################
44 sub serveFileToClient {
45 my $class=shift;
46 my $relPath=shift;
47 my $client=shift;
48
49 &::syslog('debug',"Meteor::Document: Request received for '%s'",$relPath);
50
51 my $doc=$class->documentForPath($relPath);
52
53 unless(defined($doc))
54 {
55 $class->emitHeaderToClient($client,'404 Not Found');
56
57 return undef;
58 }
59
60 $doc->serveTo($client);
61
62 $doc;
63 }
64
65 sub emitHeaderToClient {
66 my $self=shift;
67 my $client=shift;
68 my $status=shift;
69
70 my $header=$::CONF{'DocumentHeaderTemplate'};
71
72 $header=~s/~([^~]+)~/
73 if(!defined($1) || $1 eq '')
74 {
75 '~';
76 }
77 elsif($1 eq 'server')
78 {
79 $::PGM;
80 }
81 elsif($1 eq 'status')
82 {
83 $status;
84 }
85 else
86 {
87 '';
88 }
89 /gex;
90
91 $client->write($header);
92 }
93
94 sub documentForPath {
95 my $class=shift;
96 my $relPath=shift;
97
98 unless(exists($Documents{$relPath}))
99 {
100 my $path=$class->pathToAbsolute($relPath);
101
102 return undef unless(defined($path));
103
104 my $doc=$class->newDocument($path);
105
106 return undef unless(defined($doc));
107
108 $Documents{$relPath}=$doc;
109 }
110
111 $Documents{$relPath};
112 }
113
114 sub clearDocuments {
115 %Documents=();
116 }
117
118 sub pathToAbsolute {
119 my $class=shift;
120 my $relPath=shift;
121
122 # Don't serve documents unless SubscriberDocumentRoot is set
123 unless(exists($::CONF{'SubscriberDocumentRoot'})
124 && $::CONF{'SubscriberDocumentRoot'} ne ''
125 && $::CONF{'SubscriberDocumentRoot'} ne '/'
126 )
127 {
128 return undef;
129 }
130
131 #
132 # Verify if name is legal
133 #
134 # Strip leading and trailing slashes
135 $relPath=~s/^[\/]*//;
136 $relPath=~s/[\/]*$//;
137
138
139 # NOTE: With the right strings the code below triggers a bug in
140 # perl (5.8.6 currently) that will result in messages like
141 #
142 # Attempt to free unreferenced scalar
143 #
144 # and an eventual crash.
145 #
146 # So it was replaced with the more naive code following this
147 # commented out code.
148 #
149 # # split into path components
150 # my @pathComponents=split(/[\/]+/,$relPath);
151 #
152 # # Check components
153 # foreach (@pathComponents)
154 # {
155 # # Very strict: We only allow alphanumeric characters, dash and
156 # # underscore, followed by any number of extensions that also
157 # # only allow the above characters.
158 # unless(/^[a-z0-9\-\_][a-z0-9\-\_\.]*$/i)
159 # {
160 # &::syslog('debug',
161 # "Meteor::Document: Rejecting path '%s' due to invalid component '%s'",
162 # $relPath,$_
163 # );
164 #
165 # return undef;
166 # }
167 # }
168 #
169 #my $path=$::CONF{'SubscriberDocumentRoot'}.'/'.join('/',@pathComponents);
170
171 #
172 # Check for all alphanumeric or dash, underscore, dot and slash
173 #
174 unless($relPath=~/^[a-z0-9\-\_\.\/]*$/i)
175 {
176 &::syslog('debug',
177 "Meteor::Document: Rejecting path '%s' due to invalid characters",
178 $relPath
179 );
180
181 return undef;
182 }
183 #
184 # Don't allow '..'
185 #
186 if(index($relPath,'..')>=0)
187 {
188 &::syslog('debug',
189 "Meteor::Document: Rejecting path '%s' due to invalid sequence '..'",
190 $relPath
191 );
192
193 return undef;
194 }
195
196 my $path=$::CONF{'SubscriberDocumentRoot'}.'/'.$relPath;
197
198 # If it is a directory, append DirectoryIndex config value
199 $path.='/'.$::CONF{'DirectoryIndex'} if(-d $path);
200
201 # Verify file is readable
202 return undef unless(-r $path);
203
204 $path;
205 }
206
207 ###############################################################################
208 # Factory methods
209 ###############################################################################
210 sub new {
211 #
212 # Create a new empty instance
213 #
214 my $class=shift;
215
216 my $obj={};
217
218 bless($obj,$class);
219 }
220
221 sub newDocument {
222 #
223 # new instance from new server connection
224 #
225 my $self=shift->new();
226
227 my $path=shift;
228 $self->{'path'}=$path;
229
230 # Read file
231 {
232 local $/; # enable localized slurp mode
233 open(IN,$path) or return undef;
234 $self->{'document'}=<IN>;
235 close(IN);
236 }
237
238 $self->{'size'}=length($self->{'document'});
239
240 $self;
241 }
242
243 ###############################################################################
244 # Instance methods
245 ###############################################################################
246 sub serveTo {
247 my $self=shift;
248 my $client=shift;
249
250 $self->emitHeaderToClient($client,'200 OK');
251
252 $client->write($self->{'document'});
253 }
254
255 sub path {
256 shift->{'path'};
257 }
258
259 1;
260 ############################################################################EOF

  ViewVC Help
Powered by ViewVC 1.1.26