virgin perl 5.6.0

7 files changed, 191 insertions, 73 deletions

diff --git a/gnu/usr.bin/perl/ext/SDBM_File/SDBM_File.xs b/gnu/usr.bin/perl/ext/SDBM_File/SDBM_File.xs
index 38eaebf5c5e..a4b90451a9b 100644
--- a/gnu/usr.bin/perl/ext/SDBM_File/SDBM_File.xs
+++ b/gnu/usr.bin/perl/ext/SDBM_File/SDBM_File.xs
@@ -1,15 +1,47 @@
+#define PERL_NO_GET_CONTEXT
 #include "EXTERN.h"
 #include "perl.h"
 #include "XSUB.h"
 #include "sdbm/sdbm.h"
 
-typedef DBM* SDBM_File;
+typedef struct {
+	DBM * 	dbp ;
+	SV *    filter_fetch_key ;
+	SV *    filter_store_key ;
+	SV *    filter_fetch_value ;
+	SV *    filter_store_value ;
+	int     filtering ;
+	} SDBM_File_type;
+
+typedef SDBM_File_type * SDBM_File ;
+typedef datum datum_key ;
+typedef datum datum_value ;
+
+#define ckFilter(arg,type,name)					\
+	if (db->type) {						\
+	    SV * save_defsv ;					\
+            /* printf("filtering %s\n", name) ;*/		\
+	    if (db->filtering)					\
+	        croak("recursion detected in %s", name) ;	\
+	    db->filtering = TRUE ;				\
+	    save_defsv = newSVsv(DEFSV) ;			\
+	    sv_setsv(DEFSV, arg) ;				\
+	    PUSHMARK(sp) ;					\
+	    (void) perl_call_sv(db->type, G_DISCARD|G_NOARGS); 	\
+	    sv_setsv(arg, DEFSV) ;				\
+	    sv_setsv(DEFSV, save_defsv) ;				\
+	    SvREFCNT_dec(save_defsv) ;				\
+	    db->filtering = FALSE ;				\
+	    /*printf("end of filtering %s\n", name) ;*/		\
+	}
+
 #define sdbm_TIEHASH(dbtype,filename,flags,mode) sdbm_open(filename,flags,mode)
-#define sdbm_FETCH(db,key)			sdbm_fetch(db,key)
-#define sdbm_STORE(db,key,value,flags)		sdbm_store(db,key,value,flags)
-#define sdbm_DELETE(db,key)			sdbm_delete(db,key)
-#define sdbm_FIRSTKEY(db)			sdbm_firstkey(db)
-#define sdbm_NEXTKEY(db,key)			sdbm_nextkey(db)
+#define sdbm_FETCH(db,key)			sdbm_fetch(db->dbp,key)
+#define sdbm_STORE(db,key,value,flags)		sdbm_store(db->dbp,key,value,flags)
+#define sdbm_DELETE(db,key)			sdbm_delete(db->dbp,key)
+#define sdbm_EXISTS(db,key)			sdbm_exists(db->dbp,key)
+#define sdbm_FIRSTKEY(db)			sdbm_firstkey(db->dbp)
+#define sdbm_NEXTKEY(db,key)			sdbm_nextkey(db->dbp)
 
 
 MODULE = SDBM_File	PACKAGE = SDBM_File	PREFIX = sdbm_
@@ -20,23 +52,46 @@ sdbm_TIEHASH(dbtype, filename, flags, mode)
 	char *		filename
 	int		flags
 	int		mode
+	CODE:
+	{
+	    DBM * 	dbp ;
+
+	    RETVAL = NULL ;
+	    if (dbp = sdbm_open(filename,flags,mode) ) {
+	        RETVAL = (SDBM_File)safemalloc(sizeof(SDBM_File_type)) ;
+    	        Zero(RETVAL, 1, SDBM_File_type) ;
+		RETVAL->dbp = dbp ;
+	    }
+	    
+	}
+	OUTPUT:
+	  RETVAL
 
 void
 sdbm_DESTROY(db)
 	SDBM_File	db
 	CODE:
-	sdbm_close(db);
+	  sdbm_close(db->dbp);
+	  if (db->filter_fetch_key)
+	    SvREFCNT_dec(db->filter_fetch_key) ;
+	  if (db->filter_store_key)
+	    SvREFCNT_dec(db->filter_store_key) ;
+	  if (db->filter_fetch_value)
+	    SvREFCNT_dec(db->filter_fetch_value) ;
+	  if (db->filter_store_value)
+	    SvREFCNT_dec(db->filter_store_value) ;
+	  safefree(db) ;
 
-datum
+datum_value
 sdbm_FETCH(db, key)
 	SDBM_File	db
-	datum		key
+	datum_key	key
 
 int
 sdbm_STORE(db, key, value, flags = DBM_REPLACE)
 	SDBM_File	db
-	datum		key
-	datum		value
+	datum_key	key
+	datum_value	value
 	int		flags
     CLEANUP:
 	if (RETVAL) {
@@ -44,28 +99,93 @@ sdbm_STORE(db, key, value, flags = DBM_REPLACE)
 		croak("No write permission to sdbm file");
 	    croak("sdbm store returned %d, errno %d, key \"%s\"",
 			RETVAL,errno,key.dptr);
-	    sdbm_clearerr(db);
+	    sdbm_clearerr(db->dbp);
 	}
 
 int
 sdbm_DELETE(db, key)
 	SDBM_File	db
-	datum		key
+	datum_key	key
 
-datum
+int
+sdbm_EXISTS(db,key)
+	SDBM_File	db
+	datum_key	key
+
+datum_key
 sdbm_FIRSTKEY(db)
 	SDBM_File	db
 
-datum
+datum_key
 sdbm_NEXTKEY(db, key)
 	SDBM_File	db
-	datum		key
+	datum_key	key
 
 int
 sdbm_error(db)
 	SDBM_File	db
+	CODE:
+	RETVAL = sdbm_error(db->dbp) ;
+	OUTPUT:
+	  RETVAL
 
 int
 sdbm_clearerr(db)
 	SDBM_File	db
+	CODE:
+	RETVAL = sdbm_clearerr(db->dbp) ;
+	OUTPUT:
+	  RETVAL
+
+
+#define setFilter(type)					\
+	{						\
+	    if (db->type)				\
+	        RETVAL = sv_mortalcopy(db->type) ;	\
+	    ST(0) = RETVAL ;				\
+	    if (db->type && (code == &PL_sv_undef)) {	\
+                SvREFCNT_dec(db->type) ;		\
+	        db->type = NULL ;			\
+	    }						\
+	    else if (code) {				\
+	        if (db->type)				\
+	            sv_setsv(db->type, code) ;		\
+	        else					\
+	            db->type = newSVsv(code) ;		\
+	    }	    					\
+	}
+
+
+
+SV *
+filter_fetch_key(db, code)
+	SDBM_File	db
+	SV *		code
+	SV *		RETVAL = &PL_sv_undef ;
+	CODE:
+	    setFilter(filter_fetch_key) ;
+
+SV *
+filter_store_key(db, code)
+	SDBM_File	db
+	SV *		code
+	SV *		RETVAL =  &PL_sv_undef ;
+	CODE:
+	    setFilter(filter_store_key) ;
+
+SV *
+filter_fetch_value(db, code)
+	SDBM_File	db
+	SV *		code
+	SV *		RETVAL =  &PL_sv_undef ;
+	CODE:
+	    setFilter(filter_fetch_value) ;
+
+SV *
+filter_store_value(db, code)
+	SDBM_File	db
+	SV *		code
+	SV *		RETVAL =  &PL_sv_undef ;
+	CODE:
+	    setFilter(filter_store_value) ;
 
diff --git a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/README.too b/gnu/usr.bin/perl/ext/SDBM_File/sdbm/README.too
index c2d095944da..1fec3156ddc 100644
--- a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/README.too
+++ b/gnu/usr.bin/perl/ext/SDBM_File/sdbm/README.too
@@ -7,3 +7,8 @@ Fri Apr 15 10:15:30 EDT 1994.
 
 Additional portability/configuration changes for libsdbm by Andy Dougherty
 doughera@lafcol.lafayette.edu.
+
+
+Mon Mar 22 03:24:47 PST 1999.
+
+sdbm_exists added to the library by Russ Allbery <rra@stanford.edu>.
diff --git a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/dba.c b/gnu/usr.bin/perl/ext/SDBM_File/sdbm/dba.c
index 05e70c8961c..74067763985 100644
--- a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/dba.c
+++ b/gnu/usr.bin/perl/ext/SDBM_File/sdbm/dba.c
@@ -11,8 +11,7 @@ char *progname;
 extern void oops();
 
 int
-main(argc, argv)
-char **argv;
+main(int argc, char **argv)
 {
 	int n;
 	char *p;
@@ -23,6 +22,9 @@ char **argv;
 
 	if (p = argv[1]) {
 		name = (char *) malloc((n = strlen(p)) + 5);
+		if (!name)
+		    oops("cannot get memory");
+
 		strcpy(name, p);
 		strcpy(name + n, ".pag");
 
@@ -37,8 +39,8 @@ char **argv;
 	return 0;
 }
 
-sdump(pagf)
-int pagf;
+void
+sdump(int pagf)
 {
 	register b;
 	register n = 0;
@@ -67,8 +69,8 @@ int pagf;
 		oops("read failed: block %d", n);
 }
 
-pagestat(pag)
-char *pag;
+int
+pagestat(char *pag)
 {
 	register n;
 	register free;
diff --git a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/dbd.c b/gnu/usr.bin/perl/ext/SDBM_File/sdbm/dbd.c
index 04ab842e2d6..0a58d9a0f43 100644
--- a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/dbd.c
+++ b/gnu/usr.bin/perl/ext/SDBM_File/sdbm/dbd.c
@@ -14,8 +14,7 @@ extern void oops();
 #define empty(page)	(((short *) page)[0] == 0)
 
 int
-main(argc, argv)
-char **argv;
+main(int argc, char **argv)
 {
 	int n;
 	char *p;
@@ -26,6 +25,9 @@ char **argv;
 
 	if (p = argv[1]) {
 		name = (char *) malloc((n = strlen(p)) + 5);
+		if (!name)
+		    oops("cannot get memory");
+
 		strcpy(name, p);
 		strcpy(name + n, ".pag");
 
@@ -39,8 +41,8 @@ char **argv;
 	return 0;
 }
 
-sdump(pagf)
-int pagf;
+void
+sdump(int pagf)
 {
 	register r;
 	register n = 0;
@@ -65,8 +67,8 @@ int pagf;
 
 
 #ifdef OLD
-dispage(pag)
-char *pag;
+int
+dispage(char *pag)
 {
 	register i, n;
 	register off;
@@ -87,8 +89,8 @@ char *pag;
 	}
 }
 #else
-dispage(pag)
-char *pag;
+void
+dispage(char *pag)
 {
 	register i, n;
 	register off;
diff --git a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/dbe.c b/gnu/usr.bin/perl/ext/SDBM_File/sdbm/dbe.c
index 2a306f276ec..166e64efdf2 100644
--- a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/dbe.c
+++ b/gnu/usr.bin/perl/ext/SDBM_File/sdbm/dbe.c
@@ -52,10 +52,7 @@ char *optarg;			       /* Global argument pointer. */
 #endif
 
 char
-getopt(argc, argv, optstring)
-int argc;
-char **argv;
-char *optstring;
+getopt(int argc, char **argv, char *optstring)
 {
 	register int c;
 	register char *place;
@@ -131,14 +128,13 @@ char *optstring;
 
 
 void
-print_datum(db)
-datum db;
+print_datum(datum db)
 {
 	int i;
 
 	putchar('"');
 	for (i = 0; i < db.dsize; i++) {
-		if (isprint(db.dptr[i]))
+		if (isprint((unsigned char)db.dptr[i]))
 			putchar(db.dptr[i]);
 		else {
 			putchar('\\');
@@ -152,8 +148,7 @@ datum db;
 
 
 datum
-read_datum(s)
-char *s;
+read_datum(char *s)
 {
 	datum db;
 	char *p;
@@ -161,6 +156,9 @@ char *s;
 
 	db.dsize = 0;
 	db.dptr = (char *) malloc(strlen(s) * sizeof(char));
+	if (!db.dptr)
+	    oops("cannot get memory");
+
 	for (p = db.dptr; *s != '\0'; p++, db.dsize++, s++) {
 		if (*s == '\\') {
 			if (*++s == 'n')
@@ -171,7 +169,10 @@ char *s;
 				*p = '\f';
 			else if (*s == 't')
 				*p = '\t';
-			else if (isdigit(*s) && isdigit(*(s + 1)) && isdigit(*(s + 2))) {
+			else if (isdigit((unsigned char)*s)
+				 && isdigit((unsigned char)*(s + 1))
+				 && isdigit((unsigned char)*(s + 2)))
+			{
 				i = (*s++ - '0') << 6;
 				i |= (*s++ - '0') << 3;
 				i |= *s - '0';
@@ -191,22 +192,21 @@ char *s;
 
 
 char *
-key2s(db)
-datum db;
+key2s(datum db)
 {
 	char *buf;
 	char *p1, *p2;
 
 	buf = (char *) malloc((db.dsize + 1) * sizeof(char));
+	if (!buf)
+	    oops("cannot get memory");
 	for (p1 = buf, p2 = db.dptr; *p2 != '\0'; *p1++ = *p2++);
 	*p1 = '\0';
 	return buf;
 }
 
-
-main(argc, argv)
-int argc;
-char **argv;
+int
+main(int argc, char **argv)
 {
 	typedef enum {
 		YOW, FETCH, STORE, DELETE, SCAN, REGEXP
@@ -285,7 +285,7 @@ char **argv;
 		}
 	}
 
-	if (giveusage | what == YOW | argn < 1) {
+	if (giveusage || what == YOW || argn < 1) {
 		fprintf(stderr, "Usage: %s databse [-m r|w|rw] [-crtx] -a|-d|-f|-F|-s [key [content]]\n", argv[0]);
 		exit(-1);
 	}
diff --git a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/dbm.c b/gnu/usr.bin/perl/ext/SDBM_File/sdbm/dbm.c
index 1388230e2d3..dc47d7001de 100644
--- a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/dbm.c
+++ b/gnu/usr.bin/perl/ext/SDBM_File/sdbm/dbm.c
@@ -27,8 +27,8 @@ static DBM *cur_db = NODB;
 
 static char no_db[] = "dbm: no open database\n";
 
-dbminit(file)
-    char *file;
+int
+dbminit(char *file)
 {
     if (cur_db != NODB)
         dbm_close(cur_db);
@@ -43,8 +43,7 @@ dbminit(file)
 }
 
 long
-forder(key)
-datum key;
+forder(datum key)
 {
     if (cur_db == NODB) {
         printf(no_db);
@@ -54,8 +53,7 @@ datum key;
 }
 
 datum
-fetch(key)
-datum key;
+fetch(datum key)
 {
     datum item;
 
@@ -67,8 +65,8 @@ datum key;
     return (dbm_fetch(cur_db, key));
 }
 
-delete(key)
-datum key;
+int
+delete(datum key)
 {
     if (cur_db == NODB) {
         printf(no_db);
@@ -79,8 +77,8 @@ datum key;
     return (dbm_delete(cur_db, key));
 }
 
-store(key, dat)
-datum key, dat;
+int
+store(datum key, datum dat)
 {
     if (cur_db == NODB) {
         printf(no_db);
@@ -93,7 +91,7 @@ datum key, dat;
 }
 
 datum
-firstkey()
+firstkey(void)
 {
     datum item;
 
@@ -106,8 +104,7 @@ firstkey()
 }
 
 datum
-nextkey(key)
-datum key;
+nextkey(datum key)
 {
     datum item;
 
diff --git a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/dbu.c b/gnu/usr.bin/perl/ext/SDBM_File/sdbm/dbu.c
index a3c0004da9f..e68b78de44e 100644
--- a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/dbu.c
+++ b/gnu/usr.bin/perl/ext/SDBM_File/sdbm/dbu.c
@@ -65,9 +65,7 @@ static cmd *parse();
 static void badk(), doit(), prdatum();
 
 int
-main(argc, argv)
-int	argc;
-char *argv[];
+main(int argc, char **argv)
 {
 	int c;
 	register cmd *act;
@@ -98,9 +96,7 @@ char *argv[];
 }
 
 static void
-doit(act, file)
-register cmd *act;
-char *file;
+doit(register cmd *act, char *file)
 {
 	datum key;
 	datum val;
@@ -197,8 +193,7 @@ char *file;
 }
 
 static void
-badk(word)
-char *word;
+badk(char *word)
 {
 	register int i;
 
@@ -214,8 +209,7 @@ char *word;
 }
 
 static cmd *
-parse(str)
-register char *str;
+parse(register char *str)
 {
 	register int i = CTABSIZ;
 	register cmd *p;
@@ -227,9 +221,7 @@ register char *str;
 }
 
 static void
-prdatum(stream, d)
-FILE *stream;
-datum d;
+prdatum(FILE *stream, datum d)
 {
 	register int c;
 	register char *p = d.dptr;