File Coverage

perlio.c
Criterion Covered Total %
statement 1302 1618 80.5
branch 871 1464 59.5
condition n/a
subroutine n/a
total 2173 3082 70.5


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