/[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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 25 - (hide annotations)
Sun May 20 19:40:53 2007 UTC (13 years, 1 month ago) by knops.gerd
File size: 5778 byte(s)
• Add simple statistics, available via new SHOWSTATS controller command

1 andrew.betts 10 #!/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 knops.gerd 25
49 andrew.betts 10 &::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 knops.gerd 25 $::Statistics->{'documents_served'}++;
63    
64 andrew.betts 10 $doc;
65     }
66    
67     sub emitHeaderToClient {
68     my $self=shift;
69     my $client=shift;
70     my $status=shift;
71    
72     my $header=$::CONF{'DocumentHeaderTemplate'};
73    
74     $header=~s/~([^~]+)~/
75     if(!defined($1) || $1 eq '')
76     {
77     '~';
78     }
79     elsif($1 eq 'server')
80     {
81     $::PGM;
82     }
83     elsif($1 eq 'status')
84     {
85     $status;
86     }
87     else
88     {
89     '';
90     }
91     /gex;
92    
93     $client->write($header);
94     }
95    
96     sub documentForPath {
97     my $class=shift;
98     my $relPath=shift;
99    
100     unless(exists($Documents{$relPath}))
101     {
102     my $path=$class->pathToAbsolute($relPath);
103    
104     return undef unless(defined($path));
105    
106     my $doc=$class->newDocument($path);
107    
108     return undef unless(defined($doc));
109    
110     $Documents{$relPath}=$doc;
111     }
112    
113     $Documents{$relPath};
114     }
115    
116     sub clearDocuments {
117     %Documents=();
118     }
119    
120     sub pathToAbsolute {
121     my $class=shift;
122     my $relPath=shift;
123    
124     # Don't serve documents unless SubscriberDocumentRoot is set
125     unless(exists($::CONF{'SubscriberDocumentRoot'})
126     && $::CONF{'SubscriberDocumentRoot'} ne ''
127     && $::CONF{'SubscriberDocumentRoot'} ne '/'
128     )
129     {
130     return undef;
131     }
132    
133     #
134     # Verify if name is legal
135     #
136     # Strip leading and trailing slashes
137     $relPath=~s/^[\/]*//;
138     $relPath=~s/[\/]*$//;
139    
140    
141 knops.gerd 12 # NOTE: With the right strings the code below triggers a bug in
142     # perl (5.8.6 currently) that will result in messages like
143     #
144     # Attempt to free unreferenced scalar
145     #
146     # and an eventual crash.
147     #
148     # So it was replaced with the more naive code following this
149     # commented out code.
150     #
151     # # split into path components
152     # my @pathComponents=split(/[\/]+/,$relPath);
153     #
154     # # Check components
155     # foreach (@pathComponents)
156     # {
157     # # Very strict: We only allow alphanumeric characters, dash and
158     # # underscore, followed by any number of extensions that also
159     # # only allow the above characters.
160     # unless(/^[a-z0-9\-\_][a-z0-9\-\_\.]*$/i)
161     # {
162     # &::syslog('debug',
163     # "Meteor::Document: Rejecting path '%s' due to invalid component '%s'",
164     # $relPath,$_
165     # );
166     #
167     # return undef;
168     # }
169     # }
170     #
171     #my $path=$::CONF{'SubscriberDocumentRoot'}.'/'.join('/',@pathComponents);
172    
173     #
174     # Check for all alphanumeric or dash, underscore, dot and slash
175     #
176     unless($relPath=~/^[a-z0-9\-\_\.\/]*$/i)
177 andrew.betts 10 {
178 knops.gerd 12 &::syslog('debug',
179     "Meteor::Document: Rejecting path '%s' due to invalid characters",
180     $relPath
181     );
182    
183     return undef;
184 andrew.betts 10 }
185 knops.gerd 12 #
186     # Don't allow '..'
187     #
188     if(index($relPath,'..')>=0)
189     {
190     &::syslog('debug',
191     "Meteor::Document: Rejecting path '%s' due to invalid sequence '..'",
192     $relPath
193     );
194    
195     return undef;
196     }
197 andrew.betts 10
198 knops.gerd 12 my $path=$::CONF{'SubscriberDocumentRoot'}.'/'.$relPath;
199 andrew.betts 10
200     # If it is a directory, append DirectoryIndex config value
201     $path.='/'.$::CONF{'DirectoryIndex'} if(-d $path);
202    
203     # Verify file is readable
204     return undef unless(-r $path);
205    
206     $path;
207     }
208    
209     ###############################################################################
210     # Factory methods
211     ###############################################################################
212     sub new {
213     #
214     # Create a new empty instance
215     #
216     my $class=shift;
217    
218     my $obj={};
219    
220     bless($obj,$class);
221     }
222    
223     sub newDocument {
224     #
225     # new instance from new server connection
226     #
227     my $self=shift->new();
228    
229     my $path=shift;
230     $self->{'path'}=$path;
231    
232     # Read file
233     {
234     local $/; # enable localized slurp mode
235     open(IN,$path) or return undef;
236     $self->{'document'}=<IN>;
237     close(IN);
238     }
239    
240     $self->{'size'}=length($self->{'document'});
241    
242     $self;
243     }
244    
245     ###############################################################################
246     # Instance methods
247     ###############################################################################
248     sub serveTo {
249     my $self=shift;
250     my $client=shift;
251    
252     $self->emitHeaderToClient($client,'200 OK');
253    
254     $client->write($self->{'document'});
255     }
256    
257     sub path {
258     shift->{'path'};
259     }
260    
261     1;
262     ############################################################################EOF

  ViewVC Help
Powered by ViewVC 1.1.26