1 /*
2 :reverse - Reads lines backward
3 */
4 #include "perlioutil.h"
5
6 #define IOR(f) (PerlIOSelf(f, PerlIOReverse))
7
8
9 #define REV_BUFSIZ 4096
10
11 #define SEGSV_BUFSIZ 512
12 #define BUFSV_BUFSIZ (REV_BUFSIZ+SEGSV_BUFSIZ)
13
14
15 typedef struct{
16 struct _PerlIO base;
17
18 STDCHAR buffer[ REV_BUFSIZ ]; /* first buffer */
19
20 SV* segsv; /* broken segment */
21
22 SV* bufsv; /* reversed buffer */
23 STDCHAR* ptr;
24 STDCHAR* end;
25 } PerlIOReverse;
26
27 static PerlIO*
PerlIOReverse_open(pTHX_ PerlIO_funcs * const self,PerlIO_list_t * const layers,IV const n,const char * const mode,int const fd,int const imode,int const perm,PerlIO * f,int const narg,SV ** const args)28 PerlIOReverse_open(pTHX_ PerlIO_funcs* const self, PerlIO_list_t* const layers, IV const n,
29 const char* const mode, int const fd, int const imode, int const perm,
30 PerlIO* f, int const narg, SV** const args){
31 PerlIO_funcs* tab;
32
33 assert(layers->cur > 0);
34 tab = LayerFetch(layers, 0); /* :unix or :scalar */
35
36 if(!(tab && tab->Open) || PerlIOUnix_oflags(mode) & (O_WRONLY | O_RDWR) ){
37 SETERRNO(EINVAL, LIB_INVARG);
38 return NULL;
39 }
40
41 f = tab->Open(aTHX_ tab, layers, (IV)1, mode, fd, imode, perm, f, narg, args);
42
43 if(f){
44 if(!PerlIO_push(aTHX_ f, self, mode, PerlIOArg)){
45 PerlIO_close(f);
46 return NULL;
47 }
48 }
49 return f;
50 }
51
52 static IV
PerlIOReverse_pushed(pTHX_ PerlIO * const f,const char * const mode,SV * const arg,PerlIO_funcs * const tab)53 PerlIOReverse_pushed(pTHX_ PerlIO* const f, const char* const mode, SV* const arg, PerlIO_funcs* const tab){
54 PerlIOReverse* ior;
55 PerlIO* nx;
56 Off_t pos;
57 PerlIO* p;
58
59 if(!(PerlIOValid(f) && (nx = PerlIONext(f)) && PerlIOValid(nx))){
60 SETERRNO(EBADF, SS_IVCHAN);
61 return -1;
62 }
63
64 if(!IOLflag(nx, PERLIO_F_CANREAD)){
65 SETERRNO(EINVAL, LIB_INVARG);
66 return -1;
67 }
68
69 for(p = nx; PerlIOValid(p); p = PerlIONext(p)){
70 if(!(PerlIOBase(p)->tab->kind & PERLIO_K_RAW)
71 || (PerlIOBase(p)->flags & PERLIO_F_CRLF)){
72
73 PerlIOUtil_warnif(aTHX_ packWARN(WARN_LAYER),
74 ":%s is not a raw layer",
75 PerlIOBase(p)->tab->name);
76 SETERRNO(EINVAL, LIB_INVARG);
77 return -1;
78 }
79 }
80
81 pos = PerlIO_tell(nx);
82 if(pos <= 0){
83 if(pos < 0 || PerlIO_seek(nx, (Off_t)0, SEEK_END) < 0){
84 return -1;
85 }
86 }
87
88 ior = IOR(f);
89 ior->segsv = newSV(SEGSV_BUFSIZ);
90 ior->bufsv = newSV(BUFSV_BUFSIZ);
91
92 assert( ior->bufsv );
93 assert( ior->segsv );
94
95 sv_setpvn(ior->bufsv, "", 0);
96 sv_setpvn(ior->segsv, "", 0);
97
98 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
99 }
100 static IV
PerlIOReverse_popped(pTHX_ PerlIO * const f)101 PerlIOReverse_popped(pTHX_ PerlIO* const f){
102 PerlIOReverse* const ior = IOR(f);
103
104 PerlIO_debug("PerlIOReverse_popped:"
105 " bufsv=%ld, segsv=%ld\n",
106 (long)(ior->bufsv ? SvLEN(ior->bufsv) : 0),
107 (long)(ior->segsv ? SvLEN(ior->segsv) : 0));
108
109 SvREFCNT_dec(ior->bufsv);
110 SvREFCNT_dec(ior->segsv);
111
112 return PerlIOBase_popped(aTHX_ f);
113 }
114
115 #if defined(IOR_DEBUGGING)
116
117 #define write_buf(s, l, m) PerlIOReverse_debug_write_buf(aTHX_ s, l, m)
118 #define write_bufsv(sv, msg) PerlIOReverse_debug_write_buf(aTHX_ SvPVX(sv), SvCUR(sv), msg)
119
120 /* to pass -Wmissing-prototypes -Wunused-function */
121 void
122 PerlIOReverse_debug_write_buf(pTHX_ register const STDCHAR*, const Size_t count, const STDCHAR* msg);
123
124 void
PerlIOReverse_debug_write_buf(pTHX_ register const STDCHAR * src,const Size_t count,const STDCHAR * msg)125 PerlIOReverse_debug_write_buf(pTHX_ register const STDCHAR* src, const Size_t count, const STDCHAR* msg){
126 char* buf;
127 char* end;
128 register char* ptr;
129
130 Newx(buf, count, char);
131
132 ptr = buf;
133 end = buf + count;
134 /* write the buffer */
135
136 while(ptr < end){
137 *ptr = (*src == '\0' ? '@' : *src);
138 ptr++;
139 src++;
140 }
141 if(msg){
142 PerlIO_write(PerlIO_stderr(), msg, strlen(msg));
143 }
144 PerlIO_write(PerlIO_stderr(), "[", 1);
145 PerlIO_write(PerlIO_stderr(), buf, count);
146 Perl_warn(aTHX_ "]");
147 //PerlIO_write(PerlIO_stderr(), "]\n", 2);
148
149 Safefree(buf);
150 }
151 #endif /* IOR_DEBUGGING */
152
153 static IV
PerlIOReverse_flush(pTHX_ PerlIO * const f)154 PerlIOReverse_flush(pTHX_ PerlIO* const f){
155 if(IOLflag(f, PERLIO_F_RDBUF)){
156 PerlIOReverse* ior = IOR(f);
157 Off_t offset = (ior->end - ior->ptr) + SvCUR(ior->segsv);
158 SvCUR(ior->bufsv) = SvCUR(ior->segsv) = 0;
159 ior->end = ior->ptr = SvPVX(ior->bufsv);
160
161 IOLflag_off(f, PERLIO_F_RDBUF);
162 PerlIO_seek(PerlIONext(f), offset , SEEK_CUR);
163 }
164 return PerlIO_flush(PerlIONext(f));
165 }
166
167 static SSize_t
reverse_read(pTHX_ PerlIO * const f,STDCHAR * const vbuf,SSize_t count)168 reverse_read(pTHX_ PerlIO* const f, STDCHAR* const vbuf, SSize_t count){
169 PerlIO* const nx = PerlIONext(f);
170 SSize_t avail = 0;
171 Off_t const pos = PerlIO_tell(nx);
172
173 assert( pos == (SSize_t)pos ); /* XXX: What should I do? */
174
175 if(pos <= 0){
176 IOLflag_on(f, pos < 0 ? PERLIO_F_ERROR : PERLIO_F_EOF);
177
178 return (SSize_t)pos;
179 }
180
181 if(pos < count){
182 count = (SSize_t)pos;
183 }
184
185 if(PerlIO_seek(nx, (Off_t)-count, SEEK_CUR) < 0){
186 IOLflag_on(f, PERLIO_F_ERROR);
187 return -1;
188 }
189
190 while(avail < count){
191 SSize_t s = PerlIO_read(nx, vbuf+avail, (Size_t)(count - avail));
192 if(s > 0){
193 avail += s;
194 }
195 else{
196 break;
197 }
198 }
199
200 if(PerlIO_seek(nx, (Off_t)-avail, SEEK_CUR) < 0){
201 IOLflag_on(f, PERLIO_F_ERROR);
202
203 return -1;
204 }
205 return avail;
206 }
207
208
209
210 static IV
PerlIOReverse_fill(pTHX_ PerlIO * const f)211 PerlIOReverse_fill(pTHX_ PerlIO* const f){
212 PerlIOReverse* const ior = IOR(f);
213 SSize_t avail;
214
215 SV* const bufsv = ior->bufsv;
216 SV* const segsv = ior->segsv;
217 STDCHAR* rbuf;
218
219 STDCHAR* const buf = ior->buffer;
220 STDCHAR* ptr;
221 const STDCHAR* end;
222 const STDCHAR* start;
223
224 SvCUR(bufsv) = 0;
225
226 retry:
227 avail = reverse_read(aTHX_ f, buf, REV_BUFSIZ);
228
229 if(avail < 0){
230 return -1;
231 }
232
233 start = ptr = buf;
234 end = buf + avail;
235
236 if(avail == REV_BUFSIZ){ /* not EOF */
237 while(ptr < end){
238 if(*(ptr++) == '\n') break;
239 }
240
241 /* available buffer has no newlines */
242 if(ptr == end){
243 /* fill segment simply */
244 sv_insert(segsv, 0, 0, buf, (Size_t)avail);
245
246 goto retry;
247 }
248 }
249
250 /* solve previous segment */
251 if(SvCUR(segsv) > 0){
252 const STDCHAR* p = end;
253 while(p >= ptr){
254 if(*(--p) == '\n') break;
255 }
256 p++;
257 /* buf[oo\nbar\nba]
258 ^ ^ ^
259 start ptr p
260
261 seg[z\n]
262 */
263
264 sv_grow(bufsv, (end - ptr) + SvCUR(segsv));
265
266 sv_setpvn(bufsv, p, (Size_t)(end - p));
267 sv_catsv( bufsv, segsv);
268 end = p;
269 }
270 /*write_buf(start, (Size_t)(ptr - start), "");*/
271
272 sv_setpvn(segsv, start, (Size_t)(ptr - start));
273 start = ptr;
274
275 rbuf = SvPVX(bufsv) + SvCUR(bufsv);
276 SvCUR(bufsv) += end - start;
277
278 assert(SvCUR(bufsv) <= SvLEN(bufsv));
279
280 while(ptr < end){
281 if(*(ptr++) == '\n'){
282 /* line length: ptr - start */
283 /* write pos: end - ptr */
284
285 Copy( start,
286 rbuf + (end - ptr),
287 ptr - start, STDCHAR);
288
289 start = ptr;
290 }
291 }
292 if(start != end){
293 Copy( start, rbuf + (end - ptr), ptr - start, STDCHAR);
294 }
295
296
297 /*
298 write_bufsv(segsv, "segm");
299 write_buf(start, end - start, "buf");
300 write_bufsv(segsv, "rbuf");
301 // */
302 ior->ptr = SvPVX(bufsv);
303 ior->end = SvPVX(bufsv) + SvCUR(bufsv);
304
305 if( SvCUR(bufsv) == 0 ){
306 return -1;
307 }
308
309 IOLflag_on(f, PERLIO_F_RDBUF);
310
311 return 0;
312 }
313
314 static STDCHAR*
PerlIOReverse_get_base(pTHX_ PerlIO * const f)315 PerlIOReverse_get_base(pTHX_ PerlIO* const f){
316 return SvPVX(IOR(f)->bufsv);
317 }
318
319 static STDCHAR*
PerlIOReverse_get_ptr(pTHX_ PerlIO * const f)320 PerlIOReverse_get_ptr(pTHX_ PerlIO* const f){
321 return IOR(f)->ptr;
322 }
323
324 static SSize_t
PerlIOReverse_get_cnt(pTHX_ PerlIO * const f)325 PerlIOReverse_get_cnt(pTHX_ PerlIO* const f){
326 return IOR(f)->end - IOR(f)->ptr;
327 }
328
329 static Size_t
PerlIOReverse_bufsiz(pTHX_ PerlIO * const f)330 PerlIOReverse_bufsiz(pTHX_ PerlIO* const f){
331 return SvCUR(IOR(f)->bufsv);
332 }
333
334 static void
PerlIOReverse_set_ptrcnt(pTHX_ PerlIO * const f,STDCHAR * const ptr,SSize_t const cnt)335 PerlIOReverse_set_ptrcnt(pTHX_ PerlIO* const f, STDCHAR* const ptr, SSize_t const cnt){
336 PERL_UNUSED_ARG(cnt);
337
338 IOR(f)->ptr = ptr;
339 }
340
341 static IV
PerlIOReverse_seek(pTHX_ PerlIO * const f,Off_t const offset,int whence)342 PerlIOReverse_seek(pTHX_ PerlIO* const f, Off_t const offset, int whence){
343 PerlIO* const nx = PerlIONext(f);
344
345 PerlIOReverse_flush(aTHX_ f);
346
347 switch(whence){
348 case SEEK_SET:
349 whence = SEEK_END;
350 break;
351 case SEEK_END:
352 whence = SEEK_SET;
353 break;
354 }
355 return PerlIO_seek(nx, -offset, whence);
356 }
357 static Off_t
PerlIOReverse_tell(pTHX_ PerlIO * const f)358 PerlIOReverse_tell(pTHX_ PerlIO* const f){
359 PerlIO* const nx = PerlIONext(f);
360 Off_t const current = PerlIO_tell(nx);
361 Off_t end;
362
363 if(PerlIO_seek(nx, (Off_t)0, SEEK_END) < 0){
364 return -1;
365 }
366 end = PerlIO_tell(nx);
367 if(PerlIO_seek(nx, current, SEEK_SET) < 0){
368 return -1;
369 }
370
371 /*
372 warn("(end=%d - pos=%d) - (cnt=%d + segsv=%d) = %d",
373 (int)end, (int)current, (int)(IOR(f)->end-IOR(f)->ptr), (int)SvCUR(IOR(f)->segsv),
374 (int)((end - current) - ((IOR(f)->end - IOR(f)->ptr) + SvCUR(IOR(f)->segsv))));
375 */
376 return (end - current) - ((IOR(f)->end - IOR(f)->ptr) + SvCUR(IOR(f)->segsv));
377 }
378
379 PERLIO_FUNCS_DECL(PerlIO_reverse) = {
380 sizeof(PerlIO_funcs),
381 "reverse",
382 sizeof(PerlIOReverse),
383 PERLIO_K_BUFFERED | PERLIO_K_RAW,
384 PerlIOReverse_pushed,
385 PerlIOReverse_popped,
386 PerlIOReverse_open,
387 PerlIOBase_binmode,
388 NULL, /* getarg */
389 NULL, /* fileno */
390 NULL, /* dup */
391 NULL, /* read */
392 NULL, /* unread */
393 NULL, /* write */
394 PerlIOReverse_seek,
395 PerlIOReverse_tell,
396 NULL, /* close */
397 PerlIOReverse_flush,
398 PerlIOReverse_fill,
399 NULL, /* eof */
400 NULL, /* error */
401 NULL, /* clearerr */
402 NULL, /* setlinebuf */
403 PerlIOReverse_get_base,
404 PerlIOReverse_bufsiz,
405 PerlIOReverse_get_ptr,
406 PerlIOReverse_get_cnt,
407 PerlIOReverse_set_ptrcnt
408 };
409