/[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 3 - (hide annotations)
Mon Nov 20 17:59:30 2006 UTC (13 years, 7 months ago) by andrew.betts
File size: 4827 byte(s)
Initial import
1 andrew.betts 3 #!/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