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