X-Git-Url: http://sjero.net/git/?p=wget;a=blobdiff_plain;f=tests%2FFTPServer.pm;h=1603caaa251022b53460705d7e37a4de87094311;hp=94f3b9a750fae93203610f73062d0057fe034ac6;hb=320cfdcb658e8d6556ae9dfd902c2db1db866a6b;hpb=124f1050af0476082167582bed258b20b95df7db diff --git a/tests/FTPServer.pm b/tests/FTPServer.pm index 94f3b9a7..1603caaa 100644 --- a/tests/FTPServer.pm +++ b/tests/FTPServer.pm @@ -19,36 +19,36 @@ my $GOT_SIGURG = 0; # connection states my %_connection_states = ( - 'NEWCONN' => 0x01, - 'WAIT4PWD' => 0x02, + 'NEWCONN' => 0x01, + 'WAIT4PWD' => 0x02, 'LOGGEDIN' => 0x04, 'TWOSOCKS' => 0x08, ); # subset of FTP commands supported by these server and the respective # connection states in which they are allowed -my %_commands = ( +my %_commands = ( # Standard commands from RFC 959. 'CWD' => $_connection_states{LOGGEDIN} | - $_connection_states{TWOSOCKS}, + $_connection_states{TWOSOCKS}, # 'EPRT' => $_connection_states{LOGGEDIN}, -# 'EPSV' => $_connection_states{LOGGEDIN}, - 'LIST' => $_connection_states{TWOSOCKS}, +# 'EPSV' => $_connection_states{LOGGEDIN}, + 'LIST' => $_connection_states{TWOSOCKS}, # 'LPRT' => $_connection_states{LOGGEDIN}, -# 'LPSV' => $_connection_states{LOGGEDIN}, - 'PASS' => $_connection_states{WAIT4PWD}, - 'PASV' => $_connection_states{LOGGEDIN}, - 'PORT' => $_connection_states{LOGGEDIN}, +# 'LPSV' => $_connection_states{LOGGEDIN}, + 'PASS' => $_connection_states{WAIT4PWD}, + 'PASV' => $_connection_states{LOGGEDIN}, + 'PORT' => $_connection_states{LOGGEDIN}, 'PWD' => $_connection_states{LOGGEDIN} | - $_connection_states{TWOSOCKS}, + $_connection_states{TWOSOCKS}, 'QUIT' => $_connection_states{LOGGEDIN} | - $_connection_states{TWOSOCKS}, - 'REST' => $_connection_states{TWOSOCKS}, - 'RETR' => $_connection_states{TWOSOCKS}, + $_connection_states{TWOSOCKS}, + 'REST' => $_connection_states{TWOSOCKS}, + 'RETR' => $_connection_states{TWOSOCKS}, 'SYST' => $_connection_states{LOGGEDIN}, 'TYPE' => $_connection_states{LOGGEDIN} | $_connection_states{TWOSOCKS}, - 'USER' => $_connection_states{NEWCONN}, + 'USER' => $_connection_states{NEWCONN}, # From ftpexts Internet Draft. 'SIZE' => $_connection_states{LOGGEDIN} | $_connection_states{TWOSOCKS}, @@ -61,136 +61,83 @@ 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'}; + + my $ReturnEmptyList = ( $paths->GetBehavior('list_empty_if_list_a') && + $path eq '-a'); + my $SkipHiddenFiles = ( $paths->GetBehavior('list_no_hidden_if_list') && + ( ! $path ) ); + + if ($paths->GetBehavior('list_fails_if_list_a') && $path eq '-a') + { + print {$conn->{socket}} "500 Unknown command\r\n"; + return; + } - # 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}; + if (!$paths->GetBehavior('list_dont_clean_path')) + { + # 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'}; 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; - } - } + my $listing; + if (!$ReturnEmptyList) + { + $dir = FTPPaths::path_merge($dir, $path); + $listing = $paths->get_list($dir,$SkipHiddenFiles); + unless ($listing) { + print {$conn->{socket}} "550 File or directory not found.\r\n"; + return; } - } - + } + print STDERR "_LIST_command - dir is: $dir\n" if $log; - + print {$conn->{socket}} "150 Opening data connection for file listing.\r\n"; # 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"; + if (!$ReturnEmptyList) + { + for my $item (@$listing) { + print $sock "$item\r\n"; } + } - foreach (__get_file_list ($conn->{rootdir} . $dir, $wildcard)) { - __list_file ($sock, $prefix . $_); - } - } - unless ($sock->close) { print {$conn->{socket}} "550 Error closing data connection: $!\r\n"; return; @@ -207,7 +154,7 @@ sub _PASS_command print STDERR "switching to LOGGEDIN state\n" if $log; $conn->{state} = $_connection_states{LOGGEDIN}; - + if ($conn->{username} eq "anonymous") { print {$conn->{socket}} "202 Anonymous user access is always granted.\r\n"; } else { @@ -218,7 +165,7 @@ sub _PASS_command sub _PASV_command { my ($conn, $cmd, $rest) = @_; - + # Open a listening socket - but don't actually accept on it yet. "0" =~ /(0)/; # Perl 5.7 / IO::Socket::INET bug workaround. my $sock = IO::Socket::INET->new (LocalHost => '127.0.0.1', @@ -245,7 +192,7 @@ sub _PASV_command my $p2 = $sockport % 256; $conn->{state} = $_connection_states{TWOSOCKS}; - + # We only accept connections from localhost. print {$conn->{socket}} "227 Entering Passive Mode (127,0,0,1,$p1,$p2)\r\n"; } @@ -293,7 +240,7 @@ sub _PORT_command sub _PWD_command { my ($conn, $cmd, $rest) = @_; - + # See RFC 959 Appendix II and draft-ietf-ftpext-mlst-11.txt section 6.2.1. my $pathname = $conn->{dir}; $pathname =~ s,/+$,, unless $pathname eq "/"; @@ -305,7 +252,7 @@ sub _PWD_command sub _REST_command { my ($conn, $cmd, $restart_from) = @_; - + unless ($restart_from =~ /^([1-9][0-9]*|0)$/) { print {$conn->{socket}} "501 REST command needs a numeric argument.\r\n"; return; @@ -319,63 +266,18 @@ sub _REST_command 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 .= $_; - } - } - 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; - } + $path = FTPPaths::path_merge($conn->{dir}, $path); + my $info = $conn->{'paths'}->get_info($path); - # 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 +287,26 @@ 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; - } + my ($r, $buffer, $n, $w, $sent); # Copy data. - while ($r = sysread (FILE, $buffer, 65536)) + $sent = 0; + while ($sent < length($content)) { + $buffer = substr($content, $sent, 65536); + $r = length $buffer; + # Restart alarm clock timer. alarm $conn->{idle_timeout}; @@ -415,7 +317,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,30 +328,22 @@ 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; } + $sent += $r; } # 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 +357,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; } @@ -482,67 +374,20 @@ sub _RETR_command 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; + 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"; } @@ -550,19 +395,26 @@ sub _SIZE_command sub _SYST_command { my ($conn, $cmd, $dummy) = @_; - - print {$conn->{socket}} "215 UNIX Type: L8\r\n"; + + if ($conn->{'paths'}->GetBehavior('syst_response')) + { + print {$conn->{socket}} $conn->{'paths'}->GetBehavior('syst_response') . "\r\n"; + } + else + { + print {$conn->{socket}} "215 UNIX Type: L8\r\n"; + } } sub _TYPE_command { my ($conn, $cmd, $type) = @_; - + # See RFC 959 section 5.3.2. if ($type =~ /^([AI])$/i) { - $conn->{type} = 'A'; + $conn->{type} = $1; } elsif ($type =~ /^([AI])\sN$/i) { - $conn->{type} = 'A'; + $conn->{type} = $1; } elsif ($type =~ /^L\s8$/i) { $conn->{type} = 'L8'; } else { @@ -582,7 +434,7 @@ sub _USER_command print STDERR "switching to WAIT4PWD state\n" if $log; $conn->{state} = $_connection_states{WAIT4PWD}; - + if ($conn->{username} eq "anonymous") { print {$conn->{socket}} "230 Anonymous user access granted.\r\n"; } else { @@ -616,149 +468,27 @@ 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 - _localAddr => 'localhost', - _localPort => undef, - _reuseAddr => 1, - _rootDir => Cwd::getcwd(), + _input => undef, + _localAddr => 'localhost', + _localPort => undef, + _reuseAddr => 1, + _rootDir => Cwd::getcwd(), + _server_behavior => {}, ); - + sub _default_for { my ($self, $attr) = @_; $_attr_data{$attr}; } - sub _standard_keys + sub _standard_keys { keys %_attr_data; } @@ -790,11 +520,17 @@ sub new { Proto => 'tcp', Type => SOCK_STREAM) or die "bind: $!"; + + foreach my $file (keys %{$self->{_input}}) { + my $ref = \$self->{_input}{$file}{content}; + $$ref =~ s/{{port}}/$self->sockport/eg; + } + return $self; } -sub run +sub run { my ($self, $synch_callback) = @_; my $initialized = 0; @@ -822,11 +558,11 @@ sub run # the accept loop while (my $client_addr = accept (my $socket, $server_sock)) - { + { # turn buffering off on $socket select((select($socket), $|=1)[0]); - - # find out who connected + + # find out who connected my ($client_port, $client_ip) = sockaddr_in ($client_addr); my $client_ipnum = inet_ntoa ($client_ip); @@ -844,8 +580,8 @@ sub run if (1) { # Child process. # install signals - $SIG{URG} = sub { - $GOT_SIGURG = 1; + $SIG{URG} = sub { + $GOT_SIGURG = 1; }; $SIG{PIPE} = sub { @@ -857,21 +593,23 @@ sub run print STDERR "Connection idle timeout expired. Closing server.\n"; exit; }; - + #$SIG{CHLD} = 'IGNORE'; print STDERR "in child\n" if $log; - my $conn = { - 'socket' => $socket, - 'state' => $_connection_states{NEWCONN}, - 'dir' => '/', - 'restart' => 0, - 'idle_timeout' => 60, # 1 minute timeout - 'rootdir' => $self->{_rootDir}, + my $conn = { + 'paths' => FTPPaths->new($self->{'_input'}, + $self->{'_server_behavior'}), + 'socket' => $socket, + 'state' => $_connection_states{NEWCONN}, + 'dir' => '/', + 'restart' => 0, + 'idle_timeout' => 60, # 1 minute timeout + 'rootdir' => $self->{_rootDir}, }; - + print {$conn->{socket}} "220 GNU Wget Testing FTP Server ready.\r\n"; # command handling loop @@ -912,20 +650,27 @@ sub run print {$conn->{socket}} "530 Not logged in.\r\n"; next; } - + # Handle the QUIT command specially. if ($cmd eq "QUIT") { print {$conn->{socket}} "221 Goodbye. Service closing connection.\r\n"; last; } + if (defined ($self->{_server_behavior}{fail_on_pasv}) + && $cmd eq 'PASV') { + undef $self->{_server_behavior}{fail_on_pasv}; + close $socket; + last; + } + # Run the command. &{$command_table->{$cmd}} ($conn, $cmd, $rest); } } else { # Father close $socket; } - } + } $/ = $old_ils; } @@ -935,7 +680,189 @@ 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, $behavior) = @_; + 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; + $self->{'_behavior'} = $behavior; +} + +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'}; + if ($self->{'_behavior'}{'bad_list'}) { + $size = 0; + } + } + my $date = strftime ("%b %e %H:%M", localtime); + return "$mode_str 1 0 0 $size $date $name"; +} + +sub get_list { + my ($self, $path, $no_hidden) = @_; + 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 =~ /^_/; + # 2013-10-17 Andrea Urbani (matfanjol) + # I skip the hidden files if requested + if (($no_hidden) && + (defined($info->{$item}->{'attr'})) && + (index($info->{$item}->{'attr'}, "H")>=0)) + { + # This is an hidden file and I don't want to see it! + print STDERR "get_list: Skipped hidden file [$item]\n"; + } + else + { + push @$list, $self->_format_for_list($item, $info->{$item}); + } + } + } else { + push @$list, $self->_format_for_list(final_component($path), $info); + } + + return $list; +} + +# 2013-10-17 Andrea Urbani (matfanjol) +# It returns the behavior of the given name. +# In this file I handle also the following behaviors: +# list_dont_clean_path : if defined, the command +# $path =~ s/^-[a-zA-Z0-9]+\s?//; +# is not runt and the given path +# remains the original one +# list_empty_if_list_a : if defined, "LIST -a" returns an +# empty content +# list_fails_if_list_a : if defined, "LIST -a" returns an +# error +# list_no_hidden_if_list: if defined, "LIST" doesn't return +# hidden files. +# To define an hidden file add +# attr => "H" +# to the url files +# syst_response : if defined, its content is printed +# out as SYST response +sub GetBehavior { + my ($self, $name) = @_; + return $self->{'_behavior'}{$name}; +} + 1; # vim: et ts=4 sw=4 -