DirDB-FTP-0.01/0040755000175000017500000000000007757041333011762 5ustar daviddavidDirDB-FTP-0.01/README0100644000175000017500000000171507755045212012641 0ustar daviddavidDirDB/FTP version 0.01 ====================== The README is used to introduce the module and provide instructions on how to install the module, any machine dependencies it may have (for example C compilers and installed libraries) and any other information that should be provided before the module is installed. A README file is required for CPAN modules since CPAN extracts the README file from a module distribution so that people browsing the archive can use it get an idea of the modules uses. It is usually a good idea to provide version information here so that people can decide whether fixes for the module are worth downloading. INSTALLATION To install this module type the following: perl Makefile.PL make make test make install DEPENDENCIES This module requires these other modules and libraries: blah blah blah COPYRIGHT AND LICENCE Put the correct copyright and licence information here. Copyright (C) 2003 A. U. Thor blah blah blah DirDB-FTP-0.01/Makefile.PL0100644000175000017500000000077307755046351013743 0ustar daviddaviduse ExtUtils::MakeMaker; # See lib/ExtUtils/MakeMaker.pm for details of how to influence # the contents of the Makefile that is written. WriteMakefile( 'NAME' => 'DirDB::FTP', 'VERSION_FROM' => 'FTP.pm', # finds $VERSION 'PREREQ_PM' => {Net::FTP::blat => 0.02}, # e.g., Module::Name => 1.1 ($] >= 5.005 ? ## Add these new keywords supported since 5.005 (ABSTRACT_FROM => 'FTP.pm', # retrieve abstract from module AUTHOR => 'David Nicol ') : ()), ); DirDB-FTP-0.01/MANIFEST0100644000175000017500000000005307755045212013104 0ustar daviddavidFTP.pm Makefile.PL MANIFEST README test.pl DirDB-FTP-0.01/test.pl0100644000175000017500000000302407757040127013272 0ustar daviddavid# Before `make install' is performed this script should be runnable with # `make test'. After `make install' it should work as `perl test.pl' ######################### # change 'tests => 1' to 'tests => last_test_to_print'; use Test; BEGIN { plan tests => 14 }; use DirDB::FTP; ok(1); # If we made it this far, we're ok. ######################### # Insert your test code below, the Test module is use()ed here so read # its man page ( perldoc Test ) for help writing this test script. ok(my $ftp = new DirDB::FTP 'tipjar.com','blat','test0'); ok(tie my %dcty, DirDB::FTP => $ftp, "/DDtest$$"); ok($$,$dcty{pid}->{pad}->{foo} = $$); ok($$,$dcty{pid}->{pad}->{foo} ); ok(my $r = delete $dcty{pid} ); ok($$, $r->{pad}->{foo}); # print "\nCLEARING\n"; %dcty = (); ok(tie my %dct, DirDB::FTP => $ftp, "/"); ok(HASH => ref($dct{"DDtest$$"})); # print "\nDelete slice test\n"; @dcty{1..5} = qw{fee fi fo fum five}; # print "fi fo? ",delete( @dcty{2,3}),"\n"; ok("fi fo","@{[delete( @dcty{2,3})]}"); # print "fee fum five? ", (grep {defined $_} @dcty{1..5}),"\n"; ok( "fee fum five", "@{[grep {defined $_} @dcty{1..5}]}"); my $$x = "reference test\n"; # print $$x; eval { $dcty{reftest} = $x }; ok($@); my %x; $x{something}='else'; $dcty{X} = \%x; # should tie %x to dcty/X $x{fruit} = 'banana'; ok('banana',$dcty{X}->{fruit}); # print "complex delete test\n"; my $href = delete $dct{"DDtest$$"}; # print "href is $href\n"; # print "has keys @{[keys %$href]}\n"; # print "has values @{[values %$href]}\n"; ok('banana',$href->{X}->{fruit}); DirDB-FTP-0.01/FTP.pm0100644000175000017500000002033707757041330012750 0ustar daviddavidpackage DirDB::FTP; require 5.005_62; use strict; use warnings; use Carp; use Net::FTP; use Net::FTP::blat; our $VERSION = '0.01'; sub new{ # DirDB::FTP -> new ( $hostname, $user, $pass ); shift; # we don't need the package name my $f = Net::FTP->new( $_[0] , timeout => 300 ) or croak "cannot connect to $_[0]"; my $pl = 0+length $_[2]; $f->login($_[1], $_[2]) or croak "cannot login with username $_[1] and $pl char passwd"; $f->binary(); $f; }; sub TIEHASH { my ($self, $ftp, $rootpath) = @_; ref($ftp) eq 'Net::FTP' or croak <<'EOSYNTAX'; Syntax: tie my %hash, DirDB::FTP => $ftp_object [, "/some/directory"]; EOSYNTAX if(defined $rootpath){ $rootpath =~ s#/+$##; # lose trailing slash(es) if (length $rootpath){ $ftp->cwd($rootpath) or $ftp->mkdir($rootpath,'recurse') or croak "could not change to or create dir $rootpath: " . $ftp->message; }; }else{ $rootpath = $ftp->pwd(); }; bless [$ftp,"$rootpath/"], $self; }; sub TIEARRAY { confess "DirDB does not support arrays yet"; }; sub TIESCALAR { confess "DirDB does not support scalars yet -- try Tie::Slurp"; }; sub EXISTS { my ($ftp,$rootpath) = @{+shift}; my $key = shift; $key =~ s/^ / /; #escape leading space into two spaces $key eq '' and $key = ' EMPTY'; my $mdtm = $ftp->mdtm("$rootpath$key"); $ftp->message =~ m/no such/i and return 0; return 1; # my @mdtm = $ftp->ls("$rootpath$key"); # print "Debug: $mdtm\n"; defined $mdtm and return 1; $ftp->message =~ m/ not a plain file/ and return 1; 0; }; sub FETCH { my $ref = shift; my ($ftp,$rootpath) = @{$ref}; my $key = shift; $key =~ s/^ / /; #escape leading space into two spaces $key eq '' and $key = ' EMPTY'; # FIXME # Our goal here is to mimic the DirDB semantics, using # commands defined in Net::FTP, plus slurp and blat. # We are allowing some error message reading but want # to keep that down to as little as possible. sleep 1 while $ftp->ls( "$rootpath LOCK$key"); my $result = $ftp->slurp( "$rootpath$key" ); # print "DEBUG: ",$ftp->message(),"\n"; defined $result and return $result; $ftp->message =~ /no such/i and return undef; # assume a directory, ... tie my %newhash, ref($ref),$ftp,"$rootpath$key" or croak "Could not fetch [$rootpath$key]: ".$ftp->message; return \%newhash; }; { my %CircleTracker; sub STORE { my ($ref , $key, $value) = @_; my ($ftp,$rootpath) = @{$ref}; my $rnd = rand(10000).{}.$$; $rnd =~ tr/a-zA-Z0-9//cd; $key =~ s/^ / /; #escape leading space into two spaces $key eq '' and $key = ' EMPTY'; my $refvalue = ref $value; if ($refvalue){ if ( $CircleTracker{$value}++ ){ croak "$ref version $VERSION cannot store circular structures\n"; }; $refvalue eq 'HASH' or croak "$ref version $VERSION only stores references to HASH, not $refvalue\n"; if (tied (%$value)){ # recursive copy tie my %tmp, ref($ref), $ftp, "$rootpath TMP$rnd" or die "tie failed"; eval{ # %tmp = %$value my ($k,$v); while(($k,$v) = each %$value){ $tmp{$k}=$v; }; }; # print "$rootpath TMP$rnd should now contain @{[%$value]}\n"; if($@){ my $message = $@; eval {$ftp->rmdir( "$rootpath TMP$rnd", 1)}; croak "trouble writing [$value] to [$rootpath$key]: $message"; }; # print "lock (tied)"; sleep 1 while !$ftp->mkdir( "$rootpath LOCK$key"); { no warnings; $ftp->rename( "$rootpath$key", "$rootpath GARBAGE$rnd"); }; $ftp->rename( "$rootpath TMP$rnd", "$rootpath$key"); }else{ # cache, bless, restore my @cache = %$value; %$value = (); # print "lock (untied)"; while( !$ftp->mkdir( "$rootpath LOCK$key")){ # print "lock conflivt: $!"; sleep 1; }; { no warnings; $ftp->rename( "$rootpath$key","$rootpath GARBAGE$rnd"); }; tie %$value, ref($ref), $ftp, "$rootpath$key" or warn "tie to [$rootpath$key] failed: ".$ftp->message; # print "assignment"; %$value = @cache; }; $ftp->rmdir( "$rootpath LOCK$key"); delete $CircleTracker{$value}; # print "GC"; eval {$ftp->rmdir( "$rootpath GARBAGE$rnd",'recurse')}; if($@){ croak "GC problem: $@"; }; return; }; # store a scalar using write-to-temp-and-rename $ftp->blat($value,"$rootpath TMP$rnd") or croak $ftp->message; $ftp->rename( "$rootpath TMP$rnd" , "$rootpath$key") or croak " could not rename temp file to [$rootpath$key]: ".$ftp->message; }; }; sub DELETE { my ($ref , $key) = @_; my ($ftp,$rootpath) = @{$ref}; my $retval = undef; if(defined wantarray){ $retval = FETCH( $ref,$key ); if (ref $retval) { my %hash; my @keys = keys %$retval; my $k; foreach $k (@keys) { $hash{$k} = delete $retval->{$k}; }; $retval = \%hash; }; }; $key =~ s/^ / /; #escape leading space into two spaces $key eq '' and $key = ' EMPTY'; # -e "$rootpath$key" or return undef; $ftp->delete( "$rootpath$key" ) or $ftp->rmdir( "$rootpath$key", 'recurse' ); return $retval; }; sub CLEAR{ my ($ref , $key, $value) = @_; my ($ftp,$rootpath) = @{$ref}; # maybe we can delete the whole thing? # we will check to make sure this succeeds because we # want to support clearing a whole directory that we # have been issued by an administrator $ftp->rmdir($rootpath, 'recurse') and $ftp->mkdir($rootpath) and return; my @dirents = $ftp->ls($rootpath); for my $ent (@dirents){ $ftp->delete("$rootpath$ent") or $ftp->rmdir("$rootpath$ent",1) }; }; { my %IteratorListings; sub FIRSTKEY { my ($ref , $key, $value) = @_; my ($ftp,$rootpath) = @{$ref}; # opendir FSDBFH, $path or croak "opendir $path: $!"; # $IteratorListings{$ref} = [ grep {!($_ =~ /^\.\.?\Z/)} readdir FSDBFH ]; $IteratorListings{$ref} = [ $ftp->ls ]; $ref->NEXTKEY; }; sub NEXTKEY{ my $ref = shift; my ($ftp,$rootpath) = @{$ref}; #print "next key in path <$$ref> will be shifted from <@{$IteratorListings{$ref}}>\n"; @{$IteratorListings{$ref}} or return undef; my $key = shift @{$IteratorListings{$ref}}; if ($key =~ s/^ //){ if ($key = m/^ /){ # we have unescaped a leading space. }elsif ($key eq 'EMPTY'){ $key = '' #}elsif($key eq 'REF'){ # return $ref->NEXTKEY(); # next #}elsif($key =~ m/^ARRAY){ # return $ref->NEXTKEY(); # next }else{ # per-container metadata does not # appear in iterations through data. return $ref->NEXTKEY(); # next } }; wantarray or return $key; return @{[$key, $ref->FETCH($key)]}; }; sub DESTROY{ no warnings; delete $IteratorListings{$_[0]}; }; }; 1; __END__ =head1 NAME DirDB::FTP - Perl extension to use a remote directory as a database =head1 SYNOPSIS use DirDB::FTP; my $ftp = DirDB::FTP->new('some.host.name',$username,$password); tie my %entries, DirDB::FTP, $ftp, => "/blog_entries"; $entries{'entry for '.localtime} = $entry_text; =head1 DESCRIPTION DirDB::FTP is a package that lets you access a DirDB hash on a remote machine, through the FTP server. The semantics of DirDB (version 0.06) are followed, including directory locking and recursive memory loading on directory deletion. Net::FTP is used for the connection, including the Net::FTP::blat extensions. Most actions can be done with ftp method return values, but differentiating between directories and non=existent files is done by parsing the C for the phrase 'no such file' so if you are using DirDB::FTP against a FTP server that issues a different errore message when there is no such file, you will have to edit your copy of the module. The underlying object is an array containing the Net::FTP connection object and the absolute path to the directory, modulo any chrooting the FTP server might do based on the provided credentials, of course. Keys are names within the directory, values are the contents of the files. A leading space is used as an escape character, the empty string as a key becomes ' EMPTY' just like in DirDB. =head2 RISKS "mkdir locking" is used to protect incomplete directories from being accessed while they are being written. It is conceivable that your program might catch a signal and die while inside a critical section. =head2 EXPORT None by default. =head1 AUTHOR David Nicol, davidnicol@cpan.org =head1 LICENSE GPL =head1 SEE ALSO L L GPL =cut