File Coverage

blib/lib/Net/SFTP/SftpServer.pm

Criterion	Covered	Total	%
statement	343	1326	25.8
branch	7	392	1.7
condition	2	181	1.1
subroutine	110	232	47.4
pod	0	47	0.0
total	462	2178	21.2

#/*
# * Based on sftp-server.c
# * Copyright (c) 2000-2004 Markus Friedl.  All rights reserved.
# *
# * Ported to Perl and extended by Simon Day
# * Copyright (c) 2009 Pirum Systems Ltd.  All rights reserved.
# *
# * Permission to use, copy, modify, and distribute this software for any
# * purpose with or without fee is hereby granted, provided that the above
# * copyright notice and this permission notice appear in all copies.
# *
# * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
# * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
# * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
# * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
# * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
# * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
# * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
# */
#
package Net::SFTP::SftpServer;
require Exporter;
@ISA = qw(Exporter);

@EXPORT_OK = qw(
    ALL
    NET_SFTP_SYMLINKS
    NET_SFTP_RENAME_DIR
    SSH2_FXP_INIT
    SSH2_FXP_OPEN
    SSH2_FXP_CLOSE
    SSH2_FXP_READ
    SSH2_FXP_WRITE
    SSH2_FXP_LSTAT
    SSH2_FXP_STAT_VERSION_0
    SSH2_FXP_FSTAT
    SSH2_FXP_SETSTAT
    SSH2_FXP_FSETSTAT
    SSH2_FXP_OPENDIR
    SSH2_FXP_READDIR
    SSH2_FXP_REMOVE
    SSH2_FXP_MKDIR
    SSH2_FXP_RMDIR
    SSH2_FXP_REALPATH
    SSH2_FXP_STAT
    SSH2_FXP_RENAME
    SSH2_FXP_READLINK
    SSH2_FXP_SYMLINK
    logError
    logWarning
    logGeneral
    logDetail
);


%EXPORT_TAGS = (  ACTIONS => [ qw(
                              ALL
                              NET_SFTP_SYMLINKS
                              NET_SFTP_RENAME_DIR
                              SSH2_FXP_OPEN
                              SSH2_FXP_CLOSE
                              SSH2_FXP_READ
                              SSH2_FXP_WRITE
                              SSH2_FXP_LSTAT
                              SSH2_FXP_STAT_VERSION_0
                              SSH2_FXP_FSTAT
                              SSH2_FXP_SETSTAT
                              SSH2_FXP_FSETSTAT
                              SSH2_FXP_OPENDIR
                              SSH2_FXP_READDIR
                              SSH2_FXP_REMOVE
                              SSH2_FXP_MKDIR
                              SSH2_FXP_RMDIR
                              SSH2_FXP_STAT
                              SSH2_FXP_RENAME
                              SSH2_FXP_READLINK
                              SSH2_FXP_SYMLINK
                            ) ],
                  LOG  => [qw(
                              logError
                              logWarning
                              logGeneral
                              logDetail
                           )]);

use strict;
use warnings;

use version; our $VERSION = qv('1.1.0');

use Stat::lsMode;
use Fcntl qw( O_RDWR O_CREAT O_TRUNC O_EXCL O_RDONLY O_WRONLY SEEK_SET );
use POSIX qw(strftime);
use Sys::Syslog;

$SIG{__DIE__} = sub {  ## still dies upon return
		syslog 'warning', join(" : ", @_);
};

use Errno qw(:POSIX);

use constant TIMEOUT                        => 300;
use constant MAX_PACKET_SIZE                => 1024 * 1024;
use constant MAX_OPEN_HANDLES               => 512;

#/* version */
use constant SSH2_FILEXFER_VERSION          => 3;

#/* client to server */
use constant SSH2_FXP_INIT                  => 1;
use constant SSH2_FXP_OPEN                  => 3;
use constant SSH2_FXP_CLOSE                 => 4;
use constant SSH2_FXP_READ                  => 5;
use constant SSH2_FXP_WRITE                 => 6;
use constant SSH2_FXP_LSTAT                 => 7;
use constant SSH2_FXP_STAT_VERSION_0        => 7;
use constant SSH2_FXP_FSTAT                 => 8;
use constant SSH2_FXP_SETSTAT               => 9;
use constant SSH2_FXP_FSETSTAT              => 10;
use constant SSH2_FXP_OPENDIR               => 11;
use constant SSH2_FXP_READDIR               => 12;
use constant SSH2_FXP_REMOVE                => 13;
use constant SSH2_FXP_MKDIR                 => 14;
use constant SSH2_FXP_RMDIR                 => 15;
use constant SSH2_FXP_REALPATH              => 16;
use constant SSH2_FXP_STAT                  => 17;
use constant SSH2_FXP_RENAME                => 18;
use constant SSH2_FXP_READLINK              => 19;
use constant SSH2_FXP_SYMLINK               => 20;

# SFTP allow/deny actions

use constant ALL                            => 1000;
use constant NET_SFTP_RENAME_DIR            => 1001;
use constant NET_SFTP_SYMLINKS              => 1002;

#/* server to client */
use constant SSH2_FXP_VERSION               => 2;
use constant SSH2_FXP_STATUS                => 101;
use constant SSH2_FXP_HANDLE                => 102;
use constant SSH2_FXP_DATA                  => 103;
use constant SSH2_FXP_NAME                  => 104;
use constant SSH2_FXP_ATTRS                 => 105;

use constant SSH2_FXP_EXTENDED              => 200;
use constant SSH2_FXP_EXTENDED_REPLY        => 201;

#/* attributes */
use constant SSH2_FILEXFER_ATTR_SIZE        => 0x00000001;
use constant SSH2_FILEXFER_ATTR_UIDGID      => 0x00000002;
use constant SSH2_FILEXFER_ATTR_PERMISSIONS => 0x00000004;
use constant SSH2_FILEXFER_ATTR_ACMODTIME   => 0x00000008;
use constant SSH2_FILEXFER_ATTR_EXTENDED    => 0x80000000;

#/* portable open modes */
use constant SSH2_FXF_READ                  => 0x00000001;
use constant SSH2_FXF_WRITE                 => 0x00000002;
use constant SSH2_FXF_APPEND                => 0x00000004;
use constant SSH2_FXF_CREAT                 => 0x00000008;
use constant SSH2_FXF_TRUNC                 => 0x00000010;
use constant SSH2_FXF_EXCL                  => 0x00000020;

#/* status messages */
use constant SSH2_FX_OK                     => 0;
use constant SSH2_FX_EOF                    => 1;
use constant SSH2_FX_NO_SUCH_FILE           => 2;
use constant SSH2_FX_PERMISSION_DENIED      => 3;
use constant SSH2_FX_FAILURE                => 4;
use constant SSH2_FX_BAD_MESSAGE            => 5;
use constant SSH2_FX_NO_CONNECTION          => 6;
use constant SSH2_FX_CONNECTION_LOST        => 7;
use constant SSH2_FX_OP_UNSUPPORTED         => 8;
use constant SSH2_FX_MAX                    => 8;#8 is the highest that is available

use constant MESSAGE_HANDLER => {
    SSH2_FXP_INIT()        => 'processInit',
    SSH2_FXP_OPEN()        => 'processOpen',
    SSH2_FXP_CLOSE()       => 'processClose',
    SSH2_FXP_READ()        => 'processRead',
    SSH2_FXP_WRITE()       => 'processWrite',
    SSH2_FXP_LSTAT()       => 'processLstat',
    SSH2_FXP_FSTAT()       => 'processFstat',
    SSH2_FXP_SETSTAT()     => 'processSetstat',
    SSH2_FXP_FSETSTAT()    => 'processFsetstat',
    SSH2_FXP_OPENDIR()     => 'processOpendir',
    SSH2_FXP_READDIR()     => 'processReaddir',
    SSH2_FXP_REMOVE()      => 'processRemove',
    SSH2_FXP_MKDIR()       => 'processMkdir',
    SSH2_FXP_RMDIR()       => 'processRmdir',
    SSH2_FXP_REALPATH()    => 'processRealpath',
    SSH2_FXP_STAT()        => 'processStat',
    SSH2_FXP_RENAME()      => 'processRename',
    SSH2_FXP_READLINK()    => 'processReadlink',
    SSH2_FXP_SYMLINK()     => 'processSymlink',
    SSH2_FXP_EXTENDED()    => 'processExtended',
};

use constant MESSAGE_TYPES => {
    SSH2_FXP_INIT()        => 'SSH2_FXP_INIT',
    SSH2_FXP_OPEN()        => 'SSH2_FXP_OPEN',
    SSH2_FXP_CLOSE()       => 'SSH2_FXP_CLOSE',
    SSH2_FXP_READ()        => 'SSH2_FXP_READ',
    SSH2_FXP_WRITE()       => 'SSH2_FXP_WRITE',
    SSH2_FXP_LSTAT()       => 'SSH2_FXP_LSTAT',
    SSH2_FXP_FSTAT()       => 'SSH2_FXP_FSTAT',
    SSH2_FXP_SETSTAT()     => 'SSH2_FXP_SETSTAT',
    SSH2_FXP_FSETSTAT()    => 'SSH2_FXP_FSETSTAT',
    SSH2_FXP_OPENDIR()     => 'SSH2_FXP_OPENDIR',
    SSH2_FXP_READDIR()     => 'SSH2_FXP_READDIR',
    SSH2_FXP_REMOVE()      => 'SSH2_FXP_REMOVE',
    SSH2_FXP_MKDIR()       => 'SSH2_FXP_MKDIR',
    SSH2_FXP_RMDIR()       => 'SSH2_FXP_RMDIR',
    SSH2_FXP_REALPATH()    => 'SSH2_FXP_REALPATH',
    SSH2_FXP_STAT()        => 'SSH2_FXP_STAT',
    SSH2_FXP_RENAME()      => 'SSH2_FXP_RENAME',
    SSH2_FXP_READLINK()    => 'SSH2_FXP_READLINK',
    SSH2_FXP_SYMLINK()     => 'SSH2_FXP_SYMLINK',
    SSH2_FXP_EXTENDED()    => 'SSH2_FXP_EXTENDED',
    ALL()                  => 'ALL',
    NET_SFTP_SYMLINKS()    => 'NET_SFTP_SYMLINKS',
    NET_SFTP_RENAME_DIR()  => 'NET_SFTP_RENAME_DIR',
};

use constant ACTIONS => [
                              ALL,
                              NET_SFTP_SYMLINKS,
                              NET_SFTP_RENAME_DIR,
                              SSH2_FXP_OPEN,
                              SSH2_FXP_CLOSE,
                              SSH2_FXP_READ,
                              SSH2_FXP_WRITE,
                              SSH2_FXP_LSTAT,
                              SSH2_FXP_STAT_VERSION_0,
                              SSH2_FXP_FSTAT,
                              SSH2_FXP_SETSTAT,
                              SSH2_FXP_FSETSTAT,
                              SSH2_FXP_OPENDIR,
                              SSH2_FXP_READDIR,
                              SSH2_FXP_REMOVE,
                              SSH2_FXP_MKDIR,
                              SSH2_FXP_RMDIR,
                              SSH2_FXP_STAT,
                              SSH2_FXP_RENAME,
                              SSH2_FXP_READLINK,
                              SSH2_FXP_SYMLINK,
                            ];

use constant STATUS_MESSAGE => [
  "Success",                #/* SSH2_FX_OK */
  "End of file",            #/* SSH2_FX_EOF */
  "No such file",           #/* SSH2_FX_NO_SUCH_FILE */
  "Permission denied",      #/* SSH2_FX_PERMISSION_DENIED */
  "Failure",                #/* SSH2_FX_FAILURE */
  "Bad message",            #/* SSH2_FX_BAD_MESSAGE */
  "No connection",          #/* SSH2_FX_NO_CONNECTION */
  "Connection lost",        #/* SSH2_FX_CONNECTION_LOST */
  "Operation unsupported",  #/* SSH2_FX_OP_UNSUPPORTED */
  "Unknown error"            #/* Others */
];

my $USER = getpwuid($>);
my $ESCALATE_DEBUG = 0;
# --------------------------------------------------------------------
# Do evilness with symbol tables to ge
sub import{
  my $self = shift;
  my $opt = {};
  if (ref $_[0] eq 'HASH'){
    $opt = shift;
  }
  $opt->{log} ||= 'daemon';
  initLog($opt->{log});

  __PACKAGE__->export_to_level(1, $self, @_ ); # Call Exporter.
}
#-------------------------------------------------------------------------------
sub logItem {
  my ($level, $prefix, @msg) = @_;
  syslog $level, "[$USER]: $prefix" . join(" : ", @msg);
}
#-------------------------------------------------------------------------------
sub logDetail {
  logItem( $ESCALATE_DEBUG ? 'info' : 'debug', '', @_);
}
#-------------------------------------------------------------------------------
sub logGeneral {
  logItem('info', '', @_);
}
#-------------------------------------------------------------------------------
sub logWarning {
  logItem('warning', 'WARNING: ', @_);
}
#-------------------------------------------------------------------------------
sub logError {
  logItem('err', 'ERROR: ', @_);
}
#-------------------------------------------------------------------------------
sub initLog {
  my $syslog = shift;
  openlog( 'sftp', 'pid', $syslog);
  my ($remote_ip, $remote_port, $local_ip, $local_port) = split(' ', $ENV{SSH_CONNECTION});
  logGeneral "Client connected from $remote_ip:$remote_port";
  logDetail "Client connected to   $local_ip:$local_port";
}
#-------------------------------------------------------------------------------
sub getLogMsg {
  my $self = shift;
  my %arg = @_;

  my $req = $self->{_payload}->getPayloadContent();

  my $process = MESSAGE_TYPES->{$req->{message_type}};

  if ($req->{handle}){
    $req->{name} =  $self->{_payload}->getFilename() ;
  }

  my $msg = '';
  if (defined $arg{response} and $arg{response}->getType() == SSH2_FXP_STATUS ){
    $msg = 'response: ' . STATUS_MESSAGE->[$arg{response}->getStatus()] . ' ';
  }

  $msg .= "process: $process";

  if ($req->{id}){
    $msg .= " id: $req->{id}";
  }

  if ($req->{name}){
    $msg .= " filename: $req->{name}";
  }

  for my $field( qw( source_name target_name off len pflags ) ){
    if (defined $req->{$field}){
      $msg .= " $field: $req->{$field}";
    }
  }

  if ($req->{attr}){
    for my $key (keys %{$req->{attr}}){
      $msg .= " attr-$key: $req->{attr}{$key}";
    }
  }

  return $msg;
}
#-------------------------------------------------------------------------------
sub logAction {
  my $self = shift;

  my $req = $self->{_payload}->getPayloadContent();

  my $msg = $self->getLogMsg();

  if ( $self->{log_action_supress}{ $req->{message_type} } ){
    logDetail $msg;
  }
  else {
    logGeneral $msg;
  }
}
#-------------------------------------------------------------------------------
sub logStatus {
  my $self = shift;
  my $response = shift;
  my $msg = $self->getLogMsg(response => $response);
  my $req = $self->{_payload}->getPayloadContent();

  if ( $response->getType() == SSH2_FXP_STATUS
      and ( $self->{log_all_status} or ( $response->getStatus() != SSH2_FX_OK and $response->getStatus() != SSH2_FX_EOF ) )){
    logGeneral $msg;
  }
  elsif ( $response->getType() == SSH2_FXP_DATA or $req->{message_type} == SSH2_FXP_WRITE ){
    # Do nothing - otherwise we spam the syslog with every read/write packet
  }
  else {
    logDetail $msg;
  }

}
#-------------------------------------------------------------------------------
sub new {
  my $class = shift;
  my $self  = {};
  bless $self, $class;
  Stat::lsMode->novice(0); #disable warnings from this module

  $self->{client_version} = 3; # Just in case we have a bad client that doesn't init the connection properly, treat it as latest version

  my %arg = @_;
  if (defined $arg{debug}     ){ $ESCALATE_DEBUG     = $arg{debug}  };

  $self->{home} = $arg{home} || '/home';
  $self->{home} =~ s!/$!!; # strip trailing /
  if (defined $arg{file_perms}){ $self->{file_perms} = $arg{file_perms} };
  if (defined $arg{dir_perms} ){ $self->{dir_perms}  = $arg{dir_perms}  };

  $self->{home_dir} = "$self->{home}/$USER";
  $self->{FS} = Net::SFTP::SftpServer::FS->new();
  $self->{FS}->setChrootDir( $self->{home_dir} );
  unless ( -d $self->{home_dir} ){
    logWarning "No sftp folder $self->{home_dir} found for $USER";
    exit 1;
  }
  unless ( -o $self->{home_dir} ){
    logWarning "No $self->{home_dir} is not owned by $USER";
    exit 1;
  }

  if (defined $arg{on_file_sent}){
    $self->{on_file_sent} = $arg{on_file_sent};
  }
  if (defined $arg{on_file_received}){
    $self->{on_file_received} = $arg{on_file_received};
  }
  if (defined $arg{move_on_sent}){
    $self->{move_on_sent} = $arg{move_on_sent};
  }
  if (defined $arg{move_on_received}){
    $self->{move_on_received} = $arg{move_on_received};
  }

  $self->{use_tmp_upload} = (defined $arg{use_tmp_upload} and $arg{use_tmp_upload}) ? 1 : 0;

  $self->{max_file_size}  = (defined $arg{max_file_size}) ? $arg{max_file_size} : 0;

  $self->{valid_filename_char}  = (defined $arg{valid_filename_char} and ref $arg{valid_filename_char} eq 'ARRAY') ? quotemeta join ('', @{$arg{valid_filename_char}}) : '';


  if ( (defined $arg{deny} and $arg{deny} == ALL) or
       (defined $arg{allow} and $arg{allow} != ALL and not defined $arg{deny})
       ){
    $self->{deny} = { map { $_ => 1 } @{ACTIONS()} };
  }

  $arg{deny}  = (not defined $arg{deny})     ?  []         :
                (ref $arg{deny} eq 'ARRAY')  ? $arg{deny}  : [ $arg{deny} ];
  $arg{allow} = (not defined $arg{allow})    ?  []         :
                (ref $arg{allow} eq 'ARRAY') ? $arg{allow} : [ $arg{allow} ];

  for my $deny (@{$arg{deny}}){
    $self->{deny}{$deny} = 1;
  }
  for my $allow (@{$arg{allow}}){
    $self->{deny}{$allow} = 0;
  }

  # These have not been implemented yet
  $self->{deny}{SSH2_FXP_SETSTAT()}  = 1;
  $self->{deny}{SSH2_FXP_FSETSTAT()} = 1;
  $self->{deny}{SSH2_FXP_SYMLINK()}  = 1;
  $self->{deny}{SSH2_FXP_READLINK()} = 1;

  $self->{no_symlinks} = $self->{deny}{NET_SFTP_SYMLINKS()};
  if ($self->{no_symlinks}){
    # if denying symlinks then must deny these
    $self->{deny}{SSH2_FXP_SYMLINK()}  = 1;
    $self->{deny}{SSH2_FXP_READLINK()} = 1;
  }

  $arg{fake_ok} = (not defined $arg{fake_ok})    ?  []         :
                (ref $arg{fake_ok} eq 'ARRAY') ? $arg{fake_ok} : [ $arg{fake_ok} ];
  $self->{fake_ok} = { map {$_ => 1} @{$arg{fake_ok}} };

  $self->{handles} = {};
  $self->{handle_count} = 0;
  $self->{open_handle_count} = 0;

  # Logging levels

  $self->{log_action}  = { map { $_ => 1 } @{ $arg{log_action}  } };
  $self->{log_action_supress} = { map { $_ => 1 }
                          grep { not defined $self->{log_action}{$_} }
                          @{ $arg{log_action_supress} },
                            ( SSH2_FXP_READ,
                              SSH2_FXP_READDIR,
                              SSH2_FXP_WRITE,
                              SSH2_FXP_CLOSE,
                              SSH2_FXP_OPENDIR,
                              SSH2_FXP_STAT,
                              SSH2_FXP_FSTAT,
                              SSH2_FXP_LSTAT,
                              SSH2_FXP_REALPATH,
                               ) };

  $self->{log_all_status} = defined $arg{log_all_status} ? $arg{log_all_status} : 0;

  return $self;
}
#-------------------------------------------------------------------------------
sub run {
  my $self = shift;
  while (1) {
    #/* copy stdin to iqueue */
    # Read 4 byte length of message
    # read length = payload
    my $packet_length = unpack("N", $self->readData(4));
    if ($packet_length > MAX_PACKET_SIZE){
      logError "Packet length of $packet_length received - exiting";
      exit 1;
    }

    my $req;
    eval {
      local $SIG{ALRM} = sub { die "alarm\n" }; # NB: \n required
      alarm TIMEOUT;
      $req = $self->readData( $packet_length );
      alarm 0;
    };
    if ($@) {
      logError "Connection timed out trying to read $packet_length bytes";
      exit 1;
    }

    my $payload       = Net::SFTP::SftpServer::Buffer->new( data => $req );
    $self->{_payload} = $payload; # Keep a copy on self for debug output
    #/* process requests from client */
    # note - all send data will be called from the handler for this message type
    $self->process($payload);
  }
}
#-------------------------------------------------------------------------------
sub readData {
  my $self = shift;
  my $len = shift;
  my $req = '';
  #logDetail "Going to read $len bytes";
  while (length $req < $len){
    my $buf;
    my $read_len = sysread( STDIN, $buf, $len - length $req );
    if ($read_len == 0) {
      logGeneral("Client disconnected");
      $self->closeHandlesOnExit();
      exit 0;
    }
    elsif ($read_len < 0) {
      logWarning("read error");
      $self->closeHandlesOnExit();
      exit 1;
    }
    else {
      $req .= $buf;
    }
  }
  return $req;
}
#-------------------------------------------------------------------------------
sub closeHandlesOnExit {
  my $self = shift;
  for my $fd (values %{$self->{handles}}){
    $fd->close();
    logWarning "Handle for " . $fd->getFilename() . " still open on client exit";
  }
}
#-------------------------------------------------------------------------------
sub sendMessage {
  my $self = shift;
  my $msg = shift;
  #/* copy stdin to iqueue */
  # calc 4 byte length of message
  # put on front of message
  # send to STDOUT
  my $l = length $msg;
  #logDetail "Going to send $l bytes";
  my $len = pack('N', $l);
  my $write_len = syswrite( STDOUT, $len . $msg );
  if ($write_len < 0){
    logWarning "Write Error $!";
    $self->closeHandlesOnExit();
    exit 1;
  }
}
#-------------------------------------------------------------------------------
sub getHandle {
  my $self = shift;
  my $payload = shift;
  my $type = shift || '';
  my $req = $payload->getPayloadContent();
  my $handle_no = $req->{handle};
  if (defined $self->{handles}{$handle_no} and ($type eq '' or $type eq $self->{handles}{$handle_no}->getType())){
    my $handle = $self->{handles}{$handle_no};
    $payload->setFilename( $handle->getFilename() );
    $payload->setFileType( $handle->getType()     );
    return $handle;
  }
  return;
}
#-------------------------------------------------------------------------------
sub deleteHandle {
  my $self = shift;
  my $handle_no = shift;

  if (defined $self->{handles}{$handle_no}){
    $self->{open_handle_count}--;
    delete $self->{handles}{$handle_no};
  }
}
#-------------------------------------------------------------------------------
sub addHandle {
  my $self = shift;
  my $new_handle = shift;
  $self->{handle_count}++;
  $self->{open_handle_count}++;
  if ($self->{open_handle_count} > MAX_OPEN_HANDLES){
    logWarning "Exceeding max handle count";
    return;
  }
  $self->{handles}{$self->{handle_count}} = $new_handle;
  return $self->{handle_count};
}
#-------------------------------------------------------------------------------
sub process {
  my $self = shift;
  my $payload = shift;

  my $req = $payload->getPayloadContent(
    message_type  => 'char',
  );

  my $response = Net::SFTP::SftpServer::Response->new();

  if ($req->{message_type} != SSH2_FXP_INIT){
    # Init does not have an id - it has a client version - handled in processInit
    $req = $payload->getPayloadContent(
      id            => 'int',
    );
    $response->setId( $req->{id} )
  }

  logDetail "Got message_type " . MESSAGE_TYPES->{$req->{message_type}};

  if (defined MESSAGE_HANDLER->{$req->{message_type}}){
    my $method = MESSAGE_HANDLER->{$req->{message_type}};
    $self->$method($payload, $response);
  }
  else {
    logWarning("Unknown message $req->{message_type}");
    $response->setStatus( SSH2_FX_BAD_MESSAGE );
  }
  logWarning "Data left in buffer" unless $payload->done(); # check buffer is empty or warn

  $self->sendResponse( $response );
}
#-------------------------------------------------------------------------------
sub sendResponse {
  my $self = shift;
  my $response = shift;

  $self->logStatus( $response );

  my $msg;
  my $type = $response->getType();

  if ($type == SSH2_FXP_STATUS){
    my $status = $response->getStatus();
    $msg = pack('CNN', SSH2_FXP_STATUS, $response->getId() || 0, $status);
    if ($self->{client_version} >= 3){
      $msg .= pack('N', length STATUS_MESSAGE->[$status]) . STATUS_MESSAGE->[$status] . pack('N', 0);
    }
  }
  elsif ($type == SSH2_FXP_HANDLE){
    my $handle = $response->getHandle();
    $msg = pack('CNN', SSH2_FXP_HANDLE, $response->getId(), length $handle) . $handle;
  }
  elsif ($type == SSH2_FXP_DATA){
    $msg = pack('CNN', SSH2_FXP_DATA, $response->getId(), $response->getDataLength() )  . $response->getData();
  }
  elsif ($type == SSH2_FXP_VERSION){
    $msg = pack('CN', SSH2_FXP_VERSION, $response->getVersion());
  }
  elsif ($type == SSH2_FXP_ATTRS){
    $msg = pack('CN', SSH2_FXP_ATTRS, $response->getId() ) . $self->encodeAttrib( $response->getAttrs() );
  }
  elsif ($type == SSH2_FXP_NAME){
    my $files = $response->getNames();
    $msg = pack('CNN', SSH2_FXP_NAME, $response->getId(), scalar @$files );
    for my $file (@$files) {
      $msg .= pack('N', length $file->{name})      . $file->{name};
      $msg .= pack('N', length $file->{long_name}) . $file->{long_name};
      $msg .= $self->encodeAttrib($file->{attrib});
    }
  }
  else {
    logError "Unhandled response type: $type";
    # Make sure we send something back
    $msg = pack('CNN', SSH2_FXP_STATUS, $response->getId() || 0, SSH2_FX_BAD_MESSAGE );
    if ($self->{client_version} >= 3){
      $msg .= pack('N', length STATUS_MESSAGE->[SSH2_FX_BAD_MESSAGE]) . STATUS_MESSAGE->[SSH2_FX_BAD_MESSAGE] . pack('N', 0);
    }
  }
  $self->sendMessage( $msg );
}
#-------------------------------------------------------------------------------
sub processInit {
  my $self = shift;
  my $payload = shift;
  my $response = shift;

  my $req = $payload->getPayloadContent( client_version => 'int' );
  $self->{client_version} = $req->{client_version};
  logGeneral sprintf("Connection accepted, client version: %d", $self->{client_version});

  $response->setInitVersion( SSH2_FILEXFER_VERSION );
}
#-------------------------------------------------------------------------------
sub processOpen {
  my $self = shift;
  my $payload = shift;
  my $response = shift;

  my $req = $payload->getPayloadContent(
    name    => 'string',
    pflags  => 'int',         #/* portable flags */
    attr    => 'attrib',
  );

  my $flags  = $self->flagsFromPortable($req->{pflags});
  my $perm = defined $self->{file_perms}                              ? $self->{file_perms}  :
             ($req->{attr}{flags} & SSH2_FILEXFER_ATTR_PERMISSIONS)  ? $req->{attr}{perm}        : 0666;

  $self->logAction();

  return if $self->denyOperation(SSH2_FXP_OPEN, $response);

  my $filename = $self->makeSafeFileName($req->{name});

  if ((not defined $filename) or ($self->{no_symlinks} and $self->{FS}->IsSymlink( $filename ))){
    $response->setStatus( SSH2_FX_NO_SUCH_FILE );
    return;
  }
  # is this an upload
  # We use a tmp file if:
  # We have specified use tmp upload
  # And we have asked to create the file
  # And we are opening for writing
  # And we have either said to truncate the file on opening, or the file does not exist or is empty
  my $use_temp = ($self->{use_tmp_upload}  and
                  $req->{pflags} & SSH2_FXF_CREAT and
                  $req->{pflags} & SSH2_FXF_WRITE and
                  ( $req->{pflags} & SSH2_FXF_TRUNC or $self->{FS}->ZeroSize( $filename ) ) )    ? 1 : 0;

  my $fd = Net::SFTP::SftpServer::File->new( $filename, $flags, $req->{perm}, $use_temp);
  if (not defined $fd) {
    $response->setStatus( $self->errnoToPortable($! + 0) );
  } else {
    my $handle = $self->addHandle($fd);
    if (defined $handle){
      $response->setHandle( $handle );
      logDetail "Opened handle $handle for file $filename";
    }
    else {
      $response->setStatus( SSH2_FX_FAILURE );
    }
  }
}
#-------------------------------------------------------------------------------
sub processClose {
  my $self = shift;
  my $payload = shift;
  my $response = shift;

  my $req = $payload->getPayloadContent(
    handle  => 'string',
  );

  $self->logAction();

  my $ret = -1;
  my $status;
  my $fd = $self->getHandle($payload);
  if (defined $fd){
    $ret = $fd->close();
    $response->setStatus( $ret ? SSH2_FX_OK : $self->errnoToPortable($fd->err()) );
    if( $fd->getType() eq 'file'){
      #log file transmission stats
      logGeneral $fd->getStats();
      if (defined $self->{move_on_sent} and $fd->wasSent()){
        $fd->moveToProcessed( %{$self->{move_on_sent}} );
      }
      elsif (defined $self->{move_on_received} and $fd->wasReceived()){
        $fd->moveToProcessed( %{$self->{move_on_received}} );
      }
      if (defined $self->{on_file_sent} and $fd->wasSent()){
        $fd->setCallback();
        eval { $self->{on_file_sent}($fd) };
        if ($@){
          logError "on_file_sent Handler died with $@";
        }
      }
      elsif (defined $self->{on_file_received} and $fd->wasReceived()){
        $fd->setCallback();
        eval { $self->{on_file_received}($fd) };
        if ($@){
          logError "on_file_received Handler died with $@";
        }
      }
    }
  }
  else {
    $response->setStatus( SSH2_FX_NO_SUCH_FILE );
  }

  $self->deleteHandle($req->{handle});
}
#-------------------------------------------------------------------------------
sub processRead {
  my $self = shift;
  my $payload = shift;
  my $response = shift;

  my $req = $payload->getPayloadContent(
    handle  => 'string',
    off     => 'int64',
    len     => 'int',
  );

  $self->logAction();

  return if $self->denyOperation(SSH2_FXP_READ, $response);

  my $fd = $self->getHandle($payload, 'file');
  if (defined $fd) {
    if ($fd->sysseek($req->{off}, SEEK_SET) < 0) {
      my $errno = $!+0;
      logWarning "processRead: seek failed $!";
      $response->setStatus( $self->errnoToPortable($errno) );
    } else {
      my $buf;
      my $ret = $fd->sysread( $buf, $req->{len} );
      if ($ret < 0) {
        $response->setStatus( $self->errnoToPortable($!+0) );
      }
      elsif ($ret == 0) {
        $response->setStatus( SSH2_FX_EOF );
      } else {
        $response->setData( $ret, $buf );
        $fd->readBytes( $ret ) if $fd->getReadBytes() eq $req->{off}; #Only log sequential reads
      }
    }
  }
  else {
    $response->setStatus( SSH2_FX_FAILURE );
  }
}
#-------------------------------------------------------------------------------
sub processWrite {
  my $self = shift;
  my $payload = shift;
  my $response = shift;

  my $req = $payload->getPayloadContent(
    handle  => 'string',
    off     => 'int64',
    data    => 'string',
  );

  $self->logAction();

  return if $self->denyOperation(SSH2_FXP_WRITE, $response);


  my $fd = $self->getHandle($payload, 'file');
  if (defined $fd) {
    if ($self->{max_file_size} and $req->{off} + length $req->{data} > $self->{max_file_size}){
      logError "Attempt to write greater than Max file size, offset: $req->{off}, data length:" .  length $req->{data} . " on file ". $fd->getFilename();
      $response->setStatus( SSH2_FX_PERMISSION_DENIED );
      return;
    }
    elsif ($self->{max_file_size} and $req->{off} + length $req->{data} > 0.75 * $self->{max_file_size}){
      logWarning "Writing greater than 75% of Max file size, offset: $req->{off}, data length:" .  length $req->{data} . " on file ". $fd->getFilename();
    }
    if ($fd->sysseek($req->{off}, SEEK_SET) < 0) {
      my $errno = $!+0;
      logWarning "processRead: seek failed $!";
      $response->setStatus( $self->errnoToPortable($errno) );
    } else {
      my $len = length $req->{data};
      my $ret = $fd->syswrite($req->{data}, $len);
      if ($ret < 0) {
        logWarning "process_write: write failed";
        $response->setStatus( $self->errnoToPrtable($!+0) );
      }
      elsif ($ret == $len) {
        $fd->wroteBytes( $ret ) if $fd->getWrittenBytes() eq $req->{off}; #Only log sequential writes;
        $response->setStatus( SSH2_FX_OK );
      } else {
        logGeneral("nothing at all written");
      }
    }
  }
}
#-------------------------------------------------------------------------------
sub processDoStat{
  my $self = shift;
  my $mode    = shift;
  my $payload = shift;
  my $response = shift;


  my $req = $payload->getPayloadContent(
    name    => 'string',
  );

  my $filename = $self->makeSafeFileName($req->{name});

  $self->logAction();
  return if $self->denyOperation(($mode ? SSH2_FXP_LSTAT : SSH2_FXP_STAT), $response);

  if ((not defined $filename) or ($self->{no_symlinks} and $self->{FS}->IsSymlink( $filename ))){
    $response->setStatus( SSH2_FX_NO_SUCH_FILE );
    return;
  }
  my @st = $mode ? $self->{FS}->LStat($filename) : $self->{FS}->Stat($filename);
  if (scalar @st == 0) {
    $response->setStatus( $self->errnoToPortable($!+0) );
  }
  else {
    $response->setAttrs( $self->statToAttrib(@st) );
  }
}
#-------------------------------------------------------------------------------
sub processStat {
  my $self = shift;
  my $payload = shift;
  my $response = shift;
  $self->processDoStat(0, $payload, $response);
}
#-------------------------------------------------------------------------------
sub processLstat {
  my $self = shift;
  my $payload = shift;
  my $response = shift;
  $self->processDoStat(1, $payload, $response);
}
#-------------------------------------------------------------------------------
sub processFstat {
  my $self = shift;
  my $payload = shift;
  my $response = shift;

  my $status = SSH2_FX_FAILURE;

  my $req = $payload->getPayloadContent(
    handle  => 'string',
  );

  $self->logAction();

  return if $self->denyOperation(SSH2_FXP_FSTAT, $response);

  my $fd = $self->getHandle($payload);
  if (defined $fd) {
    my @st = stat($fd);
    if (scalar @st == 0) {
      $response->setStatus( $self->errnoToPortable($!+0) );
    } else {
      $response->setAttrs(  $self->statToAttrib(@st) );
    }
  }
  else {
    $response->setStatus( SSH2_FX_FAILURE );
  }
}
#-------------------------------------------------------------------------------
sub processSetstat {
  my $self = shift;
  my $payload = shift;
  my $response = shift;

  #We choose not to allow any setting of stats

  my $req = $payload->getPayloadContent(
    name    => 'string',
    attr    => 'attrib',
  );

  $self->logAction();

  my $filename = $self->makeSafeFileName($req->{name});

  if ((not defined $filename) or ($self->{no_symlinks} and $self->{FS}->IsSymlink( $filename ))){
    $response->setStatus( SSH2_FX_NO_SUCH_FILE );
    return;
  }

  return if $self->denyOperation(SSH2_FXP_SETSTAT, $response);

  logError "processSetstat not implemented";
}
#-------------------------------------------------------------------------------
sub processFsetstat {
  my $self = shift;
  my $payload = shift;
  my $response = shift;

  #We choose not to allow any setting of stats

  my $req = $payload->getPayloadContent(
    handle  => 'string',
    attr    => 'attrib',
  );

  $self->logAction();

  return if $self->denyOperation(SSH2_FXP_FSETSTAT, $response);

  logError "processFsetstat not implemented";
}
#-------------------------------------------------------------------------------
sub processOpendir {
  my $self = shift;
  my $payload = shift;
  my $response = shift;

  my $req = $payload->getPayloadContent(
    name    => 'string',
  );

  $self->logAction();

  my $pathname = $self->makeSafeFileName($req->{name});

  return if $self->denyOperation(SSH2_FXP_OPENDIR, $response);

  if ((not defined $pathname) or ($self->{no_symlinks} and $self->{FS}->IsSymlink( $pathname ))){
    $response->setStatus( SSH2_FX_NO_SUCH_FILE );
    return;
  }

  my $dirp = Net::SFTP::SftpServer::Dir->new($pathname);
  if (!defined $dirp) {
    $response->setStatus( $self->errnoToPortable($!+0) );
  } else {
    my $handle = $self->addHandle($dirp);
    if (defined $handle){
      $response->setHandle( $handle );
    }
    else {
      $response->setStatus( SSH2_FX_FAILURE );
    }
  }
}
#-------------------------------------------------------------------------------
sub processReaddir {
  my $self = shift;
  my $payload = shift;
  my $response = shift;

  my $req = $payload->getPayloadContent(
    handle  => 'string',
  );

  $self->logAction();

  return if $self->denyOperation(SSH2_FXP_READDIR, $response);

  my $dirp = $self->getHandle($payload, 'dir');
  if (not defined $dirp) {
    $response->setStatus( SSH2_FX_FAILURE );
  }
  else {
    my $fullpath = $dirp->getPath();
    my $stats = [];
    my $count = 0;
    while (my $dp = $dirp->readdir()) {
      my $pathname = $fullpath . $dp;
      next if ( $self->{no_symlinks} and $self->{FS}->IsSymlink( $pathname ) ); # we only inform the user about files and directories
    my @st = $self->{FS}->LStat($pathname);
      next unless scalar @st;
      my $file = {};
      $file->{attrib} = $self->statToAttrib(@st);
      $file->{name} = $dp;
      $file->{long_name} = $self->lsFile($dp, \@st);
      $count++;
      push @{$stats}, $file;
      #/* send up to 100 entries in one message */
      #/* XXX check packet size instead */
      last if $count == 100;
    }
    if ($count > 0) {
      $response->setNames($stats);
    }
    else {
      $response->setStatus( SSH2_FX_EOF );
    }
  }
}
#-------------------------------------------------------------------------------
sub processRemove {
  my $self = shift;
  my $payload = shift;
  my $response = shift;

  my $req = $payload->getPayloadContent(
    name    => 'string',
  );

  $self->logAction();

  my $filename = $self->makeSafeFileName($req->{name});

  logDetail sprintf("processRemove: remove id %u name %s", $req->{id}, $req->{name});

  return if $self->denyOperation(SSH2_FXP_REMOVE, $response);

  if ((not defined $filename) or ($self->{no_symlinks} and $self->{FS}->IsSymlink( $filename ))){
    $response->setStatus( SSH2_FX_NO_SUCH_FILE );
    return;
  }

  my $ret = $self->{FS}->Unlink($filename);
  my $status = $ret ?  SSH2_FX_OK : $self->errnoToPortable($!+0);
  if ( $status == SSH2_FX_OK ){
    logGeneral "Removed $filename";
  }
  $response->setStatus( $status );
}
#-------------------------------------------------------------------------------
sub processMkdir {
  my $self = shift;
  my $payload = shift;
  my $response = shift;


  my $req = $payload->getPayloadContent(
    name    => 'string',
    attr    => 'attrib',
  );

  my $filename = $self->makeSafeFileName($req->{name});

  my $mode = defined $self->{dir_perms}                              ? $self->{dir_perms}        :
             ($req->{attr}{flags} & SSH2_FILEXFER_ATTR_PERMISSIONS)  ? $req->{attr}{perm} & 0777 : 0777;

  $self->logAction();

  return if $self->denyOperation(SSH2_FXP_MKDIR, $response);

  if (not defined $filename){
    $response->setStatus( SSH2_FX_NO_SUCH_FILE );
    return;
  }

  my $ret = $self->{FS}->Mkdir($filename, $mode);
  $response->setStatus( $ret ? SSH2_FX_OK : $self->errnoToPortable($!+0) );
}
#-------------------------------------------------------------------------------
sub processRmdir {
  my $self = shift;
  my $payload = shift;
  my $response = shift;

  my $req = $payload->getPayloadContent(
    name    => 'string',
  );

  my $filename = $self->makeSafeFileName($req->{name});

  $self->logAction();

  return if $self->denyOperation(SSH2_FXP_RMDIR, $response);

  if (not defined $filename){
    $response->setStatus( SSH2_FX_NO_SUCH_FILE );
    return;
  }

  my $ret = $self->{FS}->Rmdir($filename);
  $response->setStatus( $ret ? SSH2_FX_OK : $self->errnoToPortable($!+0) );
}
#-------------------------------------------------------------------------------
sub processRealpath {
  my $self = shift;
  my $payload = shift;
  my $response = shift;

  my $req = $payload->getPayloadContent(
    name    => 'string',
  );

  $self->logAction();

  my $path     = $self->makeSafeFileName($req->{name});

  logDetail sprintf("processRealpath: realpath id %u path %s", $req->{id}, $req->{name});

  my $file = { name => $path, long_name => $path, attrib => { flags => 0 } };

  $response->setNames( $file );
}
#-------------------------------------------------------------------------------
sub processRename {
  my $self = shift;
  my $payload = shift;
  my $response = shift;

  my $req = $payload->getPayloadContent(
    source_name  => 'string',
    target_name  => 'string',
  );

  my $oldpath  = $self->makeSafeFileName($req->{source_name});
  my $newpath  = $self->makeSafeFileName($req->{target_name});

  $self->logAction();

  return if $self->denyOperation(SSH2_FXP_RENAME, $response);

  if ((not defined $oldpath or not defined $newpath) or ($self->{no_symlinks} and $self->{FS}->IsSymlink( $oldpath ) )){
    $response->setStatus( SSH2_FX_NO_SUCH_FILE );
    return;
  }

  return if $self->{FS}->IsDir( $oldpath ) and $self->denyOperation(NET_SFTP_RENAME_DIR, $response);

  if ( $self->{FS}->IsFile( $oldpath )) {
    #/* Race-free rename of regular files */
    if (! $self->{FS}->Link( $oldpath,  $newpath)) {#FIXME test all codepaths
      # link method failed - try just a rename
      if (! $self->{FS}->Rename($oldpath, $newpath)){
        $response->setStatus($self->errnoToPortable($!+0));
      }
      else {
        $response->setStatus(SSH2_FX_OK);
      }
    }
    elsif (! $self->{FS}->Unlink($oldpath)) {
      $response->setStatus( $self->errnoToPortable($!+0) );
      #/* clean spare link */
      $self->{FS}->Unlink($newpath);
    }
    else {
      $response->setStatus(SSH2_FX_OK);
    }
  }
  elsif ( $self->{FS}->IsDir( $oldpath ) ) {
    if (! $self->{FS}->Rename($oldpath, $newpath)){
      $response->setStatus($self->errnoToPortable($!+0));
    }
    else {
      $response->setStatus(SSH2_FX_OK);
    }
  }
  else {
    # File does not exist or is a symlink - deny all knowlege
    $response->setStatus(SSH2_FX_NO_SUCH_FILE);
  }
}
#-------------------------------------------------------------------------------
sub processReadlink {
  my $self = shift;
  my $payload = shift;
  my $response = shift;

  my $req = $payload->getPayloadContent(
    name     => 'string',
  );

  $self->logAction();

  $response->setStatus(SSH2_FX_NO_SUCH_FILE); # all symlinks hidden
}
#-------------------------------------------------------------------------------
sub processSymlink {
  my $self = shift;
  my $payload = shift;
  my $response = shift;

  my $req = $payload->getPayloadContent(
    source_name  => 'string',
    target_name  => 'string',
  );

  my $oldpath  = $self->makeSafeFileName($req->{source_name});
  my $newpath  = $self->makeSafeFileName($req->{target_name});

  $self->logAction();

  return if $self->denyOperation(SSH2_FXP_SYMLINK, $response);

  logError "processSymlink not implemented";
}
#-------------------------------------------------------------------------------
sub processExtended {
  my $self = shift;
  my $payload = shift;
  my $response = shift;

  my $req = $payload->getPayloadContent(
    request  => 'string',
  );

  $self->logAction();

  $response->setStatus( SSH2_FX_OP_UNSUPPORTED );    #/* MUST */
}
#-------------------------------------------------------------------------------
sub denyOperation {
  my $self = shift;
  my ($op, $response) = @_;
  if (defined $self->{deny}{$op} and $self->{deny}{$op}){
    logWarning "Denying request operation: " . MESSAGE_TYPES->{$op} . ", id: " . $response->getId();
    if (defined $self->{fake_ok}{$op} and $self->{fake_ok}{$op}){
      $response->setStatus( SSH2_FX_OK );
    }
    else {
      $response->setStatus( SSH2_FX_PERMISSION_DENIED );
    }
    return 1;
  }
  return;
}
#-------------------------------------------------------------------------------
sub lsFile {
  my $self = shift;
  my $name = shift;
  my $st = shift;
  my @ltime = localtime($st->[9]);
  my $mode = format_mode($st->[2]);

  my $user  = getpwuid($st->[4]);
  my $group = getgrgid($st->[5]);
  my $sz;
  if (scalar @ltime) {
    if (time() - $st->[9] < (365*24*60*60)/2){
      $sz = strftime "%b %e %H:%M", @ltime;
    }
    else {
      $sz = strftime "%b %e  %Y",   @ltime;
    }
  }

  my $ulen = length $user  > 8 ? length $user  : 8;
  my $glen = length $group > 8 ? length $group : 8;
  return sprintf("%s %3u %-*s %-*s %8llu %s %s", $mode, $st->[3], $ulen, $user, $glen, $group, $st->[7], $sz, $name);
}
#-------------------------------------------------------------------------------
sub makeSafeFileName {
  my $self = shift;
  # We force all file names to be treated as from / which we treat as the users home directory
  my $name = shift;

  $name = "/$name";
  while ($name =~ s!/\./!/!g)   {}
  $name =~ s!//+!/!g;

  my @path = split('/', $name);
  my @newpath;
  for my $d (@path){
    if ($d eq  '..'){
      pop @newpath;
    }
    elsif ($d ne '.') {
      if ($self->{valid_filename_char}){
        if ($d !~ /^[$self->{valid_filename_char}]*$/){
          logError "Invalid characters in $name";
          return;
        }
      }
      push @newpath, $d;
    }
    if ($self->{no_symlinks}){
      if ( $self->{FS}->IsSymlink( join('/', @newpath) ) ){
        return; # no symlinks
      }
    }
  }

  $name = join('/', @newpath) || '/';
  $name =~ s!/\.$!/!;
  return $name;
}
#-------------------------------------------------------------------------------
sub encodeAttrib {
  my $self = shift;
  my $attr = shift;
  $attr->{flags} ||= 0;
  my $msg = pack('N', $attr->{flags});
  if ($attr->{flags} & SSH2_FILEXFER_ATTR_SIZE){
    my $h = int($attr->{size} / (1 << 32));
    my $l =     $attr->{size} % (1 << 32);
    $msg .= pack('NN', $h, $l );
  }
  if ($attr->{flags} & SSH2_FILEXFER_ATTR_UIDGID) {
    $msg .= pack('N', $attr->{uid});
    $msg .= pack('N', $attr->{gid});
  }
  if ($attr->{flags} & SSH2_FILEXFER_ATTR_PERMISSIONS){
    $msg .= pack('N', $attr->{perm});
  }
  if ($attr->{flags} & SSH2_FILEXFER_ATTR_ACMODTIME) {
    $msg .= pack('N', $attr->{atime});
    $msg .= pack('N', $attr->{mtime});
  }
  return $msg;
}
#-------------------------------------------------------------------------------
sub statToAttrib {
  my $self = shift;
  my @stats = @_;
  #/* Convert from struct stat to filexfer attribs */
  my $attr = {};
  $attr->{flags} = 0;
  $attr->{flags} |= SSH2_FILEXFER_ATTR_SIZE;
  $attr->{size} = $stats[7];
  $attr->{flags} |= SSH2_FILEXFER_ATTR_UIDGID;
  $attr->{uid} = $stats[4];
  $attr->{gid} = $stats[5];
  $attr->{flags} |= SSH2_FILEXFER_ATTR_PERMISSIONS;
  $attr->{perm} = $stats[2];
  $attr->{flags} |= SSH2_FILEXFER_ATTR_ACMODTIME;
  $attr->{atime} = $stats[8];
  $attr->{mtime} = $stats[9];

  return $attr;
}
#-------------------------------------------------------------------------------
sub flagsFromPortable{
  my $self = shift;
  my $pflags = shift;
  my $flags = 0;

  if (($pflags & SSH2_FXF_READ) &&
      ($pflags & SSH2_FXF_WRITE)) {
    $flags = O_RDWR;
  }
  elsif ($pflags & SSH2_FXF_READ) {
    $flags = O_RDONLY;
  }
  elsif ($pflags & SSH2_FXF_WRITE) {
    $flags = O_WRONLY;
  }
  if ($pflags & SSH2_FXF_CREAT){
    $flags |= O_CREAT;
  }
  if ($pflags & SSH2_FXF_TRUNC){
    $flags |= O_TRUNC;
  }
  if ($pflags & SSH2_FXF_EXCL){
    $flags |= O_EXCL;
  }
  return $flags;
}
#-------------------------------------------------------------------------------
sub errnoToPortable {
  my $self = shift;
  my $errno = shift;

  if ($errno == 0){
    logWarning "Good error code received by errnoToPortable";
    return SSH2_FX_OK;
  }
  elsif ( $errno ==  ENOENT or
          $errno ==  ENOTDIR or
          $errno ==  EBADF or
          $errno ==  ELOOP ){
    return SSH2_FX_NO_SUCH_FILE;
  }
  elsif ( $errno ==   EPERM or
          $errno ==   EACCES or
          $errno ==   EFAULT ){
    return SSH2_FX_PERMISSION_DENIED;
  }
  elsif ( $errno == ENAMETOOLONG or
          $errno ==   EINVAL){
    return SSH2_FX_BAD_MESSAGE;
  }
  else {
    return SSH2_FX_FAILURE;
  }
}
#-------------------------------------------------------------------------------
#-------------------------------------------------------------------------------
#-------------------------------------------------------------------------------
#-------------------------------------------------------------------------------
#-------------------------------------------------------------------------------
package Net::SFTP::SftpServer::Buffer;
use strict;
use warnings;

#/* attributes */
use constant SSH2_FILEXFER_ATTR_SIZE        => 0x00000001;
use constant SSH2_FILEXFER_ATTR_UIDGID      => 0x00000002;
use constant SSH2_FILEXFER_ATTR_PERMISSIONS => 0x00000004;
use constant SSH2_FILEXFER_ATTR_ACMODTIME   => 0x00000008;
use constant SSH2_FILEXFER_ATTR_EXTENDED    => 0x80000000;

1;
#-------------------------------------------------------------------------------
sub new {
  my $class = shift;
  my $self  = {};
  bless $self, $class;
  my %arg = @_;
  $self->{data} = $arg{data};
  return $self;
}
#-------------------------------------------------------------------------------
sub asString {
  my $self = shift;

  my @strings;
  push @strings, length $self->{data} . " bytes left to decode";
  push @strings, "Decoded: ";
  for my $key ( sort keys %{$self->{_decoded_data}} ){
    if ($key eq 'data' and $self->{_decoded_data}{data} !~ /^[\s\w]*$/){
      push @strings, "$key\t\t=>";
    }
    else {
      push @strings, "$key\t\t=>$self->{_decoded_data}{$key}";
    }
  }

  return join("\n", @strings)
}
# ------------------------------------------------------------------------------
sub getPayloadContent {
  my $self = shift;

  while ( my $name = shift and my $type = shift ){
    if ($type eq 'int'){
      $self->{_decoded_data}{$name} = $self->getInt();
    }
    elsif ($type eq 'int64'){
      $self->{_decoded_data}{$name} = $self->getInt64();
    }
    elsif ($type eq 'char'){
      $self->{_decoded_data}{$name} = $self->getChar();
    }
    elsif ($type eq 'string'){
      $self->{_decoded_data}{$name} = $self->getString();
    }
    elsif ($type eq 'attrib'){
      $self->{_decoded_data}{$name} = $self->getAttrib();
    }
  }

  return $self->{_decoded_data};
}
# ------------------------------------------------------------------------------
sub getInt {
  my $self = shift;
  my $i = substr($self->{data}, 0, 4);
  $self->{data} = substr($self->{data}, 4);
  return unpack("N", $i);
}
# ------------------------------------------------------------------------------
sub getInt64 {
  my $self = shift;
  my $i = substr($self->{data}, 0, 8);
  $self->{data} = substr($self->{data}, 8);
  my ($h, $l) = unpack("NN", $i);
  return ($h << 32) + $l;
}
# ------------------------------------------------------------------------------
sub getChar {
  my $self = shift;
  my $c = substr($self->{data}, 0, 1);
  $self->{data} = substr($self->{data}, 1);
  return unpack("C", $c);
}
# ------------------------------------------------------------------------------
sub getString {
  my $self = shift;
  my $len = $self->getInt();
  my $str = substr($self->{data}, 0, $len);
  $self->{data} = substr($self->{data}, $len);
  return $str;
}
#-------------------------------------------------------------------------------
sub getAttrib {
  my $self = shift;
  #/* Decode attributes in buffer */

  my $attr = {};

  $attr->{flags} = $self->getInt();
  if ($attr->{flags} & SSH2_FILEXFER_ATTR_SIZE){
    $attr->{size} = $self->getInt64();
  }
  if ($attr->{flags} & SSH2_FILEXFER_ATTR_UIDGID) {
    $attr->{uid} = $self->getInt();
    $attr->{gid} = $self->getInt();
  }
  if ($attr->{flags} & SSH2_FILEXFER_ATTR_PERMISSIONS){
    $attr->{perm} = $self->getInt();
  }
  if ($attr->{flags} & SSH2_FILEXFER_ATTR_ACMODTIME) {
    $attr->{atime} = $self->getInt();
    $attr->{mtime} = $self->getInt();
  }

  #/* vendor-specific extensions */
  if ($attr->{flags} & SSH2_FILEXFER_ATTR_EXTENDED) {
    my $count = $self->getInt();
    for (my $i = 0; $i < $count; $i++) {
      my $type = $self->getString();
      my $req = $self->getString();
      logDetail("Got file attribute \"%s\"", $type);
    }
  }
  return $attr;
}
# ------------------------------------------------------------------------------
sub done {
  my $self = shift;
  return 1 if length $self->{data} eq 0;
  return;
}
#-------------------------------------------------------------------------------
sub setFileType {
  my $self = shift;
  $self->{file_type} = shift;
}
#-------------------------------------------------------------------------------
sub getFileType {
  my $self = shift;
  return $self->{file_type};
}
#-------------------------------------------------------------------------------
sub setFilename {
  my $self = shift;
  $self->{filename} = shift;
}
#-------------------------------------------------------------------------------
sub getFilename {
  my $self = shift;
  return $self->{filename};
}
1;
#-------------------------------------------------------------------------------
#-------------------------------------------------------------------------------
#-------------------------------------------------------------------------------
#-------------------------------------------------------------------------------
#-------------------------------------------------------------------------------
#-------------------------------------------------------------------------------
package Net::SFTP::SftpServer::Response;
use strict;
use warnings;

#/* server to client */
use constant SSH2_FXP_VERSION               => 2;
use constant SSH2_FXP_STATUS                => 101;
use constant SSH2_FXP_HANDLE                => 102;
use constant SSH2_FXP_DATA                  => 103;
use constant SSH2_FXP_NAME                  => 104;
use constant SSH2_FXP_ATTRS                 => 105;

1;
#-------------------------------------------------------------------------------
sub new {
  my $class = shift;
  my $self  = {};
  bless $self, $class;
  return $self;
}
#-------------------------------------------------------------------------------
sub asString {
  my $self = shift;

  my @strings;
  for my $key ( sort keys %$self ){
    if ($key eq 'data' and $self->{data} !~ /^[\s\w]*$/){
      push @strings, "$key\t\t=>";
    }
    else {
      push @strings, "$key\t\t=>$self->{$key}";
    }
  }

  return join("\n", @strings)
}
#-------------------------------------------------------------------------------
sub setId {
  my $self = shift;
  $self->{id} = shift;
}
#-------------------------------------------------------------------------------
sub getId {
  my $self = shift;
  return $self->{id};
}
#-------------------------------------------------------------------------------
sub getType {
  my $self = shift;
  return $self->{type};
}
#-------------------------------------------------------------------------------
sub setStatus {
  my $self = shift;
  $self->{status} = shift;
  $self->{type} = SSH2_FXP_STATUS;
}
#-------------------------------------------------------------------------------
sub getStatus {
  my $self = shift;
  return $self->{status};
}
#-------------------------------------------------------------------------------
sub setData {
  my $self = shift;
  $self->{data_length} = shift;
  $self->{data} = shift;
  $self->{type} = SSH2_FXP_DATA;
}
#-------------------------------------------------------------------------------
sub getData {
  my $self = shift;
  return $self->{data};
}
#-------------------------------------------------------------------------------
sub getDataLength {
  my $self = shift;
  return $self->{data_length};
}
#-------------------------------------------------------------------------------
sub setHandle {
  my $self = shift;
  $self->{handle} = shift;
  $self->{type} = SSH2_FXP_HANDLE;
}
#-------------------------------------------------------------------------------
sub getHandle {
  my $self = shift;
  return $self->{handle};
}
#-------------------------------------------------------------------------------
sub setNames {
  my $self = shift;
  $self->{names} = shift;
  $self->{names} = [ $self->{names} ] unless ref $self->{names} eq 'ARRAY';
  $self->{type} = SSH2_FXP_NAME;
}
#-------------------------------------------------------------------------------
sub getNames {
  my $self = shift;
  return $self->{names};
}
#-------------------------------------------------------------------------------
sub setInitVersion {
  my $self = shift;
  $self->{version} = shift;
  $self->{type} = SSH2_FXP_VERSION;
}
#-------------------------------------------------------------------------------
sub getVersion {
  my $self = shift;
  return $self->{version};
}
#-------------------------------------------------------------------------------
sub setAttrs {
  my $self = shift;
  $self->{attr} = shift;
  $self->{type} = SSH2_FXP_ATTRS;
}
#-------------------------------------------------------------------------------
sub getAttrs {
  my $self = shift;
  return $self->{attr};
}
1;
#-------------------------------------------------------------------------------
#-------------------------------------------------------------------------------
#-------------------------------------------------------------------------------
#-------------------------------------------------------------------------------
#-------------------------------------------------------------------------------
#-------------------------------------------------------------------------------
package Net::SFTP::SftpServer::FS;

no strict;

use Exporter qw( import );

@EXPORT = qw(
  setChrootDir
);

use strict;
use warnings;

{
  my %callback_of;

  my $chroot_dir = '';

  #-------------------------------------------------------------------------------
  sub new {
    my $class = shift;
    my $self  = bless \do{my $anon}, $class;
    return unless $self->initialise( @_ ); # Dont keep the object unless we initialise sucessfully

    my $ident = scalar $self;

    $callback_of{$ident} = 0;

    return $self;
  }
  #-------------------------------------------------------------------------------
  sub initialise {
    return 1;
  }
  #-------------------------------------------------------------------------------
  sub setChrootDir {
    my $self = shift;
    $chroot_dir = shift;
  }
  #-------------------------------------------------------------------------------
  sub IsSymlink {
    my $self = shift;
    return -l $chroot_dir . shift;
  }
  #-------------------------------------------------------------------------------
  sub Exists {
    my $self = shift;
    return -e $chroot_dir . shift;
  }
  #-------------------------------------------------------------------------------
  sub IsFile {
    my $self = shift;
    return -f $chroot_dir . shift;
  }
  #-------------------------------------------------------------------------------
  sub IsDir {
    my $self = shift;
    return -d $chroot_dir . shift;
  }
  #-------------------------------------------------------------------------------
  sub ZeroSize {
    my $self = shift;
    return -z $chroot_dir . shift;
  }
  #-------------------------------------------------------------------------------
  sub Link {
    my $self = shift;
    return link( $chroot_dir . shift, $chroot_dir . shift);
  }
  #-------------------------------------------------------------------------------
  sub LStat {
    my $self = shift;
    return lstat $chroot_dir . shift;
  }
  #-------------------------------------------------------------------------------
  sub Stat {
    my $self = shift;
    return stat $chroot_dir . shift;
  }
  #-------------------------------------------------------------------------------
  sub Size {
    my $self = shift;
    return -s $chroot_dir . shift;
  }
  #-------------------------------------------------------------------------------
  sub Unlink {
    my $self = shift;
    return unlink $chroot_dir . shift;
  }
  #-------------------------------------------------------------------------------
  sub Mkdir {
    my $self = shift;
    return mkdir( $chroot_dir . shift, shift);
  }
  #-------------------------------------------------------------------------------
  sub Rmdir {
    my $self = shift;
    return rmdir $chroot_dir . shift;
  }
  #-------------------------------------------------------------------------------
  sub Rename {
    my $self = shift;
    my ($old, $new) = @_;
    return rename( $chroot_dir . $old, $chroot_dir . $new);
  }
  #-------------------------------------------------------------------------------
  sub chrootDir {
    my $self = shift;
    return $chroot_dir;
  }
  #-------------------------------------------------------------------------------
  sub setCallback {
    my $self = shift;
    my $ident = scalar($self);
    $callback_of{$ident} = 1;
  }
  #-------------------------------------------------------------------------------
  sub callback {
    my $self = shift;
    my $ident = scalar($self);
    return $callback_of{$ident};
  }
  #-------------------------------------------------------------------------------
  sub DESTROY {
    my $self = shift;
    my $ident = scalar($self);
    delete $callback_of{$ident};
  }
}
1;
#-------------------------------------------------------------------------------
#-------------------------------------------------------------------------------
#-------------------------------------------------------------------------------
#-------------------------------------------------------------------------------
#-------------------------------------------------------------------------------
package Net::SFTP::SftpServer::FileChrootBroken;

use strict;
use warnings;

our $AUTOLOAD;

sub AUTOLOAD {
  my $self = shift;

  my $method = $AUTOLOAD;
  $method =~ m/.+::(.+)(?!::)/;
  $method = $1 if $1;

  Net::SFTP::SftpServer::logError "$method is not supported after chroot is broken";

  return;
}
#-------------------------------------------------------------------------------
#-------------------------------------------------------------------------------
#-------------------------------------------------------------------------------
#-------------------------------------------------------------------------------
#-------------------------------------------------------------------------------
package Net::SFTP::SftpServer::File;
use strict;
use warnings;

use IO::File;
use File::Basename;
use Fcntl qw( O_RDWR O_CREAT O_TRUNC O_EXCL O_RDONLY O_WRONLY SEEK_SET );

use base qw( Net::SFTP::SftpServer::FS );

{
  my $TMP_EXT = ".SftpXFR.$$";

  my %fh_of;
  my %filename_of;
  my %mode_of;
  my %perm_of;
  my %write_of;
  my %read_of;
  my %opentime_of;
  my %use_temp_of;
  my %err_of;
  my %state_of;

  #-------------------------------------------------------------------------------
  sub initialise {
    my $self = shift;

    my ($filename, $mode, $perm, $use_tmp) = @_;

    $use_tmp ||= 0;
    my $realfile = $filename;
    if ($use_tmp){
      $filename .= $TMP_EXT;
    }

    my $fd = IO::File->new($self->chrootDir . $filename, $mode, $perm);

    return unless defined $fd;

    my $ident = scalar($self);
    $filename_of{$ident} = $realfile;
    $fh_of{$ident}       = $fd;
    $mode_of{$ident}     = $mode;
    $perm_of{$ident}     = $perm;
    $write_of{$ident}    = 0;
    $read_of{$ident}     = 0;
    $opentime_of{$ident} = time();
    $use_temp_of{$ident} = $use_tmp;
    $state_of{$ident}    = 'open';

    return 1;
  }
  #-------------------------------------------------------------------------------
  sub err {
    my $self = shift;
    my $ident = scalar($self);

    return $err_of{$ident};
  }
  #-------------------------------------------------------------------------------
  sub close {
    my $self = shift;
    my $ident = scalar($self);
    my $ret = $fh_of{$ident}->close();
    unless ($ret){
      $err_of{$ident} = $!+0;
    }

    if ($use_temp_of{$ident}){
      $self->Rename( $filename_of{$ident} . $TMP_EXT, $filename_of{$ident} );
      $use_temp_of{$ident} = 0;
    }

    $state_of{$ident}    = 'closed';
    return $ret;
  }
  #-------------------------------------------------------------------------------
  sub getFilename {
    my $self = shift;
    my $ident = scalar($self);
    return $filename_of{$ident};
  }
  #-------------------------------------------------------------------------------
  sub getMode {
    my $self = shift;
    my $ident = scalar($self);
    return $mode_of{$ident};
  }
  #-------------------------------------------------------------------------------
  sub getPerm {
    my $self = shift;
    my $ident = scalar($self);
    return $perm_of{$ident};
  }
  #-------------------------------------------------------------------------------
  sub wroteBytes {
    my $self = shift;
    my $ident = scalar($self);
    my $size = shift;
    $write_of{$ident} += $size;
  }
  #-------------------------------------------------------------------------------
  sub readBytes {
    my $self = shift;
    my $ident = scalar($self);
    my $size = shift;
    $read_of{$ident} += $size;
  }
  #-------------------------------------------------------------------------------
  sub getWrittenBytes {
    my $self = shift;
    my $ident = scalar($self);
    return $write_of{$ident};
  }
  #-------------------------------------------------------------------------------
  sub getReadBytes {
    my $self = shift;
    my $ident = scalar($self);
    $read_of{$ident};
  }
  #-------------------------------------------------------------------------------
  sub getStats {
    my $self = shift;
    my $ident = scalar($self);
    my $stats = "Filename: $filename_of{$ident} ";
    my $dtime = (time() - $opentime_of{$ident}) || 1;
    if ($write_of{$ident} and $read_of{$ident}){
      ## reads and writes
      my $speed = int(($write_of{$ident} + $read_of{$ident}) / (1024 * $dtime));
      $stats .= "Received: $write_of{$ident} bytes Sent: $read_of{$ident} in $dtime seconds Speed: $speed K/s";
    }
    elsif ($write_of{$ident}){
      # File received
      my $speed = int($write_of{$ident} / (1024 * $dtime));
      $stats .= "Received: $write_of{$ident} bytes in $dtime seconds Speed: $speed K/s";
    }
    elsif ($read_of{$ident}){
      # File Sent
      my $speed = int($read_of{$ident} / (1024 * $dtime));
      $stats .= "Sent: $read_of{$ident} bytes in $dtime seconds Speed: $speed K/s";
    }
    else {
      $stats .= "No data sent or received";
    }
    return $stats;
  }
  #-------------------------------------------------------------------------------
  sub wasReceived {
    my $self = shift;
    my $ident = scalar($self);
    if ($write_of{$ident} and ! $read_of{$ident} and $self->Size( $filename_of{$ident} ) eq $write_of{$ident}){
      return 1;
    }
    return;
  }
  #-------------------------------------------------------------------------------
  sub wasSent {
    my $self = shift;
    my $ident = scalar($self);
    if ($read_of{$ident} and ! $write_of{$ident} and $self->Size( $filename_of{$ident} ) eq $read_of{$ident}){
      return 1;
    }
    return;
  }
  #-------------------------------------------------------------------------------
  sub getType {
    my $self = shift;
    return 'file';
  }
  #-------------------------------------------------------------------------------
  sub sysread {
    my $self = shift;
    my $ident = scalar($self);
    return $fh_of{$ident}->sysread( @_ );
  }
  #-------------------------------------------------------------------------------
  sub syswrite {
    my $self = shift;
    my $ident = scalar($self);
    return $fh_of{$ident}->syswrite( @_ );
  }
  #-------------------------------------------------------------------------------
  sub sysseek {
    my $self = shift;
    my $ident = scalar($self);
    return $fh_of{$ident}->sysseek( @_ );
  }
  #-------------------------------------------------------------------------------
  sub read {
    my $self = shift;
    my $ident = scalar($self);
    unless ( $self->callback ){
      Net::SFTP::SftpServer::logError "read method called outside from callback";
      return;
    }

    if ($state_of{$ident} ne 'open'){
      $fh_of{$ident}->open( $self->chrootDir . $filename_of{$ident}, '<' );
      $state_of{$ident} = 'open';
    }
    return $fh_of{$ident}->read( @_ );
  }
  #-------------------------------------------------------------------------------
  sub open {
    my $self = shift;
    my $ident = scalar($self);
    unless ( $self->callback ){
      Net::SFTP::SftpServer::logError "open method called outside from callback";
      return;
    }

    if ($state_of{$ident} ne 'open'){
      my $ret = $fh_of{$ident}->open( $self->chrootDir . $filename_of{$ident}, @_ );
      $state_of{$ident} = 'open';
      return $ret;
    }
  }
  #-------------------------------------------------------------------------------
  sub moveToProcessed {
    my $self = shift;
    my %arg = @_;

    my $ident = scalar $self;

    if ($arg{BREAKCHROOT}){
      return $self->moveToProcessedBREAKCHROOT( @_ );
    }

    $arg{dst}         ||= 'processed';
    $arg{dir_perms}   ||= 0770;

    unless ($self->Exists($filename_of{$ident})){
      Net::SFTP::SftpServer::logWarning "moveToProcessed: File $filename_of{$ident} does not exist";
      return;
    }


    if ($filename_of{$ident} =~ m!/$arg{dst}/!){
      # file is already in a processed directory
      return;
    }

    if ($arg{filename_condition}){
      return unless ($filename_of{$ident} =~ m/$arg{filename_condition}/ );
    }

    my $dir = dirname($filename_of{$ident});
    if (! $self->Exists( "$dir/processed" )){
      unless ($self->Mkdir( "$dir/processed", $arg{dir_perms} )){
        Net::SFTP::SftpServer::logWarning "moveToProcessed: failed to mkdir $dir/processed";
        return;
      }
    }
    elsif (! $self->IsDir( "$dir/processed") ){
      Net::SFTP::SftpServer::logWarning "moveToProcessed: $dir/processed exists but is not a directory";
      return;
    }

    my $name = fileparse($filename_of{$ident});
    if ( $self->Exists( "$dir/processed/$name" ) ){
      Net::SFTP::SftpServer::logWarning "moveToProcessed: cannot move $filename_of{$ident} - $dir/processed/$name already exists";
      return;
    }

    unless ($self->Rename( $filename_of{$ident}, "$dir/processed/$name" )){
      Net::SFTP::SftpServer::logWarning "moveToProcessed: failed to rename $filename_of{$ident} to $dir/processed/$name";
      return;
    }

    $filename_of{$ident} = "$dir/processed/$name";

    Net::SFTP::SftpServer::logGeneral "moveToProcessed: moved $filename_of{$ident} to $dir/processed/$name";
  }
  #-------------------------------------------------------------------------------
  sub moveToProcessedBREAKCHROOT {
    my $self = shift;
    my %arg = @_;

    my $ident = scalar $self;

    unless ( -d $arg{dst} and -w $arg{dst} ){
      Net::SFTP::SftpServer::logWarning "Cannot write to target directory $arg{dst}";
      return;
    }

    unless ($self->Exists($filename_of{$ident})){
      Net::SFTP::SftpServer::logWarning "moveToProcessed: File $filename_of{$ident} does not exist";
      return;
    }

    if ($arg{filename_condition}){
      return unless ($filename_of{$ident} =~ m/$arg{filename_condition}/ );
    }

    my $name = fileparse($filename_of{$ident});

    bless $self, 'Net::SFTP::SftpServer::FileChrootBroken';

    $self->renameBREADCHROOT( $arg{dst} . "/$name" );

    Net::SFTP::SftpServer::logGeneral "moveToProcessed: moved $filename_of{$ident} to $arg{dst}/$name";
  }
  #-------------------------------------------------------------------------------
  sub getFullFilenameBREAKCHROOT {
    my $self = shift;
    my $ident = scalar $self;

    my $chroot_dir = $self->chrootDir;

    bless $self, 'Net::SFTP::SftpServer::FileChrootBroken';

    return $chroot_dir . $filename_of{$ident}
  }
  #-------------------------------------------------------------------------------
  sub renameBREAKCHROOT {
    my $self = shift;
    my $ident = scalar $self;

    my $newname = shift;

    my $chroot_dir = $self->chrootDir;

    bless $self, 'Net::SFTP::SftpServer::FileChrootBroken';

    return rename $chroot_dir . $filename_of{$ident}, $newname;
  }
  #-------------------------------------------------------------------------------
  sub DESTROY {
    my $self = shift;
    my $ident = scalar($self);

    $fh_of{$ident}->close() if defined $fh_of{$ident} and $fh_of{$ident}->opened;
    delete $fh_of{$ident};
    delete $filename_of{$ident};
    delete $mode_of{$ident};
    delete $perm_of{$ident};
    delete $write_of{$ident};
    delete $read_of{$ident};
    delete $opentime_of{$ident};
    delete $use_temp_of{$ident};
    delete $err_of{$ident};
    delete $state_of{$ident};

    $self->SUPER::DESTROY()
  }
}
1;
#-----------------------------------------------------------------------------
#-----------------------------------------------------------------------------
#------------------------------------------------------------------------------
#------------------------------------------------------------------------------
#------------------------------------------------------------------------------
#------------------------------------------------------------------------------
package Net::SFTP::SftpServer::Dir;
use strict;
use warnings;

use IO::Dir;

use base qw( Net::SFTP::SftpServer::FS  );

{
  my %fd_of;
  my %path_of;
  my %dir_err_of;
  #-------------------------------------------------------------------------------
  sub initialise {
    my $self = shift;

    my ($path) = @_;

    my $fd = IO::Dir->new($self->chrootDir() . $path);

    return unless defined $fd;

    $path .= '/';
    $path =~ s!//$!/!; # make sure we have a trailing /
    my $ident = scalar($self);
    $path_of{$ident} = $path;
    $fd_of{$ident}   = $fd;

    return 1;
  }
  #-------------------------------------------------------------------------------
  sub err {
    my $self = shift;
    my $ident = scalar($self);

    return $dir_err_of{$ident};
  }
  #-------------------------------------------------------------------------------
  sub close {
    my $self = shift;
    my $ident = scalar($self);

    my $ret = $fd_of{$ident}->close();
    unless ($ret){
      $dir_err_of{$ident} = $!+0;
    }

    return $ret;
  }
  #-------------------------------------------------------------------------------
  sub getFilename {
    my $self = shift;
    my $ident = scalar($self);
    return "$path_of{$ident}";
  }
  #-------------------------------------------------------------------------------
  sub getPath {
    my $self = shift;
    my $ident = scalar($self);
    return $path_of{$ident};
  }
  #-------------------------------------------------------------------------------
  sub getType {
    my $self = shift;
    return 'dir';
  }
  #-------------------------------------------------------------------------------
  sub readdir {
    my $self = shift;
    my $ident = scalar $self;
    return $fd_of{$ident}->read();
  }
  #-------------------------------------------------------------------------------
  sub DESTROY {
    my $self = shift;
    my $ident = scalar($self);

    delete $fd_of{$ident};
    delete $path_of{$ident};
    delete $dir_err_of{$ident};

    $self->SUPER::DESTROY()
  }
}
1;
#-------------------------------------------------------------------------------
__END__