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