]>
Dogcows Code - chaz/chatty/blob - Meteor/Document.pm
2 ###############################################################################
4 # An HTTP server for the 2.0 web
5 # Copyright (c) 2006 contributing authors
10 # Cache and serve static documents
12 ###############################################################################
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)
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
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
28 # For more information visit www.meteorserver.org
30 ###############################################################################
32 package Meteor
::Document
;
33 ###############################################################################
35 ###############################################################################
41 ###############################################################################
43 ###############################################################################
44 sub serveFileToClient
{
49 &::syslog
('debug',"Meteor::Document: Request received for '%s'",$relPath);
51 my $doc=$class->documentForPath($relPath);
55 $class->emitHeaderToClient($client,'404 Not Found');
56 $::Statistics-
>{'documents_not_found'}++;
68 $doc->serveTo($client);
70 $::Statistics-
>{'documents_served'}++;
82 sub emitHeaderToClient
{
87 my $contenttype=shift;
88 $length = 0 unless ($length);
89 $contenttype = "text/html" unless ($contenttype);
91 my $header="HTTP/1.1 ".$status."\r\nServer: ".$::PGM
."\r\nContent-Type: ".$contenttype."; charset=utf-8\r\nPragma: no-cache\r\nCache-Control: no-cache, no-store, must-revalidate\r\nExpires: Thu, 1 Jan 1970 00:00:00 GMT\r\nContent-length: ".$length."\r\n\r\n";
93 $client->write($header);
100 unless(exists($Documents{$relPath}))
102 my $path=$class->pathToAbsolute($relPath);
104 return undef unless(defined($path));
106 my $doc=$class->newDocument($path);
108 return undef unless(defined($doc));
110 $Documents{$relPath}=$doc;
113 $Documents{$relPath};
124 # Don't serve documents unless SubscriberDocumentRoot is set
125 unless(exists($::CONF
{'SubscriberDocumentRoot'})
126 && $::CONF
{'SubscriberDocumentRoot'} ne ''
127 && $::CONF
{'SubscriberDocumentRoot'} ne '/'
134 # Verify if name is legal
136 # Strip leading and trailing slashes
137 $relPath=~s/^[\/]*//;
138 $relPath=~s/[\/]*$//;
141 # NOTE: With the right strings the code below triggers a bug in
142 # perl (5.8.6 currently) that will result in messages like
144 # Attempt to free unreferenced scalar
146 # and an eventual crash.
148 # So it was replaced with the more naive code following this
149 # commented out code.
151 # # split into path components
152 # my @pathComponents=split(/[\/]+/,$relPath);
155 # foreach (@pathComponents)
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)
163 # "Meteor::Document: Rejecting path '%s' due to invalid component '%s'",
171 #my $path=$::CONF{'SubscriberDocumentRoot'}.'/'.join('/',@pathComponents);
174 # Check for all alphanumeric or dash, underscore, dot and slash
176 unless($relPath=~/^[a-z0-9\-\_\.\/]*$/i)
179 "Meteor::Document: Rejecting path '%s' due to invalid characters",
188 if(index($relPath,'..')>=0)
191 "Meteor::Document: Rejecting path '%s' due to invalid sequence '..'",
198 my $path=$::CONF
{'SubscriberDocumentRoot'}.'/'.$relPath;
200 # If it is a directory, append DirectoryIndex config value
201 $path.='/'.$::CONF
{'DirectoryIndex'} if(-d
$path);
203 # Verify file is readable
204 return undef unless(-r
$path);
209 ###############################################################################
211 ###############################################################################
214 # Create a new empty instance
225 # new instance from new server connection
227 my $self=shift-
>new();
230 $self->{'path'}=$path;
234 local $/; # enable localized slurp mode
235 open(IN
,$path) or return undef;
236 $self->{'document'}=<IN
>;
240 $self->{'size'}=length($self->{'document'});
245 ###############################################################################
247 ###############################################################################
251 my $ct = "text/html";
252 if ($self->{'path'} =~/\.(js)$/) {
253 $ct = "text/javascript";
256 $self->emitHeaderToClient($client,'200 OK',$self->{'size'}, $ct);
258 $client->write($self->{'document'});
267 ############################################################################EOF
This page took 0.054458 seconds and 4 git commands to generate.