moparisthebest/wget
1
0
Fork 0
mirror of https://github.com/moparisthebest/wget synced 2024-07-03 16:38:41 -04:00
Code Issues Releases Wiki Activity

Rewrote FTPServer.pm to avoid filesystem; added Test-ftp-recursive.px.

Browse Source
This commit is contained in:
Micah Cowan 2009-09-05 23:08:55 -07:00
parent 1fe5ddb7fe
commit ad4b678d2d
6 changed files with 258 additions and 357 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
tests/ChangeLog
View File

@ -1,3 +1,15 @@
2009-09-05 Micah Cowan <micah@cowan.name>
* 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 <micah@cowan.name>
* WgetTest.pm.in (run): Error-checking improvements.

530
tests/FTPServer.pm
View File

@ -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};
$path = FTPPaths::path_merge($conn->{dir}, $path);
my $info = $conn->{'paths'}->get_info($path);
# 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) {
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 ($_ = <FILE>)) {
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

16
tests/FTPTest.pm
View File

@ -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);
}

1
tests/Makefile.am
View File

@ -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 \

55
tests/Test-ftp-recursive.px Executable file
View File

@ -0,0 +1,55 @@
#!/usr/bin/perl
use strict;
use warnings;
use FTPTest;
###############################################################################
my $afile = <<EOF;
Some text.
EOF
my $bfile = <<EOF;
Some more text.
EOF
$afile =~ s/\n/\r\n/;
$bfile =~ s/\n/\r\n/;
# code, msg, headers, content
my %urls = (
'/foo/afile.txt' => {
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

1
tests/run-px
View File

@ -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',