/*
* perlio.c
* Copyright (c) 1996-2006, Nick Ing-Simmons
- * Copyright (c) 2006, 2007, Larry Wall and others
+ * Copyright (c) 2006, 2007, 2008, 2009, 2010, 2011 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)
#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
#include "perliol.h"
-/*
- * We _MUST_ have <unistd.h> if we are using lseek() and may have large
- * files
- */
-#ifdef I_UNISTD
-#include <unistd.h>
-#endif
-#ifdef HAS_MMAP
-#include <sys/mman.h>
-#endif
-
void
PerlIO_debug(const char *fmt, ...)
{
dSYS;
va_start(ap, fmt);
if (!PL_perlio_debug_fd) {
- if (!PL_tainting && PL_uid == PL_euid && PL_gid == PL_egid) {
+ if (!PL_tainting &&
+ PerlProc_getuid() == PerlProc_geteuid() &&
+ PerlProc_getgid() == PerlProc_getegid()) {
const char * const s = PerlEnv_getenv("PERLIO_DEBUG");
if (s && *s)
PL_perlio_debug_fd
#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);
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 = Perl_get_cvn_flags(aTHX_ STR_WITH_LEN("PerlIO::Layer::NoWarnings"), 0);
+ 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",
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",
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;
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;
* 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:
/*
arg = newSVpvn(as, alen);
PerlIO_list_push(aTHX_ av, layer,
(arg) ? arg : &PL_sv_undef);
- if (arg)
- SvREFCNT_dec(arg);
+ 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,
PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_perlio));
PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_stdio));
PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_crlf));
-#ifdef HAS_MMAP
- PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_mmap));
-#endif
PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_utf8));
PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_remove));
PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_byte));
{
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) {
+ 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 && ckWARN(WARN_LAYER))
- Perl_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"scalar\"");
+ if (!f)
+ /* diag_listed_as: Unknown PerlIO layer "%s" */
+ Perl_ck_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"scalar\"");
return f;
}
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);
}
}
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;
sizeof(PerlIO_funcs),
"utf8",
0,
- PERLIO_K_DUMMY | PERLIO_K_UTF8,
+ PERLIO_K_DUMMY | PERLIO_K_UTF8 | PERLIO_K_MULTIARG,
PerlIOUtf8_pushed,
NULL,
- NULL,
+ PerlIOBase_open,
NULL,
NULL,
NULL,
sizeof(PerlIO_funcs),
"bytes",
0,
- PERLIO_K_DUMMY,
+ PERLIO_K_DUMMY | PERLIO_K_MULTIARG,
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)
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 (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[fd]++;
if (PL_perlio_fd_refcnt[fd] <= 0) {
+ /* diag_listed_as: refcnt_inc: fd %d%s */
Perl_croak(aTHX_ "refcnt_inc: fd %d: %d <= 0\n",
fd, PL_perlio_fd_refcnt[fd]);
}
MUTEX_UNLOCK(&PL_perlio_mutex);
#endif
} else {
+ /* diag_listed_as: refcnt_inc: fd %d%s */
Perl_croak(aTHX_ "refcnt_inc: fd %d < 0\n", fd);
}
}
MUTEX_LOCK(&PL_perlio_mutex);
#endif
if (fd >= PL_perlio_fd_refcnt_size) {
+ /* diag_listed_as: refcnt_dec: fd %d%s */
Perl_croak(aTHX_ "refcnt_dec: fd %d >= refcnt_size %d\n",
fd, PL_perlio_fd_refcnt_size);
}
if (PL_perlio_fd_refcnt[fd] <= 0) {
+ /* diag_listed_as: refcnt_dec: fd %d%s */
Perl_croak(aTHX_ "refcnt_dec: fd %d: %d <= 0\n",
fd, PL_perlio_fd_refcnt[fd]);
}
MUTEX_UNLOCK(&PL_perlio_mutex);
#endif
} else {
+ /* diag_listed_as: refcnt_dec: fd %d%s */
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_cleanup(pTHX)
{
}
}
-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
+#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. */
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) ) {
+ LEAVE;
+ 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);
+ }
+ LEAVE;
+ 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;
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;
}
f->_file = -1;
return 1;
# elif defined(WIN32)
-# if defined(__BORLANDC__)
- f->fd = PerlLIO_dup(fileno(f));
-# elif defined(UNDER_CE)
+# if defined(UNDER_CE)
/* WIN_CE does not have access to FILE internals, it hardly has FILE
structure at all
*/
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;
#ifdef STDIO_PTR_LVALUE
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
break;
if (! PerlSIO_ferror(stdio) || errno != EINTR)
return EOF;
- PERL_ASYNC_CHECK();
+ if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
+ return -1;
SETERRNO(0,0);
}
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. */
*/
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;
}
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. */
+ /* If the old top layer is a CRLF layer, reactivate it (if
+ * necessary) and remove this new layer from the 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;
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;
PerlIOCrlf_set_ptrcnt,
};
-#ifdef HAS_MMAP
-/*--------------------------------------------------------------------------------------*/
-/*
- * mmap as "buffer" layer
- */
-
-typedef struct {
- PerlIOBuf base; /* PerlIOBuf stuff */
- Mmap_t mptr; /* Mapped address */
- Size_t len; /* mapped length */
- STDCHAR *bbuf; /* malloced buffer if map fails */
-} PerlIOMmap;
-
-IV
-PerlIOMmap_map(pTHX_ PerlIO *f)
-{
- dVAR;
- PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
- const IV flags = PerlIOBase(f)->flags;
- IV code = 0;
- if (m->len)
- abort();
- if (flags & PERLIO_F_CANREAD) {
- PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
- const int fd = PerlIO_fileno(f);
- Stat_t st;
- code = Fstat(fd, &st);
- if (code == 0 && S_ISREG(st.st_mode)) {
- SSize_t len = st.st_size - b->posn;
- if (len > 0) {
- Off_t posn;
- if (PL_mmap_page_size <= 0)
- Perl_croak(aTHX_ "panic: bad pagesize %" IVdf,
- PL_mmap_page_size);
- if (b->posn < 0) {
- /*
- * This is a hack - should never happen - open should
- * have set it !
- */
- b->posn = PerlIO_tell(PerlIONext(f));
- }
- posn = (b->posn / PL_mmap_page_size) * PL_mmap_page_size;
- len = st.st_size - 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);
-#endif
-#if 0 && defined(HAS_MADVISE) && defined(MADV_WILLNEED)
- madvise(m->mptr, len, MADV_WILLNEED);
-#endif
- PerlIOBase(f)->flags =
- (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
- b->end = ((STDCHAR *) m->mptr) + len;
- b->buf = ((STDCHAR *) m->mptr) + (b->posn - posn);
- b->ptr = b->buf;
- m->len = len;
- }
- else {
- b->buf = NULL;
- }
- }
- else {
- PerlIOBase(f)->flags =
- flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
- b->buf = NULL;
- b->ptr = b->end = b->ptr;
- code = -1;
- }
- }
- }
- return code;
-}
-
-IV
-PerlIOMmap_unmap(pTHX_ PerlIO *f)
-{
- PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
- IV code = 0;
- if (m->len) {
- PerlIOBuf * const b = &m->base;
- if (b->buf) {
- /* The munmap address argument is tricky: depending on the
- * standard it is either "void *" or "caddr_t" (which is
- * usually "char *" (signed or unsigned). If we cast it
- * to "void *", those that have it caddr_t and an uptight
- * C++ compiler, will freak out. But casting it as char*
- * should work. Maybe. (Using Mmap_t figured out by
- * Configure doesn't always work, apparently.) */
- code = munmap((char*)m->mptr, m->len);
- b->buf = NULL;
- m->len = 0;
- m->mptr = NULL;
- if (PerlIO_seek(PerlIONext(f), b->posn, SEEK_SET) != 0)
- code = -1;
- }
- b->ptr = b->end = b->buf;
- PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
- }
- return code;
-}
-
-STDCHAR *
-PerlIOMmap_get_base(pTHX_ PerlIO *f)
-{
- PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
- PerlIOBuf * const b = &m->base;
- if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
- /*
- * Already have a readbuffer in progress
- */
- return b->buf;
- }
- if (b->buf) {
- /*
- * We have a write buffer or flushed PerlIOBuf read buffer
- */
- m->bbuf = b->buf; /* save it in case we need it again */
- b->buf = NULL; /* Clear to trigger below */
- }
- if (!b->buf) {
- PerlIOMmap_map(aTHX_ f); /* Try and map it */
- if (!b->buf) {
- /*
- * Map did not work - recover PerlIOBuf buffer if we have one
- */
- b->buf = m->bbuf;
- }
- }
- b->ptr = b->end = b->buf;
- if (b->buf)
- return b->buf;
- return PerlIOBuf_get_base(aTHX_ f);
-}
-
-SSize_t
-PerlIOMmap_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
-{
- PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
- PerlIOBuf * const b = &m->base;
- if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
- PerlIO_flush(f);
- if (b->ptr && (b->ptr - count) >= b->buf
- && memEQ(b->ptr - count, vbuf, count)) {
- b->ptr -= count;
- PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
- return count;
- }
- if (m->len) {
- /*
- * Loose the unwritable mapped buffer
- */
- PerlIO_flush(f);
- /*
- * If flush took the "buffer" see if we have one from before
- */
- if (!b->buf && m->bbuf)
- b->buf = m->bbuf;
- if (!b->buf) {
- PerlIOBuf_get_base(aTHX_ f);
- m->bbuf = b->buf;
- }
- }
- return PerlIOBuf_unread(aTHX_ f, vbuf, count);
-}
-
-SSize_t
-PerlIOMmap_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
-{
- PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
- PerlIOBuf * const b = &m->base;
-
- if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF)) {
- /*
- * No, or wrong sort of, buffer
- */
- if (m->len) {
- if (PerlIOMmap_unmap(aTHX_ f) != 0)
- return 0;
- }
- /*
- * If unmap took the "buffer" see if we have one from before
- */
- if (!b->buf && m->bbuf)
- b->buf = m->bbuf;
- if (!b->buf) {
- PerlIOBuf_get_base(aTHX_ f);
- m->bbuf = b->buf;
- }
- }
- return PerlIOBuf_write(aTHX_ f, vbuf, count);
-}
-
-IV
-PerlIOMmap_flush(pTHX_ PerlIO *f)
-{
- PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
- PerlIOBuf * const b = &m->base;
- IV code = PerlIOBuf_flush(aTHX_ f);
- /*
- * Now we are "synced" at PerlIOBuf level
- */
- if (b->buf) {
- if (m->len) {
- /*
- * Unmap the buffer
- */
- if (PerlIOMmap_unmap(aTHX_ f) != 0)
- code = -1;
- }
- else {
- /*
- * We seem to have a PerlIOBuf buffer which was not mapped
- * remember it in case we need one later
- */
- m->bbuf = b->buf;
- }
- }
- return code;
-}
-
-IV
-PerlIOMmap_fill(pTHX_ PerlIO *f)
-{
- PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
- IV code = PerlIO_flush(f);
- if (code == 0 && !b->buf) {
- code = PerlIOMmap_map(aTHX_ f);
- }
- if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
- code = PerlIOBuf_fill(aTHX_ f);
- }
- return code;
-}
-
-IV
-PerlIOMmap_close(pTHX_ PerlIO *f)
-{
- PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
- PerlIOBuf * const b = &m->base;
- IV code = PerlIO_flush(f);
- if (m->bbuf) {
- b->buf = m->bbuf;
- m->bbuf = NULL;
- b->ptr = b->end = b->buf;
- }
- if (PerlIOBuf_close(aTHX_ f) != 0)
- code = -1;
- return code;
-}
-
-PerlIO *
-PerlIOMmap_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
-{
- return PerlIOBase_dup(aTHX_ f, o, param, flags);
-}
-
-
-PERLIO_FUNCS_DECL(PerlIO_mmap) = {
- sizeof(PerlIO_funcs),
- "mmap",
- sizeof(PerlIOMmap),
- PERLIO_K_BUFFERED|PERLIO_K_RAW,
- PerlIOBuf_pushed,
- PerlIOBuf_popped,
- PerlIOBuf_open,
- PerlIOBase_binmode, /* binmode */
- NULL,
- PerlIOBase_fileno,
- PerlIOMmap_dup,
- PerlIOBuf_read,
- PerlIOMmap_unread,
- PerlIOMmap_write,
- PerlIOBuf_seek,
- PerlIOBuf_tell,
- PerlIOBuf_close,
- PerlIOMmap_flush,
- PerlIOMmap_fill,
- PerlIOBase_eof,
- PerlIOBase_error,
- PerlIOBase_clearerr,
- PerlIOBase_setlinebuf,
- PerlIOMmap_get_base,
- PerlIOBuf_bufsiz,
- PerlIOBuf_get_ptr,
- PerlIOBuf_get_cnt,
- PerlIOBuf_set_ptrcnt,
-};
-
-#endif /* HAS_MMAP */
-
PerlIO *
Perl_PerlIO_stdin(pTHX)
{
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));
+ PerlLIO_unlink(sv ? SvPVX_const(sv) : tempname);
}
SvREFCNT_dec(sv);
# else /* !HAS_MKSTEMP, fallback to stdio 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