#!/usr/local/bin/perl
# -------------------------------------------------------------------- #
#   btree-test.pl -- DB_File モジュールによる前方一致検索
#   Copyright 2000 Kawasaki Yusuke <u-suke@kawa.net>, Kappe Inc.
# -------------------------------------------------------------------- #
=tuc
【概要】
        Berkley_DB (DB_File) の BTREE 機能を用いると、連想配列のキーを
        前方一致で指定して、それにマッチする全てのキー＆値を取り出せる
        また BTREE なので、sort しなくても自動的にキーがソートされてる
【結果】
        all keys and values:        ← sort 指定しなくてもソートされている
                'nec'   = 'Lavie'
                'pana'  = 'Letsnote'
                'sharp' = 'Mebius'
                'sony'  = 'VAIO'
                'sotec' = 'eOne'
        's' matches 3 keys.         ← s で始まるキーのみ取り出した場合
                'otec'  = 'eOne'
                'harp'  = 'Mebius'
                'ony'   = 'VAIO'
        'so' matches 2 keys.        ← so で始まるキーのみ取り出した場合
                'tec'   = 'eOne'
                'ny'    = 'VAIO'
        'sony' matches 1 keys.      ← sony で始まるキーのみ取り出した場合
                ''      = 'VAIO'
        'hitachi' matches 0 keys.   ← hitachi で始まるキーは存在しない
【補足】
        get_lmatch_hash() 関数の $key = $1; の行をコメントアウトすると、
        マッチしたキーを取り出したときに、マッチしていた部分も保存される
        デフォルトでは、マッチしていた部分は削除している
【ダウンロード】
        http://www.kawa.net/works/perl/btree/btree-test.pl
=cut
# -------------------------------------------------------------------- #
    use strict;
    use DB_File;
    use Fcntl;
    &main();
# -------------------------------------------------------------------- #
sub main {
    my $tied;               # 川崎はリファレンスと my が好きなので（笑）
    my $iname = undef;      # 普通は "data.btree" 等ＤＢファイル名を指定
                            # ファイル名 undef を指定するとメモリ上で動く
                            # 今回はテストなので、メモリ上でいいでしょう
    my $otype = Fcntl::O_RDWR()|Fcntl::O_CREAT();   # 読み書き可能で開く
    my $omode = 0666;                               # 作成時は rx-rx-rx-
    my $dbopt = new DB_File::BTREEINFO();           # BTREE モードで開く

    my $dbobj = tie( %$tied, "DB_File", $iname, $otype, $omode, $dbopt )
                or die "$! '$iname'";               # 開けなければエラー

    $tied->{pana}   = "Letsnote";                   # 適当に値を代入する
    $tied->{sotec}  = "eOne";
    $tied->{sharp}  = "Mebius";
    $tied->{sony}   = "VAIO";
    $tied->{nec}    = "Lavie";

    print "all keys and values:\n";
    foreach my $key ( keys %$tied ) {               # 全てのキーを取り出す
        printf( "\t'%s'\t= '%s'\n", $key, $tied->{$key} );
    }

    foreach my $left (qw( s so sony hitachi )) {    # 前方一致で取り出す
        my $hash = &get_lmatch_hash( $dbobj, $left );
        printf( "'%s' matches %d keys.\n", $left, scalar keys %$hash );
        foreach my $key ( keys %$hash ) {
            printf( "\t'%s'\t= '%s'\n", $key, $hash->{$key} );
        }
    }
}
# -------------------------------------------------------------------- #
sub get_lmatch_hash {
    my $db   = shift;               # tie( %hash, "DB_File ) の返り値
    my $okey = shift;               # 前方一致マッチングしたいキー
    my $key  = $okey;               # 最初の seq() で指定するために
    my $value = "";                 # seq() 用のメモリ確保？
    my $opt  = DB_File::R_CURSOR(); # 前方一致指定オプション
    my $hash = {};
    while ( 1 ) {
        # １回目のみ＝前方一致で $key, $value を取り出す
        # ２回目以降＝Ｂ木の次の $key, $value を取り出す
        # 返り値が真の場合、ＤＢの末尾なので終了
        $db->seq( $key, $value, $opt ) and last;

        # 本当にキー前方一致しているか確認する
        last unless ( $key =~ /^\Q$okey\E(.*)$/s );

        $key = $1;                  # 指定キーの右側を取り出す
        $hash->{$key} = $value;     # ハッシュに突っ込む
        $opt = DB_File::R_NEXT();   # 次のキーを取り出すオプション
    }
    scalar keys %$hash ? $hash : undef;
}
# -------------------------------------------------------------------- #