/* * perlio.c Copyright (c) 1996-2005, Nick Ing-Simmons You may distribute * under the terms of either the GNU General Public License or the * Artistic License, as specified in the README file. */ /* * Hour after hour for nearly three weary days he had jogged up and down, * over passes, and through long dales, and across many streams. */ /* This file contains the functions needed to implement PerlIO, which * is Perl's private replacement for the C stdio library. This is used * by default unless you compile with -Uuseperlio or run with * PERLIO=:stdio (but don't do this unless you know what you're doing) */ /* * If we have ActivePerl-like PERL_IMPLICIT_SYS then we need a dTHX to get * at the dispatch tables, even when we do not need it for other reasons. * Invent a dSYS macro to abstract this out */ #ifdef PERL_IMPLICIT_SYS #define dSYS dTHX #else #define dSYS dNOOP #endif #define VOIDUSED 1 #ifdef PERL_MICRO # include "uconfig.h" #else # include "config.h" #endif #define PERLIO_NOT_STDIO 0 #if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO) /* * #define PerlIO FILE */ #endif /* * This file provides those parts of PerlIO abstraction * which are not #defined in perlio.h. * Which these are depends on various Configure #ifdef's */ #include "EXTERN.h" #define PERL_IN_PERLIO_C #include "perl.h" #ifdef PERL_IMPLICIT_CONTEXT #undef dSYS #define dSYS dTHX #endif #include "XSUB.h" #define PERLIO_MAX_REFCOUNTABLE_FD 2048 #ifdef __Lynx__ /* Missing proto on LynxOS */ int mkstemp(char*); #endif /* Call the callback or PerlIOBase, and return failure. */ #define Perl_PerlIO_or_Base(f, callback, base, failure, args) \ if (PerlIOValid(f)) { \ const PerlIO_funcs *tab = PerlIOBase(f)->tab; \ if (tab && tab->callback) \ return (*tab->callback) args; \ else \ return PerlIOBase_ ## base args; \ } \ else \ SETERRNO(EBADF, SS_IVCHAN); \ return failure /* Call the callback or fail, and return failure. */ #define Perl_PerlIO_or_fail(f, callback, failure, args) \ if (PerlIOValid(f)) { \ const PerlIO_funcs *tab = PerlIOBase(f)->tab; \ if (tab && tab->callback) \ return (*tab->callback) args; \ SETERRNO(EINVAL, LIB_INVARG); \ } \ else \ SETERRNO(EBADF, SS_IVCHAN); \ return failure /* Call the callback or PerlIOBase, and be void. */ #define Perl_PerlIO_or_Base_void(f, callback, base, args) \ if (PerlIOValid(f)) { \ const PerlIO_funcs *tab = PerlIOBase(f)->tab; \ if (tab && tab->callback) \ (*tab->callback) args; \ else \ PerlIOBase_ ## base args; \ } \ else \ SETERRNO(EBADF, SS_IVCHAN) /* Call the callback or fail, and be void. */ #define Perl_PerlIO_or_fail_void(f, callback, args) \ if (PerlIOValid(f)) { \ const PerlIO_funcs *tab = PerlIOBase(f)->tab; \ if (tab && tab->callback) \ (*tab->callback) args; \ else \ SETERRNO(EINVAL, LIB_INVARG); \ } \ else \ SETERRNO(EBADF, SS_IVCHAN) #ifndef USE_SFIO int perlsio_binmode(FILE *fp, int iotype, int mode) ###### { /* * This used to be contents of do_binmode in doio.c */ #ifdef DOSISH # if defined(atarist) || defined(__MINT__) if (!fflush(fp)) { if (mode & O_BINARY) ((FILE *) fp)->_flag |= _IOBIN; else ((FILE *) fp)->_flag &= ~_IOBIN; return 1; } return 0; # else dTHX; #ifdef NETWARE if (PerlLIO_setmode(fp, mode) != -1) { #else if (PerlLIO_setmode(fileno(fp), mode) != -1) { #endif # if defined(WIN32) && defined(__BORLANDC__) /* * The translation mode of the stream is maintained independent of * the translation mode of the fd in the Borland RTL (heavy * digging through their runtime sources reveal). User has to set * the mode explicitly for the stream (though they don't document * this anywhere). GSAR 97-5-24 */ fseek(fp, 0L, 0); if (mode & O_BINARY) fp->flags |= _F_BIN; else fp->flags &= ~_F_BIN; # endif return 1; } else return 0; # endif #else # if defined(USEMYBINMODE) dTHX; if (my_binmode(fp, iotype, mode) != FALSE) return 1; else return 0; # else ###### PERL_UNUSED_ARG(fp); ###### PERL_UNUSED_ARG(iotype); ###### PERL_UNUSED_ARG(mode); ###### return 1; # endif #endif } #endif /* sfio */ #ifndef O_ACCMODE #define O_ACCMODE 3 /* Assume traditional implementation */ #endif int PerlIO_intmode2str(int rawmode, char *mode, int *writing) 3053 { 3053 const int result = rawmode & O_ACCMODE; 3053 int ix = 0; 3053 int ptype; 3053 switch (result) { case O_RDONLY: 28 ptype = IoTYPE_RDONLY; 28 break; case O_WRONLY: 20 ptype = IoTYPE_WRONLY; 20 break; case O_RDWR: default: 3005 ptype = IoTYPE_RDWR; 3053 break; } 3053 if (writing) 3053 *writing = (result != O_RDONLY); 3053 if (result == O_RDONLY) { 28 mode[ix++] = 'r'; } #ifdef O_APPEND 3025 else if (rawmode & O_APPEND) { ###### mode[ix++] = 'a'; ###### if (result != O_WRONLY) ###### mode[ix++] = '+'; } #endif else { 3025 if (result == O_WRONLY) 20 mode[ix++] = 'w'; else { 3005 mode[ix++] = 'r'; 3005 mode[ix++] = '+'; } } 3053 if (rawmode & O_BINARY) 3053 mode[ix++] = 'b'; 3053 mode[ix] = '\0'; 3053 return ptype; } #ifndef PERLIO_LAYERS int PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names) { if (!names || !*names || strEQ(names, ":crlf") || strEQ(names, ":raw") || strEQ(names, ":bytes") ) { return 0; } Perl_croak(aTHX_ "Cannot apply \"%s\" in non-PerlIO perl", names); /* * NOTREACHED */ return -1; } void PerlIO_destruct(pTHX) { } int PerlIO_binmode(pTHX_ PerlIO *fp, int iotype, int mode, const char *names) { #ifdef USE_SFIO PERL_UNUSED_ARG(iotype); PERL_UNUSED_ARG(mode); PERL_UNUSED_ARG(names); return 1; #else return perlsio_binmode(fp, iotype, mode); #endif } PerlIO * PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags) { #if defined(PERL_MICRO) || defined(SYMBIAN) return NULL; #else #ifdef PERL_IMPLICIT_SYS return PerlSIO_fdupopen(f); #else #ifdef WIN32 return win32_fdupopen(f); #else if (f) { const int fd = PerlLIO_dup(PerlIO_fileno(f)); if (fd >= 0) { char mode[8]; int omode = fcntl(fd, F_GETFL); #ifdef DJGPP omode = djgpp_get_stream_mode(f); #endif PerlIO_intmode2str(omode,mode,NULL); /* the r+ is a hack */ return PerlIO_fdopen(fd, mode); } return NULL; } else { SETERRNO(EBADF, SS_IVCHAN); } #endif return NULL; #endif #endif } /* * De-mux PerlIO_openn() into fdopen, freopen and fopen type entries */ PerlIO * PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd, int imode, int perm, PerlIO *old, int narg, SV **args) { if (narg) { if (narg > 1) { Perl_croak(aTHX_ "More than one argument to open"); } if (*args == &PL_sv_undef) return PerlIO_tmpfile(); else { const char *name = SvPV_nolen_const(*args); if (*mode == IoTYPE_NUMERIC) { fd = PerlLIO_open3(name, imode, perm); if (fd >= 0) return PerlIO_fdopen(fd, mode + 1); } else if (old) { return PerlIO_reopen(name, mode, old); } else { return PerlIO_open(name, mode); } } } else { return PerlIO_fdopen(fd, (char *) mode); } return NULL; } XS(XS_PerlIO__Layer__find) { dXSARGS; if (items < 2) Perl_croak(aTHX_ "Usage class->find(name[,load])"); else { const char *name = SvPV_nolen_const(ST(1)); ST(0) = (strEQ(name, "crlf") || strEQ(name, "raw")) ? &PL_sv_yes : &PL_sv_undef; XSRETURN(1); } } void Perl_boot_core_PerlIO(pTHX) { newXS("PerlIO::Layer::find", XS_PerlIO__Layer__find, __FILE__); } #endif #ifdef PERLIO_IS_STDIO void PerlIO_init(pTHX) { /* * Does nothing (yet) except force this file to be included in perl * binary. That allows this file to force inclusion of other functions * that may be required by loadable extensions e.g. for * FileHandle::tmpfile */ } #undef PerlIO_tmpfile PerlIO * PerlIO_tmpfile(void) { return tmpfile(); } #else /* PERLIO_IS_STDIO */ #ifdef USE_SFIO #undef HAS_FSETPOS #undef HAS_FGETPOS /* * This section is just to make sure these functions get pulled in from * libsfio.a */ #undef PerlIO_tmpfile PerlIO * PerlIO_tmpfile(void) { return sftmp(0); } void PerlIO_init(pTHX) { /* * Force this file to be included in perl binary. Which allows this * file to force inclusion of other functions that may be required by * loadable extensions e.g. for FileHandle::tmpfile */ /* * Hack sfio does its own 'autoflush' on stdout in common cases. Flush * results in a lot of lseek()s to regular files and lot of small * writes to pipes. */ sfset(sfstdout, SF_SHARE, 0); } /* This is not the reverse of PerlIO_exportFILE(), PerlIO_releaseFILE() is. */ PerlIO * PerlIO_importFILE(FILE *stdio, const char *mode) { const int fd = fileno(stdio); if (!mode || !*mode) { mode = "r+"; } return PerlIO_fdopen(fd, mode); } FILE * PerlIO_findFILE(PerlIO *pio) { const int fd = PerlIO_fileno(pio); FILE * const f = fdopen(fd, "r+"); PerlIO_flush(pio); if (!f && errno == EINVAL) f = fdopen(fd, "w"); if (!f && errno == EINVAL) f = fdopen(fd, "r"); return f; } #else /* USE_SFIO */ /*======================================================================================*/ /* * Implement all the PerlIO interface ourselves. */ #include "perliol.h" /* * We _MUST_ have if we are using lseek() and may have large * files */ #ifdef I_UNISTD #include #endif #ifdef HAS_MMAP #include #endif void PerlIO_debug(const char *fmt, ...) 931103 { 931103 va_list ap; dSYS; 931103 va_start(ap, fmt); 931103 if (!PL_perlio_debug_fd && !PL_tainting && PL_uid == PL_euid && PL_gid == PL_egid) { 4459 const char *s = PerlEnv_getenv("PERLIO_DEBUG"); 4459 if (s && *s) ###### PL_perlio_debug_fd = PerlLIO_open3(s, O_WRONLY | O_CREAT | O_APPEND, 0666); else 4459 PL_perlio_debug_fd = -1; } 931103 if (PL_perlio_debug_fd > 0) { dTHX; ###### const char *s = CopFILE(PL_curcop); ###### STRLEN len; #ifdef USE_ITHREADS /* Use fixed buffer as sv_catpvf etc. needs SVs */ char buffer[1024]; if (!s) s = "(none)"; len = sprintf(buffer, "%.40s:%" IVdf " ", s, (IV) CopLINE(PL_curcop)); vsprintf(buffer+len, fmt, ap); PerlLIO_write(PL_perlio_debug_fd, buffer, strlen(buffer)); #else ###### SV *sv = newSVpvn("", 0); ###### if (!s) ###### s = "(none)"; ###### Perl_sv_catpvf(aTHX_ sv, "%s:%" IVdf " ", s, (IV) CopLINE(PL_curcop)); ###### Perl_sv_vcatpvf(aTHX_ sv, fmt, &ap); ###### s = SvPV_const(sv, len); ###### PerlLIO_write(PL_perlio_debug_fd, s, len); ###### SvREFCNT_dec(sv); #endif } 931103 va_end(ap); } /*--------------------------------------------------------------------------------------*/ /* * Inner level routines */ /* * Table of pointers to the PerlIO structs (malloc'ed) */ #define PERLIO_TABLE_SIZE 64 PerlIO * PerlIO_allocate(pTHX) 83232 { /* * Find a free slot in the table, allocating new table as necessary */ 83232 PerlIO **last; 83232 PerlIO *f; 83232 last = &PL_perlio; 83232 while ((f = *last)) { 78729 int i; 78729 last = (PerlIO **) (f); 363193 for (i = 1; i < PERLIO_TABLE_SIZE; i++) { 363193 if (!*++f) { 78729 return f; } } } 4503 Newz('I',f,PERLIO_TABLE_SIZE,PerlIO); 4503 if (!f) { ###### return NULL; } 4503 *last = f; 4503 return f + 1; } #undef PerlIO_fdupopen PerlIO * PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags) 1483 { 1483 if (PerlIOValid(f)) { 1483 const PerlIO_funcs * const tab = PerlIOBase(f)->tab; 1483 PerlIO_debug("fdupopen f=%p param=%p\n",(void*)f,(void*)param); 1483 if (tab && tab->Dup) 1483 return (*tab->Dup)(aTHX_ PerlIO_allocate(aTHX), f, param, flags); else { ###### return PerlIOBase_dup(aTHX_ PerlIO_allocate(aTHX), f, param, flags); } } else ###### SETERRNO(EBADF, SS_IVCHAN); ###### return NULL; } void PerlIO_cleantable(pTHX_ PerlIO **tablep) 9098 { 9098 PerlIO *table = *tablep; 9098 if (table) { 4549 int i; 4549 PerlIO_cleantable(aTHX_(PerlIO **) & (table[0])); 291136 for (i = PERLIO_TABLE_SIZE - 1; i > 0; i--) { 286587 PerlIO *f = table + i; 286587 if (*f) { 13671 PerlIO_close(f); } } 4549 Safefree(table); 4549 *tablep = NULL; } } PerlIO_list_t * PerlIO_list_alloc(pTHX) 11077 { 11077 PerlIO_list_t *list; 11077 Newz('L', list, 1, PerlIO_list_t); 11077 list->refcnt = 1; 11077 return list; } void PerlIO_list_free(pTHX_ PerlIO_list_t *list) 94277 { 94277 if (list) { 94277 if (--list->refcnt == 0) { 11169 if (list->array) { 11166 IV i; 63628 for (i = 0; i < list->cur; i++) { 52462 if (list->array[i].arg) 11486 SvREFCNT_dec(list->array[i].arg); } 11166 Safefree(list->array); } 11169 Safefree(list); } } } void PerlIO_list_push(pTHX_ PerlIO_list_t *list, PerlIO_funcs *funcs, SV *arg) 51956 { 51956 PerlIO_pair_t *p; 51956 if (list->cur >= list->len) { 15577 list->len += 8; 15577 if (list->array) 4503 Renew(list->array, list->len, PerlIO_pair_t); else 11074 New('l', list->array, list->len, PerlIO_pair_t); } 51956 p = &(list->array[list->cur++]); 51956 p->funcs = funcs; 51956 if ((p->arg = arg)) { 11394 (void)SvREFCNT_inc(arg); } } PerlIO_list_t * PerlIO_clone_list(pTHX_ PerlIO_list_t *proto, CLONE_PARAMS *param) ###### { ###### PerlIO_list_t *list = (PerlIO_list_t *) NULL; ###### if (proto) { ###### int i; ###### list = PerlIO_list_alloc(aTHX); ###### for (i=0; i < proto->cur; i++) { ###### SV *arg = Nullsv; ###### if (proto->array[i].arg) ###### arg = PerlIO_sv_dup(aTHX_ proto->array[i].arg,param); ###### PerlIO_list_push(aTHX_ list, proto->array[i].funcs, arg); } } ###### return list; } void PerlIO_clone(pTHX_ PerlInterpreter *proto, CLONE_PARAMS *param) ###### { #ifdef USE_ITHREADS PerlIO **table = &proto->Iperlio; PerlIO *f; PL_perlio = NULL; PL_known_layers = PerlIO_clone_list(aTHX_ proto->Iknown_layers, param); PL_def_layerlist = PerlIO_clone_list(aTHX_ proto->Idef_layerlist, param); PerlIO_allocate(aTHX); /* root slot is never used */ PerlIO_debug("Clone %p from %p\n",aTHX,proto); while ((f = *table)) { int i; table = (PerlIO **) (f++); for (i = 1; i < PERLIO_TABLE_SIZE; i++) { if (*f) { (void) fp_dup(f, 0, param); } f++; } } #else ###### PERL_UNUSED_ARG(proto); ###### PERL_UNUSED_ARG(param); #endif } void PerlIO_destruct(pTHX) 4549 { 4549 PerlIO **table = &PL_perlio; 9098 PerlIO *f; #ifdef USE_ITHREADS PerlIO_debug("Destruct %p\n",aTHX); #endif 9098 while ((f = *table)) { 4549 int i; 4549 table = (PerlIO **) (f++); 291136 for (i = 1; i < PERLIO_TABLE_SIZE; i++) { 286587 PerlIO *x = f; 316748 PerlIOl *l; 316748 while ((l = *x)) { 30161 if (l->tab->kind & PERLIO_K_DESTRUCT) { 27 PerlIO_debug("Destruct popping %s\n", l->tab->name); 27 PerlIO_flush(x); 27 PerlIO_pop(aTHX_ x); } else { 30134 x = PerlIONext(x); } } 286587 f++; } } } void PerlIO_pop(pTHX_ PerlIO *f) 157094 { 157094 PerlIOl *l = *f; 157094 if (l) { 157094 PerlIO_debug("PerlIO_pop f=%p %s\n", (void*)f, l->tab->name); 157094 if (l->tab->Popped) { /* * If popped returns non-zero do not free its layer structure * it has either done so itself, or it is shared and still in * use */ 157094 if ((*l->tab->Popped) (aTHX_ f) != 0) ###### return; } 157094 *f = l->next; 157094 Safefree(l); } } /* Return as an array the stack of layers on a filehandle. Note that * the stack is returned top-first in the array, and there are three * times as many array elements as there are layers in the stack: the * first element of a layer triplet is the name, the second one is the * arguments, and the third one is the flags. */ AV * PerlIO_get_layers(pTHX_ PerlIO *f) 13 { 13 AV *av = newAV(); 13 if (PerlIOValid(f)) { 13 PerlIOl *l = PerlIOBase(f); 47 while (l) { 34 SV *name = l->tab && l->tab->name ? 34 newSVpv(l->tab->name, 0) : &PL_sv_undef; 34 SV *arg = l->tab && l->tab->Getarg ? 34 (*l->tab->Getarg)(aTHX_ &l, 0, 0) : &PL_sv_undef; 34 av_push(av, name); 34 av_push(av, arg); 34 av_push(av, newSViv((IV)l->flags)); 34 l = l->next; } } 13 return av; } /*--------------------------------------------------------------------------------------*/ /* * XS Interface for perl code */ PerlIO_funcs * PerlIO_find_layer(pTHX_ const char *name, STRLEN len, int load) 11226 { dVAR; 11226 IV i; 11226 if ((SSize_t) len <= 0) 9006 len = strlen(name); 36348 for (i = 0; i < PL_known_layers->cur; i++) { 36305 PerlIO_funcs *f = PL_known_layers->array[i].funcs; 36305 if (memEQ(f->name, name, len) && f->name[len] == 0) { 11183 PerlIO_debug("%.*s => %p\n", (int) len, name, (void*)f); 11183 return f; } } 43 if (load && PL_subname && PL_def_layerlist && PL_def_layerlist->cur >= 2) { 33 if (PL_in_load_module) { ###### Perl_croak(aTHX_ "Recursive call to Perl_load_module in PerlIO_find_layer"); 33 return NULL; } else { 33 SV *pkgsv = newSVpvn("PerlIO", 6); 33 SV *layer = newSVpvn(name, len); 33 CV *cv = get_cv("PerlIO::Layer::NoWarnings", FALSE); 33 ENTER; 33 SAVEINT(PL_in_load_module); 33 if (cv) { 33 SAVEGENERICSV(PL_warnhook); 33 (void)SvREFCNT_inc(cv); 33 PL_warnhook = (SV *) cv; } 33 PL_in_load_module++; /* * The two SVs are magically freed by load_module */ 33 Perl_load_module(aTHX_ 0, pkgsv, Nullsv, layer, Nullsv); 33 PL_in_load_module--; 33 LEAVE; 33 return PerlIO_find_layer(aTHX_ name, len, 0); } } 10 PerlIO_debug("Cannot find %.*s\n", (int) len, name); 10 return NULL; } #ifdef USE_ATTRIBUTES_FOR_PERLIO static int perlio_mg_set(pTHX_ SV *sv, MAGIC *mg) { if (SvROK(sv)) { IO *io = GvIOn((GV *) SvRV(sv)); PerlIO *ifp = IoIFP(io); PerlIO *ofp = IoOFP(io); Perl_warn(aTHX_ "set %" SVf " %p %p %p", sv, io, ifp, ofp); } return 0; } static int perlio_mg_get(pTHX_ SV *sv, MAGIC *mg) { if (SvROK(sv)) { IO *io = GvIOn((GV *) SvRV(sv)); PerlIO *ifp = IoIFP(io); PerlIO *ofp = IoOFP(io); Perl_warn(aTHX_ "get %" SVf " %p %p %p", sv, io, ifp, ofp); } return 0; } static int perlio_mg_clear(pTHX_ SV *sv, MAGIC *mg) { Perl_warn(aTHX_ "clear %" SVf, sv); return 0; } static int perlio_mg_free(pTHX_ SV *sv, MAGIC *mg) { Perl_warn(aTHX_ "free %" SVf, sv); return 0; } MGVTBL perlio_vtab = { perlio_mg_get, perlio_mg_set, NULL, /* len */ perlio_mg_clear, perlio_mg_free }; XS(XS_io_MODIFY_SCALAR_ATTRIBUTES) { dXSARGS; SV *sv = SvRV(ST(1)); AV *av = newAV(); MAGIC *mg; int count = 0; int i; sv_magic(sv, (SV *) av, PERL_MAGIC_ext, NULL, 0); SvRMAGICAL_off(sv); mg = mg_find(sv, PERL_MAGIC_ext); mg->mg_virtual = &perlio_vtab; mg_magical(sv); Perl_warn(aTHX_ "attrib %" SVf, sv); for (i = 2; i < items; i++) { STRLEN len; const char *name = SvPV_const(ST(i), len); SV *layer = PerlIO_find_layer(aTHX_ name, len, 1); if (layer) { av_push(av, SvREFCNT_inc(layer)); } else { ST(count) = ST(i); count++; } } SvREFCNT_dec(av); XSRETURN(count); } #endif /* USE_ATTIBUTES_FOR_PERLIO */ SV * PerlIO_tab_sv(pTHX_ PerlIO_funcs *tab) 73 { 73 HV *stash = gv_stashpv("PerlIO::Layer", TRUE); 73 SV *sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))), stash); 73 return sv; } XS(XS_PerlIO__Layer__NoWarnings) 11 { /* This is used as a %SIG{__WARN__} handler to supress warnings during loading of layers. */ 11 dXSARGS; 11 if (items) 11 PerlIO_debug("warning:%s\n",SvPV_nolen_const(ST(0))); 11 XSRETURN(0); } XS(XS_PerlIO__Layer__find) 76 { 76 dXSARGS; 76 if (items < 2) ###### Perl_croak(aTHX_ "Usage class->find(name[,load])"); else { 76 STRLEN len; 76 const char *name = SvPV_const(ST(1), len); 76 const bool load = (items > 2) ? SvTRUE(ST(2)) : 0; 76 PerlIO_funcs *layer = PerlIO_find_layer(aTHX_ name, len, load); 76 ST(0) = (layer) ? sv_2mortal(PerlIO_tab_sv(aTHX_ layer)) : &PL_sv_undef; 76 XSRETURN(1); } } void PerlIO_define_layer(pTHX_ PerlIO_funcs *tab) 40562 { 40562 if (!PL_known_layers) 4503 PL_known_layers = PerlIO_list_alloc(aTHX); 40562 PerlIO_list_push(aTHX_ PL_known_layers, tab, Nullsv); 40562 PerlIO_debug("define %s %p\n", tab->name, (void*)tab); } int PerlIO_parse_layers(pTHX_ PerlIO_list_t *av, const char *names) 1135 { 1135 if (names) { 1135 const char *s = names; 2302 while (*s) { 1587 while (isSPACE(*s) || *s == ':') 406 s++; 1181 if (*s) { 1181 STRLEN llen = 0; 1181 const char *e = s; 1181 const char *as = Nullch; 1181 STRLEN alen = 0; 1181 if (!isIDFIRST(*s)) { /* * Message is consistent with how attribute lists are * passed. Even though this means "foo : : bar" is * seen as an invalid separator character. */ 5 const char q = ((*s == '\'') ? '"' : '\''); 5 if (ckWARN(WARN_LAYER)) 4 Perl_warner(aTHX_ packWARN(WARN_LAYER), "Invalid separator character %c%c%c in PerlIO layer specification %s", q, *s, q, s); 5 SETERRNO(EINVAL, LIB_INVARG); 5 return -1; } 5109 do { 5109 e++; 5109 } while (isALNUM(*e)); 1176 llen = e - s; 1176 if (*e == '(') { 116 int nesting = 1; 116 as = ++e; 1113 while (nesting) { 999 switch (*e++) { case ')': 114 if (--nesting == 0) 114 alen = (e - 1) - as; 114 break; case '(': ###### ++nesting; ###### break; case '\\': /* * It's a nul terminated string, not allowed * to \ the terminating null. Anything other * character is passed over. */ ###### if (*e++) { ###### break; } /* * Drop through */ case '\0': 2 e--; 2 if (ckWARN(WARN_LAYER)) 1 Perl_warner(aTHX_ packWARN(WARN_LAYER), "Argument list not closed for PerlIO layer \"%.*s\"", (int) (e - s), s); 2 return -1; default: /* * boring. */ 1174 break; } } } 1174 if (e > s) { 1174 const bool warn_layer = ckWARN(WARN_LAYER); 1174 PerlIO_funcs *layer = 1174 PerlIO_find_layer(aTHX_ s, llen, 1); 1174 if (layer) { 1167 PerlIO_list_push(aTHX_ av, layer, (as) ? newSVpvn(as, alen) : &PL_sv_undef); } else { 7 if (warn_layer) 5 Perl_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"%.*s\"", (int) llen, s); 7 return -1; } } 1167 s = e; } } } 1121 return 0; } void PerlIO_default_buffer(pTHX_ PerlIO_list_t *av) 4503 { 4503 PERLIO_FUNCS_DECL(*tab) = &PerlIO_perlio; #ifdef PERLIO_USING_CRLF tab = &PerlIO_crlf; #else 4503 if (PerlIO_stdio.Set_ptrcnt) ###### tab = &PerlIO_stdio; #endif 4503 PerlIO_debug("Pushing %s\n", tab->name); 4503 PerlIO_list_push(aTHX_ av, PerlIO_find_layer(aTHX_ tab->name, 0, 0), &PL_sv_undef); } SV * PerlIO_arg_fetch(PerlIO_list_t *av, IV n) 153733 { 153733 return av->array[n].arg; } PerlIO_funcs * PerlIO_layer_fetch(pTHX_ PerlIO_list_t *av, IV n, PerlIO_funcs *def) 251883 { 251883 if (n >= 0 && n < av->cur) { 251883 PerlIO_debug("Layer %" IVdf " is %s\n", n, av->array[n].funcs->name); 251883 return av->array[n].funcs; } ###### if (!def) ###### Perl_croak(aTHX_ "panic: PerlIO layer array corrupt"); ###### return def; } IV PerlIOPop_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab) 1 { 1 PERL_UNUSED_ARG(mode); 1 PERL_UNUSED_ARG(arg); 1 PERL_UNUSED_ARG(tab); 1 if (PerlIOValid(f)) { 1 PerlIO_flush(f); 1 PerlIO_pop(aTHX_ f); 1 return 0; } ###### return -1; } PERLIO_FUNCS_DECL(PerlIO_remove) = { sizeof(PerlIO_funcs), "pop", 0, PERLIO_K_DUMMY | PERLIO_K_UTF8, PerlIOPop_pushed, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, /* flush */ NULL, /* fill */ NULL, NULL, NULL, NULL, NULL, /* get_base */ NULL, /* get_bufsiz */ NULL, /* get_ptr */ NULL, /* get_cnt */ NULL, /* set_ptrcnt */ }; PerlIO_list_t * PerlIO_default_layers(pTHX) 167492 { 167492 if (!PL_def_layerlist) { 4503 const char *s = (PL_tainting) ? Nullch : PerlEnv_getenv("PERLIO"); 4503 PERLIO_FUNCS_DECL(*osLayer) = &PerlIO_unix; 4503 PL_def_layerlist = PerlIO_list_alloc(aTHX); 4503 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_unix)); #if defined(WIN32) PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_win32)); #if 0 osLayer = &PerlIO_win32; #endif #endif 4503 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_raw)); 4503 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_perlio)); 4503 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_stdio)); 4503 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_crlf)); #ifdef HAS_MMAP 4503 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_mmap)); #endif 4503 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_utf8)); 4503 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_remove)); 4503 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_byte)); 4503 PerlIO_list_push(aTHX_ PL_def_layerlist, PerlIO_find_layer(aTHX_ osLayer->name, 0, 0), &PL_sv_undef); 4503 if (s) { ###### PerlIO_parse_layers(aTHX_ PL_def_layerlist, s); } else { 4503 PerlIO_default_buffer(aTHX_ PL_def_layerlist); } } 167492 if (PL_def_layerlist->cur < 2) { ###### PerlIO_default_buffer(aTHX_ PL_def_layerlist); } 167492 return PL_def_layerlist; } void Perl_boot_core_PerlIO(pTHX) 4500 { #ifdef USE_ATTRIBUTES_FOR_PERLIO newXS("io::MODIFY_SCALAR_ATTRIBUTES", XS_io_MODIFY_SCALAR_ATTRIBUTES, __FILE__); #endif 4500 newXS("PerlIO::Layer::find", XS_PerlIO__Layer__find, __FILE__); 4500 newXS("PerlIO::Layer::NoWarnings", XS_PerlIO__Layer__NoWarnings, __FILE__); } PerlIO_funcs * PerlIO_default_layer(pTHX_ I32 n) 83305 { 83305 PerlIO_list_t *av = PerlIO_default_layers(aTHX); 83305 if (n < 0) ###### n += av->cur; 83305 return PerlIO_layer_fetch(aTHX_ av, n, PERLIO_FUNCS_CAST(&PerlIO_stdio)); } #define PerlIO_default_top() PerlIO_default_layer(aTHX_ -1) #define PerlIO_default_btm() PerlIO_default_layer(aTHX_ 0) void PerlIO_stdstreams(pTHX) 4503 { 4503 if (!PL_perlio) { 4503 PerlIO_allocate(aTHX); 4503 PerlIO_fdopen(0, "Ir" PERLIO_STDTEXT); 4503 PerlIO_fdopen(1, "Iw" PERLIO_STDTEXT); 4503 PerlIO_fdopen(2, "Iw" PERLIO_STDTEXT); } } PerlIO * PerlIO_push(pTHX_ PerlIO *f, PERLIO_FUNCS_DECL(*tab), const char *mode, SV *arg) 167931 { 167931 if (tab->fsize != sizeof(PerlIO_funcs)) { mismatch: ###### Perl_croak(aTHX_ "Layer does not match this perl"); } 167931 if (tab->size) { 156622 PerlIOl *l; 156622 if (tab->size < sizeof(PerlIOl)) { ###### goto mismatch; } /* Real layer with a data area */ 156622 Newc('L',l,tab->size,char,PerlIOl); 156622 if (l && f) { 156622 Zero(l, tab->size, char); 156622 l->next = *f; 156622 l->tab = (PerlIO_funcs*) tab; 156622 *f = l; 156622 PerlIO_debug("PerlIO_push f=%p %s %s %p\n", (void*)f, tab->name, (mode) ? mode : "(Null)", (void*)arg); 156622 if (*l->tab->Pushed && (*l->tab->Pushed) (aTHX_ f, mode, arg, (PerlIO_funcs*) tab) != 0) { 7 PerlIO_pop(aTHX_ f); 7 return NULL; } } } 11309 else if (f) { /* Pseudo-layer where push does its own stack adjust */ 11309 PerlIO_debug("PerlIO_push f=%p %s %s %p\n", (void*)f, tab->name, (mode) ? mode : "(Null)", (void*)arg); 11309 if (tab->Pushed && (*tab->Pushed) (aTHX_ f, mode, arg, (PerlIO_funcs*) tab) != 0) { ###### return NULL; } } 167924 return f; } IV PerlIOBase_binmode(pTHX_ PerlIO *f) 20668 { 20668 if (PerlIOValid(f)) { /* Is layer suitable for raw stream ? */ 20668 if (PerlIOBase(f)->tab->kind & PERLIO_K_RAW) { /* Yes - turn off UTF-8-ness, to undo UTF-8 locale effects */ 20668 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8; } else { /* Not suitable - pop it */ ###### PerlIO_pop(aTHX_ f); } 20668 return 0; } ###### return -1; } IV PerlIORaw_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab) 10333 { 10333 PERL_UNUSED_ARG(mode); 10333 PERL_UNUSED_ARG(arg); 10333 PERL_UNUSED_ARG(tab); 10333 if (PerlIOValid(f)) { 10333 PerlIO *t; 10333 const PerlIOl *l; 10333 PerlIO_flush(f); /* * Strip all layers that are not suitable for a raw stream */ 10333 t = f; 31014 while (t && (l = *t)) { 20681 if (l->tab->Binmode) { /* Has a handler - normal case */ 20671 if ((*l->tab->Binmode)(aTHX_ f) == 0) { 20671 if (*t == l) { /* Layer still there - move down a layer */ 20668 t = PerlIONext(t); } } else { ###### return -1; } } else { /* No handler - pop it */ 10 PerlIO_pop(aTHX_ t); } } 10333 if (PerlIOValid(f)) { 10333 PerlIO_debug(":raw f=%p :%s\n", (void*)f, PerlIOBase(f)->tab->name); 10333 return 0; } } ###### return -1; } int PerlIO_apply_layera(pTHX_ PerlIO *f, const char *mode, PerlIO_list_t *layers, IV n, IV max) 1036 { 1036 int code = 0; 2102 while (n < max) { 1066 PerlIO_funcs * const tab = PerlIO_layer_fetch(aTHX_ layers, n, NULL); 1066 if (tab) { 1066 if (!PerlIO_push(aTHX_ f, tab, mode, PerlIOArg)) { ###### code = -1; ###### break; } } 1066 n++; } 1036 return code; } int PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names) 992 { 992 int code = 0; 992 if (f && names) { 992 PerlIO_list_t * const layers = PerlIO_list_alloc(aTHX); 992 code = PerlIO_parse_layers(aTHX_ layers, names); 992 if (code == 0) { 990 code = PerlIO_apply_layera(aTHX_ f, mode, layers, 0, layers->cur); } 992 PerlIO_list_free(aTHX_ layers); } 992 return code; } /*--------------------------------------------------------------------------------------*/ /* * Given the abstraction above the public API functions */ int PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names) 11276 { 11276 PerlIO_debug("PerlIO_binmode f=%p %s %c %x %s\n", (void*)f, PerlIOBase(f)->tab->name, iotype, mode, (names) ? names : "(Null)"); 11276 if (names) { /* Do not flush etc. if (e.g.) switching encodings. if a pushed layer knows it needs to flush lower layers (for example :unix which is never going to call them) it can do the flush when it is pushed. */ 983 return PerlIO_apply_layers(aTHX_ f, NULL, names) == 0 ? TRUE : FALSE; } else { /* Fake 5.6 legacy of using this call to turn ON O_TEXT */ #ifdef PERLIO_USING_CRLF /* Legacy binmode only has meaning if O_TEXT has a value distinct from O_BINARY so we can look for it in mode. */ if (!(mode & O_BINARY)) { /* Text mode */ /* FIXME?: Looking down the layer stack seems wrong, but is a way of reaching past (say) an encoding layer to flip CRLF-ness of the layer(s) below */ while (*f) { /* Perhaps we should turn on bottom-most aware layer e.g. Ilya's idea that UNIX TTY could serve */ if (PerlIOBase(f)->tab->kind & PERLIO_K_CANCRLF) { if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF)) { /* Not in text mode - flush any pending stuff and flip it */ PerlIO_flush(f); PerlIOBase(f)->flags |= PERLIO_F_CRLF; } /* Only need to turn it on in one layer so we are done */ return TRUE; } f = PerlIONext(f); } /* Not finding a CRLF aware layer presumably means we are binary which is not what was requested - so we failed We _could_ push :crlf layer but so could caller */ return FALSE; } #endif /* Legacy binmode is now _defined_ as being equivalent to pushing :raw So code that used to be here is now in PerlIORaw_pushed(). */ 10293 return PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_raw), Nullch, Nullsv) ? TRUE : FALSE; } } int PerlIO__close(pTHX_ PerlIO *f) 78959 { 78959 if (PerlIOValid(f)) { 78958 PerlIO_funcs *tab = PerlIOBase(f)->tab; 78958 if (tab && tab->Close) 78958 return (*tab->Close)(aTHX_ f); else ###### return PerlIOBase_close(aTHX_ f); } else { 1 SETERRNO(EBADF, SS_IVCHAN); 1 return -1; } } int Perl_PerlIO_close(pTHX_ PerlIO *f) 78959 { 78959 const int code = PerlIO__close(aTHX_ f); 236001 while (PerlIOValid(f)) { 157042 PerlIO_pop(aTHX_ f); } 78959 return code; } int Perl_PerlIO_fileno(pTHX_ PerlIO *f) 400431 { 400431 Perl_PerlIO_or_Base(f, Fileno, fileno, -1, (aTHX_ f)); } static const char * PerlIO_context_layers(pTHX_ const char *mode) 82959 { 82959 const char *type = NULL; /* * Need to supply default layer info from open.pm */ 82959 if (PL_curcop) { 82959 SV *layers = PL_curcop->cop_io; 82959 if (layers) { 7 STRLEN len; 7 type = SvPV_const(layers, len); 7 if (type && mode[0] != 'r') { /* * Skip to write part */ 3 const char *s = strchr(type, 0); 3 if (s && (STRLEN)(s - type) < len) { 3 type = s + 1; } } } } 82959 return type; } static PerlIO_funcs * PerlIO_layer_from_ref(pTHX_ SV *sv) 937 { /* * For any scalar type load the handler which is bundled with perl */ 937 if (SvTYPE(sv) < SVt_PVAV) 937 return PerlIO_find_layer(aTHX_ "scalar", 6, 1); /* * For other types allow if layer is known but don't try and load it */ ###### switch (SvTYPE(sv)) { case SVt_PVAV: ###### return PerlIO_find_layer(aTHX_ "Array", 5, 0); case SVt_PVHV: ###### return PerlIO_find_layer(aTHX_ "Hash", 4, 0); case SVt_PVCV: ###### return PerlIO_find_layer(aTHX_ "Code", 4, 0); case SVt_PVGV: ###### return PerlIO_find_layer(aTHX_ "Glob", 4, 0); } ###### return NULL; } PerlIO_list_t * PerlIO_resolve_layers(pTHX_ const char *layers, const char *mode, int narg, SV **args) 84187 { 84187 PerlIO_list_t *def = PerlIO_default_layers(aTHX); 84187 int incdef = 1; 84187 if (!PL_perlio) 4481 PerlIO_stdstreams(aTHX); 84187 if (narg) { 65559 SV *arg = *args; /* * If it is a reference but not an object see if we have a handler * for it */ 65559 if (SvROK(arg) && !sv_isobject(arg)) { 937 PerlIO_funcs *handler = PerlIO_layer_from_ref(aTHX_ SvRV(arg)); 937 if (handler) { 937 def = PerlIO_list_alloc(aTHX); 937 PerlIO_list_push(aTHX_ def, handler, &PL_sv_undef); 937 incdef = 0; } /* * Don't fail if handler cannot be found :via(...) etc. may do * something sensible else we will just stringfy and open * resulting string. */ } } 84187 if (!layers) 82959 layers = PerlIO_context_layers(aTHX_ mode); 84187 if (layers && *layers) { 143 PerlIO_list_t *av; 143 if (incdef) { 142 IV i; 142 av = PerlIO_list_alloc(aTHX); 426 for (i = 0; i < def->cur; i++) { 284 PerlIO_list_push(aTHX_ av, def->array[i].funcs, def->array[i].arg); } } else { 1 av = def; } 143 if (PerlIO_parse_layers(aTHX_ av, layers) == 0) { 131 return av; } else { 12 PerlIO_list_free(aTHX_ av); 12 return (PerlIO_list_t *) NULL; } } else { 84044 if (incdef) 83108 def->refcnt++; 84044 return def; } } PerlIO * PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd, int imode, int perm, PerlIO *f, int narg, SV **args) 84191 { 84191 if (!f && narg == 1 && *args == &PL_sv_undef) { 4 if ((f = PerlIO_tmpfile())) { 4 if (!layers) ###### layers = PerlIO_context_layers(aTHX_ mode); 4 if (layers && *layers) ###### PerlIO_apply_layers(aTHX_ f, mode, layers); } } else { 84187 PerlIO_list_t *layera; 84187 IV n; 84187 PerlIO_funcs *tab = NULL; 84187 if (PerlIOValid(f)) { /* * This is "reopen" - it is not tested as perl does not use it * yet */ ###### PerlIOl *l = *f; ###### layera = PerlIO_list_alloc(aTHX); ###### while (l) { ###### SV *arg = (l->tab->Getarg) ? (*l->tab->Getarg) (aTHX_ &l, NULL, 0) ###### : &PL_sv_undef; ###### PerlIO_list_push(aTHX_ layera, l->tab, arg); ###### l = *PerlIONext(&l); } } else { 84187 layera = PerlIO_resolve_layers(aTHX_ layers, mode, narg, args); 84187 if (!layera) { 12 return NULL; } } /* * Start at "top" of layer stack */ 84175 n = layera->cur - 1; 84221 while (n >= 0) { 84221 PerlIO_funcs *t = PerlIO_layer_fetch(aTHX_ layera, n, NULL); 84221 if (t && t->Open) { 84175 tab = t; 84175 break; } 46 n--; } 84175 if (tab) { /* * Found that layer 'n' can do opens - call it */ 84175 if (narg > 1 && !(tab->kind & PERLIO_K_MULTIARG)) { ###### Perl_croak(aTHX_ "More than one argument to open(,':%s')",tab->name); } 84175 PerlIO_debug("openn(%s,'%s','%s',%d,%x,%o,%p,%d,%p)\n", tab->name, layers, mode, fd, imode, perm, (void*)f, narg, (void*)args); 84175 if (tab->Open) 84175 f = (*tab->Open) (aTHX_ tab, layera, n, mode, fd, imode, perm, f, narg, args); else { ###### SETERRNO(EINVAL, LIB_INVARG); ###### f = NULL; } 84175 if (f) { 77237 if (n + 1 < layera->cur) { /* * More layers above the one that we used to open - * apply them now */ 46 if (PerlIO_apply_layera(aTHX_ f, mode, layera, n + 1, layera->cur) != 0) { /* If pushing layers fails close the file */ ###### PerlIO_close(f); ###### f = NULL; } } } } 84175 PerlIO_list_free(aTHX_ layera); } 84179 return f; } SSize_t Perl_PerlIO_read(pTHX_ PerlIO *f, void *vbuf, Size_t count) 508610 { 508610 Perl_PerlIO_or_Base(f, Read, read, -1, (aTHX_ f, vbuf, count)); } SSize_t Perl_PerlIO_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count) 7437 { 7437 Perl_PerlIO_or_Base(f, Unread, unread, -1, (aTHX_ f, vbuf, count)); } SSize_t Perl_PerlIO_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count) 1318615 { 1318615 Perl_PerlIO_or_fail(f, Write, -1, (aTHX_ f, vbuf, count)); } int Perl_PerlIO_seek(pTHX_ PerlIO *f, Off_t offset, int whence) 77937 { 77937 Perl_PerlIO_or_fail(f, Seek, -1, (aTHX_ f, offset, whence)); } Off_t Perl_PerlIO_tell(pTHX_ PerlIO *f) 1886891 { 1886891 Perl_PerlIO_or_fail(f, Tell, -1, (aTHX_ f)); } int Perl_PerlIO_flush(pTHX_ PerlIO *f) 1113344 { 1113344 if (f) { 1104217 if (*f) { 1104213 const PerlIO_funcs *tab = PerlIOBase(f)->tab; 1104213 if (tab && tab->Flush) 1104213 return (*tab->Flush) (aTHX_ f); else ###### return 0; /* If no Flush defined, silently succeed. */ } else { 4 PerlIO_debug("Cannot flush f=%p\n", (void*)f); 4 SETERRNO(EBADF, SS_IVCHAN); 4 return -1; } } else { /* * Is it good API design to do flush-all on NULL, a potentially * errorneous input? Maybe some magical value (PerlIO* * PERLIO_FLUSH_ALL = (PerlIO*)-1;)? Yes, stdio does similar * things on fflush(NULL), but should we be bound by their design * decisions? --jhi */ 9127 PerlIO **table = &PL_perlio; 9127 int code = 0; 18251 while ((f = *table)) { 9124 int i; 9124 table = (PerlIO **) (f++); 583936 for (i = 1; i < PERLIO_TABLE_SIZE; i++) { 574812 if (*f && PerlIO_flush(f) != 0) ###### code = -1; 574812 f++; } } 9127 return code; } } void PerlIOBase_flush_linebuf(pTHX) 9 { 9 PerlIO **table = &PL_perlio; 18 PerlIO *f; 18 while ((f = *table)) { 9 int i; 9 table = (PerlIO **) (f++); 576 for (i = 1; i < PERLIO_TABLE_SIZE; i++) { 567 if (*f && (PerlIOBase(f)-> flags & (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE)) == (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE)) 13 PerlIO_flush(f); 567 f++; } } } int Perl_PerlIO_fill(pTHX_ PerlIO *f) 244516 { 244516 Perl_PerlIO_or_fail(f, Fill, -1, (aTHX_ f)); } int PerlIO_isutf8(PerlIO *f) 13412227 { 13412227 if (PerlIOValid(f)) 13412227 return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0; else ###### SETERRNO(EBADF, SS_IVCHAN); ###### return -1; } int Perl_PerlIO_eof(pTHX_ PerlIO *f) 3749 { 3749 Perl_PerlIO_or_Base(f, Eof, eof, -1, (aTHX_ f)); } int Perl_PerlIO_error(pTHX_ PerlIO *f) 1207558 { 1207558 Perl_PerlIO_or_Base(f, Error, error, -1, (aTHX_ f)); } void Perl_PerlIO_clearerr(pTHX_ PerlIO *f) 7760 { 7760 Perl_PerlIO_or_Base_void(f, Clearerr, clearerr, (aTHX_ f)); } void Perl_PerlIO_setlinebuf(pTHX_ PerlIO *f) ###### { ###### Perl_PerlIO_or_Base_void(f, Setlinebuf, setlinebuf, (aTHX_ f)); } int PerlIO_has_base(PerlIO *f) 11 { 11 if (PerlIOValid(f)) { 11 const PerlIO_funcs *tab = PerlIOBase(f)->tab; 11 if (tab) 11 return (tab->Get_base != NULL); ###### SETERRNO(EINVAL, LIB_INVARG); } else ###### SETERRNO(EBADF, SS_IVCHAN); ###### return 0; } int PerlIO_fast_gets(PerlIO *f) 11376159 { 11376159 if (PerlIOValid(f) && (PerlIOBase(f)->flags & PERLIO_F_FASTGETS)) { 11132035 const PerlIO_funcs *tab = PerlIOBase(f)->tab; 11132035 if (tab) 11132035 return (tab->Set_ptrcnt != NULL); ###### SETERRNO(EINVAL, LIB_INVARG); } else 244124 SETERRNO(EBADF, SS_IVCHAN); 244124 return 0; } int PerlIO_has_cntptr(PerlIO *f) 1575 { 1575 if (PerlIOValid(f)) { 1575 const PerlIO_funcs *tab = PerlIOBase(f)->tab; 1575 if (tab) 1575 return (tab->Get_ptr != NULL && tab->Get_cnt != NULL); ###### SETERRNO(EINVAL, LIB_INVARG); } else ###### SETERRNO(EBADF, SS_IVCHAN); ###### return 0; } int PerlIO_canset_cnt(PerlIO *f) 49 { 49 if (PerlIOValid(f)) { 49 const PerlIO_funcs *tab = PerlIOBase(f)->tab; 49 if (tab) 49 return (tab->Set_ptrcnt != NULL); ###### SETERRNO(EINVAL, LIB_INVARG); } else ###### SETERRNO(EBADF, SS_IVCHAN); ###### return 0; } STDCHAR * Perl_PerlIO_get_base(pTHX_ PerlIO *f) 351986 { 351986 Perl_PerlIO_or_fail(f, Get_base, NULL, (aTHX_ f)); } int Perl_PerlIO_get_bufsiz(pTHX_ PerlIO *f) 9 { 9 Perl_PerlIO_or_fail(f, Get_bufsiz, -1, (aTHX_ f)); } STDCHAR * Perl_PerlIO_get_ptr(pTHX_ PerlIO *f) 11606560 { 11606560 Perl_PerlIO_or_fail(f, Get_ptr, NULL, (aTHX_ f)); } int Perl_PerlIO_get_cnt(pTHX_ PerlIO *f) 23412647 { 23412647 Perl_PerlIO_or_fail(f, Get_cnt, -1, (aTHX_ f)); } void Perl_PerlIO_set_cnt(pTHX_ PerlIO *f, int cnt) ###### { ###### Perl_PerlIO_or_fail_void(f, Set_ptrcnt, (aTHX_ f, NULL, cnt)); } void Perl_PerlIO_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, int cnt) 11606552 { 11606552 Perl_PerlIO_or_fail_void(f, Set_ptrcnt, (aTHX_ f, ptr, cnt)); } /*--------------------------------------------------------------------------------------*/ /* * utf8 and raw dummy layers */ IV PerlIOUtf8_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab) 975 { 975 PERL_UNUSED_ARG(mode); 975 PERL_UNUSED_ARG(arg); 975 if (PerlIOValid(f)) { 975 if (tab->kind & PERLIO_K_UTF8) 911 PerlIOBase(f)->flags |= PERLIO_F_UTF8; else 64 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8; 975 return 0; } ###### return -1; } PERLIO_FUNCS_DECL(PerlIO_utf8) = { sizeof(PerlIO_funcs), "utf8", 0, PERLIO_K_DUMMY | PERLIO_K_UTF8, PerlIOUtf8_pushed, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, /* flush */ NULL, /* fill */ NULL, NULL, NULL, NULL, NULL, /* get_base */ NULL, /* get_bufsiz */ NULL, /* get_ptr */ NULL, /* get_cnt */ NULL, /* set_ptrcnt */ }; PERLIO_FUNCS_DECL(PerlIO_byte) = { sizeof(PerlIO_funcs), "bytes", 0, PERLIO_K_DUMMY, PerlIOUtf8_pushed, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, /* flush */ NULL, /* fill */ NULL, NULL, NULL, NULL, NULL, /* get_base */ NULL, /* get_bufsiz */ NULL, /* get_ptr */ NULL, /* get_cnt */ NULL, /* set_ptrcnt */ }; PerlIO * PerlIORaw_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, IV n, const char *mode, int fd, int imode, int perm, PerlIO *old, int narg, SV **args) 19 { 19 PerlIO_funcs * const tab = PerlIO_default_btm(); 19 PERL_UNUSED_ARG(self); 19 if (tab && tab->Open) 19 return (*tab->Open) (aTHX_ tab, layers, n - 1, mode, fd, imode, perm, old, narg, args); ###### SETERRNO(EINVAL, LIB_INVARG); ###### return NULL; } PERLIO_FUNCS_DECL(PerlIO_raw) = { sizeof(PerlIO_funcs), "raw", 0, PERLIO_K_DUMMY, PerlIORaw_pushed, PerlIOBase_popped, PerlIORaw_open, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, /* flush */ NULL, /* fill */ NULL, NULL, NULL, NULL, NULL, /* get_base */ NULL, /* get_bufsiz */ NULL, /* get_ptr */ NULL, /* get_cnt */ NULL, /* set_ptrcnt */ }; /*--------------------------------------------------------------------------------------*/ /*--------------------------------------------------------------------------------------*/ /* * "Methods" of the "base class" */ IV PerlIOBase_fileno(pTHX_ PerlIO *f) 199852 { 199852 return PerlIOValid(f) ? PerlIO_fileno(PerlIONext(f)) : -1; } char * PerlIO_modestr(PerlIO * f, char *buf) 2967 { 2967 char *s = buf; 2967 if (PerlIOValid(f)) { 2967 const IV flags = PerlIOBase(f)->flags; 2967 if (flags & PERLIO_F_APPEND) { ###### *s++ = 'a'; ###### if (flags & PERLIO_F_CANREAD) { ###### *s++ = '+'; } } 2967 else if (flags & PERLIO_F_CANREAD) { 11 *s++ = 'r'; 11 if (flags & PERLIO_F_CANWRITE) 1 *s++ = '+'; } 2956 else if (flags & PERLIO_F_CANWRITE) { 2956 *s++ = 'w'; 2956 if (flags & PERLIO_F_CANREAD) { ###### *s++ = '+'; } } #ifdef PERLIO_USING_CRLF if (!(flags & PERLIO_F_CRLF)) *s++ = 'b'; #endif } 2967 *s = '\0'; 2967 return buf; } IV PerlIOBase_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab) 156622 { 156622 PerlIOl * const l = PerlIOBase(f); 156622 PERL_UNUSED_ARG(arg); 156622 l->flags &= ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_TRUNCATE | PERLIO_F_APPEND); 156622 if (tab->Set_ptrcnt != NULL) 78835 l->flags |= PERLIO_F_FASTGETS; 156622 if (mode) { 156572 if (*mode == IoTYPE_NUMERIC || *mode == IoTYPE_IMPLICIT) 16557 mode++; 156572 switch (*mode++) { case 'r': 120356 l->flags |= PERLIO_F_CANREAD; 120356 break; case 'a': 75 l->flags |= PERLIO_F_APPEND | PERLIO_F_CANWRITE; 75 break; case 'w': 36141 l->flags |= PERLIO_F_TRUNCATE | PERLIO_F_CANWRITE; 36141 break; default: ###### SETERRNO(EINVAL, LIB_INVARG); ###### return -1; } 162650 while (*mode) { 6078 switch (*mode++) { case '+': 6078 l->flags |= PERLIO_F_CANREAD | PERLIO_F_CANWRITE; 6078 break; case 'b': ###### l->flags &= ~PERLIO_F_CRLF; ###### break; case 't': ###### l->flags |= PERLIO_F_CRLF; ###### break; default: ###### SETERRNO(EINVAL, LIB_INVARG); ###### return -1; } } } else { 50 if (l->next) { 50 l->flags |= l->next->flags & (PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_TRUNCATE | PERLIO_F_APPEND); } } #if 0 PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08" UVxf " (%s)\n", f, PerlIOBase(f)->tab->name, (omode) ? omode : "(Null)", l->flags, PerlIO_modestr(f, temp)); #endif 156622 return 0; } IV PerlIOBase_popped(pTHX_ PerlIO *f) 156040 { 156040 PERL_UNUSED_ARG(f); 156040 return 0; } SSize_t PerlIOBase_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count) ###### { /* * Save the position as current head considers it */ ###### const Off_t old = PerlIO_tell(f); ###### PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_pending), "r", Nullsv); ###### PerlIOSelf(f, PerlIOBuf)->posn = old; ###### return PerlIOBuf_unread(aTHX_ f, vbuf, count); } SSize_t PerlIOBase_read(pTHX_ PerlIO *f, void *vbuf, Size_t count) 264479 { 264479 STDCHAR *buf = (STDCHAR *) vbuf; 264479 if (f) { 264479 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD)) { 10 PerlIOBase(f)->flags |= PERLIO_F_ERROR; 10 SETERRNO(EBADF, SS_IVCHAN); 10 return 0; } 693017 while (count > 0) { 468517 SSize_t avail = PerlIO_get_cnt(f); 468517 SSize_t take = 0; 468517 if (avail > 0) 232910 take = ((SSize_t)count < avail) ? count : avail; 468517 if (take > 0) { 232910 STDCHAR *ptr = PerlIO_get_ptr(f); 232910 Copy(ptr, buf, take, STDCHAR); 232910 PerlIO_set_ptrcnt(f, ptr + take, (avail -= take)); 232910 count -= take; 232910 buf += take; } 468517 if (count > 0 && avail <= 0) { 244341 if (PerlIO_fill(f) != 0) 264468 break; } } 264468 return (buf - (STDCHAR *) vbuf); } ###### return 0; } IV PerlIOBase_noop_ok(pTHX_ PerlIO *f) 550317 { 550317 PERL_UNUSED_ARG(f); 550317 return 0; } IV PerlIOBase_noop_fail(pTHX_ PerlIO *f) ###### { ###### PERL_UNUSED_ARG(f); ###### return -1; } IV PerlIOBase_close(pTHX_ PerlIO *f) 79018 { 79018 IV code = -1; 79018 if (PerlIOValid(f)) { 79018 PerlIO *n = PerlIONext(f); 79018 code = PerlIO_flush(f); 79018 PerlIOBase(f)->flags &= ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN); 79018 while (PerlIOValid(n)) { 78080 const PerlIO_funcs * const tab = PerlIOBase(n)->tab; 78080 if (tab && tab->Close) { 78080 if ((*tab->Close)(aTHX_ n) != 0) 2 code = -1; 2 break; } else { ###### PerlIOBase(n)->flags &= ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN); } ###### n = PerlIONext(n); } } else { ###### SETERRNO(EBADF, SS_IVCHAN); } 79018 return code; } IV PerlIOBase_eof(pTHX_ PerlIO *f) 3749 { 3749 if (PerlIOValid(f)) { 3749 return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0; } ###### return 1; } IV PerlIOBase_error(pTHX_ PerlIO *f) 1207557 { 1207557 if (PerlIOValid(f)) { 1207557 return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0; } ###### return 1; } void PerlIOBase_clearerr(pTHX_ PerlIO *f) 7760 { 7760 if (PerlIOValid(f)) { 7760 PerlIO *n = PerlIONext(f); 7760 PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR | PERLIO_F_EOF); 7760 if (PerlIOValid(n)) 3891 PerlIO_clearerr(n); } } void PerlIOBase_setlinebuf(pTHX_ PerlIO *f) ###### { ###### if (PerlIOValid(f)) { ###### PerlIOBase(f)->flags |= PERLIO_F_LINEBUF; } } SV * PerlIO_sv_dup(pTHX_ SV *arg, CLONE_PARAMS *param) 2 { 2 if (!arg) ###### return Nullsv; #ifdef sv_dup if (param) { return sv_dup(arg, param); } else { return newSVsv(arg); } #else 2 PERL_UNUSED_ARG(param); 2 return newSVsv(arg); #endif } PerlIO * PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags) 2967 { 2967 PerlIO * const nexto = PerlIONext(o); 2967 if (PerlIOValid(nexto)) { 1484 const PerlIO_funcs * const tab = PerlIOBase(nexto)->tab; 1484 if (tab && tab->Dup) 1484 f = (*tab->Dup)(aTHX_ f, nexto, param, flags); else ###### f = PerlIOBase_dup(aTHX_ f, nexto, param, flags); } 2967 if (f) { 2967 PerlIO_funcs *self = PerlIOBase(o)->tab; 2967 SV *arg; 2967 char buf[8]; 2967 PerlIO_debug("PerlIOBase_dup %s f=%p o=%p param=%p\n", self->name, (void*)f, (void*)o, (void*)param); 2967 if (self->Getarg) 3 arg = (*self->Getarg)(aTHX_ o, param, flags); else { 2964 arg = Nullsv; } 2967 f = PerlIO_push(aTHX_ f, self, PerlIO_modestr(o,buf), arg); 2967 if (arg) { 3 SvREFCNT_dec(arg); } } 2967 return f; } #ifdef USE_THREADS perl_mutex PerlIO_mutex; #endif /* PL_perlio_fd_refcnt[] is in intrpvar.h */ void PerlIO_init(pTHX) 4503 { /* Place holder for stdstreams call ??? */ #ifdef USE_THREADS MUTEX_INIT(&PerlIO_mutex); #endif } void PerlIOUnix_refcnt_inc(int fd) 91433 { dTHX; 91433 if (fd >= 0 && fd < PERLIO_MAX_REFCOUNTABLE_FD) { #ifdef USE_THREADS MUTEX_LOCK(&PerlIO_mutex); #endif 91433 PL_perlio_fd_refcnt[fd]++; 91433 PerlIO_debug("fd %d refcnt=%d\n",fd,PL_perlio_fd_refcnt[fd]); #ifdef USE_THREADS MUTEX_UNLOCK(&PerlIO_mutex); #endif } } int PerlIOUnix_refcnt_dec(int fd) 91667 { dTHX; 91667 int cnt = 0; 91667 if (fd >= 0 && fd < PERLIO_MAX_REFCOUNTABLE_FD) { #ifdef USE_THREADS MUTEX_LOCK(&PerlIO_mutex); #endif 91667 cnt = --PL_perlio_fd_refcnt[fd]; 91667 PerlIO_debug("fd %d refcnt=%d\n",fd,cnt); #ifdef USE_THREADS MUTEX_UNLOCK(&PerlIO_mutex); #endif } 91667 return cnt; } void PerlIO_cleanup(pTHX) 4549 { 4549 int i; #ifdef USE_ITHREADS PerlIO_debug("Cleanup layers for %p\n",aTHX); #else 4549 PerlIO_debug("Cleanup layers\n"); #endif /* Raise STDIN..STDERR refcount so we don't close them */ 18196 for (i=0; i < 3; i++) 13647 PerlIOUnix_refcnt_inc(i); 4549 PerlIO_cleantable(aTHX_ &PL_perlio); /* Restore STDIN..STDERR refcount */ 18196 for (i=0; i < 3; i++) 13647 PerlIOUnix_refcnt_dec(i); 4549 if (PL_known_layers) { 4549 PerlIO_list_free(aTHX_ PL_known_layers); 4549 PL_known_layers = NULL; } 4549 if (PL_def_layerlist) { 4549 PerlIO_list_free(aTHX_ PL_def_layerlist); 4549 PL_def_layerlist = NULL; } } /*--------------------------------------------------------------------------------------*/ /* * Bottom-most level for UNIX-like case */ typedef struct { struct _PerlIO base; /* The generic part */ int fd; /* UNIX like file descriptor */ int oflags; /* open/fcntl flags */ } PerlIOUnix; int PerlIOUnix_oflags(const char *mode) 61552 { 61552 int oflags = -1; 61552 if (*mode == IoTYPE_IMPLICIT || *mode == IoTYPE_NUMERIC) ###### mode++; 61552 switch (*mode) { case 'r': 55112 oflags = O_RDONLY; 55112 if (*++mode == '+') { 3 oflags = O_RDWR; 3 mode++; } 3 break; case 'w': 6402 oflags = O_CREAT | O_TRUNC; 6402 if (*++mode == '+') { 8 oflags |= O_RDWR; 8 mode++; } else 6394 oflags |= O_WRONLY; 6394 break; case 'a': 38 oflags = O_CREAT | O_APPEND; 38 if (*++mode == '+') { 1 oflags |= O_RDWR; 1 mode++; } else 37 oflags |= O_WRONLY; break; } 61552 if (*mode == 'b') { ###### oflags |= O_BINARY; ###### oflags &= ~O_TEXT; ###### mode++; } 61552 else if (*mode == 't') { ###### oflags |= O_TEXT; ###### oflags &= ~O_BINARY; ###### mode++; } /* * Always open in binary mode */ 61552 oflags |= O_BINARY; 61552 if (*mode || oflags == -1) { ###### SETERRNO(EINVAL, LIB_INVARG); ###### oflags = -1; } 61552 return oflags; } IV PerlIOUnix_fileno(pTHX_ PerlIO *f) 199630 { 199630 return PerlIOSelf(f, PerlIOUnix)->fd; } static void PerlIOUnix_setfd(pTHX_ PerlIO *f, int fd, int imode) 77786 { 77786 PerlIOUnix * const s = PerlIOSelf(f, PerlIOUnix); #if defined(WIN32) Stat_t st; if (PerlLIO_fstat(fd, &st) == 0) { if (!S_ISREG(st.st_mode)) { PerlIO_debug("%d is not regular file\n",fd); PerlIOBase(f)->flags |= PERLIO_F_NOTREG; } else { PerlIO_debug("%d _is_ a regular file\n",fd); } } #endif 77786 s->fd = fd; 77786 s->oflags = imode; 77786 PerlIOUnix_refcnt_inc(fd); } IV PerlIOUnix_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab) 77786 { 77786 IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab); 77786 if (*PerlIONext(f)) { /* We never call down so do any pending stuff now */ 2 PerlIO_flush(PerlIONext(f)); /* * XXX could (or should) we retrieve the oflags from the open file * handle rather than believing the "mode" we are passed in? XXX * Should the value on NULL mode be 0 or -1? */ 2 PerlIOUnix_setfd(aTHX_ f, PerlIO_fileno(PerlIONext(f)), mode ? PerlIOUnix_oflags(mode) : -1); } 77786 PerlIOBase(f)->flags |= PERLIO_F_OPEN; 77786 return code; } IV PerlIOUnix_seek(pTHX_ PerlIO *f, Off_t offset, int whence) 48925 { 48925 const int fd = PerlIOSelf(f, PerlIOUnix)->fd; 48925 Off_t new_loc; 48925 if (PerlIOBase(f)->flags & PERLIO_F_NOTREG) { #ifdef ESPIPE ###### SETERRNO(ESPIPE, LIB_INVARG); #else SETERRNO(EINVAL, LIB_INVARG); #endif ###### return -1; } 48925 new_loc = PerlLIO_lseek(fd, offset, whence); 48925 if (new_loc == (Off_t) - 1) { 12 return -1; } 48913 PerlIOBase(f)->flags &= ~PERLIO_F_EOF; 48913 return 0; } PerlIO * PerlIOUnix_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, IV n, const char *mode, int fd, int imode, int perm, PerlIO *f, int narg, SV **args) 83233 { 83233 if (PerlIOValid(f)) { ###### if (PerlIOBase(f)->flags & PERLIO_F_OPEN) ###### (*PerlIOBase(f)->tab->Close)(aTHX_ f); } 83233 if (narg > 0) { 64605 if (*mode == IoTYPE_NUMERIC) 3053 mode++; else { 61552 imode = PerlIOUnix_oflags(mode); 61552 perm = 0666; } 64605 if (imode != -1) { 64605 const char *path = SvPV_nolen_const(*args); 64605 fd = PerlLIO_open3(path, imode, perm); } } 83233 if (fd >= 0) { 76302 if (*mode == IoTYPE_IMPLICIT) 13509 mode++; 76302 if (!f) { 76298 f = PerlIO_allocate(aTHX); } 76302 if (!PerlIOValid(f)) { 76302 if (!(f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) { ###### return NULL; } } 76302 PerlIOUnix_setfd(aTHX_ f, fd, imode); 76302 PerlIOBase(f)->flags |= PERLIO_F_OPEN; 76302 if (*mode == IoTYPE_APPEND) 37 PerlIOUnix_seek(aTHX_ f, 0, SEEK_END); 76302 return f; } else { 6931 if (f) { /* * FIXME: pop layers ??? */ } 6931 return NULL; } } PerlIO * PerlIOUnix_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags) 1482 { 1482 PerlIOUnix *os = PerlIOSelf(o, PerlIOUnix); 1482 int fd = os->fd; 1482 if (flags & PERLIO_DUP_FD) { 1477 fd = PerlLIO_dup(fd); } 1482 if (fd >= 0 && fd < PERLIO_MAX_REFCOUNTABLE_FD) { 1482 f = PerlIOBase_dup(aTHX_ f, o, param, flags); 1482 if (f) { /* If all went well overwrite fd in dup'ed lay with the dup()'ed fd */ 1482 PerlIOUnix_setfd(aTHX_ f, fd, os->oflags); 1482 return f; } } ###### return NULL; } SSize_t PerlIOUnix_read(pTHX_ PerlIO *f, void *vbuf, Size_t count) 244131 { 244131 const int fd = PerlIOSelf(f, PerlIOUnix)->fd; #ifdef PERLIO_STD_SPECIAL if (fd == 0) return PERLIO_STD_IN(fd, vbuf, count); #endif 244131 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD) || PerlIOBase(f)->flags & (PERLIO_F_EOF|PERLIO_F_ERROR)) { 2173 return 0; } 241958 while (1) { 241958 const SSize_t len = PerlLIO_read(fd, vbuf, count); 241958 if (len >= 0 || errno != EINTR) { 241957 if (len < 0) { 2 if (errno != EAGAIN) { 2 PerlIOBase(f)->flags |= PERLIO_F_ERROR; } } 241955 else if (len == 0 && count != 0) { 37784 PerlIOBase(f)->flags |= PERLIO_F_EOF; 37784 SETERRNO(0,0); } 241957 return len; } 1 PERL_ASYNC_CHECK(); } /*NOTREACHED*/ } SSize_t PerlIOUnix_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count) 146040 { 146040 const int fd = PerlIOSelf(f, PerlIOUnix)->fd; #ifdef PERLIO_STD_SPECIAL if (fd == 1 || fd == 2) return PERLIO_STD_OUT(fd, vbuf, count); #endif 146040 while (1) { 146040 const SSize_t len = PerlLIO_write(fd, vbuf, count); 146040 if (len >= 0 || errno != EINTR) { 146040 if (len < 0) { 3 if (errno != EAGAIN) { 3 PerlIOBase(f)->flags |= PERLIO_F_ERROR; } } 146040 return len; } ###### PERL_ASYNC_CHECK(); } /*NOTREACHED*/ } Off_t PerlIOUnix_tell(pTHX_ PerlIO *f) 126660 { 126660 return PerlLIO_lseek(PerlIOSelf(f, PerlIOUnix)->fd, 0, SEEK_CUR); } IV PerlIOUnix_close(pTHX_ PerlIO *f) 78020 { 78020 const int fd = PerlIOSelf(f, PerlIOUnix)->fd; 78020 int code = 0; 78020 if (PerlIOBase(f)->flags & PERLIO_F_OPEN) { 78020 if (PerlIOUnix_refcnt_dec(fd) > 0) { 14269 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN; 14269 return 0; } } else { ###### SETERRNO(EBADF,SS_IVCHAN); ###### return -1; } 63751 while (PerlLIO_close(fd) != 0) { 2 if (errno != EINTR) { 2 code = -1; 2 break; } ###### PERL_ASYNC_CHECK(); } 63751 if (code == 0) { 63749 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN; } 63751 return code; } PERLIO_FUNCS_DECL(PerlIO_unix) = { sizeof(PerlIO_funcs), "unix", sizeof(PerlIOUnix), PERLIO_K_RAW, PerlIOUnix_pushed, PerlIOBase_popped, PerlIOUnix_open, PerlIOBase_binmode, /* binmode */ NULL, PerlIOUnix_fileno, PerlIOUnix_dup, PerlIOUnix_read, PerlIOBase_unread, PerlIOUnix_write, PerlIOUnix_seek, PerlIOUnix_tell, PerlIOUnix_close, PerlIOBase_noop_ok, /* flush */ PerlIOBase_noop_fail, /* fill */ PerlIOBase_eof, PerlIOBase_error, PerlIOBase_clearerr, PerlIOBase_setlinebuf, NULL, /* get_base */ NULL, /* get_bufsiz */ NULL, /* get_ptr */ NULL, /* get_cnt */ NULL, /* set_ptrcnt */ }; /*--------------------------------------------------------------------------------------*/ /* * stdio as a layer */ #if defined(VMS) && !defined(STDIO_BUFFER_WRITABLE) /* perl5.8 - This ensures the last minute VMS ungetc fix is not broken by the last second glibc 2.3 fix */ #define STDIO_BUFFER_WRITABLE #endif typedef struct { struct _PerlIO base; FILE *stdio; /* The stream */ } PerlIOStdio; IV PerlIOStdio_fileno(pTHX_ PerlIO *f) 1 { 1 FILE *s; 1 if (PerlIOValid(f) && (s = PerlIOSelf(f, PerlIOStdio)->stdio)) { 1 return PerlSIO_fileno(s); } ###### errno = EBADF; ###### return -1; } char * PerlIOStdio_mode(const char *mode, char *tmode) ###### { ###### char * const ret = tmode; ###### if (mode) { ###### while (*mode) { ###### *tmode++ = *mode++; } } #if defined(PERLIO_USING_CRLF) || defined(__CYGWIN__) *tmode++ = 'b'; #endif ###### *tmode = '\0'; ###### return ret; } IV PerlIOStdio_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab) 1 { 1 PerlIO *n; 1 if (PerlIOValid(f) && PerlIOValid(n = PerlIONext(f))) { ###### PerlIO_funcs *toptab = PerlIOBase(n)->tab; ###### if (toptab == tab) { /* Top is already stdio - pop self (duplicate) and use original */ ###### PerlIO_pop(aTHX_ f); ###### return 0; } else { ###### const int fd = PerlIO_fileno(n); ###### char tmode[8]; ###### FILE *stdio; ###### if (fd >= 0 && (stdio = PerlSIO_fdopen(fd, mode = PerlIOStdio_mode(mode, tmode)))) { ###### PerlIOSelf(f, PerlIOStdio)->stdio = stdio; /* We never call down so do any pending stuff now */ ###### PerlIO_flush(PerlIONext(f)); } else { ###### return -1; } } } 1 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab); } PerlIO * PerlIO_importFILE(FILE *stdio, const char *mode) 1 { dTHX; 1 PerlIO *f = NULL; 1 if (stdio) { 1 PerlIOStdio *s; 1 if (!mode || !*mode) { /* We need to probe to see how we can open the stream so start with read/write and then try write and read we dup() so that we can fclose without loosing the fd. Note that the errno value set by a failing fdopen varies between stdio implementations. */ 1 const int fd = PerlLIO_dup(fileno(stdio)); 1 FILE *f2 = PerlSIO_fdopen(fd, (mode = "r+")); 1 if (!f2) { 1 f2 = PerlSIO_fdopen(fd, (mode = "w")); } 1 if (!f2) { ###### f2 = PerlSIO_fdopen(fd, (mode = "r")); } 1 if (!f2) { /* Don't seem to be able to open */ ###### PerlLIO_close(fd); ###### return f; } 1 fclose(f2); } 1 if ((f = PerlIO_push(aTHX_(f = PerlIO_allocate(aTHX)), PERLIO_FUNCS_CAST(&PerlIO_stdio), mode, Nullsv))) { 1 s = PerlIOSelf(f, PerlIOStdio); 1 s->stdio = stdio; } } 1 return f; } PerlIO * PerlIOStdio_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, IV n, const char *mode, int fd, int imode, int perm, PerlIO *f, int narg, SV **args) ###### { ###### char tmode[8]; ###### if (PerlIOValid(f)) { ###### const char *path = SvPV_nolen_const(*args); ###### PerlIOStdio *s = PerlIOSelf(f, PerlIOStdio); ###### FILE *stdio; ###### PerlIOUnix_refcnt_dec(fileno(s->stdio)); ###### stdio = PerlSIO_freopen(path, (mode = PerlIOStdio_mode(mode, tmode)), s->stdio); ###### if (!s->stdio) ###### return NULL; ###### s->stdio = stdio; ###### PerlIOUnix_refcnt_inc(fileno(s->stdio)); ###### return f; } else { ###### if (narg > 0) { ###### const char *path = SvPV_nolen_const(*args); ###### if (*mode == IoTYPE_NUMERIC) { ###### mode++; ###### fd = PerlLIO_open3(path, imode, perm); } else { ###### FILE *stdio; ###### bool appended = FALSE; #ifdef __CYGWIN__ /* Cygwin wants its 'b' early. */ appended = TRUE; mode = PerlIOStdio_mode(mode, tmode); #endif ###### stdio = PerlSIO_fopen(path, mode); ###### if (stdio) { ###### PerlIOStdio *s; ###### if (!f) { ###### f = PerlIO_allocate(aTHX); } ###### if (!appended) ###### mode = PerlIOStdio_mode(mode, tmode); ###### f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg); ###### if (f) { ###### s = PerlIOSelf(f, PerlIOStdio); ###### s->stdio = stdio; ###### PerlIOUnix_refcnt_inc(fileno(s->stdio)); } ###### return f; } else { ###### return NULL; } } } ###### if (fd >= 0) { ###### FILE *stdio = NULL; ###### int init = 0; ###### if (*mode == IoTYPE_IMPLICIT) { ###### init = 1; ###### mode++; } ###### if (init) { ###### switch (fd) { case 0: ###### stdio = PerlSIO_stdin; ###### break; case 1: ###### stdio = PerlSIO_stdout; ###### break; case 2: ###### stdio = PerlSIO_stderr; ###### break; } } else { ###### stdio = PerlSIO_fdopen(fd, mode = PerlIOStdio_mode(mode, tmode)); } ###### if (stdio) { ###### if (!f) { ###### f = PerlIO_allocate(aTHX); } ###### if ((f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) { ###### PerlIOStdio *s = PerlIOSelf(f, PerlIOStdio); ###### s->stdio = stdio; ###### PerlIOUnix_refcnt_inc(fileno(s->stdio)); } ###### return f; } } } ###### return NULL; } PerlIO * PerlIOStdio_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags) ###### { /* This assumes no layers underneath - which is what happens, but is not how I remember it. NI-S 2001/10/16 */ ###### if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) { ###### FILE *stdio = PerlIOSelf(o, PerlIOStdio)->stdio; ###### const int fd = fileno(stdio); ###### char mode[8]; ###### if (flags & PERLIO_DUP_FD) { ###### const int dfd = PerlLIO_dup(fileno(stdio)); ###### if (dfd >= 0) { ###### stdio = PerlSIO_fdopen(dfd, PerlIO_modestr(o,mode)); ###### goto set_this; } else { /* FIXME: To avoid messy error recovery if dup fails re-use the existing stdio as though flag was not set */ } } ###### stdio = PerlSIO_fdopen(fd, PerlIO_modestr(o,mode)); set_this: ###### PerlIOSelf(f, PerlIOStdio)->stdio = stdio; ###### PerlIOUnix_refcnt_inc(fileno(stdio)); } ###### return f; } static int PerlIOStdio_invalidate_fileno(pTHX_ FILE *f) ###### { /* XXX this could use PerlIO_canset_fileno() and * PerlIO_set_fileno() support from Configure */ # if defined(__UCLIBC__) /* uClibc must come before glibc because it defines __GLIBC__ as well. */ f->__filedes = -1; return 1; # elif defined(__GLIBC__) /* There may be a better way for GLIBC: - libio.h defines a flag to not close() on cleanup */ ###### f->_fileno = -1; ###### return 1; # elif defined(__sun__) # if defined(_LP64) /* On solaris, if _LP64 is defined, the FILE structure is this: * * struct FILE { * long __pad[16]; * }; * * It turns out that the fd is stored in the top 32 bits of * file->__pad[4]. The lower 32 bits contain flags. file->pad[5] appears * to contain a pointer or offset into another structure. All the * remaining fields are zero. * * We set the top bits to -1 (0xFFFFFFFF). */ f->__pad[4] |= 0xffffffff00000000L; assert(fileno(f) == 0xffffffff); # else /* !defined(_LP64) */ /* _file is just a unsigned char :-( Not clear why we dup() rather than using -1 even if that would be treated as 0xFF - so will a dup fail ... */ f->_file = PerlLIO_dup(fileno(f)); # endif /* defined(_LP64) */ return 1; # elif defined(__hpux) f->__fileH = 0xff; f->__fileL = 0xff; return 1; /* Next one ->_file seems to be a reasonable fallback, i.e. if your platform does not have special entry try this one. [For OSF only have confirmation for Tru64 (alpha) but assume other OSFs will be similar.] */ # elif defined(_AIX) || defined(__osf__) || defined(__irix__) f->_file = -1; return 1; # elif defined(__FreeBSD__) /* There may be a better way on FreeBSD: - we could insert a dummy func in the _close function entry f->_close = (int (*)(void *)) dummy_close; */ f->_file = -1; return 1; # elif defined(__OpenBSD__) /* There may be a better way on OpenBSD: - we could insert a dummy func in the _close function entry f->_close = (int (*)(void *)) dummy_close; */ f->_file = -1; return 1; # elif defined(__EMX__) /* f->_flags &= ~_IOOPEN; */ /* Will leak stream->_buffer */ f->_handle = -1; return 1; # elif defined(__CYGWIN__) /* There may be a better way on CYGWIN: - we could insert a dummy func in the _close function entry f->_close = (int (*)(void *)) dummy_close; */ f->_file = -1; return 1; # elif defined(WIN32) # if defined(__BORLANDC__) f->fd = PerlLIO_dup(fileno(f)); # elif defined(UNDER_CE) /* WIN_CE does not have access to FILE internals, it hardly has FILE structure at all */ # else f->_file = -1; # endif return 1; # else #if 0 /* Sarathy's code did this - we fall back to a dup/dup2 hack (which isn't thread safe) instead */ # error "Don't know how to set FILE.fileno on your platform" #endif PERL_UNUSED_ARG(f); return 0; # endif } IV PerlIOStdio_close(pTHX_ PerlIO *f) ###### { ###### FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio; ###### if (!stdio) { ###### errno = EBADF; ###### return -1; } else { ###### const int fd = fileno(stdio); ###### int socksfd = 0; ###### int invalidate = 0; ###### IV result = 0; ###### int saveerr = 0; ###### int dupfd = 0; #ifdef SOCKS5_VERSION_NAME /* Socks lib overrides close() but stdio isn't linked to that library (though we are) - so we must call close() on sockets on stdio's behalf. */ int optval; Sock_size_t optlen = sizeof(int); if (getsockopt(fd, SOL_SOCKET, SO_TYPE, (void *) &optval, &optlen) == 0) { socksfd = 1; invalidate = 1; } #endif ###### if (PerlIOUnix_refcnt_dec(fd) > 0) { /* File descriptor still in use */ ###### invalidate = 1; ###### socksfd = 0; } ###### if (invalidate) { /* For STD* handles don't close the stdio at all this is because we have shared the FILE * too */ ###### if (stdio == stdin) { /* Some stdios are buggy fflush-ing inputs */ ###### return 0; } ###### else if (stdio == stdout || stdio == stderr) { ###### return PerlIO_flush(f); } /* Tricky - must fclose(stdio) to free memory but not close(fd) Use Sarathy's trick from maint-5.6 to invalidate the fileno slot of the FILE * */ ###### result = PerlIO_flush(f); ###### saveerr = errno; ###### if (!(invalidate = PerlIOStdio_invalidate_fileno(aTHX_ stdio))) { ###### dupfd = PerlLIO_dup(fd); } } ###### result = PerlSIO_fclose(stdio); /* We treat error from stdio as success if we invalidated errno may NOT be expected EBADF */ ###### if (invalidate && result != 0) { ###### errno = saveerr; ###### result = 0; } ###### if (socksfd) { /* in SOCKS case let close() determine return value */ ###### result = close(fd); } ###### if (dupfd) { ###### PerlLIO_dup2(dupfd,fd); ###### PerlLIO_close(dupfd); } ###### return result; } } SSize_t PerlIOStdio_read(pTHX_ PerlIO *f, void *vbuf, Size_t count) ###### { ###### FILE *s = PerlIOSelf(f, PerlIOStdio)->stdio; ###### SSize_t got = 0; ###### for (;;) { ###### if (count == 1) { ###### STDCHAR *buf = (STDCHAR *) vbuf; /* * Perl is expecting PerlIO_getc() to fill the buffer Linux's * stdio does not do that for fread() */ ###### const int ch = PerlSIO_fgetc(s); ###### if (ch != EOF) { ###### *buf = ch; ###### got = 1; } } else ###### got = PerlSIO_fread(vbuf, 1, count, s); ###### if (got == 0 && PerlSIO_ferror(s)) ###### got = -1; ###### if (got >= 0 || errno != EINTR) ###### break; ###### PERL_ASYNC_CHECK(); ###### SETERRNO(0,0); /* just in case */ } ###### return got; } SSize_t PerlIOStdio_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count) ###### { ###### SSize_t unread = 0; ###### FILE *s = PerlIOSelf(f, PerlIOStdio)->stdio; #ifdef STDIO_BUFFER_WRITABLE if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) { STDCHAR *buf = ((STDCHAR *) vbuf) + count; STDCHAR *base = PerlIO_get_base(f); SSize_t cnt = PerlIO_get_cnt(f); STDCHAR *ptr = PerlIO_get_ptr(f); SSize_t avail = ptr - base; if (avail > 0) { if (avail > count) { avail = count; } ptr -= avail; Move(buf-avail,ptr,avail,STDCHAR); count -= avail; unread += avail; PerlIO_set_ptrcnt(f,ptr,cnt+avail); if (PerlSIO_feof(s) && unread >= 0) PerlSIO_clearerr(s); } } else #endif ###### if (PerlIO_has_cntptr(f)) { /* We can get pointer to buffer but not its base Do ungetc() but check chars are ending up in the buffer */ ###### STDCHAR *eptr = (STDCHAR*)PerlSIO_get_ptr(s); ###### STDCHAR *buf = ((STDCHAR *) vbuf) + count; ###### while (count > 0) { ###### const int ch = *--buf & 0xFF; ###### if (ungetc(ch,s) != ch) { /* ungetc did not work */ ###### break; } ###### if ((STDCHAR*)PerlSIO_get_ptr(s) != --eptr || ((*eptr & 0xFF) != ch)) { /* Did not change pointer as expected */ ###### fgetc(s); /* get char back again */ ###### break; } /* It worked ! */ ###### count--; ###### unread++; } } ###### if (count > 0) { ###### unread += PerlIOBase_unread(aTHX_ f, vbuf, count); } ###### return unread; } SSize_t PerlIOStdio_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count) 1 { 1 SSize_t got; 1 for (;;) { 1 got = PerlSIO_fwrite(vbuf, 1, count, PerlIOSelf(f, PerlIOStdio)->stdio); 1 if (got >= 0 || errno != EINTR) ###### break; ###### PERL_ASYNC_CHECK(); ###### SETERRNO(0,0); /* just in case */ } 1 return got; } IV PerlIOStdio_seek(pTHX_ PerlIO *f, Off_t offset, int whence) ###### { ###### FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio; ###### return PerlSIO_fseek(stdio, offset, whence); } Off_t PerlIOStdio_tell(pTHX_ PerlIO *f) ###### { ###### FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio; ###### return PerlSIO_ftell(stdio); } IV PerlIOStdio_flush(pTHX_ PerlIO *f) ###### { ###### FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio; ###### if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) { ###### return PerlSIO_fflush(stdio); } else { #if 0 /* * FIXME: This discards ungetc() and pre-read stuff which is not * right if this is just a "sync" from a layer above Suspect right * design is to do _this_ but not have layer above flush this * layer read-to-read */ /* * Not writeable - sync by attempting a seek */ int err = errno; if (PerlSIO_fseek(stdio, (Off_t) 0, SEEK_CUR) != 0) errno = err; #endif } ###### return 0; } IV PerlIOStdio_eof(pTHX_ PerlIO *f) ###### { ###### return PerlSIO_feof(PerlIOSelf(f, PerlIOStdio)->stdio); } IV PerlIOStdio_error(pTHX_ PerlIO *f) 1 { 1 return PerlSIO_ferror(PerlIOSelf(f, PerlIOStdio)->stdio); } void PerlIOStdio_clearerr(pTHX_ PerlIO *f) ###### { ###### PerlSIO_clearerr(PerlIOSelf(f, PerlIOStdio)->stdio); } void PerlIOStdio_setlinebuf(pTHX_ PerlIO *f) ###### { #ifdef HAS_SETLINEBUF ###### PerlSIO_setlinebuf(PerlIOSelf(f, PerlIOStdio)->stdio); #else PerlSIO_setvbuf(PerlIOSelf(f, PerlIOStdio)->stdio, Nullch, _IOLBF, 0); #endif } #ifdef FILE_base STDCHAR * PerlIOStdio_get_base(pTHX_ PerlIO *f) { FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio; return (STDCHAR*)PerlSIO_get_base(stdio); } Size_t PerlIOStdio_get_bufsiz(pTHX_ PerlIO *f) { FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio; return PerlSIO_get_bufsiz(stdio); } #endif #ifdef USE_STDIO_PTR STDCHAR * PerlIOStdio_get_ptr(pTHX_ PerlIO *f) { FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio; return (STDCHAR*)PerlSIO_get_ptr(stdio); } SSize_t PerlIOStdio_get_cnt(pTHX_ PerlIO *f) { FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio; return PerlSIO_get_cnt(stdio); } void PerlIOStdio_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt) { FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio; if (ptr != NULL) { #ifdef STDIO_PTR_LVALUE PerlSIO_set_ptr(stdio, (void*)ptr); /* LHS STDCHAR* cast non-portable */ #ifdef STDIO_PTR_LVAL_SETS_CNT if (PerlSIO_get_cnt(stdio) != (cnt)) { assert(PerlSIO_get_cnt(stdio) == (cnt)); } #endif #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT)) /* * Setting ptr _does_ change cnt - we are done */ return; #endif #else /* STDIO_PTR_LVALUE */ PerlProc_abort(); #endif /* STDIO_PTR_LVALUE */ } /* * Now (or only) set cnt */ #ifdef STDIO_CNT_LVALUE PerlSIO_set_cnt(stdio, cnt); #else /* STDIO_CNT_LVALUE */ #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT)) PerlSIO_set_ptr(stdio, PerlSIO_get_ptr(stdio) + (PerlSIO_get_cnt(stdio) - cnt)); #else /* STDIO_PTR_LVAL_SETS_CNT */ PerlProc_abort(); #endif /* STDIO_PTR_LVAL_SETS_CNT */ #endif /* STDIO_CNT_LVALUE */ } #endif IV PerlIOStdio_fill(pTHX_ PerlIO *f) ###### { ###### FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio; ###### int c; /* * fflush()ing read-only streams can cause trouble on some stdio-s */ ###### if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE)) { ###### if (PerlSIO_fflush(stdio) != 0) ###### return EOF; } ###### c = PerlSIO_fgetc(stdio); ###### if (c == EOF) ###### return EOF; #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT))) #ifdef STDIO_BUFFER_WRITABLE if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) { /* Fake ungetc() to the real buffer in case system's ungetc goes elsewhere */ STDCHAR *base = (STDCHAR*)PerlSIO_get_base(stdio); SSize_t cnt = PerlSIO_get_cnt(stdio); STDCHAR *ptr = (STDCHAR*)PerlSIO_get_ptr(stdio); if (ptr == base+1) { *--ptr = (STDCHAR) c; PerlIOStdio_set_ptrcnt(aTHX_ f,ptr,cnt+1); if (PerlSIO_feof(stdio)) PerlSIO_clearerr(stdio); return 0; } } else #endif if (PerlIO_has_cntptr(f)) { STDCHAR ch = c; if (PerlIOStdio_unread(aTHX_ f,&ch,1) == 1) { return 0; } } #endif #if defined(VMS) /* An ungetc()d char is handled separately from the regular * buffer, so we stuff it in the buffer ourselves. * Should never get called as should hit code above */ *(--((*stdio)->_ptr)) = (unsigned char) c; (*stdio)->_cnt++; #else /* If buffer snoop scheme above fails fall back to using ungetc(). */ ###### if (PerlSIO_ungetc(c, stdio) != c) ###### return EOF; #endif ###### return 0; } PERLIO_FUNCS_DECL(PerlIO_stdio) = { sizeof(PerlIO_funcs), "stdio", sizeof(PerlIOStdio), PERLIO_K_BUFFERED|PERLIO_K_RAW, PerlIOStdio_pushed, PerlIOBase_popped, PerlIOStdio_open, PerlIOBase_binmode, /* binmode */ NULL, PerlIOStdio_fileno, PerlIOStdio_dup, PerlIOStdio_read, PerlIOStdio_unread, PerlIOStdio_write, PerlIOStdio_seek, PerlIOStdio_tell, PerlIOStdio_close, PerlIOStdio_flush, PerlIOStdio_fill, PerlIOStdio_eof, PerlIOStdio_error, PerlIOStdio_clearerr, PerlIOStdio_setlinebuf, #ifdef FILE_base PerlIOStdio_get_base, PerlIOStdio_get_bufsiz, #else NULL, NULL, #endif #ifdef USE_STDIO_PTR PerlIOStdio_get_ptr, PerlIOStdio_get_cnt, # if defined(HAS_FAST_STDIO) && defined(USE_FAST_STDIO) PerlIOStdio_set_ptrcnt, # else NULL, # endif /* HAS_FAST_STDIO && USE_FAST_STDIO */ #else NULL, NULL, NULL, #endif /* USE_STDIO_PTR */ }; /* Note that calls to PerlIO_exportFILE() are reversed using * PerlIO_releaseFILE(), not importFILE. */ FILE * PerlIO_exportFILE(PerlIO * f, const char *mode) ###### { dTHX; ###### FILE *stdio = NULL; ###### if (PerlIOValid(f)) { ###### char buf[8]; ###### PerlIO_flush(f); ###### if (!mode || !*mode) { ###### mode = PerlIO_modestr(f, buf); } ###### stdio = PerlSIO_fdopen(PerlIO_fileno(f), mode); ###### if (stdio) { ###### PerlIOl *l = *f; ###### PerlIO *f2; /* De-link any lower layers so new :stdio sticks */ ###### *f = NULL; ###### if ((f2 = PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_stdio), buf, Nullsv))) { ###### PerlIOStdio *s = PerlIOSelf((f = f2), PerlIOStdio); ###### s->stdio = stdio; /* Link previous lower layers under new one */ ###### *PerlIONext(f) = l; } else { /* restore layers list */ ###### *f = l; } } } ###### return stdio; } FILE * PerlIO_findFILE(PerlIO *f) 2 { 2 PerlIOl *l = *f; 2 while (l) { 2 if (l->tab == &PerlIO_stdio) { 2 PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio); 2 return s->stdio; } ###### l = *PerlIONext(&l); } /* Uses fallback "mode" via PerlIO_modestr() in PerlIO_exportFILE */ ###### return PerlIO_exportFILE(f, Nullch); } /* Use this to reverse PerlIO_exportFILE calls. */ void PerlIO_releaseFILE(PerlIO *p, FILE *f) 1 { dVAR; 1 PerlIOl *l; 1 while ((l = *p)) { 1 if (l->tab == &PerlIO_stdio) { 1 PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio); 1 if (s->stdio == f) { dTHX; 1 PerlIO_pop(aTHX_ p); 1 return; } } ###### p = PerlIONext(p); } 1 return; } /*--------------------------------------------------------------------------------------*/ /* * perlio buffer layer */ IV PerlIOBuf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab) 77887 { 77887 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf); 77887 const int fd = PerlIO_fileno(f); 77887 if (fd >= 0 && PerlLIO_isatty(fd)) { 9041 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF | PERLIO_F_TTY; } 77887 if (*PerlIONext(f)) { 77887 const Off_t posn = PerlIO_tell(PerlIONext(f)); 77887 if (posn != (Off_t) - 1) { 57982 b->posn = posn; } } 77887 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab); } PerlIO * PerlIOBuf_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, IV n, const char *mode, int fd, int imode, int perm, PerlIO *f, int narg, SV **args) 83286 { 83286 if (PerlIOValid(f)) { ###### PerlIO *next = PerlIONext(f); ###### PerlIO_funcs *tab = ###### PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIOBase(next)->tab); ###### if (tab && tab->Open) ###### next = (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm, next, narg, args); ###### if (!next || (*PerlIOBase(f)->tab->Pushed) (aTHX_ f, mode, PerlIOArg, self) != 0) { ###### return NULL; } } else { 83286 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIO_default_btm()); 83286 int init = 0; 83286 if (*mode == IoTYPE_IMPLICIT) { 13509 init = 1; /* * mode++; */ } 83286 if (tab && tab->Open) 83286 f = (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm, f, narg, args); else ###### SETERRNO(EINVAL, LIB_INVARG); 83286 if (f) { 76355 if (PerlIO_push(aTHX_ f, self, mode, PerlIOArg) == 0) { /* * if push fails during open, open fails. close will pop us. */ 2 PerlIO_close (f); 2 return NULL; } else { 76353 fd = PerlIO_fileno(f); 76353 if (init && fd == 2) { /* * Initial stderr is unbuffered */ 4503 PerlIOBase(f)->flags |= PERLIO_F_UNBUF; } #ifdef PERLIO_USING_CRLF # ifdef PERLIO_IS_BINMODE_FD if (PERLIO_IS_BINMODE_FD(fd)) PerlIO_binmode(aTHX_ f, '<'/*not used*/, O_BINARY, Nullch); else # endif /* * do something about failing setmode()? --jhi */ PerlLIO_setmode(fd, O_BINARY); #endif } } } 83284 return f; } /* * This "flush" is akin to sfio's sync in that it handles files in either * read or write state */ IV PerlIOBuf_flush(pTHX_ PerlIO *f) 550364 { 550364 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf); 550364 int code = 0; 550364 PerlIO *n = PerlIONext(f); 550364 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) { /* * write() the buffer */ 146033 const STDCHAR *buf = b->buf; 146033 const STDCHAR *p = buf; 292063 while (p < b->ptr) { 146033 SSize_t count = PerlIO_write(n, p, b->ptr - p); 146033 if (count > 0) { 146030 p += count; } 3 else if (count < 0 || PerlIO_error(n)) { 3 PerlIOBase(f)->flags |= PERLIO_F_ERROR; 3 code = -1; break; } } 146033 b->posn += (p - buf); } 404331 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) { 288657 STDCHAR *buf = PerlIO_get_base(f); /* * Note position change */ 288657 b->posn += (b->ptr - buf); 288657 if (b->ptr < b->end) { /* We did not consume all of it - try and seek downstream to our logical position */ 19849 if (PerlIOValid(n) && PerlIO_seek(n, b->posn, SEEK_SET) == 0) { /* Reload n as some layers may pop themselves on seek */ 19838 b->posn = PerlIO_tell(n = PerlIONext(f)); } else { /* Seek failed (e.g. pipe or tty). Do NOT clear buffer or pre-read data is lost for good - so return saying "ok" having undone the position adjust */ 11 b->posn -= (b->ptr - buf); 11 return code; } } } 550353 b->ptr = b->end = b->buf; 550353 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF); /* We check for Valid because of dubious decision to make PerlIO_flush(NULL) flush all */ 550353 if (PerlIOValid(n) && PerlIO_flush(n) != 0) ###### code = -1; 550353 return code; } IV PerlIOBuf_fill(pTHX_ PerlIO *f) 244155 { 244155 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf); 244155 PerlIO *n = PerlIONext(f); 244155 SSize_t avail; /* * Down-stream flush is defined not to loose read data so is harmless. * we would not normally be fill'ing if there was data left in anycase. */ 244155 if (PerlIO_flush(f) != 0) ###### return -1; 244155 if (PerlIOBase(f)->flags & PERLIO_F_TTY) 9 PerlIOBase_flush_linebuf(aTHX); 244155 if (!b->buf) ###### PerlIO_get_base(f); /* allocate via vtable */ 244155 b->ptr = b->end = b->buf; 244155 if (!PerlIOValid(n)) { ###### PerlIOBase(f)->flags |= PERLIO_F_EOF; ###### return -1; } 244155 if (PerlIO_fast_gets(n)) { /* * Layer below is also buffered. We do _NOT_ want to call its * ->Read() because that will loop till it gets what we asked for * which may hang on a pipe etc. Instead take anything it has to * hand, or ask it to fill _once_. */ 33 avail = PerlIO_get_cnt(n); 33 if (avail <= 0) { 11 avail = PerlIO_fill(n); 11 if (avail == 0) 9 avail = PerlIO_get_cnt(n); else { 2 if (!PerlIO_error(n) && PerlIO_eof(n)) 2 avail = 0; } } 33 if (avail > 0) { 31 STDCHAR *ptr = PerlIO_get_ptr(n); 31 SSize_t cnt = avail; 31 if (avail > (SSize_t)b->bufsiz) 23 avail = b->bufsiz; 31 Copy(ptr, b->buf, avail, STDCHAR); 31 PerlIO_set_ptrcnt(n, ptr + avail, cnt - avail); } } else { 244122 avail = PerlIO_read(n, b->ptr, b->bufsiz); } 244154 if (avail <= 0) { 39960 if (avail == 0) 39958 PerlIOBase(f)->flags |= PERLIO_F_EOF; else 2 PerlIOBase(f)->flags |= PERLIO_F_ERROR; 39960 return -1; } 204194 b->end = b->buf + avail; 204194 PerlIOBase(f)->flags |= PERLIO_F_RDBUF; 204194 return 0; } SSize_t PerlIOBuf_read(pTHX_ PerlIO *f, void *vbuf, Size_t count) 264464 { 264464 if (PerlIOValid(f)) { 264464 const PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf); 264464 if (!b->ptr) 2739 PerlIO_get_base(f); 264464 return PerlIOBase_read(aTHX_ f, vbuf, count); } ###### return 0; } SSize_t PerlIOBuf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count) 7436 { 7436 const STDCHAR *buf = (const STDCHAR *) vbuf + count; 7436 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf); 7436 SSize_t unread = 0; 7436 SSize_t avail; 7436 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) ###### PerlIO_flush(f); 7436 if (!b->buf) ###### PerlIO_get_base(f); 7436 if (b->buf) { 7436 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) { /* * Buffer is already a read buffer, we can overwrite any chars * which have been read back to buffer start */ 7436 avail = (b->ptr - b->buf); } else { /* * Buffer is idle, set it up so whole buffer is available for * unread */ ###### avail = b->bufsiz; ###### b->end = b->buf + avail; ###### b->ptr = b->end; ###### PerlIOBase(f)->flags |= PERLIO_F_RDBUF; /* * Buffer extends _back_ from where we are now */ ###### b->posn -= b->bufsiz; } 7436 if (avail > (SSize_t) count) { /* * If we have space for more than count, just move count */ 7407 avail = count; } 7436 if (avail > 0) { 7436 b->ptr -= avail; 7436 buf -= avail; /* * In simple stdio-like ungetc() case chars will be already * there */ 7436 if (buf != b->ptr) { 7436 Copy(buf, b->ptr, avail, STDCHAR); } 7436 count -= avail; 7436 unread += avail; 7436 PerlIOBase(f)->flags &= ~PERLIO_F_EOF; } } 7436 if (count > 0) { ###### unread += PerlIOBase_unread(aTHX_ f, vbuf, count); } 7436 return unread; } SSize_t PerlIOBuf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count) 1141559 { 1141559 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf); 1141559 const STDCHAR *buf = (const STDCHAR *) vbuf; 1141559 const STDCHAR *flushptr = buf; 1141559 Size_t written = 0; 1141559 if (!b->buf) 12042 PerlIO_get_base(f); 1141559 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE)) ###### return 0; 1141559 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) { 6 if (PerlIO_flush(f) != 0) { ###### return 0; } } 1141559 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) { 4361 flushptr = buf + count; 229906 while (flushptr > buf && *(flushptr - 1) != '\n') 225545 --flushptr; } 2326435 while (count > 0) { 1184876 SSize_t avail = b->bufsiz - (b->ptr - b->buf); 1184876 if ((SSize_t) count < avail) 1135682 avail = count; 1184876 if (flushptr > buf && flushptr <= buf + avail) 1659 avail = flushptr - buf; 1184876 PerlIOBase(f)->flags |= PERLIO_F_WRBUF; 1184876 if (avail) { 1184876 Copy(buf, b->ptr, avail, STDCHAR); 1184876 count -= avail; 1184876 buf += avail; 1184876 written += avail; 1184876 b->ptr += avail; 1184876 if (buf == flushptr) 1659 PerlIO_flush(f); } 1184876 if (b->ptr >= (b->buf + b->bufsiz)) 49194 PerlIO_flush(f); } 1141559 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF) 2360 PerlIO_flush(f); 1141559 return written; } IV PerlIOBuf_seek(pTHX_ PerlIO *f, Off_t offset, int whence) 29042 { 29042 IV code; 29042 if ((code = PerlIO_flush(f)) == 0) { 29042 PerlIOBase(f)->flags &= ~PERLIO_F_EOF; 29042 code = PerlIO_seek(PerlIONext(f), offset, whence); 29042 if (code == 0) { 29041 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf); 29041 b->posn = PerlIO_tell(PerlIONext(f)); } } 29042 return code; } Off_t PerlIOBuf_tell(pTHX_ PerlIO *f) 1760220 { 1760220 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf); /* * b->posn is file position where b->buf was read, or will be written */ 1760220 Off_t posn = b->posn; 1760220 if ((PerlIOBase(f)->flags & PERLIO_F_APPEND) && (PerlIOBase(f)->flags & PERLIO_F_WRBUF)) { #if 1 /* As O_APPEND files are normally shared in some sense it is better to flush : */ 1 PerlIO_flush(f); #else /* when file is NOT shared then this is sufficient */ PerlIO_seek(PerlIONext(f),0, SEEK_END); #endif 1 posn = b->posn = PerlIO_tell(PerlIONext(f)); } 1760220 if (b->buf) { /* * If buffer is valid adjust position by amount in buffer */ 1756890 posn += (b->ptr - b->buf); } 1760220 return posn; } IV PerlIOBuf_popped(pTHX_ PerlIO *f) 78017 { 78017 const IV code = PerlIOBase_popped(aTHX_ f); 78017 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf); 78017 if (b->buf && b->buf != (STDCHAR *) & b->oneword) { 2 Safefree(b->buf); } 78017 b->buf = NULL; 78017 b->ptr = b->end = b->buf; 78017 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF); 78017 return code; } IV PerlIOBuf_close(pTHX_ PerlIO *f) 78010 { 78010 const IV code = PerlIOBase_close(aTHX_ f); 78010 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf); 78010 if (b->buf && b->buf != (STDCHAR *) & b->oneword) { 63283 Safefree(b->buf); } 78010 b->buf = NULL; 78010 b->ptr = b->end = b->buf; 78010 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF); 78010 return code; } STDCHAR * PerlIOBuf_get_ptr(pTHX_ PerlIO *f) 11606502 { 11606502 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf); 11606502 if (!b->buf) ###### PerlIO_get_base(f); 11606502 return b->ptr; } SSize_t PerlIOBuf_get_cnt(pTHX_ PerlIO *f) 23374802 { 23374802 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf); 23374802 if (!b->buf) 48529 PerlIO_get_base(f); 23374802 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) 23193184 return (b->end - b->ptr); 181618 return 0; } STDCHAR * PerlIOBuf_get_base(pTHX_ PerlIO *f) 351914 { 351914 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf); 351914 if (!b->buf) { 63248 if (!b->bufsiz) 63248 b->bufsiz = 4096; 63248 b->buf = Newz('B',b->buf,b->bufsiz, STDCHAR); 63248 if (!b->buf) { ###### b->buf = (STDCHAR *) & b->oneword; ###### b->bufsiz = sizeof(b->oneword); } 63248 b->ptr = b->buf; 63248 b->end = b->ptr; } 351914 return b->buf; } Size_t PerlIOBuf_bufsiz(pTHX_ PerlIO *f) 9 { 9 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf); 9 if (!b->buf) ###### PerlIO_get_base(f); 9 return (b->end - b->buf); } void PerlIOBuf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt) 11568739 { 11568739 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf); 11568739 if (!b->buf) ###### PerlIO_get_base(f); 11568739 b->ptr = ptr; 11568739 if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf) { ###### assert(PerlIO_get_cnt(f) == cnt); ###### assert(b->ptr >= b->buf); } 11568739 PerlIOBase(f)->flags |= PERLIO_F_RDBUF; } PerlIO * PerlIOBuf_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags) 1482 { 1482 return PerlIOBase_dup(aTHX_ f, o, param, flags); } PERLIO_FUNCS_DECL(PerlIO_perlio) = { sizeof(PerlIO_funcs), "perlio", sizeof(PerlIOBuf), PERLIO_K_BUFFERED|PERLIO_K_RAW, PerlIOBuf_pushed, PerlIOBuf_popped, PerlIOBuf_open, PerlIOBase_binmode, /* binmode */ NULL, PerlIOBase_fileno, PerlIOBuf_dup, PerlIOBuf_read, PerlIOBuf_unread, PerlIOBuf_write, PerlIOBuf_seek, PerlIOBuf_tell, PerlIOBuf_close, PerlIOBuf_flush, PerlIOBuf_fill, PerlIOBase_eof, PerlIOBase_error, PerlIOBase_clearerr, PerlIOBase_setlinebuf, PerlIOBuf_get_base, PerlIOBuf_bufsiz, PerlIOBuf_get_ptr, PerlIOBuf_get_cnt, PerlIOBuf_set_ptrcnt, }; /*--------------------------------------------------------------------------------------*/ /* * Temp layer to hold unread chars when cannot do it any other way */ IV PerlIOPending_fill(pTHX_ PerlIO *f) ###### { /* * Should never happen */ ###### PerlIO_flush(f); ###### return 0; } IV PerlIOPending_close(pTHX_ PerlIO *f) ###### { /* * A tad tricky - flush pops us, then we close new top */ ###### PerlIO_flush(f); ###### return PerlIO_close(f); } IV PerlIOPending_seek(pTHX_ PerlIO *f, Off_t offset, int whence) ###### { /* * A tad tricky - flush pops us, then we seek new top */ ###### PerlIO_flush(f); ###### return PerlIO_seek(f, offset, whence); } IV PerlIOPending_flush(pTHX_ PerlIO *f) ###### { ###### PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf); ###### if (b->buf && b->buf != (STDCHAR *) & b->oneword) { ###### Safefree(b->buf); ###### b->buf = NULL; } ###### PerlIO_pop(aTHX_ f); ###### return 0; } void PerlIOPending_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt) ###### { ###### if (cnt <= 0) { ###### PerlIO_flush(f); } else { ###### PerlIOBuf_set_ptrcnt(aTHX_ f, ptr, cnt); } } IV PerlIOPending_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab) ###### { ###### const IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab); ###### PerlIOl *l = PerlIOBase(f); /* * Our PerlIO_fast_gets must match what we are pushed on, or sv_gets() * etc. get muddled when it changes mid-string when we auto-pop. */ ###### l->flags = (l->flags & ~(PERLIO_F_FASTGETS | PERLIO_F_UTF8)) | (PerlIOBase(PerlIONext(f))-> flags & (PERLIO_F_FASTGETS | PERLIO_F_UTF8)); ###### return code; } SSize_t PerlIOPending_read(pTHX_ PerlIO *f, void *vbuf, Size_t count) ###### { ###### SSize_t avail = PerlIO_get_cnt(f); ###### SSize_t got = 0; ###### if ((SSize_t)count < avail) ###### avail = count; ###### if (avail > 0) ###### got = PerlIOBuf_read(aTHX_ f, vbuf, avail); ###### if (got >= 0 && got < (SSize_t)count) { ###### const SSize_t more = ###### PerlIO_read(f, ((STDCHAR *) vbuf) + got, count - got); ###### if (more >= 0 || got == 0) ###### got += more; } ###### return got; } PERLIO_FUNCS_DECL(PerlIO_pending) = { sizeof(PerlIO_funcs), "pending", sizeof(PerlIOBuf), PERLIO_K_BUFFERED|PERLIO_K_RAW, /* not sure about RAW here */ PerlIOPending_pushed, PerlIOBuf_popped, NULL, PerlIOBase_binmode, /* binmode */ NULL, PerlIOBase_fileno, PerlIOBuf_dup, PerlIOPending_read, PerlIOBuf_unread, PerlIOBuf_write, PerlIOPending_seek, PerlIOBuf_tell, PerlIOPending_close, PerlIOPending_flush, PerlIOPending_fill, PerlIOBase_eof, PerlIOBase_error, PerlIOBase_clearerr, PerlIOBase_setlinebuf, PerlIOBuf_get_base, PerlIOBuf_bufsiz, PerlIOBuf_get_ptr, PerlIOBuf_get_cnt, PerlIOPending_set_ptrcnt, }; /*--------------------------------------------------------------------------------------*/ /* * crlf - translation On read translate CR,LF to "\n" we do this by * overriding ptr/cnt entries to hand back a line at a time and keeping a * record of which nl we "lied" about. On write translate "\n" to CR,LF */ typedef struct { PerlIOBuf base; /* PerlIOBuf stuff */ STDCHAR *nl; /* Position of crlf we "lied" about in the * buffer */ } PerlIOCrlf; IV PerlIOCrlf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab) 16 { 16 IV code; 16 PerlIOBase(f)->flags |= PERLIO_F_CRLF; 16 code = PerlIOBuf_pushed(aTHX_ f, mode, arg, tab); #if 0 PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08" UVxf "\n", f, PerlIOBase(f)->tab->name, (mode) ? mode : "(Null)", PerlIOBase(f)->flags); #endif { /* Enable the first CRLF capable layer you can find, but if none * found, the one we just pushed is fine. This results in at * any given moment at most one CRLF-capable layer being enabled * in the whole layer stack. */ 16 PerlIO *g = PerlIONext(f); 45 while (g && *g) { 31 PerlIOl *b = PerlIOBase(g); 31 if (b && b->tab == &PerlIO_crlf) { 2 if (!(b->flags & PERLIO_F_CRLF)) ###### b->flags |= PERLIO_F_CRLF; 2 PerlIO_pop(aTHX_ f); 2 return code; } 29 g = PerlIONext(g); } } 14 return code; } SSize_t PerlIOCrlf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count) ###### { ###### PerlIOCrlf *c = PerlIOSelf(f, PerlIOCrlf); ###### if (c->nl) { ###### *(c->nl) = 0xd; ###### c->nl = NULL; } ###### if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF)) ###### return PerlIOBuf_unread(aTHX_ f, vbuf, count); else { ###### const STDCHAR *buf = (const STDCHAR *) vbuf + count; ###### PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf); ###### SSize_t unread = 0; ###### if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) ###### PerlIO_flush(f); ###### if (!b->buf) ###### PerlIO_get_base(f); ###### if (b->buf) { ###### if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) { ###### b->end = b->ptr = b->buf + b->bufsiz; ###### PerlIOBase(f)->flags |= PERLIO_F_RDBUF; ###### b->posn -= b->bufsiz; } ###### while (count > 0 && b->ptr > b->buf) { ###### int ch = *--buf; ###### if (ch == '\n') { ###### if (b->ptr - 2 >= b->buf) { ###### *--(b->ptr) = 0xa; ###### *--(b->ptr) = 0xd; ###### unread++; ###### count--; } else { ###### buf++; ###### break; } } else { ###### *--(b->ptr) = ch; ###### unread++; ###### count--; } } } ###### return unread; } } SSize_t PerlIOCrlf_get_cnt(pTHX_ PerlIO *f) 37769 { 37769 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf); 37769 if (!b->buf) 3 PerlIO_get_base(f); 37769 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) { 37763 PerlIOCrlf *c = PerlIOSelf(f, PerlIOCrlf); 37763 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && (!c->nl || *c->nl == 0xd)) { 18943 STDCHAR *nl = (c->nl) ? c->nl : b->ptr; scan: 96919 while (nl < b->end && *nl != 0xd) 77976 nl++; 18943 if (nl < b->end && *nl == 0xd) { test: 18939 if (nl + 1 < b->end) { 18876 if (nl[1] == 0xa) { 18876 *nl = '\n'; 18876 c->nl = nl; } else { /* * Not CR,LF but just CR */ ###### nl++; ###### goto scan; } } else { /* * Blast - found CR as last char in buffer */ 63 if (b->ptr < nl) { /* * They may not care, defer work as long as * possible */ 42 c->nl = nl; 42 return (nl - b->ptr); } else { 21 int code; 21 b->ptr++; /* say we have read it as far as * flush() is concerned */ 21 b->buf++; /* Leave space in front of buffer */ /* Note as we have moved buf up flush's posn += ptr-buf will naturally make posn point at CR */ 21 b->bufsiz--; /* Buffer is thus smaller */ 21 code = PerlIO_fill(f); /* Fetch some more */ 21 b->bufsiz++; /* Restore size for next time */ 21 b->buf--; /* Point at space */ 21 b->ptr = nl = b->buf; /* Which is what we hand * off */ 21 *nl = 0xd; /* Fill in the CR */ 21 if (code == 0) 21 goto test; /* fill() call worked */ /* * CR at EOF - just fall through */ /* Should we clear EOF though ??? */ } } } } 37721 return (((c->nl) ? (c->nl + 1) : b->end) - b->ptr); } 6 return 0; } void PerlIOCrlf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt) 37755 { 37755 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf); 37755 PerlIOCrlf *c = PerlIOSelf(f, PerlIOCrlf); 37755 if (!b->buf) ###### PerlIO_get_base(f); 37755 if (!ptr) { ###### if (c->nl) { ###### ptr = c->nl + 1; ###### if (ptr == b->end && *c->nl == 0xd) { /* Defered CR at end of buffer case - we lied about count */ ###### ptr--; } } else { ###### ptr = b->end; } ###### ptr -= cnt; } else { #if 0 /* * Test code - delete when it works ... */ IV flags = PerlIOBase(f)->flags; STDCHAR *chk = (c->nl) ? (c->nl+1) : b->end; if (ptr+cnt == c->nl && c->nl+1 == b->end && *c->nl == 0xd) { /* Defered CR at end of buffer case - we lied about count */ chk--; } chk -= cnt; if (ptr != chk ) { Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08" UVxf " nl=%p e=%p for %d", ptr, chk, flags, c->nl, b->end, cnt); } #endif } 37755 if (c->nl) { 37738 if (ptr > c->nl) { /* * They have taken what we lied about */ 18875 *(c->nl) = 0xd; 18875 c->nl = NULL; 18875 ptr++; } } 37755 b->ptr = ptr; 37755 PerlIOBase(f)->flags |= PERLIO_F_RDBUF; } SSize_t PerlIOCrlf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count) 9 { 9 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF)) ###### return PerlIOBuf_write(aTHX_ f, vbuf, count); else { 9 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf); 9 const STDCHAR *buf = (const STDCHAR *) vbuf; 9 const STDCHAR *ebuf = buf + count; 9 if (!b->buf) 7 PerlIO_get_base(f); 9 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE)) ###### return 0; 25 while (buf < ebuf) { 16 STDCHAR *eptr = b->buf + b->bufsiz; 16 PerlIOBase(f)->flags |= PERLIO_F_WRBUF; 30066 while (buf < ebuf && b->ptr < eptr) { 30057 if (*buf == '\n') { 2009 if ((b->ptr + 2) > eptr) { /* * Not room for both */ 1 PerlIO_flush(f); 1 break; } else { 2008 *(b->ptr)++ = 0xd; /* CR */ 2008 *(b->ptr)++ = 0xa; /* LF */ 2008 buf++; 2008 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) { ###### PerlIO_flush(f); ###### break; } } } else { 28048 int ch = *buf++; 28048 *(b->ptr)++ = ch; } 30056 if (b->ptr >= eptr) { 6 PerlIO_flush(f); 6 break; } } } 9 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF) ###### PerlIO_flush(f); 9 return (buf - (STDCHAR *) vbuf); } } IV PerlIOCrlf_flush(pTHX_ PerlIO *f) 57 { 57 PerlIOCrlf *c = PerlIOSelf(f, PerlIOCrlf); 57 if (c->nl) { 22 *(c->nl) = 0xd; 22 c->nl = NULL; } 57