###
### $Id: YukiWikiDBNS.pm,v 1.6 2003/07/27 05:22:52 wakaba Exp $
###

# Yuki::YukiWikiDB2.pm - Pure Perl database module, esp. for YukiWiki.
#
# Copyright (C) 2002 by Gokuaku.
# <FZH01112@nifty.ne.jp>, http://homepage1.nifty.com/dune/

# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.

require 5.004_71;
package Yuki::YukiWikiDBNS;
($VERSION) = q($Revision: 1.6 $) =~ m/\x20([\d.]+)\x20/;
use strict;



#
# _die	- 致命的なエラー発生時に呼び出す関数。
# _warn	- 警告発生時に呼び出す関数。
#
sub _die{
	my $self	= shift;
	my $file	= $self->{-logfile};
	my $dir		= $self->{-dir};
	my $caller	= join(" ",(caller 1)[1,2]);
	my $msg		= qq/ERR (@{[scalar localtime]}) $dir @_ $caller/;
	push(@{$self->{-error}},$msg);
	if($file){
		# $file は壊れても気にしない
		# サイズが気になるときは >> を > に変える。
		open(FILE,">>$file")		or die qq(_die : $! "$file");
		print FILE $msg,"\n";
		close FILE;
	}
	die "$msg\n";
}
sub _warn{
	my $self	= shift;
	my $file	= $self->{-logfile};
	my $dir		= $self->{-dir};
	my $caller	= join(" ",(caller 1)[1,2]);
	my $msg		= qq/WRN (@{[scalar localtime]}) $dir @_ $caller/;
	push(@{$self->{-error}},$msg);
	if($file){
		# $file は壊れても気にしない
		# サイズが気になるときは >> を > に変える。
		open(FILE,">>$file")		or die qq(_warn : $! "$file");
		print FILE $msg,"\n";
		close FILE;
	}
	return $msg;
}



#
# エラーメッセージの処理
#
# errmsg	- エラーメッセージ（文字列）を取得します。
#				エラーがない場合は undef を返します。
# clr_errmsg	- エラーメッセージを消去します。
#               戻り値は常に undef です。
#
# errlog	- エラーログ（ファイル）を読み出します。
#				エラーがない場合は undef を返します。
# clr_errlog	- エラーログ（ファイル）を消去します。
#               戻り値は常に undef です。
#
sub errmsg{
	my $self	= shift				or die qq(errmsg : usage error.);
	my @log	= @{$self->{-error}};
	if(wantarray){
		return @log;
	}else{
		return @log ? join("",@log) : undef;
	}
}
sub errlog{
	my $self	= shift				or die qq(errlog : usage error.);
	my $file	= $self->{-logfile}	or return;
	open(FILE,$file)				or return;
	my @log	= <FILE>;
	close FILE;
	if(wantarray){
		return @log;
	}else{
		return @log ? join("",@log) : undef;
	}
}
sub clr_errmsg{
	my $self	= shift			or die qq(clr_errmsg : usage error.);
	$self->{-error} = [];
	return undef;
}
sub clr_errlog{
	my $self	= shift			or die qq(clr_errlog : usage error.);
	my $file	= $self->{-logfile};
	-e $file and unlink $file;
	return undef;
}



#
# 生のファイル名を得る
#
# ハッシュの内容は、例えば $hash{foo} = 'bar' を実行すると  
# foo.txt というファイルに bar と書き込まれます（１件につき
# １ファイルが作成される）。
# filename で、そのファイル名（foo）を得ることができます。
# bkupname はバックアップファイル名を得ます。
# 該当ファイルの有無に関係なく、形式的にファイル名を返します。
#
# ex. $filename = $DB->filename('foo');
# ex. $filename = $DB->bkupname('foo');
#
sub filename{
	my($self,$key) = @_;
	&{$self->{-encode}}($key);
	return $self->{-dir}.$key.$self->{-extension};
}
sub bkupname{
	my($self,$key) = @_;
	&{$self->{-encode}}($key);
	return $self->{-dir}.$key.'.bak';
}

sub dig_directory ($$) {
  my ($self, $dir) = @_;
  my $path = '';
  $dir =~ s#[/\\][^/\\]+$##;
  return if -d $dir;
	foreach(split(m/[\/\\]/,$dir)){
		if(not -d ($path .= "$_/")){
			mkdir($path,0777)	or $self->_die(qq{_init : $! "$path"});
		}
	}
}

sub _get_lock_file_name ($%) {
    my ($self, %o) = @_;
    return sprintf '%s.%d.%d.lock%s', $o{prefix}, $o{seq}, $o{time}, $o{suffix};
}

sub _match_lock_file_name ($$%) {
    my ($self, $fname, %o) = @_;
    if ($fname =~ /\Q$o{prefix}\E\.([0-9]+)\.([0-9]+)\.lock\Q$o{suffix}\E$/) {
	return {seq => $1, time => $2};
    }
    return undef;
}

sub _s_lock_file_name ($$$$) {
  my ($self, $fname, $p, $o) = @_;
  return ($$fname =~ s/\Q$p->{prefix}\E\.([0-9]+)\.([0-9]+)\.lock\Q$p->{suffix}\E$/sprintf '%s.%d.%d.lock%s', $o->{prefix}, $1*$o->{seq_z}+$o->{seq_p}, $2*$o->{time_x}+$o->{time_p}, $o->{suffix}/);
}

#
# ロック
# ロックしたいモード（0:ロックしない 1:共有 2:排他）と、
# ロックファイル名（ロックされる前のもの）を渡します。
# ロックに成功すると、新しいロックファイル名を返します。
# 失敗すると undef を返します。
# 通常、この関数をユーザが呼び出すことはありません。
#
sub _lock{
	my($self,$mode,$from)	= @_;
	my $to		= $from;
	if($mode == 0){
		# 何もせずに戻る
		return($self->{-lock} = $to);
	}elsif($mode == 1){
		# 共有ロック
		#$to	=~ s/\.\.\.lock\Q$self->{-extension}\E$/.1.@{[time]}.lock$self->{-extension}/x
		#		or
		#$to	=~ s/\.(\d+)\.(\d+)\.lock\Q$self->{-extension}\E$/.@{[$1+1]}.@{[time]}.lock$self->{-extension}/x
		#		or
		#return;	# たぶん、排他ロックされている。
	  $self->_s_lock_file_name (\$to,
	       {suffix => $self->{-extension}}
	    => {seq_x => 1, seq_p => 1, time_x => 0, time_p => time,
	        suffix => $self->{-extension}})
	    or
	  return;
	}else{
		# 排他ロック
		#$to	=~ s/\.\.\.lock\Q$self->{-extension}\E$/..@{[time]}.lock$self->{-extension}/x
		#		or
		#return;	# たぶん、共有ロックされている。
	  my $lock_name = $self->_match_lock_file_name
	    ($to, suffix => $self->{-extension});
	  if ($lock_name && $lock_name->{seq} == 0
	                 && $lock_name->{time} == 0) {
	    $self->_get_lock_file_name (\$to,
	         {suffix => $self->{-extension}}
	      => {seq_x => 0, seq_p => 0, time_x => 0, time_p => time,
	          suffix => $self->{-extension}})
	  } else {
	    return;
	  }
	}
	if(rename($from => $to)){
		# ロック成功
		$self->{-mode}	= $mode;
		return($self->{-lock} = $to);
	}else{
		# ロックできなかったら undef を返す
		return;
	}
}



#
# 強制ロック
# ロックしたいモード（0:ロックしない 1:共有 2:排他）と、
# ロックファイル名を渡します。
# この関数は現在のロック状態を無視するので、（おそらく）常に
# ロックに成功します。
# ロックに成功すると、新しいロックファイル名を返します。
# 失敗すると undef を返します。
# 通常、この関数をユーザが呼び出すことはありません。
#
sub _force_lock{
	my($self,$mode,$from)	= @_;
	my $to		= $from;
	if($mode == 0){
		# 何もせずに戻る
		return($self->{-lock} = $to);
	}elsif($mode == 1){
		# 強制共有ロック
		#$to	=~ s/\.(\d*)\.(\d*)\.lock\Q$self->{-extension}\E$/.1.@{[time]}.lock$self->{-extension}/x
		#							or return;
	  my $lock_name = $self->_match_lock_file_name
	    ($to, suffix => $self->{-extension});
	  if ($lock_name) {
	    $self->_get_lock_file_name (\$to,
	         {suffix => $self->{-extension}}
	      => {seq_x => 0, seq_p => 1, time_x => 0, time_p => time,
	          suffix => $self->{-extension}})
	  } else {
	    return;
	  }
	}else{
		# 強制排他ロック
		#$to	=~ s/\.(\d*)\.(\d*)\.lock\Q$self->{-extension}\E$/..@{[time]}.lock$self->{-extension}/x
		#							or return;
	  my $lock_name = $self->_match_lock_file_name
	    ($to, suffix => $self->{-extension});
	  if ($lock_name) {
	    $self->_get_lock_file_name (\$to,
	         {suffix => $self->{-extension}}
	      => {seq_x => 0, seq_p => 0, time_x => 0, time_p => time,
	          suffix => $self->{-extension}})
	  } else {
	    return;
	  }
	}
	if(rename($from => $to)){
		$self->{-mode}	= $mode;
		return($self->{-lock} = $to);
	}
	# ロックできなかったら undef を返す
	return;
}



#
# ロック解除
# ロックファイル名を渡します。
# アンロックに成功すると、新しいロックファイル名を返します。
# 失敗すると undef を返します。
# 通常、この関数をユーザが呼び出すことはありません。
#
sub _unlock{
	my($self,$from)	= @_;
	my $mode	= $self->{-mode};
	my $to		= $from;
	if($mode == 0){
		# 何もしない
		return($self->{-lock} = $to);
	}elsif($mode == 1){
		# 共有ロック解除
		#$to	=~ s/\.(\d+)\.(\d+)\.lock\Q$self->{-extension}\E$
		#		/.@{[$1 == 1 ? "." : ($1-1).".".$2]}.lock$self->{-extension}/x
		#							or return;
	  my $lock_name = $self->_match_lock_file_name ($to,
	    suffix => $self->{-extension});
	  if ($lock_name && $lock_name->{seq}
	                 && $lock_name->{time}) {
	    if ($lock_name->{seq} == 1) {
	      $self->_s_lock_file_name (\$to,
	           {suffix => $self->{-extension}}
	        => {seq_x => 0, seq_p => 0,
	            time_x => 0, time_p => 0,
	            suffix => $self->{-extension}});
	    } else {
	      $self->_s_lock_file_name (\$to,
	           {suffix => $self->{-extension}}
	        => {seq_x => 1, seq_p => -1,
	            time_x => 0, time_p => time,
	            suffix => $self->{-extension}});
	    }
	  } else {
	    return;
	  }
	}else{
		# 排他ロック解除
		#$to	=~ s/\.\.(\d+)\.lock\Q$self->{-extension}\E$/...lock$self->{-extension}/x
		#							or return;
	  my $lock_name = $self->_match_lock_file_name ($to,
	    suffix => $self->{-extension});
	  if ($lock_name && !$lock_name->{seq}
	                 && $lock_name->{time}) {
	    $self->_s_lock_file_name (\$to,
	         {suffix => $self->{-extension}}
	      => {seq_x => 0, seq_p => 0,
	          time_x => 0, time_p => 0,
	          suffix => $self->{-extension}});
	  } else {
	    return;
	  }
	}
	if(rename($from => $to)){
		# アンロック成功
		$self->{-mode}	= 0;
		return($self->{-lock} = $to);
	}else{
		# アンロックできなかったら undef を返す
		return;
	}
}



#
# コンストラクタ
#
sub new{	shift->TIEHASH(@_)	}



#
# 引数の検査
#
sub _check_opt{
	my($dbname,$opt) = @_;

	$dbname	||=	q(YukiWikiDBNS);
	(my $dir	= $dbname) =~ s/[\\\/]/\//g;
	$dir	=~ s/[\/]*$/\//;

	my $self = {
		-dir		=> $dir,		# データベース名（ディレクトリ）
		-mode		=> 0,			# ロックしたら 0 以外の値になる
		-lock		=> undef,		# ロックファイル名
		-keys		=> [],			# キーリスト
		-error		=> [],			# エラーメッセージ
		-bkup		=> $opt->{-backup},			# 1:バックアップを取る
		-bkup_next	=> $opt->{-backup},			# 1:次回バックアップを取る
		-trytime	=> $opt->{-trytime}	|| 8,	# リトライ回数 [１秒/回]
		-timeout	=> $opt->{-timeout}	|| 20,	# 最長ロック時間 [秒]
		-logfile	=> $opt->{-logfile},		# ログファイル
		
		-extension	=> (exists $opt->{-extension} ?
						 $opt->{-extension} : '.txt'),	# 拡張子

		-cache		=> {},
		-headline	=> {},
	};



	# モードのチェック
	my $mode	= $opt->{-lock};
	if($mode == 0){
		;;;
	}elsif($mode == 1 or $mode == 2 or $mode == 5 or $mode == 6){
		;;;
	}else{
		_die($self,qq{_check_opt : unknown lock mode "$mode"});
	}

	# キーのエンコードメソッド
	## ENCODE: perl hash key name ->-> file system name
	## DECODE: file system name ->-> perl hash key name
	my $method	= $opt->{-encode};
	if("\U$method" eq 'HEXNS' or not defined $method){
		# HEX + NS
		$self->{-encode}	= sub{	$_[0] = uc unpack("H*",$_[0]); $_[0] =~ s#2F2F#.ns/#g; $_[0]	};
		$self->{-decode}	= sub{	$_[0] =~ s#\.ns/#2F2F#g; $_[0] = pack("H*",$_[0]); $_[0]		};
	} elsif("\U$method" eq 'YUKIWIKI'){
		# YukiWiki 互換
		$self->{-encode}	= sub{	$_[0] = uc unpack("H*",$_[0])	};
		$self->{-decode}	= sub{	$_[0] = pack("H*",$_[0])		};
	}elsif("\U$method" eq 'NONE'){
		# dune/wiki 互換（エンコードしない）
		$self->{-encode}	= sub{	$_[0]	};
		$self->{-decode}	= sub{	$_[0]	};
	}elsif($method eq 'RFC'){
		# RFC2396/2732	[^A-Za-z0-9\-_.!~*'()]
		$self->{-encode}	= sub{
			$_[0] =~ s/([^\w\-.!~()])/
				sprintf('%%%02X',ord $1)/eg
			};
		$self->{-decode}	= sub{
				$_[0] =~ s/%([0-9A-Fa-f]{2})/chr(hex $1)/eg;
			};
	}elsif($method eq 'rfc'){
		$self->{-encode}	= sub{
			$_[0] =~ s/([^\w\_!~()])/
				sprintf('%%%02x',ord $1)/eg
			};
		$self->{-decode}	= sub{
				$_[0] =~ s/%([0-9A-Fa-f]{2})/chr(hex $1)/eg;
			};
	}else{
		_die($self,qq{_check_opt : unkown encode method "$method"});
	}

	# 簡易チェック
	foreach(keys %{$opt}){
		next if m/^-\w+$/;
		_die($self,qq{_check_opt : unknown option "$_"});
	}

	return $self;
}



#
# ディレクトリを掘る。
# ロックファイルを作る。
#
sub _init{
	my($self)	= @_;
	chop(my $dbname	= $self->{-dir});	# 最後の / を削除
	my $path;
	foreach(split(m/[\/\\]/,$dbname)){
		if(not -d ($path .= "$_/")){
			mkdir($path,0777)	or $self->_die(qq{_init : $! "$path"});
		}
	}
	opendir(DIR,"$dbname/..")		or $self->_die(qq{_init : $! "$dbname/.."});
	my @lockfile	= readdir DIR;
	closedir DIR;
	my($lockfile);
	foreach(@lockfile){
		#if(m/^\Q$dbname\E\.(\d*)\.(\d*)\.lock\Q$self->{-extension}\E$/){
		#	last;
		#}
	  if ($self->_match_lock_file_name ($_,
	        suffix => $self->{-extension})) {
	    last;
	  }
	}
	if(not defined $lockfile){
	  $lockfile = $self->_get_lock_file_name (prefix => $dbname,
	                                          seq => 0, time => 0,
	                                          suffix => $self->{-extension});
		#$lockfile	= "$dbname...lock$self->{-extension}";
		open(FILE,">", $lockfile)		or $self->_die(qq{_init : $! "$lockfile"});
#		print FILE scalar localtime,"\n";
		close FILE;
	}else{
		$self->_die(qq{_init : lockfile already exists. "$lockfile"});
	};
}



#
# ハッシュ %db をファイルに結びつける。
# tie(%db,"Yuki::YukiWikiDBNS",$dbname,%opt)
# 
# 最初の引数 $dbname はデータ（ファイル）を保存するディレクトリ名
#
# それ以降はオプショナルの引数で、ハッシュ %opt の形で指定する。
#
# -lock => ロックモード
#		0 : ロックしない。省略時のデフォルト
#		1 : (LOCK_SH) 共有ロック，リトライあり
#		2 : (LOCK_EX) 排他ロック，リトライあり
#		5 : (LOCK_SH|LOCK_NB) 共有ロック，リトライなし
#		6 : (LOCK_EX|LOCK_NB) 排他ロック，リトライなし
#		8 : (LOCK_UN) 使わないこと。
#	ロックモード 0 は、現在のロック状態に関係なくデータベースに接続
#	します。そのため共有ロック中のデータベースにロックモード 0 で
#	接続してデータを書き込む、といったことができてしまいます（仕様）。
#	当然、ロックモード 0 は他のロックモードのブロックもしません。
#
# -trytime => ロックビジー時にリトライする回数（[１秒/回]）を指定
#             します。１回リトライする毎に１秒休止します。
# -timeout => ロックをかけていられる最長時間（単位 [秒]）を指定しま
#             す。プロセスがロックを解除せずに異常終了した場
#             合の対策用です。
#		-trytime < -timeout : ロックリトライで失敗する可能性あり
#		-trytime = -timeout : リトライ失敗後は常に強制ロック
#
# -logfile => ログファイル名
#	エラーやワーニングが発生したときに、その内容が書き込まれ
#	るファイルです。CGI が動かないときのヒントになります。ロ
#	ックリトライ時もワーニングが書き込まれるので、アクセス状
#	況の参考になります。
#
# -extension => ファイルにつける拡張子
#
sub TIEHASH{
	my($class,$dbname,%opt)	= @_;
	my $self	= bless(_check_opt($dbname,\%opt) => $class);
	my $mode	= $opt{-lock} & ~4;
	my $block	= $opt{-lock} & 4;

	# 初期化
	# rename でディレクトリ名の変更ができるかどうかは実装依存なので、
	# ロックファイルを作って rename する。
	if(not -d $self->{-dir}){
		$self->_init();
	}

	# ここからロック処理
	chop($dbname	= $self->{-dir});
	#my $lock	= "$dbname...lock$self->{-extension}";
	my $lock = $self->_get_lock_file_name (prefix => $dbname,
	               seq => 0, time => 0,
	               suffix => $self->{-extension});
	if($self->_lock($mode,$lock)){
		# ロック成功（たいてい、ここで完了する）
		;;;
	}elsif($block){
		# ロック失敗（ウェイトなし）
		$self->_warn(qq{TIEHASH : lock blocked. "$lock"});
	}else{
		# ロック失敗（ウェイト）
		my $trytime	= $self->{-trytime};
		TRY:foreach(my $try = 0;$try < $trytime;++$try){

			# ロックファイルを探す
			opendir(DIR,"$dbname/..")
								or $self->_die(qq{TIEHASH : $! "$dbname/.."});
			my @nglock	= readdir DIR;
			closedir DIR;

			my($nglock,$duration);
			foreach(@nglock){
			#	if(m/^\Q$dbname\E\.(\d*)\.(\d*)\.lock\Q$self->{-extension}\E$/){
			#		$nglock		= qq($dbname.$1.$2.lock$self->{-extension});
			#		$duration	= time - $2	if $2;
			#		last;
			#	}
			  if ($self->_match_lock_file_name ($_,
			        prefix => $dbname,
			        suffix => $self->{-extension})) {
			    #$nglock = $self->_get_lock_file_name (
			    #  prefix => $dbname,
			    #  suffix => $self->{-extension});
			    $nglock = $_;
			    $duration = time - $2;
			    last;
			  }
			}

			# ロックファイルが見つからない?
			if(not defined $nglock){
				## Maybe it is the first time to use this DB
				open NEWLOCK, ">", $lock or $self->_die(qq{TIEHASH : lockfile not found. "$lock"});
				close NEWLOCK;
				return TIEHASH (@_);
			}

			# 既存ロックを更新してロック
			if($self->{-timeout} < $duration){
				# 異常なロック
				$self->_warn(qq{TIEHASH : dated lock found ($duration). "$nglock"});
				last TRY	if $self->_force_lock($mode,$nglock);
				$self->_warn(qq{TIEHASH : force lock failure. "$nglock"});
			}else{
				# 正常なロック
				last TRY	if $self->_lock($mode,$nglock);
			}

			# ウェイト
			$self->_warn(qq{TIEHASH : retry lock ($try/$trytime). "$nglock"});
			sleep 1;
		}
	}

	if(not $self->{-lock}){
		# ロック失敗
		$self->_warn(qq{TIEHASH : lock failure. "$lock"});
		return;
	}else{
		return $self;
	}
}



#
# UNTIE
# スクリプトを終了せずにデータベースを閉じる場合は
# untie %db; などとする。
# UNTIE は untie し忘れると呼ばれない（ロックが解除されな
# い）ので、オブジェクトのデストラクタからも自動的に呼び出さ
# れるようにした。
#
sub UNTIE{
	my($self) = @_;
	my $mode	= $self->{-mode};
	my $lock	= $self->{-lock};

	if(!$mode or $self->_unlock($lock)){
		# アンロック成功（たいてい、ここで完了する）
		;;;
	}else{
		# アンロック失敗、ロックファイルを探す（共有ロック時）
		chop(my $dbname	= $self->{-dir});
		my $trytime	= $self->{-trytime};
		TRY:foreach(my $try = 0;$try < $trytime;++$try){
			opendir(DIR,"$dbname/..")	or $self->_die(qq{UNTIE : $! "$dbname/.."});
			my @nglock	= readdir DIR;
			closedir DIR;

			my($nglock,$duration);
			foreach(@nglock){
				#if(m/^\Q$dbname\E\.(\d*)\.(\d*)\.lock\.\Q$self->{-extension}\E$/){
				#	$nglock		= qq($dbname.$1.$2.lock$self->{-extension});
				#	$duration	= time - $2	if $2;
				#	last;
				#}
			  if ($self->_match_lock_file_name ($_,
			        prefix => $dbname,
			        suffix => $self->{-extension})) {
			    $nglock = $_;
			    $duration = time - $2;
			    last;
			  }
			}
			last TRY if $self->_unlock($nglock);
			
			#if($nglock eq "$dbname...lock$self->{-extension}"){
			if ($nglock eq $self->_get_lock_file_name (prefix => $dbname, seq => 0, time => 0, prefix => $self->{-extension})) {
				# ありえないはずだが、なぜかときどきくる。
				$self->_warn(qq{UNTIE : not locked. "$nglock"});
				last TRY;
			}

			# ウェイト(sleep なし)
			$self->_warn(qq{UNTIE : retry unlock ($try/@{[$trytime-1]}). "$nglock"});
		}
		
		if($self->{-lock} eq $lock){
			$self->_warn(qq{UNTIE : unlock failure. "$lock"});
		}
	}
	return;
}



#
# デストラクタ
#
# DESTROY は untie し忘れても呼ばれる。
# new または tie のスコープの外に出たとき（perl 終了時とか）
# に呼ばれるか、あるいは戻り値を使っている場合、オブジェクト
# が参照されなくなったとき、または明示的に untie に続けて undef
# したときに呼ばれる。とにかく、いつかは必ず呼ばれるみたいだ。 
#
sub DESTROY{
	my($self) = @_;
	if($self->{-mode}){
		# untie 忘れの尻拭い
		$self->_warn(qq{DESTROY : invoke untie method.}) if 0;
		$self->UNTIE();
	}
	return;
}



#
# 書き込み
#
sub STORE{
	my($self,$key,$val)	= @_;
	my $mode	= $self->{-mode};
	$self->_die(qq{STORE : method not allowd, mode="$mode"})	if $mode == 1;
	my $file	= $self->filename($key);
	my $temp	= "$file.".time;
	my $bkup	= $self->bkupname($key);
	$self->dig_directory ($file);
	open(FILE,">$temp")				or $self->_die(qq{STORE : $! "$temp"});
	binmode FILE;
	print FILE $val;
	close FILE;
	if($self->{-bkup_next}){
		if(-e $bkup){
			unlink $bkup			or $self->_die(qq{STORE : $! "$bkup"});
		}
		if(-e $file){
			rename($file => $bkup)	or $self->_die(qq{STORE : $! "$file" => "$bkup"});
		}
	}else{
		if(-e $file){
			unlink $file			or $self->_die(qq{STORE : $! "$file"});
		}
	}
	rename($temp => $file)			or $self->_die(qq{STORE : $! "$temp" => "$file"});
	$self->{-bkup_next}	= $self->{-bkup};
	$self->{-cache}->{-key}	= $key;
	$self->{-cache}->{-val}	= $val;
	delete $self->{-headline}->{$key};
	return $val;
}



#
# 読み出し
#
sub FETCH{
	my($self,$key) = @_;
	if($self->{-cache}->{-key} eq $key){
		return $self->{-cache}->{-val};
	}
	my $file	= $self->filename($key);
	if(-e $file){
		open(FILE,$file)			or $self->_die(qq{FETCH : $! "$file"});
		binmode FILE;
		local $/	= undef;
		my $val	= <FILE>;
		close FILE;
		$self->{-cache}->{-key}	= $key;
		$self->{-cache}->{-val}	= $val;
		return $val;
	}else{
		return;
	}
}



#
# 削除
#
sub DELETE{
	my($self,$key) = @_;
	my $file	= $self->filename($key);
	my $bkup	= $self->bkupname($key);
	my $mode	= $self->{-mode};
	$self->_die(qq{DELETE : method not allowd, mode="$mode"})	if $mode == 1;
	if($self->{-bkup_next}){
		if(-e $bkup){
			unlink $bkup	or $self->_die(qq{DELETE : $! "$bkup"});
		}
		if(-e $file){
			rename($file => $bkup)
							or $self->_die(qq{DELETE : $! "$file" => "$bkup"});
		}
	}else{
		if(-e $file){
			unlink $file	or $self->_die(qq{DELETE : $! "$file"});
		}
	}
	$self->{-bkup_next}	= $self->{-bkup};
	$self->{-cache}->{-key}	= undef;
	$self->{-cache}->{-val}	= undef;
	delete $self->{-headline}->{$key};
	return;
}



#
# 存在チェック
#
sub EXISTS{
	my($self,$key) = @_;
	my $file	= $self->filename($key);
	return -e $file;
}



#
# イテレータ
#
sub FIRSTKEY{
	my($self)	= @_;
	@{$self->{-keys}}	= $self->_list_all();
	my $tmp = shift @{$self->{-keys}};
	return defined $tmp ? &{$self->{-decode}}($tmp) : undef;
}
sub NEXTKEY{
	my($self)	= @_;
	my $tmp = shift @{$self->{-keys}};
	return defined $tmp ? &{$self->{-decode}}($tmp) : undef;
}



#
# ハッシュ全体の削除
#
# フォルダの中身を空にする（空ハッシュにする）だけで、ディレ
# クトリやロックファイル、アーカイブは残す（仕様！）。
#
sub CLEAR{
	my($self)	= @_;
	my $mode	= $self->{-mode};
	$self->_die(qq{CLEAR : method not allowd, mode="$mode"})	if $mode == 1;
	my $dbname	= $self->{-dir};
	my @key		= $self->_list_all();
	foreach(@key){
		my $file	= $dbname.$_.$self->{-extension};
		unlink $file			or $self->_die(qq{CLEAR : $! "$file".});
	}
	if(0){
		my $file	= $self->{-logfile};
		if(-e $file){
			unlink $file		or $self->_die(qq{CLEAR : $! "$file".});
		}
	}
	if(0){
		my $lock	= $self->{-lock};
		rmdir $dbname				or $self->_die(qq{CLEAR : $! "$dbname".});
		unlink $lock			or $self->_die(qq{CLEAR : $! "$lock".});
		$self->{-mode}	= 0;
	}
	$self->{-cache}->{-key}	= undef;
	$self->{-cache}->{-val}	= undef;
	$self->{-headline}		= {};
	return;
}



#
# 指定したキーのデータサイズを [byte] で返します。
# キーを指定しないと、全てのデータの合計サイズを返します
# （ただしバックアップ用のデータや、-extension で拡張子を
# 変えたデータは計上しません）。
#
sub size{
	my $self	= shift				or die qq(size : usage error.);
	my $dbname		= $self->{-dir};
	my @key		= @_;
	if(not @key){
		@key	= $self->_list_all();
	}else{
		foreach(@key){
			&{$self->{-encode}}($_);
		}
	}
	my $size;
	foreach(@key){
		$size	+= -s $dbname.$_.$self->{-extension};
	}
	return $size;
}



#
# いわゆる ListAll
#
sub list_all{
	my $self	= shift				or die qq(list_all : usage error.);
	my @key		= $self->_list_all();
	foreach(@key){
		&{$self->{-decode}}($_);
	}
	return @key;
}

# $self->_list_all
# - Returns all items (including NS'ed items) in encoded (file system) form

sub _list_all ($) {
  my $self = shift or die q(_list_all: $self is not specified);
  $self->_list_all_NS ('');
}

sub _list_all_NS ($$) {
  my ($self, $NS) = @_;
  my @items = $self->_list_items_by_suffix_NS ($NS, $self->{-extension});
  for my $ns ($self->_list_nss_by_suffix_NS ($NS, '.ns')) {
    push @items, $self->_list_all_NS ($ns.'.ns/', $self->{-extension});
  }
  @items;
}

sub _list_nss_NS ($$) {
  my ($self, $NS) = @_;
  my @items;
  for my $ns ($self->_list_nss_by_suffix_NS ($NS, '.ns')) {
    push @items, $self->_list_nss_NS ($ns.'.ns/', $self->{-extension});
  }
  @items;
}

# $self->_list_items_by_suffix_NS ($encoded_ns, $suffix)
# - Returns all items within the NS that have given suffix, in encoded (file system) form

sub _list_items_by_suffix_NS ($$$) {
  my ($self, $ns, $suffix) = @_;
  my $dbname	= $self->{-dir} . $ns;
  opendir(DIR,$dbname)	or return ();
    my @key	= grep(-f $dbname.$_,readdir DIR);
  closedir DIR;
  @key = grep {s/\Q$suffix\E$//} @key if length $suffix;
  return map {$ns.$_} @key;
}
sub _list_nss_by_suffix_NS ($$$) {
  my ($self, $ns, $suffix) = @_;
  my $dbname	= $self->{-dir} . $ns;
  opendir(DIR,$dbname)	or return ();
    my @key	= grep(-d $dbname.$_,readdir DIR);
  closedir DIR;
  @key = grep {s/\Q$suffix\E$//} @key if length $suffix;
  return map {$ns.$_} @key;
}

sub list_items ($$) {
  my ($self, $option) = @_;
  $option->{ns} = &{$self->{-encode}} ($option->{ns});
  my @items;
  if ($option->{type} ne 'key') {	# ns or both
    $option->{recursive} = 1 unless defined $option->{recursive};
    if ($option->{recursive}) {
      push @items, map {&{$self->{-decode}} ($_).'//'} $self->_list_nss_NS ($option->{ns}, '.ns');
    } else {
      push @items, map {&{$self->{-decode}} ($_).'//'} $self->_list_nss_by_suffix_NS ($option->{ns}, '.ns');
    }
  }
  if ($option->{type} ne 'ns') {	# key or both
    push @items, map {&{$self->{-decode}} ($_)} $self->_list_items ($option);
  }
  @items;
}
sub _list_items ($$) {
  my ($self, $option) = @_;
  #$option->{ns} = &{$self->{-encode}} ($option->{ns});
  my @items;
  #if ($option{type} ne 'ns') {	# key or both
    $option->{recursive} = 1 unless defined $option->{recursive};
    if ($option->{recursive}) {
      push @items, $self->_list_all_NS ($option->{ns}, '.ns');
    } else {
      push @items, $self->_list_items_by_suffix_NS ($option->{ns}, $self->{-extension});
    }
  #}
  (@items);
}

#
# キーの名前を変える
# 成功したら 1 を返す。
#
sub rename{
	my $self		= shift				or die qq(rename : usage error.);
	my($from,$to)	= @_;
	my $mode	= $self->{-mode};
	$self->_die(qq{rename : method not allowd, mode="$mode"})	if $mode == 1;
	if(rename($self->filename($from) => $self->filename($to))){
		if($self->{-cache}->{-key} eq $from
		or $self->{-cache}->{-key} eq $to){
			$self->{-cache}->{-key}	= undef;
			$self->{-cache}->{-val}	= undef;
		}
		delete $self->{-headline}->{$from};
		delete $self->{-headline}->{$to};
		return 1;
	}else{
		$self->_warn(qq{rename : $! "$from" => "$to"});
		return 0;
	}
}



#
# キーのリストを、更新日順に並べて返す（最近のものが先頭）。
#
sub sort_by_mtime{
	my ($self, $option) = (shift, shift||{});
	my $dbname		= $self->{-dir};
	my @key		= @_;
	if(not @key){
		@key	= $self->_list_items ({%$option, type => 'key'});
	}else{
		foreach(@key){
			&{$self->{-encode}}($_);
		}
	}
	return map(&{$self->{-decode}}($_->[1]),
				sort({$a->[0] <=> $b->[0] or $a->[1] cmp $b->[1]}
					map([-M $dbname.$_.$self->{-extension},$_],@key)));
}



#
# キーのリストを、データサイズ順に並べて返す（小さいものが先頭）。
#
sub sort_by_size{
	my ($self, $option)	= (shift, shift||{});
	my $dbname		= $self->{-dir};
	my @key		= @_;
	if(not @key){
		@key	= $self->_list_items ({%$option, type => 'key'});
	}else{
		foreach(@key){
			&{$self->{-encode}}($_);
		}
	}
	return map(&{$self->{-decode}}($_->[1]),
				sort({$a->[0] <=> $b->[0] or $a->[1] cmp $b->[1]}
					map([-s $dbname.$_.$self->{-extension},$_],@key)));
}



#
# 本体のないバックアップファイルの削除
#
sub clean{
	my $self	= shift				or die qq(clean : usage error.);
	my $mode	= $self->{-mode};
	$self->_die(qq{clean : method not allowd, mode="$mode"})	if $mode == 1;
	my $dbname		= $self->{-dir};
	my @key		= @_;
	if(not @key){
		@key	= $self->_list_all();
	}else{
		foreach(@key){
			&{$self->{-encode}}($_);
			
		}
	}
	my $err;
	foreach(@key){
		if(-e $dbname.$_.".bak"){
			unlink $dbname.$_.".bak"	|| ++$err;
		}
	}
	return $err;
}



#
# データをアーカイブする。
# 成功するとアーカイブのサイズ [byte] を返します。
# 失敗すると undef を返します。
#
sub archive{
	my $self	= shift				or die qq(archive : usage error.);
	my $mode	= $self->{-mode};
	$self->_die(qq{archive : method not allowd, mode="$mode"})	if $mode == 1;
	my(@key)	= @_;
	my $dir	= $self->{-dir};
	(my $archive	= $dir)	=~ s/\/$/.zip/;
	eval <<'	###__CODE__###';
	use Archive::Zip qw(:ERROR_CODES :CONSTANTS);
	use Archive::Zip::Tree;
	my $zip	= Archive::Zip->new();
	if(@key){
		foreach(@key){
			my $member	= $zip->addFile($self->filename($_),$dir.$_);
			$member->desiredCompressionMethod(COMPRESSION_DEFLATED);
			$member->desiredCompressionLevel(COMPRESSION_LEVEL_BEST_COMPRESSION);
		}
	}else{
		$zip->addTreeMatching($dir,$dir,$self->{-extension}.'$');
		foreach my $member ($zip->members()){
			$member->desiredCompressionMethod(COMPRESSION_DEFLATED);
			$member->desiredCompressionLevel(COMPRESSION_LEVEL_BEST_COMPRESSION);
		}
	}
	$zip->zipfileComment(
		"created by Yuki::YukiWikiDBNS $Yuki::YukiWikiDBNS::VERSION"
		." with Archive::Zip $Archive::Zip::VERSION");
	die(qq{write error "$archive"})
		if $zip->writeToFileNamed("$archive") != AZ_OK;
	###__CODE__###
	if($@){
		$self->_warn(qq{archive : $@});
		return undef;
	}else{
		return -s "$archive";
	}
}



#
# いわゆる RecentChanges(WhatsNew)
# $db->recent_changes() - sort_by_mtime() と同じで全てのキーを返す。
# $db->recent_changes(+n) - 最新の n 件を返す。
# $db->recent_changes(-n) - 最古の n 件を返す。
#
sub recent_changes{
	my $self	= shift				or die qq(recent_changes : usage error.);
	my($n,$m,$option)	= @_;
	my @key		= $self->sort_by_mtime($option);
	if($m){
		return @key[$n..$m];
	}elsif($n == 0){
		return @key;
	}elsif($n < 0){
		$n		= -$n - 1;
		@key	= reverse @key;
	}else{
		--$n;
	}
	return @key[0..$n];
}



#
# バックアップフラグの一時セット
#
# セットすると次のデータ更新時にバックアップをとる。
# バックアップをとったらフラグはリセットされる。
#
# ex. $DB->bkup_next(1);	# 次回バックアップをとる。
# ex. $DB->bkup_next(0);	# 次回バックアップをとらない。
#
sub bkup_next{
	my $self	= shift				or die qq(bkup_next : usage error.);
	my($flag) = @_;
	return defined $flag ?
			($self->{-bkup_next} = $flag) :
			$self->{-bkup_next};
#	$self->{-bkup_next}	= $flag || 1
}



#
# 現在のデータとバックアップデータとの間の差分を求める。
# ex. $diff = $DB->diff('foo');
# ex. @diff = $DB->diff('foo');
#
sub diff{
	my $self	= shift				or die qq(diff : usage error.);
	my($key) = @_;
	my $diff;
	eval <<'	###__CODE__###';
	use Algorithm::Diff;
	my $file	= $self->filename($key);
	my $bkup	= $self->bkupname($key);
	my(@old,@new);
	local $/	= undef;

	if(-e $bkup){
		open(FILE,$bkup)		or die(qq{$! "$bkup"});
		binmode FILE;
		@old	= split(m/[\x0D\x0A\x00]+/,<FILE>);
		close FILE;
	}
	if(-e $file){
		open(FILE,$file)		or die(qq{$! "$file"});
		binmode FILE;
		@new	= split(m/[\x0D\x0A\x00]+/,<FILE>);
		close FILE;
	}

	foreach(Algorithm::Diff::diff(\@old,\@new)){
		foreach(@{$_}){
			my($sign,$lineno,$text) = @{$_};
			$diff	.= qq($sign$text\n);
		}
		$diff	.= "\n";
	}
	$diff	=~ s/\n+$/\n/;
	return $diff;
	###__CODE__###
	if($@){
		$self->_warn(qq{diff : $@});
		return undef;
	}else{
		return $diff;
	}
}
sub traverse_diff{
	my $self	= shift				or die qq(traverse_diff : usage error.);
	my($key) = @_;
	my $diff;
	eval <<'	###__CODE__###';
	# http://www.stonehenge.com/merlyn/UnixReview/col35.html
	use Algorithm::Diff;
	my $file	= $self->filename($key);
	my $bkup	= $self->bkupname($key);
	my(@old,@new);
	local $/	= undef;

	if(-e $bkup){
		open(FILE,$bkup)	or die(qq{$! "$bkup"});
		binmode FILE;
		@old	= split(m/[\x0D\x0A\x00]+/,<FILE>);
		close FILE;
	}
	if(-e $file){
		open(FILE,$file)	or die(qq{$! "$file"});
		binmode FILE;
		@new	= split(m/[\x0D\x0A\x00]+/,<FILE>);
		close FILE;
	}

	Algorithm::Diff::traverse_sequences(\@old,\@new,{
		MATCH		=> sub{ $diff .= qq/=$new[$_[1]]\n/	},
		DISCARD_A	=> sub{ $diff .= qq/-$old[$_[0]]\n/	},
		DISCARD_B	=> sub{ $diff .= qq/+$new[$_[1]]\n/	},
	});
	return $diff;
	###__CODE__###
	if($@){
		$self->_warn(qq{traverse_diff : $@});
		return undef;
	}else{
		return $diff;
	}
}



#
# データの最終更新日時を localtime で求める。
#
sub stat{
	my $self	= shift				or die qq(stat : usage error.);
	my($key) = @_;
	my $file	= $self->filename($key);
	return CORE::stat($file);
}
sub mtime{
	my $self	= shift				or die qq(mtime : usage error.);
	my($key) = @_;
	my $file	= $self->filename($key);
	return ( (CORE::stat($file))[9] );
}
sub localtime{
	my $self	= shift				or die qq(localtime : usage error.);
	my($key) = @_;
	my $file	= $self->filename($key);
	return localtime( (CORE::stat($file))[9] );
}



#
# 情報の読み出し
#
sub info{
	my $self	= shift				or die qq(info : usage error.);
	my $info;
	$info	.= qq(Yuki::YukiWikiDBNS\t: $Yuki::YukiWikiDBNS::VERSION\n);
	$info	.= qq(Algorithm::Diff\t: )
			.eval('use Algorithm::Diff; $Algorithm::Diff::VERSION')."\n";
	$info	.= qq(Archive::Zip\t: )
			.eval('use Archive::Zip; $Archive::Zip::VERSION')."\n";
	foreach my $key (sort keys %{$self}){
		my $val	= $self->{$key};
		$info	.= qq($key\t: $val\n);
		if(ref($val) eq 'ARRAY' and @{$val}){
			$info	.= join("\n",@{$val})."\n"
		}
	}
	return $info;
}



#
# ヘッドライン読み出し
# 最初の行を返します。行末の改行は chomp されます。
#
sub headline{
	my $self	= shift				or die qq(headline : usage error.);
	my($key) = @_;
	my $file	= $self->filename($key);
	if(exists $self->{-headline}->{$key}){
		;;;
	}elsif(-e $file){
		open(FILE,$file)	or $self->_die(qq{headline : $! "$file"});
		binmode FILE;
		local $/	= "\n";
		while(<FILE>){
			s/^[\s\t]+//;
			s/[\s\t]+$//;
			next unless length;
			$self->{-headline}->{$key}	= $_;
			last;
		}
		close FILE;
	}else{
		$self->{-headline}->{$key}	= undef;
	}
	return $self->{-headline}->{$key};
}

1;;;

__END__