This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Add PERL_NO_GET_CONTEXT to ODBM_File
[perl5.git] / ext / ODBM_File / ODBM_File.xs
CommitLineData
040eaf47
NC
1#define PERL_NO_GET_CONTEXT
2
463ee0b2
LW
3#include "EXTERN.h"
4#include "perl.h"
5#include "XSUB.h"
6
8e07c86e
AD
7#ifdef I_DBM
8# include <dbm.h>
9#else
10# ifdef I_RPCSVC_DBM
11# include <rpcsvc/dbm.h>
12# endif
13#endif
463ee0b2 14
2ef53570
JH
15#ifndef HAS_DBMINIT_PROTO
16int dbminit(char* filename);
17int dbmclose(void);
18datum fetch(datum key);
19int store(datum key, datum dat);
eb5402b2 20int delete(datum key);
2ef53570
JH
21datum firstkey(void);
22datum nextkey(datum key);
23#endif
24
1639c7b3
PP
25#ifdef DBM_BUG_DUPLICATE_FREE
26/*
27 * DBM on at least Ultrix and HPUX call dbmclose() from dbminit(),
28 * resulting in duplicate free() because dbmclose() does *not*
29 * check if it has already been called for this DBM.
30 * If some malloc/free calls have been done between dbmclose() and
31 * the next dbminit(), the memory might be used for something else when
32 * it is freed.
33 * Verified to work on ultrix4.3. Probably will work on HP/UX.
34 * Set DBM_BUG_DUPLICATE_FREE in the extension hint file.
35 */
36/* Close the previous dbm, and fail to open a new dbm */
2359510d 37#define dbmclose() ((void) dbminit("/non/exist/ent"))
1639c7b3
PP
38#endif
39
463ee0b2
LW
40#include <fcntl.h>
41
a4051d29
NC
42#define fetch_key 0
43#define store_key 1
44#define fetch_value 2
45#define store_value 3
46
9fe6733a
PM
47typedef struct {
48 void * dbp ;
a4051d29 49 SV * filter[4];
9fe6733a
PM
50 int filtering ;
51 } ODBM_File_type;
52
53typedef ODBM_File_type * ODBM_File ;
54typedef datum datum_key ;
0bf2e707 55typedef datum datum_key_copy ;
9fe6733a
PM
56typedef datum datum_value ;
57
a0d0e21e
LW
58#define odbm_FETCH(db,key) fetch(key)
59#define odbm_STORE(db,key,value,flags) store(key,value)
2b9198b7 60#define odbm_DELETE(db,key) delete(key)
a0d0e21e
LW
61#define odbm_FIRSTKEY(db) firstkey()
62#define odbm_NEXTKEY(db,key) nextkey(key)
463ee0b2 63
df3728a2
JH
64#define MY_CXT_KEY "ODBM_File::_guts" XS_VERSION
65
66typedef struct {
67 int x_dbmrefcnt;
68} my_cxt_t;
69
70START_MY_CXT
71
72#define dbmrefcnt (MY_CXT.x_dbmrefcnt)
463ee0b2 73
85e6fe83 74#ifndef DBM_REPLACE
463ee0b2 75#define DBM_REPLACE 0
85e6fe83 76#endif
463ee0b2
LW
77
78MODULE = ODBM_File PACKAGE = ODBM_File PREFIX = odbm_
79
df3728a2
JH
80BOOT:
81{
82 MY_CXT_INIT;
83}
84
463ee0b2 85ODBM_File
a0d0e21e 86odbm_TIEHASH(dbtype, filename, flags, mode)
463ee0b2
LW
87 char * dbtype
88 char * filename
89 int flags
90 int mode
91 CODE:
92 {
46fc3d4c 93 char *tmpbuf;
9fe6733a 94 void * dbp ;
df3728a2
JH
95 dMY_CXT;
96
463ee0b2
LW
97 if (dbmrefcnt++)
98 croak("Old dbm can only open one database");
a02a5408 99 Newx(tmpbuf, strlen(filename) + 5, char);
46fc3d4c 100 SAVEFREEPV(tmpbuf);
463ee0b2 101 sprintf(tmpbuf,"%s.dir",filename);
3280af22 102 if (stat(tmpbuf, &PL_statbuf) < 0) {
463ee0b2
LW
103 if (flags & O_CREAT) {
104 if (mode < 0 || close(creat(tmpbuf,mode)) < 0)
105 croak("ODBM_File: Can't create %s", filename);
106 sprintf(tmpbuf,"%s.pag",filename);
107 if (close(creat(tmpbuf,mode)) < 0)
108 croak("ODBM_File: Can't create %s", filename);
109 }
110 else
111 croak("ODBM_FILE: Can't open %s", filename);
112 }
9fe6733a 113 dbp = (void*)(dbminit(filename) >= 0 ? &dbmrefcnt : 0);
a5c6857c 114 RETVAL = (ODBM_File)safecalloc(1, sizeof(ODBM_File_type));
9fe6733a 115 RETVAL->dbp = dbp ;
6b88bc9c 116 ST(0) = sv_mortalcopy(&PL_sv_undef);
56431972 117 sv_setptrobj(ST(0), RETVAL, dbtype);
463ee0b2
LW
118 }
119
120void
121DESTROY(db)
122 ODBM_File db
df3728a2
JH
123 PREINIT:
124 dMY_CXT;
a4051d29 125 int i = store_value;
463ee0b2
LW
126 CODE:
127 dbmrefcnt--;
128 dbmclose();
a4051d29
NC
129 do {
130 if (db->filter[i])
131 SvREFCNT_dec(db->filter[i]);
132 } while (i-- > 0);
eb99164f 133 safefree(db);
463ee0b2 134
1b882d32 135datum_value
a0d0e21e 136odbm_FETCH(db, key)
463ee0b2 137 ODBM_File db
0bf2e707 138 datum_key_copy key
463ee0b2
LW
139
140int
a0d0e21e 141odbm_STORE(db, key, value, flags = DBM_REPLACE)
463ee0b2 142 ODBM_File db
9fe6733a
PM
143 datum_key key
144 datum_value value
463ee0b2 145 int flags
a0d0e21e
LW
146 CLEANUP:
147 if (RETVAL) {
148 if (RETVAL < 0 && errno == EPERM)
149 croak("No write permission to odbm file");
748a9306 150 croak("odbm store returned %d, errno %d, key \"%s\"",
a0d0e21e
LW
151 RETVAL,errno,key.dptr);
152 }
463ee0b2
LW
153
154int
a0d0e21e 155odbm_DELETE(db, key)
463ee0b2 156 ODBM_File db
9fe6733a 157 datum_key key
463ee0b2 158
9fe6733a 159datum_key
a0d0e21e 160odbm_FIRSTKEY(db)
463ee0b2
LW
161 ODBM_File db
162
9fe6733a 163datum_key
a0d0e21e 164odbm_NEXTKEY(db, key)
463ee0b2 165 ODBM_File db
9fe6733a
PM
166 datum_key key
167
168
169#define setFilter(type) \
170 { \
171 if (db->type) \
cad2e5aa
JH
172 RETVAL = sv_mortalcopy(db->type) ; \
173 ST(0) = RETVAL ; \
9fe6733a
PM
174 if (db->type && (code == &PL_sv_undef)) { \
175 SvREFCNT_dec(db->type) ; \
1b882d32 176 db->type = Nullsv ; \
9fe6733a
PM
177 } \
178 else if (code) { \
179 if (db->type) \
180 sv_setsv(db->type, code) ; \
181 else \
182 db->type = newSVsv(code) ; \
183 } \
184 }
185
186
187
188SV *
189filter_fetch_key(db, code)
190 ODBM_File db
191 SV * code
192 SV * RETVAL = &PL_sv_undef ;
a4051d29
NC
193 ALIAS:
194 ODBM_File::filter_fetch_key = fetch_key
195 ODBM_File::filter_store_key = store_key
196 ODBM_File::filter_fetch_value = fetch_value
197 ODBM_File::filter_store_value = store_value
9fe6733a 198 CODE:
a4051d29 199 DBM_setFilter(db->filter[ix], code);