sub _CWD_command
{
my ($conn, $cmd, $path) = @_;
+ my $paths = $conn->{'paths'};
local $_;
- my $newdir = $conn->{dir};
-
- # If the path starts with a "/" then it's an absolute path.
- if (substr ($path, 0, 1) eq "/") {
- $newdir = "";
- $path =~ s,^/+,,;
- }
+ my $new_path = FTPPaths::path_merge($conn->{'dir'}, $path);
# Split the path into its component parts and process each separately.
- my @elems = split /\//, $path;
-
- foreach (@elems) {
- if ($_ eq "" || $_ eq ".") {
- # Ignore these.
- next;
- } elsif ($_ eq "..") {
- # Go to parent directory.
- if ($newdir eq "") {
- print {$conn->{socket}} "550 Directory not found.\r\n";
- return;
- }
- $newdir = substr ($newdir, 0, rindex ($newdir, "/"));
- } else {
- # Go into subdirectory, if it exists.
- $newdir .= ("/" . $_);
- if (! -d $conn->{rootdir} . $newdir) {
- print {$conn->{socket}} "550 Directory not found.\r\n";
- return;
- }
- }
+ if (! $paths->dir_exists($new_path)) {
+ print {$conn->{socket}} "550 Directory not found.\r\n";
+ return;
}
- $conn->{dir} = $newdir;
+ $conn->{'dir'} = $new_path;
+ print {$conn->{socket}} "200 directory changed to $new_path.\r\n";
}
sub _LIST_command
{
my ($conn, $cmd, $path) = @_;
+ my $paths = $conn->{'paths'};
# This is something of a hack. Some clients expect a Unix server
# to respond to flags on the 'ls command line'. Remove these flags
# and ignore them. This is particularly an issue with ncftp 2.4.3.
$path =~ s/^-[a-zA-Z0-9]+\s?//;
- my $dir = $conn->{dir};
+ my $dir = $conn->{'dir'};
print STDERR "_LIST_command - dir is: $dir\n";
- # Absolute path?
- if (substr ($path, 0, 1) eq "/") {
- $dir = "/";
- $path =~ s,^/+,,;
- }
-
# Parse the first elements of the path until we find the appropriate
# working directory.
- my @elems = split /\//, $path;
- my ($wildcard, $filename);
local $_;
- for (my $i = 0; $i < @elems; ++$i) {
- $_ = $elems[$i];
- my $lastelement = $i == @elems-1;
-
- if ($_ eq "" || $_ eq ".") { next } # Ignore these.
- elsif ($_ eq "..") {
- # Go to parent directory.
- unless ($dir eq "/") {
- $dir = substr ($dir, 0, rindex ($dir, "/"));
- }
- } else {
- if (!$lastelement) { # These elements can only be directories.
- unless (-d $conn->{rootdir} . $dir . $_) {
- print {$conn->{socket}} "550 File or directory not found.\r\n";
- return;
- }
- $dir .= $_;
- } else { # It's the last element: check if it's a file, directory or wildcard.
- if (-f $conn->{rootdir} . $dir . $_) {
- # It's a file.
- $filename = $_;
- } elsif (-d $conn->{rootdir} . $dir . $_) {
- # It's a directory.
- $dir .= $_;
- } elsif (/\*/ || /\?/) {
- # It is a wildcard.
- $wildcard = $_;
- } else {
- print {$conn->{socket}} "550 File or directory not found.\r\n";
- return;
- }
- }
- }
+ $dir = FTPPaths::path_merge($dir, $path);
+ my $listing = $paths->get_list($dir);
+ unless ($listing) {
+ print {$conn->{socket}} "550 File or directory not found.\r\n";
+ return;
}
print STDERR "_LIST_command - dir is: $dir\n" if $log;
# Open a path back to the client.
my $sock = __open_data_connection ($conn);
-
unless ($sock) {
print {$conn->{socket}} "425 Can't open data connection.\r\n";
return;
}
- # If the path contains a directory name, extract it so that
- # we can prefix it to every filename listed.
- my $prefix = (($filename || $wildcard) && $path =~ /(.*\/).*/) ? $1 : "";
-
- print STDERR "_LIST_command - prefix is: $prefix\n" if $log;
-
- # OK, we're either listing a full directory, listing a single
- # file or listing a wildcard.
- if ($filename) { # Single file.
- __list_file ($sock, $prefix . $filename);
- } else { # Wildcard or full directory $dirh.
- unless ($wildcard) {
- # Synthesize (fake) "total" field for directory listing.
- print $sock "total 1 \r\n";
- }
-
- foreach (__get_file_list ($conn->{rootdir} . $dir, $wildcard)) {
- __list_file ($sock, $prefix . $_);
- }
+ for my $item (@$listing) {
+ print $sock "$item\r\n";
}
unless ($sock->close) {
{
my ($conn, $cmd, $path) = @_;
- my $dir = $conn->{dir};
-
- # Absolute path?
- if (substr ($path, 0, 1) eq "/") {
- $dir = "/";
- $path =~ s,^/+,,;
- $path = "." if $path eq "";
- }
-
- # Parse the first elements of path until we find the appropriate
- # working directory.
- my @elems = split /\//, $path;
- my $filename = pop @elems;
-
- foreach (@elems) {
- if ($_ eq "" || $_ eq ".") {
- next # Ignore these.
- } elsif ($_ eq "..") {
- # Go to parent directory.
- unless ($dir eq "/") {
- $dir = substr ($dir, 0, rindex ($dir, "/"));
- }
- } else {
- unless (-d $conn->{rootdir} . $dir . $_) {
- print {$conn->{socket}} "550 File or directory not found.\r\n";
- return;
- }
- $dir .= $_;
- }
- }
+ $path = FTPPaths::path_merge($conn->{dir}, $path);
+ my $info = $conn->{'paths'}->get_info($path);
- unless (defined $filename && length $filename) {
- print {$conn->{socket}} "550 File or directory not found.\r\n";
- return;
- }
-
- if ($filename eq "." || $filename eq "..") {
- print {$conn->{socket}} "550 RETR command is not supported on directories.\r\n";
- return;
- }
-
- my $fullname = $conn->{rootdir} . $dir . $filename;
- unless (-f $fullname) {
- print {$conn->{socket}} "550 RETR command is only supported on plain files.\r\n";
- return;
- }
-
- # Try to open the file.
- unless (open (FILE, '<', $fullname)) {
- print {$conn->{socket}} "550 File or directory not found.\r\n";
+ unless ($info->{'_type'} eq 'f') {
+ print {$conn->{socket}} "550 File not found.\r\n";
return;
}
print {$conn->{socket}} "150 Opening " .
($conn->{type} eq 'A' ? "ASCII mode" : "BINARY mode") .
- " data connection for file $filename.\r\n";
+ " data connection.\r\n";
# Open a path back to the client.
my $sock = __open_data_connection ($conn);
return;
}
+ my $content = $info->{'content'};
+
+ # Restart the connection from previous point?
+ if ($conn->{restart}) {
+ $content = substr($content, $conn->{restart});
+ $conn->{restart} = 0;
+ }
+
# What mode are we sending this file in?
unless ($conn->{type} eq 'A') # Binary type.
{
my ($r, $buffer, $n, $w);
- # Restart the connection from previous point?
- if ($conn->{restart}) {
- # VFS seek method only required to support relative forward seeks
- #
- # In Perl = 5.00503, SEEK_CUR is exported by IO::Seekable,
- # in Perl >= 5.6, SEEK_CUR is exported by both IO::Seekable
- # and Fcntl. Hence we 'use IO::Seekable' at the top of the
- # file to get this symbol reliably in both cases.
- sysseek (FILE, $conn->{restart}, SEEK_CUR);
- $conn->{restart} = 0;
- }
# Copy data.
- while ($r = sysread (FILE, $buffer, 65536))
+ while ($buffer = substr($content, 0, 65536))
{
+ $r = length $buffer;
+
# Restart alarm clock timer.
alarm $conn->{idle_timeout};
# Cleanup and exit if there was an error.
unless (defined $w) {
close $sock;
- close FILE;
print {$conn->{socket}} "426 File retrieval error: $!. Data connection has been closed.\r\n";
return;
}
if ($GOT_SIGURG) {
$GOT_SIGURG = 0;
close $sock;
- close FILE;
print {$conn->{socket}} "426 Transfer aborted. Data connection closed.\r\n";
return;
}
# Cleanup and exit if there was an error.
unless (defined $r) {
close $sock;
- close FILE;
print {$conn->{socket}} "426 File retrieval error: $!. Data connection has been closed.\r\n";
return;
}
} else { # ASCII type.
- # Restart the connection from previous point?
- if ($conn->{restart}) {
- for (my $i = 0; $i < $conn->{restart}; ++$i) {
- getc FILE;
- }
- $conn->{restart} = 0;
- }
-
# Copy data.
- while (defined ($_ = <FILE>)) {
+ my @lines = split /\r\n?|\n/, $content;
+ for (@lines) {
# Remove any native line endings.
s/[\n\r]+$//;
if ($GOT_SIGURG) {
$GOT_SIGURG = 0;
close $sock;
- close FILE;
print {$conn->{socket}} "426 Transfer aborted. Data connection closed.\r\n";
return;
}
}
}
- unless (close ($sock) && close (FILE)) {
+ unless (close ($sock)) {
print {$conn->{socket}} "550 File retrieval error: $!.\r\n";
return;
}
{
my ($conn, $cmd, $path) = @_;
- my $dir = $conn->{dir};
-
- # Absolute path?
- if (substr ($path, 0, 1) eq "/") {
- $dir = "/";
- $path =~ s,^/+,,;
- $path = "." if $path eq "";
- }
-
- # Parse the first elements of path until we find the appropriate
- # working directory.
- my @elems = split /\//, $path;
- my $filename = pop @elems;
-
- foreach (@elems) {
- if ($_ eq "" || $_ eq ".") {
- next # Ignore these.
- } elsif ($_ eq "..") {
- # Go to parent directory.
- unless ($dir eq "/") {
- $dir = substr ($dir, 0, rindex ($dir, "/"));
- }
- } else {
- unless (-d $conn->{rootdir} . $dir . $_) {
- print {$conn->{socket}} "550 File or directory not found.\r\n";
- return;
- }
- $dir .= $_;
- }
- }
-
- unless (defined $filename && length $filename) {
+ $path = FTPPaths::path_merge($conn->{dir}, $path);
+ my $info = $conn->{'paths'}->get_info($path);
+ unless ($info) {
print {$conn->{socket}} "550 File or directory not found.\r\n";
return;
}
- if ($filename eq "." || $filename eq "..") {
+ if ($info->{'_type'} eq 'd') {
print {$conn->{socket}} "550 SIZE command is not supported on directories.\r\n";
return;
}
- my $fullname = $conn->{rootdir} . $dir . $filename;
- unless (-f $fullname) {
- print {$conn->{socket}} "550 SIZE command is only supported on plain files.\r\n";
- return;
- }
-
- my $size = 0;
- if ($conn->{type} eq 'A') {
- # ASCII mode: we have to count the characters by hand.
- unless (open (FILE, '<', $filename)) {
- print {$conn->{socket}} "550 Cannot calculate size of $filename.\r\n";
- return;
- }
- $size++ while (defined (getc(FILE)));
- close FILE;
- } else {
- # BINARY mode: we can use stat
- $size = (stat($filename))[7];
- }
+ my $size = length $info->{'content'};
print {$conn->{socket}} "213 $size\r\n";
}
}
-sub __list_file
-{
- my $sock = shift;
- my $filename = shift;
-
- # Get the status information.
- my ($dev, $ino, $mode, $nlink, $uid, $gid, $rdev, $size,
- $atime, $mtime, $ctime, $blksize, $blocks)
- = lstat $filename;
-
- # If the file has been removed since we created this
- # handle, then $dev will be undefined. Return immediately.
- return unless defined $dev;
-
- # Generate printable user/group.
- my $user = getpwuid ($uid) || "-";
- my $group = getgrgid ($gid) || "-";
-
- # Permissions from mode.
- my $perms = $mode & 0777;
-
- # Work out the mode using special "_" operator which causes Perl
- # to use the result of the previous stat call.
- $mode = (-f _ ? 'f' :
- (-d _ ? 'd' :
- (-l _ ? 'l' :
- (-p _ ? 'p' :
- (-S _ ? 's' :
- (-b _ ? 'b' :
- (-c _ ? 'c' : '?')))))));
-
- # Generate printable date (this logic is taken from GNU fileutils:
- # src/ls.c: print_long_format).
- my $time = time;
- my $fmt;
- if ($time > $mtime + 6 * 30 * 24 * 60 * 60 || $time < $mtime - 60 * 60) {
- $fmt = "%b %e %Y";
- } else {
- $fmt = "%b %e %H:%M";
- }
-
- my $fmt_time = strftime $fmt, localtime ($mtime);
-
- # Generate printable permissions.
- my $fmt_perms = join "",
- ($perms & 0400 ? 'r' : '-'),
- ($perms & 0200 ? 'w' : '-'),
- ($perms & 0100 ? 'x' : '-'),
- ($perms & 040 ? 'r' : '-'),
- ($perms & 020 ? 'w' : '-'),
- ($perms & 010 ? 'x' : '-'),
- ($perms & 04 ? 'r' : '-'),
- ($perms & 02 ? 'w' : '-'),
- ($perms & 01 ? 'x' : '-');
-
- # Printable file type.
- my $fmt_mode = $mode eq 'f' ? '-' : $mode;
-
- # If it's a symbolic link, display the link.
- my $link;
- if ($mode eq 'l') {
- $link = readlink $filename;
- die "readlink: $!" unless defined $link;
- }
- my $fmt_link = defined $link ? " -> $link" : "";
-
- # Display the file.
- my $line = sprintf
- ("%s%s%4d %-8s %-8s %8d %s %s%s\r\n",
- $fmt_mode,
- $fmt_perms,
- $nlink,
- $user,
- $group,
- $size,
- $fmt_time,
- $filename,
- $fmt_link);
- $sock->print ($line);
-}
-
-
-sub __get_file_list
-{
- my $dir = shift;
- my $wildcard = shift;
-
- opendir (DIRHANDLE, $dir)
- or die "Cannot open directory!!!";
-
- my @allfiles = readdir DIRHANDLE;
- my @filenames = ();
-
- if ($wildcard) {
- # Get rid of . and ..
- @allfiles = grep !/^\.{1,2}$/, @allfiles;
-
- # Convert wildcard to a regular expression.
- $wildcard = __wildcard_to_regex ($wildcard);
-
- @filenames = grep /$wildcard/, @allfiles;
- } else {
- @filenames = @allfiles;
- }
-
- closedir (DIRHANDLE);
-
- return sort @filenames;
-}
-
-
-sub __wildcard_to_regex
-{
- my $wildcard = shift;
-
- $wildcard =~ s,([^?*a-zA-Z0-9]),\\$1,g; # Escape punctuation.
- $wildcard =~ s,\*,.*,g; # Turn * into .*
- $wildcard =~ s,\?,.,g; # Turn ? into .
- $wildcard = "^$wildcard\$"; # Bracket it.
-
- return $wildcard;
-}
-
-
###########################################################################
# FTPSERVER CLASS
###########################################################################
{
my %_attr_data = ( # DEFAULT
+ _input => undef,
_localAddr => 'localhost',
_localPort => undef,
_reuseAddr => 1,
print STDERR "in child\n" if $log;
my $conn = {
+ 'paths' => FTPPaths->new($self->{'_input'}),
'socket' => $socket,
'state' => $_connection_states{NEWCONN},
'dir' => '/',
return $self->{_server_sock}->sockport;
}
+
+package FTPPaths;
+
+use POSIX qw(strftime);
+
+# not a method
+sub final_component {
+ my $path = shift;
+
+ $path =~ s|.*/||;
+ return $path;
+}
+
+# not a method
+sub path_merge {
+ my ($a, $b) = @_;
+
+ return $a unless $b;
+
+ if ($b =~ m.^/.) {
+ $a = '';
+ $b =~ s.^/..;
+ }
+ $a =~ s./$..;
+
+ my @components = split('/', $b);
+
+ foreach my $c (@components) {
+ if ($c =~ /^\.?$/) {
+ next;
+ } elsif ($c eq '..') {
+ next if $a eq '';
+ $a =~ s|/[^/]*$||;
+ } else {
+ $a .= "/$c";
+ }
+ }
+
+ return $a;
+}
+
+sub new {
+ my ($this, @args) = @_;
+ my $class = ref($this) || $this;
+ my $self = {};
+ bless $self, $class;
+ $self->initialize(@args);
+ return $self;
+}
+
+sub initialize {
+ my ($self, $urls) = @_;
+ my $paths = {_type => 'd'};
+
+ # From a path like '/foo/bar/baz.txt', construct $paths such that
+ # $paths->{'foo'}->{'bar'}->{'baz.txt'} is
+ # $urls->{'/foo/bar/baz.txt'}.
+ for my $path (keys %$urls) {
+ my @components = split('/', $path);
+ shift @components;
+ my $x = $paths;
+ for my $c (@components) {
+ unless (exists $x->{$c}) {
+ $x->{$c} = {_type => 'd'};
+ }
+ $x = $x->{$c};
+ }
+ %$x = %{$urls->{$path}};
+ $x->{_type} = 'f';
+ }
+
+ $self->{'_paths'} = $paths;
+}
+
+sub get_info {
+ my ($self, $path, $node) = @_;
+ $node = $self->{'_paths'} unless $node;
+ my @components = split('/', $path);
+ shift @components if @components && $components[0] eq '';
+
+ for my $c (@components) {
+ if ($node->{'_type'} eq 'd') {
+ $node = $node->{$c};
+ } else {
+ return undef;
+ }
+ }
+ return $node;
+}
+
+sub dir_exists {
+ my ($self, $path) = @_;
+ return $self->exists($path, 'd');
+}
+
+sub exists {
+ # type is optional, in which case we don't check it.
+ my ($self, $path, $type) = @_;
+ my $paths = $self->{'_paths'};
+
+ die "Invalid path $path (not absolute).\n" unless $path =~ m.^/.;
+ my $info = $self->get_info($path);
+ return 0 unless defined($info);
+ return $info->{'_type'} eq $type if defined($type);
+ return 1;
+}
+
+sub _format_for_list {
+ my ($self, $name, $info) = @_;
+
+ # XXX: mode should be specifyable as part of the node info.
+ my $mode_str;
+ if ($info->{'_type'} eq 'd') {
+ $mode_str = 'dr-xr-xr-x';
+ } else {
+ $mode_str = '-r--r--r--';
+ }
+
+ my $size = 0;
+ if ($info->{'_type'} eq 'f') {
+ $size = length $info->{'content'};
+ }
+ my $date = strftime ("%b %e %H:%M", localtime);
+ return "$mode_str 1 0 0 $size $date $name";
+}
+
+sub get_list {
+ my ($self, $path) = @_;
+ my $info = $self->get_info($path);
+ return undef unless defined $info;
+ my $list = [];
+
+ if ($info->{'_type'} eq 'd') {
+ for my $item (keys %$info) {
+ next if $item =~ /^_/;
+ push @$list, $self->_format_for_list($item, $info->{$item});
+ }
+ } else {
+ push @$list, $self->_format_for_list(final_component($path), $info);
+ }
+
+ return $list;
+}
+
1;
# vim: et ts=4 sw=4
-
projects / wget / commitdiff