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