/*
- * perlio.c Copyright (c) 1996-2006, 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.
+ * perlio.c
+ * Copyright (c) 1996-2006, Nick Ing-Simmons
+ * Copyright (c) 2006, 2007, 2008 Larry Wall and others
+ *
+ * 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.
+ *
+ * [pp.791-792 of _The Lord of the Rings_, V/iii: "The Muster of Rohan"]
*/
/* This file contains the functions needed to implement PerlIO, which
int mkstemp(char*);
#endif
+#define PerlIO_lockcnt(f) (((PerlIOl*)(f))->head->flags)
+
/* Call the callback or PerlIOBase, and return failure. */
#define Perl_PerlIO_or_Base(f, callback, base, failure, args) \
if (PerlIOValid(f)) { \
* This used to be contents of do_binmode in doio.c
*/
#ifdef DOSISH
-# if defined(atarist) || defined(__MINT__)
+# if defined(atarist)
+ PERL_UNUSED_ARG(iotype);
if (!fflush(fp)) {
if (mode & O_BINARY)
((FILE *) fp)->_flag |= _IOBIN;
return 0;
# else
dTHX;
+ PERL_UNUSED_ARG(iotype);
#ifdef NETWARE
if (PerlLIO_setmode(fp, mode) != -1) {
#else
#else
# if defined(USEMYBINMODE)
dTHX;
+# if defined(__CYGWIN__)
+ PERL_UNUSED_ARG(iotype);
+# endif
if (my_binmode(fp, iotype, mode) != FALSE)
return 1;
else
#else
const char *s = CopFILE(PL_curcop);
STRLEN len;
- SV * const sv = newSVpvs("");
- Perl_sv_catpvf(aTHX_ sv, "%s:%" IVdf " ", s ? s : "(none)",
- (IV) CopLINE(PL_curcop));
+ SV * const sv = Perl_newSVpvf(aTHX_ "%s:%" IVdf " ", s ? s : "(none)",
+ (IV) CopLINE(PL_curcop));
Perl_sv_vcatpvf(aTHX_ sv, fmt, &ap);
s = SvPV_const(sv, len);
* Inner level routines
*/
+/* check that the head field of each layer points back to the head */
+
+#ifdef DEBUGGING
+# define VERIFY_HEAD(f) PerlIO_verify_head(aTHX_ f)
+static void
+PerlIO_verify_head(pTHX_ PerlIO *f)
+{
+ PerlIOl *head, *p;
+ int seen = 0;
+ if (!PerlIOValid(f))
+ return;
+ p = head = PerlIOBase(f)->head;
+ assert(p);
+ do {
+ assert(p->head == head);
+ if (p == (PerlIOl*)f)
+ seen = 1;
+ p = p->next;
+ } while (p);
+ assert(seen);
+}
+#else
+# define VERIFY_HEAD(f)
+#endif
+
+
/*
* Table of pointers to the PerlIO structs (malloc'ed)
*/
#define PERLIO_TABLE_SIZE 64
+static void
+PerlIO_init_table(pTHX)
+{
+ if (PL_perlio)
+ return;
+ Newxz(PL_perlio, PERLIO_TABLE_SIZE, PerlIOl);
+}
+
+
+
PerlIO *
PerlIO_allocate(pTHX)
{
/*
* Find a free slot in the table, allocating new table as necessary
*/
- PerlIO **last;
- PerlIO *f;
+ PerlIOl **last;
+ PerlIOl *f;
last = &PL_perlio;
while ((f = *last)) {
int i;
- last = (PerlIO **) (f);
+ last = (PerlIOl **) (f);
for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
- if (!*++f) {
- return f;
+ if (!((++f)->next)) {
+ f->flags = 0; /* lockcnt */
+ f->tab = NULL;
+ f->head = f;
+ return (PerlIO *)f;
}
}
}
- Newxz(f,PERLIO_TABLE_SIZE,PerlIO);
+ Newxz(f,PERLIO_TABLE_SIZE,PerlIOl);
if (!f) {
return NULL;
}
- *last = f;
- return f + 1;
+ *last = (PerlIOl*) f++;
+ f->flags = 0; /* lockcnt */
+ f->tab = NULL;
+ f->head = f;
+ return (PerlIO*) f;
}
#undef PerlIO_fdupopen
}
void
-PerlIO_cleantable(pTHX_ PerlIO **tablep)
+PerlIO_cleantable(pTHX_ PerlIOl **tablep)
{
- PerlIO * const table = *tablep;
+ PerlIOl * const table = *tablep;
if (table) {
int i;
- PerlIO_cleantable(aTHX_(PerlIO **) & (table[0]));
+ PerlIO_cleantable(aTHX_(PerlIOl **) & (table[0]));
for (i = PERLIO_TABLE_SIZE - 1; i > 0; i--) {
- PerlIO * const f = table + i;
- if (*f) {
- PerlIO_close(f);
+ PerlIOl * const f = table + i;
+ if (f->next) {
+ PerlIO_close(&(f->next));
}
}
Safefree(table);
if (--list->refcnt == 0) {
if (list->array) {
IV i;
- for (i = 0; i < list->cur; i++) {
- if (list->array[i].arg)
- SvREFCNT_dec(list->array[i].arg);
- }
+ for (i = 0; i < list->cur; i++)
+ SvREFCNT_dec(list->array[i].arg);
Safefree(list->array);
}
Safefree(list);
int i;
list = PerlIO_list_alloc(aTHX);
for (i=0; i < proto->cur; i++) {
- SV *arg = NULL;
- if (proto->array[i].arg)
- arg = PerlIO_sv_dup(aTHX_ proto->array[i].arg,param);
+ SV *arg = proto->array[i].arg;
+#ifdef sv_dup
+ if (arg && param)
+ arg = sv_dup(arg, param);
+#else
+ PERL_UNUSED_ARG(param);
+#endif
PerlIO_list_push(aTHX_ list, proto->array[i].funcs, arg);
}
}
PerlIO_clone(pTHX_ PerlInterpreter *proto, CLONE_PARAMS *param)
{
#ifdef USE_ITHREADS
- PerlIO **table = &proto->Iperlio;
- PerlIO *f;
+ PerlIOl **table = &proto->Iperlio;
+ PerlIOl *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_init_table(aTHX);
PerlIO_debug("Clone %p from %p\n",(void*)aTHX,(void*)proto);
while ((f = *table)) {
int i;
- table = (PerlIO **) (f++);
+ table = (PerlIOl **) (f++);
for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
- if (*f) {
- (void) fp_dup(f, 0, param);
+ if (f->next) {
+ (void) fp_dup(&(f->next), 0, param);
}
f++;
}
PerlIO_destruct(pTHX)
{
dVAR;
- PerlIO **table = &PL_perlio;
- PerlIO *f;
+ PerlIOl **table = &PL_perlio;
+ PerlIOl *f;
#ifdef USE_ITHREADS
PerlIO_debug("Destruct %p\n",(void*)aTHX);
#endif
while ((f = *table)) {
int i;
- table = (PerlIO **) (f++);
+ table = (PerlIOl **) (f++);
for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
- PerlIO *x = f;
+ PerlIO *x = &(f->next);
const PerlIOl *l;
while ((l = *x)) {
- if (l->tab->kind & PERLIO_K_DESTRUCT) {
+ if (l->tab && l->tab->kind & PERLIO_K_DESTRUCT) {
PerlIO_debug("Destruct popping %s\n", l->tab->name);
PerlIO_flush(x);
PerlIO_pop(aTHX_ x);
PerlIO_pop(pTHX_ PerlIO *f)
{
const PerlIOl *l = *f;
+ VERIFY_HEAD(f);
if (l) {
- PerlIO_debug("PerlIO_pop f=%p %s\n", (void*)f, l->tab->name);
- if (l->tab->Popped) {
+ PerlIO_debug("PerlIO_pop f=%p %s\n", (void*)f,
+ l->tab ? l->tab->name : "(Null)");
+ if (l->tab && 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
if ((*l->tab->Popped) (aTHX_ f) != 0)
return;
}
- *f = l->next;
- Safefree(l);
+ if (PerlIO_lockcnt(f)) {
+ /* we're in use; defer freeing the structure */
+ PerlIOBase(f)->flags = PERLIO_F_CLEARED;
+ PerlIOBase(f)->tab = NULL;
+ }
+ else {
+ *f = l->next;
+ Safefree(l);
+ }
+
}
}
PerlIOl *l = PerlIOBase(f);
while (l) {
+ /* There is some collusion in the implementation of
+ XS_PerlIO_get_layers - it knows that name and flags are
+ generated as fresh SVs here, and takes advantage of that to
+ "copy" them by taking a reference. If it changes here, it needs
+ to change there too. */
SV * const name = l->tab && l->tab->name ?
newSVpv(l->tab->name, 0) : &PL_sv_undef;
SV * const arg = l->tab && l->tab->Getarg ?
} else {
SV * const pkgsv = newSVpvs("PerlIO");
SV * const layer = newSVpvn(name, len);
- CV * const cv = get_cv("PerlIO::Layer::NoWarnings", FALSE);
+ CV * const cv = get_cvs("PerlIO::Layer::NoWarnings", 0);
ENTER;
- SAVEINT(PL_in_load_module);
+ SAVEBOOL(PL_in_load_module);
if (cv) {
SAVEGENERICSV(PL_warnhook);
- PL_warnhook = (SV *) (SvREFCNT_inc_simple_NN(cv));
+ PL_warnhook = MUTABLE_SV((SvREFCNT_inc_simple_NN(cv)));
}
- PL_in_load_module++;
+ PL_in_load_module = TRUE;
/*
* The two SVs are magically freed by load_module
*/
Perl_load_module(aTHX_ 0, pkgsv, NULL, layer, NULL);
- PL_in_load_module--;
LEAVE;
return PerlIO_find_layer(aTHX_ name, len, 0);
}
perlio_mg_set(pTHX_ SV *sv, MAGIC *mg)
{
if (SvROK(sv)) {
- IO * const io = GvIOn((GV *) SvRV(sv));
+ IO * const io = GvIOn(MUTABLE_GV(SvRV(sv)));
PerlIO * const ifp = IoIFP(io);
PerlIO * const ofp = IoOFP(io);
- Perl_warn(aTHX_ "set %" SVf " %p %p %p", sv, io, ifp, ofp);
+ Perl_warn(aTHX_ "set %" SVf " %p %p %p",
+ SVfARG(sv), (void*)io, (void*)ifp, (void*)ofp);
}
return 0;
}
perlio_mg_get(pTHX_ SV *sv, MAGIC *mg)
{
if (SvROK(sv)) {
- IO * const io = GvIOn((GV *) SvRV(sv));
+ IO * const io = GvIOn(MUTABLE_GV(SvRV(sv)));
PerlIO * const ifp = IoIFP(io);
PerlIO * const ofp = IoOFP(io);
- Perl_warn(aTHX_ "get %" SVf " %p %p %p", sv, io, ifp, ofp);
+ Perl_warn(aTHX_ "get %" SVf " %p %p %p",
+ SVfARG(sv), (void*)io, (void*)ifp, (void*)ofp);
}
return 0;
}
static int
perlio_mg_clear(pTHX_ SV *sv, MAGIC *mg)
{
- Perl_warn(aTHX_ "clear %" SVf, sv);
+ Perl_warn(aTHX_ "clear %" SVf, SVfARG(sv));
return 0;
}
static int
perlio_mg_free(pTHX_ SV *sv, MAGIC *mg)
{
- Perl_warn(aTHX_ "free %" SVf, sv);
+ Perl_warn(aTHX_ "free %" SVf, SVfARG(sv));
return 0;
}
MAGIC *mg;
int count = 0;
int i;
- sv_magic(sv, (SV *) av, PERL_MAGIC_ext, NULL, 0);
+ sv_magic(sv, MUTABLE_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);
+ Perl_warn(aTHX_ "attrib %" SVf, SVfARG(sv));
for (i = 2; i < items; i++) {
STRLEN len;
const char * const name = SvPV_const(ST(i), len);
SV *
PerlIO_tab_sv(pTHX_ PerlIO_funcs *tab)
{
- HV * const stash = gv_stashpvs("PerlIO::Layer", TRUE);
+ HV * const stash = gv_stashpvs("PerlIO::Layer", GV_ADD);
SV * const sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))), stash);
return sv;
}
XS(XS_PerlIO__Layer__NoWarnings)
{
- /* This is used as a %SIG{__WARN__} handler to supress warnings
+ /* This is used as a %SIG{__WARN__} handler to suppress warnings
during loading of layers.
*/
dVAR;
dXSARGS;
+ PERL_UNUSED_ARG(cv);
if (items)
PerlIO_debug("warning:%s\n",SvPV_nolen_const(ST(0)));
XSRETURN(0);
{
dVAR;
dXSARGS;
+ PERL_UNUSED_ARG(cv);
if (items < 2)
Perl_croak(aTHX_ "Usage class->find(name[,load])");
else {
* seen as an invalid separator character.
*/
const char q = ((*s == '\'') ? '"' : '\'');
- if (ckWARN(WARN_LAYER))
- Perl_warner(aTHX_ packWARN(WARN_LAYER),
- "Invalid separator character %c%c%c in PerlIO layer specification %s",
- q, *s, q, s);
+ Perl_ck_warner(aTHX_ packWARN(WARN_LAYER),
+ "Invalid separator character %c%c%c in PerlIO layer specification %s",
+ q, *s, q, s);
SETERRNO(EINVAL, LIB_INVARG);
return -1;
}
*/
case '\0':
e--;
- if (ckWARN(WARN_LAYER))
- Perl_warner(aTHX_ packWARN(WARN_LAYER),
- "Argument list not closed for PerlIO layer \"%.*s\"",
- (int) (e - s), s);
+ Perl_ck_warner(aTHX_ packWARN(WARN_LAYER),
+ "Argument list not closed for PerlIO layer \"%.*s\"",
+ (int) (e - s), s);
return -1;
default:
/*
PerlIO_funcs * const layer =
PerlIO_find_layer(aTHX_ s, llen, 1);
if (layer) {
+ SV *arg = NULL;
+ if (as)
+ arg = newSVpvn(as, alen);
PerlIO_list_push(aTHX_ av, layer,
- (as) ? newSVpvn(as,
- alen) :
- &PL_sv_undef);
+ (arg) ? arg : &PL_sv_undef);
+ SvREFCNT_dec(arg);
}
else {
- if (ckWARN(WARN_LAYER))
- Perl_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"%.*s\"",
- (int) llen, s);
+ Perl_ck_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"%.*s\"",
+ (int) llen, s);
return -1;
}
}
PERLIO_K_DUMMY | PERLIO_K_UTF8,
PerlIOPop_pushed,
NULL,
- NULL,
+ PerlIOBase_open,
NULL,
NULL,
NULL,
{
dVAR;
if (!PL_perlio) {
- PerlIO_allocate(aTHX);
+ PerlIO_init_table(aTHX);
PerlIO_fdopen(0, "Ir" PERLIO_STDTEXT);
PerlIO_fdopen(1, "Iw" PERLIO_STDTEXT);
PerlIO_fdopen(2, "Iw" PERLIO_STDTEXT);
PerlIO *
PerlIO_push(pTHX_ PerlIO *f, PERLIO_FUNCS_DECL(*tab), const char *mode, SV *arg)
{
+ VERIFY_HEAD(f);
if (tab->fsize != sizeof(PerlIO_funcs)) {
- mismatch:
- Perl_croak(aTHX_ "Layer does not match this perl");
+ Perl_croak( aTHX_
+ "%s (%"UVuf") does not match %s (%"UVuf")",
+ "PerlIO layer function table size", (UV)tab->fsize,
+ "size expected by this perl", (UV)sizeof(PerlIO_funcs) );
}
if (tab->size) {
PerlIOl *l;
if (tab->size < sizeof(PerlIOl)) {
- goto mismatch;
+ Perl_croak( aTHX_
+ "%s (%"UVuf") smaller than %s (%"UVuf")",
+ "PerlIO layer instance size", (UV)tab->size,
+ "size expected by this perl", (UV)sizeof(PerlIOl) );
}
/* Real layer with a data area */
if (f) {
if (l) {
l->next = *f;
l->tab = (PerlIO_funcs*) tab;
+ l->head = ((PerlIOl*)f)->head;
*f = l;
PerlIO_debug("PerlIO_push f=%p %s %s %p\n",
(void*)f, tab->name,
return f;
}
+PerlIO *
+PerlIOBase_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
+ IV n, const char *mode, int fd, int imode, int perm,
+ PerlIO *old, int narg, SV **args)
+{
+ PerlIO_funcs * const tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIO_default_layer(aTHX_ 0));
+ if (tab && tab->Open) {
+ PerlIO* ret = (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm, old, narg, args);
+ if (ret && PerlIO_push(aTHX_ ret, self, mode, PerlIOArg) == NULL) {
+ PerlIO_close(ret);
+ return NULL;
+ }
+ return ret;
+ }
+ SETERRNO(EINVAL, LIB_INVARG);
+ return NULL;
+}
+
IV
PerlIOBase_binmode(pTHX_ PerlIO *f)
{
if (PerlIOValid(f)) {
/* Is layer suitable for raw stream ? */
- if (PerlIOBase(f)->tab->kind & PERLIO_K_RAW) {
+ if (PerlIOBase(f)->tab && PerlIOBase(f)->tab->kind & PERLIO_K_RAW) {
/* Yes - turn off UTF-8-ness, to undo UTF-8 locale effects */
PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
}
*/
t = f;
while (t && (l = *t)) {
- if (l->tab->Binmode) {
+ if (l->tab && l->tab->Binmode) {
/* Has a handler - normal case */
- if ((*l->tab->Binmode)(aTHX_ f) == 0) {
+ if ((*l->tab->Binmode)(aTHX_ t) == 0) {
if (*t == l) {
/* Layer still there - move down a layer */
t = PerlIONext(t);
}
}
if (PerlIOValid(f)) {
- PerlIO_debug(":raw f=%p :%s\n", (void*)f, PerlIOBase(f)->tab->name);
+ PerlIO_debug(":raw f=%p :%s\n", (void*)f,
+ PerlIOBase(f)->tab ? PerlIOBase(f)->tab->name : "(Null)");
return 0;
}
}
PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
{
int code = 0;
+ ENTER;
+ save_scalar(PL_errgv);
if (f && names) {
PerlIO_list_t * const layers = PerlIO_list_alloc(aTHX);
code = PerlIO_parse_layers(aTHX_ layers, names);
}
PerlIO_list_free(aTHX_ layers);
}
+ LEAVE;
return code;
}
PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names)
{
PerlIO_debug("PerlIO_binmode f=%p %s %c %x %s\n", (void*)f,
- (PerlIOBase(f)) ? PerlIOBase(f)->tab->name : "(Null)",
+ (PerlIOBase(f) && PerlIOBase(f)->tab) ?
+ PerlIOBase(f)->tab->name : "(Null)",
iotype, mode, (names) ? names : "(Null)");
if (names) {
/* 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)->tab &&
+ 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);
const int code = PerlIO__close(aTHX_ f);
while (PerlIOValid(f)) {
PerlIO_pop(aTHX_ f);
+ if (PerlIO_lockcnt(f))
+ /* we're in use; the 'pop' deferred freeing the structure */
+ f = PerlIONext(f);
}
return code;
}
/*
* For any scalar type load the handler which is bundled with perl
*/
- if (SvTYPE(sv) < SVt_PVAV)
- return PerlIO_find_layer(aTHX_ STR_WITH_LEN("scalar"), 1);
+ if (SvTYPE(sv) < SVt_PVAV && (!isGV_with_GP(sv) || SvFAKE(sv))) {
+ PerlIO_funcs *f = PerlIO_find_layer(aTHX_ STR_WITH_LEN("scalar"), 1);
+ /* This isn't supposed to happen, since PerlIO::scalar is core,
+ * but could happen anyway in smaller installs or with PAR */
+ if (!f)
+ Perl_ck_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"scalar\"");
+ return f;
+ }
/*
* For other types allow if layer is known but don't try and load it
if (layers && *layers) {
PerlIO_list_t *av;
if (incdef) {
- IV i;
- av = PerlIO_list_alloc(aTHX);
- for (i = 0; i < def->cur; i++) {
- PerlIO_list_push(aTHX_ av, def->array[i].funcs,
- def->array[i].arg);
- }
+ av = PerlIO_clone_list(aTHX_ def, NULL);
}
else {
av = def;
PerlIOl *l = *f;
layera = PerlIO_list_alloc(aTHX);
while (l) {
- SV * const arg = (l->tab->Getarg)
- ? (*l->tab->Getarg) (aTHX_ &l, NULL, 0)
- : &PL_sv_undef;
- PerlIO_list_push(aTHX_ layera, l->tab, arg);
+ SV *arg = NULL;
+ if (l->tab && l->tab->Getarg)
+ arg = (*l->tab->Getarg) (aTHX_ &l, NULL, 0);
+ PerlIO_list_push(aTHX_ layera, l->tab,
+ (arg) ? arg : &PL_sv_undef);
+ SvREFCNT_dec(arg);
l = *PerlIONext(&l);
}
}
SSize_t
Perl_PerlIO_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
{
+ PERL_ARGS_ASSERT_PERLIO_READ;
+
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)
{
+ PERL_ARGS_ASSERT_PERLIO_UNREAD;
+
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)
{
+ PERL_ARGS_ASSERT_PERLIO_WRITE;
+
Perl_PerlIO_or_fail(f, Write, -1, (aTHX_ f, vbuf, count));
}
else {
/*
* Is it good API design to do flush-all on NULL, a potentially
- * errorneous input? Maybe some magical value (PerlIO*
+ * erroneous 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
*/
- PerlIO **table = &PL_perlio;
+ PerlIOl **table = &PL_perlio;
+ PerlIOl *ff;
int code = 0;
- while ((f = *table)) {
+ while ((ff = *table)) {
int i;
- table = (PerlIO **) (f++);
+ table = (PerlIOl **) (ff++);
for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
- if (*f && PerlIO_flush(f) != 0)
+ if (ff->next && PerlIO_flush(&(ff->next)) != 0)
code = -1;
- f++;
+ ff++;
}
}
return code;
PerlIOBase_flush_linebuf(pTHX)
{
dVAR;
- PerlIO **table = &PL_perlio;
- PerlIO *f;
+ PerlIOl **table = &PL_perlio;
+ PerlIOl *f;
while ((f = *table)) {
int i;
- table = (PerlIO **) (f++);
+ table = (PerlIOl **) (f++);
for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
- if (*f
- && (PerlIOBase(f)->
+ if (f->next
+ && (PerlIOBase(&(f->next))->
flags & (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE))
== (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE))
- PerlIO_flush(f);
+ PerlIO_flush(&(f->next));
f++;
}
}
if (tab)
return (tab->Get_base != NULL);
- SETERRNO(EINVAL, LIB_INVARG);
}
- else
- SETERRNO(EBADF, SS_IVCHAN);
return 0;
}
int
PerlIO_fast_gets(PerlIO *f)
{
- if (PerlIOValid(f) && (PerlIOBase(f)->flags & PERLIO_F_FASTGETS)) {
- const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
+ if (PerlIOValid(f)) {
+ if (PerlIOBase(f)->flags & PERLIO_F_FASTGETS) {
+ const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
- if (tab)
- return (tab->Set_ptrcnt != NULL);
- SETERRNO(EINVAL, LIB_INVARG);
+ if (tab)
+ return (tab->Set_ptrcnt != NULL);
+ }
}
- else
- SETERRNO(EBADF, SS_IVCHAN);
return 0;
}
if (tab)
return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
- SETERRNO(EINVAL, LIB_INVARG);
}
- else
- SETERRNO(EBADF, SS_IVCHAN);
return 0;
}
if (tab)
return (tab->Set_ptrcnt != NULL);
- SETERRNO(EINVAL, LIB_INVARG);
}
- else
- SETERRNO(EBADF, SS_IVCHAN);
return 0;
}
PERL_UNUSED_ARG(mode);
PERL_UNUSED_ARG(arg);
if (PerlIOValid(f)) {
- if (tab->kind & PERLIO_K_UTF8)
+ if (tab && tab->kind & PERLIO_K_UTF8)
PerlIOBase(f)->flags |= PERLIO_F_UTF8;
else
PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
PERLIO_K_DUMMY | PERLIO_K_UTF8,
PerlIOUtf8_pushed,
NULL,
- NULL,
+ PerlIOBase_open,
NULL,
NULL,
NULL,
PERLIO_K_DUMMY,
PerlIOUtf8_pushed,
NULL,
- NULL,
+ PerlIOBase_open,
NULL,
NULL,
NULL,
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)
-{
- PerlIO_funcs * const tab = PerlIO_default_btm();
- PERL_UNUSED_ARG(self);
- if (tab && tab->Open)
- 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",
PERLIO_K_DUMMY,
PerlIORaw_pushed,
PerlIOBase_popped,
- PerlIORaw_open,
+ PerlIOBase_open,
NULL,
NULL,
NULL,
l->flags &= ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE |
PERLIO_F_TRUNCATE | PERLIO_F_APPEND);
- if (tab->Set_ptrcnt != NULL)
+ if (tab && tab->Set_ptrcnt != NULL)
l->flags |= PERLIO_F_FASTGETS;
if (mode) {
if (*mode == IoTYPE_NUMERIC || *mode == IoTYPE_IMPLICIT)
}
#if 0
PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08" UVxf " (%s)\n",
- f, PerlIOBase(f)->tab->name, (omode) ? omode : "(Null)",
+ (void*)f, PerlIOBase(f)->tab->name, (omode) ? omode : "(Null)",
l->flags, PerlIO_modestr(f, temp));
#endif
return 0;
return NULL;
#ifdef sv_dup
if (param) {
- return sv_dup(arg, param);
+ arg = sv_dup(arg, param);
+ SvREFCNT_inc_simple_void_NN(arg);
+ return arg;
}
else {
return newSVsv(arg);
}
if (f) {
PerlIO_funcs * const self = PerlIOBase(o)->tab;
- SV *arg;
+ SV *arg = NULL;
char buf[8];
PerlIO_debug("PerlIOBase_dup %s f=%p o=%p param=%p\n",
- self->name, (void*)f, (void*)o, (void*)param);
- if (self->Getarg)
+ self ? self->name : "(Null)",
+ (void*)f, (void*)o, (void*)param);
+ if (self && self->Getarg)
arg = (*self->Getarg)(aTHX_ o, param, flags);
- else {
- arg = NULL;
- }
f = PerlIO_push(aTHX_ f, self, PerlIO_modestr(o,buf), arg);
- if (arg) {
- SvREFCNT_dec(arg);
- }
+ if (PerlIOBase(o)->flags & PERLIO_F_UTF8)
+ PerlIOBase(f)->flags |= PERLIO_F_UTF8;
+ SvREFCNT_dec(arg);
}
return f;
}
/* PL_perlio_fd_refcnt[] is in intrpvar.h */
-/* Must be called with PL_perlio_mutex locked (if under 5.005 threads). */
+/* Must be called with PL_perlio_mutex locked. */
static void
S_more_refcounted_fds(pTHX_ const int new_fd) {
dVAR;
assert (new_max > new_fd);
- new_array =
- (int*) PerlMemShared_realloc(PL_perlio_fd_refcnt, new_max * sizeof(int));
+ /* Use plain realloc() since we need this memory to be really
+ * global and visible to all the interpreters and/or threads. */
+ new_array = (int*) realloc(PL_perlio_fd_refcnt, new_max * sizeof(int));
if (!new_array) {
-#ifdef USE_THREADS
+#ifdef USE_ITHREADS
MUTEX_UNLOCK(&PL_perlio_mutex);
#endif
/* Can't use PerlIO to write as it allocates memory */
void
PerlIO_init(pTHX)
{
- /* Place holder for stdstreams call ??? */
-#ifdef USE_THREADS
- MUTEX_INIT(&PL_perlio_mutex);
-#else
+ /* MUTEX_INIT(&PL_perlio_mutex) is done in PERL_SYS_INIT3(). */
PERL_UNUSED_CONTEXT;
-#endif
}
void
if (fd >= 0) {
dVAR;
-#ifdef USE_THREADS
+#ifdef USE_ITHREADS
MUTEX_LOCK(&PL_perlio_mutex);
#endif
if (fd >= PL_perlio_fd_refcnt_size)
S_more_refcounted_fds(aTHX_ fd);
PL_perlio_fd_refcnt[fd]++;
- PerlIO_debug("fd %d refcnt=%d\n",fd,PL_perlio_fd_refcnt[fd]);
+ if (PL_perlio_fd_refcnt[fd] <= 0) {
+ Perl_croak(aTHX_ "refcnt_inc: fd %d: %d <= 0\n",
+ fd, PL_perlio_fd_refcnt[fd]);
+ }
+ PerlIO_debug("refcnt_inc: fd %d refcnt=%d\n",
+ fd, PL_perlio_fd_refcnt[fd]);
-#ifdef USE_THREADS
+#ifdef USE_ITHREADS
MUTEX_UNLOCK(&PL_perlio_mutex);
#endif
+ } else {
+ Perl_croak(aTHX_ "refcnt_inc: fd %d < 0\n", fd);
}
}
int cnt = 0;
if (fd >= 0) {
dVAR;
-#ifdef USE_THREADS
+#ifdef USE_ITHREADS
MUTEX_LOCK(&PL_perlio_mutex);
#endif
- /* XXX should this be a panic? */
- if (fd >= PL_perlio_fd_refcnt_size)
- S_more_refcounted_fds(aTHX_ fd);
-
- /* XXX should this be a panic if it drops below 0? */
+ if (fd >= PL_perlio_fd_refcnt_size) {
+ Perl_croak(aTHX_ "refcnt_dec: fd %d >= refcnt_size %d\n",
+ fd, PL_perlio_fd_refcnt_size);
+ }
+ if (PL_perlio_fd_refcnt[fd] <= 0) {
+ Perl_croak(aTHX_ "refcnt_dec: fd %d: %d <= 0\n",
+ fd, PL_perlio_fd_refcnt[fd]);
+ }
cnt = --PL_perlio_fd_refcnt[fd];
- PerlIO_debug("fd %d refcnt=%d\n",fd,cnt);
-#ifdef USE_THREADS
+ PerlIO_debug("refcnt_dec: fd %d refcnt=%d\n", fd, cnt);
+#ifdef USE_ITHREADS
MUTEX_UNLOCK(&PL_perlio_mutex);
#endif
+ } else {
+ Perl_croak(aTHX_ "refcnt_dec: fd %d < 0\n", fd);
+ }
+ return cnt;
+}
+
+int
+PerlIOUnix_refcnt(int fd)
+{
+ dTHX;
+ int cnt = 0;
+ if (fd >= 0) {
+ dVAR;
+#ifdef USE_ITHREADS
+ MUTEX_LOCK(&PL_perlio_mutex);
+#endif
+ if (fd >= PL_perlio_fd_refcnt_size) {
+ /* diag_listed_as: refcnt: fd %d%s */
+ Perl_croak(aTHX_ "refcnt: fd %d >= refcnt_size %d\n",
+ fd, PL_perlio_fd_refcnt_size);
+ }
+ if (PL_perlio_fd_refcnt[fd] <= 0) {
+ /* diag_listed_as: refcnt: fd %d%s */
+ Perl_croak(aTHX_ "refcnt: fd %d: %d <= 0\n",
+ fd, PL_perlio_fd_refcnt[fd]);
+ }
+ cnt = PL_perlio_fd_refcnt[fd];
+#ifdef USE_ITHREADS
+ MUTEX_UNLOCK(&PL_perlio_mutex);
+#endif
+ } else {
+ /* diag_listed_as: refcnt: fd %d%s */
+ Perl_croak(aTHX_ "refcnt: fd %d < 0\n", fd);
}
return cnt;
}
}
}
-void PerlIO_teardown(pTHX) /* Call only from PERL_SYS_TERM(). */
+void PerlIO_teardown(void) /* Call only from PERL_SYS_TERM(). */
{
+ dVAR;
+#if 0
+/* XXX we can't rely on an interpreter being present at this late stage,
+ XXX so we can't use a function like PerlLIO_write that relies on one
+ being present (at least in win32) :-(.
+ Disable for now.
+*/
#ifdef DEBUGGING
{
/* By now all filehandles should have been closed, so any
* stray (non-STD-)filehandles indicate *possible* (PerlIO)
* errors. */
+#define PERLIO_TEARDOWN_MESSAGE_BUF_SIZE 64
+#define PERLIO_TEARDOWN_MESSAGE_FD 2
+ char buf[PERLIO_TEARDOWN_MESSAGE_BUF_SIZE];
int i;
for (i = 3; i < PL_perlio_fd_refcnt_size; i++) {
- if (PL_perlio_fd_refcnt[i])
- PerlIO_debug("PerlIO_cleanup: fd %d refcnt=%d\n",
- i, PL_perlio_fd_refcnt[i]);
+ if (PL_perlio_fd_refcnt[i]) {
+ const STRLEN len =
+ my_snprintf(buf, sizeof(buf),
+ "PerlIO_teardown: fd %d refcnt=%d\n",
+ i, PL_perlio_fd_refcnt[i]);
+ PerlLIO_write(PERLIO_TEARDOWN_MESSAGE_FD, buf, len);
+ }
}
}
#endif
-#ifdef USE_THREADS
- MUTEX_LOCK(&PL_perlio_mutex);
#endif
+ /* Not bothering with PL_perlio_mutex since by now
+ * all the interpreters are gone. */
if (PL_perlio_fd_refcnt_size /* Assuming initial size of zero. */
&& PL_perlio_fd_refcnt) {
-#ifdef PERL_TRACK_MEMPOOL
- Malloc_t ptr = (Malloc_t)((char*)PL_perlio_fd_refcnt-sTHX);
- struct perl_memory_debug_header *const header
- = (struct perl_memory_debug_header *)ptr;
- /* Only the thread that allocated us can free us. */
- if (header->interpreter == aTHX)
-#endif
- {
- PerlMemShared_free(PL_perlio_fd_refcnt); /* Not Safefree() because was allocated with PerlMemShared_realloc(). */
- PL_perlio_fd_refcnt = NULL;
- PL_perlio_fd_refcnt_size = 0;
- }
+ free(PL_perlio_fd_refcnt); /* To match realloc() in S_more_refcounted_fds(). */
+ PL_perlio_fd_refcnt = NULL;
+ PL_perlio_fd_refcnt_size = 0;
}
-#ifdef USE_THREADS
- MUTEX_UNLOCK(&PL_perlio_mutex);
-#endif
}
-
-
/*--------------------------------------------------------------------------------------*/
/*
* Bottom-most level for UNIX-like case
int oflags; /* open/fcntl flags */
} PerlIOUnix;
+static void
+S_lockcnt_dec(pTHX_ const void* f)
+{
+ PerlIO_lockcnt((PerlIO*)f)--;
+}
+
+
+/* call the signal handler, and if that handler happens to clear
+ * this handle, free what we can and return true */
+
+static bool
+S_perlio_async_run(pTHX_ PerlIO* f) {
+ ENTER;
+ SAVEDESTRUCTOR_X(S_lockcnt_dec, (void*)f);
+ PerlIO_lockcnt(f)++;
+ PERL_ASYNC_CHECK();
+ if ( !(PerlIOBase(f)->flags & PERLIO_F_CLEARED) )
+ return 0;
+ /* we've just run some perl-level code that could have done
+ * anything, including closing the file or clearing this layer.
+ * If so, free any lower layers that have already been
+ * cleared, then return an error. */
+ while (PerlIOValid(f) &&
+ (PerlIOBase(f)->flags & PERLIO_F_CLEARED))
+ {
+ const PerlIOl *l = *f;
+ *f = l->next;
+ Safefree(l);
+ }
+ return 1;
+}
+
int
PerlIOUnix_oflags(const char *mode)
{
int perm, PerlIO *f, int narg, SV **args)
{
if (PerlIOValid(f)) {
- if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
+ if (PerlIOBase(f)->tab && PerlIOBase(f)->flags & PERLIO_F_OPEN)
(*PerlIOBase(f)->tab->Close)(aTHX_ f);
}
if (narg > 0) {
mode++;
else {
imode = PerlIOUnix_oflags(mode);
+#ifdef VMS
+ perm = 0777; /* preserve RMS defaults, ACL inheritance, etc. */
+#else
perm = 0666;
+#endif
}
if (imode != -1) {
const char *path = SvPV_nolen_const(*args);
PerlIOUnix_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
{
dVAR;
- const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
+ int fd;
+ if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
+ return -1;
+ fd = PerlIOSelf(f, PerlIOUnix)->fd;
#ifdef PERLIO_STD_SPECIAL
if (fd == 0)
return PERLIO_STD_IN(fd, vbuf, count);
}
return len;
}
- PERL_ASYNC_CHECK();
+ /* EINTR */
+ if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
+ return -1;
}
/*NOTREACHED*/
}
PerlIOUnix_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
{
dVAR;
- const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
+ int fd;
+ if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
+ return -1;
+ fd = PerlIOSelf(f, PerlIOUnix)->fd;
#ifdef PERLIO_STD_SPECIAL
if (fd == 1 || fd == 2)
return PERLIO_STD_OUT(fd, vbuf, count);
}
return len;
}
- PERL_ASYNC_CHECK();
+ /* EINTR */
+ if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
+ return -1;
}
/*NOTREACHED*/
}
code = -1;
break;
}
- PERL_ASYNC_CHECK();
+ /* EINTR */
+ if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
+ return -1;
}
if (code == 0) {
PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
if ((f = PerlIO_push(aTHX_(f = PerlIO_allocate(aTHX)), PERLIO_FUNCS_CAST(&PerlIO_stdio), mode, NULL))) {
s = PerlIOSelf(f, PerlIOStdio);
s->stdio = stdio;
+ PerlIOUnix_refcnt_inc(fileno(stdio));
}
}
return f;
stdio = PerlSIO_fdopen(fd, PerlIO_modestr(o,mode));
set_this:
PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
- PerlIOUnix_refcnt_inc(fileno(stdio));
+ if(stdio) {
+ PerlIOUnix_refcnt_inc(fileno(stdio));
+ }
}
return f;
}
const int fd = fileno(stdio);
int invalidate = 0;
IV result = 0;
- int saveerr = 0;
- int dupfd = 0;
+ int dupfd = -1;
+ dSAVEDERRNO;
+#ifdef USE_ITHREADS
+ dVAR;
+#endif
#ifdef SOCKS5_VERSION_NAME
/* Socks lib overrides close() but stdio isn't linked to
that library (though we are) - so we must call close()
if (getsockopt(fd, SOL_SOCKET, SO_TYPE, (void *) &optval, &optlen) == 0)
invalidate = 1;
#endif
- if (PerlIOUnix_refcnt_dec(fd) > 0) /* File descriptor still in use */
+ /* Test for -1, as *BSD stdio (at least) on fclose sets the FILE* such
+ that a subsequent fileno() on it returns -1. Don't want to croak()
+ from within PerlIOUnix_refcnt_dec() if some buggy caller code is
+ trying to close an already closed handle which somehow it still has
+ a reference to. (via.xs, I'm looking at you). */
+ if (fd != -1 && PerlIOUnix_refcnt_dec(fd) > 0) {
+ /* File descriptor still in use */
invalidate = 1;
+ }
if (invalidate) {
/* For STD* handles, don't close stdio, since we shared the FILE *, too. */
if (stdio == stdin) /* Some stdios are buggy fflush-ing inputs */
fileno slot of the FILE *
*/
result = PerlIO_flush(f);
- saveerr = errno;
+ SAVE_ERRNO;
invalidate = PerlIOStdio_invalidate_fileno(aTHX_ stdio);
- if (!invalidate)
+ if (!invalidate) {
+#ifdef USE_ITHREADS
+ MUTEX_LOCK(&PL_perlio_mutex);
+ /* Right. We need a mutex here because for a brief while we
+ will have the situation that fd is actually closed. Hence if
+ a second thread were to get into this block, its dup() would
+ likely return our fd as its dupfd. (after all, it is closed)
+ Then if we get to the dup2() first, we blat the fd back
+ (messing up its temporary as a side effect) only for it to
+ then close its dupfd (== our fd) in its close(dupfd) */
+
+ /* There is, of course, a race condition, that any other thread
+ trying to input/output/whatever on this fd will be stuffed
+ for the duration of this little manoeuvrer. Perhaps we
+ should hold an IO mutex for the duration of every IO
+ operation if we know that invalidate doesn't work on this
+ platform, but that would suck, and could kill performance.
+
+ Except that correctness trumps speed.
+ Advice from klortho #11912. */
+#endif
dupfd = PerlLIO_dup(fd);
+#ifdef USE_ITHREADS
+ if (dupfd < 0) {
+ MUTEX_UNLOCK(&PL_perlio_mutex);
+ /* Oh cXap. This isn't going to go well. Not sure if we can
+ recover from here, or if closing this particular FILE *
+ is a good idea now. */
+ }
+#endif
+ }
+ } else {
+ SAVE_ERRNO; /* This is here only to silence compiler warnings */
}
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;
+ RESTORE_ERRNO;
result = 0;
}
#ifdef SOCKS5_VERSION_NAME
/* in SOCKS' case, let close() determine return value */
result = close(fd);
#endif
- if (dupfd) {
+ if (dupfd >= 0) {
PerlLIO_dup2(dupfd,fd);
PerlLIO_close(dupfd);
+#ifdef USE_ITHREADS
+ MUTEX_UNLOCK(&PL_perlio_mutex);
+#endif
}
return result;
}
PerlIOStdio_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
{
dVAR;
- FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
+ FILE * s;
SSize_t got = 0;
+ if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
+ return -1;
+ s = PerlIOSelf(f, PerlIOStdio)->stdio;
for (;;) {
if (count == 1) {
STDCHAR *buf = (STDCHAR *) vbuf;
got = -1;
if (got >= 0 || errno != EINTR)
break;
- PERL_ASYNC_CHECK();
+ if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
+ return -1;
SETERRNO(0,0); /* just in case */
}
return got;
{
dVAR;
SSize_t got;
+ if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
+ return -1;
for (;;) {
got = PerlSIO_fwrite(vbuf, 1, count,
PerlIOSelf(f, PerlIOStdio)->stdio);
if (got >= 0 || errno != EINTR)
break;
- PERL_ASYNC_CHECK();
+ if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
+ return -1;
SETERRNO(0,0); /* just in case */
}
return got;
/*
* Not writeable - sync by attempting a seek
*/
- const int err = errno;
+ dSAVE_ERRNO;
if (PerlSIO_fseek(stdio, (Off_t) 0, SEEK_CUR) != 0)
- errno = err;
+ RESTORE_ERRNO;
#endif
}
return 0;
FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
if (ptr != NULL) {
#ifdef STDIO_PTR_LVALUE
- PerlSIO_set_ptr(stdio, (void*)ptr); /* LHS STDCHAR* cast non-portable */
+ PerlSIO_set_ptr(stdio, ptr); /* LHS STDCHAR* cast non-portable */
#ifdef STDIO_PTR_LVAL_SETS_CNT
- if (PerlSIO_get_cnt(stdio) != (cnt)) {
- assert(PerlSIO_get_cnt(stdio) == (cnt));
- }
+ assert(PerlSIO_get_cnt(stdio) == (cnt));
#endif
#if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
/*
IV
PerlIOStdio_fill(pTHX_ PerlIO *f)
{
- FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
+ FILE * stdio;
int c;
PERL_UNUSED_CONTEXT;
+ if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
+ return -1;
+ stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
/*
* fflush()ing read-only streams can cause trouble on some stdio-s
if (PerlSIO_fflush(stdio) != 0)
return EOF;
}
- c = PerlSIO_fgetc(stdio);
- if (c == EOF)
- return EOF;
+ for (;;) {
+ c = PerlSIO_fgetc(stdio);
+ if (c != EOF)
+ break;
+ if (! PerlSIO_ferror(stdio) || errno != EINTR)
+ return EOF;
+ if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
+ return -1;
+ SETERRNO(0,0);
+ }
#if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
if ((f2 = PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_stdio), buf, NULL))) {
PerlIOStdio *s = PerlIOSelf((f = f2), PerlIOStdio);
s->stdio = stdio;
+ PerlIOUnix_refcnt_inc(fileno(stdio));
/* Link previous lower layers under new one */
*PerlIONext(f) = l;
}
PerlIO_findFILE(PerlIO *f)
{
PerlIOl *l = *f;
+ FILE *stdio;
while (l) {
if (l->tab == &PerlIO_stdio) {
PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
l = *PerlIONext(&l);
}
/* Uses fallback "mode" via PerlIO_modestr() in PerlIO_exportFILE */
- return PerlIO_exportFILE(f, NULL);
+ /* However, we're not really exporting a FILE * to someone else (who
+ becomes responsible for closing it, or calling PerlIO_releaseFILE())
+ So we need to undo its reference count increase on the underlying file
+ descriptor. We have to do this, because if the loop above returns you
+ the FILE *, then *it* didn't increase any reference count. So there's
+ only one way to be consistent. */
+ stdio = PerlIO_exportFILE(f, NULL);
+ if (stdio) {
+ const int fd = fileno(stdio);
+ if (fd >= 0)
+ PerlIOUnix_refcnt_dec(fd);
+ }
+ return stdio;
}
/* Use this to reverse PerlIO_exportFILE calls. */
PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
if (s->stdio == f) {
dTHX;
+ const int fd = fileno(f);
+ if (fd >= 0)
+ PerlIOUnix_refcnt_dec(fd);
PerlIO_pop(aTHX_ p);
return;
}
*/
PerlLIO_setmode(fd, O_BINARY);
#endif
+#ifdef VMS
+#include <rms.h>
+ /* Enable line buffering with record-oriented regular files
+ * so we don't introduce an extraneous record boundary when
+ * the buffer fills up.
+ */
+ if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
+ Stat_t st;
+ if (PerlLIO_fstat(fd, &st) == 0
+ && S_ISREG(st.st_mode)
+ && (st.st_fab_rfm == FAB$C_VAR
+ || st.st_fab_rfm == FAB$C_VFC)) {
+ PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
+ }
+ }
+#endif
}
}
}
PerlIO_flush(f);
}
if (b->ptr >= (b->buf + b->bufsiz))
- PerlIO_flush(f);
+ if (PerlIO_flush(f) == -1)
+ return -1;
}
if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
PerlIO_flush(f);
if (!b->buf) {
if (!b->bufsiz)
- b->bufsiz = 4096;
- b->buf = Newxz(b->buf,b->bufsiz, STDCHAR);
+ b->bufsiz = PERLIOBUF_DEFAULT_BUFSIZ;
+ Newxz(b->buf,b->bufsiz, STDCHAR);
if (!b->buf) {
b->buf = (STDCHAR *) & b->oneword;
b->bufsiz = sizeof(b->oneword);
PerlIOBuf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
{
PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
+#ifndef DEBUGGING
+ PERL_UNUSED_ARG(cnt);
+#endif
if (!b->buf)
PerlIO_get_base(f);
b->ptr = ptr;
- if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf) {
- assert(PerlIO_get_cnt(f) == cnt);
- assert(b->ptr >= b->buf);
- }
+ assert(PerlIO_get_cnt(f) == cnt);
+ assert(b->ptr >= b->buf);
PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
}
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)",
+ (void*)f, PerlIOBase(f)->tab->name, (mode) ? mode : "(Null)",
PerlIOBase(f)->flags);
#endif
{
* any given moment at most one CRLF-capable layer being enabled
* in the whole layer stack. */
PerlIO *g = PerlIONext(f);
- while (PerlIOValid(g)) {
+ if (PerlIOValid(g)) {
PerlIOl *b = PerlIOBase(g);
if (b && b->tab == &PerlIO_crlf) {
if (!(b->flags & PERLIO_F_CRLF))
S_inherit_utf8_flag(g);
PerlIO_pop(aTHX_ f);
return code;
- }
- g = PerlIONext(g);
+ }
}
}
S_inherit_utf8_flag(f);
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 */
+ /* Deferred CR at end of buffer case - we lied about count */
ptr--;
}
}
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 */
+ /* Deferred 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);
+ " nl=%p e=%p for %d", (void*)ptr, (void*)chk,
+ flags, c->nl, b->end, cnt);
}
#endif
}
PerlIOBase(f)->flags &= ~PERLIO_F_CRLF;
#ifndef PERLIO_USING_CRLF
/* CRLF is unusual case - if this is just the :crlf layer pop it */
- if (PerlIOBase(f)->tab == &PerlIO_crlf) {
- PerlIO_pop(aTHX_ f);
- }
+ PerlIO_pop(aTHX_ f);
#endif
}
return 0;
}
posn = (b->posn / PL_mmap_page_size) * PL_mmap_page_size;
len = st.st_size - posn;
- m->mptr = mmap(NULL, len, PROT_READ, MAP_SHARED, fd, posn);
+ m->mptr = (Mmap_t)mmap(NULL, len, PROT_READ, MAP_SHARED, fd, posn);
if (m->mptr && m->mptr != (Mmap_t) - 1) {
#if 0 && defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
madvise(m->mptr, len, MADV_SEQUENTIAL);
if (!PL_perlio) {
PerlIO_stdstreams(aTHX);
}
- return &PL_perlio[1];
+ return (PerlIO*)&PL_perlio[1];
}
PerlIO *
if (!PL_perlio) {
PerlIO_stdstreams(aTHX);
}
- return &PL_perlio[2];
+ return (PerlIO*)&PL_perlio[2];
}
PerlIO *
if (!PL_perlio) {
PerlIO_stdstreams(aTHX);
}
- return &PL_perlio[3];
+ return (PerlIO*)&PL_perlio[3];
}
/*--------------------------------------------------------------------------------------*/
PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
{
dTHX;
- SV * const sv = newSVpvs("");
+ SV * sv;
const char *s;
STRLEN len;
SSize_t wrote;
#ifdef NEED_VA_COPY
va_list apc;
Perl_va_copy(ap, apc);
- sv_vcatpvf(sv, fmt, &apc);
+ sv = vnewSVpvf(fmt, &apc);
#else
- sv_vcatpvf(sv, fmt, &ap);
+ sv = vnewSVpvf(fmt, &ap);
#endif
s = SvPV_const(sv, len);
wrote = PerlIO_write(f, s, len);
f = PerlIO_fdopen(fd, "w+b");
#else /* WIN32 */
# if defined(HAS_MKSTEMP) && ! defined(VMS) && ! defined(OS2)
- SV * const sv = newSVpvs("/tmp/PerlIO_XXXXXX");
+ int fd = -1;
+ char tempname[] = "/tmp/PerlIO_XXXXXX";
+ const char * const tmpdir = PL_tainting ? NULL : PerlEnv_getenv("TMPDIR");
+ SV * sv = NULL;
/*
* I have no idea how portable mkstemp() is ... NI-S
*/
- const int fd = mkstemp(SvPVX(sv));
+ if (tmpdir && *tmpdir) {
+ /* if TMPDIR is set and not empty, we try that first */
+ sv = newSVpv(tmpdir, 0);
+ sv_catpv(sv, tempname + 4);
+ fd = mkstemp(SvPVX(sv));
+ }
+ if (fd < 0) {
+ sv = NULL;
+ /* else we try /tmp */
+ fd = mkstemp(tempname);
+ }
if (fd >= 0) {
f = PerlIO_fdopen(fd, "w+");
if (f)
PerlIOBase(f)->flags |= PERLIO_F_TEMP;
- PerlLIO_unlink(SvPVX_const(sv));
- SvREFCNT_dec(sv);
+ PerlLIO_unlink(sv ? SvPVX_const(sv) : tempname);
}
+ SvREFCNT_dec(sv);
# else /* !HAS_MKSTEMP, fallback to stdio tmpfile(). */
FILE * const stdio = PerlSIO_tmpfile();
- if (stdio) {
- if ((f = PerlIO_push(aTHX_(PerlIO_allocate(aTHX)),
- PERLIO_FUNCS_CAST(&PerlIO_stdio),
- "w+", NULL))) {
- PerlIOStdio * const s = PerlIOSelf(f, PerlIOStdio);
+ if (stdio)
+ f = PerlIO_fdopen(fileno(stdio), "w+");
- if (s)
- s->stdio = stdio;
- }
- }
# endif /* else HAS_MKSTEMP */
#endif /* else WIN32 */
return f;
Perl_PerlIO_context_layers(pTHX_ const char *mode)
{
dVAR;
- const char *type = NULL;
+ const char *direction = NULL;
+ SV *layers;
/*
* Need to supply default layer info from open.pm
*/
- if (PL_curcop && PL_curcop->cop_hints & HINT_LEXICAL_IO) {
- SV * const layers
- = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash, 0,
- "open", 4, 0, 0);
- assert(layers);
- if (SvOK(layers)) {
- STRLEN len;
- type = SvPV_const(layers, len);
- if (type && mode && mode[0] != 'r') {
- /*
- * Skip to write part, which is separated by a '\0'
- */
- STRLEN read_len = strlen(type);
- if (read_len < len) {
- type += read_len + 1;
- }
- }
- }
+
+ if (!PL_curcop)
+ return NULL;
+
+ if (mode && mode[0] != 'r') {
+ if (PL_curcop->cop_hints & HINT_LEXICAL_IO_OUT)
+ direction = "open>";
+ } else {
+ if (PL_curcop->cop_hints & HINT_LEXICAL_IO_IN)
+ direction = "open<";
}
- return type;
+ if (!direction)
+ return NULL;
+
+ layers = cop_hints_fetch_pvn(PL_curcop, direction, 5, 0, 0);
+
+ assert(layers);
+ return SvOK(layers) ? SvPV_nolen_const(layers) : NULL;
}
https://perl5.git.perl.org / perl5.git / blobdiff