/[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 3 - (show annotations)
Mon Nov 20 17:59:30 2006 UTC (17 years, 4 months ago) by andrew.betts
File size: 4827 byte(s)
Initial import
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 my $doc=$class->documentForPath($relPath);
50
51 unless(defined($doc))
52 {
53 $class->emitHeaderToClient($client,'404 Not Found');
54
55 return undef;
56 }
57
58 $doc->serveTo($client);
59
60 $doc;
61 }
62
63 sub emitHeaderToClient {
64 my $self=shift;
65 my $client=shift;
66 my $status=shift;
67
68 my $header=$::CONF{'DocumentHeaderTemplate'};
69
70 $header=~s/~([^~]+)~/
71 if(!defined($1) || $1 eq '')
72 {
73 '~';
74 }
75 elsif($1 eq 'server')
76 {
77 $::PGM;
78 }
79 elsif($1 eq 'status')
80 {
81 $status;
82 }
83 else
84 {
85 '';
86 }
87 /gex;
88
89 $client->write($header);
90 }
91
92 sub documentForPath {
93 my $class=shift;
94 my $relPath=shift;
95
96 unless(exists($Documents{$relPath}))
97 {
98 my $path=$class->pathToAbsolute($relPath);
99
100 return undef unless(defined($path));
101
102 my $doc=$class->newDocument($path);
103
104 return undef unless(defined($doc));
105
106 $Documents{$relPath}=$doc;
107 }
108
109 $Documents{$relPath};
110 }
111
112 sub clearDocuments {
113 %Documents=();
114 }
115
116 sub pathToAbsolute {
117 my $class=shift;
118 my $relPath=shift;
119
120 # Don't serve documents unless SubscriberDocumentRoot is set
121 unless(exists($::CONF{'SubscriberDocumentRoot'})
122 && $::CONF{'SubscriberDocumentRoot'} ne ''
123 && $::CONF{'SubscriberDocumentRoot'} ne '/'
124 )
125 {
126 return undef;
127 }
128
129 #
130 # Verify if name is legal
131 #
132 # Strip leading and trailing slashes
133 $relPath=~s/^[\/]*//;
134 $relPath=~s/[\/]*$//;
135
136 # split into path components
137 my @pathComponents=split(/[\/]+/,$relPath);
138
139 # Check components
140 foreach (@pathComponents)
141 {
142 # Very strict: We only allow alphanumric characters, dash and
143 # underscore, followed by any number of extensions that also
144 # only allow the above characters.
145 unless(/^[a-z0-9\-\_][a-z0-9\-\_\.]*$/i)
146 {
147 &::syslog('debug',
148 "Meteor::Document: Rejecting path '%s' due to invalid component '%s'",
149 $relPath,$_
150 );
151
152 return undef;
153 }
154 }
155
156 my $path=$::CONF{'SubscriberDocumentRoot'}.'/'.join('/',@pathComponents);
157
158 # If it is a directory, append DirectoryIndex config value
159 $path.='/'.$::CONF{'DirectoryIndex'} if(-d $path);
160
161 # Verify file is readable
162 return undef unless(-r $path);
163
164 $path;
165 }
166
167 ###############################################################################
168 # Factory methods
169 ###############################################################################
170 sub new {
171 #
172 # Create a new empty instance
173 #
174 my $class=shift;
175
176 my $obj={};
177
178 bless($obj,$class);
179 }
180
181 sub newDocument {
182 #
183 # new instance from new server connection
184 #
185 my $self=shift->new();
186
187 my $path=shift;
188 $self->{'path'}=$path;
189
190 # Read file
191 {
192 local $/; # enable localized slurp mode
193 open(IN,$path) or return undef;
194 $self->{'document'}=<IN>;
195 close(IN);
196 }
197
198 $self->{'size'}=length($self->{'document'});
199
200 $self;
201 }
202
203 ###############################################################################
204 # Instance methods
205 ###############################################################################
206 sub serveTo {
207 my $self=shift;
208 my $client=shift;
209
210 $self->emitHeaderToClient($client,'200 OK');
211
212 $client->write($self->{'document'});
213 }
214
215 sub path {
216 shift->{'path'};
217 }
218
219 1;
220 ############################################################################EOF

  ViewVC Help
Powered by ViewVC 1.1.26