* 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;
+ 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;
+ 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);
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
SV * const layer = newSVpvn(name, len);
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 = 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);
}
arg = newSVpvn(as, alen);
PerlIO_list_push(aTHX_ av, layer,
(arg) ? arg : &PL_sv_undef);
- if (arg)
- SvREFCNT_dec(arg);
+ SvREFCNT_dec(arg);
}
else {
Perl_ck_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"%.*s\"",
{
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 (%d) does not match %s (%d)",
+ "PerlIO layer function table size", tab->fsize,
+ "size expected by this perl", sizeof(PerlIO_funcs) );
}
if (tab->size) {
PerlIOl *l;
if (tab->size < sizeof(PerlIOl)) {
- goto mismatch;
+ Perl_croak( aTHX_
+ "%s (%d) smaller than %s (%d)",
+ "PerlIO layer instance size", tab->size,
+ "size expected by this perl", 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,
{
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_ t) == 0) {
if (*t == l) {
}
}
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);
/*
* For any scalar type load the handler which is bundled with perl
*/
- if (SvTYPE(sv) < SVt_PVAV) {
+ 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 */
layera = PerlIO_list_alloc(aTHX);
while (l) {
SV *arg = NULL;
- if (l->tab->Getarg)
+ 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);
- if (arg)
- SvREFCNT_dec(arg);
+ SvREFCNT_dec(arg);
l = *PerlIONext(&l);
}
}
* 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++;
}
}
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;
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)
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);
f = PerlIO_push(aTHX_ f, self, PerlIO_modestr(o,buf), arg);
if (PerlIOBase(o)->flags & PERLIO_F_UTF8)
PerlIOBase(f)->flags |= PERLIO_F_UTF8;
- if (arg)
- SvREFCNT_dec(arg);
+ SvREFCNT_dec(arg);
}
return f;
}
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);
*/
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
}
}
}
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);
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];
}
/*--------------------------------------------------------------------------------------*/
int fd = -1;
char tempname[] = "/tmp/PerlIO_XXXXXX";
const char * const tmpdir = PL_tainting ? NULL : PerlEnv_getenv("TMPDIR");
- SV * const sv = tmpdir && *tmpdir ? newSVpv(tmpdir, 0) : NULL;
+ SV * sv = NULL;
/*
* I have no idea how portable mkstemp() is ... NI-S
*/
- if (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);
}
PerlIOBase(f)->flags |= PERLIO_F_TEMP;
PerlLIO_unlink(sv ? SvPVX_const(sv) : tempname);
}
- if (sv)
- SvREFCNT_dec(sv);
+ SvREFCNT_dec(sv);
# else /* !HAS_MKSTEMP, fallback to stdio tmpfile(). */
FILE * const stdio = PerlSIO_tmpfile();
if (!direction)
return NULL;
- layers = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash,
- 0, direction, 5, 0, 0);
+ 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