TreeDB.pm

package TreeDB;

use strict;

my $debug = 1;

use File::Find;
use Tool;
use Jcode;

# File::Find用
use vars qw/*name *dir *prune/;
*name   = *File::Find::name;
*dir    = *File::Find::dir;
*prune  = *File::Find::prune;

# dirとかキーにすると壊れるよ
# STOREのmkdirのエラーチェック

# Constructor
sub new {
    return shift->TIEHASH(@_);
}

# tying
sub TIEHASH {
    my ($class, $dbname) = @_;
    my $self = {
        dir => $dbname,
        keys => [],
    };
    if (not -d $self->{dir}) {
        if (not mkdir($self->{dir}, 0777)) {
            Tool::error("mkdir ".$self->{dir}.") fail\n");
            return undef;
        }
    }
    return bless($self, $class);
}

# Store
sub STORE {
    my ($self, $key, $val) = @_;
    my $file = $self->encode($key);

	# ディレクトリ作成
	(my $dir = $file) =~ s#[^/]*$##;
	system("mkdir -p $dir");

    open(FILE,"> $file") or Tool::error( "error on $file creation.");
	flock(FILE, 2);
	binmode(FILE);
	print FILE $val;
	close(FILE);

	$val;
}

# Fetch
sub FETCH {
    my ($self, $key) = @_;
    my $file = $self->encode($key);
    open(FILE, $file) or return undef;
	my $val = join("", <FILE>);
	close(FILE);
	Jcode::convert(\$val, 'euc');
	$val;
}

# Exists
sub EXISTS {
    my ($self, $key) = @_;
    my $file = $self->encode($key);
    -e ($file);
}

# Delete
sub DELETE {
    my ($self, $key) = @_;
    my $file = $self->encode($key);
    unlink $file;
}

sub FIRSTKEY {
    my ($self) = @_;

	my @dir;

	# これディレクトリも拾うだろ
	# プロシジャ的用法。@{$self->{keys}}に$nameが溜まって行く
	my $wanted  = sub{
		# バックアップファイルは除外
		return if /^\./; # ドットファイルは無視
		return if $self->decode($name) =~ /\.bak$/;
		return if $self->decode($name) =~ /\~$/;
		return if $self->decode($name) =~ /-#[^-]+#$/;
		push(@{$self->{keys}}, $self->decode($name));
	};
	File::Find::find({wanted => $wanted}, $self->{dir});

    shift @{$self->{keys}};
}

sub NEXTKEY {
    my ($self) = @_;
    return shift @{$self->{keys}};
}

sub encode {
    my ($self, $key) = @_;
	# 非英数字をエスケープする
	return undef if $key =~ /^\./; # ドットファイルはダメ
	my $suf = ($key =~ /\.\w+$/); #拡張子チェック
	$key =~ s#([^-a-zA-Z0-9._])#sprintf( "%%%02lx", unpack( "C", $1 ) )#eg;
	$key =~ s#-#/#g;
	$key .= ".wik" unless $suf; #拡張子なければ.wikを付ける
    return $self->{dir} . "/$key";
}

sub decode {
    my ($self, $key) = @_;
	my $dir = $self->{dir};
    $key =~ s#^$dir/##;
	$key =~ s#\.wik$##;
	$key =~ s#/#-#g;
	$key =~ s/%[0-9A-F][0-9A-F]/pack("C", hex($&))/ieg;
	return $key;
}

1;