dslinux/user/perl/ext/GDBM_File GDBM_File.pm GDBM_File.xs Makefile.PL typemap

[cayenne]

Update of /cvsroot/dslinux/dslinux/user/perl/ext/GDBM_File
In directory antilope:/tmp/cvs-serv17422/ext/GDBM_File

Added Files:
	GDBM_File.pm GDBM_File.xs Makefile.PL typemap 
Log Message:
Adding fresh perl source to HEAD to branch from

--- NEW FILE: GDBM_File.xs ---
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"

#include <gdbm.h>
#include <fcntl.h>

typedef struct {
	GDBM_FILE 	dbp ;
	SV *    filter_fetch_key ;
	SV *    filter_store_key ;
	SV *    filter_fetch_value ;
	SV *    filter_store_value ;
	int     filtering ;
	} GDBM_File_type;

typedef GDBM_File_type * GDBM_File ;
typedef datum datum_key ;
typedef datum datum_value ;
typedef datum datum_key_copy;

#define GDBM_BLOCKSIZE 0 /* gdbm defaults to stat blocksize */

typedef void (*FATALFUNC)();

#ifndef GDBM_FAST
static int
not_here(char *s)
{
    croak("GDBM_File::%s not implemented on this architecture", s);
    return -1;
}
#endif

/* GDBM allocates the datum with system malloc() and expects the user
 * to free() it.  So we either have to free() it immediately, or have
 * perl free() it when it deallocates the SV, depending on whether
 * perl uses malloc()/free() or not. */
static void
output_datum(pTHX_ SV *arg, char *str, int size)
{
	sv_setpvn(arg, str, size);
	free(str);
}

/* Versions of gdbm prior to 1.7x might not have the gdbm_sync,
   gdbm_exists, and gdbm_setopt functions.  Apparently Slackware
   (Linux) 2.1 contains gdbm-1.5 (which dates back to 1991).
*/
#ifndef GDBM_FAST
#define gdbm_exists(db,key) not_here("gdbm_exists")
#define gdbm_sync(db) (void) not_here("gdbm_sync")
#define gdbm_setopt(db,optflag,optval,optlen) not_here("gdbm_setopt")
#endif

#include "const-c.inc"

MODULE = GDBM_File	PACKAGE = GDBM_File	PREFIX = gdbm_

INCLUDE: const-xs.inc

GDBM_File
gdbm_TIEHASH(dbtype, name, read_write, mode, fatal_func = (FATALFUNC)croak)
	char *		dbtype
	char *		name
	int		read_write
	int		mode
	FATALFUNC	fatal_func
	CODE:
	{
	    GDBM_FILE  	dbp ;

	    RETVAL = NULL ;
	    if ((dbp =  gdbm_open(name, GDBM_BLOCKSIZE, read_write, mode, fatal_func))) {
	        RETVAL = (GDBM_File)safemalloc(sizeof(GDBM_File_type)) ;
    	        Zero(RETVAL, 1, GDBM_File_type) ;
		RETVAL->dbp = dbp ;
	    }
	    
	}
	OUTPUT:
	  RETVAL
	

#define gdbm_close(db)			gdbm_close(db->dbp)
void
gdbm_close(db)
	GDBM_File	db
	CLEANUP:

void
gdbm_DESTROY(db)
	GDBM_File	db
	CODE:
	gdbm_close(db);
	safefree(db);

#define gdbm_FETCH(db,key)			gdbm_fetch(db->dbp,key)
datum_value
gdbm_FETCH(db, key)
	GDBM_File	db
	datum_key_copy	key

#define gdbm_STORE(db,key,value,flags)		gdbm_store(db->dbp,key,value,flags)
int
gdbm_STORE(db, key, value, flags = GDBM_REPLACE)
	GDBM_File	db
	datum_key	key
	datum_value	value
	int		flags
    CLEANUP:
	if (RETVAL) {
	    if (RETVAL < 0 && errno == EPERM)
		croak("No write permission to gdbm file");
	    croak("gdbm store returned %d, errno %d, key \"%.*s\"",
			RETVAL,errno,key.dsize,key.dptr);
	}

#define gdbm_DELETE(db,key)			gdbm_delete(db->dbp,key)
int
gdbm_DELETE(db, key)
	GDBM_File	db
	datum_key	key

#define gdbm_FIRSTKEY(db)			gdbm_firstkey(db->dbp)
datum_key
gdbm_FIRSTKEY(db)
	GDBM_File	db

#define gdbm_NEXTKEY(db,key)			gdbm_nextkey(db->dbp,key)
datum_key
gdbm_NEXTKEY(db, key)
	GDBM_File	db
	datum_key	key 

#define gdbm_reorganize(db)			gdbm_reorganize(db->dbp)
int
gdbm_reorganize(db)
	GDBM_File	db


#define gdbm_sync(db)				gdbm_sync(db->dbp)
void
gdbm_sync(db)
	GDBM_File	db

#define gdbm_EXISTS(db,key)			gdbm_exists(db->dbp,key)
int
gdbm_EXISTS(db, key)
	GDBM_File	db
	datum_key	key

#define gdbm_setopt(db,optflag, optval, optlen)	gdbm_setopt(db->dbp,optflag, optval, optlen)
int
gdbm_setopt (db, optflag, optval, optlen)
	GDBM_File	db
	int		optflag
	int		&optval
	int		optlen


SV *
filter_fetch_key(db, code)
	GDBM_File	db
	SV *		code
	SV *		RETVAL = &PL_sv_undef ;
	CODE:
	    DBM_setFilter(db->filter_fetch_key, code) ;

SV *
filter_store_key(db, code)
	GDBM_File	db
	SV *		code
	SV *		RETVAL =  &PL_sv_undef ;
	CODE:
	    DBM_setFilter(db->filter_store_key, code) ;

SV *
filter_fetch_value(db, code)
	GDBM_File	db
	SV *		code
	SV *		RETVAL =  &PL_sv_undef ;
	CODE:
	    DBM_setFilter(db->filter_fetch_value, code) ;

SV *
filter_store_value(db, code)
	GDBM_File	db
	SV *		code
	SV *		RETVAL =  &PL_sv_undef ;
	CODE:
	    DBM_setFilter(db->filter_store_value, code) ;


--- NEW FILE: typemap ---
#
#################################### DBM SECTION
#

datum_key		T_DATUM_K
datum_key_copy		T_DATUM_K
datum_value		T_DATUM_V
NDBM_File		T_PTROBJ
GDBM_File		T_PTROBJ
SDBM_File		T_PTROBJ
ODBM_File		T_PTROBJ
DB_File			T_PTROBJ
DBZ_File		T_PTROBJ
FATALFUNC		T_OPAQUEPTR

INPUT
T_DATUM_K
	DBM_ckFilter($arg, filter_store_key, \"filter_store_key\");
	$var.dptr = SvPVbyte($arg, PL_na);
	$var.dsize = (int)PL_na;
T_DATUM_K_C
	{
	    SV * tmpSV;
	    if (db->filter_store_key) {
	        tmpSV = sv_2mortal(newSVsv($arg)); 
	        DBM_ckFilter(tmpSV, filter_store_key, \"filter_store_key\");
            }
            else
                tmpSV = $arg;
	    $var.dptr = SvPVbyte(tmpSV, PL_na);
	    $var.dsize = (int)PL_na;
	}
T_DATUM_V
        DBM_ckFilter($arg, filter_store_value, \"filter_store_value\");
	if (SvOK($arg)) {
	    $var.dptr = SvPVbyte($arg, PL_na);
	    $var.dsize = (int)PL_na;
	}
	else {
	    $var.dptr = \"\";
	    $var.dsize = 0;
	}
OUTPUT
T_DATUM_K
	output_datum(aTHX_ $arg, $var.dptr, $var.dsize);
	DBM_ckFilter($arg, filter_fetch_key,\"filter_fetch_key\");
T_DATUM_V
	output_datum(aTHX_ $arg, $var.dptr, $var.dsize);
	DBM_ckFilter($arg, filter_fetch_value,\"filter_fetch_value\");
T_PTROBJ
        sv_setref_pv($arg, dbtype, (void*)$var);

--- NEW FILE: GDBM_File.pm ---
# GDBM_File.pm -- Perl 5 interface to GNU gdbm library.

=head1 NAME

GDBM_File - Perl5 access to the gdbm library.

=head1 SYNOPSIS

    use GDBM_File ;
    tie %hash, 'GDBM_File', $filename, &GDBM_WRCREAT, 0640;
    # Use the %hash array.
    untie %hash ;

=head1 DESCRIPTION

B<GDBM_File> is a module which allows Perl programs to make use of the
facilities provided by the GNU gdbm library.  If you intend to use this
module you should really have a copy of the gdbm manualpage at hand.

Most of the libgdbm.a functions are available through the GDBM_File
interface.

=head1 AVAILABILITY

gdbm is available from any GNU archive.  The master site is
C<ftp.gnu.org>, but you are strongly urged to use one of the many
mirrors.  You can obtain a list of mirror sites from
http://www.gnu.org/order/ftp.html.

=head1 BUGS

The available functions and the gdbm/perl interface need to be documented.

The GDBM error number and error message interface needs to be added.

=head1 SEE ALSO

L<perl(1)>, L<DB_File(3)>, L<perldbmfilter>. 

=cut

package GDBM_File;

use strict;
use warnings;
our($VERSION, @ISA, @EXPORT, $AUTOLOAD);

require Carp;
require Tie::Hash;
require Exporter;
use XSLoader ();
@ISA = qw(Tie::Hash Exporter);
@EXPORT = qw(
	GDBM_CACHESIZE
	GDBM_CENTFREE
	GDBM_COALESCEBLKS
	GDBM_FAST
	GDBM_FASTMODE
	GDBM_INSERT
	GDBM_NEWDB
	GDBM_NOLOCK
	GDBM_OPENMASK
	GDBM_READER
	GDBM_REPLACE
	GDBM_SYNC
	GDBM_SYNCMODE
	GDBM_WRCREAT
	GDBM_WRITER
);

$VERSION = "1.08";

sub AUTOLOAD {
    my($constname);
    ($constname = $AUTOLOAD) =~ s/.*:://;
    my ($error, $val) = constant($constname);
    Carp::croak $error if $error;
    no strict 'refs';
    *{$AUTOLOAD} = sub { $val };
    goto &{$AUTOLOAD};
}

XSLoader::load 'GDBM_File', $VERSION;

1;

--- NEW FILE: Makefile.PL ---
use ExtUtils::MakeMaker;
use ExtUtils::Constant 0.11 'WriteConstants';
WriteMakefile(
    NAME => 'GDBM_File',
    LIBS => ["-lgdbm", "-ldbm"],
    MAN3PODS 	=> {}, 	# Pods will be built by installman.
    XSPROTOARG => '-noprototypes', 		# XXX remove later?
    VERSION_FROM => 'GDBM_File.pm',
    realclean => {FILES=> 'const-c.inc const-xs.inc'},
);
WriteConstants(
    NAME => 'GDBM_File',
    DEFAULT_TYPE => 'IV',
    BREAKOUT_AT => 8,
    NAMES => [qw(GDBM_CACHESIZE GDBM_CENTFREE GDBM_COALESCEBLKS
		 GDBM_FAST GDBM_FASTMODE GDBM_INSERT GDBM_NEWDB GDBM_NOLOCK
		 GDBM_OPENMASK GDBM_READER GDBM_REPLACE GDBM_SYNC GDBM_SYNCMODE
		 GDBM_WRCREAT GDBM_WRITER)],
);