From ad4b678d2d8aac8644810319cb439994c1470a18 Mon Sep 17 00:00:00 2001 From: Micah Cowan Date: Sat, 5 Sep 2009 23:08:55 -0700 Subject: [PATCH] Rewrote FTPServer.pm to avoid filesystem; added Test-ftp-recursive.px. --- tests/ChangeLog | 12 + tests/FTPServer.pm | 530 +++++++++++++----------------------- tests/FTPTest.pm | 16 +- tests/Makefile.am | 1 + tests/Test-ftp-recursive.px | 55 ++++ tests/run-px | 1 + 6 files changed, 258 insertions(+), 357 deletions(-) create mode 100755 tests/Test-ftp-recursive.px diff --git a/tests/ChangeLog b/tests/ChangeLog index 9b3cbe07..90907f4a 100644 --- a/tests/ChangeLog +++ b/tests/ChangeLog @@ -1,3 +1,15 @@ +2009-09-05 Micah Cowan + + * Test-ftp-recursive.px: Added. + * run-px, Makefile.am (EXTRA_DIST): Added Test-ftp-recursive.px. + + * FTPTest.pm (_setup_server): Don't construct the "input" + directory's contents, just pass the URLs structure to + FTPServer->new. + * FTPServer.pm: Rewrote portions, so that the server now uses the + information from the %urls hash directly, rather than reading from + real files. Added an FTPPaths package to the file. + 2009-09-04 Micah Cowan * WgetTest.pm.in (run): Error-checking improvements. diff --git a/tests/FTPServer.pm b/tests/FTPServer.pm index edeb69dd..f3c42d17 100644 --- a/tests/FTPServer.pm +++ b/tests/FTPServer.pm @@ -61,101 +61,44 @@ my %_commands = ( 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; @@ -164,31 +107,13 @@ sub _LIST_command # 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) { @@ -320,62 +245,17 @@ sub _RETR_command { 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); @@ -385,26 +265,25 @@ sub _RETR_command 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}; @@ -415,7 +294,6 @@ sub _RETR_command # 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; } @@ -427,7 +305,6 @@ sub _RETR_command if ($GOT_SIGURG) { $GOT_SIGURG = 0; close $sock; - close FILE; print {$conn->{socket}} "426 Transfer aborted. Data connection closed.\r\n"; return; } @@ -436,21 +313,13 @@ sub _RETR_command # 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 ($_ = )) { + my @lines = split /\r\n?|\n/, $content; + for (@lines) { # Remove any native line endings. s/[\n\r]+$//; @@ -464,14 +333,13 @@ sub _RETR_command 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; } @@ -483,66 +351,19 @@ sub _SIZE_command { 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"; } @@ -616,136 +437,13 @@ sub __open_data_connection } -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, @@ -864,6 +562,7 @@ sub run print STDERR "in child\n" if $log; my $conn = { + 'paths' => FTPPaths->new($self->{'_input'}), 'socket' => $socket, 'state' => $_connection_states{NEWCONN}, 'dir' => '/', @@ -935,7 +634,150 @@ sub sockport { 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 - diff --git a/tests/FTPTest.pm b/tests/FTPTest.pm index 81b8b008..85fc1dd3 100644 --- a/tests/FTPTest.pm +++ b/tests/FTPTest.pm @@ -32,19 +32,8 @@ my $VERSION = 0.01; sub _setup_server { my $self = shift; - foreach my $url (keys %{$self->{_input}}) { - my $filename = $url; - $filename =~ s/^\///; - open (FILE, ">$filename") - or return "Test failed: cannot open input file $filename\n"; - - print FILE $self->{_input}->{$url}->{content} - or return "Test failed: cannot write input file $filename\n"; - - close (FILE); - } - - $self->{_server} = FTPServer->new (LocalAddr => 'localhost', + $self->{_server} = FTPServer->new (input => $self->{_input}, + LocalAddr => 'localhost', ReuseAddr => 1, rootDir => "$self->{_workdir}/$self->{_name}/input") or die "Cannot create server!!!"; } @@ -53,6 +42,7 @@ sub _setup_server { sub _launch_server { my $self = shift; my $synch_func = shift; + $self->{_server}->run ($synch_func); } diff --git a/tests/Makefile.am b/tests/Makefile.am index e4d0e96b..4fb90b39 100644 --- a/tests/Makefile.am +++ b/tests/Makefile.am @@ -72,6 +72,7 @@ EXTRA_DIST = FTPServer.pm FTPTest.pm HTTPServer.pm HTTPTest.pm \ Test-E-k-K.px \ Test-E-k.px \ Test-ftp.px \ + Test-ftp-recursive.px \ Test-ftp-iri.px \ Test-ftp-iri-fallback.px \ Test-ftp-iri-recursive.px \ diff --git a/tests/Test-ftp-recursive.px b/tests/Test-ftp-recursive.px new file mode 100755 index 00000000..5a86a166 --- /dev/null +++ b/tests/Test-ftp-recursive.px @@ -0,0 +1,55 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use FTPTest; + + +############################################################################### + +my $afile = < { + content => $afile, + }, + '/bar/baz/bfile.txt' => { + content => $bfile, + }, +); + +my $cmdline = $WgetTest::WGETPATH . " -S -nH -r ftp://localhost:{{port}}/"; + +my $expected_error_code = 0; + +my %expected_downloaded_files = ( + 'foo/afile.txt' => { + content => $afile, + }, + 'bar/baz/bfile.txt' => { + content => $bfile, + }, +); + +############################################################################### + +my $the_test = FTPTest->new (name => "Test-ftp-recursive", + input => \%urls, + cmdline => $cmdline, + errcode => $expected_error_code, + output => \%expected_downloaded_files); +exit $the_test->run(); + +# vim: et ts=4 sw=4 + diff --git a/tests/run-px b/tests/run-px index 5dade1bd..5c04b8cc 100755 --- a/tests/run-px +++ b/tests/run-px @@ -27,6 +27,7 @@ my @tests = ( 'Test-E-k-K.px', 'Test-E-k.px', 'Test-ftp.px', + 'Test-ftp-recursive.px', 'Test-ftp-iri.px', 'Test-ftp-iri-fallback.px', 'Test-ftp-iri-recursive.px', -- 2.39.2