comment on

Background

As part of a content management tool (work) I am presenting a virtual FTP interface to the MySQL database so that content production can be performed via DreamWeaver and contribute.

I've had to implement a subclass of IO::Scalar that flushes the contents to the database when the handle is closed and call this from my new personalities. (If there is a better way please share :) ).

This is a working (for me) implementation that I thought I would share. There is still work to do but its functional :). I would appreciate feedback on this and I'll post improvements as people suggest them. TTFN!

The Server personality

package Project::Net::FTP::Server;

use strict;

use DBI;

use Net::FTPServer;
use Project::Net::FTP::FileHandle;
use Project::Net::FTP::DirHandle;

use vars qw($VERSION);
$VERSION = '0.1 ';

use vars qw(@ISA);
@ISA = qw(Net::FTPServer);

# Cached statement handles.
use vars qw($sth1 $sth2 $sth3);

# This is called before configuration.

sub pre_configuration_hook
{
    my $self = shift;

    $self->{version_string} .= " Project::Net::FTP/$VERSION";

    # Custom SITE commands.
    $self->{site_command_table}{USAGE} = \&_SITE_USAGE_command;
}

# This is called just after accepting a new connection. We connect
# to the database here.

sub post_accept_hook
{
    my $self = shift;

    # Connect to the database.
    my $dbh = DBI->connect ("dbi:mysql(RaiseError=>1,AutoCommit=>1):db
+name=TEST",
                "username", "password")
      or die "cannot connect to database: ftp: $!";

    # Store the database handle.
    $self->{fs_dbh} = $dbh;
}

# This is called after executing every command. It commits the transac
+tion
# into the database.

sub post_command_hook
{
    my $self = shift;
}

# Perform login against the database.

sub authentication_hook
{
    my $self = shift;
    my $user = shift;
    my $pass = shift;
    my $user_is_anon = shift;

    # Disallow anonymous access.
    return -1 if $user_is_anon;

    # Verify access against the database.
    my $sql = "select password from USERS where username = ?";
    $sth1 ||= $self->{fs_dbh}->prepare ($sql);
    $sth1->execute ($user);

    my $row = $sth1->fetch or return -1; # No such user.

    # Check password.
    my $hashed_pass = $row->[0];
    return -1 unless crypt ($pass, $hashed_pass) eq $hashed_pass;

    # Successful login.
    return 0;
}

# Called just after user C<$user> has successfully logged in.

sub user_login_hook
{
    # Do nothing for now, but in future it would be a good
    # idea to change uid or chroot to a safe place.
}

#  Return an instance of Net::FTPServer::DBeg1::DirHandle
# corresponding to the root directory.

sub root_directory_hook
{
    my $self = shift;

    return new Project::Net::FTP::DirHandle ($self);
}

# The SITE USAGE command.

sub _SITE_USAGE_command
{
    my $self = shift;
    my $cmd = shift;
    my $rest = shift;

    # Count the number of files and directories used.
    my $sql = "select count(ID) from FILES";
    $sth2 ||= $self->{fs_dbh}->prepare ($sql);
    $sth2->execute;

    my $row = $sth2->fetch or die "no rows returned from count";

    my $nr_files = $row->[0];

    $sql = "select count(ID) from DIRECTORIES";
    $sth3 ||= $self->{fs_dbh}->prepare ($sql);
    $sth3->execute;

    $row = $sth3->fetch or die "no rows returned from count";

    my $nr_dirs = $row->[0];

    $self->reply (200,
          "There are $nr_files files and $nr_dirs directories.");
}

1;

__END__
[download]

The DirHandle personality

package Project::Net::FTP::DirHandle;

use strict;

use vars qw($VERSION);
$VERSION = '0.1';

use DBI;
use Carp qw(confess croak);

use Net::FTPServer::DirHandle;
use Project::IO::Blob;
use File::Temp qw/ :POSIX /;

use vars qw(@ISA);

@ISA = qw(Net::FTPServer::DirHandle);

# Cached statement handles.
use vars qw($sth1 $sth2 $sth3 $sth4 $sth5 $sth6 $sth7 $sth8 $sth9 $sth
+10 $sth11 $sth12 $sth13 $sth14 $sth15 $sth16 $sth17 $sth18 $sth19 $st
+h20);

# Return a new directory handle.

sub new
{
    my $class = shift;
    my $ftps = shift;        # FTP server object.
    my $pathname = shift || "/"; # (only used in internal calls)
    my $dir_id = shift;        # (only used in internal calls)

    # Create object.
    my $self = Net::FTPServer::DirHandle->new ($ftps, $pathname);
    bless $self, $class;

    if ($dir_id)
    {
        $self->{fs_dir_id} = $dir_id;
    }
    else
    {
        # Find the root directory ID.
        my $sql = "select ID from DIRECTORIES where parent_ID = 0";
        $sth6 ||= $self->{ftps}{fs_dbh}->prepare ($sql);
        $sth6->execute;

        my $row = $sth6->fetch
            or die "no root directory in database (has the database be
+en populated?): $!";

        $self->{fs_dir_id} = $row->[0];
    }
    return $self;
}

# Return a subdirectory handle or a file handle within this directory.

sub get
{
    my $self = shift;
    my $filename = shift;

    # None of these cases should ever happen.
    confess "no filename" unless defined($filename) && length($filenam
+e);
    confess "slash filename" if $filename =~ /\//;
    confess ".. filename"    if $filename eq "..";
    confess ". filename"     if $filename eq ".";

    # Search for the file first, since files are more common than dirs
+.
    my $sql = "select ID, data from FILES where directory_ID = ? and n
+ame = ?";
    $sth1 ||= $self->{ftps}{fs_dbh}->prepare ($sql);
    $sth1->execute (int ($self->{fs_dir_id}), $filename);

    my $row = $sth1->fetch;

    if ($row)
    {
        # Found a file.
        return Project::Net::FTP::FileHandle->new(
            $self->{ftps},
            $self->pathname . $filename,
            $self->{fs_dir_id},
            $row->[0], $row->[1],
            $row->[2]
        );
    }

    # Search for a directory.
    $sql = "select ID from DIRECTORIES where parent_ID = ? and name = 
+?";
    $sth2 ||= $self->{ftps}{fs_dbh}->prepare ($sql);
    $sth2->execute (int ($self->{fs_dir_id}), $filename);

    $row = $sth2->fetch;

    if ($row)
    {
        # Found a directory.
        return Project::Net::FTP::DirHandle->new(
            $self->{ftps},
            $self->pathname . $filename . "/",
            $row->[0]
        );
    }

    # Not found.
    return undef;
}

# Get parent of current directory.

sub parent
{
    my $self = shift;

    return $self if $self->is_root;

    # Get a new directory handle.
    my $dirh = $self->SUPER::parent;

    # Find directory ID of the parent directory.
    my $sql = "select parent_ID from DIRECTORIES where ID = ?";
    $sth3 ||= $self->{ftps}{fs_dbh}->prepare ($sql);
    $sth3->execute (int ($self->{fs_dir_id}));

    my $row = $sth3->fetch
        or die "directory ID ", $self->{fs_dir_id}, " missing";

    $dirh->{fs_dir_id} = $row->[0];

    return bless $dirh, ref $self;
}

sub list
{
    my $self = shift;
    my $wildcard = shift;

    # Convert wildcard into a SQL LIKE pattern.
    if ($wildcard)
    {
        if ($wildcard ne "*")
        {
            $wildcard = $self->{ftps}->wildcard_to_sql_like ($wildcard
+);
        }
        else
        {
            # If wildcard is "*" then it defaults to undefined (for sp
+eed).
            $wildcard = undef;
        }
    }

    # Get subdirectories.
    my ($sql, $sth);
    if ($wildcard)
    {
        $sql = "select ID, name from directories
                 where parent_ID = ? and name like ?";
        $sth15 ||= $self->{ftps}{fs_dbh}->prepare ($sql);
        $sth15->execute (int ($self->{fs_dir_id}), $wildcard);
        $sth = $sth15;
    }
    else
    {
        $sql = "select ID, name from DIRECTORIES where parent_ID = ?";
        $sth4 ||= $self->{ftps}{fs_dbh}->prepare ($sql);
        $sth4->execute (int ($self->{fs_dir_id}));
        $sth = $sth4;
    }

    my @result = ();
    my $username = substr $self->{ftps}{user}, 0, 8;

    while (my $row = $sth->fetch)
    {
        my $dirh = Project::Net::FTP::DirHandle->new(
            $self->{ftps},
            $self->pathname . $row->[1] . "/",
            $row->[0]
        );

        push @result, [ $row->[1], $dirh ];
    }

    # Get files.
    if ($wildcard)
    {
        $sql = "select ID, name, data from FILES where directory_ID = 
+? and name like ?";
        $sth16 ||= $self->{ftps}{fs_dbh}->prepare ($sql);
        $sth16->execute (int ($self->{fs_dir_id}), $wildcard);
        $sth = $sth16;
    }
    else
    {
        $sql = "select ID, name, data from FILES where directory_ID = 
+?";
        $sth5 ||= $self->{ftps}{fs_dbh}->prepare ($sql);
        $sth5->execute (int ($self->{fs_dir_id}));
        $sth = $sth5;
    }

    while (my $row = $sth->fetch)
    {
        my $fileh = Project::Net::FTP::FileHandle->new(
            $self->{ftps},
            $self->pathname . $row->[1],
            $self->{fs_dir_id},
            $row->[0],
            $row->[2]
        );

        push @result, [ $row->[1], $fileh ];
    }

    return \@result;
}

sub list_status
{
    my $self = shift;
    my $wildcard = shift;

    # Convert wildcard into a SQL LIKE pattern.
    if ($wildcard)
    {
        if ($wildcard ne "*")
        {
            $wildcard = $self->{ftps}->wildcard_to_sql_like ($wildcard
+);
        }
        else
        {
            # If wildcard is "*" then it defaults to undefined (for sp
+eed).
            $wildcard = undef;
        }
    }

    # Get subdirectories.
    my ($sql, $sth);
    if ($wildcard)
    {
        $sql = "select ID, name from DIRECTORIES where parent_ID = ? a
+nd name like ?";
        $sth18 ||= $self->{ftps}{fs_dbh}->prepare ($sql);
        $sth18->execute (int ($self->{fs_dir_id}), $wildcard);
        $sth = $sth18;
    }
    else
    {
        $sql = "select ID, name from DIRECTORIES where parent_ID = ?";
        $sth17 ||= $self->{ftps}{fs_dbh}->prepare ($sql);
        $sth17->execute (int ($self->{fs_dir_id}));
        $sth = $sth17;
    }

    my @result = ();
    my $username = substr $self->{ftps}{user}, 0, 8;

    while (my $row = $sth->fetch)
    {
        my $dirh = Project::Net::FTP::DirHandle->new(
            $self->{ftps},
            $self->pathname . $row->[1] . "/",
            $row->[0]
        );

        my @status = $dirh->status;
        push @result, [ $row->[1], $dirh, \@status ];
    }

    # Get files.
    if ($wildcard)
    {
        $sql = "select ID, name, data from FILES where directory_ID = 
+? and name like ?";
        $sth20 ||= $self->{ftps}{fs_dbh}->prepare ($sql);
        $sth20->execute (int ($self->{fs_dir_id}), $wildcard);
        $sth = $sth20;
    }
    else
    {
        $sql = "select ID, name, data from FILES where directory_ID = 
+?";
        $sth19 ||= $self->{ftps}{fs_dbh}->prepare ($sql);
        $sth19->execute (int ($self->{fs_dir_id}));
        $sth = $sth19;
    }

    while (my $row = $sth->fetch)
    {
        my $fileh = Project::Net::FTP::FileHandle->new(
            $self->{ftps},
            $self->pathname . $row->[1],
            $self->{fs_dir_id},
            $row->[0],
            $row->[2]
        );

        my @status = $fileh->status;
        push @result, [ $row->[1], $fileh, \@status ];
    }

    return \@result;
}

# Return the status of this directory.

sub status
{
    my $self = shift;
    my $username = substr $self->{ftps}{user}, 0, 8;

    return ( 'd', 0755, 1, $username, "users", 1024, 0 );
}

# Move a directory to elsewhere.

sub move
{
    my $self = shift;
    my $dirh = shift;
    my $filename = shift;

    # You can't move the root directory. That would be bad :-)
    return -1 if $self->is_root;

    my $sql = "update DIRECTORIES set parent_ID = ?, name = ? where ID
+ = ?";
    $sth12 ||= $self->{ftps}{fs_dbh}->prepare ($sql);
    $sth12->execute (int ($dirh->{fs_dir_id}), $filename, int ($self->
+{fs_dir_id}));

    return 0;
}

# We should only be able to delete a directory if the directory
# is empty. We could use referential constraints. However, I'm using 
# MySQL.

sub delete
{
    my $self = shift;

    # Check referential constraints.
    my $sql = "select count(ID) from FILES where directory_ID = ?";
    $sth7 ||= $self->{ftps}{fs_dbh}->prepare ($sql);
    $sth7->execute (int ($self->{fs_dir_id}));

    my $row = $sth7->fetch or die "no rows returned from count";

    my $nr_files = $row->[0];

    $sql = "select count(ID) from DIRECTORIES where parent_ID = ?";
    $sth8 ||= $self->{ftps}{fs_dbh}->prepare ($sql);
    $sth8->execute (int ($self->{fs_dir_id}));

    $row = $sth8->fetch or die "no rows returned from count";

    my $nr_dirs = $row->[0];

    return -1 if $nr_files > 0 || $nr_dirs > 0;

    # Delete the directory.
    $sql = "delete from DIRECTORIES where ID = ?";
    $sth9 ||= $self->{ftps}{fs_dbh}->prepare ($sql);
    $sth9->execute (int ($self->{fs_dir_id}));

    return 0;
}

# Create a subdirectory.

sub mkdir
{
    my $self = shift;
    my $dirname = shift;

    my $sql = "insert into DIRECTORIES (parent_ID, name) values (?, ?)
+";
    $sth10 ||= $self->{ftps}{fs_dbh}->prepare ($sql);
    $sth10->execute (int ($self->{fs_dir_id}), $dirname);

    return 0;
}

# Open or create a file in this directory.

sub open
{
    my $self = shift;
    my $filename = shift;
    my $mode = shift;

    if($mode eq 'r')
    {
        # Read an existing file
        my $sql = 'select data,ID from FILES where directory_ID = ? an
+d name =?';
        $sth11 ||= $self->{ftps}{fs_dbh}->prepare($sql);
        $sth11->execute(int ($self->{fs_dir_id}), $filename);

        # Fetch the data or return
        my $row = $sth11->fetch or return undef;

        return Project::IO::Blob->new({
            mode    =>    'r', 
            dbh    =>    $self->{ftps}{fs_dbh}, 
            data    =>    \$row->[0],
            ID        =>    $row->[1]
        });
    }
    elsif($mode eq 'w')
    {
        # Create a file entry (this also covers an overwrite apparentl
+y)
        my $dbh = $self->{ftps}{fs_dbh};

        my $check = "select data, ID from FILES where directory_ID = ?
+ and name = ?";
        $sth13 ||= $self->{ftps}{fs_dbh}->prepare ($check);
        $sth13->execute (int ($self->{fs_dir_id}), $filename);

        my $row = $sth13->fetch;
        if($row)
        {
            return Project::IO::Blob->new({
                mode    =>    'a', 
                dbh    =>    $self->{ftps}{fs_dbh}, 
                data    =>    undef,
                ID        =>    $row->[1]
            });
        }

        my $sql = "insert into FILES (name, directory_ID) values (?, ?
+)";
        $sth14 ||= $dbh->prepare ($sql);
        $sth14->execute ($filename, int ($self->{fs_dir_id}));

        # Return an IO::Blob. This allows us to write to an internal s
+calar
        # flush it to the database on file closure.
        return Project::IO::Blob->new({
            mode    =>    'w', 
            dbh    =>    $self->{ftps}{fs_dbh},
            data    =>    undef,
            ID        =>    $dbh->{'mysql_insertid'}
        });
    }
    elsif($mode eq 'a')
    {
        # Append to an existing file - read the data from the blob, sa
+ve to
        # a scalar, return an IO::* handle on that, every write will
        # save to the scalar and the close saves back to the db.
        my $sql = "select data, ID from FILES where directory_ID = ? a
+nd name = ?";
        $sth13 ||= $self->{ftps}{fs_dbh}->prepare ($sql);
        $sth13->execute (int ($self->{fs_dir_id}), $filename);

        my $row = $sth13->fetch or return undef;

        return Project::IO::Blob->new({
            mode    =>    'a', 
            dbh    =>    $self->{ftps}{fs_dbh}, 
            data    =>    \$row->[0],
            ID        =>    $row->[1]
        });
    }
    else
    {
        croak "unknown file mode: $mode; use 'r', 'w' or 'a' instead";
    }
    return;

  }

1;

__END__
[download]

The FileHandle personality

package Project::Net::FTP::FileHandle;

use strict;

use vars qw($VERSION);
$VERSION = '0.1';

use Carp qw(croak confess);

use Net::FTPServer::FileHandle;
use Project::Net::FTP::DirHandle;
use Project::IO::Blob;

use vars qw(@ISA);
@ISA = qw(Net::FTPServer::FileHandle);

use vars qw($sth1 $sth2 $sth3 $sth4 $sth13);

# Return a new file handle.

sub new
{
    my $class = shift;
    my $ftps = shift;
    my $pathname = shift;
    my $dir_id = shift;
    my $file_id = shift;
    my $content = shift;

    # Create object.
    my $self = Net::FTPServer::FileHandle->new ($ftps, $pathname);

    $self->{fs_dir_id} = $dir_id;
    $self->{fs_file_id} = $file_id;
    $self->{fs_content} = $content;

    return bless $self, $class;
}

# Return the directory handle for this file.

sub dir
{
    my $self = shift;

    return Project::Net::FTP::DirHandle->new (
        $self->{ftps},
        $self->dirname,
        $self->{fs_dir_id}
    );
}

# Open the file handle.

sub open
{
    my $self = shift;
    my $mode = shift;

    if ($mode eq "r")        # Open file for reading.
    {
        return Project::IO::Blob->new({
            mode    =>    'r', 
            dbh    =>    $self->{ftps}{fs_dbh}, 
            data    =>    \$self->{fs_content},
            ID        =>    undef
        });
    }
    elsif ($mode eq "w")    # Create/overwrite the file.
    {
        # Remove the existing large object and create a new one.
        my $dbh = $self->{ftps}{fs_dbh};

        my $sql = "update FILES set data = null where ID = ?";
        $sth4 ||= $dbh->prepare ($sql);
        $sth4->execute (int ($self->{fs_file_id}));

        return Project::IO::Blob->new({
            mode    =>    'w', 
            dbh    =>    $self->{ftps}{fs_dbh}, 
            data    =>    \$self->{fs_content}, 
            ID        =>    $self->{fs_file_id}
        });
    }
    elsif ($mode eq "a")    # Append to the file.
    {
        return Project::IO::Blob->new({
            mode    =>    'w', 
            dbh    =>    $self->{ftps}{fs_dbh}, 
            data    =>    \$self->{fs_content}, 
            ID        =>    $self->{fs_file_id}
        });
    }
    else
    {
        croak "unknown file mode: $mode; use 'r', 'w' or 'a' instead";
    }
}

sub status
{
    my $self = shift;
    my $dbh = $self->{ftps}{fs_dbh};
    my $username = substr $self->{ftps}{user}, 0, 8;

    my $blob_fd;
    my $sql = "select length(data) from FILES where ID = ?";
    $sth13 ||= $self->{ftps}{fs_dbh}->prepare ($sql);
    $sth13->execute (int ($self->{fs_file_id}));

    my $row = $sth13->fetch or return undef;
    return ( 'f', 0644, 1, $username, "users", $row->[0], 0 );
}

# Move a file to elsewhere.

sub move
{
    my $self = shift;
    my $dirh = shift;
    my $filename = shift;

    my $sql = "update FILES set directory_ID = ?, name = ? where ID = 
+?";
    $sth2 ||= $self->{ftps}{fs_dbh}->prepare ($sql);
    $sth2->execute (int ($dirh->{fs_dir_id}), $filename, int ($self->{
+fs_file_id}));

    return 0;
}

# Delete a file.

sub delete
{
    my $self = shift;

    my $sql = "delete from FILES where ID = ?";
    $sth1 ||= $self->{ftps}{fs_dbh}->prepare ($sql);
    $sth1->execute (int ($self->{fs_file_id}));

    return 0;
}

1;

__END__
[download]

The Blob handle

package Project::IO::Blob;

use strict;
use IO::Scalar;

use vars qw($VERSION $sth @ISA);
$VERSION = '0.1';

use DBI;
use Carp qw(confess croak);

@ISA  = qw(IO::Scalar);

sub new
{
    my $class = shift;
    my $opts = shift;
    my $mode = $opts->{'mode'};
    my $dbh = $opts->{'dbh'};
    my $data = $opts->{'data'};
    my $ID = $opts->{'ID'};

    # Bless you my child
    my $self = IO::Scalar->new ($data);
    bless $self, $class;


    *$self->{'io_blob_mode'} = $mode;
    *$self->{'io_blob_dbh'} = $dbh;
    *$self->{'io_blob_ID'}    =    $ID;

    return $self;
}

sub close
{
    my $self = shift;

    # Flush to db
    if (*$self->{'io_blob_dbh'} && defined(*$self->{'io_blob_ID'}))
    {
        my $sql = "update FILES set data = ? where ID = ?";
        $sth ||= *$self->{'io_blob_dbh'}->prepare ($sql);
        $sth->execute (${$self->sref}, *$self->{'io_blob_ID'});

        delete *$self->{'io_blob_dbh'};
    }

    return 1;
}

1;

__END__
[download]

In reply to Net::FTPServer MySQL Port by simon.proctor

Posts are HTML formatted. Put <p> </p> tags around your paragraphs. Put <code> </code> tags around your code and data!

Titles consisting of a single word are discouraged, and in most cases are disallowed outright.

Read Where should I post X? if you're not absolutely sure you're posting in the right place.

Please read these before you post! —

Posts may use any of the Perl Monks Approved HTML tags:

a, abbr, b, big, blockquote, br, caption, center, col, colgroup, dd, del, details, div, dl, dt, em, font, h1, h2, h3, h4, h5, h6, hr, i, ins, li, ol, p, pre, readmore, small, span, spoiler, strike, strong, sub, summary, sup, table, tbody, td, tfoot, th, thead, tr, tt, u, ul, wbr

You may need to use entities for some characters, as follows. (Exception: Within code tags, you can put the characters literally.)

	For:		Use:
	&		`&`
	<		`<`
	>		`>`
	[		`[`
	]		`]`

Link using PerlMonks shortcuts! What shortcuts can I use for linking?

See Writeup Formatting Tips and other pages linked from there for more info.