Adding upstream version 1.21.3.upstream/1.21.3upstream

Signed-off-by: Daniel Baumann <daniel.baumann@progress-linux.org>

1 files changed, 998 insertions, 0 deletions

diff --git a/tests/FTPServer.pm b/tests/FTPServer.pm
new file mode 100644
index 0000000..cac8094
--- /dev/null
+++ b/tests/FTPServer.pm
@@ -0,0 +1,998 @@
+# Part of this code was borrowed from Richard Jones's Net::FTPServer
+# http://www.annexia.org/freeware/netftpserver
+
+package FTPServer;
+
+use strict;
+use warnings;
+
+use Cwd;
+use Socket;
+use IO::Socket::INET;
+use IO::Seekable;
+use POSIX qw(strftime);
+
+my $log        = undef;
+my $GOT_SIGURG = 0;
+
+# CONSTANTS
+
+# connection states
+my %_connection_states = (
+                          '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 = (
+
+    # Standard commands from RFC 959.
+    'CWD' => $_connection_states{LOGGEDIN} | $_connection_states{TWOSOCKS},
+
+    #   'EPRT' => $_connection_states{LOGGEDIN},
+    #   '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},
+    'PWD'  => $_connection_states{LOGGEDIN} | $_connection_states{TWOSOCKS},
+    'QUIT' => $_connection_states{LOGGEDIN} | $_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},
+
+    # From ftpexts Internet Draft.
+    'SIZE' => $_connection_states{LOGGEDIN} | $_connection_states{TWOSOCKS},
+);
+
+# COMMAND-HANDLING ROUTINES
+
+sub _CWD_command
+{
+    my ($conn, $cmd, $path) = @_;
+    my $paths = $conn->{'paths'};
+
+    local $_;
+    my $new_path = FTPPaths::path_merge($conn->{'dir'}, $path);
+
+    # Split the path into its component parts and process each separately.
+    if (!$paths->dir_exists($new_path))
+    {
+        print {$conn->{socket}} "550 Directory not found.\r\n";
+        return;
+    }
+
+    $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;
+    }
+
+    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";
+
+    # Parse the first elements of the path until we find the appropriate
+    # working directory.
+    local $_;
+
+    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 (!$ReturnEmptyList)
+    {
+        for my $item (@$listing)
+        {
+            print $sock "$item\r\n";
+        }
+    }
+
+    unless ($sock->close)
+    {
+        print {$conn->{socket}} "550 Error closing data connection: $!\r\n";
+        return;
+    }
+
+    print {$conn->{socket}}
+      "226 Listing complete. Data connection has been closed.\r\n";
+}
+
+sub _PASS_command
+{
+    my ($conn, $cmd, $pass) = @_;
+
+    # TODO: implement authentication?
+
+    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
+    {
+        print {$conn->{socket}}
+          "230 Authentication not implemented yet, access is always granted.\r\n";
+    }
+}
+
+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',
+                                     LocalPort => '0',
+                                     Listen    => 1,
+                                     Reuse     => 1,
+                                     Proto     => 'tcp',
+                                     Type      => SOCK_STREAM
+                                    );
+
+    unless ($sock)
+    {
+        # Return a code 550 here, even though this is not in the RFC. XXX
+        print {$conn->{socket}} "550 Can't open a listening socket.\r\n";
+        return;
+    }
+
+    $conn->{passive}        = 1;
+    $conn->{passive_socket} = $sock;
+
+    # Get our port number.
+    my $sockport = $sock->sockport;
+
+    # Split the port number into high and low components.
+    my $p1 = int($sockport / 256);
+    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";
+}
+
+sub _PORT_command
+{
+    my ($conn, $cmd, $rest) = @_;
+
+    # The arguments to PORT are a1,a2,a3,a4,p1,p2 where a1 is the
+    # most significant part of the address (eg. 127,0,0,1) and
+    # p1 is the most significant part of the port.
+    unless ($rest =~
+        /^\s*(\d{1,3}),\s*(\d{1,3}),\s*(\d{1,3}),\s*(\d{1,3}),\s*(\d{1,3}),\s*(\d{1,3})/
+      )
+    {
+        print {$conn->{socket}} "501 Syntax error in PORT command.\r\n";
+        return;
+    }
+
+    # Check host address.
+    unless (   $1 > 0
+            && $1 < 224
+            && $2 >= 0
+            && $2 < 256
+            && $3 >= 0
+            && $3 < 256
+            && $4 >= 0
+            && $4 < 256)
+    {
+        print {$conn->{socket}} "501 Invalid host address.\r\n";
+        return;
+    }
+
+    # Construct host address and port number.
+    my $peeraddrstring = "$1.$2.$3.$4";
+    my $peerport       = $5 * 256 + $6;
+
+    # Check port number.
+    unless ($peerport > 0 && $peerport < 65536)
+    {
+        print {$conn->{socket}} "501 Invalid port number.\r\n";
+    }
+
+    $conn->{peeraddrstring} = $peeraddrstring;
+    $conn->{peeraddr}       = inet_aton($peeraddrstring);
+    $conn->{peerport}       = $peerport;
+    $conn->{passive}        = 0;
+
+    $conn->{state} = $_connection_states{TWOSOCKS};
+
+    print {$conn->{socket}} "200 PORT command OK.\r\n";
+}
+
+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 "/";
+    $pathname =~ tr,/,/,s;
+
+    print {$conn->{socket}} "257 \"$pathname\"\r\n";
+}
+
+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;
+    }
+
+    $conn->{restart} = $1;
+
+    print {$conn->{socket}} "350 Restarting next transfer at $1.\r\n";
+}
+
+sub _RETR_command
+{
+    my ($conn, $cmd, $path) = @_;
+
+    $path = FTPPaths::path_merge($conn->{dir}, $path);
+    my $info = $conn->{'paths'}->get_info($path);
+
+    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.\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;
+    }
+
+    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, $sent);
+
+        # Copy data.
+        $sent = 0;
+        while ($sent < length($content))
+        {
+            $buffer = substr($content, $sent, 65536);
+            $r = length $buffer;
+
+            # Restart alarm clock timer.
+            alarm $conn->{idle_timeout};
+
+            for ($n = 0 ; $n < $r ;)
+            {
+                $w = syswrite($sock, $buffer, $r - $n, $n);
+
+                # Cleanup and exit if there was an error.
+                unless (defined $w)
+                {
+                    close $sock;
+                    print {$conn->{socket}}
+                      "426 File retrieval error: $!. Data connection has been closed.\r\n";
+                    return;
+                }
+
+                $n += $w;
+            }
+
+            # Transfer aborted by client?
+            if ($GOT_SIGURG)
+            {
+                $GOT_SIGURG = 0;
+                close $sock;
+                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;
+            print {$conn->{socket}}
+              "426 File retrieval error: $!. Data connection has been closed.\r\n";
+            return;
+        }
+    }
+    else
+    {    # ASCII type.
+            # Copy data.
+        my @lines = split /\r\n?|\n/, $content;
+        for (@lines)
+        {
+            # Remove any native line endings.
+            s/[\n\r]+$//;
+
+            # Restart alarm clock timer.
+            alarm $conn->{idle_timeout};
+
+            # Write the line with telnet-format line endings.
+            print $sock "$_\r\n";
+
+            # Transfer aborted by client?
+            if ($GOT_SIGURG)
+            {
+                $GOT_SIGURG = 0;
+                close $sock;
+                print {$conn->{socket}}
+                  "426 Transfer aborted. Data connection closed.\r\n";
+                return;
+            }
+        }
+    }
+
+    unless (close($sock))
+    {
+        print {$conn->{socket}} "550 File retrieval error: $!.\r\n";
+        return;
+    }
+
+    print {$conn->{socket}}
+      "226 File retrieval complete. Data connection has been closed.\r\n";
+}
+
+sub _SIZE_command
+{
+    my ($conn, $cmd, $path) = @_;
+
+    $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 ($info->{'_type'} eq 'd')
+    {
+        print {$conn->{socket}}
+          "550 SIZE command is not supported on directories.\r\n";
+        return;
+    }
+
+    my $size = length $info->{'content'};
+
+    print {$conn->{socket}} "213 $size\r\n";
+}
+
+sub _SYST_command
+{
+    my ($conn, $cmd, $dummy) = @_;
+
+    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} = $1;
+    }
+    elsif ($type =~ /^([AI])\sN$/i)
+    {
+        $conn->{type} = $1;
+    }
+    elsif ($type =~ /^L\s8$/i)
+    {
+        $conn->{type} = 'L8';
+    }
+    else
+    {
+        print {$conn->{socket}}
+          "504 This server does not support TYPE $type.\r\n";
+        return;
+    }
+
+    print {$conn->{socket}} "200 TYPE changed to $type.\r\n";
+}
+
+sub _USER_command
+{
+    my ($conn, $cmd, $username) = @_;
+
+    print STDERR "username: $username\n" if $log;
+    $conn->{username} = $username;
+
+    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
+    {
+        print {$conn->{socket}} "331 Password required.\r\n";
+    }
+}
+
+# HELPER ROUTINES
+
+sub __open_data_connection
+{
+    my $conn = shift;
+
+    my $sock;
+
+    if ($conn->{passive})
+    {
+        # Passive mode - wait for a connection from the client.
+        accept($sock, $conn->{passive_socket}) or return undef;
+    }
+    else
+    {
+        # Active mode - connect back to the client.
+        "0" =~ /(0)/;    # Perl 5.7 / IO::Socket::INET bug workaround.
+        $sock = IO::Socket::INET->new(
+                                      LocalAddr => '127.0.0.1',
+                                      PeerAddr  => $conn->{peeraddrstring},
+                                      PeerPort  => $conn->{peerport},
+                                      Proto     => 'tcp',
+                                      Type      => SOCK_STREAM
+                                     )
+          or return undef;
+    }
+
+    return $sock;
+}
+
+###########################################################################
+# FTPSERVER CLASS
+###########################################################################
+
+{
+    my %_attr_data = (    # DEFAULT
+                       _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
+    {
+        keys %_attr_data;
+    }
+}
+
+sub new
+{
+    my ($caller, %args) = @_;
+    my $caller_is_obj = ref($caller);
+    my $class         = $caller_is_obj || $caller;
+    my $self          = bless {}, $class;
+    foreach my $attrname ($self->_standard_keys())
+    {
+        my ($argname) = ($attrname =~ /^_(.*)/);
+        if (exists $args{$argname})
+        {
+            $self->{$attrname} = $args{$argname};
+        }
+        elsif ($caller_is_obj)
+        {
+            $self->{$attrname} = $caller->{$attrname};
+        }
+        else
+        {
+            $self->{$attrname} = $self->_default_for($attrname);
+        }
+    }
+
+    # create server socket
+    "0" =~ /(0)/;    # Perl 5.7 / IO::Socket::INET bug workaround.
+    $self->{_server_sock} =
+      IO::Socket::INET->new(
+                            LocalHost => $self->{_localAddr},
+                            LocalPort => $self->{_localPort},
+                            Listen    => 1,
+                            Reuse     => $self->{_reuseAddr},
+                            Proto     => 'tcp',
+                            Type      => SOCK_STREAM
+                           )
+      or die "bind: $!";
+
+    foreach my $file (keys %{$self->{_input}})
+    {
+        my $ref = \$self->{_input}{$file}{content};
+        $$ref =~ s/\Q{{port}}/$self->sockport/eg;
+    }
+
+    return $self;
+}
+
+sub run
+{
+    my ($self, $synch_callback) = @_;
+    my $initialized = 0;
+
+    # turn buffering off on STDERR
+    select((select(STDERR), $| = 1)[0]);
+
+    # initialize command table
+    my $command_table = {};
+    foreach (keys %_commands)
+    {
+        my $subname = "_${_}_command";
+        $command_table->{$_} = \&$subname;
+    }
+
+    my $old_ils = $/;
+    $/ = "\r\n";
+
+    if (!$initialized)
+    {
+        $synch_callback->();
+        $initialized = 1;
+    }
+
+    $SIG{CHLD} = sub { wait };
+    my $server_sock = $self->{_server_sock};
+
+    # 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
+        my ($client_port, $client_ip) = sockaddr_in($client_addr);
+        my $client_ipnum = inet_ntoa($client_ip);
+
+        # print who connected
+        print STDERR "got a connection from: $client_ipnum\n" if $log;
+
+        # fork off a process to handle this connection.
+        # my $pid = fork();
+        # unless (defined $pid) {
+        #     warn "fork: $!";
+        #     sleep 5; # Back off in case system is overloaded.
+        #     next;
+        # }
+
+        if (1)
+        {    # Child process.
+
+            # install signals
+            $SIG{URG} = sub {
+                $GOT_SIGURG = 1;
+            };
+
+            $SIG{PIPE} = sub {
+                print STDERR "Client closed connection abruptly.\n";
+                exit;
+            };
+
+            $SIG{ALRM} = sub {
+                print STDERR
+                  "Connection idle timeout expired. Closing server.\n";
+                exit;
+            };
+
+            #$SIG{CHLD} = 'IGNORE';
+
+            print STDERR "in child\n" if $log;
+
+            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
+            for (; ;)
+            {
+                print STDERR "waiting for request\n" if $log;
+
+                last unless defined(my $req = <$socket>);
+
+                # Remove trailing CRLF.
+                $req =~ s/[\n\r]+$//;
+
+                print STDERR "received request $req\n" if $log;
+
+                # Get the command.
+                # See also RFC 2640 section 3.1.
+                unless ($req =~ m/^([A-Z]{3,4})\s?(.*)/i)
+                {
+                    # badly formed command
+                    exit 0;
+                }
+
+                # The following strange 'eval' is necessary to work around a
+                # very odd bug in Perl 5.6.0. The following assignment to
+                # $cmd will fail in some cases unless you use $1 in some sort
+                # of an expression beforehand.
+                # - RWMJ 2002-07-05.
+                eval '$1 eq $1';
+
+                my ($cmd, $rest) = (uc $1, $2);
+
+                # Got a command which matches in the table?
+                unless (exists $command_table->{$cmd})
+                {
+                    print {$conn->{socket}} "500 Unrecognized command.\r\n";
+                    next;
+                }
+
+                # Command requires user to be authenticated?
+                unless ($_commands{$cmd} | $conn->{state})
+                {
+                    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;
+                }
+
+                if (defined($self->{_server_behavior}{pasv_not_supported})
+                    && $cmd eq 'PASV')
+                {
+                    print {$conn->{socket}}
+                      "500 PASV not supported.\r\n";
+                    next;
+                }
+
+                # Run the command.
+                &{$command_table->{$cmd}}($conn, $cmd, $rest);
+            }
+        }
+        else
+        {    # Father
+            close $socket;
+        }
+    }
+
+    $/ = $old_ils;
+}
+
+sub sockport
+{
+    my $self = shift;
+    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 ($path_a, $path_b) = @_;
+
+    if (!$path_b)
+    {
+        return $path_a;
+    }
+
+    if ($path_b =~ m.^/.)
+    {
+        $path_a = '';
+        $path_b =~ s.^/..;
+    }
+    $path_a =~ s./$..;
+
+    my @components = split m{/}msx, $path_b;
+
+    foreach my $c (@components)
+    {
+        if ($c =~ /^\.?$/)
+        {
+            next;
+        }
+        elsif ($c eq '..')
+        {
+            if (!$path_a)
+            {
+                next;
+            }
+            $path_a =~ s|/[^/]*$||;
+        }
+        else
+        {
+            $path_a .= "/$c";
+        }
+    }
+
+    return $path_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 m{/}msx, $path;
+        shift @components;
+        my $x = $paths;
+        for my $c (@components)
+        {
+            if (!exists $x->{$c})
+            {
+                $x->{$c} = {_type => 'd'};
+            }
+            $x = $x->{$c};
+        }
+        %$x = %{$urls->{$path}};
+        $x->{_type} = 'f';
+    }
+
+    $self->{'_paths'}    = $paths;
+    $self->{'_behavior'} = $behavior;
+    return 1;
+}
+
+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;
+        }
+    }
+    return $node;
+}
+
+sub dir_exists
+{
+    my ($self, $path) = @_;
+    return $self->path_exists($path, 'd');
+}
+
+sub path_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 %d %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);
+    if (!defined $info)
+    {
+        return;
+    }
+    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