File Coverage

Iterator.xs
Criterion Covered Total %
statement 93 97 95.8
branch 75 106 70.7
condition n/a
subroutine n/a
pod n/a
total 168 203 82.7


line stmt bran cond sub pod time code
1             /*
2             Copyright 2009, 2010, 2011, 2019 Kevin Ryde
3              
4             This file is part of File-Locate-Iterator.
5              
6             File-Locate-Iterator is free software; you can redistribute it and/or
7             modify it under the terms of the GNU General Public License as published
8             by the Free Software Foundation; either version 3, or (at your option)
9             any later version.
10              
11             File-Locate-Iterator is distributed in the hope that it will be useful,
12             but WITHOUT ANY WARRANTY; without even the implied warranty of
13             MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General
14             Public License for more details.
15              
16             You should have received a copy of the GNU General Public License along
17             with File-Locate-Iterator. If not, see . */
18              
19             #include
20             #include
21              
22             #include "EXTERN.h"
23             #include "perl.h"
24             #include "XSUB.h"
25              
26             /* POD docs in ppport.h. Must have at least ppport.h from Devel::PPPort
27             version 3.55 here for PERL_MAGIC_qr before SvRX.
28             */
29             #define NEED_SvRX
30             #define NEED_sv_2pv_flags
31             #include "ppport.h"
32              
33              
34             /* set this to 1 or 2 for some debug prints to stderr */
35             #define MY_DEBUG 0
36              
37              
38             #if MY_DEBUG >= 1
39             #define MY_DEBUG1(code) do { code; } while (0)
40             #else
41             #define MY_DEBUG1(code)
42             #endif
43             #if MY_DEBUG >= 2
44             #define MY_DEBUG2(code) do { code; } while (0)
45             #else
46             #define MY_DEBUG2(code)
47             #endif
48              
49             #define GET_FIELD(var,name) \
50             do { \
51             SV **svptr; \
52             field = (name); \
53             svptr = hv_fetch (h, field, strlen(field), 0); \
54             if (! svptr) goto FIELD_MISSING; \
55             (var) = *svptr; \
56             } while (0)
57              
58             #define MATCH(target) \
59             do { \
60             if (regexp) { \
61             if (CALLREGEXEC (regexp, \
62             entry_p, entry_p + entry_len, \
63             entry_p, 0, entry, NULL, \
64             REXEC_IGNOREPOS)) { \
65             goto target; \
66             } \
67             MY_DEBUG1 (fprintf (stderr, " no match regexp\n")); \
68             } else { \
69             if (! globs_ptr) { \
70             MY_DEBUG1 (fprintf (stderr, " no regexp or globs, so match\n")); \
71             goto target; \
72             } \
73             } \
74             { \
75             SSize_t i; \
76             for (i = 0; i <= globs_lastidx; i++) { \
77             MY_DEBUG2 (fprintf (stderr, " fnmatch \"%s\" entry \"%s\"\n", \
78             SvPV_nolen(globs_ptr[i]), entry_p)); \
79             if (fnmatch (SvPV_nolen(globs_ptr[i]), entry_p, 0) == 0) \
80             goto target; \
81             } \
82             MY_DEBUG1 (fprintf (stderr, " no match globs\n")); \
83             } \
84             MY_DEBUG1 (fprintf (stderr, " no match\n")); \
85             } while (0)
86              
87             MODULE = File::Locate::Iterator PACKAGE = File::Locate::Iterator
88              
89             void
90             next (SV *self)
91             CODE:
92             {
93             HV *h;
94             SV **mref_svptr, *entry, *sharelen_sv;
95 573           SV **globs_ptr = NULL;
96 573           SSize_t globs_lastidx = -1;
97 573           REGEXP *regexp = NULL;
98             const char *field;
99             char *entry_p;
100             STRLEN entry_len;
101             IV sharelen, adj;
102 573           int at_eof = 0;
103              
104             MY_DEBUG2 (fprintf (stderr, "FLI XS next()\n"));
105              
106 573           goto START;
107             {
108             FIELD_MISSING:
109 0           croak ("oops, missing '%s'", field);
110             }
111             START:
112 573           h = (HV*) SvRV(self);
113              
114 573 50         GET_FIELD (entry, "entry");
115              
116 573 50         GET_FIELD (sharelen_sv, "sharelen");
117 573 50         sharelen = SvIV (sharelen_sv);
118              
119             {
120 573           SV **regexp_svptr = hv_fetch (h, "regexp", 6, 0);
121 573 100         if (regexp_svptr) {
122 32           SV *regexp_sv = *regexp_svptr;
123             MY_DEBUG2(fprintf (stderr, "regexp sv="); sv_dump (regexp_sv));
124 32           regexp = SvRX(regexp_sv);
125             /* regexp=>undef is no regexp to match. Normally the regexp field
126             is omitted if undef (ie regexp_svptr==NULL), but the Moose stuff
127             insists on filling-in named attributes. :-( */
128 32 50         if (SvOK(regexp_sv)) {
    0          
    0          
129 32 50         if (! regexp) croak ("'regexp' not a regexp");
130             }
131             }
132             MY_DEBUG1 (fprintf (stderr, "REGEXP obj %"UVxf"\n", PTR2UV(regexp)));
133             }
134              
135             {
136 573           SV **globs_svptr = hv_fetch (h, "globs", 5, 0);
137 573 100         if (globs_svptr) {
138 24           SV *globs_sv = *globs_svptr;
139             /* globs=>undef is no globs to match. Normally the globs field is
140             omitted if undef (ie globs_svptr==NULL), but the Moose stuff
141             insists on filling-in named attributes. :-(
142             globs has been crunched by new(), so it's a plain array, no need
143             to worry about SvGetMagic() or whatnot. */
144 24 50         if (SvOK (globs_sv)) {
    0          
    0          
145 24 50         if (! SvROK (globs_sv))
146 0           croak ("oops, 'globs' not a reference");
147 24           AV *globs_av = (AV*) SvRV(globs_sv);
148              
149 24 50         if (SvTYPE(globs_av) != SVt_PVAV)
150 0           croak ("oops, 'globs' not an arrayref");
151 24           globs_ptr = AvARRAY (globs_av);
152 24           globs_lastidx = av_len (globs_av);
153             }
154             }
155             MY_DEBUG1 (fprintf
156             (stderr, "globs_svptr %"UVxf" globs_ptr %"UVxf" globs_lastidx %d\n",
157             PTR2UV(globs_svptr), PTR2UV(globs_ptr), globs_lastidx));
158             }
159              
160 573           mref_svptr = hv_fetch (h, "mref", 4, 0);
161 573 100         if (mref_svptr) {
162             SV *mref, *mmap, *pos_sv;
163 286           mref = *mref_svptr;
164             char *mp, *gets_beg, *gets_end;
165             STRLEN mlen;
166             UV pos;
167              
168 286           mmap = (SV*) SvRV(mref);
169 286 100         mp = SvPV (mmap, mlen);
170              
171 286 50         GET_FIELD (pos_sv, "pos");
172 286 50         pos = SvUV(pos_sv);
173             MY_DEBUG2 (fprintf (stderr, "mmap %"UVxf" mlen %u, pos %"UVuf"\n",
174             PTR2UV(mp), mlen, pos));
175              
176             for (;;) {
177             MY_DEBUG2 (fprintf (stderr, "MREF_LOOP\n"));
178 342 100         if (pos >= mlen) {
179             /* EOF */
180 36           at_eof = 1;
181 36           break;
182             }
183 306           adj = ((I8*)mp)[pos++];
184              
185 306 100         if (adj == -128) {
186             MY_DEBUG1 (fprintf (stderr, "two-byte adj at pos=%"UVuf"\n", pos));
187 72 100         if (pos >= mlen-1) goto UNEXPECTED_EOF;
188 132           adj = (I16) ((((U16) ((U8*)mp)[pos]) << 8)
189 66           + ((U8*)mp)[pos+1]);
190 66           pos += 2;
191             }
192             MY_DEBUG1 (fprintf (stderr, "adj %"IVdf" at pos=%"UVuf"\n", adj, pos));
193              
194 304           sharelen += adj;
195 304 100         if (sharelen < 0 || sharelen > SvCUR(entry)) {
    100          
196 8           sv_setpv (entry, NULL);
197 8           croak ("Invalid database contents (bad share length %"IVdf")",
198             sharelen);
199             }
200             MY_DEBUG1 (fprintf (stderr, "sharelen %"IVdf"\n", sharelen));
201              
202 296 100         if (pos >= mlen) goto UNEXPECTED_EOF;
203 294           gets_beg = mp + pos;
204 294           gets_end = memchr (gets_beg, '\0', mlen-pos);
205 294 100         if (! gets_end) {
206             MY_DEBUG1 (fprintf (stderr, "NUL not found gets_beg=%"UVxf" len=%lu\n",
207             PTR2UV(gets_beg), mlen-pos));
208 2           goto UNEXPECTED_EOF;
209             }
210              
211 292           SvCUR_set (entry, sharelen);
212 292           sv_catpvn (entry, gets_beg, gets_end - gets_beg);
213 292           pos = gets_end + 1 - mp;
214              
215 292 50         entry_p = SvPV(entry, entry_len);
216              
217 329 100         MATCH(MREF_LOOP_END);
    100          
    100          
    50          
    100          
    100          
218 56           }
219             MREF_LOOP_END:
220 272           SvUV_set (pos_sv, pos);
221              
222             } else {
223             SV *fh;
224             PerlIO *fp;
225             int got;
226             union {
227             char buf[2];
228             U16 u16;
229             } adj_u;
230             char *gets_ret;
231              
232 287 50         GET_FIELD (fh, "fh");
233 287           fp = IoIFP(sv_2io(fh));
234             MY_DEBUG2 (fprintf (stderr, "fp=%"UVxf" fh=\n", PTR2UV(fp));
235             sv_dump (fh));
236              
237             /* local $/ = "\0" */
238 287           save_item (PL_rs);
239 287           sv_setpvn (PL_rs, "\0", 1);
240              
241             for (;;) {
242             MY_DEBUG2 (fprintf (stderr, "IO_LOOP\n"));
243 302           got = PerlIO_read (fp, adj_u.buf, 1);
244 302 100         if (got == 0) {
245             /* EOF */
246 16           at_eof = 1;
247 16           break;
248             }
249 286 50         if (got != 1) {
250             READ_ERROR:
251             MY_DEBUG1 (fprintf (stderr, "read fp=%"UVxf" got=%d\n",
252             PTR2UV(fp), got));
253 2 50         if (got < 0) {
254 0           croak ("Error reading database");
255             } else {
256             UNEXPECTED_EOF:
257 12           croak ("Invalid database contents (unexpected EOF)");
258             }
259             }
260              
261 286           adj = (I8) adj_u.buf[0];
262 286 100         if (adj == -128) {
263             MY_DEBUG1 (fprintf (stderr, "two-byte adj\n"));
264 72           got = PerlIO_read (fp, adj_u.buf, 2);
265 72 100         if (got != 2) goto READ_ERROR;
266             MY_DEBUG1 (fprintf (stderr, "raw %X,%X %X ntohs %X\n",
267             (int) (U8) adj_u.buf[0], (int) (U8) adj_u.buf[1],
268             adj_u.u16, ntohs(adj_u.u16)));
269 70           adj = (int) (I16) ntohs(adj_u.u16);
270             }
271             MY_DEBUG1 (fprintf (stderr, "adj %"IVdf" %#"UVxf"\n", adj, adj));
272              
273 284           sharelen += adj;
274             MY_DEBUG1 (fprintf (stderr, "sharelen %"IVdf" %#"UVxf" SvCUR %d utf8 %d\n",
275             sharelen, sharelen,
276             SvCUR(entry), SvUTF8(entry)));
277              
278 284 100         if (sharelen < 0 || sharelen > SvCUR(entry)) {
    100          
279 8           sv_setpv (entry, NULL);
280 8           croak ("Invalid database contents (bad share length %"IVdf")",
281             sharelen);
282             }
283              
284             /* sv_gets() in perl 5.10.1 and earlier must have "append" equal to
285             SvCUR(sv). The "fast" direct buffer access takes it as a byte
286             position to store to, but the plain read code takes it as a flag
287             to do sv_catpvn() instead of sv_setpvn(). This appears to be so
288             right back to 5.002 ("fast" access directly into a FILE*). So
289             SvCUR_set() here to work in either case. */
290 276           SvCUR_set (entry, sharelen);
291              
292 276           gets_ret = sv_gets (entry, fp, sharelen);
293 276 100         if (gets_ret == NULL) goto UNEXPECTED_EOF;
294             MY_DEBUG2 (fprintf (stderr,
295             "entry gets to %u, chomp to %u, fpos now %lu(%#lx)\n",
296             SvCUR(entry), SvCUR(entry) - 1,
297             (unsigned long) PerlIO_tell(fp),
298             (unsigned long) PerlIO_tell(fp));
299             fprintf (stderr, "entry gets to %u, chomp to %u\n",
300             SvCUR(entry), SvCUR(entry) - 1));
301              
302 274 50         entry_p = SvPV(entry, entry_len);
303 274 50         if (entry_len < 1 || entry_p[entry_len-1] != '\0') {
    100          
304             MY_DEBUG1 (fprintf (stderr, "no NUL from sv_gets\n"));
305             goto UNEXPECTED_EOF;
306             }
307 272           entry_len--;
308 272           SvCUR_set (entry, entry_len); /* chomp \0 terminator */
309              
310 287 50         MATCH(IO_LOOP_END);
    0          
    100          
    50          
    100          
    100          
311 15           }
312             IO_LOOP_END:
313             /* taint the same as other reads from a file, and in particular the
314             same as from the pure-perl reads */
315 273 50         SvTAINTED_on(entry);
316             }
317 545 100         if (at_eof) {
318 52           sv_setpv (entry, NULL);
319             MY_DEBUG2 (fprintf (stderr, "eof\n entry=\n");
320             sv_dump (entry);
321             fprintf (stderr, "\n"));
322 52           XSRETURN(0);
323              
324             } else {
325 493           SvUV_set (sharelen_sv, sharelen);
326             MY_DEBUG2 (fprintf (stderr, "return entry=\n");
327             sv_dump (entry);
328             fprintf (stderr, "\n"));
329              
330 493 50         SvREFCNT_inc_simple_void (entry);
331 493           ST(0) = sv_2mortal(entry);
332 545           XSRETURN(1);
333             }
334             }