1 #ifdef __cplusplus
2 extern "C" {
3 #endif
4 #include "EXTERN.h"
5 #include "perl.h"
6 #include "XSUB.h"
7 #ifdef __cplusplus
8 }
9 #endif
10
11 #include <sys/types.h>
12 #include <sys/mman.h>
13 #include <errno.h>
14 #include <fcntl.h>
15 #include <stdio.h>
16 #include <string.h>
17 #include <unistd.h>
18
19 #if PERL_REVISION > 5 || (PERL_REVISION == 5 && (PERL_VERSION > 5 || (PERL_VERSION == 5 && (PERL_SUBVERSION > 57))))
20 # define MODERN_PERL
21 #endif
22
23 #if INTSIZE != 4
24 # error Works only with INTSIZE=4
25 #endif
26
27 #if !defined(PL_na) && !defined(MODERN_PERL)
28 # define PL_na na
29 #endif
30 #if !defined(PL_sv_undef) && !defined(MODERN_PERL)
31 # define PL_sv_undef sv_undef
32 #endif
33
34 #define VAR_LEN 1
35 #define FREEZED 2
36
37 struct VirtArray {
38 caddr_t filebuf;
39 long filebuflen;
40 int fd;
41 I32 is_var_len;
42 I32 freezed;
43 I32 len;
44 I32 reclen;
45 caddr_t start_data;
46 };
47 typedef struct VirtArray* VirtArray;
48
49 #define MAGIC_LEN 8
50 #define HEADER_LEN_VAR (MAGIC_LEN+sizeof(I32)*2)
51 #define HEADER_LEN_FIXED (MAGIC_LEN+sizeof(I32)*3)
52
53 #ifndef MAP_FAILED
54 #define MAP_FAILED ((caddr_t)-1)
55 #endif
56
57 static VirtArray dflt_array = NULL;
58
59 /* schnelles FETCH: keine �bergabe des Objekts (siehe set_default) */
XS(XS_VirtArray_fast_fetch)60 XS(XS_VirtArray_fast_fetch)
61 {
62 dXSARGS;
63 if (items != 1)
64 croak("Usage: VirtArray::fast_fetch(i)");
65 {
66 long i = (long)SvIV(ST(0));
67 SV * RETVAL;
68
69 if (!dflt_array->is_var_len) {
70 RETVAL = newSVpv((char*)(dflt_array->start_data+i*dflt_array->reclen),
71 dflt_array->reclen);
72 } else {
73 long i0 = (long)*(I32*)(dflt_array->filebuf+HEADER_LEN_VAR+i*sizeof(I32));
74 long i1 = (long)*(I32*)(dflt_array->filebuf+HEADER_LEN_VAR+(i+1)*sizeof(I32));
75 RETVAL = newSVpv((char*)(dflt_array->start_data+i0), i1-i0);
76 }
77 ST(0) = RETVAL;
78 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
79 }
80 XSRETURN(1);
81 }
82
XS(XS_VirtArray_fast_fetch_var)83 XS(XS_VirtArray_fast_fetch_var)
84 {
85 dXSARGS;
86 if (items != 1)
87 croak("Usage: VirtArray::fast_fetch_var(i)");
88 {
89 long i = (long)SvIV(ST(0));
90
91 long i0 = (long)*(I32*)(dflt_array->filebuf+HEADER_LEN_VAR+i*sizeof(I32));
92 long i1 = (long)*(I32*)(dflt_array->filebuf+HEADER_LEN_VAR+(i+1)*sizeof(I32));
93 ST(0) = newSVpv((char*)(dflt_array->start_data+i0), i1-i0);
94 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
95 }
96 XSRETURN(1);
97 }
98
XS(XS_VirtArray_fast_fetch_fixed)99 XS(XS_VirtArray_fast_fetch_fixed)
100 {
101 dXSARGS;
102 if (items != 1)
103 croak("Usage: VirtArray::fast_fetch_fixed(i)");
104 {
105 long i = (long)SvIV(ST(0));
106
107 ST(0) = newSVpv((char*)(dflt_array->start_data+i*dflt_array->reclen),
108 dflt_array->reclen);
109 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
110 }
111 XSRETURN(1);
112 }
113
114 MODULE = VirtArray PACKAGE = VirtArray
115
116 VirtArray
117 TIEARRAY(package, filename)
118 char* package;
119 char* filename;
120 PREINIT:
121 SV* ref;
122 SV* magic;
123 I32 flags;
124 CODE:
125 RETVAL = safemalloc(sizeof(struct VirtArray));
126 if (RETVAL == NULL)
127 croak("Can't alloc memory for VirtArray");
128 RETVAL->filebuf = MAP_FAILED;
129 if ((RETVAL->fd = open(filename, O_RDONLY)) < 0)
130 croak("Can't open %s: %s", filename, strerror(errno));
131 RETVAL->filebuflen = lseek(RETVAL->fd, 0, SEEK_END);
132 if ((RETVAL->filebuf = mmap(0, RETVAL->filebuflen, PROT_READ, MAP_SHARED, RETVAL->fd, 0)) == MAP_FAILED)
133 croak("Can't mmap %s: %s", filename, strerror(errno));
134
135 /* check for magic number */
136 magic = newSVsv(perl_get_sv("VirtArray::magic", TRUE));
137 sv_catsv(magic, perl_get_sv("VirtArray::formatversion", TRUE));
138 if (strncmp(SvPV(magic, PL_na), RETVAL->filebuf, MAGIC_LEN) != 0)
139 croak("Got wrong magic number in %s", filename);
140 SvREFCNT_dec(magic);
141
142 flags = *(I32*)(RETVAL->filebuf+MAGIC_LEN);
143 RETVAL->is_var_len = flags & VAR_LEN;
144 RETVAL->freezed = flags & FREEZED;
145 if (RETVAL->freezed) {
146 perl_require_pv("Storable.pm");
147 }
148
149 RETVAL->len = *(I32*)(RETVAL->filebuf+MAGIC_LEN+sizeof(I32));
150 if (!RETVAL->is_var_len) {
151 RETVAL->reclen = *(I32*)(RETVAL->filebuf+MAGIC_LEN+sizeof(I32)*2);
152 RETVAL->start_data = RETVAL->filebuf + HEADER_LEN_FIXED;
153 } else
154 RETVAL->start_data = RETVAL->filebuf + HEADER_LEN_VAR + (RETVAL->len+1)*sizeof(I32);
155
156 if (SvTRUE(perl_get_sv("VirtArray::VERBOSE", FALSE)))
157 fprintf(stderr, "File %s is `mmap'ed and contains %s%s data\n",
158 filename,
159 (RETVAL->is_var_len ? "variable" : "fixed"),
160 (RETVAL->freezed ? " complex" : "")
161 );
162
163 ref = newSViv((long)RETVAL);
164 /* XXX del: ST(0) = sv_2mortal(newRV_inc(ref)); */
165 ST(0) = sv_2mortal(newRV_noinc(ref));
166 sv_bless(ST(0), gv_stashpv(package, TRUE));
167
168 SV*
FETCH(self,i)169 FETCH(self, i)
170 VirtArray self;
171 long i;
172 CODE:
173 if (!self->is_var_len) {
174 RETVAL = newSVpv((char*)(self->start_data+i*self->reclen),
175 self->reclen);
176 } else {
177 SV* tmp;
178 long i0 = (long)*(I32*)(self->filebuf+HEADER_LEN_VAR+i*sizeof(I32));
179 long i1 = (long)*(I32*)(self->filebuf+HEADER_LEN_VAR+(i+1)*sizeof(I32));
180 tmp = newSVpv((char*)(self->start_data+i0), i1-i0);
181 if (self->freezed) {
182 dSP;
183 int count;
184 ENTER;
185 SAVETMPS;
186
187 PUSHMARK(SP);
188 XPUSHs(tmp);
189 PUTBACK;
190
191 count = perl_call_pv("Storable::thaw", G_SCALAR);
192 SPAGAIN;
193
194 SvREFCNT_dec(tmp);
195
196 tmp = newSVsv(POPs);
197 PUTBACK ;
198 FREETMPS ;
199 LEAVE ;
200 }
201 RETVAL = tmp;
202 }
203 OUTPUT:
204 RETVAL
205
206 void
207 DESTROY(self)
208 VirtArray self;
209 CODE:
210 if (self->filebuf != MAP_FAILED)
211 if (munmap(self->filebuf, self->filebuflen) != 0)
212 croak("Can't free mmap region: %s", strerror(errno));
213 if (self->fd >= 0)
214 close(self->fd);
215 safefree(self);
216
217 int
218 FETCHSIZE(self)
219 VirtArray self;
220 CODE:
221 /* STORESIZE? */
222 RETVAL = self->len;
223 OUTPUT:
224 RETVAL
225
226 void
227 printinfo(self)
228 VirtArray self;
229 CODE:
230 printf("Filebuf address: %p\n", self->filebuf);
231 printf("Filebuf len: %ld\n", self->filebuflen);
232 printf("File descriptor: %d\n", self->fd);
233 printf("Variable length: %s\n", (self->is_var_len ? "yes" : "no"));
234 printf("Freezed: %s\n", (self->freezed ? "yes" : "no"));
235 printf("Length: %ld\n", self->len);
236 printf("Record length: %ld\n", self->reclen);
237
238 void
239 fetch_list_var(self, i)
240 VirtArray self;
241 long i;
242 PREINIT:
243 /* nur f�r Arrays mit variabler L�nge
244 * gibt eine Liste von Integern zur�ck
245 * XXX funktioniert nicht f�r freezed Dateien
246 */
247 char *data;
248 long i0, i1, len;
249 int ii;
250 PPCODE:
251 i0 = (long)*(I32*)(self->filebuf+HEADER_LEN_VAR+i*sizeof(I32));
252 i1 = (long)*(I32*)(self->filebuf+HEADER_LEN_VAR+(i+1)*sizeof(I32));
253 data = (char*)(self->start_data+i0);
254 len = (i1-i0)/sizeof(I32);
255 EXTEND(sp, len);
256 for(ii = 0; ii < len; ii++)
257 PUSHs(sv_2mortal(newSViv((long)*(I32*)(data+sizeof(I32)*ii))));
258
259 void
260 fetch_list_fixed(self, i)
261 VirtArray self;
262 long i;
263 PREINIT:
264 /* nur f�r Arrays mit fixer L�nge
265 * gibt eine Liste von Integern zur�ck
266 */
267 long len;
268 int ii;
269 PPCODE:
270 len = self->reclen/sizeof(I32);
271 EXTEND(sp, len);
272 for(ii = 0; ii < len; ii++)
273 PUSHs(sv_2mortal(newSViv((long)*(I32*)(self->start_data+i*self->reclen+ii))));
274
275 void
276 set_default(self)
277 VirtArray self;
278 CODE:
279 /* set_default setzt das Objekt f�r fast_fetch fest */
280 dflt_array = self;
281
282 BOOT:
283 newXS("VirtArray::fast_fetch", XS_VirtArray_fast_fetch, file);
284 newXS("VirtArray::fast_fetch_var", XS_VirtArray_fast_fetch_var, file);
285 newXS("VirtArray::fast_fetch_fixed", XS_VirtArray_fast_fetch_fixed, file);
286
287