1# -*- perl -*-
2
3# Net::FTPServer A Perl FTP Server
4# Copyright (C) 2000 Bibliotech Ltd., Unit 2-3, 50 Carnwath Road,
5# London, SW6 3EG, United Kingdom.
6#
7# This program is free software; you can redistribute it and/or modify
8# it under the terms of the GNU General Public License as published by
9# the Free Software Foundation; either version 2 of the License, or
10# (at your option) any later version.
11#
12# This program is distributed in the hope that it will be useful,
13# but WITHOUT ANY WARRANTY; without even the implied warranty of
14# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
15# GNU General Public License for more details.
16#
17# You should have received a copy of the GNU General Public License
18# along with this program; if not, write to the Free Software
19# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
20
21=pod
22
23=head1 NAME
24
25Net::FTPServer::InMem::DirHandle - Store files in local memory
26
27=head1 SYNOPSIS
28
29  use Net::FTPServer::InMem::DirHandle;
30
31=head1 METHODS
32
33=cut
34
35package Net::FTPServer::InMem::DirHandle;
36
37use strict;
38
39use vars qw($VERSION);
40( $VERSION ) = '$Revision: 1.1 $ ' =~ /\$Revision:\s+([^\s]+)/;
41
42use Carp qw(confess croak);
43use IO::Scalar;
44
45use Net::FTPServer::DirHandle;
46
47use vars qw(@ISA);
48
49@ISA = qw(Net::FTPServer::DirHandle);
50
51# Global variables.
52use vars qw(%dirs $next_dir_id %files $next_file_id);
53
54# The initial directory structure.
55$next_dir_id = 2;
56$dirs{1} = { name => "", parent => 0 };
57$next_file_id = 1;
58
59# Return a new directory handle.
60
61sub new
62  {
63    my $class = shift;
64    my $ftps = shift;		# FTP server object.
65    my $pathname = shift || "/"; # (only used in internal calls)
66    my $dir_id = shift;		# (only used in internal calls)
67
68    # Create object.
69    my $self = Net::FTPServer::DirHandle->new ($ftps, $pathname);
70    bless $self, $class;
71
72    if ($dir_id)
73      {
74	$self->{fs_dir_id} = $dir_id;
75      }
76    else
77      {
78	$self->{fs_dir_id} = 1;
79      }
80
81    return $self;
82  }
83
84# Return a subdirectory handle or a file handle within this directory.
85
86sub get
87  {
88    my $self = shift;
89    my $filename = shift;
90
91    # None of these cases should ever happen.
92    confess "no filename" unless defined($filename) && length($filename);
93    confess "slash filename" if $filename =~ /\//;
94    confess ".. filename"    if $filename eq "..";
95    confess ". filename"     if $filename eq ".";
96
97    # Search for the file first, since files are more common than dirs.
98    foreach (keys %files)
99      {
100	if ($files{$_}{dir_id} == $self->{fs_dir_id} &&
101	    $files{$_}{name} eq $filename)
102	  {
103	    # Found a file.
104	    return new Net::FTPServer::InMem::FileHandle ($self->{ftps},
105							  $self->pathname . $filename,
106							  $self->{fs_dir_id},
107							  $_,
108							  $files{$_}{content});
109	  }
110      }
111
112    # Search for a directory.
113    foreach (keys %dirs)
114      {
115	if ($dirs{$_}{parent} == $self->{fs_dir_id} &&
116	    $dirs{$_}{name} eq $filename)
117	  {
118	    # Found a directory.
119	    return new Net::FTPServer::InMem::DirHandle ($self->{ftps},
120							 $self->pathname . $filename . "/",
121							 $_);
122	  }
123      }
124
125    # Not found.
126    return undef;
127  }
128
129# Get parent of current directory.
130
131sub parent
132  {
133    my $self = shift;
134
135    return $self if $self->is_root;
136
137    # Get a new directory handle.
138    my $dirh = $self->SUPER::parent;
139
140    # Find directory ID of the parent directory.
141    $dirh->{fs_dir_id} = $dirs{$self->{fs_dir_id}}{parent};
142
143    return bless $dirh, ref $self;
144  }
145
146sub list
147  {
148    my $self = shift;
149    my $wildcard = shift;
150
151    # Convert wildcard to regular expression.
152    if ($wildcard)
153      {
154	if ($wildcard ne "*")
155	  {
156	    $wildcard = $self->{ftps}->wildcard_to_regex ($wildcard);
157	  }
158	else
159	  {
160	    $wildcard = undef;
161	  }
162      }
163
164    # Get subdirectories.
165    my @dirs;
166    if ($wildcard)
167      {
168	@dirs = grep { $dirs{$_}{parent} == $self->{fs_dir_id} &&
169		       $dirs{$_}{name} =~ /$wildcard/ } keys %dirs;
170      }
171    else
172      {
173	@dirs = grep { $dirs{$_}{parent} == $self->{fs_dir_id} } keys %dirs;
174      }
175
176    my @result = ();
177    my $username = substr $self->{ftps}{user}, 0, 8;
178
179    foreach (@dirs)
180      {
181	my $dirh
182	  = new Net::FTPServer::InMem::DirHandle ($self->{ftps},
183						  $self->pathname . $dirs{$_}{name} . "/",
184						  $_);
185
186	push @result, [ $dirs{$_}{name}, $dirh ];
187      }
188
189    # Get files.
190    my @files;
191    if ($wildcard)
192      {
193	@files = grep { $files{$_}{dir_id} == $self->{fs_dir_id} &&
194			$files{$_}{name} =~ /$wildcard/ } keys %files;
195      }
196    else
197      {
198	@files = grep { $files{$_}{dir_id} == $self->{fs_dir_id} } keys %files;
199      }
200
201    foreach (@files)
202      {
203	my $fileh
204	  = new Net::FTPServer::InMem::FileHandle ($self->{ftps},
205						   $self->pathname . $files{$_}{name},
206						   $self->{fs_dir_id},
207						   $_,
208						   $files{$_}{content});
209
210	push @result, [ $files{$_}{name}, $fileh ];
211      }
212
213    return \@result;
214  }
215
216sub list_status
217  {
218    my $self = shift;
219    my $wildcard = shift;
220
221    # Convert wildcard to regular expression.
222    if ($wildcard)
223      {
224	if ($wildcard ne "*")
225	  {
226	    $wildcard = $self->{ftps}->wildcard_to_regex ($wildcard);
227	  }
228	else
229	  {
230	    $wildcard = undef;
231	  }
232      }
233
234    # Get subdirectories.
235    my @dirs;
236    if ($wildcard)
237      {
238	@dirs = grep { $dirs{$_}{parent} == $self->{fs_dir_id} &&
239		       $dirs{$_}{name} =~ /$wildcard/ } keys %dirs;
240      }
241    else
242      {
243	@dirs = grep { $dirs{$_}{parent} == $self->{fs_dir_id} } keys %dirs;
244      }
245
246    my @result = ();
247    my $username = substr $self->{ftps}{user}, 0, 8;
248
249    foreach (@dirs)
250      {
251	my $dirh
252	  = new Net::FTPServer::InMem::DirHandle ($self->{ftps},
253						  $self->pathname . $dirs{$_}{name} . "/",
254						  $_);
255
256	my @status = $dirh->status;
257	push @result, [ $dirs{$_}{name}, $dirh, \@status ];
258      }
259
260    # Get files.
261    my @files;
262    if ($wildcard)
263      {
264	@files = grep { $files{$_}{dir_id} == $self->{fs_dir_id} &&
265			$files{$_}{name} =~ /$wildcard/ } keys %files;
266      }
267    else
268      {
269	@files = grep { $files{$_}{dir_id} == $self->{fs_dir_id} } keys %files;
270      }
271
272    foreach (@files)
273      {
274	my $fileh
275	  = new Net::FTPServer::InMem::FileHandle ($self->{ftps},
276						   $self->pathname . $files{$_}{name},
277						   $self->{fs_dir_id},
278						   $_,
279						   $files{$_}{content});
280
281	my @status = $fileh->status;
282	push @result, [ $files{$_}{name}, $fileh, \@status ];
283      }
284
285    return \@result;
286  }
287
288# Return the status of this directory.
289
290sub status
291  {
292    my $self = shift;
293    my $username = substr $self->{ftps}{user}, 0, 8;
294
295    return ( 'd', 0755, 1, $username, "users", 1024, 0 );
296  }
297
298# Move a directory to elsewhere.
299
300sub move
301  {
302    my $self = shift;
303    my $dirh = shift;
304    my $filename = shift;
305
306    # You can't move the root directory. That would be bad :-)
307    return -1 if $self->is_root;
308
309    $dirs{$self->{fs_dir_id}}{parent} = $dirh->{fs_dir_id};
310    $dirs{$self->{fs_dir_id}}{name} = $filename;
311
312    return 0;
313  }
314
315sub delete
316  {
317    my $self = shift;
318
319    delete $dirs{$self->{fs_dir_id}};
320
321    return 0;
322  }
323
324# Create a subdirectory.
325
326sub mkdir
327  {
328    my $self = shift;
329    my $dirname = shift;
330
331    $dirs{$next_dir_id++} = { name => $dirname, parent => $self->{fs_dir_id} };
332
333    return 0;
334  }
335
336# Open or create a file in this directory.
337
338sub open
339  {
340    my $self = shift;
341    my $filename = shift;
342    my $mode = shift;
343
344    if ($mode eq "r")		# Open an existing file for reading.
345      {
346	foreach (keys %files)
347	  {
348	    if ($files{$_}{dir_id} == $self->{fs_dir_id} &&
349		$files{$_}{name} eq $filename)
350	      {
351		return new IO::Scalar ($files{$_}{content});
352	      }
353	  }
354
355	return undef;
356      }
357    elsif ($mode eq "w")	# Create/overwrite the file.
358      {
359	# If a file with the same name exists already, erase it.
360	foreach (keys %files)
361	  {
362	    if ($files{$_}{dir_id} == $self->{fs_dir_id} &&
363		$files{$_}{name} eq $filename)
364	      {
365		delete $files{$_};
366		last;
367	      }
368	  }
369
370	my $content = "";
371
372	$files{$next_file_id++} = { dir_id => $self->{fs_dir_id},
373				    name => $filename,
374				    content => \$content };
375
376	return new IO::Scalar (\$content);
377      }
378    elsif ($mode eq "a")	# Append to the file.
379      {
380	foreach (keys %files)
381	  {
382	    if ($files{$_}{dir_id} == $self->{fs_dir_id} &&
383		$files{$_}{name} eq $filename)
384	      {
385		return new IO::Scalar ($files{$_}{content});
386	      }
387	  }
388
389	return undef;
390      }
391    else
392      {
393	croak "unknown file mode: $mode; use 'r', 'w' or 'a' instead";
394      }
395  }
396
3971 # So that the require or use succeeds.
398
399__END__
400
401=head1 AUTHORS
402
403Richard Jones (rich@annexia.org).
404
405=head1 COPYRIGHT
406
407Copyright (C) 2000 Biblio@Tech Ltd., Unit 2-3, 50 Carnwath Road,
408London, SW6 3EG, UK
409
410=head1 SEE ALSO
411
412C<Net::FTPServer(3)>, C<perl(1)>
413
414=cut
415