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::Full::FileHandle - The full FTP server personality 26 27=head1 SYNOPSIS 28 29 use Net::FTPServer::Full::FileHandle; 30 31=head1 METHODS 32 33=cut 34 35package Net::FTPServer::Full::FileHandle; 36 37use strict; 38 39use vars qw($VERSION); 40( $VERSION ) = '$Revision: 1.2 $ ' =~ /\$Revision:\s+([^\s]+)/; 41 42use Net::FTPServer::FileHandle; 43 44use vars qw(@ISA); 45 46@ISA = qw(Net::FTPServer::FileHandle); 47 48=pod 49 50=over 4 51 52=item $dirh = $fileh->dir; 53 54Return the directory which contains this file. 55 56=cut 57 58sub dir 59 { 60 my $self = shift; 61 62 my $dirname = $self->{_pathname}; 63 $dirname =~ s,[^/]+$,,; 64 65 return Net::FTPServer::Full::DirHandle->new ($self->{ftps}, $dirname); 66 } 67 68=pod 69 70=item $fh = $fileh->open (["r"|"w"|"a"]); 71 72Open a file handle (derived from C<IO::Handle>, see 73C<IO::Handle(3)>) in either read or write mode. 74 75=cut 76 77sub open 78 { 79 my $self = shift; 80 my $mode = shift; 81 82 return new IO::File $self->{_pathname}, $mode; 83 } 84 85=pod 86 87=item ($mode, $perms, $nlink, $user, $group, $size, $time) = $handle->status; 88 89Return the file or directory status. The fields returned are: 90 91 $mode Mode 'd' = directory, 92 'f' = file, 93 and others as with 94 the find(1) -type option. 95 $perms Permissions Permissions in normal octal numeric format. 96 $nlink Link count 97 $user Username In printable format. 98 $group Group name In printable format. 99 $size Size File size in bytes. 100 $time Time Time (usually mtime) in Unix time_t format. 101 102In derived classes, some of this status information may well be 103synthesized, since virtual filesystems will often not contain 104information in a Unix-like format. 105 106=cut 107 108sub status 109 { 110 my $self = shift; 111 112 my ($dev, $ino, $mode, $nlink, $uid, $gid, $rdev, $size, 113 $atime, $mtime, $ctime, $blksize, $blocks) 114 = lstat $self->{_pathname}; 115 116 # If the file has been removed since we created this 117 # handle, then $dev will be undefined. Return dummy status 118 # information. 119 return ("f", 0000, 1, "-", "-", 0, 0) unless defined $dev; 120 121 # Generate printable user/group. 122 my $user = getpwuid ($uid) || "-"; 123 my $group = getgrgid ($gid) || "-"; 124 125 # Permissions from mode. 126 my $perms = $mode & 0777; 127 128 # Work out the mode using special "_" operator which causes Perl 129 # to use the result of the previous stat call. 130 $mode 131 = (-f _ ? 'f' : 132 (-d _ ? 'd' : 133 (-l _ ? 'l' : 134 (-p _ ? 'p' : 135 (-S _ ? 's' : 136 (-b _ ? 'b' : 137 (-c _ ? 'c' : '?'))))))); 138 139 return ($mode, $perms, $nlink, $user, $group, $size, $mtime); 140 } 141 142=pod 143 144=item $rv = $handle->move ($dirh, $filename); 145 146Move the current file (or directory) into directory C<$dirh> and 147call it C<$filename>. If the operation is successful, return 0, 148else return -1. 149 150Underlying filesystems may impose limitations on moves: for example, 151it may not be possible to move a directory; it may not be possible 152to move a file to another directory; it may not be possible to 153move a file across filesystems. 154 155=cut 156 157sub move 158 { 159 my $self = shift; 160 my $dirh = shift; 161 my $filename = shift; 162 163 die if $filename =~ /\//; # Should never happen. 164 165 my $new_name = $dirh->{_pathname} . $filename; 166 167 rename $self->{_pathname}, $new_name or return -1; 168 169 $self->{_pathname} = $new_name; 170 return 0; 171 } 172 173=pod 174 175=item $rv = $fileh->delete; 176 177Delete the current file. If the delete command was 178successful, then return 0, else if there was an error return -1. 179 180=cut 181 182sub delete 183 { 184 my $self = shift; 185 186 unlink $self->{_pathname} or return -1; 187 188 return 0; 189 } 190 191=item $link = $fileh->readlink; 192 193If the current file is really a symbolic link, read the contents 194of the link and return it. 195 196=cut 197 198sub readlink 199 { 200 my $self = shift; 201 202 return readlink $self->{_pathname}; 203 } 204 2051 # So that the require or use succeeds. 206 207__END__ 208 209=back 210 211=head1 AUTHORS 212 213Richard Jones (rich@annexia.org). 214 215=head1 COPYRIGHT 216 217Copyright (C) 2000 Biblio@Tech Ltd., Unit 2-3, 50 Carnwath Road, 218London, SW6 3EG, UK 219 220=head1 SEE ALSO 221 222C<Net::FTPServer(3)>, C<perl(1)> 223 224=cut 225