lib/Yuki/YukiWikiDB2.pm

###
### $Id: YukiWikiDB2.pm,v 1.3 2003/01/02 04:20:05 w Exp $
###

# Yuki::YukiWikiDB2.pm - Pure Perl database module, esp. for YukiWiki.
#
# Copyright (C) 2002 by Gokuaku.
# <[email protected]>, 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::YukiWikiDB2;
($VERSION) = q($Revision: 1.3 $) =~ 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';
}


#
# ���å�
# ���å��������⡼�ɡ�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$/.1.@{[time]}.lock/x
                                or
                $to     =~ s/\.(\d+)\.(\d+)\.lock$/.@{[$1+1]}.@{[time]}.lock/x
                                or
                return; # ���֤���¾���å�����Ƥ��롣
        }else{
                # ��¾���å�
                $to     =~ s/\.\.\.lock$/..@{[time]}.lock/x
                                or
                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$/.1.@{[time]}.lock/x
                                                                        or return;
        }else{
                # ������¾���å�
                $to     =~ s/\.(\d*)\.(\d*)\.lock$/..@{[time]}.lock/x
                                                                        or 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$
                                /.@{[$1 == 1 ? "." : ($1-1).".".$2]}.lock/x
                                                                        or return;
        }else{
                # ��¾���å����
                $to     =~ s/\.\.(\d+)\.lock$/...lock/x
                                                                        or 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(YukiWikiDB2);
        (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"});
        }

        # �����Υ��󥳡��ɥ᥽�å�
        my $method      = $opt->{-encode};
        if("\U$method" eq 'YUKIWIKI' or not defined $method){
                # 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$/){
                        last;
                }
        }
        if(not defined $lockfile){
                $lockfile       = "$dbname...lock";
                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::YukiWikiDB2",$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";
        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$/){
                                        $nglock         = qq($dbname.$1.$2.lock);
                                        $duration       = time - $2     if $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$/){
                                        $nglock         = qq($dbname.$1.$2.lock);
                                        $duration       = time - $2     if $2;
                                        last;
                                }
                        }
                        last TRY if $self->_unlock($nglock);
                        
                        if($nglock eq "$dbname...lock"){
                                # ���ꤨ�ʤ��Ϥ��������ʤ����Ȥ��ɤ����롣
                                $self->_warn(qq{UNTIE : not locked. "$nglock"});
                                last TRY;
                        }

                        # ��������(sleep �ʤ�)
                        $self->_warn(qq{UNTIE : retry unlock ($try/$trytime). "$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);
        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 $dbname      = $self->{-dir};
        my $ext         = $self->{-extension};
        my $extlen      = length $ext;
        opendir(DIR,$dbname)    or $self->_die(qq{_list_all : $! "$dbname".});
        my @key = grep(-f $dbname.$_,readdir DIR);
        closedir DIR;
        if($extlen){
                @key    = grep(index("$_/","$ext/") != -1,@key);
                foreach(@key){
                        substr($_,-$extlen)     = ''
                }
        }
        return @key;
}
sub list_all{
        my $self        = shift                         or die qq(list_all : usage error.);
        my @key         = $self->_list_all();
        foreach(@key){
                &{$self->{-decode}}($_);
        }
        return @key;
}


#
# ������̾�����Ѥ���
# ���������� 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        = shift                         or die qq(sort_by_mtime : usage error.);
        my $dbname              = $self->{-dir};
        my @key         = @_;
        if(not @key){
                @key    = $self->_list_all();
        }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        = shift                         or die qq(sort_by_size : usage error.);
        my $dbname              = $self->{-dir};
        my @key         = @_;
        if(not @key){
                @key    = $self->_list_all();
        }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::YukiWikiDB2 $Yuki::YukiWikiDB2::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)       = @_;
        my @key         = $self->sort_by_mtime();
        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::YukiWikiDB2\t: $Yuki::YukiWikiDB2::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__