Article 11335 of comp.lang.perl:
Xref: feenix.metronet.com comp.lang.perl:11335 comp.databases:12309
Newsgroups: comp.lang.perl,comp.databases
Path: feenix.metronet.com!news.utdallas.edu!corpgate!bnrgate!nott!utnut!cs.utexas.edu!howland.reston.ans.net!agate!ames!decwrl!decwrl!netcomsv!netcom.com!conover
From: conover@netcom.com (John Conover)
Subject: Re: berkeley NDBM and perl
Message-ID: <conoverCME4zr.C3E@netcom.com>
Followup-To: poster
Keywords: NDBM perl btree
Organization: NETCOM On-line Communication Services (408 241-9760 guest)
Date: Wed, 9 Mar 1994 09:28:38 GMT
Lines: 1188

Attached are the sources that add btree file indexing to the Perl
programming language. The rationale behind adding btree operations to
the language are:

    1) It is a portable pseudo-4GL (depending on your POV) script
       language, that is readily available and widely used with good
       documentation and support from the user community.
    2) It has native inet (eg., sockets) capability which provides
       inter-operability.
    3) It has file/record locking capabilities, with deadlock
       detection/intervention provided by the fcntl() facility.
    4) It has native report generation/formatting facilities.

The btree library used is the BSD DBM library. The sources are
available by anonymous ftp from cs.berkeley.edu in
/ucb/4bsd/db*.tar.Z. Both the sources to the Perl program (available
by anonymous ftp from ftp.uu.net in the /languages/perl/perl*.tar.gz
directory,) and the BSD DBM library are necessary to add the btree
capability to Perl. There are no modifications to either of the
sources, and the native DBM capability of Perl is not altered. See the
README for particulars.

	john@johncon.com (John Conover)

#!/bin/sh
# This is a shell archive (produced by shar 3.49)
# To extract the files from this archive, save it to a file, remove
# everything above the "!/bin/sh" line above, and type "sh file_name".
#
# made 03/09/1994 08:32 UTC by john@johncon
# Source directory /home/john
#
# existing files will NOT be overwritten unless -c is specified
#
# This shar contains:
# length  mode       name
# ------ ---------- ------------------------------------------
#    791 -rw-r--r-- btreeperl/Makefile
#   1934 -rw-r--r-- btreeperl/README
#   8675 -rw-r--r-- btreeperl/btree.c
#   8789 -rwxr--r-- btreeperl/example.pl
#   8150 -rw-r--r-- btreeperl/btreeperl.man
#
# ============= btreeperl/Makefile ==============
if test ! -d 'btreeperl'; then
    echo 'x - creating directory btreeperl'
    mkdir 'btreeperl'
fi
if test -f 'btreeperl/Makefile' -a X"$1" != X"-c"; then
	echo 'x - skipping btreeperl/Makefile (File already exists)'
else
echo 'x - extracting btreeperl/Makefile (Text)'
sed 's/^X//' << 'SHAR_EOF' > 'btreeperl/Makefile' &&
# Makefile for btreeperl.
#
# Note that "LIBS" and "LDFLAGS" must be specified exactly as defined in
# config.sh from the perl source directory, with the BSD GDBM libraries
# concatenated at the end. This is particularly important for
# environments that support both BSD and SYSV variants of dbm/ndbm, (for
# example, SysV rel. 4.x.) Otherwise, btreeperl and real perl could have
# incompatible dbm functions.
#
# In my system, /usr/local/include is the path to the BSD GDBM ".h"
# files, /usr/local/lib is the path to the BSD GDBM library, "libdb.a".
#
LDFLAGS = -L/usr/ucblib
X
LIBS = -lsocket -lnsl -ldbm -lmalloc -lm -lx -lc -lucb -L/usr/local/lib -ldb
X
btreeperl: uperl.o btree.o
X	cc uperl.o btree.o $(LDFLAGS) $(LIBS) -o btreeperl
X
btree.o: btree.c
X	cc -c -I/usr/local/include btree.c
SHAR_EOF
chmod 0644 btreeperl/Makefile ||
echo 'restore of btreeperl/Makefile failed'
Wc_c="`wc -c < 'btreeperl/Makefile'`"
test 791 -eq "$Wc_c" ||
	echo 'btreeperl/Makefile: original size 791, current size' "$Wc_c"
fi
# ============= btreeperl/README ==============
if test -f 'btreeperl/README' -a X"$1" != X"-c"; then
	echo 'x - skipping btreeperl/README (File already exists)'
else
echo 'x - extracting btreeperl/README (Text)'
sed 's/^X//' << 'SHAR_EOF' > 'btreeperl/README' &&
In the perl source distribution directory there is an object module,
uperl.o, which is the complete perl program except for a single
undefined function, userinit ().  This function is called from perl's
initialization routines to provide the capability of adding functions,
written in C, to the perl program. See the README in the usub
directory of the perl sources for particulars.
X
The module, btree.c, exploits this capability to add the BSD NDBM
btree database functions to perl, and contains the userinit (),
usersub (), and userval () functions to enable the btree database
functions to be called directly from perl scripts.
X
These modifications to the perl program are free software, and can be
redistributed and/or modified, without any restrictions. It is
distributed with no warranty of any kind, implied or otherwise.
Specifically, there is no warranty of fitness for any particular
purpose and/or merchantability.
X
INSTALLATION:
X
The Perl program sources are available from ftp.uu.net in the
/languages/perl/perl*.tar.gz directory, and the BSD NDBM library
sources are available from cs.berkeley.edu in
/ucb/4bsd/db*.tar.Z. Obtain, compile, test, and install both.
X
The object module, uperl.o, and all of the .h files should be copied,
from the perl source directory, into this directory.
X
Edit the Makefile with the appropriate paths for your environment,
paying particular attention to the comments in the header of the
Makefile. Be sure that the compiler can find the BSD NDBM .h files.
X
Type make to compile the executable, btreeperl. This executable is the
same as the perl executable, except that all of the btree functions
are available to perl scripts.
X
An example program, "example.pl," is provided to exercise all of the
BSD NDBM btree functions-it is a simple key/data pair database, and
serves no other useful purpose than to test the functionality of the
btreeperl port.
X
X    john@johncon.com (John Conover)
X
SHAR_EOF
chmod 0644 btreeperl/README ||
echo 'restore of btreeperl/README failed'
Wc_c="`wc -c < 'btreeperl/README'`"
test 1934 -eq "$Wc_c" ||
	echo 'btreeperl/README: original size 1934, current size' "$Wc_c"
fi
# ============= btreeperl/btree.c ==============
if test -f 'btreeperl/btree.c' -a X"$1" != X"-c"; then
	echo 'x - skipping btreeperl/btree.c (File already exists)'
else
echo 'x - extracting btreeperl/btree.c (Text)'
sed 's/^X//' << 'SHAR_EOF' > 'btreeperl/btree.c' &&
/*
X
btree.c
X
In the perl source distribution directory there is an object module,
uperl.o, which is the complete perl program except for a single
undefined function, userinit ().  This function is called from perl's
initialization routines to provide the capability of adding functions,
written in C, to the perl program. See the README in the usub
directory of the perl sources for particulars.
X
This module, btree.c, exploits this capability to add the BSD NDBM
btree database functions to perl, and contains the userinit (),
usersub (), and userval () functions to enable the btree database
functions to be called directly from perl scripts.
X
These modifications to the perl program are free software, and can be
redistributed and/or modified, without any restrictions. It is
distributed with no warranty of any kind, implied or otherwise.
Specifically, there is no warranty of fitness for any particular
purpose and/or merchantability.
X
INSTALLATION:
X
The Perl program sources are available from ftp.uu.net in the
/languages/perl/perl*.tar.gz directory, and the BSD NDBM library
sources are available from cs.berkeley.edu in
/ucb/4bsd/db*.tar.Z. Obtain, compile, test, and install both.
X
The object module, uperl.o, and all of the .h files should be copied,
from the perl source directory, into this directory.
X
Edit the Makefile with the appropriate paths for your environment,
paying particular attention to the comments in the header of the
Makefile. Be sure that the compiler can find the BSD NDBM .h files.
X
Type make to compile the executable, btreeperl. This executable is the
same as the perl executable, except that all of the btree functions
are available to perl scripts.
X
X    john@johncon.com (John Conover)
X
*/
X
#include <fcntl.h>
X
/* perl .h files. */
X
#include "EXTERN.h"
#include "perl.h"
X
/* BSD GDBM .h files. */
X
#include <db.h>
X
#define MAGICVAR(name,ix) uf.uf_index = ix, magicname (name, &uf, sizeof (uf))
X
#define	DB_FLAGS (DB_LOCK | DB_SHMEM | DB_TXN)
#define	USE_OPEN_FLAGS (O_CREAT | O_EXCL | O_EXLOCK | O_NONBLOCK | O_RDONLY | O_RDWR | O_SHLOCK | O_TRUNC)
X
int bterror = 0;
X
#ifdef __STDC__
X
extern DB *__bt_open (const char *fname, int flags, int mode, const BTREEINFO *openinfo, int dflags);
X
int userinit (void);
X
static int usersub (int ix, int sp, int items);
static int userval (int ix, STR * str);
X
#else
X
extern DB *__bt_open ();
X
int userinit ();
X
static int usersub ();
static int userval ();
X
#endif
X
static enum uservars /* btree variable names, pre-pended with "UV_" */
{
X    UV_bterror
};
X
static enum usersubs /* btree function names, pre-pended with "US_" */
{
X    US_btopen,
X    US_btclose,
X    US_btsync,
X    US_btseq,
X    US_btput,
X    US_btget,
X    US_btdel
};
X
/*
X
install btree variables and functions in perl
X
*/
X
#ifdef __STDC__
X
int userinit (void)
X
#else
X
int userinit ()
X
#endif
X
{
X    char *filename = "btree.c";
X
X    struct ufuncs uf;
X
X    uf.uf_val = userval;
X
X    MAGICVAR ("bterror", UV_bterror);
X
X    make_usub ("btopen", US_btopen, usersub, filename);
X    make_usub ("btclose", US_btclose, usersub, filename);
X    make_usub ("btsync", US_btsync, usersub, filename);
X    make_usub ("btseq", US_btseq, usersub, filename);
X    make_usub ("btput", US_btput, usersub, filename);
X    make_usub ("btget", US_btget, usersub, filename);
X    make_usub ("btdel", US_btdel, usersub, filename);
X
X    return (0);
}
X
/*
X
btree function calls-simply a case statement on the usersubs enumeration
X
*/
X
#ifdef __STDC__
X
static int usersub (int ix, int sp, int items)
X
#else
X
static int usersub (ix, sp, items)
X    int ix;
X    int sp;
X    int items;
X
#endif
X
{
X    STR *Str; /* used in str_get and str_gnum macros */
X    STR **st = stack->ary_array + sp;
X
X    switch (ix)
X    {
X
X	case US_btopen:
X
X	    if (items != 4)
X	    {
X		fatal ("Usage: &btopen($fname, $flags, $mode, $duplicates)");
X	    }
X
X	    else
X	    {
X		DB *retval = 0;
X		BTREEINFO openinfo;
X		char *fname = str_get (st[1]);
X		int flags = str_gnum (st[2]);
X		int mode = str_gnum (st[3]);
X		int duplicates	= str_gnum (st[4]);
X
X		bterror = 0;
X
X		openinfo.flags = 0;
X		openinfo.cachesize = 0;
X		openinfo.maxkeypage = 0;
X		openinfo.minkeypage = 0;
X		openinfo.psize = 0;
X		openinfo.compare = NULL;
X		openinfo.prefix = NULL;
X		openinfo.lorder = 0;
X
X		openinfo.flags = (openinfo.flags | duplicates);
X
X		if ((flags & ~(USE_OPEN_FLAGS | DB_FLAGS)) == 0)
X		{
X
X		    if ((retval = __bt_open (fname, flags & USE_OPEN_FLAGS, mode, &openinfo, flags & DB_FLAGS)) == 0)
X		    {
X			bterror = 1;
X		    }
X
X		}
X
X		str_nset (st[0], (char*) &retval, sizeof (retval));
X	    }
X
X	    return (sp);
X
X	case US_btclose:
X
X	    if (items != 1)
X	    {
X		fatal ("Usage: &btclose($db)");
X	    }
X
X	    else
X	    {
X		int retval = 0;
X		DB *db = *(DB **) str_get (st[1]);
X
X		bterror = 0;
X
X		if ((retval = (db->sync)(db,0)) != RET_ERROR)
X		{
X
X		    if ((retval = (db->close)(db)) == RET_ERROR)
X		    {
X			bterror = 1;
X		    }
X
X		}
X
X		else
X		{
X		    bterror = 1;
X		}
X
X
X		str_numset (st[0], (double) retval);
X	    }
X
X	    return (sp);
X
X	case US_btsync:
X
X	    if (items != 1)
X	    {
X		fatal ("Usage: &btsync($db)");
X	    }
X
X	    else
X	    {
X		int retval = 0;
X		DB *db = *(DB **) str_get (st[1]);
X
X		bterror = 0;
X
X		if ((retval = (db->sync)(db,0)) == RET_ERROR)
X		{
X		    bterror = 1;
X		}
X
X		str_numset (st[0], (double) retval);
X	    }
X
X	    return (sp);
X
X	case US_btseq:
X
X	    if (items != 6)
X	    {
X		fatal ("Usage: &btseq($db, $key, $key_size, $data, $data_size, $mode)");
X	    }
X
X	    else
X	    {
X		int retval = 0;
X		DBT send_key;
X		DBT data_key;
X		DB *db = *(DB **) str_get (st[1]);
X		char *key = str_get (st[2]);
X		int key_size = str_gnum (st[3]);
X		char *data = str_get (st[4]);
X		int data_size = str_gnum (st[5]);
X		int mode = str_gnum (st[6]);
X
X		bterror = 0;
X
X		send_key.data = key;
X		send_key.size = key_size;
X
X		data_key.data = data;
X		data_key.size = data_size;
X
X		if ((retval = (*db->seq)(db, &send_key, &data_key, mode)) == RET_SUCCESS)
X		{
X		    str_nset (st[4], (char*) data_key.data, data_key.size);
X		    str_numset (st[5], (double) data_key.size);
X		}
X
X		else
X		{
X		    bterror = retval;
X		}
X
X		str_numset (st[0], (double) retval);
X	    }
X
X	    return (sp);
X
X	case US_btput:
X
X	    if (items != 6)
X	    {
X		fatal ("Usage: &btput($db, $key, $key_size, $data, $data_size, $mode)");
X	    }
X
X	    else
X	    {
X		int retval = 0;
X		DBT send_key;
X		DBT data_key;
X		DB *db = *(DB **) str_get (st[1]);
X		char *key = str_get (st[2]);
X		int key_size = str_gnum (st[3]);
X		char *data = str_get (st[4]);
X		int data_size = str_gnum (st[5]);
X		int mode = str_gnum (st[6]);
X
X		bterror = 0;
X
X		send_key.data = key;
X		send_key.size = key_size;
X
X		data_key.data = data;
X		data_key.size = data_size;
X
X		if ((retval = (db->put)(db, &send_key, &data_key, mode)) != RET_SUCCESS)
X		{
X		    bterror = retval;
X		}
X
X		str_numset (st[0], (double) retval);
X	    }
X
X	    return (sp);
X
X	case US_btget:
X
X	    if (items != 6)
X	    {
X		fatal ("Usage: &btget($db, $key, $key_size, $data, $data_size, $mode)");
X	    }
X
X	    else
X	    {
X		int retval = 0;
X		DBT send_key;
X		DBT data_key;
X		DB *db = *(DB **) str_get (st[1]);
X		char *key = str_get (st[2]);
X		int key_size = str_gnum (st[3]);
X		char *data = str_get (st[4]);
X		int data_size = str_gnum (st[5]);
X		int mode = str_gnum (st[6]);
X
X		bterror = 0;
X
X		send_key.data = key;
X		send_key.size = key_size;
X
X		data_key.data = data;
X		data_key.size = data_size;
X
X		if ((retval = (db->get)(db, &send_key, &data_key, mode)) == RET_SUCCESS)
X		{
X		    str_nset (st[4], (char*) data_key.data, data_key.size);
X		    str_numset (st[5], (double) data_key.size);
X		}
X
X		else
X		{
X		    bterror = retval;
X		}
X
X		str_numset (st[0], (double) retval);
X	    }
X
X	    return (sp);
X
X	case US_btdel:
X
X	    if (items != 4)
X	    {
X		fatal ("Usage: &btdel($db, $key, $key_size, $mode)");
X	    }
X
X	    else
X	    {
X		int retval = 0;
X		DBT send_key;
X		DB *db = *(DB **) str_get (st[1]);
X		char *key = str_get (st[2]);
X		int key_size = str_gnum (st[3]);
X		int mode = str_gnum (st[4]);
X
X		bterror = 0;
X
X		send_key.data = key;
X		send_key.size = key_size;
X
X		if ((retval = (db->del)(db, &send_key, mode)) != RET_SUCCESS)
X		{
X		    bterror = retval;
X		}
X
X		str_numset (st[0], (double) retval);
X	    }
X
X	    return (sp);
X
X	default:
X
X	    fatal ("Unimplemented user-defined subroutine");
X
X    }
X
X    return (0);
}
X
/*
X
btree variable calls-simply a case statement on the uservars enumeration
X
*/
X
#ifdef __STDC__
X
static int userval (int ix, STR * str)
X
#else
X
static int userval (ix, str)
X    int ix;
X    STR *str;
X
#endif
X
{
X
X    switch (ix)
X    {
X
X	case UV_bterror:
X
X	    str_numset (str, (double) bterror);
X	    break;
X
X	default:
X
X	    fatal ("Unimplemented user-defined variable");
X
X    }
X
X    return (0);
}
SHAR_EOF
chmod 0644 btreeperl/btree.c ||
echo 'restore of btreeperl/btree.c failed'
Wc_c="`wc -c < 'btreeperl/btree.c'`"
test 8675 -eq "$Wc_c" ||
	echo 'btreeperl/btree.c: original size 8675, current size' "$Wc_c"
fi
# ============= btreeperl/example.pl ==============
if test -f 'btreeperl/example.pl' -a X"$1" != X"-c"; then
	echo 'x - skipping btreeperl/example.pl (File already exists)'
else
echo 'x - extracting btreeperl/example.pl (Text)'
sed 's/^X//' << 'SHAR_EOF' > 'btreeperl/example.pl' &&
#!btreeperl
X
# this is an example of using btreeperl to exercise all of the libdb.a
# btree functions-it is a simple database, and serves no other useful
# purpose than to test the functionality of the btreeperl port
X
# require 'db.ph'; # db.h #define's, make this by h2ph < db.h > db.ph-db.h is from the libdb.a source directory
X
X
# the following variable setup was "cut" from 'db.ph' to facilitate
# loading of this script-and the perl variable setup of libdb.a btree
# #define's, as per page 396 of "Programming Perl," Larry Wall and
# Randal Schwartz
X
eval 'sub RET_ERROR {-1;}';
$RET_ERROR = &RET_ERROR;
eval 'sub RET_SUCCESS {0;}';
$RET_SUCCESS = &RET_SUCCESS;
eval 'sub RET_SPECIAL {1;}';
$RET_SPECIAL = &RET_SPECIAL;
eval 'sub R_CURSOR {1;}';
$R_CURSOR = &R_CURSOR;
eval 'sub R_FIRST {3;}';
$R_FIRST = &R_FIRST;
eval 'sub R_LAST {6;}';
$R_LAST = &R_LAST;
eval 'sub R_NEXT {7;}';
$R_NEXT = &R_NEXT;
eval 'sub R_NOOVERWRITE {8;}';
$R_NOOVERWRITE = &R_NOOVERWRITE;
eval 'sub R_PREV {9;}';
$R_PREV = &R_PREV;
X
# require 'fcntl.ph'; # fcntl.h #define's, make this by h2ph < fcntl.h > fcntl.h
X
# the following variable setup was "cut" from 'fcntl.ph' to facilitate
# loading of this script-and the perl variable setup of the 'fcntl.ph'
# #define's, as per page 396 of "Programming Perl," Larry Wall and
# Randal Schwartz
X
eval 'sub O_RDWR {2;}';
$O_RDWR = &O_RDWR;
eval 'sub O_CREAT {0x100;}';
$O_CREAT = &O_CREAT;
X
$db = &btopen ("example.db", $O_CREAT | $O_RDWR, 0600, 0); # open the database
X
if ($bterror != 0) # database open?
{
X    print "Error opening database\n"; # no, print the error and exit
X    exit (1);
}
X
$key = ""; # key of key/data pairs
$key_size = 0; # length of key in key/data pairs
X
$data = ""; # data of key/data pairs
$data_size = 0; # length of data in key/data pairs
X
$retval = 0; # return value from any btree function call
X
$operation = ""; # user response to the interactive prompt
X
while ($operation ne "q") # while the user response to the interactive prompt is not "quit"
{
X    print "\nnon-cursor database operations:\n"; # print the prompts
X    print "A) Add key/data pair, D) Delete key/data pair, F) Fetch key/data pair\n";
X    print "\ncursor database operations:\n";
X    print "c) move cursor to key/data pair, d) delete key/data pair referenced by cursor\n";
X    print "f) move cursor to first key/data pair, l) move cursor to last key/data pair\n";
X    print "n) move cursor to next key/data pair, p) move cursor to previous key/data pair\n";
X    print "r) replace key/data pair referenced by cursor\n";
X    print "\nfile operations:\n";
X    print "(q quit (s sync\n";
X    print "\nchoice: ";
X
X    $operation = <STDIN>; # get the user response
X    chop ($operation); # chop the trailing EOL character from the user response
X
X    if ($operation eq "A") # user response a request to add a key/data pair?
X    {
X	print "Key: "; # yes, prompt for a key
X	$key = <STDIN>; # get the key
X	chop ($key); # chop the trailing EOL character from the key
X	$key_size = length ($key) + 1; # save the key's length
X	print "Data: "; # prompt for the key's data
X	$data = <STDIN>; # get the key's data
X	chop ($data); # chop the trailing EOL character from the key
X	$data_size =  length ($data) + 1; # save the key's data's length
X
X	if (($retval = &btput ($db, $key, $key_size, $data, $data_size, $R_NOOVERWRITE)) != 0) # add the key/data pair
X	{
X	    print "Error inserting key/data pair\n"; # couldn't add the key/data pair, print the error
X	}
X
X    }
X
X    elsif ($operation eq "D") # user response a request to delete a key/data pair?
X    {
X	print "Key: "; # yes, prompt for a key
X	$key = <STDIN>; # get the key
X	chop ($key); # chop the trailing EOL character from the key
X	$key_size = length ($key) + 1; # save the key's length
X
X	$data = ""; # null the data
X	$data_size =  0; # null the data's length
X
X	if (($retval = &btdel ($db, $key, $key_size, 0)) != 0) # delete the key/data pair
X	{
X	    print "Error deleting key/data pair\n"; # couldn't delete the key/data pair, print the error
X	}
X
X    }
X
X    elsif ($operation eq "F") # user response a request to fetch a key/data pair?
X    {
X	print "Key: "; # yes, prompt for a key
X	$key = <STDIN>; # get the key
X	chop ($key); # chop the trailing EOL character from the key
X	$key_size = length ($key) + 1; # save the key's length
X
X	$data = ""; # null the data
X	$data_size =  0; # null the data's length
X
X	if (($retval = &btget ($db, $key, $key_size, $data, $data_size, 0)) != 0) # fetch the key/data pair
X	{
X	    print "Error getting key/data pair\n"; # couldn't fetch the key/data pair, print the error
X	}
X
X	else
X	{
X	    print "$data\n"; # fetched the key/data pair, print it
X	}
X
X    }
X
X    elsif ($operation eq "c") # user response a request to reference a key/data pair?
X    {
X	print "Key: "; # yes, prompt for a key
X	$key = <STDIN>; # get the key
X	chop ($key); # chop the trailing EOL character from the key
X	$key_size = length ($key) + 1; # save the key's length
X
X	$data = ""; # null the data
X	$data_size =  0; # null the data's length
X
X	if (($retval = &btseq ($db, $key, $key_size, $data, $data_size, $R_CURSOR)) != 0)
X	{
X	    print "Error getting key/data pair\n";
X	}
X
X	else
X	{
X	    print "$data\n"; # referenced the key/data pair, print it
X	}
X
X    }
X
X    elsif ($operation eq "d") # user response a request to delete the key/data pair referenced by the cursor?
X    {
X
X	if (($retval = &btdel ($db, $key, $key_size, $R_CURSOR)) != 0) # yes, delet the key/data pair referenced by the cursor
X	{
X	    print "Error deleting key/data pair\n"; # couldn't delete the key/data pair referenced by the cursor, print the error
X	}
X
X    }
X
X    elsif ($operation eq "f") # user response a request to move cursor to first key/data pair?
X    {
X
X	if (($retval = &btseq ($db, $key, $key_size, $data, $data_size, $R_FIRST)) != 0) # yes, move the cursor to the first key/data pair
X	{
X	    print "Error getting key/data pair\n"; # couldn't move the cursor to the first key/data pair, print the error
X	}
X
X	else
X	{
X	    print "$data\n"; # moved the cursor to the first key/data pair, print it
X	}
X
X    }
X
X    elsif ($operation eq "l") # user response a request to move cursor to last key/data pair?
X    {
X
X	if (($retval = &btseq ($db, $key, $key_size, $data, $data_size, $R_LAST)) != 0) # yes, move the cursor to the last key/data pair
X	{
X	    print "Error getting key/data pair\n"; # couldn't move the cursor to the last key/data pair, print the error
X	}
X
X	else
X	{
X	    print "$data\n"; # moved the cursor to the last key/data pair, print it
X	}
X
X    }
X
X    elsif ($operation eq "n") # user response a request to move cursor to next key/data pair?
X    {
X
X	if (($retval = &btseq ($db, $key, $key_size, $data, $data_size, $R_NEXT)) != 0) # yes, move the cursor to the next key/data pair
X	{
X	    print "Error getting key/data pair\n"; # couldn't move the cursor to the next key/data pair, print the error
X	}
X
X	else
X	{
X	    print "$data\n"; # moved the cursor to the next key/data pair, print it
X	}
X
X    }
X
X    elsif ($operation eq "p") # user response a request to move cursor to previous key/data pair?
X    {
X
X	if (($retval = &btseq ($db, $key, $key_size, $data, $data_size, $R_PREV)) != 0) # yes, move the cursor to the previous key/data pair
X	{
X	    print "Error getting key/data pair\n"; # couldn't move the cursor to the previous key/data pair, print the error
X	}
X
X	else
X	{
X	    print "$data\n"; # moved the cursor to the previous key/data pair, print it
X	}
X
X    }
X
X    elsif ($operation eq "r") # user response a request to replace key/data pair referenced by cursor?
X    {
X	print "Key: "; # yes, prompt for a key
X	$key = <STDIN>; # get the key
X	chop ($key); # chop the trailing EOL character from the key
X	$key_size = length ($key) + 1; # save the key's length
X	print "Data: "; # prompt for the key's data
X	$data = <STDIN>; # get the key's data
X	chop ($data); # chop the trailing EOL character from the key
X	$data_size =  length ($data) + 1; # save the key's data's length
X
X	if (($retval = &btput ($db, $key, $key_size, $data, $data_size, $R_CURSOR)) != 0) # replace the key/data pair referenced by the cursor
X	{
X	    print "Error inserting key/data pair\n"; # couldn't replace the key/data pair referenced by the cursor, print the error
X	}
X
X    }
X
X    elsif ($operation eq  "q") # user response a request to exit the script?
X    {
X
X	if (($retval = &btclose ($db)) == $RET_ERROR) # yes, close the database
X	{
X	    print "Error closing database\n"; # couldn't close the database, print the error
X	}
X
X    }
X
X    elsif ($operation eq "s") # user response a request to sync?
X    {
X
X	if (($retval = &btsync ($db)) != 0) # yes, sync the database
X	{
X	    print "Error in sync\n"; # couldn't sync the database, print the error
X	}
X
X    }
X
X    else # none of the above is an error
X    {
X	print "Unrecognized operation\n" # print the error
X    }
X
}
SHAR_EOF
chmod 0744 btreeperl/example.pl ||
echo 'restore of btreeperl/example.pl failed'
Wc_c="`wc -c < 'btreeperl/example.pl'`"
test 8789 -eq "$Wc_c" ||
	echo 'btreeperl/example.pl: original size 8789, current size' "$Wc_c"
fi
# ============= btreeperl/btreeperl.man ==============
if test -f 'btreeperl/btreeperl.man' -a X"$1" != X"-c"; then
	echo 'x - skipping btreeperl/btreeperl.man (File already exists)'
else
echo 'x - extracting btreeperl/btreeperl.man (Text)'
sed 's/^X//' << 'SHAR_EOF' > 'btreeperl/btreeperl.man' &&
X
X
X
BTREEPERL(1)		 USER COMMANDS		     BTREEPERL(1)
X
X
X
NNNNAAAAMMMMEEEE
X     btreeperl - btree extensions to the Perl Programming Language
X
DDDDEEEESSSSCCCCRRRRIIIIPPPPTTTTIIIIOOOONNNN
X     In the perl source distribution directory there is an object
X     module, uperl.o, which is the complete perl program except for a
X     single undefined function, userinit ().  This function is called
X     from perl's initialization routines to provide the capability of
X     adding functions, written in C, to the perl program. See the
X     README in the usub directory of the perl sources for particulars.
X
X     The BSD NDBM database library contains btree file index functions
X     which were added to the perl program to enable the btree database
X     functions to be called directly from perl scripts. The functions
X     added are:
X
X     $db = &btopen ($fname, $flags, $mode, $duplicates) opens a btree
X	 database file, where:
X
X	 $fname is the name of the database file.
X
X	 $flags is the logical "or" of any combination of $O_CREAT,
X	 $O_EXCL, $O_EXLOCK, $O_NONBLOCK, $O_RDONLY, $O_RDWR,
X	 $O_SHLOCK and $O_TRUNC-opening a database file $O_WRONLY is
X	 not possible. See fcntl(1), or equivalent, for the
X	 description of these flags.
X
X	 $mode is chmod(1) absolute mode permissions of the database
X	 file.
X
X	 $duplicates is either 0 if duplicate keys are not permitted,
X	 or $R_DUP if duplicate keys are permitted.
X
X	 The return value of &btopen() is a file reference to the open
X	 database on success (all operations on the database will be
X	 referenced via this return value,) or $bterror != 0 on
X	 failure.
X
X	 For example:
X
X	 $db = &btopen ("example.db", $O_CREAT | $O_RDWR, 0600, 0)
X
X	 if ($bterror != 0) # database open?
X	 {
X	     print "Error opening database\n";
X	     exit (1);
X	 }
X
X     $retval = &btclose ($db) closes a btree database file, where:
X
X	 $db is the database file reference returned by a successful
X	 call to &dbopen().
X
X	 The return value of &btclose() is $RET_SUCCESS if successful,
X	 and $RET_ERROR if not.
X
X	 For example:
X
X	 if (($retval = &btclose ($db)) != $RET_SUCCESS)
X	 {
X	     print "Error closing database\n";
X	 }
X
X     $retval = &btsync ($db) flush the cached data to the database
X	 file, where:
X
X	 $db is the database file reference returned by a successful
X	 call to &dbopen().
X
X	 The return value of &btsync() is $RET_SUCCESS if successful,
X	 and $RET_ERROR if not.
X
X	 For example:
X
X	 if (($retval = &btsync ($db)) != $RET_SUCCESS)
X	 {
X	     print "Error in sync\n";
X	 }
X
X     $retval = &btseq ($db, $key, $key_size, $data, $data_size, $mode)
X	 sets the database cursor to reference a key, where:
X
X	 $db is the database file reference returned by a successful
X	 call to &dbopen().
X
X	 $key is the key value to be referenced.
X
X	 $key_size is the length of the key value to be referenced
X	 (eg., via length ($key).)
X
X	 $data will contain the data of the key/data pair on
X	 successful completion.
X
X	 $data_size will contain the length of the data on successful
X	 completion.
X
X	 $mode specifies the mode sequence, and is any one of
X	 $R_CURSOR, to return the data from the specified key,
X	 $R_FIRST, to return the data from the first key in the
X	 database, $R_LAST, to return the data from the last key in
X	 the database, $R_NEXT to return the data from the next key in
X	 the database, or $R_PREVIOUS to return the data from the
X	 previous key in the database.	(Note that for $R_CURSOR, the
X	 returned key is not necessarily an exact match for the
X	 specified key.	 The returned key is the smallest key greater
X	 than or equal to the specified key, permitting partial key
X	 matches and range searches.)
X
X	 The return value of &btseq() is $RET_SUCCESS if successful,
X	 and $RET_ERROR if not.
X
X	 For example (for partial key searches):
X
X	 if (($retval = &btseq ($db, $key, $key_size, $data, \
X	 $data_size, $R_CURSOR)) != $RET_SUCCESS)
X	 {
X	     print "Error getting key/data pair\n";
X	 }
X
X	 else
X	 {
X	     print "$data\n";
X	 }
X
X	 and to get the data of the next key/data pair in the
X	 database:
X
X	 if (($retval = &btseq ($db, $key, $key_size, $data, \
X	 $data_size, $R_NEXT)) != $RET_SUCCESS)
X	 {
X	     print "Error getting key/data pair\n";
X	 }
X
X	 else
X	 {
X	     print "$data\n";
X	 }
X
X     $retval = &btput ($db, $key, $key_size, $data, $data_size, $mode)
X	 add a key/data pair to the database, where:
X
X	 $db is the database file reference returned by a successful
X	 call to &dbopen().
X
X	 $key is the key value by which the data will be referenced.
X
X	 $key_size is the length of the key value (eg., via length
X	 ($key).)
X
X	 $data is the data to be stored in the database.
X
X	 $data_size is the length of the data to be stored (eg., via
X	 length ($key).)
X
X	 $mode specifies the mode with which the data will be stored,
X	 and is any one of $R_CURSOR, to replace the key/data pair
X	 referenced by the cursor, $R_NOOVERWRITE to add the key/data
X	 pair only if the key does not exist, and $R_SETCURSOR to
X	 store the key/data pair, setting the cursor to reference this
X	 key/data pair.
X
X	 The return value of &btput() is $RET_SUCCESS if successful,
X	 and $RET_ERROR if not.
X
X	 For example:
X
X	 if (($retval = &btput ($db, $key, $key_size, $data, \
X	 $data_size, $R_NOOVERWRITE)) != $RET_SUCCESS)
X	 {
X	     print "Error inserting key/data pair\n";
X	 }
X
X	 will add the key/data pair to the database (but only if the
X	 key does not already exist in the database.)
X
X	 Or to replace the key/data pair referenced by the cursor:
X
X	 if (($retval = &btput ($db, $key, $key_size, $data, \
X	 $data_size, $R_CURSOR)) != $RET_SUCCESS)
X	 {
X	     print "Error inserting key/data pair\n";
X	 }
X
X     $retval = &btget ($db, $key, $key_size, $data, $data_size, $mode)
X	 to get a key/data pair from the database, where:
X
X	 $db is the database file reference returned by a successful
X	 call to &dbopen().
X
X	 $key is the key value to be referenced.
X
X	 $key_size is the length of the key value to be referenced
X	 (eg., via length ($key).)
X
X	 $data will contain the data of the key/data pair on
X	 successful completion.
X
X	 $data_size will contain the length of the data on successful
X	 completion.
X
X	 $mode is currently not used, and should be 0.
X
X	 The return value of &btget() is $RET_SUCCESS if successful,
X	 and $RET_ERROR if not.
X
X	 For example:
X
X	 if (($retval = &btget ($db, $key, $key_size, $data, \
X	 $data_size, 0)) != $RET_SUCCESS)
X	 {
X	     print "Error getting key/data pair\n";
X	 }
X
X	 else
X	 {
X	     print "$data\n";
X	 }
X
X     $retval = &btdel ($db, $key, $key_size, $mode) to delete a key
X	 from the database, where:
X
X	 $db is the database file reference returned by a successful
X	 call to &dbopen().
X
X	 $key is the key value of the key/data pair to be deleted.
X
X	 $key_size is the length of the key value to be deleted (eg.,
X	 via length ($key).)
X
X	 $mode specifies the mode with which the data will be deleted,
X	 and is either 0 to delete specified key, or $R_CURSOR to
X	 delete the key/data pair referenced by the cursor.
X
X	 $mode specifies the mode with which the data will be stored,
X	 and is any one of $R_CURSOR, to replace the key/data pair
X	 referenced by the cursor, $R_NOOVERWRITE to add the key/data
X	 pair only if the key does not exist, and $R_SETCURSOR to
X	 store the key/data pair, setting the cursor to reference this
X	 key/data pair.
X
X	 The return value of &btdel() is $RET_SUCCESS if successful,
X	 and $RET_ERROR if not.
X
X	 For example:
X
X	 if (($retval = &btdel ($db, $key, $key_size, 0)) != \
X	 $RET_SUCCESS)
X	 {
X	     print "Error deleting key/data pair\n";
X	 }
X
X	 would delete the specified key/data pair, or:
X
X	 if (($retval = &btdel ($db, $key, $key_size, $R_CURSOR)) \
X	 != 0)
X	 {
X	     print "Error deleting key/data pair\n"; 
X	 }
X
X	 would delete the key/data pair referenced by the cursor.
X
X     Error handling is through return values on all functions, except
X     &btopen(). The variable, $bterror, is set by all functions to 0
X     if the call to a function was successful, and 1 if it was not.
X
X     Comments may be addressed to john@johncon.com (John Conover).
X
SSSSEEEEEEEE AAAALLLLSSSSOOOO
X     perl(1), dbopen(3), btree(3), dbm(3), ndbm(3)
X
SHAR_EOF
chmod 0644 btreeperl/btreeperl.man ||
echo 'restore of btreeperl/btreeperl.man failed'
Wc_c="`wc -c < 'btreeperl/btreeperl.man'`"
test 8150 -eq "$Wc_c" ||
	echo 'btreeperl/btreeperl.man: original size 8150, current size' "$Wc_c"
fi
exit 0