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::RO::DirHandle - The anonymous, read-only FTP server personality 26 27=head1 SYNOPSIS 28 29 use Net::FTPServer::RO::DirHandle; 30 31=head1 METHODS 32 33=cut 34 35package Net::FTPServer::RO::DirHandle; 36 37use strict; 38 39use vars qw($VERSION); 40( $VERSION ) = '$Revision: 1.2 $ ' =~ /\$Revision:\s+([^\s]+)/; 41 42use IO::Dir; 43use Carp qw(confess); 44 45use Net::FTPServer::DirHandle; 46 47use vars qw(@ISA); 48 49@ISA = qw(Net::FTPServer::DirHandle); 50 51=pod 52 53=over 4 54 55=item $handle = $dirh->get ($filename); 56 57Return the file or directory C<$handle> corresponding to 58the file C<$filename> in directory C<$dirh>. If there is 59no file or subdirectory of that name, then this returns 60undef. 61 62=cut 63 64sub get 65 { 66 my $self = shift; 67 my $filename = shift; 68 69 # None of these cases should ever happen. 70 confess "no filename" unless defined($filename) && length($filename); 71 confess "slash filename" if $filename =~ /\//; 72 confess ".. filename" if $filename eq ".."; 73 confess ". filename" if $filename eq "."; 74 75 my $pathname = $self->{_pathname} . $filename; 76 stat $pathname; 77 78 if (-d _) 79 { 80 return Net::FTPServer::RO::DirHandle->new ($self->{ftps}, $pathname."/"); 81 } 82 83 if (-e _) 84 { 85 return Net::FTPServer::RO::FileHandle->new ($self->{ftps}, $pathname); 86 } 87 88 return undef; 89 } 90 91=item $dirh = $dirh->parent; 92 93Return the parent directory of the directory C<$dirh>. If 94the directory is already "/", this returns the same directory handle. 95 96=cut 97 98sub parent 99 { 100 my $self = shift; 101 102 my $parent = $self->SUPER::parent; 103 bless $parent, ref $self; 104 return $parent; 105 } 106 107=pod 108 109=item $ref = $dirh->list ([$wildcard]); 110 111Return a list of the contents of directory C<$dirh>. The list 112returned is a reference to an array of pairs: 113 114 [ $filename, $handle ] 115 116The list returned does I<not> include "." or "..". 117 118The list is sorted into alphabetical order automatically. 119 120=cut 121 122sub list 123 { 124 my $self = shift; 125 my $wildcard = shift; 126 127 # Convert wildcard to a regular expression. 128 if ($wildcard) 129 { 130 $wildcard = $self->{ftps}->wildcard_to_regex ($wildcard); 131 } 132 133 my $dir = new IO::Dir ($self->{_pathname}) 134 or return undef; 135 136 my $file; 137 my @filenames = (); 138 139 while (defined ($file = $dir->read)) 140 { 141 next if $file eq "." || $file eq ".."; 142 next if $wildcard && $file !~ /$wildcard/; 143 144 push @filenames, $file; 145 } 146 147 $dir->close; 148 149 @filenames = sort @filenames; 150 my @array = (); 151 152 foreach $file (@filenames) 153 { 154 if (my $handle = $self->get($file)) { 155 push @array, [ $file, $handle ]; 156 } 157 } 158 159 return \@array; 160 } 161 162=pod 163 164=item $ref = $dirh->list_status ([$wildcard]); 165 166Return a list of the contents of directory C<$dirh> and 167status information. The list returned is a reference to 168an array of triplets: 169 170 [ $filename, $handle, $statusref ] 171 172where $statusref is the tuple returned from the C<status> 173method (see L<Net::FTPServer::Handle>). 174 175The list returned does I<not> include "." or "..". 176 177The list is sorted into alphabetical order automatically. 178 179=cut 180 181sub list_status 182 { 183 my $self = shift; 184 185 my $arrayref = $self->list (@_); 186 my $elem; 187 188 foreach $elem (@$arrayref) 189 { 190 my @status = $elem->[1]->status; 191 push @$elem, \@status; 192 } 193 194 return $arrayref; 195 } 196 197=pod 198 199=item ($mode, $perms, $nlink, $user, $group, $size, $time) = $handle->status; 200 201Return the file or directory status. The fields returned are: 202 203 $mode Mode 'd' = directory, 204 'f' = file, 205 and others as with 206 the find(1) -type option. 207 $perms Permissions Permissions in normal octal numeric format. 208 $nlink Link count 209 $user Username In printable format. 210 $group Group name In printable format. 211 $size Size File size in bytes. 212 $time Time Time (usually mtime) in Unix time_t format. 213 214In derived classes, some of this status information may well be 215synthesized, since virtual filesystems will often not contain 216information in a Unix-like format. 217 218=cut 219 220sub status 221 { 222 my $self = shift; 223 224 my ($dev, $ino, $mode, $nlink, $uid, $gid, $rdev, $size, 225 $atime, $mtime, $ctime, $blksize, $blocks) 226 = lstat $self->{_pathname}; 227 228 # If the directory has been removed since we created this 229 # handle, then $dev will be undefined. Return dummy status 230 # information. 231 return ("d", 0000, 1, "-", "-", 0, 0) unless defined $dev; 232 233 # Generate printable user/group. 234 my $user = getpwuid ($uid) || "-"; 235 my $group = getgrgid ($gid) || "-"; 236 237 # Permissions from mode. 238 my $perms = $mode & 0777; 239 240 # Work out the mode using special "_" operator which causes Perl 241 # to use the result of the previous stat call. 242 $mode 243 = (-f _ ? 'f' : 244 (-d _ ? 'd' : 245 (-l _ ? 'l' : 246 (-p _ ? 'p' : 247 (-S _ ? 's' : 248 (-b _ ? 'b' : 249 (-c _ ? 'c' : '?'))))))); 250 251 return ($mode, $perms, $nlink, $user, $group, $size, $mtime); 252 } 253 254=pod 255 256=item $rv = $handle->move ($dirh, $filename); 257 258Move the current file (or directory) into directory C<$dirh> and 259call it C<$filename>. If the operation is successful, return 0, 260else return -1. 261 262Underlying filesystems may impose limitations on moves: for example, 263it may not be possible to move a directory; it may not be possible 264to move a file to another directory; it may not be possible to 265move a file across filesystems. 266 267=cut 268 269sub move 270 { 271 return -1; # Not permitted in read-only server. 272 } 273 274=pod 275 276=item $rv = $dirh->delete; 277 278Delete the current directory. If the delete command was 279successful, then return 0, else if there was an error return -1. 280 281It is normally only possible to delete a directory if it 282is empty. 283 284=cut 285 286sub delete 287 { 288 return -1; # Not permitted in read-only server. 289 } 290 291=item $rv = $dirh->mkdir ($name); 292 293Create a subdirectory called C<$name> within the current directory 294C<$dirh>. 295 296=cut 297 298sub mkdir 299 { 300 return -1; # Not permitted in read-only server. 301 } 302 303=item $file = $dirh->open ($filename, "r"|"w"|"a"); 304 305Open or create a file called C<$filename> in the current directory, 306opening it for either read, write or append. This function 307returns a C<IO::File> handle object. 308 309=cut 310 311sub open 312 { 313 my $self = shift; 314 my $filename = shift; 315 my $mode = shift; 316 317 die if $filename =~ /\//; # Should never happen. 318 319 return undef unless $mode eq "r"; 320 321 return new IO::File $self->{_pathname} . $filename, $mode; 322 } 323 3241 # So that the require or use succeeds. 325 326__END__ 327 328=back 329 330=head1 AUTHORS 331 332Richard Jones (rich@annexia.org). 333 334=head1 COPYRIGHT 335 336Copyright (C) 2000 Biblio@Tech Ltd., Unit 2-3, 50 Carnwath Road, 337London, SW6 3EG, UK 338 339=head1 SEE ALSO 340 341C<Net::FTPServer(3)>, C<perl(1)> 342 343=cut 344