/[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 10 - (hide annotations)
Thu Dec 14 10:45:43 2006 UTC (13 years, 6 months ago) by andrew.betts
File size: 4905 byte(s)
Some additional logging and bug fixes

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    
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     # split into path components
139     my @pathComponents=split(/[\/]+/,$relPath);
140    
141     # Check components
142     foreach (@pathComponents)
143     {
144     # Very strict: We only allow alphanumric characters, dash and
145     # underscore, followed by any number of extensions that also
146     # only allow the above characters.
147     unless(/^[a-z0-9\-\_][a-z0-9\-\_\.]*$/i)
148     {
149     &::syslog('debug',
150     "Meteor::Document: Rejecting path '%s' due to invalid component '%s'",
151     $relPath,$_
152     );
153    
154     return undef;
155     }
156     }
157    
158     my $path=$::CONF{'SubscriberDocumentRoot'}.'/'.join('/',@pathComponents);
159    
160     # If it is a directory, append DirectoryIndex config value
161     $path.='/'.$::CONF{'DirectoryIndex'} if(-d $path);
162    
163     # Verify file is readable
164     return undef unless(-r $path);
165    
166     $path;
167     }
168    
169     ###############################################################################
170     # Factory methods
171     ###############################################################################
172     sub new {
173     #
174     # Create a new empty instance
175     #
176     my $class=shift;
177    
178     my $obj={};
179    
180     bless($obj,$class);
181     }
182    
183     sub newDocument {
184     #
185     # new instance from new server connection
186     #
187     my $self=shift->new();
188    
189     my $path=shift;
190     $self->{'path'}=$path;
191    
192     # Read file
193     {
194     local $/; # enable localized slurp mode
195     open(IN,$path) or return undef;
196     $self->{'document'}=<IN>;
197     close(IN);
198     }
199    
200     $self->{'size'}=length($self->{'document'});
201    
202     $self;
203     }
204    
205     ###############################################################################
206     # Instance methods
207     ###############################################################################
208     sub serveTo {
209     my $self=shift;
210     my $client=shift;
211    
212     $self->emitHeaderToClient($client,'200 OK');
213    
214     $client->write($self->{'document'});
215     }
216    
217     sub path {
218     shift->{'path'};
219     }
220    
221     1;
222     ############################################################################EOF

  ViewVC Help
Powered by ViewVC 1.1.26