projects / p5sagit/p5-mst-13.2.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | history | HEAD
More fixups for thrperl integration.
[p5sagit/p5-mst-13.2.git] / ext / DB_File / DB_File.xs
CommitLineData
a0d0e21e 1/*
2
3 DB_File.xs -- Perl 5 interface to Berkeley DB
4
5 written by Paul Marquess (pmarquess@bfsec.bt.co.uk)
e858de61 6 last modified 31st May 1997
7 version 1.15
a0d0e21e 8
9 All comments/suggestions/problems are welcome
10
a0b8c8c1 11 Copyright (c) 1995, 1996, 1997 Paul Marquess. All rights reserved.
36477c24 12 This program is free software; you can redistribute it and/or
13 modify it under the same terms as Perl itself.
14
3b35bae3 15 Changes:
4633a7c4 16 0.1 - Initial Release
17 0.2 - No longer bombs out if dbopen returns an error.
18 0.3 - Added some support for multiple btree compares
19 1.0 - Complete support for multiple callbacks added.
20 Fixed a problem with pushing a value onto an empty list.
21 1.01 - Fixed a SunOS core dump problem.
22 The return value from TIEHASH wasn't set to NULL when
23 dbopen returned an error.
88108326 24 1.02 - Use ALIAS to define TIEARRAY.
25 Removed some redundant commented code.
26 Merged OS2 code into the main distribution.
27 Allow negative subscripts with RECNO interface.
28 Changed the default flags to O_CREAT|O_RDWR
f6b705ef 29 1.03 - Added EXISTS
610ab055 30 1.04 - fixed a couple of bugs in hash_cb. Patches supplied by
31 Dave Hammen, hammen@gothamcity.jsc.nasa.gov
32 1.05 - Added logic to allow prefix & hash types to be specified via
33 Makefile.PL
ff68c719 34 1.06 - Minor namespace cleanup: Localized PrintBtree.
36477c24 35 1.07 - Fixed bug with RECNO, where bval wasn't defaulting to "\n".
36 1.08 - No change to DB_File.xs
18d2dc8c 37 1.09 - Default mode for dbopen changed to 0666
a0b8c8c1 38 1.10 - Fixed fd method so that it still returns -1 for
39 in-memory files when db 1.86 is used.
778183f3 40 1.11 - No change to DB_File.xs
68dc0745 41 1.12 - No change to DB_File.xs
d3ef3b8a 42 1.13 - Tidied up a few casts.
05475680 43 1.14 - Made it illegal to tie an associative array to a RECNO
44 database and an ordinary array to a HASH or BTREE database.
e858de61 45 1.15 - Minor additions to DB_File.xs to support multithreaded perl.
f6b705ef 46
a0d0e21e 47*/
48
49#include "EXTERN.h"
50#include "perl.h"
51#include "XSUB.h"
52
53#include <db.h>
54
55#include <fcntl.h>
56
610ab055 57#ifdef mDB_Prefix_t
58#ifdef DB_Prefix_t
59#undef DB_Prefix_t
60#endif
61#define DB_Prefix_t mDB_Prefix_t
62#endif
63
64#ifdef mDB_Hash_t
65#ifdef DB_Hash_t
66#undef DB_Hash_t
67#endif
68#define DB_Hash_t mDB_Hash_t
69#endif
70
71union INFO {
72 HASHINFO hash ;
73 RECNOINFO recno ;
74 BTREEINFO btree ;
75 } ;
76
8e07c86e 77typedef struct {
78 DBTYPE type ;
79 DB * dbp ;
80 SV * compare ;
81 SV * prefix ;
82 SV * hash ;
a0b8c8c1 83 int in_memory ;
610ab055 84 union INFO info ;
8e07c86e 85 } DB_File_type;
86
87typedef DB_File_type * DB_File ;
a0d0e21e 88typedef DBT DBTKEY ;
89
a0d0e21e 90
610ab055 91/* #define TRACE */
a0d0e21e 92
4633a7c4 93#define db_DESTROY(db) ((db->dbp)->close)(db->dbp)
94#define db_DELETE(db, key, flags) ((db->dbp)->del)(db->dbp, &key, flags)
95#define db_STORE(db, key, value, flags) ((db->dbp)->put)(db->dbp, &key, &value, flags)
96#define db_FETCH(db, key, flags) ((db->dbp)->get)(db->dbp, &key, &value, flags)
a0d0e21e 97
4633a7c4 98#define db_close(db) ((db->dbp)->close)(db->dbp)
99#define db_del(db, key, flags) ((db->dbp)->del)(db->dbp, &key, flags)
a0b8c8c1 100#define db_fd(db) (db->in_memory \
101 ? -1 \
102 : ((db->dbp)->fd)(db->dbp) )
4633a7c4 103#define db_put(db, key, value, flags) ((db->dbp)->put)(db->dbp, &key, &value, flags)
104#define db_get(db, key, value, flags) ((db->dbp)->get)(db->dbp, &key, &value, flags)
105#define db_seq(db, key, value, flags) ((db->dbp)->seq)(db->dbp, &key, &value, flags)
106#define db_sync(db, flags) ((db->dbp)->sync)(db->dbp, flags)
a0d0e21e 107
108
88108326 109#define OutputValue(arg, name) \
110 { if (RETVAL == 0) { \
111 sv_setpvn(arg, name.data, name.size) ; \
112 } \
113 }
a0d0e21e 114
115#define OutputKey(arg, name) \
116 { if (RETVAL == 0) \
117 { \
88108326 118 if (db->type != DB_RECNO) { \
a0d0e21e 119 sv_setpvn(arg, name.data, name.size); \
88108326 120 } \
a0d0e21e 121 else \
122 sv_setiv(arg, (I32)*(I32*)name.data - 1); \
123 } \
124 }
125
126/* Internal Global Data */
8e07c86e 127static recno_t Value ;
128static DB_File CurrentDB ;
129static recno_t zero = 0 ;
130static DBTKEY empty = { &zero, sizeof(recno_t) } ;
a0d0e21e 131
132
133static int
134btree_compare(key1, key2)
135const DBT * key1 ;
136const DBT * key2 ;
137{
e858de61 138 dTHR ;
a0d0e21e 139 dSP ;
140 void * data1, * data2 ;
141 int retval ;
142 int count ;
143
144 data1 = key1->data ;
145 data2 = key2->data ;
146
147 /* As newSVpv will assume that the data pointer is a null terminated C
148 string if the size parameter is 0, make sure that data points to an
149 empty string if the length is 0
150 */
151 if (key1->size == 0)
152 data1 = "" ;
153 if (key2->size == 0)
154 data2 = "" ;
155
156 ENTER ;
157 SAVETMPS;
158
159 PUSHMARK(sp) ;
160 EXTEND(sp,2) ;
161 PUSHs(sv_2mortal(newSVpv(data1,key1->size)));
162 PUSHs(sv_2mortal(newSVpv(data2,key2->size)));
163 PUTBACK ;
164
8e07c86e 165 count = perl_call_sv(CurrentDB->compare, G_SCALAR);
a0d0e21e 166
167 SPAGAIN ;
168
169 if (count != 1)
ff0cee69 170 croak ("DB_File btree_compare: expected 1 return value from compare sub, got %d\n", count) ;
a0d0e21e 171
172 retval = POPi ;
173
174 PUTBACK ;
175 FREETMPS ;
176 LEAVE ;
177 return (retval) ;
178
179}
180
ecfc5424 181static DB_Prefix_t
a0d0e21e 182btree_prefix(key1, key2)
183const DBT * key1 ;
184const DBT * key2 ;
185{
e858de61 186 dTHR ;
a0d0e21e 187 dSP ;
188 void * data1, * data2 ;
189 int retval ;
190 int count ;
191
192 data1 = key1->data ;
193 data2 = key2->data ;
194
195 /* As newSVpv will assume that the data pointer is a null terminated C
196 string if the size parameter is 0, make sure that data points to an
197 empty string if the length is 0
198 */
199 if (key1->size == 0)
200 data1 = "" ;
201 if (key2->size == 0)
202 data2 = "" ;
203
204 ENTER ;
205 SAVETMPS;
206
207 PUSHMARK(sp) ;
208 EXTEND(sp,2) ;
209 PUSHs(sv_2mortal(newSVpv(data1,key1->size)));
210 PUSHs(sv_2mortal(newSVpv(data2,key2->size)));
211 PUTBACK ;
212
8e07c86e 213 count = perl_call_sv(CurrentDB->prefix, G_SCALAR);
a0d0e21e 214
215 SPAGAIN ;
216
217 if (count != 1)
ff0cee69 218 croak ("DB_File btree_prefix: expected 1 return value from prefix sub, got %d\n", count) ;
a0d0e21e 219
220 retval = POPi ;
221
222 PUTBACK ;
223 FREETMPS ;
224 LEAVE ;
225
226 return (retval) ;
227}
228
ecfc5424 229static DB_Hash_t
a0d0e21e 230hash_cb(data, size)
231const void * data ;
232size_t size ;
233{
e858de61 234 dTHR ;
a0d0e21e 235 dSP ;
236 int retval ;
237 int count ;
238
239 if (size == 0)
240 data = "" ;
241
610ab055 242 /* DGH - Next two lines added to fix corrupted stack problem */
243 ENTER ;
244 SAVETMPS;
245
a0d0e21e 246 PUSHMARK(sp) ;
610ab055 247
a0d0e21e 248 XPUSHs(sv_2mortal(newSVpv((char*)data,size)));
249 PUTBACK ;
250
8e07c86e 251 count = perl_call_sv(CurrentDB->hash, G_SCALAR);
a0d0e21e 252
253 SPAGAIN ;
254
255 if (count != 1)
ff0cee69 256 croak ("DB_File hash_cb: expected 1 return value from hash sub, got %d\n", count) ;
a0d0e21e 257
258 retval = POPi ;
259
260 PUTBACK ;
261 FREETMPS ;
262 LEAVE ;
263
264 return (retval) ;
265}
266
267
268#ifdef TRACE
269
270static void
271PrintHash(hash)
610ab055 272HASHINFO * hash ;
a0d0e21e 273{
274 printf ("HASH Info\n") ;
610ab055 275 printf (" hash = %s\n", (hash->hash != NULL ? "redefined" : "default")) ;
276 printf (" bsize = %d\n", hash->bsize) ;
277 printf (" ffactor = %d\n", hash->ffactor) ;
278 printf (" nelem = %d\n", hash->nelem) ;
279 printf (" cachesize = %d\n", hash->cachesize) ;
280 printf (" lorder = %d\n", hash->lorder) ;
a0d0e21e 281
282}
283
284static void
285PrintRecno(recno)
610ab055 286RECNOINFO * recno ;
a0d0e21e 287{
288 printf ("RECNO Info\n") ;
610ab055 289 printf (" flags = %d\n", recno->flags) ;
290 printf (" cachesize = %d\n", recno->cachesize) ;
291 printf (" psize = %d\n", recno->psize) ;
292 printf (" lorder = %d\n", recno->lorder) ;
d3ef3b8a 293 printf (" reclen = %lu\n", (unsigned long)recno->reclen) ;
36477c24 294 printf (" bval = %d 0x%x\n", recno->bval, recno->bval) ;
610ab055 295 printf (" bfname = %d [%s]\n", recno->bfname, recno->bfname) ;
a0d0e21e 296}
297
ff68c719 298static void
a0d0e21e 299PrintBtree(btree)
610ab055 300BTREEINFO * btree ;
a0d0e21e 301{
302 printf ("BTREE Info\n") ;
610ab055 303 printf (" compare = %s\n", (btree->compare ? "redefined" : "default")) ;
304 printf (" prefix = %s\n", (btree->prefix ? "redefined" : "default")) ;
305 printf (" flags = %d\n", btree->flags) ;
306 printf (" cachesize = %d\n", btree->cachesize) ;
307 printf (" psize = %d\n", btree->psize) ;
308 printf (" maxkeypage = %d\n", btree->maxkeypage) ;
309 printf (" minkeypage = %d\n", btree->minkeypage) ;
310 printf (" lorder = %d\n", btree->lorder) ;
a0d0e21e 311}
312
313#else
314
315#define PrintRecno(recno)
316#define PrintHash(hash)
317#define PrintBtree(btree)
318
319#endif /* TRACE */
320
321
322static I32
323GetArrayLength(db)
8e07c86e 324DB * db ;
a0d0e21e 325{
326 DBT key ;
327 DBT value ;
328 int RETVAL ;
329
330 RETVAL = (db->seq)(db, &key, &value, R_LAST) ;
331 if (RETVAL == 0)
332 RETVAL = *(I32 *)key.data ;
333 else if (RETVAL == 1) /* No key means empty file */
334 RETVAL = 0 ;
335
a0b8c8c1 336 return ((I32)RETVAL) ;
a0d0e21e 337}
338
88108326 339static recno_t
340GetRecnoKey(db, value)
341DB_File db ;
342I32 value ;
343{
344 if (value < 0) {
345 /* Get the length of the array */
346 I32 length = GetArrayLength(db->dbp) ;
347
348 /* check for attempt to write before start of array */
349 if (length + value + 1 <= 0)
ff0cee69 350 croak("Modification of non-creatable array value attempted, subscript %ld", (long)value) ;
88108326 351
352 value = length + value + 1 ;
353 }
354 else
355 ++ value ;
356
357 return value ;
a0d0e21e 358}
359
360static DB_File
05475680 361ParseOpenInfo(isHASH, name, flags, mode, sv)
362int isHASH ;
a0d0e21e 363char * name ;
364int flags ;
365int mode ;
366SV * sv ;
a0d0e21e 367{
368 SV ** svp;
369 HV * action ;
8e07c86e 370 DB_File RETVAL = (DB_File)safemalloc(sizeof(DB_File_type)) ;
a0d0e21e 371 void * openinfo = NULL ;
610ab055 372 union INFO * info = &RETVAL->info ;
a0d0e21e 373
88108326 374 /* Default to HASH */
8e07c86e 375 RETVAL->hash = RETVAL->compare = RETVAL->prefix = NULL ;
376 RETVAL->type = DB_HASH ;
a0d0e21e 377
610ab055 378 /* DGH - Next line added to avoid SEGV on existing hash DB */
379 CurrentDB = RETVAL;
380
a0b8c8c1 381 /* fd for 1.86 hash in memory files doesn't return -1 like 1.85 */
382 RETVAL->in_memory = (name == NULL) ;
383
a0d0e21e 384 if (sv)
385 {
386 if (! SvROK(sv) )
387 croak ("type parameter is not a reference") ;
388
36477c24 389 svp = hv_fetch( (HV*)SvRV(sv), "GOT", 3, FALSE) ;
390 if (svp && SvOK(*svp))
391 action = (HV*) SvRV(*svp) ;
392 else
393 croak("internal error") ;
610ab055 394
a0d0e21e 395 if (sv_isa(sv, "DB_File::HASHINFO"))
396 {
05475680 397
398 if (!isHASH)
399 croak("DB_File can only tie an associative array to a DB_HASH database") ;
400
8e07c86e 401 RETVAL->type = DB_HASH ;
610ab055 402 openinfo = (void*)info ;
a0d0e21e 403
404 svp = hv_fetch(action, "hash", 4, FALSE);
405
406 if (svp && SvOK(*svp))
407 {
610ab055 408 info->hash.hash = hash_cb ;
8e07c86e 409 RETVAL->hash = newSVsv(*svp) ;
a0d0e21e 410 }
411 else
610ab055 412 info->hash.hash = NULL ;
a0d0e21e 413
414 svp = hv_fetch(action, "bsize", 5, FALSE);
610ab055 415 info->hash.bsize = svp ? SvIV(*svp) : 0;
a0d0e21e 416
417 svp = hv_fetch(action, "ffactor", 7, FALSE);
610ab055 418 info->hash.ffactor = svp ? SvIV(*svp) : 0;
a0d0e21e 419
420 svp = hv_fetch(action, "nelem", 5, FALSE);
610ab055 421 info->hash.nelem = svp ? SvIV(*svp) : 0;
a0d0e21e 422
423 svp = hv_fetch(action, "cachesize", 9, FALSE);
610ab055 424 info->hash.cachesize = svp ? SvIV(*svp) : 0;
a0d0e21e 425
426 svp = hv_fetch(action, "lorder", 6, FALSE);
610ab055 427 info->hash.lorder = svp ? SvIV(*svp) : 0;
a0d0e21e 428
429 PrintHash(info) ;
430 }
431 else if (sv_isa(sv, "DB_File::BTREEINFO"))
432 {
05475680 433 if (!isHASH)
434 croak("DB_File can only tie an associative array to a DB_BTREE database");
435
8e07c86e 436 RETVAL->type = DB_BTREE ;
610ab055 437 openinfo = (void*)info ;
a0d0e21e 438
439 svp = hv_fetch(action, "compare", 7, FALSE);
440 if (svp && SvOK(*svp))
441 {
610ab055 442 info->btree.compare = btree_compare ;
8e07c86e 443 RETVAL->compare = newSVsv(*svp) ;
a0d0e21e 444 }
445 else
610ab055 446 info->btree.compare = NULL ;
a0d0e21e 447
448 svp = hv_fetch(action, "prefix", 6, FALSE);
449 if (svp && SvOK(*svp))
450 {
610ab055 451 info->btree.prefix = btree_prefix ;
8e07c86e 452 RETVAL->prefix = newSVsv(*svp) ;
a0d0e21e 453 }
454 else
610ab055 455 info->btree.prefix = NULL ;
a0d0e21e 456
457 svp = hv_fetch(action, "flags", 5, FALSE);
610ab055 458 info->btree.flags = svp ? SvIV(*svp) : 0;
a0d0e21e 459
460 svp = hv_fetch(action, "cachesize", 9, FALSE);
610ab055 461 info->btree.cachesize = svp ? SvIV(*svp) : 0;
a0d0e21e 462
463 svp = hv_fetch(action, "minkeypage", 10, FALSE);
610ab055 464 info->btree.minkeypage = svp ? SvIV(*svp) : 0;
a0d0e21e 465
466 svp = hv_fetch(action, "maxkeypage", 10, FALSE);
610ab055 467 info->btree.maxkeypage = svp ? SvIV(*svp) : 0;
a0d0e21e 468
469 svp = hv_fetch(action, "psize", 5, FALSE);
610ab055 470 info->btree.psize = svp ? SvIV(*svp) : 0;
a0d0e21e 471
472 svp = hv_fetch(action, "lorder", 6, FALSE);
610ab055 473 info->btree.lorder = svp ? SvIV(*svp) : 0;
a0d0e21e 474
475 PrintBtree(info) ;
476
477 }
478 else if (sv_isa(sv, "DB_File::RECNOINFO"))
479 {
05475680 480 if (isHASH)
481 croak("DB_File can only tie an array to a DB_RECNO database");
482
8e07c86e 483 RETVAL->type = DB_RECNO ;
610ab055 484 openinfo = (void *)info ;
a0d0e21e 485
486 svp = hv_fetch(action, "flags", 5, FALSE);
d3ef3b8a 487 info->recno.flags = (u_long) (svp ? SvIV(*svp) : 0);
a0d0e21e 488
489 svp = hv_fetch(action, "cachesize", 9, FALSE);
d3ef3b8a 490 info->recno.cachesize = (u_int) (svp ? SvIV(*svp) : 0);
a0d0e21e 491
492 svp = hv_fetch(action, "psize", 5, FALSE);
d3ef3b8a 493 info->recno.psize = (u_int) (svp ? SvIV(*svp) : 0);
a0d0e21e 494
495 svp = hv_fetch(action, "lorder", 6, FALSE);
d3ef3b8a 496 info->recno.lorder = (int) (svp ? SvIV(*svp) : 0);
a0d0e21e 497
498 svp = hv_fetch(action, "reclen", 6, FALSE);
d3ef3b8a 499 info->recno.reclen = (size_t) (svp ? SvIV(*svp) : 0);
a0d0e21e 500
501 svp = hv_fetch(action, "bval", 4, FALSE);
502 if (svp && SvOK(*svp))
503 {
504 if (SvPOK(*svp))
610ab055 505 info->recno.bval = (u_char)*SvPV(*svp, na) ;
a0d0e21e 506 else
610ab055 507 info->recno.bval = (u_char)(unsigned long) SvIV(*svp) ;
a0d0e21e 508 }
509 else
510 {
610ab055 511 if (info->recno.flags & R_FIXEDLEN)
512 info->recno.bval = (u_char) ' ' ;
a0d0e21e 513 else
610ab055 514 info->recno.bval = (u_char) '\n' ;
a0d0e21e 515 }
516
517 svp = hv_fetch(action, "bfname", 6, FALSE);
36477c24 518 if (svp && SvOK(*svp)) {
88108326 519 char * ptr = SvPV(*svp,na) ;
d3ef3b8a 520 info->recno.bfname = (char*) (na ? ptr : NULL) ;
88108326 521 }
36477c24 522 else
523 info->recno.bfname = NULL ;
a0d0e21e 524
525 PrintRecno(info) ;
526 }
527 else
528 croak("type is not of type DB_File::HASHINFO, DB_File::BTREEINFO or DB_File::RECNOINFO");
529 }
530
531
88108326 532 /* OS2 Specific Code */
533#ifdef OS2
534#ifdef __EMX__
535 flags |= O_BINARY;
536#endif /* __EMX__ */
537#endif /* OS2 */
a0d0e21e 538
88108326 539 RETVAL->dbp = dbopen(name, flags, mode, RETVAL->type, openinfo) ;
a0d0e21e 540
541 return (RETVAL) ;
542}
543
544
545static int
546not_here(s)
547char *s;
548{
549 croak("DB_File::%s not implemented on this architecture", s);
550 return -1;
551}
552
553static double
554constant(name, arg)
555char *name;
556int arg;
557{
558 errno = 0;
559 switch (*name) {
560 case 'A':
561 break;
562 case 'B':
563 if (strEQ(name, "BTREEMAGIC"))
564#ifdef BTREEMAGIC
565 return BTREEMAGIC;
566#else
567 goto not_there;
568#endif
569 if (strEQ(name, "BTREEVERSION"))
570#ifdef BTREEVERSION
571 return BTREEVERSION;
572#else
573 goto not_there;
574#endif
575 break;
576 case 'C':
577 break;
578 case 'D':
579 if (strEQ(name, "DB_LOCK"))
580#ifdef DB_LOCK
581 return DB_LOCK;
582#else
583 goto not_there;
584#endif
585 if (strEQ(name, "DB_SHMEM"))
586#ifdef DB_SHMEM
587 return DB_SHMEM;
588#else
589 goto not_there;
590#endif
591 if (strEQ(name, "DB_TXN"))
592#ifdef DB_TXN
593 return (U32)DB_TXN;
594#else
595 goto not_there;
596#endif
597 break;
598 case 'E':
599 break;
600 case 'F':
601 break;
602 case 'G':
603 break;
604 case 'H':
605 if (strEQ(name, "HASHMAGIC"))
606#ifdef HASHMAGIC
607 return HASHMAGIC;
608#else
609 goto not_there;
610#endif
611 if (strEQ(name, "HASHVERSION"))
612#ifdef HASHVERSION
613 return HASHVERSION;
614#else
615 goto not_there;
616#endif
617 break;
618 case 'I':
619 break;
620 case 'J':
621 break;
622 case 'K':
623 break;
624 case 'L':
625 break;
626 case 'M':
627 if (strEQ(name, "MAX_PAGE_NUMBER"))
628#ifdef MAX_PAGE_NUMBER
629 return (U32)MAX_PAGE_NUMBER;
630#else
631 goto not_there;
632#endif
633 if (strEQ(name, "MAX_PAGE_OFFSET"))
634#ifdef MAX_PAGE_OFFSET
635 return MAX_PAGE_OFFSET;
636#else
637 goto not_there;
638#endif
639 if (strEQ(name, "MAX_REC_NUMBER"))
640#ifdef MAX_REC_NUMBER
641 return (U32)MAX_REC_NUMBER;
642#else
643 goto not_there;
644#endif
645 break;
646 case 'N':
647 break;
648 case 'O':
649 break;
650 case 'P':
651 break;
652 case 'Q':
653 break;
654 case 'R':
655 if (strEQ(name, "RET_ERROR"))
656#ifdef RET_ERROR
657 return RET_ERROR;
658#else
659 goto not_there;
660#endif
661 if (strEQ(name, "RET_SPECIAL"))
662#ifdef RET_SPECIAL
663 return RET_SPECIAL;
664#else
665 goto not_there;
666#endif
667 if (strEQ(name, "RET_SUCCESS"))
668#ifdef RET_SUCCESS
669 return RET_SUCCESS;
670#else
671 goto not_there;
672#endif
673 if (strEQ(name, "R_CURSOR"))
674#ifdef R_CURSOR
675 return R_CURSOR;
676#else
677 goto not_there;
678#endif
679 if (strEQ(name, "R_DUP"))
680#ifdef R_DUP
681 return R_DUP;
682#else
683 goto not_there;
684#endif
685 if (strEQ(name, "R_FIRST"))
686#ifdef R_FIRST
687 return R_FIRST;
688#else
689 goto not_there;
690#endif
691 if (strEQ(name, "R_FIXEDLEN"))
692#ifdef R_FIXEDLEN
693 return R_FIXEDLEN;
694#else
695 goto not_there;
696#endif
697 if (strEQ(name, "R_IAFTER"))
698#ifdef R_IAFTER
699 return R_IAFTER;
700#else
701 goto not_there;
702#endif
703 if (strEQ(name, "R_IBEFORE"))
704#ifdef R_IBEFORE
705 return R_IBEFORE;
706#else
707 goto not_there;
708#endif
709 if (strEQ(name, "R_LAST"))
710#ifdef R_LAST
711 return R_LAST;
712#else
713 goto not_there;
714#endif
715 if (strEQ(name, "R_NEXT"))
716#ifdef R_NEXT
717 return R_NEXT;
718#else
719 goto not_there;
720#endif
721 if (strEQ(name, "R_NOKEY"))
722#ifdef R_NOKEY
723 return R_NOKEY;
724#else
725 goto not_there;
726#endif
727 if (strEQ(name, "R_NOOVERWRITE"))
728#ifdef R_NOOVERWRITE
729 return R_NOOVERWRITE;
730#else
731 goto not_there;
732#endif
733 if (strEQ(name, "R_PREV"))
734#ifdef R_PREV
735 return R_PREV;
736#else
737 goto not_there;
738#endif
739 if (strEQ(name, "R_RECNOSYNC"))
740#ifdef R_RECNOSYNC
741 return R_RECNOSYNC;
742#else
743 goto not_there;
744#endif
745 if (strEQ(name, "R_SETCURSOR"))
746#ifdef R_SETCURSOR
747 return R_SETCURSOR;
748#else
749 goto not_there;
750#endif
751 if (strEQ(name, "R_SNAPSHOT"))
752#ifdef R_SNAPSHOT
753 return R_SNAPSHOT;
754#else
755 goto not_there;
756#endif
757 break;
758 case 'S':
759 break;
760 case 'T':
761 break;
762 case 'U':
763 break;
764 case 'V':
765 break;
766 case 'W':
767 break;
768 case 'X':
769 break;
770 case 'Y':
771 break;
772 case 'Z':
773 break;
774 case '_':
775 if (strEQ(name, "__R_UNUSED"))
776#ifdef __R_UNUSED
777 return __R_UNUSED;
778#else
779 goto not_there;
780#endif
781 break;
782 }
783 errno = EINVAL;
784 return 0;
785
786not_there:
787 errno = ENOENT;
788 return 0;
789}
790
791MODULE = DB_File PACKAGE = DB_File PREFIX = db_
792
793double
794constant(name,arg)
795 char * name
796 int arg
797
798
799DB_File
05475680 800db_DoTie_(isHASH, dbtype, name=undef, flags=O_CREAT|O_RDWR, mode=0666, type=DB_HASH)
801 int isHASH
a0d0e21e 802 char * dbtype
803 int flags
804 int mode
805 CODE:
806 {
807 char * name = (char *) NULL ;
808 SV * sv = (SV *) NULL ;
809
05475680 810 if (items >= 3 && SvOK(ST(2)))
811 name = (char*) SvPV(ST(2), na) ;
a0d0e21e 812
05475680 813 if (items == 6)
814 sv = ST(5) ;
a0d0e21e 815
05475680 816 RETVAL = ParseOpenInfo(isHASH, name, flags, mode, sv) ;
4633a7c4 817 if (RETVAL->dbp == NULL)
818 RETVAL = NULL ;
a0d0e21e 819 }
820 OUTPUT:
821 RETVAL
822
a0d0e21e 823int
824db_DESTROY(db)
825 DB_File db
8e07c86e 826 INIT:
827 CurrentDB = db ;
828 CLEANUP:
829 if (db->hash)
830 SvREFCNT_dec(db->hash) ;
831 if (db->compare)
832 SvREFCNT_dec(db->compare) ;
833 if (db->prefix)
834 SvREFCNT_dec(db->prefix) ;
835 Safefree(db) ;
a0d0e21e 836
837
838int
839db_DELETE(db, key, flags=0)
840 DB_File db
841 DBTKEY key
842 u_int flags
8e07c86e 843 INIT:
844 CurrentDB = db ;
a0d0e21e 845
f6b705ef 846
847int
848db_EXISTS(db, key)
849 DB_File db
850 DBTKEY key
851 CODE:
852 {
853 DBT value ;
854
855 CurrentDB = db ;
856 RETVAL = (((db->dbp)->get)(db->dbp, &key, &value, 0) == 0) ;
857 }
858 OUTPUT:
859 RETVAL
860
a0d0e21e 861int
862db_FETCH(db, key, flags=0)
863 DB_File db
864 DBTKEY key
865 u_int flags
866 CODE:
867 {
868 DBT value ;
869
8e07c86e 870 CurrentDB = db ;
4633a7c4 871 RETVAL = ((db->dbp)->get)(db->dbp, &key, &value, flags) ;
a0d0e21e 872 ST(0) = sv_newmortal();
873 if (RETVAL == 0)
874 sv_setpvn(ST(0), value.data, value.size);
875 }
876
877int
878db_STORE(db, key, value, flags=0)
879 DB_File db
880 DBTKEY key
881 DBT value
882 u_int flags
8e07c86e 883 INIT:
884 CurrentDB = db ;
a0d0e21e 885
886
887int
888db_FIRSTKEY(db)
889 DB_File db
890 CODE:
891 {
892 DBTKEY key ;
893 DBT value ;
4633a7c4 894 DB * Db = db->dbp ;
a0d0e21e 895
8e07c86e 896 CurrentDB = db ;
4633a7c4 897 RETVAL = (Db->seq)(Db, &key, &value, R_FIRST) ;
a0d0e21e 898 ST(0) = sv_newmortal();
899 if (RETVAL == 0)
900 {
05475680 901 if (db->type != DB_RECNO)
a0d0e21e 902 sv_setpvn(ST(0), key.data, key.size);
903 else
904 sv_setiv(ST(0), (I32)*(I32*)key.data - 1);
905 }
906 }
907
908int
909db_NEXTKEY(db, key)
910 DB_File db
911 DBTKEY key
912 CODE:
913 {
914 DBT value ;
4633a7c4 915 DB * Db = db->dbp ;
a0d0e21e 916
8e07c86e 917 CurrentDB = db ;
4633a7c4 918 RETVAL = (Db->seq)(Db, &key, &value, R_NEXT) ;
a0d0e21e 919 ST(0) = sv_newmortal();
920 if (RETVAL == 0)
921 {
05475680 922 if (db->type != DB_RECNO)
a0d0e21e 923 sv_setpvn(ST(0), key.data, key.size);
924 else
925 sv_setiv(ST(0), (I32)*(I32*)key.data - 1);
926 }
927 }
928
929#
930# These would be nice for RECNO
931#
932
933int
934unshift(db, ...)
935 DB_File db
936 CODE:
937 {
938 DBTKEY key ;
939 DBT value ;
940 int i ;
941 int One ;
4633a7c4 942 DB * Db = db->dbp ;
a0d0e21e 943
8e07c86e 944 CurrentDB = db ;
a0d0e21e 945 RETVAL = -1 ;
946 for (i = items-1 ; i > 0 ; --i)
947 {
948 value.data = SvPV(ST(i), na) ;
949 value.size = na ;
950 One = 1 ;
951 key.data = &One ;
952 key.size = sizeof(int) ;
4633a7c4 953 RETVAL = (Db->put)(Db, &key, &value, R_IBEFORE) ;
a0d0e21e 954 if (RETVAL != 0)
955 break;
956 }
957 }
958 OUTPUT:
959 RETVAL
960
961I32
962pop(db)
963 DB_File db
964 CODE:
965 {
966 DBTKEY key ;
967 DBT value ;
4633a7c4 968 DB * Db = db->dbp ;
a0d0e21e 969
8e07c86e 970 CurrentDB = db ;
a0d0e21e 971 /* First get the final value */
4633a7c4 972 RETVAL = (Db->seq)(Db, &key, &value, R_LAST) ;
a0d0e21e 973 ST(0) = sv_newmortal();
974 /* Now delete it */
975 if (RETVAL == 0)
976 {
f6b705ef 977 /* the call to del will trash value, so take a copy now */
978 sv_setpvn(ST(0), value.data, value.size);
4633a7c4 979 RETVAL = (Db->del)(Db, &key, R_CURSOR) ;
f6b705ef 980 if (RETVAL != 0)
981 sv_setsv(ST(0), &sv_undef);
a0d0e21e 982 }
983 }
984
985I32
986shift(db)
987 DB_File db
988 CODE:
989 {
a0d0e21e 990 DBT value ;
f6b705ef 991 DBTKEY key ;
4633a7c4 992 DB * Db = db->dbp ;
a0d0e21e 993
8e07c86e 994 CurrentDB = db ;
a0d0e21e 995 /* get the first value */
f6b705ef 996 RETVAL = (Db->seq)(Db, &key, &value, R_FIRST) ;
a0d0e21e 997 ST(0) = sv_newmortal();
998 /* Now delete it */
999 if (RETVAL == 0)
1000 {
f6b705ef 1001 /* the call to del will trash value, so take a copy now */
1002 sv_setpvn(ST(0), value.data, value.size);
1003 RETVAL = (Db->del)(Db, &key, R_CURSOR) ;
1004 if (RETVAL != 0)
1005 sv_setsv (ST(0), &sv_undef) ;
a0d0e21e 1006 }
1007 }
1008
1009
1010I32
1011push(db, ...)
1012 DB_File db
1013 CODE:
1014 {
1015 DBTKEY key ;
8e07c86e 1016 DBTKEY * keyptr = &key ;
a0d0e21e 1017 DBT value ;
4633a7c4 1018 DB * Db = db->dbp ;
a0d0e21e 1019 int i ;
1020
8e07c86e 1021 CurrentDB = db ;
a0d0e21e 1022 /* Set the Cursor to the Last element */
4633a7c4 1023 RETVAL = (Db->seq)(Db, &key, &value, R_LAST) ;
8e07c86e 1024 if (RETVAL >= 0)
a0d0e21e 1025 {
8e07c86e 1026 if (RETVAL == 1)
1027 keyptr = &empty ;
1028 for (i = items - 1 ; i > 0 ; --i)
1029 {
1030 value.data = SvPV(ST(i), na) ;
1031 value.size = na ;
4633a7c4 1032 RETVAL = (Db->put)(Db, keyptr, &value, R_IAFTER) ;
8e07c86e 1033 if (RETVAL != 0)
1034 break;
1035 }
a0d0e21e 1036 }
1037 }
1038 OUTPUT:
1039 RETVAL
1040
1041
1042I32
1043length(db)
1044 DB_File db
1045 CODE:
8e07c86e 1046 CurrentDB = db ;
1047 RETVAL = GetArrayLength(db->dbp) ;
a0d0e21e 1048 OUTPUT:
1049 RETVAL
1050
1051
1052#
1053# Now provide an interface to the rest of the DB functionality
1054#
1055
1056int
1057db_del(db, key, flags=0)
1058 DB_File db
1059 DBTKEY key
1060 u_int flags
8e07c86e 1061 INIT:
1062 CurrentDB = db ;
a0d0e21e 1063
1064
1065int
1066db_get(db, key, value, flags=0)
1067 DB_File db
1068 DBTKEY key
1069 DBT value
1070 u_int flags
8e07c86e 1071 INIT:
1072 CurrentDB = db ;
a0d0e21e 1073 OUTPUT:
1074 value
1075
1076int
1077db_put(db, key, value, flags=0)
1078 DB_File db
1079 DBTKEY key
1080 DBT value
1081 u_int flags
8e07c86e 1082 INIT:
1083 CurrentDB = db ;
a0d0e21e 1084 OUTPUT:
1085 key if (flags & (R_IAFTER|R_IBEFORE)) OutputKey(ST(1), key);
1086
1087int
1088db_fd(db)
1089 DB_File db
8e07c86e 1090 INIT:
1091 CurrentDB = db ;
a0d0e21e 1092
1093int
1094db_sync(db, flags=0)
1095 DB_File db
1096 u_int flags
8e07c86e 1097 INIT:
1098 CurrentDB = db ;
a0d0e21e 1099
1100
1101int
1102db_seq(db, key, value, flags)
1103 DB_File db
1104 DBTKEY key
1105 DBT value
1106 u_int flags
8e07c86e 1107 INIT:
1108 CurrentDB = db ;
a0d0e21e 1109 OUTPUT:
1110 key
1111 value
610ab055 1112
Unnamed repository; edit this file to name it for gitweb.