xref: /openbsd/gnu/usr.bin/perl/perlio.c (revision e0680481)
1 /*
2  * perlio.c
3  * Copyright (c) 1996-2006, Nick Ing-Simmons
4  * Copyright (c) 2006, 2007, 2008, 2009, 2010, 2011 Larry Wall and others
5  *
6  * You may distribute under the terms of either the GNU General Public License
7  * or the Artistic License, as specified in the README file.
8  */
9 
10 /*
11  * Hour after hour for nearly three weary days he had jogged up and down,
12  * over passes, and through long dales, and across many streams.
13  *
14  *     [pp.791-792 of _The Lord of the Rings_, V/iii: "The Muster of Rohan"]
15  */
16 
17 /* This file contains the functions needed to implement PerlIO, which
18  * is Perl's private replacement for the C stdio library. This is used
19  * by default unless you compile with -Uuseperlio or run with
20  * PERLIO=:stdio (but don't do this unless you know what you're doing)
21  */
22 
23 /*
24  * If we have ActivePerl-like PERL_IMPLICIT_SYS then we need a dTHX to get
25  * at the dispatch tables, even when we do not need it for other reasons.
26  * Invent a dSYS macro to abstract this out
27  */
28 #ifdef PERL_IMPLICIT_SYS
29 #  define dSYS dTHX
30 #else
31 #  define dSYS dNOOP
32 #endif
33 
34 #define PERLIO_NOT_STDIO 0
35 /*
36  * This file provides those parts of PerlIO abstraction
37  * which are not #defined in perlio.h.
38  * Which these are depends on various Configure #ifdef's
39  */
40 
41 #include "EXTERN.h"
42 #define PERL_IN_PERLIO_C
43 #include "perl.h"
44 
45 #ifdef MULTIPLICITY
46 #  undef dSYS
47 #  define dSYS dTHX
48 #endif
49 
50 #include "XSUB.h"
51 
52 #ifdef VMS
53 #  include <rms.h>
54 #endif
55 
56 #define PerlIO_lockcnt(f) (((PerlIOl*)(void*)(f))->head->flags)
57 
58 /* Call the callback or PerlIOBase, and return failure. */
59 #define Perl_PerlIO_or_Base(f, callback, base, failure, args) 	\
60         if (PerlIOValid(f)) {					\
61                 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\
62                 if (tab && tab->callback)			\
63                         return (*tab->callback) args;		\
64                 else						\
65                         return PerlIOBase_ ## base args;	\
66         }							\
67         else							\
68                 SETERRNO(EBADF, SS_IVCHAN);			\
69         return failure
70 
71 /* Call the callback or fail, and return failure. */
72 #define Perl_PerlIO_or_fail(f, callback, failure, args) 	\
73         if (PerlIOValid(f)) {					\
74                 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\
75                 if (tab && tab->callback)			\
76                         return (*tab->callback) args;		\
77                 SETERRNO(EINVAL, LIB_INVARG);			\
78         }							\
79         else							\
80                 SETERRNO(EBADF, SS_IVCHAN);			\
81         return failure
82 
83 /* Call the callback or PerlIOBase, and be void. */
84 #define Perl_PerlIO_or_Base_void(f, callback, base, args) 	\
85         if (PerlIOValid(f)) {					\
86                 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\
87                 if (tab && tab->callback)			\
88                         (*tab->callback) args;			\
89                 else						\
90                         PerlIOBase_ ## base args;		\
91         }							\
92         else							\
93                 SETERRNO(EBADF, SS_IVCHAN)
94 
95 /* Call the callback or fail, and be void. */
96 #define Perl_PerlIO_or_fail_void(f, callback, args) 		\
97         if (PerlIOValid(f)) {					\
98                 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\
99                 if (tab && tab->callback)			\
100                         (*tab->callback) args;			\
101                 else						\
102                         SETERRNO(EINVAL, LIB_INVARG);		\
103         }							\
104         else							\
105                 SETERRNO(EBADF, SS_IVCHAN)
106 
107 #if defined(__osf__) && _XOPEN_SOURCE < 500
108 extern int   fseeko(FILE *, off_t, int);
109 extern off_t ftello(FILE *);
110 #endif
111 
112 #define NATIVE_0xd  CR_NATIVE
113 #define NATIVE_0xa  LF_NATIVE
114 
115 EXTERN_C int perlsio_binmode(FILE *fp, int iotype, int mode);
116 
117 int
perlsio_binmode(FILE * fp,int iotype,int mode)118 perlsio_binmode(FILE *fp, int iotype, int mode)
119 {
120     /*
121      * This used to be contents of do_binmode in doio.c
122      */
123 #ifdef DOSISH
124     dTHX;
125     PERL_UNUSED_ARG(iotype);
126     if (PerlLIO_setmode(fileno(fp), mode) != -1) {
127         return 1;
128     }
129     else
130         return 0;
131 #else
132 #  if defined(USEMYBINMODE)
133     dTHX;
134 #    if defined(__CYGWIN__)
135     PERL_UNUSED_ARG(iotype);
136 #    endif
137     if (my_binmode(fp, iotype, mode) != FALSE)
138         return 1;
139     else
140         return 0;
141 #  else
142     PERL_UNUSED_ARG(fp);
143     PERL_UNUSED_ARG(iotype);
144     PERL_UNUSED_ARG(mode);
145     return 1;
146 #  endif
147 #endif
148 }
149 
150 #ifndef O_ACCMODE
151 #  define O_ACCMODE 3             /* Assume traditional implementation */
152 #endif
153 
154 int
PerlIO_intmode2str(int rawmode,char * mode,int * writing)155 PerlIO_intmode2str(int rawmode, char *mode, int *writing)
156 {
157     const int result = rawmode & O_ACCMODE;
158     int ix = 0;
159     int ptype;
160     switch (result) {
161     case O_RDONLY:
162         ptype = IoTYPE_RDONLY;
163         break;
164     case O_WRONLY:
165         ptype = IoTYPE_WRONLY;
166         break;
167     case O_RDWR:
168     default:
169         ptype = IoTYPE_RDWR;
170         break;
171     }
172     if (writing)
173         *writing = (result != O_RDONLY);
174 
175     if (result == O_RDONLY) {
176         mode[ix++] = 'r';
177     }
178 #ifdef O_APPEND
179     else if (rawmode & O_APPEND) {
180         mode[ix++] = 'a';
181         if (result != O_WRONLY)
182             mode[ix++] = '+';
183     }
184 #endif
185     else {
186         if (result == O_WRONLY)
187             mode[ix++] = 'w';
188         else {
189             mode[ix++] = 'r';
190             mode[ix++] = '+';
191         }
192     }
193 #if O_BINARY != 0
194     /* Unless O_BINARY is different from zero, bit-and:ing
195      * with it won't do much good. */
196     if (rawmode & O_BINARY)
197         mode[ix++] = 'b';
198 #endif
199     mode[ix] = '\0';
200     return ptype;
201 }
202 
203 #ifndef PERLIO_LAYERS
204 int
PerlIO_apply_layers(pTHX_ PerlIO * f,const char * mode,const char * names)205 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
206 {
207     if (!names || !*names
208         || strEQ(names, ":crlf")
209         || strEQ(names, ":raw")
210         || strEQ(names, ":bytes")
211        ) {
212         return 0;
213     }
214     Perl_croak(aTHX_ "Cannot apply \"%s\" in non-PerlIO perl", names);
215     /*
216      * NOTREACHED
217      */
218     return -1;
219 }
220 
221 void
PerlIO_destruct(pTHX)222 PerlIO_destruct(pTHX)
223 {
224 }
225 
226 int
PerlIO_binmode(pTHX_ PerlIO * fp,int iotype,int mode,const char * names)227 PerlIO_binmode(pTHX_ PerlIO *fp, int iotype, int mode, const char *names)
228 {
229     return perlsio_binmode(fp, iotype, mode);
230 }
231 
232 PerlIO *
PerlIO_fdupopen(pTHX_ PerlIO * f,CLONE_PARAMS * param,int flags)233 PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)
234 {
235 #  if defined(PERL_MICRO)
236     return NULL;
237 #  elif defined(PERL_IMPLICIT_SYS)
238     return PerlSIO_fdupopen(f);
239 #  else
240 #    ifdef WIN32
241     return win32_fdupopen(f);
242 #    else
243     if (f) {
244         const int fd = PerlLIO_dup_cloexec(PerlIO_fileno(f));
245         if (fd >= 0) {
246             char mode[8];
247             const int omode = fcntl(fd, F_GETFL);
248             PerlIO_intmode2str(omode,mode,NULL);
249             /* the r+ is a hack */
250             return PerlIO_fdopen(fd, mode);
251         }
252         return NULL;
253     }
254     else {
255         SETERRNO(EBADF, SS_IVCHAN);
256     }
257 #    endif
258     return NULL;
259 #  endif
260 }
261 
262 
263 /*
264  * De-mux PerlIO_openn() into fdopen, freopen and fopen type entries
265  */
266 
267 PerlIO *
PerlIO_openn(pTHX_ const char * layers,const char * mode,int fd,int imode,int perm,PerlIO * old,int narg,SV ** args)268 PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
269              int imode, int perm, PerlIO *old, int narg, SV **args)
270 {
271     if (narg) {
272         if (narg > 1) {
273             Perl_croak(aTHX_ "More than one argument to open");
274         }
275         if (*args == &PL_sv_undef)
276             return PerlIO_tmpfile();
277         else {
278             STRLEN len;
279             const char *name = SvPV_const(*args, len);
280             if (!IS_SAFE_PATHNAME(name, len, "open"))
281                 return NULL;
282 
283             if (*mode == IoTYPE_NUMERIC) {
284                 fd = PerlLIO_open3_cloexec(name, imode, perm);
285                 if (fd >= 0)
286                     return PerlIO_fdopen(fd, mode + 1);
287             }
288             else if (old) {
289                 return PerlIO_reopen(name, mode, old);
290             }
291             else {
292                 return PerlIO_open(name, mode);
293             }
294         }
295     }
296     else {
297         return PerlIO_fdopen(fd, mode);
298     }
299     return NULL;
300 }
301 
302 XS(XS_PerlIO__Layer__find); /* prototype to pass -Wmissing-prototypes */
XS(XS_PerlIO__Layer__find)303 XS(XS_PerlIO__Layer__find)
304 {
305     dXSARGS;
306     if (items < 2)
307         Perl_croak(aTHX_ "Usage class->find(name[,load])");
308     else {
309         const char * const name = SvPV_nolen_const(ST(1));
310         ST(0) = (strEQ(name, "crlf")
311                  || strEQ(name, "raw")) ? &PL_sv_yes : &PL_sv_undef;
312         XSRETURN(1);
313     }
314 }
315 
316 
317 void
Perl_boot_core_PerlIO(pTHX)318 Perl_boot_core_PerlIO(pTHX)
319 {
320     newXS("PerlIO::Layer::find", XS_PerlIO__Layer__find, __FILE__);
321 }
322 
323 #endif
324 
325 
326 /*======================================================================================*/
327 /*
328  * Implement all the PerlIO interface ourselves.
329  */
330 
331 #include "perliol.h"
332 
333 void
PerlIO_debug(const char * fmt,...)334 PerlIO_debug(const char *fmt, ...)
335 {
336     va_list ap;
337     dSYS;
338 
339     if (!DEBUG_i_TEST)
340         return;
341 
342     va_start(ap, fmt);
343 
344     if (!PL_perlio_debug_fd) {
345         if (!TAINTING_get &&
346             PerlProc_getuid() == PerlProc_geteuid() &&
347             PerlProc_getgid() == PerlProc_getegid()) {
348             const char * const s = PerlEnv_getenv("PERLIO_DEBUG");
349             if (s && *s)
350                 PL_perlio_debug_fd = PerlLIO_open3_cloexec(s,
351                                         O_WRONLY | O_CREAT | O_APPEND, 0666);
352             else
353                 PL_perlio_debug_fd = PerlLIO_dup_cloexec(2); /* stderr */
354         } else {
355             /* tainting or set*id, so ignore the environment and send the
356                debug output to stderr, like other -D switches.  */
357             PL_perlio_debug_fd = PerlLIO_dup_cloexec(2); /* stderr */
358         }
359     }
360     if (PL_perlio_debug_fd > 0) {
361 #ifdef USE_ITHREADS
362         const char * const s = CopFILE(PL_curcop);
363         /* Use fixed buffer as sv_catpvf etc. needs SVs */
364         char buffer[1024];
365         const STRLEN len1 = my_snprintf(buffer, sizeof(buffer), "%.40s:%" LINE_Tf " ", s ? s : "(none)", CopLINE(PL_curcop));
366 #  ifdef USE_QUADMATH
367 #    ifdef HAS_VSNPRINTF
368         /* my_vsnprintf() isn't available with quadmath, but the native vsnprintf()
369            should be, otherwise the system isn't likely to support quadmath.
370            Nothing should be calling PerlIO_debug() with floating point anyway.
371         */
372         DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
373         STORE_LC_NUMERIC_SET_TO_NEEDED();
374         const STRLEN len2 = vsnprintf(buffer + len1, sizeof(buffer) - len1, fmt, ap);
375         RESTORE_LC_NUMERIC();
376 #    else
377         STATIC_ASSERT_STMT(0);
378 #    endif
379 #  else
380         const STRLEN len2 = my_vsnprintf(buffer + len1, sizeof(buffer) - len1, fmt, ap);
381 #  endif
382         PERL_UNUSED_RESULT(PerlLIO_write(PL_perlio_debug_fd, buffer, len1 + len2));
383 #else
384         const char *s = CopFILE(PL_curcop);
385         STRLEN len;
386         SV * const sv = Perl_newSVpvf(aTHX_ "%s:%" LINE_Tf " ",
387                                       s ? s : "(none)", CopLINE(PL_curcop));
388         Perl_sv_vcatpvf(aTHX_ sv, fmt, &ap);
389 
390         s = SvPV_const(sv, len);
391         PERL_UNUSED_RESULT(PerlLIO_write(PL_perlio_debug_fd, s, len));
392         SvREFCNT_dec(sv);
393 #endif
394     }
395     va_end(ap);
396 }
397 
398 /*--------------------------------------------------------------------------------------*/
399 
400 /*
401  * Inner level routines
402  */
403 
404 /* check that the head field of each layer points back to the head */
405 
406 #ifdef DEBUGGING
407 #  define VERIFY_HEAD(f) PerlIO_verify_head(aTHX_ f)
408 static void
PerlIO_verify_head(pTHX_ PerlIO * f)409 PerlIO_verify_head(pTHX_ PerlIO *f)
410 {
411     PerlIOl *head, *p;
412     int seen = 0;
413 #  ifndef PERL_IMPLICIT_SYS
414     PERL_UNUSED_CONTEXT;
415 #  endif
416     if (!PerlIOValid(f))
417         return;
418     p = head = PerlIOBase(f)->head;
419     assert(p);
420     do {
421         assert(p->head == head);
422         if (&p->next == f)
423             seen = 1;
424         p = p->next;
425     } while (p);
426     assert(seen);
427 }
428 #else
429 #  define VERIFY_HEAD(f)
430 #endif
431 
432 
433 /*
434  * Table of pointers to the PerlIO structs (malloc'ed)
435  */
436 #define PERLIO_TABLE_SIZE 64
437 
438 static void
PerlIO_init_table(pTHX)439 PerlIO_init_table(pTHX)
440 {
441     if (PL_perlio)
442         return;
443     Newxz(PL_perlio, PERLIO_TABLE_SIZE, PerlIOl);
444 }
445 
446 
447 
448 PerlIO *
PerlIO_allocate(pTHX)449 PerlIO_allocate(pTHX)
450 {
451     /*
452      * Find a free slot in the table, allocating new tables as necessary
453      */
454     PerlIOl **last;
455     PerlIOl *f;
456     last = &PL_perlio;
457     while ((f = *last)) {
458         int i;
459         last = &f->next;
460         for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
461             if (!((++f)->next)) {
462                 goto good_exit;
463             }
464         }
465     }
466     Newxz(f,PERLIO_TABLE_SIZE,PerlIOl);
467     if (!f) {
468         return NULL;
469     }
470     *last = f++;
471 
472     good_exit:
473     f->flags = 0; /* lockcnt */
474     f->tab = NULL;
475     f->head = f;
476     return &f->next;
477 }
478 
479 #undef PerlIO_fdupopen
480 PerlIO *
PerlIO_fdupopen(pTHX_ PerlIO * f,CLONE_PARAMS * param,int flags)481 PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)
482 {
483     if (PerlIOValid(f)) {
484         const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
485         DEBUG_i( PerlIO_debug("fdupopen f=%p param=%p\n",(void*)f,(void*)param) );
486         if (tab && tab->Dup)
487              return (*tab->Dup)(aTHX_ PerlIO_allocate(aTHX), f, param, flags);
488         else {
489              return PerlIOBase_dup(aTHX_ PerlIO_allocate(aTHX), f, param, flags);
490         }
491     }
492     else
493          SETERRNO(EBADF, SS_IVCHAN);
494 
495     return NULL;
496 }
497 
498 void
PerlIO_cleantable(pTHX_ PerlIOl ** tablep)499 PerlIO_cleantable(pTHX_ PerlIOl **tablep)
500 {
501     PerlIOl * const table = *tablep;
502     if (table) {
503         int i;
504         PerlIO_cleantable(aTHX_ &table[0].next);
505         for (i = PERLIO_TABLE_SIZE - 1; i > 0; i--) {
506             PerlIOl * const f = table + i;
507             if (f->next) {
508                 PerlIO_close(&(f->next));
509             }
510         }
511         Safefree(table);
512         *tablep = NULL;
513     }
514 }
515 
516 
517 PerlIO_list_t *
PerlIO_list_alloc(pTHX)518 PerlIO_list_alloc(pTHX)
519 {
520     PerlIO_list_t *list;
521     PERL_UNUSED_CONTEXT;
522     Newxz(list, 1, PerlIO_list_t);
523     list->refcnt = 1;
524     return list;
525 }
526 
527 void
PerlIO_list_free(pTHX_ PerlIO_list_t * list)528 PerlIO_list_free(pTHX_ PerlIO_list_t *list)
529 {
530     if (list) {
531         if (--list->refcnt == 0) {
532             if (list->array) {
533                 IV i;
534                 for (i = 0; i < list->cur; i++)
535                     SvREFCNT_dec(list->array[i].arg);
536                 Safefree(list->array);
537             }
538             Safefree(list);
539         }
540     }
541 }
542 
543 void
PerlIO_list_push(pTHX_ PerlIO_list_t * list,PerlIO_funcs * funcs,SV * arg)544 PerlIO_list_push(pTHX_ PerlIO_list_t *list, PerlIO_funcs *funcs, SV *arg)
545 {
546     PerlIO_pair_t *p;
547     PERL_UNUSED_CONTEXT;
548 
549     if (list->cur >= list->len) {
550         const IV new_len = list->len + 8;
551         if (list->array)
552             Renew(list->array, new_len, PerlIO_pair_t);
553         else
554             Newx(list->array, new_len, PerlIO_pair_t);
555         list->len = new_len;
556     }
557     p = &(list->array[list->cur++]);
558     p->funcs = funcs;
559     if ((p->arg = arg)) {
560         SvREFCNT_inc_simple_void_NN(arg);
561     }
562 }
563 
564 PerlIO_list_t *
PerlIO_clone_list(pTHX_ PerlIO_list_t * proto,CLONE_PARAMS * param)565 PerlIO_clone_list(pTHX_ PerlIO_list_t *proto, CLONE_PARAMS *param)
566 {
567     PerlIO_list_t *list = NULL;
568     if (proto) {
569         int i;
570         list = PerlIO_list_alloc(aTHX);
571         for (i=0; i < proto->cur; i++) {
572             SV *arg = proto->array[i].arg;
573 #ifdef USE_ITHREADS
574             if (arg && param)
575                 arg = sv_dup(arg, param);
576 #else
577             PERL_UNUSED_ARG(param);
578 #endif
579             PerlIO_list_push(aTHX_ list, proto->array[i].funcs, arg);
580         }
581     }
582     return list;
583 }
584 
585 void
PerlIO_clone(pTHX_ PerlInterpreter * proto,CLONE_PARAMS * param)586 PerlIO_clone(pTHX_ PerlInterpreter *proto, CLONE_PARAMS *param)
587 {
588 #ifdef USE_ITHREADS
589     PerlIOl **table = &proto->Iperlio;
590     PerlIOl *f;
591     PL_perlio = NULL;
592     PL_known_layers = PerlIO_clone_list(aTHX_ proto->Iknown_layers, param);
593     PL_def_layerlist = PerlIO_clone_list(aTHX_ proto->Idef_layerlist, param);
594     PerlIO_init_table(aTHX);
595     DEBUG_i( PerlIO_debug("Clone %p from %p\n",(void*)aTHX,(void*)proto) );
596     while ((f = *table)) {
597             int i;
598             table = &f->next;
599             f++;
600             for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
601                 if (f->next) {
602                     (void) fp_dup(&(f->next), 0, param);
603                 }
604                 f++;
605             }
606         }
607 #else
608     PERL_UNUSED_CONTEXT;
609     PERL_UNUSED_ARG(proto);
610     PERL_UNUSED_ARG(param);
611 #endif
612 }
613 
614 void
PerlIO_destruct(pTHX)615 PerlIO_destruct(pTHX)
616 {
617     PerlIOl **table = &PL_perlio;
618     PerlIOl *f;
619 #ifdef USE_ITHREADS
620     DEBUG_i( PerlIO_debug("Destruct %p\n",(void*)aTHX) );
621 #endif
622     while ((f = *table)) {
623         int i;
624         table = &f->next;
625         f++;
626         for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
627             PerlIO *x = &(f->next);
628             const PerlIOl *l;
629             while ((l = *x)) {
630                 if (l->tab && l->tab->kind & PERLIO_K_DESTRUCT) {
631                     DEBUG_i( PerlIO_debug("Destruct popping %s\n", l->tab->name) );
632                     PerlIO_flush(x);
633                     PerlIO_pop(aTHX_ x);
634                 }
635                 else {
636                     x = PerlIONext(x);
637                 }
638             }
639             f++;
640         }
641     }
642 }
643 
644 void
PerlIO_pop(pTHX_ PerlIO * f)645 PerlIO_pop(pTHX_ PerlIO *f)
646 {
647     const PerlIOl *l = *f;
648     VERIFY_HEAD(f);
649     if (l) {
650         DEBUG_i( PerlIO_debug("PerlIO_pop f=%p %s\n", (void*)f,
651                               l->tab ? l->tab->name : "(Null)") );
652         if (l->tab && l->tab->Popped) {
653             /*
654              * If popped returns non-zero do not free its layer structure
655              * it has either done so itself, or it is shared and still in
656              * use
657              */
658             if ((*l->tab->Popped) (aTHX_ f) != 0)
659                 return;
660         }
661         if (PerlIO_lockcnt(f)) {
662             /* we're in use; defer freeing the structure */
663             PerlIOBase(f)->flags = PERLIO_F_CLEARED;
664             PerlIOBase(f)->tab = NULL;
665         }
666         else {
667             *f = l->next;
668             Safefree(l);
669         }
670 
671     }
672 }
673 
674 /* Return as an array the stack of layers on a filehandle.  Note that
675  * the stack is returned top-first in the array, and there are three
676  * times as many array elements as there are layers in the stack: the
677  * first element of a layer triplet is the name, the second one is the
678  * arguments, and the third one is the flags. */
679 
680 AV *
PerlIO_get_layers(pTHX_ PerlIO * f)681 PerlIO_get_layers(pTHX_ PerlIO *f)
682 {
683     AV * const av = newAV();
684 
685     if (PerlIOValid(f)) {
686         PerlIOl *l = PerlIOBase(f);
687 
688         while (l) {
689             /* There is some collusion in the implementation of
690                XS_PerlIO_get_layers - it knows that name and flags are
691                generated as fresh SVs here, and takes advantage of that to
692                "copy" them by taking a reference. If it changes here, it needs
693                to change there too.  */
694             SV * const name = l->tab && l->tab->name ?
695             newSVpv(l->tab->name, 0) : &PL_sv_undef;
696             SV * const arg = l->tab && l->tab->Getarg ?
697             (*l->tab->Getarg)(aTHX_ &l, 0, 0) : &PL_sv_undef;
698             av_push_simple(av, name);
699             av_push_simple(av, arg);
700             av_push_simple(av, newSViv((IV)l->flags));
701             l = l->next;
702         }
703     }
704 
705     return av;
706 }
707 
708 /*--------------------------------------------------------------------------------------*/
709 /*
710  * XS Interface for perl code
711  */
712 
713 PerlIO_funcs *
PerlIO_find_layer(pTHX_ const char * name,STRLEN len,int load)714 PerlIO_find_layer(pTHX_ const char *name, STRLEN len, int load)
715 {
716 
717     IV i;
718     if ((SSize_t) len <= 0)
719         len = strlen(name);
720     for (i = 0; i < PL_known_layers->cur; i++) {
721         PerlIO_funcs * const f = PL_known_layers->array[i].funcs;
722         const STRLEN this_len = strlen(f->name);
723         if (this_len == len && memEQ(f->name, name, len)) {
724             DEBUG_i( PerlIO_debug("%.*s => %p\n", (int) len, name, (void*)f) );
725             return f;
726         }
727     }
728     if (load && PL_subname && PL_def_layerlist
729         && PL_def_layerlist->cur >= 2) {
730         if (PL_in_load_module) {
731             Perl_croak(aTHX_ "Recursive call to Perl_load_module in PerlIO_find_layer");
732             return NULL;
733         } else {
734             SV * const pkgsv = newSVpvs("PerlIO");
735             SV * const layer = newSVpvn(name, len);
736             CV * const cv    = get_cvs("PerlIO::Layer::NoWarnings", 0);
737             ENTER;
738             SAVEBOOL(PL_in_load_module);
739             if (cv) {
740                 SAVEGENERICSV(PL_warnhook);
741                 PL_warnhook = MUTABLE_SV((SvREFCNT_inc_simple_NN(cv)));
742             }
743             PL_in_load_module = TRUE;
744             /*
745              * The two SVs are magically freed by load_module
746              */
747             Perl_load_module(aTHX_ 0, pkgsv, NULL, layer, NULL);
748             LEAVE;
749             return PerlIO_find_layer(aTHX_ name, len, 0);
750         }
751     }
752     DEBUG_i( PerlIO_debug("Cannot find %.*s\n", (int) len, name) );
753     return NULL;
754 }
755 
756 #ifdef USE_ATTRIBUTES_FOR_PERLIO
757 
758 static int
perlio_mg_set(pTHX_ SV * sv,MAGIC * mg)759 perlio_mg_set(pTHX_ SV *sv, MAGIC *mg)
760 {
761     if (SvROK(sv)) {
762         IO * const io = GvIOn(MUTABLE_GV(SvRV(sv)));
763         PerlIO * const ifp = IoIFP(io);
764         PerlIO * const ofp = IoOFP(io);
765         Perl_warn(aTHX_ "set %" SVf " %p %p %p",
766                   SVfARG(sv), (void*)io, (void*)ifp, (void*)ofp);
767     }
768     return 0;
769 }
770 
771 static int
perlio_mg_get(pTHX_ SV * sv,MAGIC * mg)772 perlio_mg_get(pTHX_ SV *sv, MAGIC *mg)
773 {
774     if (SvROK(sv)) {
775         IO * const io = GvIOn(MUTABLE_GV(SvRV(sv)));
776         PerlIO * const ifp = IoIFP(io);
777         PerlIO * const ofp = IoOFP(io);
778         Perl_warn(aTHX_ "get %" SVf " %p %p %p",
779                   SVfARG(sv), (void*)io, (void*)ifp, (void*)ofp);
780     }
781     return 0;
782 }
783 
784 static int
perlio_mg_clear(pTHX_ SV * sv,MAGIC * mg)785 perlio_mg_clear(pTHX_ SV *sv, MAGIC *mg)
786 {
787     Perl_warn(aTHX_ "clear %" SVf, SVfARG(sv));
788     return 0;
789 }
790 
791 static int
perlio_mg_free(pTHX_ SV * sv,MAGIC * mg)792 perlio_mg_free(pTHX_ SV *sv, MAGIC *mg)
793 {
794     Perl_warn(aTHX_ "free %" SVf, SVfARG(sv));
795     return 0;
796 }
797 
798 MGVTBL perlio_vtab = {
799     perlio_mg_get,
800     perlio_mg_set,
801     NULL,                       /* len */
802     perlio_mg_clear,
803     perlio_mg_free
804 };
805 
806 XS(XS_io_MODIFY_SCALAR_ATTRIBUTES); /* prototype to pass -Wmissing-prototypes */
XS(XS_io_MODIFY_SCALAR_ATTRIBUTES)807 XS(XS_io_MODIFY_SCALAR_ATTRIBUTES)
808 {
809     dXSARGS;
810     SV * const sv = SvRV(ST(1));
811     AV * const av = newAV();
812     MAGIC *mg;
813     int count = 0;
814     int i;
815     sv_magic(sv, MUTABLE_SV(av), PERL_MAGIC_ext, NULL, 0);
816     SvRMAGICAL_off(sv);
817     mg = mg_find(sv, PERL_MAGIC_ext);
818     mg->mg_virtual = &perlio_vtab;
819     mg_magical(sv);
820     Perl_warn(aTHX_ "attrib %" SVf, SVfARG(sv));
821     for (i = 2; i < items; i++) {
822         STRLEN len;
823         const char * const name = SvPV_const(ST(i), len);
824         SV * const layer = PerlIO_find_layer(aTHX_ name, len, 1);
825         if (layer) {
826             av_push_simple(av, SvREFCNT_inc_simple_NN(layer));
827         }
828         else {
829             ST(count) = ST(i);
830             count++;
831         }
832     }
833     SvREFCNT_dec(av);
834     XSRETURN(count);
835 }
836 
837 #endif                          /* USE_ATTRIBUTES_FOR_PERLIO */
838 
839 SV *
PerlIO_tab_sv(pTHX_ PerlIO_funcs * tab)840 PerlIO_tab_sv(pTHX_ PerlIO_funcs *tab)
841 {
842     HV * const stash = gv_stashpvs("PerlIO::Layer", GV_ADD);
843     SV * const sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))), stash);
844     return sv;
845 }
846 
847 XS(XS_PerlIO__Layer__NoWarnings); /* prototype to pass -Wmissing-prototypes */
XS(XS_PerlIO__Layer__NoWarnings)848 XS(XS_PerlIO__Layer__NoWarnings)
849 {
850     /* This is used as a %SIG{__WARN__} handler to suppress warnings
851        during loading of layers.
852      */
853     dXSARGS;
854     PERL_UNUSED_VAR(items);
855     DEBUG_i(
856         if (items)
857             PerlIO_debug("warning:%s\n",SvPV_nolen_const(ST(0))) );
858     XSRETURN(0);
859 }
860 
861 XS(XS_PerlIO__Layer__find); /* prototype to pass -Wmissing-prototypes */
XS(XS_PerlIO__Layer__find)862 XS(XS_PerlIO__Layer__find)
863 {
864     dXSARGS;
865     if (items < 2)
866         Perl_croak(aTHX_ "Usage class->find(name[,load])");
867     else {
868         STRLEN len;
869         const char * const name = SvPV_const(ST(1), len);
870         const bool load = (items > 2) ? SvTRUE_NN(ST(2)) : 0;
871         PerlIO_funcs * const layer = PerlIO_find_layer(aTHX_ name, len, load);
872         ST(0) =
873             (layer) ? sv_2mortal(PerlIO_tab_sv(aTHX_ layer)) :
874             &PL_sv_undef;
875         XSRETURN(1);
876     }
877 }
878 
879 void
PerlIO_define_layer(pTHX_ PerlIO_funcs * tab)880 PerlIO_define_layer(pTHX_ PerlIO_funcs *tab)
881 {
882     if (!PL_known_layers)
883         PL_known_layers = PerlIO_list_alloc(aTHX);
884     PerlIO_list_push(aTHX_ PL_known_layers, tab, NULL);
885     DEBUG_i( PerlIO_debug("define %s %p\n", tab->name, (void*)tab) );
886 }
887 
888 int
PerlIO_parse_layers(pTHX_ PerlIO_list_t * av,const char * names)889 PerlIO_parse_layers(pTHX_ PerlIO_list_t *av, const char *names)
890 {
891     if (names) {
892         const char *s = names;
893         while (*s) {
894             while (isSPACE(*s) || *s == ':')
895                 s++;
896             if (*s) {
897                 STRLEN llen = 0;
898                 const char *e = s;
899                 const char *as = NULL;
900                 STRLEN alen = 0;
901                 if (!isIDFIRST(*s)) {
902                     /*
903                      * Message is consistent with how attribute lists are
904                      * passed. Even though this means "foo : : bar" is
905                      * seen as an invalid separator character.
906                      */
907                     const char q = ((*s == '\'') ? '"' : '\'');
908                     Perl_ck_warner(aTHX_ packWARN(WARN_LAYER),
909                                    "Invalid separator character %c%c%c in PerlIO layer specification %s",
910                                    q, *s, q, s);
911                     SETERRNO(EINVAL, LIB_INVARG);
912                     return -1;
913                 }
914                 do {
915                     e++;
916                 } while (isWORDCHAR(*e));
917                 llen = e - s;
918                 if (*e == '(') {
919                     int nesting = 1;
920                     as = ++e;
921                     while (nesting) {
922                         switch (*e++) {
923                         case ')':
924                             if (--nesting == 0)
925                                 alen = (e - 1) - as;
926                             break;
927                         case '(':
928                             ++nesting;
929                             break;
930                         case '\\':
931                             /*
932                              * It's a nul terminated string, not allowed
933                              * to \ the terminating null. Anything other
934                              * character is passed over.
935                              */
936                             if (*e++) {
937                                 break;
938                             }
939                             /* Fall through */
940                         case '\0':
941                             e--;
942                             Perl_ck_warner(aTHX_ packWARN(WARN_LAYER),
943                                            "Argument list not closed for PerlIO layer \"%.*s\"",
944                                            (int) (e - s), s);
945                             return -1;
946                         default:
947                             /*
948                              * boring.
949                              */
950                             break;
951                         }
952                     }
953                 }
954                 if (e > s) {
955                     PerlIO_funcs * const layer =
956                         PerlIO_find_layer(aTHX_ s, llen, 1);
957                     if (layer) {
958                         SV *arg = NULL;
959                         if (as)
960                             arg = newSVpvn(as, alen);
961                         PerlIO_list_push(aTHX_ av, layer,
962                                          (arg) ? arg : &PL_sv_undef);
963                         SvREFCNT_dec(arg);
964                     }
965                     else {
966                         Perl_ck_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"%.*s\"",
967                                        (int) llen, s);
968                         return -1;
969                     }
970                 }
971                 s = e;
972             }
973         }
974     }
975     return 0;
976 }
977 
978 void
PerlIO_default_buffer(pTHX_ PerlIO_list_t * av)979 PerlIO_default_buffer(pTHX_ PerlIO_list_t *av)
980 {
981     PERLIO_FUNCS_DECL(*tab) = &PerlIO_perlio;
982 #ifdef PERLIO_USING_CRLF
983     tab = &PerlIO_crlf;
984 #else
985     if (PerlIO_stdio.Set_ptrcnt)
986         tab = &PerlIO_stdio;
987 #endif
988     DEBUG_i( PerlIO_debug("Pushing %s\n", tab->name) );
989     PerlIO_list_push(aTHX_ av, (PerlIO_funcs *)tab, &PL_sv_undef);
990 }
991 
992 SV *
PerlIO_arg_fetch(PerlIO_list_t * av,IV n)993 PerlIO_arg_fetch(PerlIO_list_t *av, IV n)
994 {
995     return av->array[n].arg;
996 }
997 
998 PerlIO_funcs *
PerlIO_layer_fetch(pTHX_ PerlIO_list_t * av,IV n,PerlIO_funcs * def)999 PerlIO_layer_fetch(pTHX_ PerlIO_list_t *av, IV n, PerlIO_funcs *def)
1000 {
1001     if (n >= 0 && n < av->cur) {
1002         DEBUG_i( PerlIO_debug("Layer %" IVdf " is %s\n", n,
1003                               av->array[n].funcs->name) );
1004         return av->array[n].funcs;
1005     }
1006     if (!def)
1007         Perl_croak(aTHX_ "panic: PerlIO layer array corrupt");
1008     return def;
1009 }
1010 
1011 IV
PerlIOPop_pushed(pTHX_ PerlIO * f,const char * mode,SV * arg,PerlIO_funcs * tab)1012 PerlIOPop_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1013 {
1014     PERL_UNUSED_ARG(mode);
1015     PERL_UNUSED_ARG(arg);
1016     PERL_UNUSED_ARG(tab);
1017     if (PerlIOValid(f)) {
1018         PerlIO_flush(f);
1019         PerlIO_pop(aTHX_ f);
1020         return 0;
1021     }
1022     return -1;
1023 }
1024 
1025 PERLIO_FUNCS_DECL(PerlIO_remove) = {
1026     sizeof(PerlIO_funcs),
1027     "pop",
1028     0,
1029     PERLIO_K_DUMMY | PERLIO_K_UTF8,
1030     PerlIOPop_pushed,
1031     NULL,
1032     PerlIOBase_open,
1033     NULL,
1034     NULL,
1035     NULL,
1036     NULL,
1037     NULL,
1038     NULL,
1039     NULL,
1040     NULL,
1041     NULL,
1042     NULL,
1043     NULL,                       /* flush */
1044     NULL,                       /* fill */
1045     NULL,
1046     NULL,
1047     NULL,
1048     NULL,
1049     NULL,                       /* get_base */
1050     NULL,                       /* get_bufsiz */
1051     NULL,                       /* get_ptr */
1052     NULL,                       /* get_cnt */
1053     NULL,                       /* set_ptrcnt */
1054 };
1055 
1056 PerlIO_list_t *
PerlIO_default_layers(pTHX)1057 PerlIO_default_layers(pTHX)
1058 {
1059     if (!PL_def_layerlist) {
1060         const char * const s = TAINTING_get ? NULL : PerlEnv_getenv("PERLIO");
1061         PERLIO_FUNCS_DECL(*osLayer) = &PerlIO_unix;
1062         PL_def_layerlist = PerlIO_list_alloc(aTHX);
1063         PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_unix));
1064         PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_raw));
1065         PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_perlio));
1066         PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_stdio));
1067         PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_crlf));
1068         PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_utf8));
1069         PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_remove));
1070         PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_byte));
1071         PerlIO_list_push(aTHX_ PL_def_layerlist, (PerlIO_funcs *)osLayer,
1072                          &PL_sv_undef);
1073         if (s) {
1074             PerlIO_parse_layers(aTHX_ PL_def_layerlist, s);
1075         }
1076         else {
1077             PerlIO_default_buffer(aTHX_ PL_def_layerlist);
1078         }
1079     }
1080     if (PL_def_layerlist->cur < 2) {
1081         PerlIO_default_buffer(aTHX_ PL_def_layerlist);
1082     }
1083     return PL_def_layerlist;
1084 }
1085 
1086 void
Perl_boot_core_PerlIO(pTHX)1087 Perl_boot_core_PerlIO(pTHX)
1088 {
1089 #ifdef USE_ATTRIBUTES_FOR_PERLIO
1090     newXS("io::MODIFY_SCALAR_ATTRIBUTES", XS_io_MODIFY_SCALAR_ATTRIBUTES,
1091           __FILE__);
1092 #endif
1093     newXS("PerlIO::Layer::find", XS_PerlIO__Layer__find, __FILE__);
1094     newXS("PerlIO::Layer::NoWarnings", XS_PerlIO__Layer__NoWarnings, __FILE__);
1095 }
1096 
1097 PerlIO_funcs *
PerlIO_default_layer(pTHX_ I32 n)1098 PerlIO_default_layer(pTHX_ I32 n)
1099 {
1100     PerlIO_list_t * const av = PerlIO_default_layers(aTHX);
1101     if (n < 0)
1102         n += av->cur;
1103     return PerlIO_layer_fetch(aTHX_ av, n, PERLIO_FUNCS_CAST(&PerlIO_stdio));
1104 }
1105 
1106 #define PerlIO_default_top() PerlIO_default_layer(aTHX_ -1)
1107 #define PerlIO_default_btm() PerlIO_default_layer(aTHX_ 0)
1108 
1109 void
PerlIO_stdstreams(pTHX)1110 PerlIO_stdstreams(pTHX)
1111 {
1112     if (!PL_perlio) {
1113         PerlIO_init_table(aTHX);
1114         PerlIO_fdopen(0, "Ir" PERLIO_STDTEXT);
1115         PerlIO_fdopen(1, "Iw" PERLIO_STDTEXT);
1116         PerlIO_fdopen(2, "Iw" PERLIO_STDTEXT);
1117     }
1118 }
1119 
1120 PerlIO *
PerlIO_push(pTHX_ PerlIO * f,PERLIO_FUNCS_DECL (* tab),const char * mode,SV * arg)1121 PerlIO_push(pTHX_ PerlIO *f, PERLIO_FUNCS_DECL(*tab), const char *mode, SV *arg)
1122 {
1123     VERIFY_HEAD(f);
1124     if (tab->fsize != sizeof(PerlIO_funcs)) {
1125         Perl_croak( aTHX_
1126             "%s (%" UVuf ") does not match %s (%" UVuf ")",
1127             "PerlIO layer function table size", (UV)tab->fsize,
1128             "size expected by this perl", (UV)sizeof(PerlIO_funcs) );
1129     }
1130     if (tab->size) {
1131         PerlIOl *l;
1132         if (tab->size < sizeof(PerlIOl)) {
1133             Perl_croak( aTHX_
1134                 "%s (%" UVuf ") smaller than %s (%" UVuf ")",
1135                 "PerlIO layer instance size", (UV)tab->size,
1136                 "size expected by this perl", (UV)sizeof(PerlIOl) );
1137         }
1138         /* Real layer with a data area */
1139         if (f) {
1140             char *temp;
1141             Newxz(temp, tab->size, char);
1142             l = (PerlIOl*)temp;
1143             if (l) {
1144                 l->next = *f;
1145                 l->tab = (PerlIO_funcs*) tab;
1146                 l->head = ((PerlIOl*)f)->head;
1147                 *f = l;
1148                 DEBUG_i( PerlIO_debug("PerlIO_push f=%p %s %s %p\n",
1149                                       (void*)f, tab->name,
1150                                       (mode) ? mode : "(Null)", (void*)arg) );
1151                 if (*l->tab->Pushed &&
1152                     (*l->tab->Pushed)
1153                       (aTHX_ f, mode, arg, (PerlIO_funcs*) tab) != 0) {
1154                     PerlIO_pop(aTHX_ f);
1155                     return NULL;
1156                 }
1157             }
1158             else
1159                 return NULL;
1160         }
1161     }
1162     else if (f) {
1163         /* Pseudo-layer where push does its own stack adjust */
1164         DEBUG_i( PerlIO_debug("PerlIO_push f=%p %s %s %p\n", (void*)f, tab->name,
1165                               (mode) ? mode : "(Null)", (void*)arg) );
1166         if (tab->Pushed &&
1167             (*tab->Pushed) (aTHX_ f, mode, arg, (PerlIO_funcs*) tab) != 0) {
1168              return NULL;
1169         }
1170     }
1171     return f;
1172 }
1173 
1174 PerlIO *
PerlIOBase_open(pTHX_ PerlIO_funcs * self,PerlIO_list_t * layers,IV n,const char * mode,int fd,int imode,int perm,PerlIO * old,int narg,SV ** args)1175 PerlIOBase_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
1176                IV n, const char *mode, int fd, int imode, int perm,
1177                PerlIO *old, int narg, SV **args)
1178 {
1179     PerlIO_funcs * const tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIO_default_layer(aTHX_ 0));
1180     if (tab && tab->Open) {
1181         PerlIO* ret = (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm, old, narg, args);
1182         if (ret && PerlIO_push(aTHX_ ret, self, mode, PerlIOArg) == NULL) {
1183             PerlIO_close(ret);
1184             return NULL;
1185         }
1186         return ret;
1187     }
1188     SETERRNO(EINVAL, LIB_INVARG);
1189     return NULL;
1190 }
1191 
1192 IV
PerlIOBase_binmode(pTHX_ PerlIO * f)1193 PerlIOBase_binmode(pTHX_ PerlIO *f)
1194 {
1195    if (PerlIOValid(f)) {
1196         /* Is layer suitable for raw stream ? */
1197         if (PerlIOBase(f)->tab && PerlIOBase(f)->tab->kind & PERLIO_K_RAW) {
1198             /* Yes - turn off UTF-8-ness, to undo UTF-8 locale effects */
1199             PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1200         }
1201         else {
1202             /* Not suitable - pop it */
1203             PerlIO_pop(aTHX_ f);
1204         }
1205         return 0;
1206    }
1207    return -1;
1208 }
1209 
1210 IV
PerlIORaw_pushed(pTHX_ PerlIO * f,const char * mode,SV * arg,PerlIO_funcs * tab)1211 PerlIORaw_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1212 {
1213     PERL_UNUSED_ARG(mode);
1214     PERL_UNUSED_ARG(arg);
1215     PERL_UNUSED_ARG(tab);
1216 
1217     if (PerlIOValid(f)) {
1218         PerlIO *t;
1219         const PerlIOl *l;
1220         PerlIO_flush(f);
1221         /*
1222          * Strip all layers that are not suitable for a raw stream
1223          */
1224         t = f;
1225         while (t && (l = *t)) {
1226             if (l->tab && l->tab->Binmode) {
1227                 /* Has a handler - normal case */
1228                 if ((*l->tab->Binmode)(aTHX_ t) == 0) {
1229                     if (*t == l) {
1230                         /* Layer still there - move down a layer */
1231                         t = PerlIONext(t);
1232                     }
1233                 }
1234                 else {
1235                     return -1;
1236                 }
1237             }
1238             else {
1239                 /* No handler - pop it */
1240                 PerlIO_pop(aTHX_ t);
1241             }
1242         }
1243         if (PerlIOValid(f)) {
1244             DEBUG_i( PerlIO_debug(":raw f=%p :%s\n", (void*)f,
1245                          PerlIOBase(f)->tab ? PerlIOBase(f)->tab->name : "(Null)") );
1246             return 0;
1247         }
1248     }
1249     return -1;
1250 }
1251 
1252 int
PerlIO_apply_layera(pTHX_ PerlIO * f,const char * mode,PerlIO_list_t * layers,IV n,IV max)1253 PerlIO_apply_layera(pTHX_ PerlIO *f, const char *mode,
1254                     PerlIO_list_t *layers, IV n, IV max)
1255 {
1256     int code = 0;
1257     while (n < max) {
1258         PerlIO_funcs * const tab = PerlIO_layer_fetch(aTHX_ layers, n, NULL);
1259         if (tab) {
1260             if (!PerlIO_push(aTHX_ f, tab, mode, PerlIOArg)) {
1261                 code = -1;
1262                 break;
1263             }
1264         }
1265         n++;
1266     }
1267     return code;
1268 }
1269 
1270 int
PerlIO_apply_layers(pTHX_ PerlIO * f,const char * mode,const char * names)1271 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
1272 {
1273     int code = 0;
1274     ENTER;
1275     save_scalar(PL_errgv);
1276     if (f && names) {
1277         PerlIO_list_t * const layers = PerlIO_list_alloc(aTHX);
1278         code = PerlIO_parse_layers(aTHX_ layers, names);
1279         if (code == 0) {
1280             code = PerlIO_apply_layera(aTHX_ f, mode, layers, 0, layers->cur);
1281         }
1282         PerlIO_list_free(aTHX_ layers);
1283     }
1284     LEAVE;
1285     return code;
1286 }
1287 
1288 
1289 /*--------------------------------------------------------------------------------------*/
1290 /*
1291  * Given the abstraction above the public API functions
1292  */
1293 
1294 int
PerlIO_binmode(pTHX_ PerlIO * f,int iotype,int mode,const char * names)1295 PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names)
1296 {
1297     PERL_UNUSED_ARG(iotype);
1298     PERL_UNUSED_ARG(mode);
1299 
1300     DEBUG_i(
1301         PerlIO_debug("PerlIO_binmode f=%p %s %c %x %s\n", (void*)f,
1302                      (PerlIOBase(f) && PerlIOBase(f)->tab) ?
1303                      PerlIOBase(f)->tab->name : "(Null)",
1304                      iotype, mode, (names) ? names : "(Null)") );
1305 
1306     if (names) {
1307         /* Do not flush etc. if (e.g.) switching encodings.
1308            if a pushed layer knows it needs to flush lower layers
1309            (for example :unix which is never going to call them)
1310            it can do the flush when it is pushed.
1311          */
1312         return cBOOL(PerlIO_apply_layers(aTHX_ f, NULL, names) == 0);
1313     }
1314     else {
1315         /* Fake 5.6 legacy of using this call to turn ON O_TEXT */
1316 #ifdef PERLIO_USING_CRLF
1317         /* Legacy binmode only has meaning if O_TEXT has a value distinct from
1318            O_BINARY so we can look for it in mode.
1319          */
1320         if (!(mode & O_BINARY)) {
1321             /* Text mode */
1322             /* FIXME?: Looking down the layer stack seems wrong,
1323                but is a way of reaching past (say) an encoding layer
1324                to flip CRLF-ness of the layer(s) below
1325              */
1326             while (*f) {
1327                 /* Perhaps we should turn on bottom-most aware layer
1328                    e.g. Ilya's idea that UNIX TTY could serve
1329                  */
1330                 if (PerlIOBase(f)->tab &&
1331                     PerlIOBase(f)->tab->kind & PERLIO_K_CANCRLF)
1332                 {
1333                     if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF)) {
1334                         /* Not in text mode - flush any pending stuff and flip it */
1335                         PerlIO_flush(f);
1336                         PerlIOBase(f)->flags |= PERLIO_F_CRLF;
1337                     }
1338                     /* Only need to turn it on in one layer so we are done */
1339                     return TRUE;
1340                 }
1341                 f = PerlIONext(f);
1342             }
1343             /* Not finding a CRLF aware layer presumably means we are binary
1344                which is not what was requested - so we failed
1345                We _could_ push :crlf layer but so could caller
1346              */
1347             return FALSE;
1348         }
1349 #endif
1350         /* Legacy binmode is now _defined_ as being equivalent to pushing :raw
1351            So code that used to be here is now in PerlIORaw_pushed().
1352          */
1353         return cBOOL(PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_raw), NULL, NULL));
1354     }
1355 }
1356 
1357 int
PerlIO__close(pTHX_ PerlIO * f)1358 PerlIO__close(pTHX_ PerlIO *f)
1359 {
1360     if (PerlIOValid(f)) {
1361         PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1362         if (tab && tab->Close)
1363             return (*tab->Close)(aTHX_ f);
1364         else
1365             return PerlIOBase_close(aTHX_ f);
1366     }
1367     else {
1368         SETERRNO(EBADF, SS_IVCHAN);
1369         return -1;
1370     }
1371 }
1372 
1373 int
Perl_PerlIO_close(pTHX_ PerlIO * f)1374 Perl_PerlIO_close(pTHX_ PerlIO *f)
1375 {
1376     const int code = PerlIO__close(aTHX_ f);
1377     while (PerlIOValid(f)) {
1378         PerlIO_pop(aTHX_ f);
1379         if (PerlIO_lockcnt(f))
1380             /* we're in use; the 'pop' deferred freeing the structure */
1381             f = PerlIONext(f);
1382     }
1383     return code;
1384 }
1385 
1386 int
Perl_PerlIO_fileno(pTHX_ PerlIO * f)1387 Perl_PerlIO_fileno(pTHX_ PerlIO *f)
1388 {
1389     Perl_PerlIO_or_Base(f, Fileno, fileno, -1, (aTHX_ f));
1390 }
1391 
1392 
1393 static PerlIO_funcs *
PerlIO_layer_from_ref(pTHX_ SV * sv)1394 PerlIO_layer_from_ref(pTHX_ SV *sv)
1395 {
1396     /*
1397      * For any scalar type load the handler which is bundled with perl
1398      */
1399     if (SvTYPE(sv) < SVt_PVAV && (!isGV_with_GP(sv) || SvFAKE(sv))) {
1400         PerlIO_funcs *f = PerlIO_find_layer(aTHX_ STR_WITH_LEN("scalar"), 1);
1401         /* This isn't supposed to happen, since PerlIO::scalar is core,
1402          * but could happen anyway in smaller installs or with PAR */
1403         if (!f)
1404             /* diag_listed_as: Unknown PerlIO layer "%s" */
1405             Perl_ck_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"scalar\"");
1406         return f;
1407     }
1408 
1409     /*
1410      * For other types allow if layer is known but don't try and load it
1411      */
1412     switch (SvTYPE(sv)) {
1413     case SVt_PVAV:
1414         return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Array"), 0);
1415     case SVt_PVHV:
1416         return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Hash"), 0);
1417     case SVt_PVCV:
1418         return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Code"), 0);
1419     case SVt_PVGV:
1420         return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Glob"), 0);
1421     default:
1422         return NULL;
1423     }
1424 }
1425 
1426 PerlIO_list_t *
PerlIO_resolve_layers(pTHX_ const char * layers,const char * mode,int narg,SV ** args)1427 PerlIO_resolve_layers(pTHX_ const char *layers,
1428                       const char *mode, int narg, SV **args)
1429 {
1430     PerlIO_list_t *def = PerlIO_default_layers(aTHX);
1431     int incdef = 1;
1432     if (!PL_perlio)
1433         PerlIO_stdstreams(aTHX);
1434     if (narg) {
1435         SV * const arg = *args;
1436         /*
1437          * If it is a reference but not an object see if we have a handler
1438          * for it
1439          */
1440         if (SvROK(arg) && !SvOBJECT(SvRV(arg))) {
1441             PerlIO_funcs * const handler = PerlIO_layer_from_ref(aTHX_ SvRV(arg));
1442             if (handler) {
1443                 def = PerlIO_list_alloc(aTHX);
1444                 PerlIO_list_push(aTHX_ def, handler, &PL_sv_undef);
1445                 incdef = 0;
1446             }
1447             /*
1448              * Don't fail if handler cannot be found :via(...) etc. may do
1449              * something sensible else we will just stringify and open
1450              * resulting string.
1451              */
1452         }
1453     }
1454     if (!layers || !*layers)
1455         layers = Perl_PerlIO_context_layers(aTHX_ mode);
1456     if (layers && *layers) {
1457         PerlIO_list_t *av;
1458         if (incdef) {
1459             av = PerlIO_clone_list(aTHX_ def, NULL);
1460         }
1461         else {
1462             av = def;
1463         }
1464         if (PerlIO_parse_layers(aTHX_ av, layers) == 0) {
1465              return av;
1466         }
1467         else {
1468             PerlIO_list_free(aTHX_ av);
1469             return NULL;
1470         }
1471     }
1472     else {
1473         if (incdef)
1474             def->refcnt++;
1475         return def;
1476     }
1477 }
1478 
1479 PerlIO *
PerlIO_openn(pTHX_ const char * layers,const char * mode,int fd,int imode,int perm,PerlIO * f,int narg,SV ** args)1480 PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
1481              int imode, int perm, PerlIO *f, int narg, SV **args)
1482 {
1483     if (!f && narg == 1 && *args == &PL_sv_undef) {
1484         imode = PerlIOUnix_oflags(mode);
1485 
1486         if (imode != -1 && (f = PerlIO_tmpfile_flags(imode))) {
1487             if (!layers || !*layers)
1488                 layers = Perl_PerlIO_context_layers(aTHX_ mode);
1489             if (layers && *layers)
1490                 PerlIO_apply_layers(aTHX_ f, mode, layers);
1491         }
1492     }
1493     else {
1494         PerlIO_list_t *layera;
1495         IV n;
1496         PerlIO_funcs *tab = NULL;
1497         if (PerlIOValid(f)) {
1498             /*
1499              * This is "reopen" - it is not tested as perl does not use it
1500              * yet
1501              */
1502             PerlIOl *l = *f;
1503             layera = PerlIO_list_alloc(aTHX);
1504             while (l) {
1505                 SV *arg = NULL;
1506                 if (l->tab && l->tab->Getarg)
1507                     arg = (*l->tab->Getarg) (aTHX_ &l, NULL, 0);
1508                 PerlIO_list_push(aTHX_ layera, l->tab,
1509                                  (arg) ? arg : &PL_sv_undef);
1510                 SvREFCNT_dec(arg);
1511                 l = *PerlIONext(&l);
1512             }
1513         }
1514         else {
1515             layera = PerlIO_resolve_layers(aTHX_ layers, mode, narg, args);
1516             if (!layera) {
1517                 return NULL;
1518             }
1519         }
1520         /*
1521          * Start at "top" of layer stack
1522          */
1523         n = layera->cur - 1;
1524         while (n >= 0) {
1525             PerlIO_funcs * const t = PerlIO_layer_fetch(aTHX_ layera, n, NULL);
1526             if (t && t->Open) {
1527                 tab = t;
1528                 break;
1529             }
1530             n--;
1531         }
1532         if (tab) {
1533             /*
1534              * Found that layer 'n' can do opens - call it
1535              */
1536             if (narg > 1 && !(tab->kind & PERLIO_K_MULTIARG)) {
1537                 Perl_croak(aTHX_ "More than one argument to open(,':%s')",tab->name);
1538             }
1539             DEBUG_i( PerlIO_debug("openn(%s,'%s','%s',%d,%x,%o,%p,%d,%p)\n",
1540                                   tab->name, layers ? layers : "(Null)", mode, fd,
1541                                   imode, perm, (void*)f, narg, (void*)args) );
1542             if (tab->Open)
1543                  f = (*tab->Open) (aTHX_ tab, layera, n, mode, fd, imode, perm,
1544                                    f, narg, args);
1545             else {
1546                  SETERRNO(EINVAL, LIB_INVARG);
1547                  f = NULL;
1548             }
1549             if (f) {
1550                 if (n + 1 < layera->cur) {
1551                     /*
1552                      * More layers above the one that we used to open -
1553                      * apply them now
1554                      */
1555                     if (PerlIO_apply_layera(aTHX_ f, mode, layera, n + 1, layera->cur) != 0) {
1556                         /* If pushing layers fails close the file */
1557                         PerlIO_close(f);
1558                         f = NULL;
1559                     }
1560                 }
1561             }
1562         }
1563         PerlIO_list_free(aTHX_ layera);
1564     }
1565     return f;
1566 }
1567 
1568 
1569 SSize_t
Perl_PerlIO_read(pTHX_ PerlIO * f,void * vbuf,Size_t count)1570 Perl_PerlIO_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
1571 {
1572      PERL_ARGS_ASSERT_PERLIO_READ;
1573 
1574      Perl_PerlIO_or_Base(f, Read, read, -1, (aTHX_ f, vbuf, count));
1575 }
1576 
1577 SSize_t
Perl_PerlIO_unread(pTHX_ PerlIO * f,const void * vbuf,Size_t count)1578 Perl_PerlIO_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
1579 {
1580      PERL_ARGS_ASSERT_PERLIO_UNREAD;
1581 
1582      Perl_PerlIO_or_Base(f, Unread, unread, -1, (aTHX_ f, vbuf, count));
1583 }
1584 
1585 SSize_t
Perl_PerlIO_write(pTHX_ PerlIO * f,const void * vbuf,Size_t count)1586 Perl_PerlIO_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
1587 {
1588      PERL_ARGS_ASSERT_PERLIO_WRITE;
1589 
1590      Perl_PerlIO_or_fail(f, Write, -1, (aTHX_ f, vbuf, count));
1591 }
1592 
1593 int
Perl_PerlIO_seek(pTHX_ PerlIO * f,Off_t offset,int whence)1594 Perl_PerlIO_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
1595 {
1596      Perl_PerlIO_or_fail(f, Seek, -1, (aTHX_ f, offset, whence));
1597 }
1598 
1599 Off_t
Perl_PerlIO_tell(pTHX_ PerlIO * f)1600 Perl_PerlIO_tell(pTHX_ PerlIO *f)
1601 {
1602      Perl_PerlIO_or_fail(f, Tell, -1, (aTHX_ f));
1603 }
1604 
1605 int
Perl_PerlIO_flush(pTHX_ PerlIO * f)1606 Perl_PerlIO_flush(pTHX_ PerlIO *f)
1607 {
1608     if (f) {
1609         if (*f) {
1610             const PerlIO_funcs *tab = PerlIOBase(f)->tab;
1611 
1612             if (tab && tab->Flush)
1613                 return (*tab->Flush) (aTHX_ f);
1614             else
1615                  return 0; /* If no Flush defined, silently succeed. */
1616         }
1617         else {
1618             DEBUG_i( PerlIO_debug("Cannot flush f=%p\n", (void*)f) );
1619             SETERRNO(EBADF, SS_IVCHAN);
1620             return -1;
1621         }
1622     }
1623     else {
1624         /*
1625          * Is it good API design to do flush-all on NULL, a potentially
1626          * erroneous input? Maybe some magical value (PerlIO*
1627          * PERLIO_FLUSH_ALL = (PerlIO*)-1;)? Yes, stdio does similar
1628          * things on fflush(NULL), but should we be bound by their design
1629          * decisions? --jhi
1630          */
1631         PerlIOl **table = &PL_perlio;
1632         PerlIOl *ff;
1633         int code = 0;
1634         while ((ff = *table)) {
1635             int i;
1636             table = &ff->next;
1637             ff++;
1638             for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
1639                 if (ff->next && PerlIO_flush(&(ff->next)) != 0)
1640                     code = -1;
1641                 ff++;
1642             }
1643         }
1644         return code;
1645     }
1646 }
1647 
1648 void
PerlIOBase_flush_linebuf(pTHX)1649 PerlIOBase_flush_linebuf(pTHX)
1650 {
1651     PerlIOl **table = &PL_perlio;
1652     PerlIOl *f;
1653     while ((f = *table)) {
1654         int i;
1655         table = &f->next;
1656         f++;
1657         for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
1658             if (f->next
1659                 && (PerlIOBase(&(f->next))->
1660                     flags & (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE))
1661                 == (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE))
1662                 PerlIO_flush(&(f->next));
1663             f++;
1664         }
1665     }
1666 }
1667 
1668 int
Perl_PerlIO_fill(pTHX_ PerlIO * f)1669 Perl_PerlIO_fill(pTHX_ PerlIO *f)
1670 {
1671      Perl_PerlIO_or_fail(f, Fill, -1, (aTHX_ f));
1672 }
1673 
1674 int
PerlIO_isutf8(PerlIO * f)1675 PerlIO_isutf8(PerlIO *f)
1676 {
1677      if (PerlIOValid(f))
1678           return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
1679      else
1680           SETERRNO(EBADF, SS_IVCHAN);
1681 
1682      return -1;
1683 }
1684 
1685 int
Perl_PerlIO_eof(pTHX_ PerlIO * f)1686 Perl_PerlIO_eof(pTHX_ PerlIO *f)
1687 {
1688      Perl_PerlIO_or_Base(f, Eof, eof, -1, (aTHX_ f));
1689 }
1690 
1691 int
Perl_PerlIO_error(pTHX_ PerlIO * f)1692 Perl_PerlIO_error(pTHX_ PerlIO *f)
1693 {
1694      Perl_PerlIO_or_Base(f, Error, error, -1, (aTHX_ f));
1695 }
1696 
1697 void
Perl_PerlIO_clearerr(pTHX_ PerlIO * f)1698 Perl_PerlIO_clearerr(pTHX_ PerlIO *f)
1699 {
1700      Perl_PerlIO_or_Base_void(f, Clearerr, clearerr, (aTHX_ f));
1701 }
1702 
1703 void
Perl_PerlIO_setlinebuf(pTHX_ PerlIO * f)1704 Perl_PerlIO_setlinebuf(pTHX_ PerlIO *f)
1705 {
1706      Perl_PerlIO_or_Base_void(f, Setlinebuf, setlinebuf, (aTHX_ f));
1707 }
1708 
1709 int
PerlIO_has_base(PerlIO * f)1710 PerlIO_has_base(PerlIO *f)
1711 {
1712      if (PerlIOValid(f)) {
1713           const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1714 
1715           if (tab)
1716                return (tab->Get_base != NULL);
1717      }
1718 
1719      return 0;
1720 }
1721 
1722 int
PerlIO_fast_gets(PerlIO * f)1723 PerlIO_fast_gets(PerlIO *f)
1724 {
1725     if (PerlIOValid(f)) {
1726          if (PerlIOBase(f)->flags & PERLIO_F_FASTGETS) {
1727              const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1728 
1729              if (tab)
1730                   return (tab->Set_ptrcnt != NULL);
1731          }
1732     }
1733 
1734     return 0;
1735 }
1736 
1737 int
PerlIO_has_cntptr(PerlIO * f)1738 PerlIO_has_cntptr(PerlIO *f)
1739 {
1740     if (PerlIOValid(f)) {
1741         const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1742 
1743         if (tab)
1744              return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
1745     }
1746 
1747     return 0;
1748 }
1749 
1750 int
PerlIO_canset_cnt(PerlIO * f)1751 PerlIO_canset_cnt(PerlIO *f)
1752 {
1753     if (PerlIOValid(f)) {
1754           const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1755 
1756           if (tab)
1757                return (tab->Set_ptrcnt != NULL);
1758     }
1759 
1760     return 0;
1761 }
1762 
1763 STDCHAR *
Perl_PerlIO_get_base(pTHX_ PerlIO * f)1764 Perl_PerlIO_get_base(pTHX_ PerlIO *f)
1765 {
1766      Perl_PerlIO_or_fail(f, Get_base, NULL, (aTHX_ f));
1767 }
1768 
1769 SSize_t
Perl_PerlIO_get_bufsiz(pTHX_ PerlIO * f)1770 Perl_PerlIO_get_bufsiz(pTHX_ PerlIO *f)
1771 {
1772     /* Note that Get_bufsiz returns a Size_t */
1773      Perl_PerlIO_or_fail(f, Get_bufsiz, -1, (aTHX_ f));
1774 }
1775 
1776 STDCHAR *
Perl_PerlIO_get_ptr(pTHX_ PerlIO * f)1777 Perl_PerlIO_get_ptr(pTHX_ PerlIO *f)
1778 {
1779      Perl_PerlIO_or_fail(f, Get_ptr, NULL, (aTHX_ f));
1780 }
1781 
1782 SSize_t
Perl_PerlIO_get_cnt(pTHX_ PerlIO * f)1783 Perl_PerlIO_get_cnt(pTHX_ PerlIO *f)
1784 {
1785      Perl_PerlIO_or_fail(f, Get_cnt, -1, (aTHX_ f));
1786 }
1787 
1788 void
Perl_PerlIO_set_cnt(pTHX_ PerlIO * f,SSize_t cnt)1789 Perl_PerlIO_set_cnt(pTHX_ PerlIO *f, SSize_t cnt)
1790 {
1791      Perl_PerlIO_or_fail_void(f, Set_ptrcnt, (aTHX_ f, NULL, cnt));
1792 }
1793 
1794 void
Perl_PerlIO_set_ptrcnt(pTHX_ PerlIO * f,STDCHAR * ptr,SSize_t cnt)1795 Perl_PerlIO_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
1796 {
1797      Perl_PerlIO_or_fail_void(f, Set_ptrcnt, (aTHX_ f, ptr, cnt));
1798 }
1799 
1800 
1801 /*--------------------------------------------------------------------------------------*/
1802 /*
1803  * utf8 and raw dummy layers
1804  */
1805 
1806 IV
PerlIOUtf8_pushed(pTHX_ PerlIO * f,const char * mode,SV * arg,PerlIO_funcs * tab)1807 PerlIOUtf8_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1808 {
1809     PERL_UNUSED_CONTEXT;
1810     PERL_UNUSED_ARG(mode);
1811     PERL_UNUSED_ARG(arg);
1812     if (PerlIOValid(f)) {
1813         if (tab && tab->kind & PERLIO_K_UTF8)
1814             PerlIOBase(f)->flags |= PERLIO_F_UTF8;
1815         else
1816             PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1817         return 0;
1818     }
1819     return -1;
1820 }
1821 
1822 PERLIO_FUNCS_DECL(PerlIO_utf8) = {
1823     sizeof(PerlIO_funcs),
1824     "utf8",
1825     0,
1826     PERLIO_K_DUMMY | PERLIO_K_UTF8 | PERLIO_K_MULTIARG,
1827     PerlIOUtf8_pushed,
1828     NULL,
1829     PerlIOBase_open,
1830     NULL,
1831     NULL,
1832     NULL,
1833     NULL,
1834     NULL,
1835     NULL,
1836     NULL,
1837     NULL,
1838     NULL,
1839     NULL,
1840     NULL,                       /* flush */
1841     NULL,                       /* fill */
1842     NULL,
1843     NULL,
1844     NULL,
1845     NULL,
1846     NULL,                       /* get_base */
1847     NULL,                       /* get_bufsiz */
1848     NULL,                       /* get_ptr */
1849     NULL,                       /* get_cnt */
1850     NULL,                       /* set_ptrcnt */
1851 };
1852 
1853 PERLIO_FUNCS_DECL(PerlIO_byte) = {
1854     sizeof(PerlIO_funcs),
1855     "bytes",
1856     0,
1857     PERLIO_K_DUMMY | PERLIO_K_MULTIARG,
1858     PerlIOUtf8_pushed,
1859     NULL,
1860     PerlIOBase_open,
1861     NULL,
1862     NULL,
1863     NULL,
1864     NULL,
1865     NULL,
1866     NULL,
1867     NULL,
1868     NULL,
1869     NULL,
1870     NULL,
1871     NULL,                       /* flush */
1872     NULL,                       /* fill */
1873     NULL,
1874     NULL,
1875     NULL,
1876     NULL,
1877     NULL,                       /* get_base */
1878     NULL,                       /* get_bufsiz */
1879     NULL,                       /* get_ptr */
1880     NULL,                       /* get_cnt */
1881     NULL,                       /* set_ptrcnt */
1882 };
1883 
1884 PERLIO_FUNCS_DECL(PerlIO_raw) = {
1885     sizeof(PerlIO_funcs),
1886     "raw",
1887     0,
1888     PERLIO_K_DUMMY,
1889     PerlIORaw_pushed,
1890     PerlIOBase_popped,
1891     PerlIOBase_open,
1892     NULL,
1893     NULL,
1894     NULL,
1895     NULL,
1896     NULL,
1897     NULL,
1898     NULL,
1899     NULL,
1900     NULL,
1901     NULL,
1902     NULL,                       /* flush */
1903     NULL,                       /* fill */
1904     NULL,
1905     NULL,
1906     NULL,
1907     NULL,
1908     NULL,                       /* get_base */
1909     NULL,                       /* get_bufsiz */
1910     NULL,                       /* get_ptr */
1911     NULL,                       /* get_cnt */
1912     NULL,                       /* set_ptrcnt */
1913 };
1914 /*--------------------------------------------------------------------------------------*/
1915 /*--------------------------------------------------------------------------------------*/
1916 /*
1917  * "Methods" of the "base class"
1918  */
1919 
1920 IV
PerlIOBase_fileno(pTHX_ PerlIO * f)1921 PerlIOBase_fileno(pTHX_ PerlIO *f)
1922 {
1923     return PerlIOValid(f) ? PerlIO_fileno(PerlIONext(f)) : -1;
1924 }
1925 
1926 char *
PerlIO_modestr(PerlIO * f,char * buf)1927 PerlIO_modestr(PerlIO * f, char *buf)
1928 {
1929     char *s = buf;
1930     if (PerlIOValid(f)) {
1931         const IV flags = PerlIOBase(f)->flags;
1932         if (flags & PERLIO_F_APPEND) {
1933             *s++ = 'a';
1934             if (flags & PERLIO_F_CANREAD) {
1935                 *s++ = '+';
1936             }
1937         }
1938         else if (flags & PERLIO_F_CANREAD) {
1939             *s++ = 'r';
1940             if (flags & PERLIO_F_CANWRITE)
1941                 *s++ = '+';
1942         }
1943         else if (flags & PERLIO_F_CANWRITE) {
1944             *s++ = 'w';
1945             if (flags & PERLIO_F_CANREAD) {
1946                 *s++ = '+';
1947             }
1948         }
1949 #ifdef PERLIO_USING_CRLF
1950         if (!(flags & PERLIO_F_CRLF))
1951             *s++ = 'b';
1952 #endif
1953     }
1954     *s = '\0';
1955     return buf;
1956 }
1957 
1958 
1959 IV
PerlIOBase_pushed(pTHX_ PerlIO * f,const char * mode,SV * arg,PerlIO_funcs * tab)1960 PerlIOBase_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1961 {
1962     PerlIOl * const l = PerlIOBase(f);
1963     PERL_UNUSED_CONTEXT;
1964     PERL_UNUSED_ARG(arg);
1965 
1966     l->flags &= ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE |
1967                   PERLIO_F_TRUNCATE | PERLIO_F_APPEND);
1968     if (tab && tab->Set_ptrcnt != NULL)
1969         l->flags |= PERLIO_F_FASTGETS;
1970     if (mode) {
1971         if (*mode == IoTYPE_NUMERIC || *mode == IoTYPE_IMPLICIT)
1972             mode++;
1973         switch (*mode++) {
1974         case 'r':
1975             l->flags |= PERLIO_F_CANREAD;
1976             break;
1977         case 'a':
1978             l->flags |= PERLIO_F_APPEND | PERLIO_F_CANWRITE;
1979             break;
1980         case 'w':
1981             l->flags |= PERLIO_F_TRUNCATE | PERLIO_F_CANWRITE;
1982             break;
1983         default:
1984             SETERRNO(EINVAL, LIB_INVARG);
1985             return -1;
1986         }
1987 #ifdef __MVS__  /* XXX Perhaps should be be OEMVS instead of __MVS__ */
1988         {
1989         /* The mode variable contains one positional parameter followed by
1990          * optional keyword parameters.  The positional parameters must be
1991          * passed as lowercase characters.  The keyword parameters can be
1992          * passed in mixed case. They must be separated by commas. Only one
1993          * instance of a keyword can be specified.  */
1994         int comma = 0;
1995         while (*mode) {
1996             switch (*mode++) {
1997             case '+':
1998                 if(!comma)
1999                   l->flags |= PERLIO_F_CANREAD | PERLIO_F_CANWRITE;
2000                 break;
2001             case 'b':
2002                 if(!comma)
2003                   l->flags &= ~PERLIO_F_CRLF;
2004                 break;
2005             case 't':
2006                 if(!comma)
2007                   l->flags |= PERLIO_F_CRLF;
2008                 break;
2009             case ',':
2010                 comma = 1;
2011                 break;
2012             default:
2013                 break;
2014             }
2015         }
2016         }
2017 #else
2018         while (*mode) {
2019             switch (*mode++) {
2020             case '+':
2021                 l->flags |= PERLIO_F_CANREAD | PERLIO_F_CANWRITE;
2022                 break;
2023             case 'b':
2024                 l->flags &= ~PERLIO_F_CRLF;
2025                 break;
2026             case 't':
2027                 l->flags |= PERLIO_F_CRLF;
2028                 break;
2029             default:
2030                 SETERRNO(EINVAL, LIB_INVARG);
2031                 return -1;
2032             }
2033         }
2034 #endif
2035     }
2036     else {
2037         if (l->next) {
2038             l->flags |= l->next->flags &
2039                 (PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_TRUNCATE |
2040                  PERLIO_F_APPEND);
2041         }
2042     }
2043 #if 0
2044     DEBUG_i(
2045     PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08" UVxf " (%s)\n",
2046                  (void*)f, PerlIOBase(f)->tab->name, (omode) ? omode : "(Null)",
2047                  l->flags, PerlIO_modestr(f, temp));
2048     );
2049 #endif
2050     return 0;
2051 }
2052 
2053 IV
PerlIOBase_popped(pTHX_ PerlIO * f)2054 PerlIOBase_popped(pTHX_ PerlIO *f)
2055 {
2056     PERL_UNUSED_CONTEXT;
2057     PERL_UNUSED_ARG(f);
2058     return 0;
2059 }
2060 
2061 SSize_t
PerlIOBase_unread(pTHX_ PerlIO * f,const void * vbuf,Size_t count)2062 PerlIOBase_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
2063 {
2064     /*
2065      * Save the position as current head considers it
2066      */
2067     const Off_t old = PerlIO_tell(f);
2068     PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_pending), "r", NULL);
2069     PerlIOSelf(f, PerlIOBuf)->posn = old;
2070     return PerlIOBuf_unread(aTHX_ f, vbuf, count);
2071 }
2072 
2073 SSize_t
PerlIOBase_read(pTHX_ PerlIO * f,void * vbuf,Size_t count)2074 PerlIOBase_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
2075 {
2076     STDCHAR *buf = (STDCHAR *) vbuf;
2077     if (f) {
2078         if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD)) {
2079             PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2080             SETERRNO(EBADF, SS_IVCHAN);
2081             PerlIO_save_errno(f);
2082             return 0;
2083         }
2084         while (count > 0) {
2085          get_cnt:
2086           {
2087             SSize_t avail = PerlIO_get_cnt(f);
2088             SSize_t take = 0;
2089             if (avail > 0)
2090                 take = (((SSize_t) count >= 0) && ((SSize_t)count < avail)) ? (SSize_t)count : avail;
2091             if (take > 0) {
2092                 STDCHAR *ptr = PerlIO_get_ptr(f);
2093                 Copy(ptr, buf, take, STDCHAR);
2094                 PerlIO_set_ptrcnt(f, ptr + take, (avail -= take));
2095                 count -= take;
2096                 buf += take;
2097                 if (avail == 0)		/* set_ptrcnt could have reset avail */
2098                     goto get_cnt;
2099             }
2100             if (count > 0 && avail <= 0) {
2101                 if (PerlIO_fill(f) != 0)
2102                     break;
2103             }
2104           }
2105         }
2106         return (buf - (STDCHAR *) vbuf);
2107     }
2108     return 0;
2109 }
2110 
2111 IV
PerlIOBase_noop_ok(pTHX_ PerlIO * f)2112 PerlIOBase_noop_ok(pTHX_ PerlIO *f)
2113 {
2114     PERL_UNUSED_CONTEXT;
2115     PERL_UNUSED_ARG(f);
2116     return 0;
2117 }
2118 
2119 IV
PerlIOBase_noop_fail(pTHX_ PerlIO * f)2120 PerlIOBase_noop_fail(pTHX_ PerlIO *f)
2121 {
2122     PERL_UNUSED_CONTEXT;
2123     PERL_UNUSED_ARG(f);
2124     return -1;
2125 }
2126 
2127 IV
PerlIOBase_close(pTHX_ PerlIO * f)2128 PerlIOBase_close(pTHX_ PerlIO *f)
2129 {
2130     IV code = -1;
2131     if (PerlIOValid(f)) {
2132         PerlIO *n = PerlIONext(f);
2133         code = PerlIO_flush(f);
2134         PerlIOBase(f)->flags &=
2135            ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN);
2136         while (PerlIOValid(n)) {
2137             const PerlIO_funcs * const tab = PerlIOBase(n)->tab;
2138             if (tab && tab->Close) {
2139                 if ((*tab->Close)(aTHX_ n) != 0)
2140                     code = -1;
2141                 break;
2142             }
2143             else {
2144                 PerlIOBase(n)->flags &=
2145                     ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN);
2146             }
2147             n = PerlIONext(n);
2148         }
2149     }
2150     else {
2151         SETERRNO(EBADF, SS_IVCHAN);
2152     }
2153     return code;
2154 }
2155 
2156 IV
PerlIOBase_eof(pTHX_ PerlIO * f)2157 PerlIOBase_eof(pTHX_ PerlIO *f)
2158 {
2159     PERL_UNUSED_CONTEXT;
2160     if (PerlIOValid(f)) {
2161         return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
2162     }
2163     return 1;
2164 }
2165 
2166 IV
PerlIOBase_error(pTHX_ PerlIO * f)2167 PerlIOBase_error(pTHX_ PerlIO *f)
2168 {
2169     PERL_UNUSED_CONTEXT;
2170     if (PerlIOValid(f)) {
2171         return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
2172     }
2173     return 1;
2174 }
2175 
2176 void
PerlIOBase_clearerr(pTHX_ PerlIO * f)2177 PerlIOBase_clearerr(pTHX_ PerlIO *f)
2178 {
2179     if (PerlIOValid(f)) {
2180         PerlIO * const n = PerlIONext(f);
2181         PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR | PERLIO_F_EOF);
2182         if (PerlIOValid(n))
2183             PerlIO_clearerr(n);
2184     }
2185 }
2186 
2187 void
PerlIOBase_setlinebuf(pTHX_ PerlIO * f)2188 PerlIOBase_setlinebuf(pTHX_ PerlIO *f)
2189 {
2190     PERL_UNUSED_CONTEXT;
2191     if (PerlIOValid(f)) {
2192         PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
2193     }
2194 }
2195 
2196 SV *
PerlIO_sv_dup(pTHX_ SV * arg,CLONE_PARAMS * param)2197 PerlIO_sv_dup(pTHX_ SV *arg, CLONE_PARAMS *param)
2198 {
2199     if (!arg)
2200         return NULL;
2201 #ifdef USE_ITHREADS
2202     if (param) {
2203         arg = sv_dup(arg, param);
2204         SvREFCNT_inc_simple_void_NN(arg);
2205         return arg;
2206     }
2207     else {
2208         return newSVsv(arg);
2209     }
2210 #else
2211     PERL_UNUSED_ARG(param);
2212     return newSVsv(arg);
2213 #endif
2214 }
2215 
2216 PerlIO *
PerlIOBase_dup(pTHX_ PerlIO * f,PerlIO * o,CLONE_PARAMS * param,int flags)2217 PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
2218 {
2219     PerlIO * const nexto = PerlIONext(o);
2220     if (PerlIOValid(nexto)) {
2221         const PerlIO_funcs * const tab = PerlIOBase(nexto)->tab;
2222         if (tab && tab->Dup)
2223             f = (*tab->Dup)(aTHX_ f, nexto, param, flags);
2224         else
2225             f = PerlIOBase_dup(aTHX_ f, nexto, param, flags);
2226     }
2227     if (f) {
2228         PerlIO_funcs * const self = PerlIOBase(o)->tab;
2229         SV *arg = NULL;
2230         char buf[8];
2231         assert(self);
2232         DEBUG_i(PerlIO_debug("PerlIOBase_dup %s f=%p o=%p param=%p\n",
2233                              self->name,
2234                              (void*)f, (void*)o, (void*)param) );
2235         if (self->Getarg)
2236           arg = (*self->Getarg)(aTHX_ o, param, flags);
2237         f = PerlIO_push(aTHX_ f, self, PerlIO_modestr(o,buf), arg);
2238         if (f && PerlIOBase(o)->flags & PERLIO_F_UTF8)
2239             PerlIOBase(f)->flags |= PERLIO_F_UTF8;
2240         SvREFCNT_dec(arg);
2241     }
2242     return f;
2243 }
2244 
2245 /* PL_perlio_fd_refcnt[] is in intrpvar.h */
2246 
2247 /* Must be called with PL_perlio_mutex locked. */
2248 static void
S_more_refcounted_fds(pTHX_ const int new_fd)2249 S_more_refcounted_fds(pTHX_ const int new_fd)
2250   PERL_TSA_REQUIRES(PL_perlio_mutex)
2251 {
2252     const int old_max = PL_perlio_fd_refcnt_size;
2253     const int new_max = 16 + (new_fd & ~15);
2254     int *new_array;
2255 
2256 #ifndef PERL_IMPLICIT_SYS
2257     PERL_UNUSED_CONTEXT;
2258 #endif
2259 
2260     DEBUG_i( PerlIO_debug("More fds - old=%d, need %d, new=%d\n",
2261                           old_max, new_fd, new_max) );
2262 
2263     if (new_fd < old_max) {
2264         return;
2265     }
2266 
2267     assert (new_max > new_fd);
2268 
2269     /* Use plain realloc() since we need this memory to be really
2270      * global and visible to all the interpreters and/or threads. */
2271     new_array = (int*) realloc(PL_perlio_fd_refcnt, new_max * sizeof(int));
2272 
2273     if (!new_array) {
2274         MUTEX_UNLOCK(&PL_perlio_mutex);
2275         croak_no_mem();
2276     }
2277 
2278     PL_perlio_fd_refcnt_size = new_max;
2279     PL_perlio_fd_refcnt = new_array;
2280 
2281     DEBUG_i( PerlIO_debug("Zeroing %p, %d\n",
2282                           (void*)(new_array + old_max),
2283                           new_max - old_max) );
2284 
2285     Zero(new_array + old_max, new_max - old_max, int);
2286 }
2287 
2288 
2289 void
PerlIO_init(pTHX)2290 PerlIO_init(pTHX)
2291 {
2292     /* MUTEX_INIT(&PL_perlio_mutex) is done in PERL_SYS_INIT3(). */
2293     PERL_UNUSED_CONTEXT;
2294 }
2295 
2296 void
PerlIOUnix_refcnt_inc(int fd)2297 PerlIOUnix_refcnt_inc(int fd)
2298 {
2299     dTHX;
2300     if (fd >= 0) {
2301 
2302         MUTEX_LOCK(&PL_perlio_mutex);
2303         if (fd >= PL_perlio_fd_refcnt_size)
2304             S_more_refcounted_fds(aTHX_ fd);
2305 
2306         PL_perlio_fd_refcnt[fd]++;
2307         if (PL_perlio_fd_refcnt[fd] <= 0) {
2308             /* diag_listed_as: refcnt_inc: fd %d%s */
2309             Perl_croak(aTHX_ "refcnt_inc: fd %d: %d <= 0\n",
2310                        fd, PL_perlio_fd_refcnt[fd]);
2311         }
2312         DEBUG_i( PerlIO_debug("refcnt_inc: fd %d refcnt=%d\n",
2313                               fd, PL_perlio_fd_refcnt[fd]) );
2314 
2315         MUTEX_UNLOCK(&PL_perlio_mutex);
2316     } else {
2317         /* diag_listed_as: refcnt_inc: fd %d%s */
2318         Perl_croak(aTHX_ "refcnt_inc: fd %d < 0\n", fd);
2319     }
2320 }
2321 
2322 int
PerlIOUnix_refcnt_dec(int fd)2323 PerlIOUnix_refcnt_dec(int fd)
2324 {
2325     int cnt = 0;
2326     if (fd >= 0) {
2327 #ifdef DEBUGGING
2328         dTHX;
2329 #endif
2330         MUTEX_LOCK(&PL_perlio_mutex);
2331         if (fd >= PL_perlio_fd_refcnt_size) {
2332             /* diag_listed_as: refcnt_dec: fd %d%s */
2333             Perl_croak_nocontext("refcnt_dec: fd %d >= refcnt_size %d\n",
2334                        fd, PL_perlio_fd_refcnt_size);
2335         }
2336         if (PL_perlio_fd_refcnt[fd] <= 0) {
2337             /* diag_listed_as: refcnt_dec: fd %d%s */
2338             Perl_croak_nocontext("refcnt_dec: fd %d: %d <= 0\n",
2339                        fd, PL_perlio_fd_refcnt[fd]);
2340         }
2341         cnt = --PL_perlio_fd_refcnt[fd];
2342         DEBUG_i( PerlIO_debug("refcnt_dec: fd %d refcnt=%d\n", fd, cnt) );
2343         MUTEX_UNLOCK(&PL_perlio_mutex);
2344     } else {
2345         /* diag_listed_as: refcnt_dec: fd %d%s */
2346         Perl_croak_nocontext("refcnt_dec: fd %d < 0\n", fd);
2347     }
2348     return cnt;
2349 }
2350 
2351 int
PerlIOUnix_refcnt(int fd)2352 PerlIOUnix_refcnt(int fd)
2353 {
2354     dTHX;
2355     int cnt = 0;
2356     if (fd >= 0) {
2357         MUTEX_LOCK(&PL_perlio_mutex);
2358         if (fd >= PL_perlio_fd_refcnt_size) {
2359             /* diag_listed_as: refcnt: fd %d%s */
2360             Perl_croak(aTHX_ "refcnt: fd %d >= refcnt_size %d\n",
2361                        fd, PL_perlio_fd_refcnt_size);
2362         }
2363         if (PL_perlio_fd_refcnt[fd] <= 0) {
2364             /* diag_listed_as: refcnt: fd %d%s */
2365             Perl_croak(aTHX_ "refcnt: fd %d: %d <= 0\n",
2366                        fd, PL_perlio_fd_refcnt[fd]);
2367         }
2368         cnt = PL_perlio_fd_refcnt[fd];
2369         MUTEX_UNLOCK(&PL_perlio_mutex);
2370     } else {
2371         /* diag_listed_as: refcnt: fd %d%s */
2372         Perl_croak(aTHX_ "refcnt: fd %d < 0\n", fd);
2373     }
2374     return cnt;
2375 }
2376 
2377 void
PerlIO_cleanup(pTHX)2378 PerlIO_cleanup(pTHX)
2379 {
2380     int i;
2381 #ifdef USE_ITHREADS
2382     DEBUG_i( PerlIO_debug("Cleanup layers for %p\n",(void*)aTHX) );
2383 #else
2384     DEBUG_i( PerlIO_debug("Cleanup layers\n") );
2385 #endif
2386 
2387     /* Raise STDIN..STDERR refcount so we don't close them */
2388     for (i=0; i < 3; i++)
2389         PerlIOUnix_refcnt_inc(i);
2390     PerlIO_cleantable(aTHX_ &PL_perlio);
2391     /* Restore STDIN..STDERR refcount */
2392     for (i=0; i < 3; i++)
2393         PerlIOUnix_refcnt_dec(i);
2394 
2395     if (PL_known_layers) {
2396         PerlIO_list_free(aTHX_ PL_known_layers);
2397         PL_known_layers = NULL;
2398     }
2399     if (PL_def_layerlist) {
2400         PerlIO_list_free(aTHX_ PL_def_layerlist);
2401         PL_def_layerlist = NULL;
2402     }
2403 }
2404 
PerlIO_teardown(void)2405 void PerlIO_teardown(void) /* Call only from PERL_SYS_TERM(). */
2406 {
2407 #if 0
2408 /* XXX we can't rely on an interpreter being present at this late stage,
2409    XXX so we can't use a function like PerlLIO_write that relies on one
2410    being present (at least in win32) :-(.
2411    Disable for now.
2412 */
2413 #  ifdef DEBUGGING
2414     {
2415         /* By now all filehandles should have been closed, so any
2416          * stray (non-STD-)filehandles indicate *possible* (PerlIO)
2417          * errors. */
2418 #define PERLIO_TEARDOWN_MESSAGE_BUF_SIZE 64
2419 #define PERLIO_TEARDOWN_MESSAGE_FD 2
2420         char buf[PERLIO_TEARDOWN_MESSAGE_BUF_SIZE];
2421         int i;
2422         for (i = 3; i < PL_perlio_fd_refcnt_size; i++) {
2423             if (PL_perlio_fd_refcnt[i]) {
2424                 const STRLEN len =
2425                     my_snprintf(buf, sizeof(buf),
2426                                 "PerlIO_teardown: fd %d refcnt=%d\n",
2427                                 i, PL_perlio_fd_refcnt[i]);
2428                 PerlLIO_write(PERLIO_TEARDOWN_MESSAGE_FD, buf, len);
2429             }
2430         }
2431     }
2432 #  endif
2433 #endif
2434     /* Not bothering with PL_perlio_mutex since by now
2435      * all the interpreters are gone. */
2436     if (PL_perlio_fd_refcnt_size /* Assuming initial size of zero. */
2437         && PL_perlio_fd_refcnt) {
2438         free(PL_perlio_fd_refcnt); /* To match realloc() in S_more_refcounted_fds(). */
2439         PL_perlio_fd_refcnt = NULL;
2440         PL_perlio_fd_refcnt_size = 0;
2441     }
2442 }
2443 
2444 /*--------------------------------------------------------------------------------------*/
2445 /*
2446  * Bottom-most level for UNIX-like case
2447  */
2448 
2449 typedef struct {
2450     struct _PerlIO base;        /* The generic part */
2451     int fd;                     /* UNIX like file descriptor */
2452     int oflags;                 /* open/fcntl flags */
2453 } PerlIOUnix;
2454 
2455 static void
S_lockcnt_dec(pTHX_ const void * f)2456 S_lockcnt_dec(pTHX_ const void* f)
2457 {
2458 #ifndef PERL_IMPLICIT_SYS
2459     PERL_UNUSED_CONTEXT;
2460 #endif
2461     PerlIO_lockcnt((PerlIO*)f)--;
2462 }
2463 
2464 
2465 /* call the signal handler, and if that handler happens to clear
2466  * this handle, free what we can and return true */
2467 
2468 static bool
S_perlio_async_run(pTHX_ PerlIO * f)2469 S_perlio_async_run(pTHX_ PerlIO* f) {
2470     ENTER;
2471     SAVEDESTRUCTOR_X(S_lockcnt_dec, (void*)f);
2472     PerlIO_lockcnt(f)++;
2473     PERL_ASYNC_CHECK();
2474     if ( !(PerlIOBase(f)->flags & PERLIO_F_CLEARED) ) {
2475         LEAVE;
2476         return 0;
2477     }
2478     /* we've just run some perl-level code that could have done
2479      * anything, including closing the file or clearing this layer.
2480      * If so, free any lower layers that have already been
2481      * cleared, then return an error. */
2482     while (PerlIOValid(f) &&
2483             (PerlIOBase(f)->flags & PERLIO_F_CLEARED))
2484     {
2485         const PerlIOl *l = *f;
2486         *f = l->next;
2487         Safefree(l);
2488     }
2489     LEAVE;
2490     return 1;
2491 }
2492 
2493 int
PerlIOUnix_oflags(const char * mode)2494 PerlIOUnix_oflags(const char *mode)
2495 {
2496     int oflags = -1;
2497     if (*mode == IoTYPE_IMPLICIT || *mode == IoTYPE_NUMERIC)
2498         mode++;
2499     switch (*mode) {
2500     case 'r':
2501         oflags = O_RDONLY;
2502         if (*++mode == '+') {
2503             oflags = O_RDWR;
2504             mode++;
2505         }
2506         break;
2507 
2508     case 'w':
2509         oflags = O_CREAT | O_TRUNC;
2510         if (*++mode == '+') {
2511             oflags |= O_RDWR;
2512             mode++;
2513         }
2514         else
2515             oflags |= O_WRONLY;
2516         break;
2517 
2518     case 'a':
2519         oflags = O_CREAT | O_APPEND;
2520         if (*++mode == '+') {
2521             oflags |= O_RDWR;
2522             mode++;
2523         }
2524         else
2525             oflags |= O_WRONLY;
2526         break;
2527     }
2528 
2529     /* XXX TODO: PerlIO_open() test that exercises 'rb' and 'rt'. */
2530 
2531     /* Unless O_BINARY is different from O_TEXT, first bit-or:ing one
2532      * of them in, and then bit-and-masking the other them away, won't
2533      * have much of an effect. */
2534     switch (*mode) {
2535     case 'b':
2536 #if O_TEXT != O_BINARY
2537         oflags |= O_BINARY;
2538         oflags &= ~O_TEXT;
2539 #endif
2540         mode++;
2541         break;
2542     case 't':
2543 #if O_TEXT != O_BINARY
2544         oflags |= O_TEXT;
2545         oflags &= ~O_BINARY;
2546 #endif
2547         mode++;
2548         break;
2549     default:
2550 #if O_BINARY != 0
2551         /* bit-or:ing with zero O_BINARY would be useless. */
2552         /*
2553          * If neither "t" nor "b" was specified, open the file
2554          * in O_BINARY mode.
2555          *
2556          * Note that if something else than the zero byte was seen
2557          * here (e.g. bogus mode "rx"), just few lines later we will
2558          * set the errno and invalidate the flags.
2559          */
2560         oflags |= O_BINARY;
2561 #endif
2562         break;
2563     }
2564     if (*mode || oflags == -1) {
2565         SETERRNO(EINVAL, LIB_INVARG);
2566         oflags = -1;
2567     }
2568     return oflags;
2569 }
2570 
2571 IV
PerlIOUnix_fileno(pTHX_ PerlIO * f)2572 PerlIOUnix_fileno(pTHX_ PerlIO *f)
2573 {
2574     PERL_UNUSED_CONTEXT;
2575     return PerlIOSelf(f, PerlIOUnix)->fd;
2576 }
2577 
2578 static void
PerlIOUnix_setfd(pTHX_ PerlIO * f,int fd,int imode)2579 PerlIOUnix_setfd(pTHX_ PerlIO *f, int fd, int imode)
2580 {
2581     PerlIOUnix * const s = PerlIOSelf(f, PerlIOUnix);
2582 #if defined(WIN32)
2583     Stat_t st;
2584     if (PerlLIO_fstat(fd, &st) == 0) {
2585         if (!S_ISREG(st.st_mode)) {
2586             DEBUG_i( PerlIO_debug("%d is not regular file\n",fd) );
2587             PerlIOBase(f)->flags |= PERLIO_F_NOTREG;
2588         }
2589         else {
2590             DEBUG_i( PerlIO_debug("%d _is_ a regular file\n",fd) );
2591         }
2592     }
2593 #endif
2594     s->fd = fd;
2595     s->oflags = imode;
2596     PerlIOUnix_refcnt_inc(fd);
2597     PERL_UNUSED_CONTEXT;
2598 }
2599 
2600 IV
PerlIOUnix_pushed(pTHX_ PerlIO * f,const char * mode,SV * arg,PerlIO_funcs * tab)2601 PerlIOUnix_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2602 {
2603     IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
2604     if (*PerlIONext(f)) {
2605         /* We never call down so do any pending stuff now */
2606         PerlIO_flush(PerlIONext(f));
2607         /*
2608          * XXX could (or should) we retrieve the oflags from the open file
2609          * handle rather than believing the "mode" we are passed in? XXX
2610          * Should the value on NULL mode be 0 or -1?
2611          */
2612         PerlIOUnix_setfd(aTHX_ f, PerlIO_fileno(PerlIONext(f)),
2613                          mode ? PerlIOUnix_oflags(mode) : -1);
2614     }
2615     PerlIOBase(f)->flags |= PERLIO_F_OPEN;
2616 
2617     return code;
2618 }
2619 
2620 IV
PerlIOUnix_seek(pTHX_ PerlIO * f,Off_t offset,int whence)2621 PerlIOUnix_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
2622 {
2623     const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2624     Off_t new_loc;
2625     PERL_UNUSED_CONTEXT;
2626     if (PerlIOBase(f)->flags & PERLIO_F_NOTREG) {
2627 #ifdef  ESPIPE
2628         SETERRNO(ESPIPE, LIB_INVARG);
2629 #else
2630         SETERRNO(EINVAL, LIB_INVARG);
2631 #endif
2632         return -1;
2633     }
2634     new_loc = PerlLIO_lseek(fd, offset, whence);
2635     if (new_loc == (Off_t) - 1)
2636         return -1;
2637     PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2638     return  0;
2639 }
2640 
2641 PerlIO *
PerlIOUnix_open(pTHX_ PerlIO_funcs * self,PerlIO_list_t * layers,IV n,const char * mode,int fd,int imode,int perm,PerlIO * f,int narg,SV ** args)2642 PerlIOUnix_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
2643                 IV n, const char *mode, int fd, int imode,
2644                 int perm, PerlIO *f, int narg, SV **args)
2645 {
2646     bool known_cloexec = 0;
2647     if (PerlIOValid(f)) {
2648         if (PerlIOBase(f)->tab && PerlIOBase(f)->flags & PERLIO_F_OPEN)
2649             (*PerlIOBase(f)->tab->Close)(aTHX_ f);
2650     }
2651     if (narg > 0) {
2652         if (*mode == IoTYPE_NUMERIC)
2653             mode++;
2654         else {
2655             imode = PerlIOUnix_oflags(mode);
2656 #ifdef VMS
2657             perm = 0777; /* preserve RMS defaults, ACL inheritance, etc. */
2658 #else
2659             perm = 0666;
2660 #endif
2661         }
2662         if (imode != -1) {
2663             STRLEN len;
2664             const char *path = SvPV_const(*args, len);
2665             if (!IS_SAFE_PATHNAME(path, len, "open"))
2666                 return NULL;
2667             fd = PerlLIO_open3_cloexec(path, imode, perm);
2668             known_cloexec = 1;
2669         }
2670     }
2671     if (fd >= 0) {
2672         if (known_cloexec)
2673             setfd_inhexec_for_sysfd(fd);
2674         else
2675             setfd_cloexec_or_inhexec_by_sysfdness(fd);
2676         if (*mode == IoTYPE_IMPLICIT)
2677             mode++;
2678         if (!f) {
2679             f = PerlIO_allocate(aTHX);
2680         }
2681         if (!PerlIOValid(f)) {
2682             if (!(f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
2683                 PerlLIO_close(fd);
2684                 return NULL;
2685             }
2686         }
2687         PerlIOUnix_setfd(aTHX_ f, fd, imode);
2688         PerlIOBase(f)->flags |= PERLIO_F_OPEN;
2689         if (*mode == IoTYPE_APPEND)
2690             PerlIOUnix_seek(aTHX_ f, 0, SEEK_END);
2691         return f;
2692     }
2693     else {
2694         if (f) {
2695             NOOP;
2696             /*
2697              * FIXME: pop layers ???
2698              */
2699         }
2700         return NULL;
2701     }
2702 }
2703 
2704 PerlIO *
PerlIOUnix_dup(pTHX_ PerlIO * f,PerlIO * o,CLONE_PARAMS * param,int flags)2705 PerlIOUnix_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
2706 {
2707     const PerlIOUnix * const os = PerlIOSelf(o, PerlIOUnix);
2708     int fd = os->fd;
2709     if (flags & PERLIO_DUP_FD) {
2710         fd = PerlLIO_dup_cloexec(fd);
2711         if (fd >= 0)
2712             setfd_inhexec_for_sysfd(fd);
2713     }
2714     if (fd >= 0) {
2715         f = PerlIOBase_dup(aTHX_ f, o, param, flags);
2716         if (f) {
2717             /* If all went well overwrite fd in dup'ed lay with the dup()'ed fd */
2718             PerlIOUnix_setfd(aTHX_ f, fd, os->oflags);
2719             return f;
2720         }
2721         PerlLIO_close(fd);
2722     }
2723     return NULL;
2724 }
2725 
2726 
2727 SSize_t
PerlIOUnix_read(pTHX_ PerlIO * f,void * vbuf,Size_t count)2728 PerlIOUnix_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
2729 {
2730     int fd;
2731     if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
2732         return -1;
2733     fd = PerlIOSelf(f, PerlIOUnix)->fd;
2734     if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD) ||
2735          PerlIOBase(f)->flags & (PERLIO_F_EOF|PERLIO_F_ERROR)) {
2736         return 0;
2737     }
2738     while (1) {
2739         const SSize_t len = PerlLIO_read(fd, vbuf, count);
2740         if (len >= 0 || errno != EINTR) {
2741             if (len < 0) {
2742                 if (errno != EAGAIN) {
2743                     PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2744                     PerlIO_save_errno(f);
2745                 }
2746             }
2747             else if (len == 0 && count != 0) {
2748                 PerlIOBase(f)->flags |= PERLIO_F_EOF;
2749                 SETERRNO(0,0);
2750             }
2751             return len;
2752         }
2753         /* EINTR */
2754         if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
2755             return -1;
2756     }
2757     NOT_REACHED; /*NOTREACHED*/
2758 }
2759 
2760 SSize_t
PerlIOUnix_write(pTHX_ PerlIO * f,const void * vbuf,Size_t count)2761 PerlIOUnix_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
2762 {
2763     int fd;
2764     if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
2765         return -1;
2766     fd = PerlIOSelf(f, PerlIOUnix)->fd;
2767     while (1) {
2768         const SSize_t len = PerlLIO_write(fd, vbuf, count);
2769         if (len >= 0 || errno != EINTR) {
2770             if (len < 0) {
2771                 if (errno != EAGAIN) {
2772                     PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2773                     PerlIO_save_errno(f);
2774                 }
2775             }
2776             return len;
2777         }
2778         /* EINTR */
2779         if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
2780             return -1;
2781     }
2782     NOT_REACHED; /*NOTREACHED*/
2783 }
2784 
2785 Off_t
PerlIOUnix_tell(pTHX_ PerlIO * f)2786 PerlIOUnix_tell(pTHX_ PerlIO *f)
2787 {
2788     PERL_UNUSED_CONTEXT;
2789 
2790     return PerlLIO_lseek(PerlIOSelf(f, PerlIOUnix)->fd, 0, SEEK_CUR);
2791 }
2792 
2793 
2794 IV
PerlIOUnix_close(pTHX_ PerlIO * f)2795 PerlIOUnix_close(pTHX_ PerlIO *f)
2796 {
2797     const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2798     int code = 0;
2799     if (PerlIOBase(f)->flags & PERLIO_F_OPEN) {
2800         code = PerlIOBase_close(aTHX_ f);
2801         if (PerlIOUnix_refcnt_dec(fd) > 0) {
2802             PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2803             return 0;
2804         }
2805     }
2806     else {
2807         SETERRNO(EBADF,SS_IVCHAN);
2808         return -1;
2809     }
2810     while (PerlLIO_close(fd) != 0) {
2811         if (errno != EINTR) {
2812             code = -1;
2813             break;
2814         }
2815         /* EINTR */
2816         if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
2817             return -1;
2818     }
2819     if (code == 0) {
2820         PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2821     }
2822     return code;
2823 }
2824 
2825 PERLIO_FUNCS_DECL(PerlIO_unix) = {
2826     sizeof(PerlIO_funcs),
2827     "unix",
2828     sizeof(PerlIOUnix),
2829     PERLIO_K_RAW,
2830     PerlIOUnix_pushed,
2831     PerlIOBase_popped,
2832     PerlIOUnix_open,
2833     PerlIOBase_binmode,         /* binmode */
2834     NULL,
2835     PerlIOUnix_fileno,
2836     PerlIOUnix_dup,
2837     PerlIOUnix_read,
2838     PerlIOBase_unread,
2839     PerlIOUnix_write,
2840     PerlIOUnix_seek,
2841     PerlIOUnix_tell,
2842     PerlIOUnix_close,
2843     PerlIOBase_noop_ok,         /* flush */
2844     PerlIOBase_noop_fail,       /* fill */
2845     PerlIOBase_eof,
2846     PerlIOBase_error,
2847     PerlIOBase_clearerr,
2848     PerlIOBase_setlinebuf,
2849     NULL,                       /* get_base */
2850     NULL,                       /* get_bufsiz */
2851     NULL,                       /* get_ptr */
2852     NULL,                       /* get_cnt */
2853     NULL,                       /* set_ptrcnt */
2854 };
2855 
2856 /*--------------------------------------------------------------------------------------*/
2857 /*
2858  * stdio as a layer
2859  */
2860 
2861 #if defined(VMS) && !defined(STDIO_BUFFER_WRITABLE)
2862 /* perl5.8 - This ensures the last minute VMS ungetc fix is not
2863    broken by the last second glibc 2.3 fix
2864  */
2865 #  define STDIO_BUFFER_WRITABLE
2866 #endif
2867 
2868 
2869 typedef struct {
2870     struct _PerlIO base;
2871     FILE *stdio;                /* The stream */
2872 } PerlIOStdio;
2873 
2874 IV
PerlIOStdio_fileno(pTHX_ PerlIO * f)2875 PerlIOStdio_fileno(pTHX_ PerlIO *f)
2876 {
2877     PERL_UNUSED_CONTEXT;
2878 
2879     if (PerlIOValid(f)) {
2880         FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
2881         if (s)
2882             return PerlSIO_fileno(s);
2883     }
2884     errno = EBADF;
2885     return -1;
2886 }
2887 
2888 char *
PerlIOStdio_mode(const char * mode,char * tmode)2889 PerlIOStdio_mode(const char *mode, char *tmode)
2890 {
2891     char * const ret = tmode;
2892     if (mode) {
2893         while (*mode) {
2894             *tmode++ = *mode++;
2895         }
2896     }
2897 #if defined(PERLIO_USING_CRLF) || defined(__CYGWIN__)
2898     *tmode++ = 'b';
2899 #endif
2900     *tmode = '\0';
2901     return ret;
2902 }
2903 
2904 IV
PerlIOStdio_pushed(pTHX_ PerlIO * f,const char * mode,SV * arg,PerlIO_funcs * tab)2905 PerlIOStdio_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2906 {
2907     PerlIO *n;
2908     if (PerlIOValid(f) && PerlIOValid(n = PerlIONext(f))) {
2909         PerlIO_funcs * const toptab = PerlIOBase(n)->tab;
2910         if (toptab == tab) {
2911             /* Top is already stdio - pop self (duplicate) and use original */
2912             PerlIO_pop(aTHX_ f);
2913             return 0;
2914         } else {
2915             const int fd = PerlIO_fileno(n);
2916             char tmode[8];
2917             FILE *stdio;
2918             if (fd >= 0 && (stdio  = PerlSIO_fdopen(fd,
2919                             mode = PerlIOStdio_mode(mode, tmode)))) {
2920                 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
2921                 /* We never call down so do any pending stuff now */
2922                 PerlIO_flush(PerlIONext(f));
2923                 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
2924             }
2925             else {
2926                 return -1;
2927             }
2928         }
2929     }
2930     return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
2931 }
2932 
2933 
2934 PerlIO *
PerlIO_importFILE(FILE * stdio,const char * mode)2935 PerlIO_importFILE(FILE *stdio, const char *mode)
2936 {
2937     dTHX;
2938     PerlIO *f = NULL;
2939 #ifdef __MVS__
2940          int rc;
2941          char filename[FILENAME_MAX];
2942          fldata_t fileinfo;
2943 #endif
2944     if (stdio) {
2945         PerlIOStdio *s;
2946         int fd0 = fileno(stdio);
2947         if (fd0 < 0) {
2948 #ifdef __MVS__
2949                           rc = fldata(stdio,filename,&fileinfo);
2950                           if(rc != 0){
2951                                   return NULL;
2952                           }
2953                           if(fileinfo.__dsorgHFS){
2954             return NULL;
2955         }
2956                           /*This MVS dataset , OK!*/
2957 #else
2958             return NULL;
2959 #endif
2960         }
2961         if (!mode || !*mode) {
2962             /* We need to probe to see how we can open the stream
2963                so start with read/write and then try write and read
2964                we dup() so that we can fclose without loosing the fd.
2965 
2966                Note that the errno value set by a failing fdopen
2967                varies between stdio implementations.
2968              */
2969             const int fd = PerlLIO_dup_cloexec(fd0);
2970             FILE *f2;
2971             if (fd < 0) {
2972                 return f;
2973             }
2974             f2 = PerlSIO_fdopen(fd, (mode = "r+"));
2975             if (!f2) {
2976                 f2 = PerlSIO_fdopen(fd, (mode = "w"));
2977             }
2978             if (!f2) {
2979                 f2 = PerlSIO_fdopen(fd, (mode = "r"));
2980             }
2981             if (!f2) {
2982                 /* Don't seem to be able to open */
2983                 PerlLIO_close(fd);
2984                 return f;
2985             }
2986             fclose(f2);
2987         }
2988         if ((f = PerlIO_push(aTHX_(PerlIO_allocate(aTHX)), PERLIO_FUNCS_CAST(&PerlIO_stdio), mode, NULL))) {
2989             s = PerlIOSelf(f, PerlIOStdio);
2990             s->stdio = stdio;
2991             fd0 = fileno(stdio);
2992             if(fd0 != -1){
2993                 PerlIOUnix_refcnt_inc(fd0);
2994                 setfd_cloexec_or_inhexec_by_sysfdness(fd0);
2995             }
2996 #ifdef __MVS__
2997                 else{
2998                         rc = fldata(stdio,filename,&fileinfo);
2999                         if(rc != 0){
3000                                 PerlIOUnix_refcnt_inc(fd0);
3001                         }
3002                         if(fileinfo.__dsorgHFS){
3003                                 PerlIOUnix_refcnt_inc(fd0);
3004                         }
3005                           /*This MVS dataset , OK!*/
3006                 }
3007 #endif
3008         }
3009     }
3010     return f;
3011 }
3012 
3013 PerlIO *
PerlIOStdio_open(pTHX_ PerlIO_funcs * self,PerlIO_list_t * layers,IV n,const char * mode,int fd,int imode,int perm,PerlIO * f,int narg,SV ** args)3014 PerlIOStdio_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
3015                  IV n, const char *mode, int fd, int imode,
3016                  int perm, PerlIO *f, int narg, SV **args)
3017 {
3018     char tmode[8];
3019     if (PerlIOValid(f)) {
3020         STRLEN len;
3021         const char * const path = SvPV_const(*args, len);
3022         PerlIOStdio * const s = PerlIOSelf(f, PerlIOStdio);
3023         FILE *stdio;
3024         if (!IS_SAFE_PATHNAME(path, len, "open"))
3025             return NULL;
3026         PerlIOUnix_refcnt_dec(fileno(s->stdio));
3027         stdio = PerlSIO_freopen(path, PerlIOStdio_mode(mode, tmode),
3028                                 s->stdio);
3029         if (!s->stdio)
3030             return NULL;
3031         s->stdio = stdio;
3032         fd = fileno(stdio);
3033         PerlIOUnix_refcnt_inc(fd);
3034         setfd_cloexec_or_inhexec_by_sysfdness(fd);
3035         return f;
3036     }
3037     else {
3038         if (narg > 0) {
3039             STRLEN len;
3040             const char * const path = SvPV_const(*args, len);
3041             if (!IS_SAFE_PATHNAME(path, len, "open"))
3042                 return NULL;
3043             if (*mode == IoTYPE_NUMERIC) {
3044                 mode++;
3045                 fd = PerlLIO_open3_cloexec(path, imode, perm);
3046             }
3047             else {
3048                 FILE *stdio;
3049                 bool appended = FALSE;
3050 #ifdef __CYGWIN__
3051                 /* Cygwin wants its 'b' early. */
3052                 appended = TRUE;
3053                 mode = PerlIOStdio_mode(mode, tmode);
3054 #endif
3055                 stdio = PerlSIO_fopen(path, mode);
3056                 if (stdio) {
3057                     if (!f) {
3058                         f = PerlIO_allocate(aTHX);
3059                     }
3060                     if (!appended)
3061                         mode = PerlIOStdio_mode(mode, tmode);
3062                     f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg);
3063                     if (f) {
3064                         PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3065                         fd = fileno(stdio);
3066                         PerlIOUnix_refcnt_inc(fd);
3067                         setfd_cloexec_or_inhexec_by_sysfdness(fd);
3068                     } else {
3069                         PerlSIO_fclose(stdio);
3070                     }
3071                     return f;
3072                 }
3073                 else {
3074                     return NULL;
3075                 }
3076             }
3077         }
3078         if (fd >= 0) {
3079             FILE *stdio = NULL;
3080             int init = 0;
3081             if (*mode == IoTYPE_IMPLICIT) {
3082                 init = 1;
3083                 mode++;
3084             }
3085             if (init) {
3086                 switch (fd) {
3087                 case 0:
3088                     stdio = PerlSIO_stdin;
3089                     break;
3090                 case 1:
3091                     stdio = PerlSIO_stdout;
3092                     break;
3093                 case 2:
3094                     stdio = PerlSIO_stderr;
3095                     break;
3096                 }
3097             }
3098             else {
3099                 stdio = PerlSIO_fdopen(fd, mode =
3100                                        PerlIOStdio_mode(mode, tmode));
3101             }
3102             if (stdio) {
3103                 if (!f) {
3104                     f = PerlIO_allocate(aTHX);
3105                 }
3106                 if ((f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
3107                     PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3108                     fd = fileno(stdio);
3109                     PerlIOUnix_refcnt_inc(fd);
3110                     setfd_cloexec_or_inhexec_by_sysfdness(fd);
3111                 }
3112                 return f;
3113             }
3114             PerlLIO_close(fd);
3115         }
3116     }
3117     return NULL;
3118 }
3119 
3120 PerlIO *
PerlIOStdio_dup(pTHX_ PerlIO * f,PerlIO * o,CLONE_PARAMS * param,int flags)3121 PerlIOStdio_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
3122 {
3123     /* This assumes no layers underneath - which is what
3124        happens, but is not how I remember it. NI-S 2001/10/16
3125      */
3126     if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) {
3127         FILE *stdio = PerlIOSelf(o, PerlIOStdio)->stdio;
3128         const int fd = fileno(stdio);
3129         char mode[8];
3130         if (flags & PERLIO_DUP_FD) {
3131             const int dfd = PerlLIO_dup_cloexec(fileno(stdio));
3132             if (dfd >= 0) {
3133                 stdio = PerlSIO_fdopen(dfd, PerlIO_modestr(o,mode));
3134                 goto set_this;
3135             }
3136             else {
3137                 NOOP;
3138                 /* FIXME: To avoid messy error recovery if dup fails
3139                    re-use the existing stdio as though flag was not set
3140                  */
3141             }
3142         }
3143         stdio = PerlSIO_fdopen(fd, PerlIO_modestr(o,mode));
3144     set_this:
3145         PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3146         if(stdio) {
3147             int fd = fileno(stdio);
3148             PerlIOUnix_refcnt_inc(fd);
3149             setfd_cloexec_or_inhexec_by_sysfdness(fd);
3150         }
3151     }
3152     return f;
3153 }
3154 
3155 static int
PerlIOStdio_invalidate_fileno(pTHX_ FILE * f)3156 PerlIOStdio_invalidate_fileno(pTHX_ FILE *f)
3157 {
3158     PERL_UNUSED_CONTEXT;
3159 
3160     /* XXX this could use PerlIO_canset_fileno() and
3161      * PerlIO_set_fileno() support from Configure
3162      */
3163 #if defined(HAS_FDCLOSE)
3164     return fdclose(f, NULL) == 0 ? 1 : 0;
3165 #elif defined(__UCLIBC__)
3166     /* uClibc must come before glibc because it defines __GLIBC__ as well. */
3167     f->__filedes = -1;
3168     return 1;
3169 #elif defined(__GLIBC__)
3170     /* There may be a better way for GLIBC:
3171         - libio.h defines a flag to not close() on cleanup
3172      */
3173     f->_fileno = -1;
3174     return 1;
3175 #elif defined(__sun)
3176     PERL_UNUSED_ARG(f);
3177     return 0;
3178 #elif defined(__hpux)
3179     f->__fileH = 0xff;
3180     f->__fileL = 0xff;
3181     return 1;
3182    /* Next one ->_file seems to be a reasonable fallback, i.e. if
3183       your platform does not have special entry try this one.
3184       [For OSF only have confirmation for Tru64 (alpha)
3185       but assume other OSFs will be similar.]
3186     */
3187 #elif defined(_AIX) || defined(__osf__) || defined(__irix__)
3188     f->_file = -1;
3189     return 1;
3190 #elif defined(__FreeBSD__)
3191     /* There may be a better way on FreeBSD:
3192         - we could insert a dummy func in the _close function entry
3193         f->_close = (int (*)(void *)) dummy_close;
3194      */
3195     f->_file = -1;
3196     return 1;
3197 #elif defined(__OpenBSD__)
3198     /* There may be a better way on OpenBSD:
3199         - we could insert a dummy func in the _close function entry
3200         f->_close = (int (*)(void *)) dummy_close;
3201      */
3202     f->_file = -1;
3203     return 1;
3204 #elif defined(__EMX__)
3205     /* f->_flags &= ~_IOOPEN; */	/* Will leak stream->_buffer */
3206     f->_handle = -1;
3207     return 1;
3208 #elif defined(__CYGWIN__)
3209     /* There may be a better way on CYGWIN:
3210         - we could insert a dummy func in the _close function entry
3211         f->_close = (int (*)(void *)) dummy_close;
3212      */
3213     f->_file = -1;
3214     return 1;
3215 #elif defined(WIN32)
3216     PERLIO_FILE_file(f) = -1;
3217     return 1;
3218 #else
3219 #  if 0
3220     /* Sarathy's code did this - we fall back to a dup/dup2 hack
3221        (which isn't thread safe) instead
3222      */
3223 #    error "Don't know how to set FILE.fileno on your platform"
3224 #  endif
3225     PERL_UNUSED_ARG(f);
3226     return 0;
3227 #endif
3228 }
3229 
3230 IV
PerlIOStdio_close(pTHX_ PerlIO * f)3231 PerlIOStdio_close(pTHX_ PerlIO *f)
3232 {
3233     FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3234     if (!stdio) {
3235         errno = EBADF;
3236         return -1;
3237     }
3238     else {
3239         const int fd = fileno(stdio);
3240         int invalidate = 0;
3241         IV result = 0;
3242         int dupfd = -1;
3243         dSAVEDERRNO;
3244 #ifdef SOCKS5_VERSION_NAME
3245         /* Socks lib overrides close() but stdio isn't linked to
3246            that library (though we are) - so we must call close()
3247            on sockets on stdio's behalf.
3248          */
3249         int optval;
3250         Sock_size_t optlen = sizeof(int);
3251         if (getsockopt(fd, SOL_SOCKET, SO_TYPE, (void *) &optval, &optlen) == 0)
3252             invalidate = 1;
3253 #endif
3254         /* Test for -1, as *BSD stdio (at least) on fclose sets the FILE* such
3255            that a subsequent fileno() on it returns -1. Don't want to croak()
3256            from within PerlIOUnix_refcnt_dec() if some buggy caller code is
3257            trying to close an already closed handle which somehow it still has
3258            a reference to. (via.xs, I'm looking at you).  */
3259         if (fd != -1 && PerlIOUnix_refcnt_dec(fd) > 0) {
3260             /* File descriptor still in use */
3261             invalidate = 1;
3262         }
3263         if (invalidate) {
3264             /* For STD* handles, don't close stdio, since we shared the FILE *, too. */
3265             if (stdio == stdin) /* Some stdios are buggy fflush-ing inputs */
3266                 return 0;
3267             if (stdio == stdout || stdio == stderr)
3268                 return PerlIO_flush(f);
3269         }
3270         MUTEX_LOCK(&PL_perlio_mutex);
3271         /* Right. We need a mutex here because for a brief while we
3272            will have the situation that fd is actually closed. Hence if
3273            a second thread were to get into this block, its dup() would
3274            likely return our fd as its dupfd. (after all, it is closed)
3275            Then if we get to the dup2() first, we blat the fd back
3276            (messing up its temporary as a side effect) only for it to
3277            then close its dupfd (== our fd) in its close(dupfd) */
3278 
3279         /* There is, of course, a race condition, that any other thread
3280            trying to input/output/whatever on this fd will be stuffed
3281            for the duration of this little manoeuvrer. Perhaps we
3282            should hold an IO mutex for the duration of every IO
3283            operation if we know that invalidate doesn't work on this
3284            platform, but that would suck, and could kill performance.
3285 
3286            Except that correctness trumps speed.
3287            Advice from klortho #11912. */
3288         if (invalidate) {
3289             /* Tricky - must fclose(stdio) to free memory but not close(fd)
3290                Use Sarathy's trick from maint-5.6 to invalidate the
3291                fileno slot of the FILE *
3292             */
3293             result = PerlIO_flush(f);
3294             SAVE_ERRNO;
3295             invalidate = PerlIOStdio_invalidate_fileno(aTHX_ stdio);
3296             if (!invalidate) {
3297                 dupfd = PerlLIO_dup_cloexec(fd);
3298 #ifdef USE_ITHREADS
3299                 if (dupfd < 0) {
3300                     /* Oh cXap. This isn't going to go well. Not sure if we can
3301                        recover from here, or if closing this particular FILE *
3302                        is a good idea now.  */
3303                 }
3304 #endif
3305             }
3306         } else {
3307             SAVE_ERRNO;   /* This is here only to silence compiler warnings */
3308         }
3309         result = PerlSIO_fclose(stdio);
3310         /* We treat error from stdio as success if we invalidated
3311            errno may NOT be expected EBADF
3312          */
3313         if (invalidate && result != 0) {
3314             RESTORE_ERRNO;
3315             result = 0;
3316         }
3317 #ifdef SOCKS5_VERSION_NAME
3318         /* in SOCKS' case, let close() determine return value */
3319         result = close(fd);
3320 #endif
3321         if (dupfd >= 0) {
3322             PerlLIO_dup2_cloexec(dupfd, fd);
3323             setfd_inhexec_for_sysfd(fd);
3324             PerlLIO_close(dupfd);
3325         }
3326         MUTEX_UNLOCK(&PL_perlio_mutex);
3327         return result;
3328     }
3329 }
3330 
3331 SSize_t
PerlIOStdio_read(pTHX_ PerlIO * f,void * vbuf,Size_t count)3332 PerlIOStdio_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
3333 {
3334     FILE * s;
3335     SSize_t got = 0;
3336     if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
3337         return -1;
3338     s = PerlIOSelf(f, PerlIOStdio)->stdio;
3339     for (;;) {
3340         if (count == 1) {
3341             STDCHAR *buf = (STDCHAR *) vbuf;
3342             /*
3343              * Perl is expecting PerlIO_getc() to fill the buffer Linux's
3344              * stdio does not do that for fread()
3345              */
3346             const int ch = PerlSIO_fgetc(s);
3347             if (ch != EOF) {
3348                 *buf = ch;
3349                 got = 1;
3350             }
3351         }
3352         else
3353             got = PerlSIO_fread(vbuf, 1, count, s);
3354         if (got == 0 && PerlSIO_ferror(s))
3355             got = -1;
3356         if (got >= 0 || errno != EINTR)
3357             break;
3358         if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
3359             return -1;
3360         SETERRNO(0,0);	/* just in case */
3361     }
3362 #ifdef __sgi
3363     /* Under some circumstances IRIX stdio fgetc() and fread()
3364      * set the errno to ENOENT, which makes no sense according
3365      * to either IRIX or POSIX.  [rt.perl.org #123977] */
3366     if (errno == ENOENT) SETERRNO(0,0);
3367 #endif
3368     return got;
3369 }
3370 
3371 SSize_t
PerlIOStdio_unread(pTHX_ PerlIO * f,const void * vbuf,Size_t count)3372 PerlIOStdio_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3373 {
3374     SSize_t unread = 0;
3375     FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
3376 
3377 #ifdef STDIO_BUFFER_WRITABLE
3378     if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
3379         STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3380         STDCHAR *base = PerlIO_get_base(f);
3381         SSize_t cnt   = PerlIO_get_cnt(f);
3382         STDCHAR *ptr  = PerlIO_get_ptr(f);
3383         SSize_t avail = ptr - base;
3384         if (avail > 0) {
3385             if (avail > count) {
3386                 avail = count;
3387             }
3388             ptr -= avail;
3389             Move(buf-avail,ptr,avail,STDCHAR);
3390             count -= avail;
3391             unread += avail;
3392             PerlIO_set_ptrcnt(f,ptr,cnt+avail);
3393             if (PerlSIO_feof(s) && unread >= 0)
3394                 PerlSIO_clearerr(s);
3395         }
3396     }
3397     else
3398 #endif
3399     if (PerlIO_has_cntptr(f)) {
3400         /* We can get pointer to buffer but not its base
3401            Do ungetc() but check chars are ending up in the
3402            buffer
3403          */
3404         STDCHAR *eptr = (STDCHAR*)PerlSIO_get_ptr(s);
3405         STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3406         while (count > 0) {
3407             const int ch = (U8) *--buf;
3408             if (ungetc(ch,s) != ch) {
3409                 /* ungetc did not work */
3410                 break;
3411             }
3412             if ((STDCHAR*)PerlSIO_get_ptr(s) != --eptr || (((U8) *eptr) != ch)) {
3413                 /* Did not change pointer as expected */
3414                 if (fgetc(s) != EOF)  /* get char back again */
3415                     break;
3416             }
3417             /* It worked ! */
3418             count--;
3419             unread++;
3420         }
3421     }
3422 
3423     if (count > 0) {
3424         unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
3425     }
3426     return unread;
3427 }
3428 
3429 SSize_t
PerlIOStdio_write(pTHX_ PerlIO * f,const void * vbuf,Size_t count)3430 PerlIOStdio_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3431 {
3432     SSize_t got;
3433     if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
3434         return -1;
3435     for (;;) {
3436         got = PerlSIO_fwrite(vbuf, 1, count,
3437                               PerlIOSelf(f, PerlIOStdio)->stdio);
3438         if (got >= 0 || errno != EINTR)
3439             break;
3440         if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
3441             return -1;
3442         SETERRNO(0,0);	/* just in case */
3443     }
3444     return got;
3445 }
3446 
3447 IV
PerlIOStdio_seek(pTHX_ PerlIO * f,Off_t offset,int whence)3448 PerlIOStdio_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
3449 {
3450     FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3451     PERL_UNUSED_CONTEXT;
3452 
3453     return PerlSIO_fseek(stdio, offset, whence);
3454 }
3455 
3456 Off_t
PerlIOStdio_tell(pTHX_ PerlIO * f)3457 PerlIOStdio_tell(pTHX_ PerlIO *f)
3458 {
3459     FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3460     PERL_UNUSED_CONTEXT;
3461 
3462     return PerlSIO_ftell(stdio);
3463 }
3464 
3465 IV
PerlIOStdio_flush(pTHX_ PerlIO * f)3466 PerlIOStdio_flush(pTHX_ PerlIO *f)
3467 {
3468     FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3469     PERL_UNUSED_CONTEXT;
3470 
3471     if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
3472         return PerlSIO_fflush(stdio);
3473     }
3474     else {
3475         NOOP;
3476 #if 0
3477         /*
3478          * FIXME: This discards ungetc() and pre-read stuff which is not
3479          * right if this is just a "sync" from a layer above Suspect right
3480          * design is to do _this_ but not have layer above flush this
3481          * layer read-to-read
3482          */
3483         /*
3484          * Not writeable - sync by attempting a seek
3485          */
3486         dSAVE_ERRNO;
3487         if (PerlSIO_fseek(stdio, (Off_t) 0, SEEK_CUR) != 0)
3488             RESTORE_ERRNO;
3489 #endif
3490     }
3491     return 0;
3492 }
3493 
3494 IV
PerlIOStdio_eof(pTHX_ PerlIO * f)3495 PerlIOStdio_eof(pTHX_ PerlIO *f)
3496 {
3497     PERL_UNUSED_CONTEXT;
3498 
3499     return PerlSIO_feof(PerlIOSelf(f, PerlIOStdio)->stdio);
3500 }
3501 
3502 IV
PerlIOStdio_error(pTHX_ PerlIO * f)3503 PerlIOStdio_error(pTHX_ PerlIO *f)
3504 {
3505     PERL_UNUSED_CONTEXT;
3506 
3507     return PerlSIO_ferror(PerlIOSelf(f, PerlIOStdio)->stdio);
3508 }
3509 
3510 void
PerlIOStdio_clearerr(pTHX_ PerlIO * f)3511 PerlIOStdio_clearerr(pTHX_ PerlIO *f)
3512 {
3513     PERL_UNUSED_CONTEXT;
3514 
3515     PerlSIO_clearerr(PerlIOSelf(f, PerlIOStdio)->stdio);
3516 }
3517 
3518 void
PerlIOStdio_setlinebuf(pTHX_ PerlIO * f)3519 PerlIOStdio_setlinebuf(pTHX_ PerlIO *f)
3520 {
3521     PERL_UNUSED_CONTEXT;
3522 
3523 #ifdef HAS_SETLINEBUF
3524     PerlSIO_setlinebuf(PerlIOSelf(f, PerlIOStdio)->stdio);
3525 #else
3526     PerlSIO_setvbuf(PerlIOSelf(f, PerlIOStdio)->stdio, NULL, _IOLBF, 0);
3527 #endif
3528 }
3529 
3530 #ifdef FILE_base
3531 STDCHAR *
PerlIOStdio_get_base(pTHX_ PerlIO * f)3532 PerlIOStdio_get_base(pTHX_ PerlIO *f)
3533 {
3534     FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3535     PERL_UNUSED_CONTEXT;
3536     return (STDCHAR*)PerlSIO_get_base(stdio);
3537 }
3538 
3539 Size_t
PerlIOStdio_get_bufsiz(pTHX_ PerlIO * f)3540 PerlIOStdio_get_bufsiz(pTHX_ PerlIO *f)
3541 {
3542     FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3543     PERL_UNUSED_CONTEXT;
3544     return PerlSIO_get_bufsiz(stdio);
3545 }
3546 #endif
3547 
3548 #ifdef USE_STDIO_PTR
3549 STDCHAR *
PerlIOStdio_get_ptr(pTHX_ PerlIO * f)3550 PerlIOStdio_get_ptr(pTHX_ PerlIO *f)
3551 {
3552     FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3553     PERL_UNUSED_CONTEXT;
3554     return (STDCHAR*)PerlSIO_get_ptr(stdio);
3555 }
3556 
3557 SSize_t
PerlIOStdio_get_cnt(pTHX_ PerlIO * f)3558 PerlIOStdio_get_cnt(pTHX_ PerlIO *f)
3559 {
3560     FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3561     PERL_UNUSED_CONTEXT;
3562     return PerlSIO_get_cnt(stdio);
3563 }
3564 
3565 void
PerlIOStdio_set_ptrcnt(pTHX_ PerlIO * f,STDCHAR * ptr,SSize_t cnt)3566 PerlIOStdio_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
3567 {
3568     FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3569     PERL_UNUSED_CONTEXT;
3570     if (ptr != NULL) {
3571 #  ifdef STDIO_PTR_LVALUE
3572         /* This is a long-standing infamous mess.  The root of the
3573          * problem is that one cannot know the signedness of char, and
3574          * more precisely the signedness of FILE._ptr.  The following
3575          * things have been tried, and they have all failed (across
3576          * different compilers (remember that core needs to to build
3577          * also with c++) and compiler options:
3578          *
3579          * - casting the RHS to (void*) -- works in *some* places
3580          * - casting the LHS to (void*) -- totally unportable
3581          *
3582          * So let's try silencing the warning at least for gcc. */
3583         GCC_DIAG_IGNORE_STMT(-Wpointer-sign);
3584         PerlSIO_set_ptr(stdio, ptr); /* LHS STDCHAR* cast non-portable */
3585         GCC_DIAG_RESTORE_STMT;
3586 #    ifdef STDIO_PTR_LVAL_SETS_CNT
3587         assert(PerlSIO_get_cnt(stdio) == (cnt));
3588 #    endif
3589 #    if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
3590         /*
3591          * Setting ptr _does_ change cnt - we are done
3592          */
3593         return;
3594 #    endif
3595 #  else                           /* STDIO_PTR_LVALUE */
3596         PerlProc_abort();
3597 #  endif                          /* STDIO_PTR_LVALUE */
3598     }
3599     /*
3600      * Now (or only) set cnt
3601      */
3602 #  ifdef STDIO_CNT_LVALUE
3603     PerlSIO_set_cnt(stdio, cnt);
3604 #  elif (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
3605     PerlSIO_set_ptr(stdio,
3606                     PerlSIO_get_ptr(stdio) + (PerlSIO_get_cnt(stdio) -
3607                                               cnt));
3608 #  else                           /* STDIO_PTR_LVAL_SETS_CNT */
3609     PerlProc_abort();
3610 #  endif                          /* STDIO_CNT_LVALUE */
3611 }
3612 
3613 
3614 #endif
3615 
3616 IV
PerlIOStdio_fill(pTHX_ PerlIO * f)3617 PerlIOStdio_fill(pTHX_ PerlIO *f)
3618 {
3619     FILE * stdio;
3620     int c;
3621     PERL_UNUSED_CONTEXT;
3622     if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
3623         return -1;
3624     stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3625 
3626     /*
3627      * fflush()ing read-only streams can cause trouble on some stdio-s
3628      */
3629     if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE)) {
3630         if (PerlSIO_fflush(stdio) != 0)
3631             return EOF;
3632     }
3633     for (;;) {
3634         c = PerlSIO_fgetc(stdio);
3635         if (c != EOF)
3636             break;
3637         if (! PerlSIO_ferror(stdio) || errno != EINTR)
3638             return EOF;
3639         if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
3640             return -1;
3641         SETERRNO(0,0);
3642     }
3643 
3644 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
3645 
3646 #  ifdef STDIO_BUFFER_WRITABLE
3647     if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
3648         /* Fake ungetc() to the real buffer in case system's ungetc
3649            goes elsewhere
3650          */
3651         STDCHAR *base = (STDCHAR*)PerlSIO_get_base(stdio);
3652         SSize_t cnt   = PerlSIO_get_cnt(stdio);
3653         STDCHAR *ptr  = (STDCHAR*)PerlSIO_get_ptr(stdio);
3654         if (ptr == base+1) {
3655             *--ptr = (STDCHAR) c;
3656             PerlIOStdio_set_ptrcnt(aTHX_ f,ptr,cnt+1);
3657             if (PerlSIO_feof(stdio))
3658                 PerlSIO_clearerr(stdio);
3659             return 0;
3660         }
3661     }
3662     else
3663 #  endif
3664     if (PerlIO_has_cntptr(f)) {
3665         STDCHAR ch = c;
3666         if (PerlIOStdio_unread(aTHX_ f,&ch,1) == 1) {
3667             return 0;
3668         }
3669     }
3670 #endif
3671 
3672     /* If buffer snoop scheme above fails fall back to
3673        using ungetc().
3674      */
3675     if (PerlSIO_ungetc(c, stdio) != c)
3676         return EOF;
3677 
3678     return 0;
3679 }
3680 
3681 
3682 
3683 PERLIO_FUNCS_DECL(PerlIO_stdio) = {
3684     sizeof(PerlIO_funcs),
3685     "stdio",
3686     sizeof(PerlIOStdio),
3687     PERLIO_K_BUFFERED|PERLIO_K_RAW,
3688     PerlIOStdio_pushed,
3689     PerlIOBase_popped,
3690     PerlIOStdio_open,
3691     PerlIOBase_binmode,         /* binmode */
3692     NULL,
3693     PerlIOStdio_fileno,
3694     PerlIOStdio_dup,
3695     PerlIOStdio_read,
3696     PerlIOStdio_unread,
3697     PerlIOStdio_write,
3698     PerlIOStdio_seek,
3699     PerlIOStdio_tell,
3700     PerlIOStdio_close,
3701     PerlIOStdio_flush,
3702     PerlIOStdio_fill,
3703     PerlIOStdio_eof,
3704     PerlIOStdio_error,
3705     PerlIOStdio_clearerr,
3706     PerlIOStdio_setlinebuf,
3707 #ifdef FILE_base
3708     PerlIOStdio_get_base,
3709     PerlIOStdio_get_bufsiz,
3710 #else
3711     NULL,
3712     NULL,
3713 #endif
3714 #ifdef USE_STDIO_PTR
3715     PerlIOStdio_get_ptr,
3716     PerlIOStdio_get_cnt,
3717 #   if defined(HAS_FAST_STDIO) && defined(USE_FAST_STDIO)
3718     PerlIOStdio_set_ptrcnt,
3719 #   else
3720     NULL,
3721 #   endif /* HAS_FAST_STDIO && USE_FAST_STDIO */
3722 #else
3723     NULL,
3724     NULL,
3725     NULL,
3726 #endif /* USE_STDIO_PTR */
3727 };
3728 
3729 /* Note that calls to PerlIO_exportFILE() are reversed using
3730  * PerlIO_releaseFILE(), not importFILE. */
3731 FILE *
PerlIO_exportFILE(PerlIO * f,const char * mode)3732 PerlIO_exportFILE(PerlIO * f, const char *mode)
3733 {
3734     dTHX;
3735     FILE *stdio = NULL;
3736     if (PerlIOValid(f)) {
3737         char buf[8];
3738         int fd = PerlIO_fileno(f);
3739         if (fd < 0) {
3740             return NULL;
3741         }
3742         PerlIO_flush(f);
3743         if (!mode || !*mode) {
3744             mode = PerlIO_modestr(f, buf);
3745         }
3746         stdio = PerlSIO_fdopen(PerlIO_fileno(f), mode);
3747         if (stdio) {
3748             PerlIOl *l = *f;
3749             PerlIO *f2;
3750             /* De-link any lower layers so new :stdio sticks */
3751             *f = NULL;
3752             if ((f2 = PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_stdio), buf, NULL))) {
3753                 PerlIOStdio *s = PerlIOSelf((f = f2), PerlIOStdio);
3754                 s->stdio = stdio;
3755                 PerlIOUnix_refcnt_inc(fileno(stdio));
3756                 /* Link previous lower layers under new one */
3757                 *PerlIONext(f) = l;
3758             }
3759             else {
3760                 /* restore layers list */
3761                 *f = l;
3762             }
3763         }
3764     }
3765     return stdio;
3766 }
3767 
3768 
3769 FILE *
PerlIO_findFILE(PerlIO * f)3770 PerlIO_findFILE(PerlIO *f)
3771 {
3772     PerlIOl *l = *f;
3773     FILE *stdio;
3774     while (l) {
3775         if (l->tab == &PerlIO_stdio) {
3776             PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
3777             return s->stdio;
3778         }
3779         l = *PerlIONext(&l);
3780     }
3781     /* Uses fallback "mode" via PerlIO_modestr() in PerlIO_exportFILE */
3782     /* However, we're not really exporting a FILE * to someone else (who
3783        becomes responsible for closing it, or calling PerlIO_releaseFILE())
3784        So we need to undo its reference count increase on the underlying file
3785        descriptor. We have to do this, because if the loop above returns you
3786        the FILE *, then *it* didn't increase any reference count. So there's
3787        only one way to be consistent. */
3788     stdio = PerlIO_exportFILE(f, NULL);
3789     if (stdio) {
3790         const int fd = fileno(stdio);
3791         if (fd >= 0)
3792             PerlIOUnix_refcnt_dec(fd);
3793     }
3794     return stdio;
3795 }
3796 
3797 /* Use this to reverse PerlIO_exportFILE calls. */
3798 void
PerlIO_releaseFILE(PerlIO * p,FILE * f)3799 PerlIO_releaseFILE(PerlIO *p, FILE *f)
3800 {
3801     PerlIOl *l;
3802     while ((l = *p)) {
3803         if (l->tab == &PerlIO_stdio) {
3804             PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
3805             if (s->stdio == f) { /* not in a loop */
3806                 const int fd = fileno(f);
3807                 if (fd >= 0)
3808                     PerlIOUnix_refcnt_dec(fd);
3809                 {
3810                     dTHX;
3811                     PerlIO_pop(aTHX_ p);
3812                 }
3813                 return;
3814             }
3815         }
3816         p = PerlIONext(p);
3817     }
3818     return;
3819 }
3820 
3821 /*--------------------------------------------------------------------------------------*/
3822 /*
3823  * perlio buffer layer
3824  */
3825 
3826 IV
PerlIOBuf_pushed(pTHX_ PerlIO * f,const char * mode,SV * arg,PerlIO_funcs * tab)3827 PerlIOBuf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
3828 {
3829     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3830     const int fd = PerlIO_fileno(f);
3831     if (fd >= 0 && PerlLIO_isatty(fd)) {
3832         PerlIOBase(f)->flags |= PERLIO_F_LINEBUF | PERLIO_F_TTY;
3833     }
3834     if (*PerlIONext(f)) {
3835         const Off_t posn = PerlIO_tell(PerlIONext(f));
3836         if (posn != (Off_t) - 1) {
3837             b->posn = posn;
3838         }
3839     }
3840     return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
3841 }
3842 
3843 PerlIO *
PerlIOBuf_open(pTHX_ PerlIO_funcs * self,PerlIO_list_t * layers,IV n,const char * mode,int fd,int imode,int perm,PerlIO * f,int narg,SV ** args)3844 PerlIOBuf_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
3845                IV n, const char *mode, int fd, int imode, int perm,
3846                PerlIO *f, int narg, SV **args)
3847 {
3848     if (PerlIOValid(f)) {
3849         PerlIO *next = PerlIONext(f);
3850         PerlIO_funcs *tab =
3851              PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIOBase(next)->tab);
3852         if (tab && tab->Open)
3853              next =
3854                   (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3855                                next, narg, args);
3856         if (!next || (*PerlIOBase(f)->tab->Pushed) (aTHX_ f, mode, PerlIOArg, self) != 0) {
3857             return NULL;
3858         }
3859     }
3860     else {
3861         PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIO_default_btm());
3862         int init = 0;
3863         if (*mode == IoTYPE_IMPLICIT) {
3864             init = 1;
3865             /*
3866              * mode++;
3867              */
3868         }
3869         if (tab && tab->Open)
3870              f = (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3871                               f, narg, args);
3872         else
3873              SETERRNO(EINVAL, LIB_INVARG);
3874         if (f) {
3875             if (PerlIO_push(aTHX_ f, self, mode, PerlIOArg) == 0) {
3876                 /*
3877                  * if push fails during open, open fails. close will pop us.
3878                  */
3879                 PerlIO_close (f);
3880                 return NULL;
3881             } else {
3882                 fd = PerlIO_fileno(f);
3883                 if (init && fd == 2) {
3884                     /*
3885                      * Initial stderr is unbuffered
3886                      */
3887                     PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
3888                 }
3889 #ifdef PERLIO_USING_CRLF
3890 #  ifdef PERLIO_IS_BINMODE_FD
3891                 if (PERLIO_IS_BINMODE_FD(fd))
3892                     PerlIO_binmode(aTHX_ f,  '<'/*not used*/, O_BINARY, NULL);
3893                 else
3894 #  endif
3895                 /*
3896                  * do something about failing setmode()? --jhi
3897                  */
3898                 PerlLIO_setmode(fd, O_BINARY);
3899 #endif
3900 #ifdef VMS
3901                 /* Enable line buffering with record-oriented regular files
3902                  * so we don't introduce an extraneous record boundary when
3903                  * the buffer fills up.
3904                  */
3905                 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
3906                     Stat_t st;
3907                     if (PerlLIO_fstat(fd, &st) == 0
3908                         && S_ISREG(st.st_mode)
3909                         && (st.st_fab_rfm == FAB$C_VAR
3910                             || st.st_fab_rfm == FAB$C_VFC)) {
3911                         PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
3912                     }
3913                 }
3914 #endif
3915             }
3916         }
3917     }
3918     return f;
3919 }
3920 
3921 /*
3922  * This "flush" is akin to sfio's sync in that it handles files in either
3923  * read or write state.  For write state, we put the postponed data through
3924  * the next layers.  For read state, we seek() the next layers to the
3925  * offset given by current position in the buffer, and discard the buffer
3926  * state (XXXX supposed to be for seek()able buffers only, but now it is done
3927  * in any case?).  Then the pass the stick further in chain.
3928  */
3929 IV
PerlIOBuf_flush(pTHX_ PerlIO * f)3930 PerlIOBuf_flush(pTHX_ PerlIO *f)
3931 {
3932     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3933     int code = 0;
3934     PerlIO *n = PerlIONext(f);
3935     if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) {
3936         /*
3937          * write() the buffer
3938          */
3939         const STDCHAR *buf = b->buf;
3940         const STDCHAR *p = buf;
3941         while (p < b->ptr) {
3942             SSize_t count = PerlIO_write(n, p, b->ptr - p);
3943             if (count > 0) {
3944                 p += count;
3945             }
3946             else if (count < 0 || PerlIO_error(n)) {
3947                 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
3948                 PerlIO_save_errno(f);
3949                 code = -1;
3950                 break;
3951             }
3952         }
3953         b->posn += (p - buf);
3954     }
3955     else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3956         STDCHAR *buf = PerlIO_get_base(f);
3957         /*
3958          * Note position change
3959          */
3960         b->posn += (b->ptr - buf);
3961         if (b->ptr < b->end) {
3962             /* We did not consume all of it - try and seek downstream to
3963                our logical position
3964              */
3965             if (PerlIOValid(n) && PerlIO_seek(n, b->posn, SEEK_SET) == 0) {
3966                 /* Reload n as some layers may pop themselves on seek */
3967                 b->posn = PerlIO_tell(n = PerlIONext(f));
3968             }
3969             else {
3970                 /* Seek failed (e.g. pipe or tty). Do NOT clear buffer or pre-read
3971                    data is lost for good - so return saying "ok" having undone
3972                    the position adjust
3973                  */
3974                 b->posn -= (b->ptr - buf);
3975                 return code;
3976             }
3977         }
3978     }
3979     b->ptr = b->end = b->buf;
3980     PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
3981     /* We check for Valid because of dubious decision to make PerlIO_flush(NULL) flush all */
3982     if (PerlIOValid(n) && PerlIO_flush(n) != 0)
3983         code = -1;
3984     return code;
3985 }
3986 
3987 /* This discards the content of the buffer after b->ptr, and rereads
3988  * the buffer from the position off in the layer downstream; here off
3989  * is at offset corresponding to b->ptr - b->buf.
3990  */
3991 IV
PerlIOBuf_fill(pTHX_ PerlIO * f)3992 PerlIOBuf_fill(pTHX_ PerlIO *f)
3993 {
3994     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3995     PerlIO *n = PerlIONext(f);
3996     SSize_t avail;
3997     /*
3998      * Down-stream flush is defined not to loose read data so is harmless.
3999      * we would not normally be fill'ing if there was data left in anycase.
4000      */
4001     if (PerlIO_flush(f) != 0)	/* XXXX Check that its seek() succeeded?! */
4002         return -1;
4003     if (PerlIOBase(f)->flags & PERLIO_F_TTY)
4004         PerlIOBase_flush_linebuf(aTHX);
4005 
4006     if (!b->buf)
4007         PerlIO_get_base(f);     /* allocate via vtable */
4008 
4009     assert(b->buf); /* The b->buf does get allocated via the vtable system. */
4010 
4011     b->ptr = b->end = b->buf;
4012 
4013     if (!PerlIOValid(n)) {
4014         PerlIOBase(f)->flags |= PERLIO_F_EOF;
4015         return -1;
4016     }
4017 
4018     if (PerlIO_fast_gets(n)) {
4019         /*
4020          * Layer below is also buffered. We do _NOT_ want to call its
4021          * ->Read() because that will loop till it gets what we asked for
4022          * which may hang on a pipe etc. Instead take anything it has to
4023          * hand, or ask it to fill _once_.
4024          */
4025         avail = PerlIO_get_cnt(n);
4026         if (avail <= 0) {
4027             avail = PerlIO_fill(n);
4028             if (avail == 0)
4029                 avail = PerlIO_get_cnt(n);
4030             else {
4031                 if (!PerlIO_error(n) && PerlIO_eof(n))
4032                     avail = 0;
4033             }
4034         }
4035         if (avail > 0) {
4036             STDCHAR *ptr = PerlIO_get_ptr(n);
4037             const SSize_t cnt = avail;
4038             if (avail > (SSize_t)b->bufsiz)
4039                 avail = b->bufsiz;
4040             Copy(ptr, b->buf, avail, STDCHAR);
4041             PerlIO_set_ptrcnt(n, ptr + avail, cnt - avail);
4042         }
4043     }
4044     else {
4045         avail = PerlIO_read(n, b->ptr, b->bufsiz);
4046     }
4047     if (avail <= 0) {
4048         if (avail == 0)
4049             PerlIOBase(f)->flags |= PERLIO_F_EOF;
4050         else
4051         {
4052             PerlIOBase(f)->flags |= PERLIO_F_ERROR;
4053             PerlIO_save_errno(f);
4054         }
4055         return -1;
4056     }
4057     b->end = b->buf + avail;
4058     PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4059     return 0;
4060 }
4061 
4062 SSize_t
PerlIOBuf_read(pTHX_ PerlIO * f,void * vbuf,Size_t count)4063 PerlIOBuf_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
4064 {
4065     if (PerlIOValid(f)) {
4066         const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4067         if (!b->ptr)
4068             PerlIO_get_base(f);
4069         return PerlIOBase_read(aTHX_ f, vbuf, count);
4070     }
4071     return 0;
4072 }
4073 
4074 SSize_t
PerlIOBuf_unread(pTHX_ PerlIO * f,const void * vbuf,Size_t count)4075 PerlIOBuf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4076 {
4077     const STDCHAR *buf = (const STDCHAR *) vbuf + count;
4078     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4079     SSize_t unread = 0;
4080     SSize_t avail;
4081     if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
4082         PerlIO_flush(f);
4083     if (!b->buf)
4084         PerlIO_get_base(f);
4085     if (b->buf) {
4086         if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4087             /*
4088              * Buffer is already a read buffer, we can overwrite any chars
4089              * which have been read back to buffer start
4090              */
4091             avail = (b->ptr - b->buf);
4092         }
4093         else {
4094             /*
4095              * Buffer is idle, set it up so whole buffer is available for
4096              * unread
4097              */
4098             avail = b->bufsiz;
4099             b->end = b->buf + avail;
4100             b->ptr = b->end;
4101             PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4102             /*
4103              * Buffer extends _back_ from where we are now
4104              */
4105             b->posn -= b->bufsiz;
4106         }
4107         if ((SSize_t) count >= 0 && avail > (SSize_t) count) {
4108             /*
4109              * If we have space for more than count, just move count
4110              */
4111             avail = count;
4112         }
4113         if (avail > 0) {
4114             b->ptr -= avail;
4115             buf -= avail;
4116             /*
4117              * In simple stdio-like ungetc() case chars will be already
4118              * there
4119              */
4120             if (buf != b->ptr) {
4121                 Copy(buf, b->ptr, avail, STDCHAR);
4122             }
4123             count -= avail;
4124             unread += avail;
4125             PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
4126         }
4127     }
4128     if (count > 0) {
4129         unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
4130     }
4131     return unread;
4132 }
4133 
4134 SSize_t
PerlIOBuf_write(pTHX_ PerlIO * f,const void * vbuf,Size_t count)4135 PerlIOBuf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4136 {
4137     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4138     const STDCHAR *buf = (const STDCHAR *) vbuf;
4139     const STDCHAR *flushptr = buf;
4140     Size_t written = 0;
4141     if (!b->buf)
4142         PerlIO_get_base(f);
4143     if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
4144         return 0;
4145     if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4146         if (PerlIO_flush(f) != 0) {
4147             return 0;
4148         }
4149     }
4150     if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
4151         flushptr = buf + count;
4152         while (flushptr > buf && *(flushptr - 1) != '\n')
4153             --flushptr;
4154     }
4155     while (count > 0) {
4156         SSize_t avail = b->bufsiz - (b->ptr - b->buf);
4157         if ((SSize_t) count >= 0 && (SSize_t) count < avail)
4158             avail = count;
4159         if (flushptr > buf && flushptr <= buf + avail)
4160             avail = flushptr - buf;
4161         PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
4162         if (avail) {
4163             Copy(buf, b->ptr, avail, STDCHAR);
4164             count -= avail;
4165             buf += avail;
4166             written += avail;
4167             b->ptr += avail;
4168             if (buf == flushptr)
4169                 PerlIO_flush(f);
4170         }
4171         if (b->ptr >= (b->buf + b->bufsiz))
4172             if (PerlIO_flush(f) == -1)
4173                 return -1;
4174     }
4175     if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
4176         PerlIO_flush(f);
4177     return written;
4178 }
4179 
4180 IV
PerlIOBuf_seek(pTHX_ PerlIO * f,Off_t offset,int whence)4181 PerlIOBuf_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
4182 {
4183     IV code;
4184     if ((code = PerlIO_flush(f)) == 0) {
4185         PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
4186         code = PerlIO_seek(PerlIONext(f), offset, whence);
4187         if (code == 0) {
4188             PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
4189             b->posn = PerlIO_tell(PerlIONext(f));
4190         }
4191     }
4192     return code;
4193 }
4194 
4195 Off_t
PerlIOBuf_tell(pTHX_ PerlIO * f)4196 PerlIOBuf_tell(pTHX_ PerlIO *f)
4197 {
4198     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4199     /*
4200      * b->posn is file position where b->buf was read, or will be written
4201      */
4202     Off_t posn = b->posn;
4203     if ((PerlIOBase(f)->flags & PERLIO_F_APPEND) &&
4204         (PerlIOBase(f)->flags & PERLIO_F_WRBUF)) {
4205 #if 1
4206         /* As O_APPEND files are normally shared in some sense it is better
4207            to flush :
4208          */
4209         PerlIO_flush(f);
4210 #else
4211         /* when file is NOT shared then this is sufficient */
4212         PerlIO_seek(PerlIONext(f),0, SEEK_END);
4213 #endif
4214         posn = b->posn = PerlIO_tell(PerlIONext(f));
4215     }
4216     if (b->buf) {
4217         /*
4218          * If buffer is valid adjust position by amount in buffer
4219          */
4220         posn += (b->ptr - b->buf);
4221     }
4222     return posn;
4223 }
4224 
4225 IV
PerlIOBuf_popped(pTHX_ PerlIO * f)4226 PerlIOBuf_popped(pTHX_ PerlIO *f)
4227 {
4228     const IV code = PerlIOBase_popped(aTHX_ f);
4229     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4230     if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4231         Safefree(b->buf);
4232     }
4233     b->ptr = b->end = b->buf = NULL;
4234     PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4235     return code;
4236 }
4237 
4238 IV
PerlIOBuf_close(pTHX_ PerlIO * f)4239 PerlIOBuf_close(pTHX_ PerlIO *f)
4240 {
4241     const IV code = PerlIOBase_close(aTHX_ f);
4242     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4243     if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4244         Safefree(b->buf);
4245     }
4246     b->ptr = b->end = b->buf = NULL;
4247     PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4248     return code;
4249 }
4250 
4251 STDCHAR *
PerlIOBuf_get_ptr(pTHX_ PerlIO * f)4252 PerlIOBuf_get_ptr(pTHX_ PerlIO *f)
4253 {
4254     const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4255     if (!b->buf)
4256         PerlIO_get_base(f);
4257     return b->ptr;
4258 }
4259 
4260 SSize_t
PerlIOBuf_get_cnt(pTHX_ PerlIO * f)4261 PerlIOBuf_get_cnt(pTHX_ PerlIO *f)
4262 {
4263     const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4264     if (!b->buf)
4265         PerlIO_get_base(f);
4266     if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
4267         return (b->end - b->ptr);
4268     return 0;
4269 }
4270 
4271 STDCHAR *
PerlIOBuf_get_base(pTHX_ PerlIO * f)4272 PerlIOBuf_get_base(pTHX_ PerlIO *f)
4273 {
4274     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4275     PERL_UNUSED_CONTEXT;
4276 
4277     if (!b->buf) {
4278         if (!b->bufsiz)
4279             b->bufsiz = PERLIOBUF_DEFAULT_BUFSIZ;
4280         Newx(b->buf,b->bufsiz, STDCHAR);
4281         if (!b->buf) {
4282             b->buf = (STDCHAR *) & b->oneword;
4283             b->bufsiz = sizeof(b->oneword);
4284         }
4285         b->end = b->ptr = b->buf;
4286     }
4287     return b->buf;
4288 }
4289 
4290 Size_t
PerlIOBuf_bufsiz(pTHX_ PerlIO * f)4291 PerlIOBuf_bufsiz(pTHX_ PerlIO *f)
4292 {
4293     const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4294     if (!b->buf)
4295         PerlIO_get_base(f);
4296     return (b->end - b->buf);
4297 }
4298 
4299 void
PerlIOBuf_set_ptrcnt(pTHX_ PerlIO * f,STDCHAR * ptr,SSize_t cnt)4300 PerlIOBuf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4301 {
4302     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4303 #ifndef DEBUGGING
4304     PERL_UNUSED_ARG(cnt);
4305 #endif
4306     if (!b->buf)
4307         PerlIO_get_base(f);
4308     b->ptr = ptr;
4309     assert(PerlIO_get_cnt(f) == cnt);
4310     assert(b->ptr >= b->buf);
4311     PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4312 }
4313 
4314 PerlIO *
PerlIOBuf_dup(pTHX_ PerlIO * f,PerlIO * o,CLONE_PARAMS * param,int flags)4315 PerlIOBuf_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
4316 {
4317  return PerlIOBase_dup(aTHX_ f, o, param, flags);
4318 }
4319 
4320 
4321 
4322 PERLIO_FUNCS_DECL(PerlIO_perlio) = {
4323     sizeof(PerlIO_funcs),
4324     "perlio",
4325     sizeof(PerlIOBuf),
4326     PERLIO_K_BUFFERED|PERLIO_K_RAW,
4327     PerlIOBuf_pushed,
4328     PerlIOBuf_popped,
4329     PerlIOBuf_open,
4330     PerlIOBase_binmode,         /* binmode */
4331     NULL,
4332     PerlIOBase_fileno,
4333     PerlIOBuf_dup,
4334     PerlIOBuf_read,
4335     PerlIOBuf_unread,
4336     PerlIOBuf_write,
4337     PerlIOBuf_seek,
4338     PerlIOBuf_tell,
4339     PerlIOBuf_close,
4340     PerlIOBuf_flush,
4341     PerlIOBuf_fill,
4342     PerlIOBase_eof,
4343     PerlIOBase_error,
4344     PerlIOBase_clearerr,
4345     PerlIOBase_setlinebuf,
4346     PerlIOBuf_get_base,
4347     PerlIOBuf_bufsiz,
4348     PerlIOBuf_get_ptr,
4349     PerlIOBuf_get_cnt,
4350     PerlIOBuf_set_ptrcnt,
4351 };
4352 
4353 /*--------------------------------------------------------------------------------------*/
4354 /*
4355  * Temp layer to hold unread chars when cannot do it any other way
4356  */
4357 
4358 IV
PerlIOPending_fill(pTHX_ PerlIO * f)4359 PerlIOPending_fill(pTHX_ PerlIO *f)
4360 {
4361     /*
4362      * Should never happen
4363      */
4364     PerlIO_flush(f);
4365     return 0;
4366 }
4367 
4368 IV
PerlIOPending_close(pTHX_ PerlIO * f)4369 PerlIOPending_close(pTHX_ PerlIO *f)
4370 {
4371     /*
4372      * A tad tricky - flush pops us, then we close new top
4373      */
4374     PerlIO_flush(f);
4375     return PerlIO_close(f);
4376 }
4377 
4378 IV
PerlIOPending_seek(pTHX_ PerlIO * f,Off_t offset,int whence)4379 PerlIOPending_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
4380 {
4381     /*
4382      * A tad tricky - flush pops us, then we seek new top
4383      */
4384     PerlIO_flush(f);
4385     return PerlIO_seek(f, offset, whence);
4386 }
4387 
4388 
4389 IV
PerlIOPending_flush(pTHX_ PerlIO * f)4390 PerlIOPending_flush(pTHX_ PerlIO *f)
4391 {
4392     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4393     if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4394         Safefree(b->buf);
4395         b->buf = NULL;
4396     }
4397     PerlIO_pop(aTHX_ f);
4398     return 0;
4399 }
4400 
4401 void
PerlIOPending_set_ptrcnt(pTHX_ PerlIO * f,STDCHAR * ptr,SSize_t cnt)4402 PerlIOPending_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4403 {
4404     if (cnt <= 0) {
4405         PerlIO_flush(f);
4406     }
4407     else {
4408         PerlIOBuf_set_ptrcnt(aTHX_ f, ptr, cnt);
4409     }
4410 }
4411 
4412 IV
PerlIOPending_pushed(pTHX_ PerlIO * f,const char * mode,SV * arg,PerlIO_funcs * tab)4413 PerlIOPending_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
4414 {
4415     const IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
4416     PerlIOl * const l = PerlIOBase(f);
4417     /*
4418      * Our PerlIO_fast_gets must match what we are pushed on, or sv_gets()
4419      * etc. get muddled when it changes mid-string when we auto-pop.
4420      */
4421     l->flags = (l->flags & ~(PERLIO_F_FASTGETS | PERLIO_F_UTF8)) |
4422         (PerlIOBase(PerlIONext(f))->
4423          flags & (PERLIO_F_FASTGETS | PERLIO_F_UTF8));
4424     return code;
4425 }
4426 
4427 SSize_t
PerlIOPending_read(pTHX_ PerlIO * f,void * vbuf,Size_t count)4428 PerlIOPending_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
4429 {
4430     SSize_t avail = PerlIO_get_cnt(f);
4431     SSize_t got = 0;
4432     if ((SSize_t) count >= 0 && (SSize_t)count < avail)
4433         avail = count;
4434     if (avail > 0)
4435         got = PerlIOBuf_read(aTHX_ f, vbuf, avail);
4436     if (got >= 0 && got < (SSize_t)count) {
4437         const SSize_t more =
4438             PerlIO_read(f, ((STDCHAR *) vbuf) + got, count - got);
4439         if (more >= 0 || got == 0)
4440             got += more;
4441     }
4442     return got;
4443 }
4444 
4445 PERLIO_FUNCS_DECL(PerlIO_pending) = {
4446     sizeof(PerlIO_funcs),
4447     "pending",
4448     sizeof(PerlIOBuf),
4449     PERLIO_K_BUFFERED|PERLIO_K_RAW,  /* not sure about RAW here */
4450     PerlIOPending_pushed,
4451     PerlIOBuf_popped,
4452     NULL,
4453     PerlIOBase_binmode,         /* binmode */
4454     NULL,
4455     PerlIOBase_fileno,
4456     PerlIOBuf_dup,
4457     PerlIOPending_read,
4458     PerlIOBuf_unread,
4459     PerlIOBuf_write,
4460     PerlIOPending_seek,
4461     PerlIOBuf_tell,
4462     PerlIOPending_close,
4463     PerlIOPending_flush,
4464     PerlIOPending_fill,
4465     PerlIOBase_eof,
4466     PerlIOBase_error,
4467     PerlIOBase_clearerr,
4468     PerlIOBase_setlinebuf,
4469     PerlIOBuf_get_base,
4470     PerlIOBuf_bufsiz,
4471     PerlIOBuf_get_ptr,
4472     PerlIOBuf_get_cnt,
4473     PerlIOPending_set_ptrcnt,
4474 };
4475 
4476 
4477 
4478 /*--------------------------------------------------------------------------------------*/
4479 /*
4480  * crlf - translation On read translate CR,LF to "\n" we do this by
4481  * overriding ptr/cnt entries to hand back a line at a time and keeping a
4482  * record of which nl we "lied" about. On write translate "\n" to CR,LF
4483  *
4484  * c->nl points on the first byte of CR LF pair when it is temporarily
4485  * replaced by LF, or to the last CR of the buffer.  In the former case
4486  * the caller thinks that the buffer ends at c->nl + 1, in the latter
4487  * that it ends at c->nl; these two cases can be distinguished by
4488  * *c->nl.  c->nl is set during _getcnt() call, and unset during
4489  * _unread() and _flush() calls.
4490  * It only matters for read operations.
4491  */
4492 
4493 typedef struct {
4494     PerlIOBuf base;             /* PerlIOBuf stuff */
4495     STDCHAR *nl;                /* Position of crlf we "lied" about in the
4496                                  * buffer */
4497 } PerlIOCrlf;
4498 
4499 /* Inherit the PERLIO_F_UTF8 flag from previous layer.
4500  * Otherwise the :crlf layer would always revert back to
4501  * raw mode.
4502  */
4503 static void
S_inherit_utf8_flag(PerlIO * f)4504 S_inherit_utf8_flag(PerlIO *f)
4505 {
4506     PerlIO *g = PerlIONext(f);
4507     if (PerlIOValid(g)) {
4508         if (PerlIOBase(g)->flags & PERLIO_F_UTF8) {
4509             PerlIOBase(f)->flags |= PERLIO_F_UTF8;
4510         }
4511     }
4512 }
4513 
4514 IV
PerlIOCrlf_pushed(pTHX_ PerlIO * f,const char * mode,SV * arg,PerlIO_funcs * tab)4515 PerlIOCrlf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
4516 {
4517     IV code;
4518     PerlIOBase(f)->flags |= PERLIO_F_CRLF;
4519     code = PerlIOBuf_pushed(aTHX_ f, mode, arg, tab);
4520 #if 0
4521     DEBUG_i(
4522     PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08" UVxf "\n",
4523                  (void*)f, PerlIOBase(f)->tab->name, (mode) ? mode : "(Null)",
4524                  PerlIOBase(f)->flags);
4525     );
4526 #endif
4527     {
4528       /* If the old top layer is a CRLF layer, reactivate it (if
4529        * necessary) and remove this new layer from the stack */
4530          PerlIO *g = PerlIONext(f);
4531          if (PerlIOValid(g)) {
4532               PerlIOl *b = PerlIOBase(g);
4533               if (b && b->tab == &PerlIO_crlf) {
4534                    if (!(b->flags & PERLIO_F_CRLF))
4535                         b->flags |= PERLIO_F_CRLF;
4536                    S_inherit_utf8_flag(g);
4537                    PerlIO_pop(aTHX_ f);
4538                    return code;
4539               }
4540          }
4541     }
4542     S_inherit_utf8_flag(f);
4543     return code;
4544 }
4545 
4546 
4547 SSize_t
PerlIOCrlf_unread(pTHX_ PerlIO * f,const void * vbuf,Size_t count)4548 PerlIOCrlf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4549 {
4550     PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4551     if (c->nl) {	/* XXXX Shouldn't it be done only if b->ptr > c->nl? */
4552         *(c->nl) = NATIVE_0xd;
4553         c->nl = NULL;
4554     }
4555     if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
4556         return PerlIOBuf_unread(aTHX_ f, vbuf, count);
4557     else {
4558         const STDCHAR *buf = (const STDCHAR *) vbuf + count;
4559         PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
4560         SSize_t unread = 0;
4561         if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
4562             PerlIO_flush(f);
4563         if (!b->buf)
4564             PerlIO_get_base(f);
4565         if (b->buf) {
4566             if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
4567                 b->end = b->ptr = b->buf + b->bufsiz;
4568                 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4569                 b->posn -= b->bufsiz;
4570             }
4571             while (count > 0 && b->ptr > b->buf) {
4572                 const int ch = *--buf;
4573                 if (ch == '\n') {
4574                     if (b->ptr - 2 >= b->buf) {
4575                         *--(b->ptr) = NATIVE_0xa;
4576                         *--(b->ptr) = NATIVE_0xd;
4577                         unread++;
4578                         count--;
4579                     }
4580                     else {
4581                     /* If b->ptr - 1 == b->buf, we are undoing reading 0xa */
4582                         *--(b->ptr) = NATIVE_0xa;   /* Works even if 0xa ==
4583                                                        '\r' */
4584                         unread++;
4585                         count--;
4586                     }
4587                 }
4588                 else {
4589                     *--(b->ptr) = ch;
4590                     unread++;
4591                     count--;
4592                 }
4593             }
4594         }
4595         if (count > 0)
4596             unread += PerlIOBase_unread(aTHX_ f, (const STDCHAR *) vbuf + unread, count);
4597         return unread;
4598     }
4599 }
4600 
4601 /* XXXX This code assumes that buffer size >=2, but does not check it... */
4602 SSize_t
PerlIOCrlf_get_cnt(pTHX_ PerlIO * f)4603 PerlIOCrlf_get_cnt(pTHX_ PerlIO *f)
4604 {
4605     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4606     if (!b->buf)
4607         PerlIO_get_base(f);
4608     if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4609         PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4610         if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && (!c->nl || *c->nl == NATIVE_0xd)) {
4611             STDCHAR *nl = (c->nl) ? c->nl : b->ptr;
4612           scan:
4613             while (nl < b->end && *nl != NATIVE_0xd)
4614                 nl++;
4615             if (nl < b->end && *nl == NATIVE_0xd) {
4616               test:
4617                 if (nl + 1 < b->end) {
4618                     if (nl[1] == NATIVE_0xa) {
4619                         *nl = '\n';
4620                         c->nl = nl;
4621                     }
4622                     else {
4623                         /*
4624                          * Not CR,LF but just CR
4625                          */
4626                         nl++;
4627                         goto scan;
4628                     }
4629                 }
4630                 else {
4631                     /*
4632                      * Blast - found CR as last char in buffer
4633                      */
4634 
4635                     if (b->ptr < nl) {
4636                         /*
4637                          * They may not care, defer work as long as
4638                          * possible
4639                          */
4640                         c->nl = nl;
4641                         return (nl - b->ptr);
4642                     }
4643                     else {
4644                         int code;
4645                         b->ptr++;       /* say we have read it as far as
4646                                          * flush() is concerned */
4647                         b->buf++;       /* Leave space in front of buffer */
4648                         /* Note as we have moved buf up flush's
4649                            posn += ptr-buf
4650                            will naturally make posn point at CR
4651                          */
4652                         b->bufsiz--;    /* Buffer is thus smaller */
4653                         code = PerlIO_fill(f);  /* Fetch some more */
4654                         b->bufsiz++;    /* Restore size for next time */
4655                         b->buf--;       /* Point at space */
4656                         b->ptr = nl = b->buf;   /* Which is what we hand
4657                                                  * off */
4658                         *nl = NATIVE_0xd;      /* Fill in the CR */
4659                         if (code == 0)
4660                             goto test;  /* fill() call worked */
4661                         /*
4662                          * CR at EOF - just fall through
4663                          */
4664                         /* Should we clear EOF though ??? */
4665                     }
4666                 }
4667             }
4668         }
4669         return (((c->nl) ? (c->nl + 1) : b->end) - b->ptr);
4670     }
4671     return 0;
4672 }
4673 
4674 void
PerlIOCrlf_set_ptrcnt(pTHX_ PerlIO * f,STDCHAR * ptr,SSize_t cnt)4675 PerlIOCrlf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4676 {
4677     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4678     PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4679     if (!b->buf)
4680         PerlIO_get_base(f);
4681     if (!ptr) {
4682         if (c->nl) {
4683             ptr = c->nl + 1;
4684             if (ptr == b->end && *c->nl == NATIVE_0xd) {
4685                 /* Deferred CR at end of buffer case - we lied about count */
4686                 ptr--;
4687             }
4688         }
4689         else {
4690             ptr = b->end;
4691         }
4692         ptr -= cnt;
4693     }
4694     else {
4695         NOOP;
4696 #if 0
4697         /*
4698          * Test code - delete when it works ...
4699          */
4700         IV flags = PerlIOBase(f)->flags;
4701         STDCHAR *chk = (c->nl) ? (c->nl+1) : b->end;
4702         if (ptr+cnt == c->nl && c->nl+1 == b->end && *c->nl == NATIVE_0xd) {
4703           /* Deferred CR at end of buffer case - we lied about count */
4704           chk--;
4705         }
4706         chk -= cnt;
4707 
4708         if (ptr != chk ) {
4709             Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08" UVxf
4710                        " nl=%p e=%p for %d", (void*)ptr, (void*)chk,
4711                        flags, c->nl, b->end, cnt);
4712         }
4713 #endif
4714     }
4715     if (c->nl) {
4716         if (ptr > c->nl) {
4717             /*
4718              * They have taken what we lied about
4719              */
4720             *(c->nl) = NATIVE_0xd;
4721             c->nl = NULL;
4722             ptr++;
4723         }
4724     }
4725     b->ptr = ptr;
4726     PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4727 }
4728 
4729 SSize_t
PerlIOCrlf_write(pTHX_ PerlIO * f,const void * vbuf,Size_t count)4730 PerlIOCrlf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4731 {
4732     if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
4733         return PerlIOBuf_write(aTHX_ f, vbuf, count);
4734     else {
4735         PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4736         const STDCHAR *buf = (const STDCHAR *) vbuf;
4737         const STDCHAR * const ebuf = buf + count;
4738         if (!b->buf)
4739             PerlIO_get_base(f);
4740         if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
4741             return 0;
4742         while (buf < ebuf) {
4743             const STDCHAR * const eptr = b->buf + b->bufsiz;
4744             PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
4745             while (buf < ebuf && b->ptr < eptr) {
4746                 if (*buf == '\n') {
4747                     if ((b->ptr + 2) > eptr) {
4748                         /*
4749                          * Not room for both
4750                          */
4751                         PerlIO_flush(f);
4752                         break;
4753                     }
4754                     else {
4755                         *(b->ptr)++ = NATIVE_0xd;      /* CR */
4756                         *(b->ptr)++ = NATIVE_0xa;      /* LF */
4757                         buf++;
4758                         if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
4759                             PerlIO_flush(f);
4760                             break;
4761                         }
4762                     }
4763                 }
4764                 else {
4765                     *(b->ptr)++ = *buf++;
4766                 }
4767                 if (b->ptr >= eptr) {
4768                     PerlIO_flush(f);
4769                     break;
4770                 }
4771             }
4772         }
4773         if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
4774             PerlIO_flush(f);
4775         return (buf - (STDCHAR *) vbuf);
4776     }
4777 }
4778 
4779 IV
PerlIOCrlf_flush(pTHX_ PerlIO * f)4780 PerlIOCrlf_flush(pTHX_ PerlIO *f)
4781 {
4782     PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4783     if (c->nl) {
4784         *(c->nl) = NATIVE_0xd;
4785         c->nl = NULL;
4786     }
4787     return PerlIOBuf_flush(aTHX_ f);
4788 }
4789 
4790 IV
PerlIOCrlf_binmode(pTHX_ PerlIO * f)4791 PerlIOCrlf_binmode(pTHX_ PerlIO *f)
4792 {
4793     if ((PerlIOBase(f)->flags & PERLIO_F_CRLF)) {
4794         /* In text mode - flush any pending stuff and flip it */
4795         PerlIOBase(f)->flags &= ~PERLIO_F_CRLF;
4796 #ifndef PERLIO_USING_CRLF
4797         /* CRLF is unusual case - if this is just the :crlf layer pop it */
4798         PerlIO_pop(aTHX_ f);
4799 #endif
4800     }
4801     return PerlIOBase_binmode(aTHX_ f);
4802 }
4803 
4804 PERLIO_FUNCS_DECL(PerlIO_crlf) = {
4805     sizeof(PerlIO_funcs),
4806     "crlf",
4807     sizeof(PerlIOCrlf),
4808     PERLIO_K_BUFFERED | PERLIO_K_CANCRLF | PERLIO_K_RAW,
4809     PerlIOCrlf_pushed,
4810     PerlIOBuf_popped,         /* popped */
4811     PerlIOBuf_open,
4812     PerlIOCrlf_binmode,       /* binmode */
4813     NULL,
4814     PerlIOBase_fileno,
4815     PerlIOBuf_dup,
4816     PerlIOBuf_read,             /* generic read works with ptr/cnt lies */
4817     PerlIOCrlf_unread,          /* Put CR,LF in buffer for each '\n' */
4818     PerlIOCrlf_write,           /* Put CR,LF in buffer for each '\n' */
4819     PerlIOBuf_seek,
4820     PerlIOBuf_tell,
4821     PerlIOBuf_close,
4822     PerlIOCrlf_flush,
4823     PerlIOBuf_fill,
4824     PerlIOBase_eof,
4825     PerlIOBase_error,
4826     PerlIOBase_clearerr,
4827     PerlIOBase_setlinebuf,
4828     PerlIOBuf_get_base,
4829     PerlIOBuf_bufsiz,
4830     PerlIOBuf_get_ptr,
4831     PerlIOCrlf_get_cnt,
4832     PerlIOCrlf_set_ptrcnt,
4833 };
4834 
4835 PerlIO *
Perl_PerlIO_stdin(pTHX)4836 Perl_PerlIO_stdin(pTHX)
4837 {
4838     if (!PL_perlio) {
4839         PerlIO_stdstreams(aTHX);
4840     }
4841     return &PL_perlio[1].next;
4842 }
4843 
4844 PerlIO *
Perl_PerlIO_stdout(pTHX)4845 Perl_PerlIO_stdout(pTHX)
4846 {
4847     if (!PL_perlio) {
4848         PerlIO_stdstreams(aTHX);
4849     }
4850     return &PL_perlio[2].next;
4851 }
4852 
4853 PerlIO *
Perl_PerlIO_stderr(pTHX)4854 Perl_PerlIO_stderr(pTHX)
4855 {
4856     if (!PL_perlio) {
4857         PerlIO_stdstreams(aTHX);
4858     }
4859     return &PL_perlio[3].next;
4860 }
4861 
4862 /*--------------------------------------------------------------------------------------*/
4863 
4864 char *
PerlIO_getname(PerlIO * f,char * buf)4865 PerlIO_getname(PerlIO *f, char *buf)
4866 {
4867 #ifdef VMS
4868     dTHX;
4869     char *name = NULL;
4870     bool exported = FALSE;
4871     FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
4872     if (!stdio) {
4873         stdio = PerlIO_exportFILE(f,0);
4874         exported = TRUE;
4875     }
4876     if (stdio) {
4877         name = fgetname(stdio, buf);
4878         if (exported) PerlIO_releaseFILE(f,stdio);
4879     }
4880     return name;
4881 #else
4882     PERL_UNUSED_ARG(f);
4883     PERL_UNUSED_ARG(buf);
4884     Perl_croak_nocontext("Don't know how to get file name");
4885     return NULL;
4886 #endif
4887 }
4888 
4889 
4890 /*--------------------------------------------------------------------------------------*/
4891 /*
4892  * Functions which can be called on any kind of PerlIO implemented in
4893  * terms of above
4894  */
4895 
4896 #undef PerlIO_fdopen
4897 PerlIO *
PerlIO_fdopen(int fd,const char * mode)4898 PerlIO_fdopen(int fd, const char *mode)
4899 {
4900     dTHX;
4901     return PerlIO_openn(aTHX_ NULL, mode, fd, 0, 0, NULL, 0, NULL);
4902 }
4903 
4904 #undef PerlIO_open
4905 PerlIO *
PerlIO_open(const char * path,const char * mode)4906 PerlIO_open(const char *path, const char *mode)
4907 {
4908     dTHX;
4909     SV *name = newSVpvn_flags(path, path == NULL ? 0 : strlen(path), SVs_TEMP);
4910     return PerlIO_openn(aTHX_ NULL, mode, -1, 0, 0, NULL, 1, &name);
4911 }
4912 
4913 #undef Perlio_reopen
4914 PerlIO *
PerlIO_reopen(const char * path,const char * mode,PerlIO * f)4915 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
4916 {
4917     dTHX;
4918     SV *name = newSVpvn_flags(path, path == NULL ? 0 : strlen(path), SVs_TEMP);
4919     return PerlIO_openn(aTHX_ NULL, mode, -1, 0, 0, f, 1, &name);
4920 }
4921 
4922 #undef PerlIO_getc
4923 int
PerlIO_getc(PerlIO * f)4924 PerlIO_getc(PerlIO *f)
4925 {
4926     dTHX;
4927     STDCHAR buf[1];
4928     if ( 1 == PerlIO_read(f, buf, 1) ) {
4929         return (unsigned char) buf[0];
4930     }
4931     return EOF;
4932 }
4933 
4934 #undef PerlIO_ungetc
4935 int
PerlIO_ungetc(PerlIO * f,int ch)4936 PerlIO_ungetc(PerlIO *f, int ch)
4937 {
4938     dTHX;
4939     if (ch != EOF) {
4940         STDCHAR buf = ch;
4941         if (PerlIO_unread(f, &buf, 1) == 1)
4942             return ch;
4943     }
4944     return EOF;
4945 }
4946 
4947 #undef PerlIO_putc
4948 int
PerlIO_putc(PerlIO * f,int ch)4949 PerlIO_putc(PerlIO *f, int ch)
4950 {
4951     dTHX;
4952     STDCHAR buf = ch;
4953     return PerlIO_write(f, &buf, 1);
4954 }
4955 
4956 #undef PerlIO_puts
4957 int
PerlIO_puts(PerlIO * f,const char * s)4958 PerlIO_puts(PerlIO *f, const char *s)
4959 {
4960     dTHX;
4961     return PerlIO_write(f, s, strlen(s));
4962 }
4963 
4964 #undef PerlIO_rewind
4965 void
PerlIO_rewind(PerlIO * f)4966 PerlIO_rewind(PerlIO *f)
4967 {
4968     dTHX;
4969     PerlIO_seek(f, (Off_t) 0, SEEK_SET);
4970     PerlIO_clearerr(f);
4971 }
4972 
4973 #undef PerlIO_vprintf
4974 int
PerlIO_vprintf(PerlIO * f,const char * fmt,va_list ap)4975 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
4976 {
4977     dTHX;
4978     SV * sv;
4979     const char *s;
4980     STRLEN len;
4981     SSize_t wrote;
4982 #ifdef NEED_VA_COPY
4983     va_list apc;
4984     Perl_va_copy(ap, apc);
4985     sv = vnewSVpvf(fmt, &apc);
4986     va_end(apc);
4987 #else
4988     sv = vnewSVpvf(fmt, &ap);
4989 #endif
4990     s = SvPV_const(sv, len);
4991     wrote = PerlIO_write(f, s, len);
4992     SvREFCNT_dec(sv);
4993     return wrote;
4994 }
4995 
4996 #undef PerlIO_printf
4997 int
PerlIO_printf(PerlIO * f,const char * fmt,...)4998 PerlIO_printf(PerlIO *f, const char *fmt, ...)
4999 {
5000     va_list ap;
5001     int result;
5002     va_start(ap, fmt);
5003     result = PerlIO_vprintf(f, fmt, ap);
5004     va_end(ap);
5005     return result;
5006 }
5007 
5008 #undef PerlIO_stdoutf
5009 int
PerlIO_stdoutf(const char * fmt,...)5010 PerlIO_stdoutf(const char *fmt, ...)
5011 {
5012     dTHX;
5013     va_list ap;
5014     int result;
5015     va_start(ap, fmt);
5016     result = PerlIO_vprintf(PerlIO_stdout(), fmt, ap);
5017     va_end(ap);
5018     return result;
5019 }
5020 
5021 #undef PerlIO_tmpfile
5022 PerlIO *
PerlIO_tmpfile(void)5023 PerlIO_tmpfile(void)
5024 {
5025     return PerlIO_tmpfile_flags(0);
5026 }
5027 
5028 #define MKOSTEMP_MODES ( O_RDWR | O_CREAT | O_EXCL )
5029 #define MKOSTEMP_MODE_MASK ( O_ACCMODE | O_CREAT | O_EXCL | O_TRUNC )
5030 
5031 PerlIO *
PerlIO_tmpfile_flags(int imode)5032 PerlIO_tmpfile_flags(int imode)
5033 {
5034 #ifndef WIN32
5035      dTHX;
5036 #endif
5037      PerlIO *f = NULL;
5038 #ifdef WIN32
5039      const int fd = win32_tmpfd_mode(imode);
5040      if (fd >= 0)
5041           f = PerlIO_fdopen(fd, "w+b");
5042 #elif ! defined(OS2)
5043      int fd = -1;
5044      char tempname[] = "/tmp/PerlIO_XXXXXX";
5045      const char * const tmpdir = TAINTING_get ? NULL : PerlEnv_getenv("TMPDIR");
5046      SV * sv = NULL;
5047      int old_umask = umask(0177);
5048      imode &= ~MKOSTEMP_MODE_MASK;
5049      if (tmpdir && *tmpdir) {
5050          /* if TMPDIR is set and not empty, we try that first */
5051          sv = newSVpv(tmpdir, 0);
5052          sv_catpv(sv, tempname + 4);
5053          fd = Perl_my_mkostemp_cloexec(SvPVX(sv), imode | O_VMS_DELETEONCLOSE);
5054      }
5055      if (fd < 0) {
5056          SvREFCNT_dec(sv);
5057          sv = NULL;
5058          /* else we try /tmp */
5059          fd = Perl_my_mkostemp_cloexec(tempname, imode | O_VMS_DELETEONCLOSE);
5060      }
5061      if (fd < 0) {
5062          /* Try cwd */
5063          sv = newSVpvs(".");
5064          sv_catpv(sv, tempname + 4);
5065          fd = Perl_my_mkostemp_cloexec(SvPVX(sv), imode | O_VMS_DELETEONCLOSE);
5066      }
5067      umask(old_umask);
5068      if (fd >= 0) {
5069          /* fdopen() with a numeric mode */
5070          char mode[8];
5071          int writing = 1;
5072          (void)PerlIO_intmode2str(imode | MKOSTEMP_MODES, mode, &writing);
5073          f = PerlIO_fdopen(fd, mode);
5074           if (f)
5075                PerlIOBase(f)->flags |= PERLIO_F_TEMP;
5076 #  ifndef VMS
5077           PerlLIO_unlink(sv ? SvPVX_const(sv) : tempname);
5078 #  endif
5079      }
5080      SvREFCNT_dec(sv);
5081 #else	/* !HAS_MKSTEMP, fallback to stdio tmpfile(). */
5082      FILE * const stdio = PerlSIO_tmpfile();
5083 
5084      if (stdio)
5085           f = PerlIO_fdopen(fileno(stdio), "w+");
5086 
5087 #endif /* else WIN32 */
5088      return f;
5089 }
5090 
5091 void
Perl_PerlIO_save_errno(pTHX_ PerlIO * f)5092 Perl_PerlIO_save_errno(pTHX_ PerlIO *f)
5093 {
5094     PERL_UNUSED_CONTEXT;
5095     if (!PerlIOValid(f))
5096         return;
5097     PerlIOBase(f)->err = errno;
5098 #ifdef VMS
5099     PerlIOBase(f)->os_err = vaxc$errno;
5100 #elif defined(OS2)
5101     PerlIOBase(f)->os_err = Perl_rc;
5102 #elif defined(WIN32)
5103     PerlIOBase(f)->os_err = GetLastError();
5104 #endif
5105 }
5106 
5107 void
Perl_PerlIO_restore_errno(pTHX_ PerlIO * f)5108 Perl_PerlIO_restore_errno(pTHX_ PerlIO *f)
5109 {
5110     PERL_UNUSED_CONTEXT;
5111     if (!PerlIOValid(f))
5112         return;
5113     SETERRNO(PerlIOBase(f)->err, PerlIOBase(f)->os_err);
5114 #ifdef OS2
5115     Perl_rc = PerlIOBase(f)->os_err);
5116 #elif defined(WIN32)
5117     SetLastError(PerlIOBase(f)->os_err);
5118 #endif
5119 }
5120 
5121 #undef HAS_FSETPOS
5122 #undef HAS_FGETPOS
5123 
5124 
5125 /*======================================================================================*/
5126 /*
5127  * Now some functions in terms of above which may be needed even if we are
5128  * not in true PerlIO mode
5129  */
5130 const char *
Perl_PerlIO_context_layers(pTHX_ const char * mode)5131 Perl_PerlIO_context_layers(pTHX_ const char *mode)
5132 {
5133     /* Returns the layers set by "use open" */
5134 
5135     const char *direction = NULL;
5136     SV *layers;
5137     /*
5138      * Need to supply default layer info from open.pm
5139      */
5140 
5141     if (!PL_curcop)
5142         return NULL;
5143 
5144     if (mode && mode[0] != 'r') {
5145         if (PL_curcop->cop_hints & HINT_LEXICAL_IO_OUT)
5146             direction = "open>";
5147     } else {
5148         if (PL_curcop->cop_hints & HINT_LEXICAL_IO_IN)
5149             direction = "open<";
5150     }
5151     if (!direction)
5152         return NULL;
5153 
5154     layers = cop_hints_fetch_pvn(PL_curcop, direction, 5, 0, 0);
5155 
5156     assert(layers);
5157     return SvOK(layers) ? SvPV_nolen_const(layers) : NULL;
5158 }
5159 
5160 
5161 #ifndef HAS_FSETPOS
5162 #  undef PerlIO_setpos
5163 int
PerlIO_setpos(PerlIO * f,SV * pos)5164 PerlIO_setpos(PerlIO *f, SV *pos)
5165 {
5166     if (SvOK(pos)) {
5167         if (f) {
5168             dTHX;
5169             STRLEN len;
5170             const Off_t * const posn = (Off_t *) SvPV(pos, len);
5171             if(len == sizeof(Off_t))
5172                 return PerlIO_seek(f, *posn, SEEK_SET);
5173         }
5174     }
5175     SETERRNO(EINVAL, SS_IVCHAN);
5176     return -1;
5177 }
5178 #else
5179 #  undef PerlIO_setpos
5180 int
PerlIO_setpos(PerlIO * f,SV * pos)5181 PerlIO_setpos(PerlIO *f, SV *pos)
5182 {
5183     if (SvOK(pos)) {
5184         if (f) {
5185             dTHX;
5186             STRLEN len;
5187             Fpos_t * const fpos = (Fpos_t *) SvPV(pos, len);
5188             if(len == sizeof(Fpos_t))
5189 #  if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
5190                 return fsetpos64(f, fpos);
5191 #  else
5192                 return fsetpos(f, fpos);
5193 #  endif
5194         }
5195     }
5196     SETERRNO(EINVAL, SS_IVCHAN);
5197     return -1;
5198 }
5199 #endif
5200 
5201 #ifndef HAS_FGETPOS
5202 #  undef PerlIO_getpos
5203 int
PerlIO_getpos(PerlIO * f,SV * pos)5204 PerlIO_getpos(PerlIO *f, SV *pos)
5205 {
5206     dTHX;
5207     Off_t posn = PerlIO_tell(f);
5208     sv_setpvn(pos, (char *) &posn, sizeof(posn));
5209     return (posn == (Off_t) - 1) ? -1 : 0;
5210 }
5211 #else
5212 #  undef PerlIO_getpos
5213 int
PerlIO_getpos(PerlIO * f,SV * pos)5214 PerlIO_getpos(PerlIO *f, SV *pos)
5215 {
5216     dTHX;
5217     Fpos_t fpos;
5218     int code;
5219 #  if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
5220     code = fgetpos64(f, &fpos);
5221 #  else
5222     code = fgetpos(f, &fpos);
5223 #  endif
5224     sv_setpvn(pos, (char *) &fpos, sizeof(fpos));
5225     return code;
5226 }
5227 #endif
5228 
5229 /* print a failure format string message to stderr and fail exit the process
5230    using only libc without depending on any perl data structures being
5231    initialized.
5232 */
5233 
5234 void
Perl_noperl_die(const char * pat,...)5235 Perl_noperl_die(const char* pat, ...)
5236 {
5237     va_list arglist;
5238     PERL_ARGS_ASSERT_NOPERL_DIE;
5239     va_start(arglist, pat);
5240     vfprintf(stderr, pat, arglist);
5241     va_end(arglist);
5242     exit(1);
5243 }
5244 
5245 /*
5246  * ex: set ts=8 sts=4 sw=4 et:
5247  */
5248