安いレンタルサーバや無料スペースだと未だに動的コンテンツ作成にperlしか使えない事があるので、自分用に簡単なライブラリ書いてみました。 Perl書くの久しぶりなので、最近のモダンPerlの流儀からはだいぶ離れているかもしれません。（というかPerl自体が時代遅ｒ……げふんげふん！！！）

KVSっぽいサービスをファイルで実現するライブラリと、そのKVSサービスを利用してJSON形式でPerlのハッシュオブジェクトを透過的に読み書きするライブラリです。てきとーに書いたので、use strict したらエラー吐くかもしれない。

ソースコード

KVS（っぽくファイルにアクセスする）ライブラリのソース

package KVS;

# Very very very Simple Filebase KVS engine.
#
# How to use:
#   use lib "/path/of/mylib/perl";
#   use KVS;
#
#   my $KVS = KVS->new( "/path/of/file.tsv" );
#   $KVS->lock();
#   $ccc_value = $KVS->get("CCC");
#   $KVS->add("NewKey", "New Value.");
#   $KVS->update("NewKey", "Updated Value.");
#   $KVS->updateForce("NewKey", "Updated Value.");
#   $KVS->delete("ExistedKey");
#   print Dumper $KVS->rawdata(); # show all memory
#   $KVS->save() || die "fail to save"
#
# one linner
#   $KVS->lock()->add("key","value")->save();

use Exporter;
@ISA = qw(Exporter);
@EXPORT = qw(new rawdata add update delete save);

use Data::Dumper;

sub new {
    my $class = shift;
    my $file = shift;
    my $self = {
            "file" => $file,
            "lockdir" => sprintf("%s.lockdir", $file),
            "lockRetry" => 5,
            "lockSleep" => 1,
            "lockTimeout" => 60,
    };
    eval {
        my @tmp = _readFileAsArray($self, $self->{"file"});
    };
    if ($@) {
        print STDERR "create file=[".$self->{file}."]";
        system("touch $self->{file}");
        system("chmod 666 $self->{file}");        
    }
    my @lines = _readFileAsArray($self, $self->{"file"});
    $self->{"data"} = _parse(@lines);

    return bless $self, $class;
}

sub toString($) {
    my $self = shift;
    $self->info();
}

sub info($) {
    my $self = shift;
    return sprintf("KVS: file=[%s]",$self->{"file"});
}

sub get($$) {
    my $self = shift;
    my $key = shift;
    return $self->_decode( $self->{"data"}->{$key} );
}

sub keys($) {
    my $self = shift;
    if ($self->{"data"}) {
        return keys( %{$self->{"data"}} );
    } else {
        return undef;
    }
}

sub add($$$) {
    my $self = shift;
    my $key = shift;
    my $value = shift;
    if (! $key ) { return "ERR:empty key"; }
    if (! $value ) { return "ERR:empty value"; }
    if ($key =~ m|\s| ) { return "ERR:invalid key"; }
    $self->{"data"}->{$key} = $self->_encode($value);
    return $self;
}

sub update($$$) {
    my $self = shift;
    my $key = shift;
    my $value = shift;
    return $self->updateForce($key, $value);
}

sub updateForce($$$) {
    my $self = shift;
    my $key = shift;
    my $value = shift;
    if (! $key ) { return "ERR:empty key"; }
    if ($key =~ m|\s| ) { return "ERR:invalid key"; }
    $self->{"data"}->{$key} = $self->_encode($value);
    return $self;
}

sub delete($$) {
    my $self = shift;
    my $key = shift;
    if ($key =~ m|\s| ) { return "ERR:invalid key"; }
    if (!$self->{"data"}->{$key}) { return "ERR:key $key NOT exist."; }
    undef($self->{"data"}->{$key});
    return $self;
}

sub lock($) {
    my $self = shift;
    my $lockdir = $self->{"lockdir"};
    my $retry = $self->{"lockRetry"};

    my $lockCreatedAfterDay = -M $lockdir;
    my $lockCreatedAfterSec = $lockCreatedAfterDay * 24 * 60 * 60;
    if ($lockCreatedAfterSec > $self->{"lockTimeout"}) { # Danger!
        rmdir($lockdir);
        printf STDERR ("lock [ %s ] timed out.", $lockdir);
    }

    while( !mkdir($lockdir, 0777)) {
        if (--$retry <= 0) { die("BUSY: $lockdir"); }
        sleep($self->{"lockSleep"});
    }

    return $self;
}

# TODO: lock
sub save($) {
    my $self = shift;
    open (OUT, "> $self->{file}") || die $self->{"file"} . " : " . $!;
    foreach my $key (sort keys (%{$self->{"data"}})) {
        next unless $self->{"data"}->{$key};
        printf OUT ("%s\t%s\r\n", $key, $self->{"data"}->{$key});
    }
    close(OUT);

    eval {
        rmdir($self->{"lockdir"});
    };

    return $self;
}


sub unlock($) {
    my $self = shift;
    eval {
        rmdir($self->{"lockdir"});
    };
    return $self;
}

sub _encode($$) {
    my $self = shift;
    my $msg = shift;
    $msg =~ s|&|&amp;|g;
    $msg =~ s|\t|&tab;|g;
    $msg =~ s|\x0D|&x0D;|g;
    $msg =~ s|\x0A|&x0A;|g;
    return $msg;
}

sub _decode($$) {
    my $self = shift;
    my $msg = shift;
    $msg =~ s|&x0A;|\x0A|g;
    $msg =~ s|&x0D;|\x0D|g;
    $msg =~ s|&tab;|\t|g;
    $msg =~ s|&amp;|&|g;
    return $msg;
}


sub _readFileAsArray($$) {
    my $self = shift;
    my $file = shift;
    open (IN, $file) || die "read from $file : $!";
    my @lines = <IN>;
    close (IN);
    return @lines;
}



# data format
#
# source:
#   aaa <TAB> We invite strippers, jfk, and stalin. <CR><LF>
#   bbb <TAB> We invite strippers, jfk and stalin. <CR><LF>
#
# data
# {
#    "aaa" => "We invite strippers, jfk, and stalin.",
#    "bbb" => "We invite strippers, jfk and stalin."
# }
sub _parse(@) {
    my @lines = @_;
    my $hashref;

    foreach my $line (@lines) {
        my ($key, $value) = split("\t", $line, 2);
        $value =~ s/(\r|\n)//g;
        if ($value) {
            $hashref->{$key} = $value;
        }
    }

    return $hashref;
}

1;

ハッシュをJson形式を経由してKVSっぽくファイルで読み書きする簡易DBライブラリ

package JsonDB;

# How to use
# use lib "/path/of/KVS.pm/directory/";
# use JsonDB;
# my $jsonDB = JsonDB->new("/path/of/jsondb.tsv");
#
# $jsonDB->lock();
# my $hashref = $jsonDB->get("fuga");  # { "key1" => "value1" ,"key2" => [ 1 , 2 , 3 ] }
# $jsonDB->set("hoge", {"time"=>time(), "pid"=>$$ , "x"=>"XXX"});
# $jsonDB->delete("xxx");
# $jsonDB->save();


use JSON;
use Data::Dumper;
use KVS;

sub new() {
    my $class = shift;
    my $file = shift;
    my $kvs = KVS->new($file);
    my $self = { "kvs" => $kvs };
    return bless $self, $class;
}

sub kvs($) {
    my $self = shift;
    return $self->{"kvs"};
}

sub keys($) {
    my $self = shift;
    return $self->kvs()->keys();
}

sub get($$) {
    my $self = shift;
    my $key = shift;
    my $raw = $self->kvs()->get($key);
    return $raw ? decode_json($raw) : {};  # (String)'{ hoge: 123 , fuga: [ "A", "B"] }'  ->  (Ref){ "hoge" => 123, "fuga" => ["A" , "B"] }
}

sub set($$$) {
    my $self = shift;
    my $key = shift;
    my $value = shift;
    my $encoded = encode_json($value); #  (Ref){ "hoge" => 123, "fuga" => ["A" , "B"] }  ->  (String)'{ hoge: 123 , fuga: [ "A", "B"] }'
    $self->kvs()->updateForce($key,$encoded);
    return $self;
}

sub delete($$) {
    my $self = shift;
    my $key = shift;
    $self->kvs()->delete($key);
    return $self;
}

sub lock($) {
    my $self = shift;
    $self->kvs()->lock();
    return $self;
}

sub save($) {
    my $self = shift;
    $self->kvs()->save();
    return $self;    
}


1;

せつめい

設置場所とかuseするパスとかは、perlのモジュール検索パスやuse指定時のパス階層のルールに従って、適当に掘って配置しておいてください。
置き場所次第では、JsonDB.pm上で use KVS; している箇所を、たとえば use Path::Of::KVS; みたいに書き換える必要はあるかもしれません。

普通のKVSだとロックとかしないんですが、1個のファイルで1個のデータベースを取り扱う都合上、ロックの命令を足してあります。
別に lock しなくても良いけど、その場合はスレッドセーフではない挙動をするので、注意してください。スレッドセーフじゃなくても良いなら lock() しなくても良いです。あと、KVSっぽい実装のくせに save() 命令があります。save()しないとファイルに書き込まれません。もしlockした状態でsave()した場合、自動でアンロックされます。
ロックは60秒でタイムアウトします。

KVS.pm使用例

my $KVS = KVS->new( "/path/of/file.tsv" );
$KVS->lock();

# 読み込み
$value = $KVS->get("key");

# データの追加/更新
$KVS->add("NewKey", "New Value.");
$KVS->update("NewKey", "Updated Value.");
$KVS->updateForce("NewKey", "Updated Value.");

# データの削除
$KVS->delete("ExistedKey");

# 保存
$KVS->save() || die "fail to save"

# チェインさせてみる。
$KVS->lock()->add("key","value")->save();

JsonDB.pm使用例

my $jsonDB = JsonDB->new("/path/of/data/file/jsondb.tsv");

# ロック
$jsonDB->lock();

# データの読み込み。中身はこんなかんじ： { "key1" => "value1" ,"key2" => [ 1 , 2 , 3 ] }
my $hashref = $jsonDB->get("fuga"); 

# 書き込み(追加、上書き)
$jsonDB->set("key", {"time"=>time(), "pid"=>$$ , "x"=>"XXX"} );

# 削除
$jsonDB->delete("deleted_key");

# 保存
$jsonDB->save();

# 同じく一行でチェインさせてみる
$jsonDB->lock()->set("key2", {"hoge" => [1,2,3,4,5]})->save();

ライセンスは、そうね、うん。GPL2あたりで。
ライセンスの制限守ってくれるなら、無料で好きに使ってよいです。私への連絡も不要です。

ブログに貼り付けた後に思ったけど、ファイルが存在しない時に system 命令でtouchやchmodeしてるのは良くないよなぁ。

プアに生きてみる - ローエンドタブレット活用、安価サービス活用、あと微妙にIT開発関連など

インタプリタがperlくらいしか入ってない安いレンタルサーバ向けにKVSっぽいライブラリを書いてみた

ソースコード

せつめい

KVS.pm使用例

JsonDB.pm使用例