require
5.005;
$VERSION
=
'0.03'
;
sub
new{
shift
;
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
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/^ / /;
$key
eq
''
and
$key
=
' EMPTY'
;
my
$mdtm
=
$ftp
->mdtm(
"$rootpath$key"
);
$ftp
->message =~ m/
no
such/i and
return
0;
return
1;
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/^ / /;
$key
eq
''
and
$key
=
' EMPTY'
;
sleep
1
while
$ftp
->ls(
"$rootpath LOCK$key"
);
my
$result
=
$ftp
->slurp(
"$rootpath$key"
);
defined
$result
and
return
$result
;
$ftp
->message =~ /
no
such/i and
return
undef
;
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/^ / /;
$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
)){
tie
my
%tmp
,
ref
(
$ref
),
$ftp
,
"$rootpath TMP$rnd"
or
die
"tie failed"
;
eval
{
my
(
$k
,
$v
);
while
((
$k
,
$v
) =
each
%$value
){
$tmp
{
$k
}=
$v
;
};
};
if
($@){
my
$message
= $@;
eval
{
$ftp
->
rmdir
(
"$rootpath TMP$rnd"
, 1)};
croak
"trouble writing [$value] to [$rootpath$key]: $message"
;
};
sleep
1
while
!
$ftp
->
mkdir
(
"$rootpath LOCK$key"
);
{
$ftp
->
rename
(
"$rootpath$key"
,
"$rootpath GARBAGE$rnd"
);
};
$ftp
->
rename
(
"$rootpath TMP$rnd"
,
"$rootpath$key"
);
}
else
{
my
@cache
=
%$value
;
%$value
= ();
while
( !
$ftp
->
mkdir
(
"$rootpath LOCK$key"
)){
sleep
1;
};
{
$ftp
->
rename
(
"$rootpath$key"
,
"$rootpath GARBAGE$rnd"
);
};
tie
%$value
,
ref
(
$ref
),
$ftp
,
"$rootpath$key"
or
warn
"tie to [$rootpath$key] failed: "
.
$ftp
->message;
%$value
=
@cache
;
};
$ftp
->
rmdir
(
"$rootpath LOCK$key"
);
delete
$CircleTracker
{
$value
};
eval
{
$ftp
->
rmdir
(
"$rootpath GARBAGE$rnd"
,
'recurse'
)};
if
($@){
croak
"GC problem: $@"
;
};
return
;
};
$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/^ / /;
$key
eq
''
and
$key
=
' EMPTY'
;
$ftp
->
delete
(
"$rootpath$key"
) or
$ftp
->
rmdir
(
"$rootpath$key"
,
'recurse'
);
return
$retval
;
};
sub
CLEAR{
my
(
$ref
,
$key
,
$value
) =
@_
;
my
(
$ftp
,
$rootpath
) = @{
$ref
};
$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
};
$IteratorListings
{
$ref
} = [
$ftp
->ls ];
$ref
->NEXTKEY;
};
sub
NEXTKEY{
my
$ref
=
shift
;
my
(
$ftp
,
$rootpath
) = @{
$ref
};
@{
$IteratorListings
{
$ref
}} or
return
undef
;
my
$key
=
shift
@{
$IteratorListings
{
$ref
}};
if
(
$key
=~ s/^ //){
if
(
$key
= m/^ /){
}
elsif
(
$key
eq
'EMPTY'
){
$key
=
''
}
else
{
return
$ref
->NEXTKEY();
}
};
wantarray
or
return
$key
;
return
@{[
$key
,
$ref
->FETCH(
$key
)]};
};
sub
DESTROY{
delete
$IteratorListings
{
$_
[0]};
};
};
1;