/*
* perlio.c
* Copyright (c) 1996-2006, Nick Ing-Simmons
* 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
* is Perl's private replacement for the C stdio library. This is used
* by default unless you compile with -Uuseperlio or run with
* PERLIO=:stdio (but don't do this unless you know what you're doing)
*/
/*
* If we have ActivePerl-like PERL_IMPLICIT_SYS then we need a dTHX to get
* at the dispatch tables, even when we do not need it for other reasons.
* Invent a dSYS macro to abstract this out
*/
#ifdef PERL_IMPLICIT_SYS
#define dSYS dTHX
#else
#define dSYS dNOOP
#endif
#define VOIDUSED 1
#ifdef PERL_MICRO
# include "uconfig.h"
#else
# ifndef USE_CROSS_COMPILE
# include "config.h"
# else
# include "xconfig.h"
# endif
#endif
#define PERLIO_NOT_STDIO 0
#if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
/*
* #define PerlIO FILE
*/
#endif
/*
* This file provides those parts of PerlIO abstraction
* which are not #defined in perlio.h.
* Which these are depends on various Configure #ifdef's
*/
#include "EXTERN.h"
#define PERL_IN_PERLIO_C
#include "perl.h"
#ifdef PERL_IMPLICIT_CONTEXT
#undef dSYS
#define dSYS dTHX
#endif
#include "XSUB.h"
#ifdef __Lynx__
/* Missing proto on LynxOS */
int mkstemp(char*);
#endif
#ifdef VMS
#include <rms.h>
#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)) { \
const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\
if (tab && tab->callback) \
return (*tab->callback) args; \
else \
return PerlIOBase_ ## base args; \
} \
else \
SETERRNO(EBADF, SS_IVCHAN); \
return failure
/* Call the callback or fail, and return failure. */
#define Perl_PerlIO_or_fail(f, callback, failure, args) \
if (PerlIOValid(f)) { \
const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\
if (tab && tab->callback) \
return (*tab->callback) args; \
SETERRNO(EINVAL, LIB_INVARG); \
} \
else \
SETERRNO(EBADF, SS_IVCHAN); \
return failure
/* Call the callback or PerlIOBase, and be void. */
#define Perl_PerlIO_or_Base_void(f, callback, base, args) \
if (PerlIOValid(f)) { \
const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\
if (tab && tab->callback) \
(*tab->callback) args; \
else \
PerlIOBase_ ## base args; \
} \
else \
SETERRNO(EBADF, SS_IVCHAN)
/* Call the callback or fail, and be void. */
#define Perl_PerlIO_or_fail_void(f, callback, args) \
if (PerlIOValid(f)) { \
const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\
if (tab && tab->callback) \
(*tab->callback) args; \
else \
SETERRNO(EINVAL, LIB_INVARG); \
} \
else \
SETERRNO(EBADF, SS_IVCHAN)
#if defined(__osf__) && _XOPEN_SOURCE < 500
extern int fseeko(FILE *, off_t, int);
extern off_t ftello(FILE *);
#endif
#ifndef USE_SFIO
EXTERN_C int perlsio_binmode(FILE *fp, int iotype, int mode);
int
perlsio_binmode(FILE *fp, int iotype, int mode)
{
/*
* This used to be contents of do_binmode in doio.c
*/
#ifdef DOSISH
# if defined(atarist)
PERL_UNUSED_ARG(iotype);
if (!fflush(fp)) {
if (mode & O_BINARY)
((FILE *) fp)->_flag |= _IOBIN;
else
((FILE *) fp)->_flag &= ~_IOBIN;
return 1;
}
return 0;
# else
dTHX;
PERL_UNUSED_ARG(iotype);
#ifdef NETWARE
if (PerlLIO_setmode(fp, mode) != -1) {
#else
if (PerlLIO_setmode(fileno(fp), mode) != -1) {
#endif
return 1;
}
else
return 0;
# endif
#else
# if defined(USEMYBINMODE)
dTHX;
# if defined(__CYGWIN__)
PERL_UNUSED_ARG(iotype);
# endif
if (my_binmode(fp, iotype, mode) != FALSE)
return 1;
else
return 0;
# else
PERL_UNUSED_ARG(fp);
PERL_UNUSED_ARG(iotype);
PERL_UNUSED_ARG(mode);
return 1;
# endif
#endif
}
#endif /* sfio */
#ifndef O_ACCMODE
#define O_ACCMODE 3 /* Assume traditional implementation */
#endif
int
PerlIO_intmode2str(int rawmode, char *mode, int *writing)
{
const int result = rawmode & O_ACCMODE;
int ix = 0;
int ptype;
switch (result) {
case O_RDONLY:
ptype = IoTYPE_RDONLY;
break;
case O_WRONLY:
ptype = IoTYPE_WRONLY;
break;
case O_RDWR:
default:
ptype = IoTYPE_RDWR;
break;
}
if (writing)
*writing = (result != O_RDONLY);
if (result == O_RDONLY) {
mode[ix++] = 'r';
}
#ifdef O_APPEND
else if (rawmode & O_APPEND) {
mode[ix++] = 'a';
if (result != O_WRONLY)
mode[ix++] = '+';
}
#endif
else {
if (result == O_WRONLY)
mode[ix++] = 'w';
else {
mode[ix++] = 'r';
mode[ix++] = '+';
}
}
if (rawmode & O_BINARY)
mode[ix++] = 'b';
mode[ix] = '\0';
return ptype;
}
#ifndef PERLIO_LAYERS
int
PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
{
if (!names || !*names
|| strEQ(names, ":crlf")
|| strEQ(names, ":raw")
|| strEQ(names, ":bytes")
) {
return 0;
}
Perl_croak(aTHX_ "Cannot apply \"%s\" in non-PerlIO perl", names);
/*
* NOTREACHED
*/
return -1;
}
void
PerlIO_destruct(pTHX)
{
}
int
PerlIO_binmode(pTHX_ PerlIO *fp, int iotype, int mode, const char *names)
{
#ifdef USE_SFIO
PERL_UNUSED_ARG(iotype);
PERL_UNUSED_ARG(mode);
PERL_UNUSED_ARG(names);
return 1;
#else
return perlsio_binmode(fp, iotype, mode);
#endif
}
PerlIO *
PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)
{
#if defined(PERL_MICRO) || defined(__SYMBIAN32__)
return NULL;
#else
#ifdef PERL_IMPLICIT_SYS
return PerlSIO_fdupopen(f);
#else
#ifdef WIN32
return win32_fdupopen(f);
#else
if (f) {
const int fd = PerlLIO_dup(PerlIO_fileno(f));
if (fd >= 0) {
char mode[8];
#ifdef DJGPP
const int omode = djgpp_get_stream_mode(f);
#else
const int omode = fcntl(fd, F_GETFL);
#endif
PerlIO_intmode2str(omode,mode,NULL);
/* the r+ is a hack */
return PerlIO_fdopen(fd, mode);
}
return NULL;
}
else {
SETERRNO(EBADF, SS_IVCHAN);
}
#endif
return NULL;
#endif
#endif
}
/*
* De-mux PerlIO_openn() into fdopen, freopen and fopen type entries
*/
PerlIO *
PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
int imode, int perm, PerlIO *old, int narg, SV **args)
{
if (narg) {
if (narg > 1) {
Perl_croak(aTHX_ "More than one argument to open");
}
if (*args == &PL_sv_undef)
return PerlIO_tmpfile();
else {
const char *name = SvPV_nolen_const(*args);
if (*mode == IoTYPE_NUMERIC) {
fd = PerlLIO_open3(name, imode, perm);
if (fd >= 0)
return PerlIO_fdopen(fd, mode + 1);
}
else if (old) {
return PerlIO_reopen(name, mode, old);
}
else {
return PerlIO_open(name, mode);
}
}
}
else {
return PerlIO_fdopen(fd, (char *) mode);
}
return NULL;
}
XS(XS_PerlIO__Layer__find)
{
dXSARGS;
if (items < 2)
Perl_croak(aTHX_ "Usage class->find(name[,load])");
else {
const char * const name = SvPV_nolen_const(ST(1));
ST(0) = (strEQ(name, "crlf")
|| strEQ(name, "raw")) ? &PL_sv_yes : &PL_sv_undef;
XSRETURN(1);
}
}
void
Perl_boot_core_PerlIO(pTHX)
{
newXS("PerlIO::Layer::find", XS_PerlIO__Layer__find, __FILE__);
}
#endif
#ifdef PERLIO_IS_STDIO
void
PerlIO_init(pTHX)
{
PERL_UNUSED_CONTEXT;
/*
* Does nothing (yet) except force this file to be included in perl
* binary. That allows this file to force inclusion of other functions
* that may be required by loadable extensions e.g. for
* FileHandle::tmpfile
*/
}
#undef PerlIO_tmpfile
PerlIO *
PerlIO_tmpfile(void)
{
return tmpfile();
}
#else /* PERLIO_IS_STDIO */
#ifdef USE_SFIO
#undef HAS_FSETPOS
#undef HAS_FGETPOS
/*
* This section is just to make sure these functions get pulled in from
* libsfio.a
*/
#undef PerlIO_tmpfile
PerlIO *
PerlIO_tmpfile(void)
{
return sftmp(0);
}
void
PerlIO_init(pTHX)
{
PERL_UNUSED_CONTEXT;
/*
* Force this file to be included in perl binary. Which allows this
* file to force inclusion of other functions that may be required by
* loadable extensions e.g. for FileHandle::tmpfile
*/
/*
* Hack sfio does its own 'autoflush' on stdout in common cases. Flush
* results in a lot of lseek()s to regular files and lot of small
* writes to pipes.
*/
sfset(sfstdout, SF_SHARE, 0);
}
/* This is not the reverse of PerlIO_exportFILE(), PerlIO_releaseFILE() is. */
PerlIO *
PerlIO_importFILE(FILE *stdio, const char *mode)
{
const int fd = fileno(stdio);
if (!mode || !*mode) {
mode = "r+";
}
return PerlIO_fdopen(fd, mode);
}
FILE *
PerlIO_findFILE(PerlIO *pio)
{
const int fd = PerlIO_fileno(pio);
FILE * const f = fdopen(fd, "r+");
PerlIO_flush(pio);
if (!f && errno == EINVAL)
f = fdopen(fd, "w");
if (!f && errno == EINVAL)
f = fdopen(fd, "r");
return f;
}
#else /* USE_SFIO */
/*======================================================================================*/
/*
* Implement all the PerlIO interface ourselves.
*/
#include "perliol.h"
void
PerlIO_debug(const char *fmt, ...)
{
va_list ap;
dSYS;
va_start(ap, fmt);
if (!PL_perlio_debug_fd) {
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
= PerlLIO_open3(s, O_WRONLY | O_CREAT | O_APPEND, 0666);
else
PL_perlio_debug_fd = -1;
} else {
/* tainting or set*id, so ignore the environment, and ensure we
skip these tests next time through. */
PL_perlio_debug_fd = -1;
}
}
if (PL_perlio_debug_fd > 0) {
dTHX;
#ifdef USE_ITHREADS
const char * const s = CopFILE(PL_curcop);
/* Use fixed buffer as sv_catpvf etc. needs SVs */
char buffer[1024];
const STRLEN len1 = my_snprintf(buffer, sizeof(buffer), "%.40s:%" IVdf " ", s ? s : "(none)", (IV) CopLINE(PL_curcop));
const STRLEN len2 = my_vsnprintf(buffer + len1, sizeof(buffer) - len1, fmt, ap);
PerlLIO_write(PL_perlio_debug_fd, buffer, len1 + len2);
#else
const char *s = CopFILE(PL_curcop);
STRLEN len;
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);
PerlLIO_write(PL_perlio_debug_fd, s, len);
SvREFCNT_dec(sv);
#endif
}
va_end(ap);
}
/*--------------------------------------------------------------------------------------*/
/*
* 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)
{
dVAR;
/*
* Find a free slot in the table, allocating new table as necessary
*/
PerlIOl **last;
PerlIOl *f;
last = &PL_perlio;
while ((f = *last)) {
int i;
last = (PerlIOl **) (f);
for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
if (!((++f)->next)) {
f->flags = 0; /* lockcnt */
f->tab = NULL;
f->head = f;
return (PerlIO *)f;
}
}
}
Newxz(f,PERLIO_TABLE_SIZE,PerlIOl);
if (!f) {
return NULL;
}
*last = (PerlIOl*) f++;
f->flags = 0; /* lockcnt */
f->tab = NULL;
f->head = f;
return (PerlIO*) f;
}
#undef PerlIO_fdupopen
PerlIO *
PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)
{
if (PerlIOValid(f)) {
const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
PerlIO_debug("fdupopen f=%p param=%p\n",(void*)f,(void*)param);
if (tab && tab->Dup)
return (*tab->Dup)(aTHX_ PerlIO_allocate(aTHX), f, param, flags);
else {
return PerlIOBase_dup(aTHX_ PerlIO_allocate(aTHX), f, param, flags);
}
}
else
SETERRNO(EBADF, SS_IVCHAN);
return NULL;
}
void
PerlIO_cleantable(pTHX_ PerlIOl **tablep)
{
PerlIOl * const table = *tablep;
if (table) {
int i;
PerlIO_cleantable(aTHX_(PerlIOl **) & (table[0]));
for (i = PERLIO_TABLE_SIZE - 1; i > 0; i--) {
PerlIOl * const f = table + i;
if (f->next) {
PerlIO_close(&(f->next));
}
}
Safefree(table);
*tablep = NULL;
}
}
PerlIO_list_t *
PerlIO_list_alloc(pTHX)
{
PerlIO_list_t *list;
PERL_UNUSED_CONTEXT;
Newxz(list, 1, PerlIO_list_t);
list->refcnt = 1;
return list;
}
void
PerlIO_list_free(pTHX_ PerlIO_list_t *list)
{
if (list) {
if (--list->refcnt == 0) {
if (list->array) {
IV i;
for (i = 0; i < list->cur; i++)
SvREFCNT_dec(list->array[i].arg);
Safefree(list->array);
}
Safefree(list);
}
}
}
void
PerlIO_list_push(pTHX_ PerlIO_list_t *list, PerlIO_funcs *funcs, SV *arg)
{
dVAR;
PerlIO_pair_t *p;
PERL_UNUSED_CONTEXT;
if (list->cur >= list->len) {
list->len += 8;
if (list->array)
Renew(list->array, list->len, PerlIO_pair_t);
else
Newx(list->array, list->len, PerlIO_pair_t);
}
p = &(list->array[list->cur++]);
p->funcs = funcs;
if ((p->arg = arg)) {
SvREFCNT_inc_simple_void_NN(arg);
}
}
PerlIO_list_t *
PerlIO_clone_list(pTHX_ PerlIO_list_t *proto, CLONE_PARAMS *param)
{
PerlIO_list_t *list = NULL;
if (proto) {
int i;
list = PerlIO_list_alloc(aTHX);
for (i=0; i < proto->cur; i++) {
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);
}
}
return list;
}
void
PerlIO_clone(pTHX_ PerlInterpreter *proto, CLONE_PARAMS *param)
{
#ifdef USE_ITHREADS
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_init_table(aTHX);
PerlIO_debug("Clone %p from %p\n",(void*)aTHX,(void*)proto);
while ((f = *table)) {
int i;
table = (PerlIOl **) (f++);
for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
if (f->next) {
(void) fp_dup(&(f->next), 0, param);
}
f++;
}
}
#else
PERL_UNUSED_CONTEXT;
PERL_UNUSED_ARG(proto);
PERL_UNUSED_ARG(param);
#endif
}
void
PerlIO_destruct(pTHX)
{
dVAR;
PerlIOl **table = &PL_perlio;
PerlIOl *f;
#ifdef USE_ITHREADS
PerlIO_debug("Destruct %p\n",(void*)aTHX);
#endif
while ((f = *table)) {
int i;
table = (PerlIOl **) (f++);
for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
PerlIO *x = &(f->next);
const PerlIOl *l;
while ((l = *x)) {
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);
}
else {
x = PerlIONext(x);
}
}
f++;
}
}
}
void
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 ? 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
* use
*/
if ((*l->tab->Popped) (aTHX_ f) != 0)
return;
}
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);
}
}
}
/* Return as an array the stack of layers on a filehandle. Note that
* the stack is returned top-first in the array, and there are three
* times as many array elements as there are layers in the stack: the
* first element of a layer triplet is the name, the second one is the
* arguments, and the third one is the flags. */
AV *
PerlIO_get_layers(pTHX_ PerlIO *f)
{
dVAR;
AV * const av = newAV();
if (PerlIOValid(f)) {
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 ?
(*l->tab->Getarg)(aTHX_ &l, 0, 0) : &PL_sv_undef;
av_push(av, name);
av_push(av, arg);
av_push(av, newSViv((IV)l->flags));
l = l->next;
}
}
return av;
}
/*--------------------------------------------------------------------------------------*/
/*
* XS Interface for perl code
*/
PerlIO_funcs *
PerlIO_find_layer(pTHX_ const char *name, STRLEN len, int load)
{
dVAR;
IV i;
if ((SSize_t) len <= 0)
len = strlen(name);
for (i = 0; i < PL_known_layers->cur; i++) {
PerlIO_funcs * const f = PL_known_layers->array[i].funcs;
if (memEQ(f->name, name, len) && f->name[len] == 0) {
PerlIO_debug("%.*s => %p\n", (int) len, name, (void*)f);
return f;
}
}
if (load && PL_subname && PL_def_layerlist
&& PL_def_layerlist->cur >= 2) {
if (PL_in_load_module) {
Perl_croak(aTHX_ "Recursive call to Perl_load_module in PerlIO_find_layer");
return NULL;
} else {
SV * const pkgsv = newSVpvs("PerlIO");
SV * const layer = newSVpvn(name, len);
CV * const cv = get_cvs("PerlIO::Layer::NoWarnings", 0);
ENTER;
SAVEBOOL(PL_in_load_module);
if (cv) {
SAVEGENERICSV(PL_warnhook);
PL_warnhook = MUTABLE_SV((SvREFCNT_inc_simple_NN(cv)));
}
PL_in_load_module = TRUE;
/*
* The two SVs are magically freed by load_module
*/
Perl_load_module(aTHX_ 0, pkgsv, NULL, layer, NULL);
LEAVE;
return PerlIO_find_layer(aTHX_ name, len, 0);
}
}
PerlIO_debug("Cannot find %.*s\n", (int) len, name);
return NULL;
}
#ifdef USE_ATTRIBUTES_FOR_PERLIO
static int
perlio_mg_set(pTHX_ SV *sv, MAGIC *mg)
{
if (SvROK(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",
SVfARG(sv), (void*)io, (void*)ifp, (void*)ofp);
}
return 0;
}
static int
perlio_mg_get(pTHX_ SV *sv, MAGIC *mg)
{
if (SvROK(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",
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, SVfARG(sv));
return 0;
}
static int
perlio_mg_free(pTHX_ SV *sv, MAGIC *mg)
{
Perl_warn(aTHX_ "free %" SVf, SVfARG(sv));
return 0;
}
MGVTBL perlio_vtab = {
perlio_mg_get,
perlio_mg_set,
NULL, /* len */
perlio_mg_clear,
perlio_mg_free
};
XS(XS_io_MODIFY_SCALAR_ATTRIBUTES)
{
dXSARGS;
SV * const sv = SvRV(ST(1));
AV * const av = newAV();
MAGIC *mg;
int count = 0;
int i;
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, SVfARG(sv));
for (i = 2; i < items; i++) {
STRLEN len;
const char * const name = SvPV_const(ST(i), len);
SV * const layer = PerlIO_find_layer(aTHX_ name, len, 1);
if (layer) {
av_push(av, SvREFCNT_inc_simple_NN(layer));
}
else {
ST(count) = ST(i);
count++;
}
}
SvREFCNT_dec(av);
XSRETURN(count);
}
#endif /* USE_ATTIBUTES_FOR_PERLIO */
SV *
PerlIO_tab_sv(pTHX_ PerlIO_funcs *tab)
{
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 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);
}
XS(XS_PerlIO__Layer__find)
{
dVAR;
dXSARGS;
PERL_UNUSED_ARG(cv);
if (items < 2)
Perl_croak(aTHX_ "Usage class->find(name[,load])");
else {
STRLEN len;
const char * const name = SvPV_const(ST(1), len);
const bool load = (items > 2) ? SvTRUE(ST(2)) : 0;
PerlIO_funcs * const layer = PerlIO_find_layer(aTHX_ name, len, load);
ST(0) =
(layer) ? sv_2mortal(PerlIO_tab_sv(aTHX_ layer)) :
&PL_sv_undef;
XSRETURN(1);
}
}
void
PerlIO_define_layer(pTHX_ PerlIO_funcs *tab)
{
dVAR;
if (!PL_known_layers)
PL_known_layers = PerlIO_list_alloc(aTHX);
PerlIO_list_push(aTHX_ PL_known_layers, tab, NULL);
PerlIO_debug("define %s %p\n", tab->name, (void*)tab);
}
int
PerlIO_parse_layers(pTHX_ PerlIO_list_t *av, const char *names)
{
dVAR;
if (names) {
const char *s = names;
while (*s) {
while (isSPACE(*s) || *s == ':')
s++;
if (*s) {
STRLEN llen = 0;
const char *e = s;
const char *as = NULL;
STRLEN alen = 0;
if (!isIDFIRST(*s)) {
/*
* Message is consistent with how attribute lists are
* passed. Even though this means "foo : : bar" is
* seen as an invalid separator character.
*/
const char 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;
}
do {
e++;
} while (isALNUM(*e));
llen = e - s;
if (*e == '(') {
int nesting = 1;
as = ++e;
while (nesting) {
switch (*e++) {
case ')':
if (--nesting == 0)
alen = (e - 1) - as;
break;
case '(':
++nesting;
break;
case '\\':
/*
* It's a nul terminated string, not allowed
* to \ the terminating null. Anything other
* character is passed over.
*/
if (*e++) {
break;
}
/*
* Drop through
*/
case '\0':
e--;
Perl_ck_warner(aTHX_ packWARN(WARN_LAYER),
"Argument list not closed for PerlIO layer \"%.*s\"",
(int) (e - s), s);
return -1;
default:
/*
* boring.
*/
break;
}
}
}
if (e > s) {
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,
(arg) ? arg : &PL_sv_undef);
SvREFCNT_dec(arg);
}
else {
Perl_ck_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"%.*s\"",
(int) llen, s);
return -1;
}
}
s = e;
}
}
}
return 0;
}
void
PerlIO_default_buffer(pTHX_ PerlIO_list_t *av)
{
dVAR;
PERLIO_FUNCS_DECL(*tab) = &PerlIO_perlio;
#ifdef PERLIO_USING_CRLF
tab = &PerlIO_crlf;
#else
if (PerlIO_stdio.Set_ptrcnt)
tab = &PerlIO_stdio;
#endif
PerlIO_debug("Pushing %s\n", tab->name);
PerlIO_list_push(aTHX_ av, PerlIO_find_layer(aTHX_ tab->name, 0, 0),
&PL_sv_undef);
}
SV *
PerlIO_arg_fetch(PerlIO_list_t *av, IV n)
{
return av->array[n].arg;
}
PerlIO_funcs *
PerlIO_layer_fetch(pTHX_ PerlIO_list_t *av, IV n, PerlIO_funcs *def)
{
if (n >= 0 && n < av->cur) {
PerlIO_debug("Layer %" IVdf " is %s\n", n,
av->array[n].funcs->name);
return av->array[n].funcs;
}
if (!def)
Perl_croak(aTHX_ "panic: PerlIO layer array corrupt");
return def;
}
IV
PerlIOPop_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
{
PERL_UNUSED_ARG(mode);
PERL_UNUSED_ARG(arg);
PERL_UNUSED_ARG(tab);
if (PerlIOValid(f)) {
PerlIO_flush(f);
PerlIO_pop(aTHX_ f);
return 0;
}
return -1;
}
PERLIO_FUNCS_DECL(PerlIO_remove) = {
sizeof(PerlIO_funcs),
"pop",
0,
PERLIO_K_DUMMY | PERLIO_K_UTF8,
PerlIOPop_pushed,
NULL,
PerlIOBase_open,
NULL,
NULL,
NULL,
NULL,
NULL,
NULL,
NULL,
NULL,
NULL,
NULL,
NULL, /* flush */
NULL, /* fill */
NULL,
NULL,
NULL,
NULL,
NULL, /* get_base */
NULL, /* get_bufsiz */
NULL, /* get_ptr */
NULL, /* get_cnt */
NULL, /* set_ptrcnt */
};
PerlIO_list_t *
PerlIO_default_layers(pTHX)
{
dVAR;
if (!PL_def_layerlist) {
const char * const s = (PL_tainting) ? NULL : PerlEnv_getenv("PERLIO");
PERLIO_FUNCS_DECL(*osLayer) = &PerlIO_unix;
PL_def_layerlist = PerlIO_list_alloc(aTHX);
PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_unix));
#if defined(WIN32)
PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_win32));
#if 0
osLayer = &PerlIO_win32;
#endif
#endif
PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_raw));
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));
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));
PerlIO_list_push(aTHX_ PL_def_layerlist,
PerlIO_find_layer(aTHX_ osLayer->name, 0, 0),
&PL_sv_undef);
if (s) {
PerlIO_parse_layers(aTHX_ PL_def_layerlist, s);
}
else {
PerlIO_default_buffer(aTHX_ PL_def_layerlist);
}
}
if (PL_def_layerlist->cur < 2) {
PerlIO_default_buffer(aTHX_ PL_def_layerlist);
}
return PL_def_layerlist;
}
void
Perl_boot_core_PerlIO(pTHX)
{
#ifdef USE_ATTRIBUTES_FOR_PERLIO
newXS("io::MODIFY_SCALAR_ATTRIBUTES", XS_io_MODIFY_SCALAR_ATTRIBUTES,
__FILE__);
#endif
newXS("PerlIO::Layer::find", XS_PerlIO__Layer__find, __FILE__);
newXS("PerlIO::Layer::NoWarnings", XS_PerlIO__Layer__NoWarnings, __FILE__);
}
PerlIO_funcs *
PerlIO_default_layer(pTHX_ I32 n)
{
dVAR;
PerlIO_list_t * const av = PerlIO_default_layers(aTHX);
if (n < 0)
n += av->cur;
return PerlIO_layer_fetch(aTHX_ av, n, PERLIO_FUNCS_CAST(&PerlIO_stdio));
}
#define PerlIO_default_top() PerlIO_default_layer(aTHX_ -1)
#define PerlIO_default_btm() PerlIO_default_layer(aTHX_ 0)
void
PerlIO_stdstreams(pTHX)
{
dVAR;
if (!PL_perlio) {
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)) {
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)) {
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) {
char *temp;
Newxz(temp, tab->size, char);
l = (PerlIOl*)temp;
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,
(mode) ? mode : "(Null)", (void*)arg);
if (*l->tab->Pushed &&
(*l->tab->Pushed)
(aTHX_ f, mode, arg, (PerlIO_funcs*) tab) != 0) {
PerlIO_pop(aTHX_ f);
return NULL;
}
}
else
return NULL;
}
}
else if (f) {
/* Pseudo-layer where push does its own stack adjust */
PerlIO_debug("PerlIO_push f=%p %s %s %p\n", (void*)f, tab->name,
(mode) ? mode : "(Null)", (void*)arg);
if (tab->Pushed &&
(*tab->Pushed) (aTHX_ f, mode, arg, (PerlIO_funcs*) tab) != 0) {
return NULL;
}
}
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 && 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;
}
else {
/* Not suitable - pop it */
PerlIO_pop(aTHX_ f);
}
return 0;
}
return -1;
}
IV
PerlIORaw_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
{
PERL_UNUSED_ARG(mode);
PERL_UNUSED_ARG(arg);
PERL_UNUSED_ARG(tab);
if (PerlIOValid(f)) {
PerlIO *t;
const PerlIOl *l;
PerlIO_flush(f);
/*
* Strip all layers that are not suitable for a raw stream
*/
t = f;
while (t && (l = *t)) {
if (l->tab && l->tab->Binmode) {
/* Has a handler - normal case */
if ((*l->tab->Binmode)(aTHX_ t) == 0) {
if (*t == l) {
/* Layer still there - move down a layer */
t = PerlIONext(t);
}
}
else {
return -1;
}
}
else {
/* No handler - pop it */
PerlIO_pop(aTHX_ t);
}
}
if (PerlIOValid(f)) {
PerlIO_debug(":raw f=%p :%s\n", (void*)f,
PerlIOBase(f)->tab ? PerlIOBase(f)->tab->name : "(Null)");
return 0;
}
}
return -1;
}
int
PerlIO_apply_layera(pTHX_ PerlIO *f, const char *mode,
PerlIO_list_t *layers, IV n, IV max)
{
int code = 0;
while (n < max) {
PerlIO_funcs * const tab = PerlIO_layer_fetch(aTHX_ layers, n, NULL);
if (tab) {
if (!PerlIO_push(aTHX_ f, tab, mode, PerlIOArg)) {
code = -1;
break;
}
}
n++;
}
return code;
}
int
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);
if (code == 0) {
code = PerlIO_apply_layera(aTHX_ f, mode, layers, 0, layers->cur);
}
PerlIO_list_free(aTHX_ layers);
}
LEAVE;
return code;
}
/*--------------------------------------------------------------------------------------*/
/*
* Given the abstraction above the public API functions
*/
int
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) ?
PerlIOBase(f)->tab->name : "(Null)",
iotype, mode, (names) ? names : "(Null)");
if (names) {
/* Do not flush etc. if (e.g.) switching encodings.
if a pushed layer knows it needs to flush lower layers
(for example :unix which is never going to call them)
it can do the flush when it is pushed.
*/
return PerlIO_apply_layers(aTHX_ f, NULL, names) == 0 ? TRUE : FALSE;
}
else {
/* Fake 5.6 legacy of using this call to turn ON O_TEXT */
#ifdef PERLIO_USING_CRLF
/* Legacy binmode only has meaning if O_TEXT has a value distinct from
O_BINARY so we can look for it in mode.
*/
if (!(mode & O_BINARY)) {
/* Text mode */
/* FIXME?: Looking down the layer stack seems wrong,
but is a way of reaching past (say) an encoding layer
to flip CRLF-ness of the layer(s) below
*/
while (*f) {
/* Perhaps we should turn on bottom-most aware layer
e.g. Ilya's idea that UNIX TTY could serve
*/
if (PerlIOBase(f)->tab &&
PerlIOBase(f)->tab->kind & PERLIO_K_CANCRLF)
{
if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF)) {
/* Not in text mode - flush any pending stuff and flip it */
PerlIO_flush(f);
PerlIOBase(f)->flags |= PERLIO_F_CRLF;
}
/* Only need to turn it on in one layer so we are done */
return TRUE;
}
f = PerlIONext(f);
}
/* Not finding a CRLF aware layer presumably means we are binary
which is not what was requested - so we failed
We _could_ push :crlf layer but so could caller
*/
return FALSE;
}
#endif
/* Legacy binmode is now _defined_ as being equivalent to pushing :raw
So code that used to be here is now in PerlIORaw_pushed().
*/
return PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_raw), NULL, NULL) ? TRUE : FALSE;
}
}
int
PerlIO__close(pTHX_ PerlIO *f)
{
if (PerlIOValid(f)) {
PerlIO_funcs * const tab = PerlIOBase(f)->tab;
if (tab && tab->Close)
return (*tab->Close)(aTHX_ f);
else
return PerlIOBase_close(aTHX_ f);
}
else {
SETERRNO(EBADF, SS_IVCHAN);
return -1;
}
}
int
Perl_PerlIO_close(pTHX_ PerlIO *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;
}
int
Perl_PerlIO_fileno(pTHX_ PerlIO *f)
{
dVAR;
Perl_PerlIO_or_Base(f, Fileno, fileno, -1, (aTHX_ f));
}
static PerlIO_funcs *
PerlIO_layer_from_ref(pTHX_ SV *sv)
{
dVAR;
/*
* For any scalar type load the handler which is bundled with perl
*/
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)
/* diag_listed_as: Unknown PerlIO layer "%s" */
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
*/
switch (SvTYPE(sv)) {
case SVt_PVAV:
return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Array"), 0);
case SVt_PVHV:
return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Hash"), 0);
case SVt_PVCV:
return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Code"), 0);
case SVt_PVGV:
return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Glob"), 0);
default:
return NULL;
}
}
PerlIO_list_t *
PerlIO_resolve_layers(pTHX_ const char *layers,
const char *mode, int narg, SV **args)
{
dVAR;
PerlIO_list_t *def = PerlIO_default_layers(aTHX);
int incdef = 1;
if (!PL_perlio)
PerlIO_stdstreams(aTHX);
if (narg) {
SV * const arg = *args;
/*
* If it is a reference but not an object see if we have a handler
* for it
*/
if (SvROK(arg) && !sv_isobject(arg)) {
PerlIO_funcs * const handler = PerlIO_layer_from_ref(aTHX_ SvRV(arg));
if (handler) {
def = PerlIO_list_alloc(aTHX);
PerlIO_list_push(aTHX_ def, handler, &PL_sv_undef);
incdef = 0;
}
/*
* Don't fail if handler cannot be found :via(...) etc. may do
* something sensible else we will just stringfy and open
* resulting string.
*/
}
}
if (!layers || !*layers)
layers = Perl_PerlIO_context_layers(aTHX_ mode);
if (layers && *layers) {
PerlIO_list_t *av;
if (incdef) {
av = PerlIO_clone_list(aTHX_ def, NULL);
}
else {
av = def;
}
if (PerlIO_parse_layers(aTHX_ av, layers) == 0) {
return av;
}
else {
PerlIO_list_free(aTHX_ av);
return NULL;
}
}
else {
if (incdef)
def->refcnt++;
return def;
}
}
PerlIO *
PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
int imode, int perm, PerlIO *f, int narg, SV **args)
{
dVAR;
if (!f && narg == 1 && *args == &PL_sv_undef) {
if ((f = PerlIO_tmpfile())) {
if (!layers || !*layers)
layers = Perl_PerlIO_context_layers(aTHX_ mode);
if (layers && *layers)
PerlIO_apply_layers(aTHX_ f, mode, layers);
}
}
else {
PerlIO_list_t *layera;
IV n;
PerlIO_funcs *tab = NULL;
if (PerlIOValid(f)) {
/*
* This is "reopen" - it is not tested as perl does not use it
* yet
*/
PerlIOl *l = *f;
layera = PerlIO_list_alloc(aTHX);
while (l) {
SV *arg = 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);
}
}
else {
layera = PerlIO_resolve_layers(aTHX_ layers, mode, narg, args);
if (!layera) {
return NULL;
}
}
/*
* Start at "top" of layer stack
*/
n = layera->cur - 1;
while (n >= 0) {
PerlIO_funcs * const t = PerlIO_layer_fetch(aTHX_ layera, n, NULL);
if (t && t->Open) {
tab = t;
break;
}
n--;
}
if (tab) {
/*
* Found that layer 'n' can do opens - call it
*/
if (narg > 1 && !(tab->kind & PERLIO_K_MULTIARG)) {
Perl_croak(aTHX_ "More than one argument to open(,':%s')",tab->name);
}
PerlIO_debug("openn(%s,'%s','%s',%d,%x,%o,%p,%d,%p)\n",
tab->name, layers ? layers : "(Null)", mode, fd,
imode, perm, (void*)f, narg, (void*)args);
if (tab->Open)
f = (*tab->Open) (aTHX_ tab, layera, n, mode, fd, imode, perm,
f, narg, args);
else {
SETERRNO(EINVAL, LIB_INVARG);
f = NULL;
}
if (f) {
if (n + 1 < layera->cur) {
/*
* More layers above the one that we used to open -
* apply them now
*/
if (PerlIO_apply_layera(aTHX_ f, mode, layera, n + 1, layera->cur) != 0) {
/* If pushing layers fails close the file */
PerlIO_close(f);
f = NULL;
}
}
}
}
PerlIO_list_free(aTHX_ layera);
}
return f;
}
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));
}
int
Perl_PerlIO_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
{
Perl_PerlIO_or_fail(f, Seek, -1, (aTHX_ f, offset, whence));
}
Off_t
Perl_PerlIO_tell(pTHX_ PerlIO *f)
{
Perl_PerlIO_or_fail(f, Tell, -1, (aTHX_ f));
}
int
Perl_PerlIO_flush(pTHX_ PerlIO *f)
{
dVAR;
if (f) {
if (*f) {
const PerlIO_funcs *tab = PerlIOBase(f)->tab;
if (tab && tab->Flush)
return (*tab->Flush) (aTHX_ f);
else
return 0; /* If no Flush defined, silently succeed. */
}
else {
PerlIO_debug("Cannot flush f=%p\n", (void*)f);
SETERRNO(EBADF, SS_IVCHAN);
return -1;
}
}
else {
/*
* Is it good API design to do flush-all on NULL, a potentially
* 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
*/
PerlIOl **table = &PL_perlio;
PerlIOl *ff;
int code = 0;
while ((ff = *table)) {
int i;
table = (PerlIOl **) (ff++);
for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
if (ff->next && PerlIO_flush(&(ff->next)) != 0)
code = -1;
ff++;
}
}
return code;
}
}
void
PerlIOBase_flush_linebuf(pTHX)
{
dVAR;
PerlIOl **table = &PL_perlio;
PerlIOl *f;
while ((f = *table)) {
int i;
table = (PerlIOl **) (f++);
for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
if (f->next
&& (PerlIOBase(&(f->next))->
flags & (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE))
== (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE))
PerlIO_flush(&(f->next));
f++;
}
}
}
int
Perl_PerlIO_fill(pTHX_ PerlIO *f)
{
Perl_PerlIO_or_fail(f, Fill, -1, (aTHX_ f));
}
int
PerlIO_isutf8(PerlIO *f)
{
if (PerlIOValid(f))
return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
else
SETERRNO(EBADF, SS_IVCHAN);
return -1;
}
int
Perl_PerlIO_eof(pTHX_ PerlIO *f)
{
Perl_PerlIO_or_Base(f, Eof, eof, -1, (aTHX_ f));
}
int
Perl_PerlIO_error(pTHX_ PerlIO *f)
{
Perl_PerlIO_or_Base(f, Error, error, -1, (aTHX_ f));
}
void
Perl_PerlIO_clearerr(pTHX_ PerlIO *f)
{
Perl_PerlIO_or_Base_void(f, Clearerr, clearerr, (aTHX_ f));
}
void
Perl_PerlIO_setlinebuf(pTHX_ PerlIO *f)
{
Perl_PerlIO_or_Base_void(f, Setlinebuf, setlinebuf, (aTHX_ f));
}
int
PerlIO_has_base(PerlIO *f)
{
if (PerlIOValid(f)) {
const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
if (tab)
return (tab->Get_base != NULL);
}
return 0;
}
int
PerlIO_fast_gets(PerlIO *f)
{
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);
}
}
return 0;
}
int
PerlIO_has_cntptr(PerlIO *f)
{
if (PerlIOValid(f)) {
const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
if (tab)
return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
}
return 0;
}
int
PerlIO_canset_cnt(PerlIO *f)
{
if (PerlIOValid(f)) {
const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
if (tab)
return (tab->Set_ptrcnt != NULL);
}
return 0;
}
STDCHAR *
Perl_PerlIO_get_base(pTHX_ PerlIO *f)
{
Perl_PerlIO_or_fail(f, Get_base, NULL, (aTHX_ f));
}
int
Perl_PerlIO_get_bufsiz(pTHX_ PerlIO *f)
{
Perl_PerlIO_or_fail(f, Get_bufsiz, -1, (aTHX_ f));
}
STDCHAR *
Perl_PerlIO_get_ptr(pTHX_ PerlIO *f)
{
Perl_PerlIO_or_fail(f, Get_ptr, NULL, (aTHX_ f));
}
int
Perl_PerlIO_get_cnt(pTHX_ PerlIO *f)
{
Perl_PerlIO_or_fail(f, Get_cnt, -1, (aTHX_ f));
}
void
Perl_PerlIO_set_cnt(pTHX_ PerlIO *f, int cnt)
{
Perl_PerlIO_or_fail_void(f, Set_ptrcnt, (aTHX_ f, NULL, cnt));
}
void
Perl_PerlIO_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, int cnt)
{
Perl_PerlIO_or_fail_void(f, Set_ptrcnt, (aTHX_ f, ptr, cnt));
}
/*--------------------------------------------------------------------------------------*/
/*
* utf8 and raw dummy layers
*/
IV
PerlIOUtf8_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
{
PERL_UNUSED_CONTEXT;
PERL_UNUSED_ARG(mode);
PERL_UNUSED_ARG(arg);
if (PerlIOValid(f)) {
if (tab && tab->kind & PERLIO_K_UTF8)
PerlIOBase(f)->flags |= PERLIO_F_UTF8;
else
PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
return 0;
}
return -1;
}
PERLIO_FUNCS_DECL(PerlIO_utf8) = {
sizeof(PerlIO_funcs),
"utf8",
0,
PERLIO_K_DUMMY | PERLIO_K_UTF8 | PERLIO_K_MULTIARG,
PerlIOUtf8_pushed,
NULL,
PerlIOBase_open,
NULL,
NULL,
NULL,
NULL,
NULL,
NULL,
NULL,
NULL,
NULL,
NULL,
NULL, /* flush */
NULL, /* fill */
NULL,
NULL,
NULL,
NULL,
NULL, /* get_base */
NULL, /* get_bufsiz */
NULL, /* get_ptr */
NULL, /* get_cnt */
NULL, /* set_ptrcnt */
};
PERLIO_FUNCS_DECL(PerlIO_byte) = {
sizeof(PerlIO_funcs),
"bytes",
0,
PERLIO_K_DUMMY | PERLIO_K_MULTIARG,
PerlIOUtf8_pushed,
NULL,
PerlIOBase_open,
NULL,
NULL,
NULL,
NULL,
NULL,
NULL,
NULL,
NULL,
NULL,
NULL,
NULL, /* flush */
NULL, /* fill */
NULL,
NULL,
NULL,
NULL,
NULL, /* get_base */
NULL, /* get_bufsiz */
NULL, /* get_ptr */
NULL, /* get_cnt */
NULL, /* set_ptrcnt */
};
PERLIO_FUNCS_DECL(PerlIO_raw) = {
sizeof(PerlIO_funcs),
"raw",
0,
PERLIO_K_DUMMY,
PerlIORaw_pushed,
PerlIOBase_popped,
PerlIOBase_open,
NULL,
NULL,
NULL,
NULL,
NULL,
NULL,
NULL,
NULL,
NULL,
NULL,
NULL, /* flush */
NULL, /* fill */
NULL,
NULL,
NULL,
NULL,
NULL, /* get_base */
NULL, /* get_bufsiz */
NULL, /* get_ptr */
NULL, /* get_cnt */
NULL, /* set_ptrcnt */
};
/*--------------------------------------------------------------------------------------*/
/*--------------------------------------------------------------------------------------*/
/*
* "Methods" of the "base class"
*/
IV
PerlIOBase_fileno(pTHX_ PerlIO *f)
{
return PerlIOValid(f) ? PerlIO_fileno(PerlIONext(f)) : -1;
}
char *
PerlIO_modestr(PerlIO * f, char *buf)
{
char *s = buf;
if (PerlIOValid(f)) {
const IV flags = PerlIOBase(f)->flags;
if (flags & PERLIO_F_APPEND) {
*s++ = 'a';
if (flags & PERLIO_F_CANREAD) {
*s++ = '+';
}
}
else if (flags & PERLIO_F_CANREAD) {
*s++ = 'r';
if (flags & PERLIO_F_CANWRITE)
*s++ = '+';
}
else if (flags & PERLIO_F_CANWRITE) {
*s++ = 'w';
if (flags & PERLIO_F_CANREAD) {
*s++ = '+';
}
}
#ifdef PERLIO_USING_CRLF
if (!(flags & PERLIO_F_CRLF))
*s++ = 'b';
#endif
}
*s = '\0';
return buf;
}
IV
PerlIOBase_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
{
PerlIOl * const l = PerlIOBase(f);
PERL_UNUSED_CONTEXT;
PERL_UNUSED_ARG(arg);
l->flags &= ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE |
PERLIO_F_TRUNCATE | PERLIO_F_APPEND);
if (tab && tab->Set_ptrcnt != NULL)
l->flags |= PERLIO_F_FASTGETS;
if (mode) {
if (*mode == IoTYPE_NUMERIC || *mode == IoTYPE_IMPLICIT)
mode++;
switch (*mode++) {
case 'r':
l->flags |= PERLIO_F_CANREAD;
break;
case 'a':
l->flags |= PERLIO_F_APPEND | PERLIO_F_CANWRITE;
break;
case 'w':
l->flags |= PERLIO_F_TRUNCATE | PERLIO_F_CANWRITE;
break;
default:
SETERRNO(EINVAL, LIB_INVARG);
return -1;
}
while (*mode) {
switch (*mode++) {
case '+':
l->flags |= PERLIO_F_CANREAD | PERLIO_F_CANWRITE;
break;
case 'b':
l->flags &= ~PERLIO_F_CRLF;
break;
case 't':
l->flags |= PERLIO_F_CRLF;
break;
default:
SETERRNO(EINVAL, LIB_INVARG);
return -1;
}
}
}
else {
if (l->next) {
l->flags |= l->next->flags &
(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_TRUNCATE |
PERLIO_F_APPEND);
}
}
#if 0
PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08" UVxf " (%s)\n",
(void*)f, PerlIOBase(f)->tab->name, (omode) ? omode : "(Null)",
l->flags, PerlIO_modestr(f, temp));
#endif
return 0;
}
IV
PerlIOBase_popped(pTHX_ PerlIO *f)
{
PERL_UNUSED_CONTEXT;
PERL_UNUSED_ARG(f);
return 0;
}
SSize_t
PerlIOBase_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
{
/*
* Save the position as current head considers it
*/
const Off_t old = PerlIO_tell(f);
PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_pending), "r", NULL);
PerlIOSelf(f, PerlIOBuf)->posn = old;
return PerlIOBuf_unread(aTHX_ f, vbuf, count);
}
SSize_t
PerlIOBase_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
{
STDCHAR *buf = (STDCHAR *) vbuf;
if (f) {
if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD)) {
PerlIOBase(f)->flags |= PERLIO_F_ERROR;
SETERRNO(EBADF, SS_IVCHAN);
return 0;
}
while (count > 0) {
get_cnt:
{
SSize_t avail = PerlIO_get_cnt(f);
SSize_t take = 0;
if (avail > 0)
take = ((SSize_t)count < avail) ? (SSize_t)count : avail;
if (take > 0) {
STDCHAR *ptr = PerlIO_get_ptr(f);
Copy(ptr, buf, take, STDCHAR);
PerlIO_set_ptrcnt(f, ptr + take, (avail -= take));
count -= take;
buf += take;
if (avail == 0) /* set_ptrcnt could have reset avail */
goto get_cnt;
}
if (count > 0 && avail <= 0) {
if (PerlIO_fill(f) != 0)
break;
}
}
}
return (buf - (STDCHAR *) vbuf);
}
return 0;
}
IV
PerlIOBase_noop_ok(pTHX_ PerlIO *f)
{
PERL_UNUSED_CONTEXT;
PERL_UNUSED_ARG(f);
return 0;
}
IV
PerlIOBase_noop_fail(pTHX_ PerlIO *f)
{
PERL_UNUSED_CONTEXT;
PERL_UNUSED_ARG(f);
return -1;
}
IV
PerlIOBase_close(pTHX_ PerlIO *f)
{
IV code = -1;
if (PerlIOValid(f)) {
PerlIO *n = PerlIONext(f);
code = PerlIO_flush(f);
PerlIOBase(f)->flags &=
~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN);
while (PerlIOValid(n)) {
const PerlIO_funcs * const tab = PerlIOBase(n)->tab;
if (tab && tab->Close) {
if ((*tab->Close)(aTHX_ n) != 0)
code = -1;
break;
}
else {
PerlIOBase(n)->flags &=
~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN);
}
n = PerlIONext(n);
}
}
else {
SETERRNO(EBADF, SS_IVCHAN);
}
return code;
}
IV
PerlIOBase_eof(pTHX_ PerlIO *f)
{
PERL_UNUSED_CONTEXT;
if (PerlIOValid(f)) {
return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
}
return 1;
}
IV
PerlIOBase_error(pTHX_ PerlIO *f)
{
PERL_UNUSED_CONTEXT;
if (PerlIOValid(f)) {
return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
}
return 1;
}
void
PerlIOBase_clearerr(pTHX_ PerlIO *f)
{
if (PerlIOValid(f)) {
PerlIO * const n = PerlIONext(f);
PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR | PERLIO_F_EOF);
if (PerlIOValid(n))
PerlIO_clearerr(n);
}
}
void
PerlIOBase_setlinebuf(pTHX_ PerlIO *f)
{
PERL_UNUSED_CONTEXT;
if (PerlIOValid(f)) {
PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
}
}
SV *
PerlIO_sv_dup(pTHX_ SV *arg, CLONE_PARAMS *param)
{
if (!arg)
return NULL;
#ifdef sv_dup
if (param) {
arg = sv_dup(arg, param);
SvREFCNT_inc_simple_void_NN(arg);
return arg;
}
else {
return newSVsv(arg);
}
#else
PERL_UNUSED_ARG(param);
return newSVsv(arg);
#endif
}
PerlIO *
PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
{
PerlIO * const nexto = PerlIONext(o);
if (PerlIOValid(nexto)) {
const PerlIO_funcs * const tab = PerlIOBase(nexto)->tab;
if (tab && tab->Dup)
f = (*tab->Dup)(aTHX_ f, nexto, param, flags);
else
f = PerlIOBase_dup(aTHX_ f, nexto, param, flags);
}
if (f) {
PerlIO_funcs * const self = PerlIOBase(o)->tab;
SV *arg = NULL;
char buf[8];
PerlIO_debug("PerlIOBase_dup %s f=%p o=%p param=%p\n",
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;
SvREFCNT_dec(arg);
}
return f;
}
/* PL_perlio_fd_refcnt[] is in intrpvar.h */
/* Must be called with PL_perlio_mutex locked. */
static void
S_more_refcounted_fds(pTHX_ const int new_fd) {
dVAR;
const int old_max = PL_perlio_fd_refcnt_size;
const int new_max = 16 + (new_fd & ~15);
int *new_array;
PerlIO_debug("More fds - old=%d, need %d, new=%d\n",
old_max, new_fd, new_max);
if (new_fd < old_max) {
return;
}
assert (new_max > new_fd);
/* 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_ITHREADS
MUTEX_UNLOCK(&PL_perlio_mutex);
#endif
/* Can't use PerlIO to write as it allocates memory */
PerlLIO_write(PerlIO_fileno(Perl_error_log),
PL_no_mem, strlen(PL_no_mem));
my_exit(1);
}
PL_perlio_fd_refcnt_size = new_max;
PL_perlio_fd_refcnt = new_array;
PerlIO_debug("Zeroing %p, %d\n",
(void*)(new_array + old_max),
new_max - old_max);
Zero(new_array + old_max, new_max - old_max, int);
}
void
PerlIO_init(pTHX)
{
/* MUTEX_INIT(&PL_perlio_mutex) is done in PERL_SYS_INIT3(). */
PERL_UNUSED_CONTEXT;
}
void
PerlIOUnix_refcnt_inc(int fd)
{
dTHX;
if (fd >= 0) {
dVAR;
#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]++;
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]);
}
PerlIO_debug("refcnt_inc: fd %d refcnt=%d\n",
fd, PL_perlio_fd_refcnt[fd]);
#ifdef USE_ITHREADS
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);
}
}
int
PerlIOUnix_refcnt_dec(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_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]);
}
cnt = --PL_perlio_fd_refcnt[fd];
PerlIO_debug("refcnt_dec: fd %d refcnt=%d\n", fd, cnt);
#ifdef USE_ITHREADS
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)
{
dVAR;
int i;
#ifdef USE_ITHREADS
PerlIO_debug("Cleanup layers for %p\n",(void*)aTHX);
#else
PerlIO_debug("Cleanup layers\n");
#endif
/* Raise STDIN..STDERR refcount so we don't close them */
for (i=0; i < 3; i++)
PerlIOUnix_refcnt_inc(i);
PerlIO_cleantable(aTHX_ &PL_perlio);
/* Restore STDIN..STDERR refcount */
for (i=0; i < 3; i++)
PerlIOUnix_refcnt_dec(i);
if (PL_known_layers) {
PerlIO_list_free(aTHX_ PL_known_layers);
PL_known_layers = NULL;
}
if (PL_def_layerlist) {
PerlIO_list_free(aTHX_ PL_def_layerlist);
PL_def_layerlist = NULL;
}
}
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]) {
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. */
&& PL_perlio_fd_refcnt) {
free(PL_perlio_fd_refcnt); /* To match realloc() in S_more_refcounted_fds(). */
PL_perlio_fd_refcnt = NULL;
PL_perlio_fd_refcnt_size = 0;
}
}
/*--------------------------------------------------------------------------------------*/
/*
* Bottom-most level for UNIX-like case
*/
typedef struct {
struct _PerlIO base; /* The generic part */
int fd; /* UNIX like file descriptor */
int oflags; /* open/fcntl flags */
} PerlIOUnix;
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 oflags = -1;
if (*mode == IoTYPE_IMPLICIT || *mode == IoTYPE_NUMERIC)
mode++;
switch (*mode) {
case 'r':
oflags = O_RDONLY;
if (*++mode == '+') {
oflags = O_RDWR;
mode++;
}
break;
case 'w':
oflags = O_CREAT | O_TRUNC;
if (*++mode == '+') {
oflags |= O_RDWR;
mode++;
}
else
oflags |= O_WRONLY;
break;
case 'a':
oflags = O_CREAT | O_APPEND;
if (*++mode == '+') {
oflags |= O_RDWR;
mode++;
}
else
oflags |= O_WRONLY;
break;
}
if (*mode == 'b') {
oflags |= O_BINARY;
oflags &= ~O_TEXT;
mode++;
}
else if (*mode == 't') {
oflags |= O_TEXT;
oflags &= ~O_BINARY;
mode++;
}
/*
* Always open in binary mode
*/
oflags |= O_BINARY;
if (*mode || oflags == -1) {
SETERRNO(EINVAL, LIB_INVARG);
oflags = -1;
}
return oflags;
}
IV
PerlIOUnix_fileno(pTHX_ PerlIO *f)
{
PERL_UNUSED_CONTEXT;
return PerlIOSelf(f, PerlIOUnix)->fd;
}
static void
PerlIOUnix_setfd(pTHX_ PerlIO *f, int fd, int imode)
{
PerlIOUnix * const s = PerlIOSelf(f, PerlIOUnix);
#if defined(WIN32)
Stat_t st;
if (PerlLIO_fstat(fd, &st) == 0) {
if (!S_ISREG(st.st_mode)) {
PerlIO_debug("%d is not regular file\n",fd);
PerlIOBase(f)->flags |= PERLIO_F_NOTREG;
}
else {
PerlIO_debug("%d _is_ a regular file\n",fd);
}
}
#endif
s->fd = fd;
s->oflags = imode;
PerlIOUnix_refcnt_inc(fd);
PERL_UNUSED_CONTEXT;
}
IV
PerlIOUnix_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
{
IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
if (*PerlIONext(f)) {
/* We never call down so do any pending stuff now */
PerlIO_flush(PerlIONext(f));
/*
* XXX could (or should) we retrieve the oflags from the open file
* handle rather than believing the "mode" we are passed in? XXX
* Should the value on NULL mode be 0 or -1?
*/
PerlIOUnix_setfd(aTHX_ f, PerlIO_fileno(PerlIONext(f)),
mode ? PerlIOUnix_oflags(mode) : -1);
}
PerlIOBase(f)->flags |= PERLIO_F_OPEN;
return code;
}
IV
PerlIOUnix_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
{
const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
Off_t new_loc;
PERL_UNUSED_CONTEXT;
if (PerlIOBase(f)->flags & PERLIO_F_NOTREG) {
#ifdef ESPIPE
SETERRNO(ESPIPE, LIB_INVARG);
#else
SETERRNO(EINVAL, LIB_INVARG);
#endif
return -1;
}
new_loc = PerlLIO_lseek(fd, offset, whence);
if (new_loc == (Off_t) - 1)
return -1;
PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
return 0;
}
PerlIO *
PerlIOUnix_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
IV n, const char *mode, int fd, int imode,
int perm, PerlIO *f, int narg, SV **args)
{
if (PerlIOValid(f)) {
if (PerlIOBase(f)->tab && PerlIOBase(f)->flags & PERLIO_F_OPEN)
(*PerlIOBase(f)->tab->Close)(aTHX_ f);
}
if (narg > 0) {
if (*mode == IoTYPE_NUMERIC)
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);
fd = PerlLIO_open3(path, imode, perm);
}
}
if (fd >= 0) {
if (*mode == IoTYPE_IMPLICIT)
mode++;
if (!f) {
f = PerlIO_allocate(aTHX);
}
if (!PerlIOValid(f)) {
if (!(f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
return NULL;
}
}
PerlIOUnix_setfd(aTHX_ f, fd, imode);
PerlIOBase(f)->flags |= PERLIO_F_OPEN;
if (*mode == IoTYPE_APPEND)
PerlIOUnix_seek(aTHX_ f, 0, SEEK_END);
return f;
}
else {
if (f) {
NOOP;
/*
* FIXME: pop layers ???
*/
}
return NULL;
}
}
PerlIO *
PerlIOUnix_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
{
const PerlIOUnix * const os = PerlIOSelf(o, PerlIOUnix);
int fd = os->fd;
if (flags & PERLIO_DUP_FD) {
fd = PerlLIO_dup(fd);
}
if (fd >= 0) {
f = PerlIOBase_dup(aTHX_ f, o, param, flags);
if (f) {
/* If all went well overwrite fd in dup'ed lay with the dup()'ed fd */
PerlIOUnix_setfd(aTHX_ f, fd, os->oflags);
return f;
}
}
return NULL;
}
SSize_t
PerlIOUnix_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
{
dVAR;
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);
#endif
if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD) ||
PerlIOBase(f)->flags & (PERLIO_F_EOF|PERLIO_F_ERROR)) {
return 0;
}
while (1) {
const SSize_t len = PerlLIO_read(fd, vbuf, count);
if (len >= 0 || errno != EINTR) {
if (len < 0) {
if (errno != EAGAIN) {
PerlIOBase(f)->flags |= PERLIO_F_ERROR;
}
}
else if (len == 0 && count != 0) {
PerlIOBase(f)->flags |= PERLIO_F_EOF;
SETERRNO(0,0);
}
return len;
}
/* EINTR */
if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
return -1;
}
/*NOTREACHED*/
}
SSize_t
PerlIOUnix_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
{
dVAR;
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);
#endif
while (1) {
const SSize_t len = PerlLIO_write(fd, vbuf, count);
if (len >= 0 || errno != EINTR) {
if (len < 0) {
if (errno != EAGAIN) {
PerlIOBase(f)->flags |= PERLIO_F_ERROR;
}
}
return len;
}
/* EINTR */
if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
return -1;
}
/*NOTREACHED*/
}
Off_t
PerlIOUnix_tell(pTHX_ PerlIO *f)
{
PERL_UNUSED_CONTEXT;
return PerlLIO_lseek(PerlIOSelf(f, PerlIOUnix)->fd, 0, SEEK_CUR);
}
IV
PerlIOUnix_close(pTHX_ PerlIO *f)
{
dVAR;
const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
int code = 0;
if (PerlIOBase(f)->flags & PERLIO_F_OPEN) {
if (PerlIOUnix_refcnt_dec(fd) > 0) {
PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
return 0;
}
}
else {
SETERRNO(EBADF,SS_IVCHAN);
return -1;
}
while (PerlLIO_close(fd) != 0) {
if (errno != EINTR) {
code = -1;
break;
}
/* EINTR */
if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
return -1;
}
if (code == 0) {
PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
}
return code;
}
PERLIO_FUNCS_DECL(PerlIO_unix) = {
sizeof(PerlIO_funcs),
"unix",
sizeof(PerlIOUnix),
PERLIO_K_RAW,
PerlIOUnix_pushed,
PerlIOBase_popped,
PerlIOUnix_open,
PerlIOBase_binmode, /* binmode */
NULL,
PerlIOUnix_fileno,
PerlIOUnix_dup,
PerlIOUnix_read,
PerlIOBase_unread,
PerlIOUnix_write,
PerlIOUnix_seek,
PerlIOUnix_tell,
PerlIOUnix_close,
PerlIOBase_noop_ok, /* flush */
PerlIOBase_noop_fail, /* fill */
PerlIOBase_eof,
PerlIOBase_error,
PerlIOBase_clearerr,
PerlIOBase_setlinebuf,
NULL, /* get_base */
NULL, /* get_bufsiz */
NULL, /* get_ptr */
NULL, /* get_cnt */
NULL, /* set_ptrcnt */
};
/*--------------------------------------------------------------------------------------*/
/*
* stdio as a layer
*/
#if defined(VMS) && !defined(STDIO_BUFFER_WRITABLE)
/* perl5.8 - This ensures the last minute VMS ungetc fix is not
broken by the last second glibc 2.3 fix
*/
#define STDIO_BUFFER_WRITABLE
#endif
typedef struct {
struct _PerlIO base;
FILE *stdio; /* The stream */
} PerlIOStdio;
IV
PerlIOStdio_fileno(pTHX_ PerlIO *f)
{
PERL_UNUSED_CONTEXT;
if (PerlIOValid(f)) {
FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
if (s)
return PerlSIO_fileno(s);
}
errno = EBADF;
return -1;
}
char *
PerlIOStdio_mode(const char *mode, char *tmode)
{
char * const ret = tmode;
if (mode) {
while (*mode) {
*tmode++ = *mode++;
}
}
#if defined(PERLIO_USING_CRLF) || defined(__CYGWIN__)
*tmode++ = 'b';
#endif
*tmode = '\0';
return ret;
}
IV
PerlIOStdio_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
{
PerlIO *n;
if (PerlIOValid(f) && PerlIOValid(n = PerlIONext(f))) {
PerlIO_funcs * const toptab = PerlIOBase(n)->tab;
if (toptab == tab) {
/* Top is already stdio - pop self (duplicate) and use original */
PerlIO_pop(aTHX_ f);
return 0;
} else {
const int fd = PerlIO_fileno(n);
char tmode[8];
FILE *stdio;
if (fd >= 0 && (stdio = PerlSIO_fdopen(fd,
mode = PerlIOStdio_mode(mode, tmode)))) {
PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
/* We never call down so do any pending stuff now */
PerlIO_flush(PerlIONext(f));
}
else {
return -1;
}
}
}
return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
}
PerlIO *
PerlIO_importFILE(FILE *stdio, const char *mode)
{
dTHX;
PerlIO *f = NULL;
if (stdio) {
PerlIOStdio *s;
if (!mode || !*mode) {
/* We need to probe to see how we can open the stream
so start with read/write and then try write and read
we dup() so that we can fclose without loosing the fd.
Note that the errno value set by a failing fdopen
varies between stdio implementations.
*/
const int fd = PerlLIO_dup(fileno(stdio));
FILE *f2 = PerlSIO_fdopen(fd, (mode = "r+"));
if (!f2) {
f2 = PerlSIO_fdopen(fd, (mode = "w"));
}
if (!f2) {
f2 = PerlSIO_fdopen(fd, (mode = "r"));
}
if (!f2) {
/* Don't seem to be able to open */
PerlLIO_close(fd);
return f;
}
fclose(f2);
}
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;
}
PerlIO *
PerlIOStdio_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
IV n, const char *mode, int fd, int imode,
int perm, PerlIO *f, int narg, SV **args)
{
char tmode[8];
if (PerlIOValid(f)) {
const char * const path = SvPV_nolen_const(*args);
PerlIOStdio * const s = PerlIOSelf(f, PerlIOStdio);
FILE *stdio;
PerlIOUnix_refcnt_dec(fileno(s->stdio));
stdio = PerlSIO_freopen(path, (mode = PerlIOStdio_mode(mode, tmode)),
s->stdio);
if (!s->stdio)
return NULL;
s->stdio = stdio;
PerlIOUnix_refcnt_inc(fileno(s->stdio));
return f;
}
else {
if (narg > 0) {
const char * const path = SvPV_nolen_const(*args);
if (*mode == IoTYPE_NUMERIC) {
mode++;
fd = PerlLIO_open3(path, imode, perm);
}
else {
FILE *stdio;
bool appended = FALSE;
#ifdef __CYGWIN__
/* Cygwin wants its 'b' early. */
appended = TRUE;
mode = PerlIOStdio_mode(mode, tmode);
#endif
stdio = PerlSIO_fopen(path, mode);
if (stdio) {
if (!f) {
f = PerlIO_allocate(aTHX);
}
if (!appended)
mode = PerlIOStdio_mode(mode, tmode);
f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg);
if (f) {
PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
PerlIOUnix_refcnt_inc(fileno(stdio));
} else {
PerlSIO_fclose(stdio);
}
return f;
}
else {
return NULL;
}
}
}
if (fd >= 0) {
FILE *stdio = NULL;
int init = 0;
if (*mode == IoTYPE_IMPLICIT) {
init = 1;
mode++;
}
if (init) {
switch (fd) {
case 0:
stdio = PerlSIO_stdin;
break;
case 1:
stdio = PerlSIO_stdout;
break;
case 2:
stdio = PerlSIO_stderr;
break;
}
}
else {
stdio = PerlSIO_fdopen(fd, mode =
PerlIOStdio_mode(mode, tmode));
}
if (stdio) {
if (!f) {
f = PerlIO_allocate(aTHX);
}
if ((f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
PerlIOUnix_refcnt_inc(fileno(stdio));
}
return f;
}
}
}
return NULL;
}
PerlIO *
PerlIOStdio_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
{
/* This assumes no layers underneath - which is what
happens, but is not how I remember it. NI-S 2001/10/16
*/
if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) {
FILE *stdio = PerlIOSelf(o, PerlIOStdio)->stdio;
const int fd = fileno(stdio);
char mode[8];
if (flags & PERLIO_DUP_FD) {
const int dfd = PerlLIO_dup(fileno(stdio));
if (dfd >= 0) {
stdio = PerlSIO_fdopen(dfd, PerlIO_modestr(o,mode));
goto set_this;
}
else {
NOOP;
/* FIXME: To avoid messy error recovery if dup fails
re-use the existing stdio as though flag was not set
*/
}
}
stdio = PerlSIO_fdopen(fd, PerlIO_modestr(o,mode));
set_this:
PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
if(stdio) {
PerlIOUnix_refcnt_inc(fileno(stdio));
}
}
return f;
}
static int
PerlIOStdio_invalidate_fileno(pTHX_ FILE *f)
{
PERL_UNUSED_CONTEXT;
/* XXX this could use PerlIO_canset_fileno() and
* PerlIO_set_fileno() support from Configure
*/
# if defined(__UCLIBC__)
/* uClibc must come before glibc because it defines __GLIBC__ as well. */
f->__filedes = -1;
return 1;
# elif defined(__GLIBC__)
/* There may be a better way for GLIBC:
- libio.h defines a flag to not close() on cleanup
*/
f->_fileno = -1;
return 1;
# elif defined(__sun__)
PERL_UNUSED_ARG(f);
return 0;
# elif defined(__hpux)
f->__fileH = 0xff;
f->__fileL = 0xff;
return 1;
/* Next one ->_file seems to be a reasonable fallback, i.e. if
your platform does not have special entry try this one.
[For OSF only have confirmation for Tru64 (alpha)
but assume other OSFs will be similar.]
*/
# elif defined(_AIX) || defined(__osf__) || defined(__irix__)
f->_file = -1;
return 1;
# elif defined(__FreeBSD__)
/* There may be a better way on FreeBSD:
- we could insert a dummy func in the _close function entry
f->_close = (int (*)(void *)) dummy_close;
*/
f->_file = -1;
return 1;
# elif defined(__OpenBSD__)
/* There may be a better way on OpenBSD:
- we could insert a dummy func in the _close function entry
f->_close = (int (*)(void *)) dummy_close;
*/
f->_file = -1;
return 1;
# elif defined(__EMX__)
/* f->_flags &= ~_IOOPEN; */ /* Will leak stream->_buffer */
f->_handle = -1;
return 1;
# elif defined(__CYGWIN__)
/* There may be a better way on CYGWIN:
- we could insert a dummy func in the _close function entry
f->_close = (int (*)(void *)) dummy_close;
*/
f->_file = -1;
return 1;
# elif defined(WIN32)
# if defined(UNDER_CE)
/* WIN_CE does not have access to FILE internals, it hardly has FILE
structure at all
*/
# else
f->_file = -1;
# endif
return 1;
# else
#if 0
/* Sarathy's code did this - we fall back to a dup/dup2 hack
(which isn't thread safe) instead
*/
# error "Don't know how to set FILE.fileno on your platform"
#endif
PERL_UNUSED_ARG(f);
return 0;
# endif
}
IV
PerlIOStdio_close(pTHX_ PerlIO *f)
{
FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
if (!stdio) {
errno = EBADF;
return -1;
}
else {
const int fd = fileno(stdio);
int invalidate = 0;
IV result = 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()
on sockets on stdio's behalf.
*/
int optval;
Sock_size_t optlen = sizeof(int);
if (getsockopt(fd, SOL_SOCKET, SO_TYPE, (void *) &optval, &optlen) == 0)
invalidate = 1;
#endif
/* 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 */
return 0;
if (stdio == stdout || stdio == stderr)
return PerlIO_flush(f);
/* Tricky - must fclose(stdio) to free memory but not close(fd)
Use Sarathy's trick from maint-5.6 to invalidate the
fileno slot of the FILE *
*/
result = PerlIO_flush(f);
SAVE_ERRNO;
invalidate = PerlIOStdio_invalidate_fileno(aTHX_ stdio);
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) {
RESTORE_ERRNO;
result = 0;
}
#ifdef SOCKS5_VERSION_NAME
/* in SOCKS' case, let close() determine return value */
result = close(fd);
#endif
if (dupfd >= 0) {
PerlLIO_dup2(dupfd,fd);
PerlLIO_close(dupfd);
#ifdef USE_ITHREADS
MUTEX_UNLOCK(&PL_perlio_mutex);
#endif
}
return result;
}
}
SSize_t
PerlIOStdio_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
{
dVAR;
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;
/*
* Perl is expecting PerlIO_getc() to fill the buffer Linux's
* stdio does not do that for fread()
*/
const int ch = PerlSIO_fgetc(s);
if (ch != EOF) {
*buf = ch;
got = 1;
}
}
else
got = PerlSIO_fread(vbuf, 1, count, s);
if (got == 0 && PerlSIO_ferror(s))
got = -1;
if (got >= 0 || errno != EINTR)
break;
if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
return -1;
SETERRNO(0,0); /* just in case */
}
return got;
}
SSize_t
PerlIOStdio_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
{
SSize_t unread = 0;
FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
#ifdef STDIO_BUFFER_WRITABLE
if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
STDCHAR *buf = ((STDCHAR *) vbuf) + count;
STDCHAR *base = PerlIO_get_base(f);
SSize_t cnt = PerlIO_get_cnt(f);
STDCHAR *ptr = PerlIO_get_ptr(f);
SSize_t avail = ptr - base;
if (avail > 0) {
if (avail > count) {
avail = count;
}
ptr -= avail;
Move(buf-avail,ptr,avail,STDCHAR);
count -= avail;
unread += avail;
PerlIO_set_ptrcnt(f,ptr,cnt+avail);
if (PerlSIO_feof(s) && unread >= 0)
PerlSIO_clearerr(s);
}
}
else
#endif
if (PerlIO_has_cntptr(f)) {
/* We can get pointer to buffer but not its base
Do ungetc() but check chars are ending up in the
buffer
*/
STDCHAR *eptr = (STDCHAR*)PerlSIO_get_ptr(s);
STDCHAR *buf = ((STDCHAR *) vbuf) + count;
while (count > 0) {
const int ch = *--buf & 0xFF;
if (ungetc(ch,s) != ch) {
/* ungetc did not work */
break;
}
if ((STDCHAR*)PerlSIO_get_ptr(s) != --eptr || ((*eptr & 0xFF) != ch)) {
/* Did not change pointer as expected */
fgetc(s); /* get char back again */
break;
}
/* It worked ! */
count--;
unread++;
}
}
if (count > 0) {
unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
}
return unread;
}
SSize_t
PerlIOStdio_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
{
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;
if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
return -1;
SETERRNO(0,0); /* just in case */
}
return got;
}
IV
PerlIOStdio_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
{
FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
PERL_UNUSED_CONTEXT;
return PerlSIO_fseek(stdio, offset, whence);
}
Off_t
PerlIOStdio_tell(pTHX_ PerlIO *f)
{
FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
PERL_UNUSED_CONTEXT;
return PerlSIO_ftell(stdio);
}
IV
PerlIOStdio_flush(pTHX_ PerlIO *f)
{
FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
PERL_UNUSED_CONTEXT;
if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
return PerlSIO_fflush(stdio);
}
else {
NOOP;
#if 0
/*
* FIXME: This discards ungetc() and pre-read stuff which is not
* right if this is just a "sync" from a layer above Suspect right
* design is to do _this_ but not have layer above flush this
* layer read-to-read
*/
/*
* Not writeable - sync by attempting a seek
*/
dSAVE_ERRNO;
if (PerlSIO_fseek(stdio, (Off_t) 0, SEEK_CUR) != 0)
RESTORE_ERRNO;
#endif
}
return 0;
}
IV
PerlIOStdio_eof(pTHX_ PerlIO *f)
{
PERL_UNUSED_CONTEXT;
return PerlSIO_feof(PerlIOSelf(f, PerlIOStdio)->stdio);
}
IV
PerlIOStdio_error(pTHX_ PerlIO *f)
{
PERL_UNUSED_CONTEXT;
return PerlSIO_ferror(PerlIOSelf(f, PerlIOStdio)->stdio);
}
void
PerlIOStdio_clearerr(pTHX_ PerlIO *f)
{
PERL_UNUSED_CONTEXT;
PerlSIO_clearerr(PerlIOSelf(f, PerlIOStdio)->stdio);
}
void
PerlIOStdio_setlinebuf(pTHX_ PerlIO *f)
{
PERL_UNUSED_CONTEXT;
#ifdef HAS_SETLINEBUF
PerlSIO_setlinebuf(PerlIOSelf(f, PerlIOStdio)->stdio);
#else
PerlSIO_setvbuf(PerlIOSelf(f, PerlIOStdio)->stdio, NULL, _IOLBF, 0);
#endif
}
#ifdef FILE_base
STDCHAR *
PerlIOStdio_get_base(pTHX_ PerlIO *f)
{
FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
return (STDCHAR*)PerlSIO_get_base(stdio);
}
Size_t
PerlIOStdio_get_bufsiz(pTHX_ PerlIO *f)
{
FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
return PerlSIO_get_bufsiz(stdio);
}
#endif
#ifdef USE_STDIO_PTR
STDCHAR *
PerlIOStdio_get_ptr(pTHX_ PerlIO *f)
{
FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
return (STDCHAR*)PerlSIO_get_ptr(stdio);
}
SSize_t
PerlIOStdio_get_cnt(pTHX_ PerlIO *f)
{
FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
return PerlSIO_get_cnt(stdio);
}
void
PerlIOStdio_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
{
FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
if (ptr != NULL) {
#ifdef STDIO_PTR_LVALUE
PerlSIO_set_ptr(stdio, ptr); /* LHS STDCHAR* cast non-portable */
#ifdef STDIO_PTR_LVAL_SETS_CNT
assert(PerlSIO_get_cnt(stdio) == (cnt));
#endif
#if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
/*
* Setting ptr _does_ change cnt - we are done
*/
return;
#endif
#else /* STDIO_PTR_LVALUE */
PerlProc_abort();
#endif /* STDIO_PTR_LVALUE */
}
/*
* Now (or only) set cnt
*/
#ifdef STDIO_CNT_LVALUE
PerlSIO_set_cnt(stdio, cnt);
#else /* STDIO_CNT_LVALUE */
#if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
PerlSIO_set_ptr(stdio,
PerlSIO_get_ptr(stdio) + (PerlSIO_get_cnt(stdio) -
cnt));
#else /* STDIO_PTR_LVAL_SETS_CNT */
PerlProc_abort();
#endif /* STDIO_PTR_LVAL_SETS_CNT */
#endif /* STDIO_CNT_LVALUE */
}
#endif
IV
PerlIOStdio_fill(pTHX_ PerlIO *f)
{
FILE * stdio;
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 ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE)) {
if (PerlSIO_fflush(stdio) != 0)
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)))
#ifdef STDIO_BUFFER_WRITABLE
if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
/* Fake ungetc() to the real buffer in case system's ungetc
goes elsewhere
*/
STDCHAR *base = (STDCHAR*)PerlSIO_get_base(stdio);
SSize_t cnt = PerlSIO_get_cnt(stdio);
STDCHAR *ptr = (STDCHAR*)PerlSIO_get_ptr(stdio);
if (ptr == base+1) {
*--ptr = (STDCHAR) c;
PerlIOStdio_set_ptrcnt(aTHX_ f,ptr,cnt+1);
if (PerlSIO_feof(stdio))
PerlSIO_clearerr(stdio);
return 0;
}
}
else
#endif
if (PerlIO_has_cntptr(f)) {
STDCHAR ch = c;
if (PerlIOStdio_unread(aTHX_ f,&ch,1) == 1) {
return 0;
}
}
#endif
#if defined(VMS)
/* An ungetc()d char is handled separately from the regular
* buffer, so we stuff it in the buffer ourselves.
* Should never get called as should hit code above
*/
*(--((*stdio)->_ptr)) = (unsigned char) c;
(*stdio)->_cnt++;
#else
/* If buffer snoop scheme above fails fall back to
using ungetc().
*/
if (PerlSIO_ungetc(c, stdio) != c)
return EOF;
#endif
return 0;
}
PERLIO_FUNCS_DECL(PerlIO_stdio) = {
sizeof(PerlIO_funcs),
"stdio",
sizeof(PerlIOStdio),
PERLIO_K_BUFFERED|PERLIO_K_RAW,
PerlIOStdio_pushed,
PerlIOBase_popped,
PerlIOStdio_open,
PerlIOBase_binmode, /* binmode */
NULL,
PerlIOStdio_fileno,
PerlIOStdio_dup,
PerlIOStdio_read,
PerlIOStdio_unread,
PerlIOStdio_write,
PerlIOStdio_seek,
PerlIOStdio_tell,
PerlIOStdio_close,
PerlIOStdio_flush,
PerlIOStdio_fill,
PerlIOStdio_eof,
PerlIOStdio_error,
PerlIOStdio_clearerr,
PerlIOStdio_setlinebuf,
#ifdef FILE_base
PerlIOStdio_get_base,
PerlIOStdio_get_bufsiz,
#else
NULL,
NULL,
#endif
#ifdef USE_STDIO_PTR
PerlIOStdio_get_ptr,
PerlIOStdio_get_cnt,
# if defined(HAS_FAST_STDIO) && defined(USE_FAST_STDIO)
PerlIOStdio_set_ptrcnt,
# else
NULL,
# endif /* HAS_FAST_STDIO && USE_FAST_STDIO */
#else
NULL,
NULL,
NULL,
#endif /* USE_STDIO_PTR */
};
/* Note that calls to PerlIO_exportFILE() are reversed using
* PerlIO_releaseFILE(), not importFILE. */
FILE *
PerlIO_exportFILE(PerlIO * f, const char *mode)
{
dTHX;
FILE *stdio = NULL;
if (PerlIOValid(f)) {
char buf[8];
PerlIO_flush(f);
if (!mode || !*mode) {
mode = PerlIO_modestr(f, buf);
}
stdio = PerlSIO_fdopen(PerlIO_fileno(f), mode);
if (stdio) {
PerlIOl *l = *f;
PerlIO *f2;
/* De-link any lower layers so new :stdio sticks */
*f = NULL;
if ((f2 = PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_stdio), buf, 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;
}
else {
/* restore layers list */
*f = l;
}
}
}
return stdio;
}
FILE *
PerlIO_findFILE(PerlIO *f)
{
PerlIOl *l = *f;
FILE *stdio;
while (l) {
if (l->tab == &PerlIO_stdio) {
PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
return s->stdio;
}
l = *PerlIONext(&l);
}
/* Uses fallback "mode" via PerlIO_modestr() in PerlIO_exportFILE */
/* 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. */
void
PerlIO_releaseFILE(PerlIO *p, FILE *f)
{
dVAR;
PerlIOl *l;
while ((l = *p)) {
if (l->tab == &PerlIO_stdio) {
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;
}
}
p = PerlIONext(p);
}
return;
}
/*--------------------------------------------------------------------------------------*/
/*
* perlio buffer layer
*/
IV
PerlIOBuf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
{
PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
const int fd = PerlIO_fileno(f);
if (fd >= 0 && PerlLIO_isatty(fd)) {
PerlIOBase(f)->flags |= PERLIO_F_LINEBUF | PERLIO_F_TTY;
}
if (*PerlIONext(f)) {
const Off_t posn = PerlIO_tell(PerlIONext(f));
if (posn != (Off_t) - 1) {
b->posn = posn;
}
}
return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
}
PerlIO *
PerlIOBuf_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
IV n, const char *mode, int fd, int imode, int perm,
PerlIO *f, int narg, SV **args)
{
if (PerlIOValid(f)) {
PerlIO *next = PerlIONext(f);
PerlIO_funcs *tab =
PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIOBase(next)->tab);
if (tab && tab->Open)
next =
(*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
next, narg, args);
if (!next || (*PerlIOBase(f)->tab->Pushed) (aTHX_ f, mode, PerlIOArg, self) != 0) {
return NULL;
}
}
else {
PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIO_default_btm());
int init = 0;
if (*mode == IoTYPE_IMPLICIT) {
init = 1;
/*
* mode++;
*/
}
if (tab && tab->Open)
f = (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
f, narg, args);
else
SETERRNO(EINVAL, LIB_INVARG);
if (f) {
if (PerlIO_push(aTHX_ f, self, mode, PerlIOArg) == 0) {
/*
* if push fails during open, open fails. close will pop us.
*/
PerlIO_close (f);
return NULL;
} else {
fd = PerlIO_fileno(f);
if (init && fd == 2) {
/*
* Initial stderr is unbuffered
*/
PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
}
#ifdef PERLIO_USING_CRLF
# ifdef PERLIO_IS_BINMODE_FD
if (PERLIO_IS_BINMODE_FD(fd))
PerlIO_binmode(aTHX_ f, '<'/*not used*/, O_BINARY, NULL);
else
# endif
/*
* do something about failing setmode()? --jhi
*/
PerlLIO_setmode(fd, O_BINARY);
#endif
#ifdef VMS
/* 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
}
}
}
return f;
}
/*
* This "flush" is akin to sfio's sync in that it handles files in either
* read or write state. For write state, we put the postponed data through
* the next layers. For read state, we seek() the next layers to the
* offset given by current position in the buffer, and discard the buffer
* state (XXXX supposed to be for seek()able buffers only, but now it is done
* in any case?). Then the pass the stick further in chain.
*/
IV
PerlIOBuf_flush(pTHX_ PerlIO *f)
{
PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
int code = 0;
PerlIO *n = PerlIONext(f);
if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) {
/*
* write() the buffer
*/
const STDCHAR *buf = b->buf;
const STDCHAR *p = buf;
while (p < b->ptr) {
SSize_t count = PerlIO_write(n, p, b->ptr - p);
if (count > 0) {
p += count;
}
else if (count < 0 || PerlIO_error(n)) {
PerlIOBase(f)->flags |= PERLIO_F_ERROR;
code = -1;
break;
}
}
b->posn += (p - buf);
}
else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
STDCHAR *buf = PerlIO_get_base(f);
/*
* Note position change
*/
b->posn += (b->ptr - buf);
if (b->ptr < b->end) {
/* We did not consume all of it - try and seek downstream to
our logical position
*/
if (PerlIOValid(n) && PerlIO_seek(n, b->posn, SEEK_SET) == 0) {
/* Reload n as some layers may pop themselves on seek */
b->posn = PerlIO_tell(n = PerlIONext(f));
}
else {
/* Seek failed (e.g. pipe or tty). Do NOT clear buffer or pre-read
data is lost for good - so return saying "ok" having undone
the position adjust
*/
b->posn -= (b->ptr - buf);
return code;
}
}
}
b->ptr = b->end = b->buf;
PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
/* We check for Valid because of dubious decision to make PerlIO_flush(NULL) flush all */
if (PerlIOValid(n) && PerlIO_flush(n) != 0)
code = -1;
return code;
}
/* This discards the content of the buffer after b->ptr, and rereads
* the buffer from the position off in the layer downstream; here off
* is at offset corresponding to b->ptr - b->buf.
*/
IV
PerlIOBuf_fill(pTHX_ PerlIO *f)
{
PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
PerlIO *n = PerlIONext(f);
SSize_t avail;
/*
* Down-stream flush is defined not to loose read data so is harmless.
* we would not normally be fill'ing if there was data left in anycase.
*/
if (PerlIO_flush(f) != 0) /* XXXX Check that its seek() succeeded?! */
return -1;
if (PerlIOBase(f)->flags & PERLIO_F_TTY)
PerlIOBase_flush_linebuf(aTHX);
if (!b->buf)
PerlIO_get_base(f); /* allocate via vtable */
assert(b->buf); /* The b->buf does get allocated via the vtable system. */
b->ptr = b->end = b->buf;
if (!PerlIOValid(n)) {
PerlIOBase(f)->flags |= PERLIO_F_EOF;
return -1;
}
if (PerlIO_fast_gets(n)) {
/*
* Layer below is also buffered. We do _NOT_ want to call its
* ->Read() because that will loop till it gets what we asked for
* which may hang on a pipe etc. Instead take anything it has to
* hand, or ask it to fill _once_.
*/
avail = PerlIO_get_cnt(n);
if (avail <= 0) {
avail = PerlIO_fill(n);
if (avail == 0)
avail = PerlIO_get_cnt(n);
else {
if (!PerlIO_error(n) && PerlIO_eof(n))
avail = 0;
}
}
if (avail > 0) {
STDCHAR *ptr = PerlIO_get_ptr(n);
const SSize_t cnt = avail;
if (avail > (SSize_t)b->bufsiz)
avail = b->bufsiz;
Copy(ptr, b->buf, avail, STDCHAR);
PerlIO_set_ptrcnt(n, ptr + avail, cnt - avail);
}
}
else {
avail = PerlIO_read(n, b->ptr, b->bufsiz);
}
if (avail <= 0) {
if (avail == 0)
PerlIOBase(f)->flags |= PERLIO_F_EOF;
else
PerlIOBase(f)->flags |= PERLIO_F_ERROR;
return -1;
}
b->end = b->buf + avail;
PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
return 0;
}
SSize_t
PerlIOBuf_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
{
if (PerlIOValid(f)) {
const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
if (!b->ptr)
PerlIO_get_base(f);
return PerlIOBase_read(aTHX_ f, vbuf, count);
}
return 0;
}
SSize_t
PerlIOBuf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
{
const STDCHAR *buf = (const STDCHAR *) vbuf + count;
PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
SSize_t unread = 0;
SSize_t avail;
if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
PerlIO_flush(f);
if (!b->buf)
PerlIO_get_base(f);
if (b->buf) {
if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
/*
* Buffer is already a read buffer, we can overwrite any chars
* which have been read back to buffer start
*/
avail = (b->ptr - b->buf);
}
else {
/*
* Buffer is idle, set it up so whole buffer is available for
* unread
*/
avail = b->bufsiz;
b->end = b->buf + avail;
b->ptr = b->end;
PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
/*
* Buffer extends _back_ from where we are now
*/
b->posn -= b->bufsiz;
}
if (avail > (SSize_t) count) {
/*
* If we have space for more than count, just move count
*/
avail = count;
}
if (avail > 0) {
b->ptr -= avail;
buf -= avail;
/*
* In simple stdio-like ungetc() case chars will be already
* there
*/
if (buf != b->ptr) {
Copy(buf, b->ptr, avail, STDCHAR);
}
count -= avail;
unread += avail;
PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
}
}
if (count > 0) {
unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
}
return unread;
}
SSize_t
PerlIOBuf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
{
PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
const STDCHAR *buf = (const STDCHAR *) vbuf;
const STDCHAR *flushptr = buf;
Size_t written = 0;
if (!b->buf)
PerlIO_get_base(f);
if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
return 0;
if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
if (PerlIO_flush(f) != 0) {
return 0;
}
}
if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
flushptr = buf + count;
while (flushptr > buf && *(flushptr - 1) != '\n')
--flushptr;
}
while (count > 0) {
SSize_t avail = b->bufsiz - (b->ptr - b->buf);
if ((SSize_t) count < avail)
avail = count;
if (flushptr > buf && flushptr <= buf + avail)
avail = flushptr - buf;
PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
if (avail) {
Copy(buf, b->ptr, avail, STDCHAR);
count -= avail;
buf += avail;
written += avail;
b->ptr += avail;
if (buf == flushptr)
PerlIO_flush(f);
}
if (b->ptr >= (b->buf + b->bufsiz))
if (PerlIO_flush(f) == -1)
return -1;
}
if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
PerlIO_flush(f);
return written;
}
IV
PerlIOBuf_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
{
IV code;
if ((code = PerlIO_flush(f)) == 0) {
PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
code = PerlIO_seek(PerlIONext(f), offset, whence);
if (code == 0) {
PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
b->posn = PerlIO_tell(PerlIONext(f));
}
}
return code;
}
Off_t
PerlIOBuf_tell(pTHX_ PerlIO *f)
{
PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
/*
* b->posn is file position where b->buf was read, or will be written
*/
Off_t posn = b->posn;
if ((PerlIOBase(f)->flags & PERLIO_F_APPEND) &&
(PerlIOBase(f)->flags & PERLIO_F_WRBUF)) {
#if 1
/* As O_APPEND files are normally shared in some sense it is better
to flush :
*/
PerlIO_flush(f);
#else
/* when file is NOT shared then this is sufficient */
PerlIO_seek(PerlIONext(f),0, SEEK_END);
#endif
posn = b->posn = PerlIO_tell(PerlIONext(f));
}
if (b->buf) {
/*
* If buffer is valid adjust position by amount in buffer
*/
posn += (b->ptr - b->buf);
}
return posn;
}
IV
PerlIOBuf_popped(pTHX_ PerlIO *f)
{
const IV code = PerlIOBase_popped(aTHX_ f);
PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
Safefree(b->buf);
}
b->ptr = b->end = b->buf = NULL;
PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
return code;
}
IV
PerlIOBuf_close(pTHX_ PerlIO *f)
{
const IV code = PerlIOBase_close(aTHX_ f);
PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
Safefree(b->buf);
}
b->ptr = b->end = b->buf = NULL;
PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
return code;
}
STDCHAR *
PerlIOBuf_get_ptr(pTHX_ PerlIO *f)
{
const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
if (!b->buf)
PerlIO_get_base(f);
return b->ptr;
}
SSize_t
PerlIOBuf_get_cnt(pTHX_ PerlIO *f)
{
const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
if (!b->buf)
PerlIO_get_base(f);
if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
return (b->end - b->ptr);
return 0;
}
STDCHAR *
PerlIOBuf_get_base(pTHX_ PerlIO *f)
{
PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
PERL_UNUSED_CONTEXT;
if (!b->buf) {
if (!b->bufsiz)
b->bufsiz = PERLIOBUF_DEFAULT_BUFSIZ;
Newxz(b->buf,b->bufsiz, STDCHAR);
if (!b->buf) {
b->buf = (STDCHAR *) & b->oneword;
b->bufsiz = sizeof(b->oneword);
}
b->end = b->ptr = b->buf;
}
return b->buf;
}
Size_t
PerlIOBuf_bufsiz(pTHX_ PerlIO *f)
{
const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
if (!b->buf)
PerlIO_get_base(f);
return (b->end - b->buf);
}
void
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;
assert(PerlIO_get_cnt(f) == cnt);
assert(b->ptr >= b->buf);
PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
}
PerlIO *
PerlIOBuf_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
{
return PerlIOBase_dup(aTHX_ f, o, param, flags);
}
PERLIO_FUNCS_DECL(PerlIO_perlio) = {
sizeof(PerlIO_funcs),
"perlio",
sizeof(PerlIOBuf),
PERLIO_K_BUFFERED|PERLIO_K_RAW,
PerlIOBuf_pushed,
PerlIOBuf_popped,
PerlIOBuf_open,
PerlIOBase_binmode, /* binmode */
NULL,
PerlIOBase_fileno,
PerlIOBuf_dup,
PerlIOBuf_read,
PerlIOBuf_unread,
PerlIOBuf_write,
PerlIOBuf_seek,
PerlIOBuf_tell,
PerlIOBuf_close,
PerlIOBuf_flush,
PerlIOBuf_fill,
PerlIOBase_eof,
PerlIOBase_error,
PerlIOBase_clearerr,
PerlIOBase_setlinebuf,
PerlIOBuf_get_base,
PerlIOBuf_bufsiz,
PerlIOBuf_get_ptr,
PerlIOBuf_get_cnt,
PerlIOBuf_set_ptrcnt,
};
/*--------------------------------------------------------------------------------------*/
/*
* Temp layer to hold unread chars when cannot do it any other way
*/
IV
PerlIOPending_fill(pTHX_ PerlIO *f)
{
/*
* Should never happen
*/
PerlIO_flush(f);
return 0;
}
IV
PerlIOPending_close(pTHX_ PerlIO *f)
{
/*
* A tad tricky - flush pops us, then we close new top
*/
PerlIO_flush(f);
return PerlIO_close(f);
}
IV
PerlIOPending_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
{
/*
* A tad tricky - flush pops us, then we seek new top
*/
PerlIO_flush(f);
return PerlIO_seek(f, offset, whence);
}
IV
PerlIOPending_flush(pTHX_ PerlIO *f)
{
PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
Safefree(b->buf);
b->buf = NULL;
}
PerlIO_pop(aTHX_ f);
return 0;
}
void
PerlIOPending_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
{
if (cnt <= 0) {
PerlIO_flush(f);
}
else {
PerlIOBuf_set_ptrcnt(aTHX_ f, ptr, cnt);
}
}
IV
PerlIOPending_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
{
const IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
PerlIOl * const l = PerlIOBase(f);
/*
* Our PerlIO_fast_gets must match what we are pushed on, or sv_gets()
* etc. get muddled when it changes mid-string when we auto-pop.
*/
l->flags = (l->flags & ~(PERLIO_F_FASTGETS | PERLIO_F_UTF8)) |
(PerlIOBase(PerlIONext(f))->
flags & (PERLIO_F_FASTGETS | PERLIO_F_UTF8));
return code;
}
SSize_t
PerlIOPending_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
{
SSize_t avail = PerlIO_get_cnt(f);
SSize_t got = 0;
if ((SSize_t)count < avail)
avail = count;
if (avail > 0)
got = PerlIOBuf_read(aTHX_ f, vbuf, avail);
if (got >= 0 && got < (SSize_t)count) {
const SSize_t more =
PerlIO_read(f, ((STDCHAR *) vbuf) + got, count - got);
if (more >= 0 || got == 0)
got += more;
}
return got;
}
PERLIO_FUNCS_DECL(PerlIO_pending) = {
sizeof(PerlIO_funcs),
"pending",
sizeof(PerlIOBuf),
PERLIO_K_BUFFERED|PERLIO_K_RAW, /* not sure about RAW here */
PerlIOPending_pushed,
PerlIOBuf_popped,
NULL,
PerlIOBase_binmode, /* binmode */
NULL,
PerlIOBase_fileno,
PerlIOBuf_dup,
PerlIOPending_read,
PerlIOBuf_unread,
PerlIOBuf_write,
PerlIOPending_seek,
PerlIOBuf_tell,
PerlIOPending_close,
PerlIOPending_flush,
PerlIOPending_fill,
PerlIOBase_eof,
PerlIOBase_error,
PerlIOBase_clearerr,
PerlIOBase_setlinebuf,
PerlIOBuf_get_base,
PerlIOBuf_bufsiz,
PerlIOBuf_get_ptr,
PerlIOBuf_get_cnt,
PerlIOPending_set_ptrcnt,
};
/*--------------------------------------------------------------------------------------*/
/*
* crlf - translation On read translate CR,LF to "\n" we do this by
* overriding ptr/cnt entries to hand back a line at a time and keeping a
* record of which nl we "lied" about. On write translate "\n" to CR,LF
*
* c->nl points on the first byte of CR LF pair when it is temporarily
* replaced by LF, or to the last CR of the buffer. In the former case
* the caller thinks that the buffer ends at c->nl + 1, in the latter
* that it ends at c->nl; these two cases can be distinguished by
* *c->nl. c->nl is set during _getcnt() call, and unset during
* _unread() and _flush() calls.
* It only matters for read operations.
*/
typedef struct {
PerlIOBuf base; /* PerlIOBuf stuff */
STDCHAR *nl; /* Position of crlf we "lied" about in the
* buffer */
} PerlIOCrlf;
/* Inherit the PERLIO_F_UTF8 flag from previous layer.
* Otherwise the :crlf layer would always revert back to
* raw mode.
*/
static void
S_inherit_utf8_flag(PerlIO *f)
{
PerlIO *g = PerlIONext(f);
if (PerlIOValid(g)) {
if (PerlIOBase(g)->flags & PERLIO_F_UTF8) {
PerlIOBase(f)->flags |= PERLIO_F_UTF8;
}
}
}
IV
PerlIOCrlf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
{
IV code;
PerlIOBase(f)->flags |= PERLIO_F_CRLF;
code = PerlIOBuf_pushed(aTHX_ f, mode, arg, tab);
#if 0
PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08" UVxf "\n",
(void*)f, PerlIOBase(f)->tab->name, (mode) ? mode : "(Null)",
PerlIOBase(f)->flags);
#endif
{
/* 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);
if (PerlIOValid(g)) {
PerlIOl *b = PerlIOBase(g);
if (b && b->tab == &PerlIO_crlf) {
if (!(b->flags & PERLIO_F_CRLF))
b->flags |= PERLIO_F_CRLF;
S_inherit_utf8_flag(g);
PerlIO_pop(aTHX_ f);
return code;
}
}
}
S_inherit_utf8_flag(f);
return code;
}
SSize_t
PerlIOCrlf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
{
PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
if (c->nl) { /* XXXX Shouldn't it be done only if b->ptr > c->nl? */
*(c->nl) = 0xd;
c->nl = NULL;
}
if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
return PerlIOBuf_unread(aTHX_ f, vbuf, count);
else {
const STDCHAR *buf = (const STDCHAR *) vbuf + count;
PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
SSize_t unread = 0;
if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
PerlIO_flush(f);
if (!b->buf)
PerlIO_get_base(f);
if (b->buf) {
if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
b->end = b->ptr = b->buf + b->bufsiz;
PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
b->posn -= b->bufsiz;
}
while (count > 0 && b->ptr > b->buf) {
const int ch = *--buf;
if (ch == '\n') {
if (b->ptr - 2 >= b->buf) {
*--(b->ptr) = 0xa;
*--(b->ptr) = 0xd;
unread++;
count--;
}
else {
/* If b->ptr - 1 == b->buf, we are undoing reading 0xa */
*--(b->ptr) = 0xa; /* Works even if 0xa == '\r' */
unread++;
count--;
}
}
else {
*--(b->ptr) = ch;
unread++;
count--;
}
}
}
return unread;
}
}
/* XXXX This code assumes that buffer size >=2, but does not check it... */
SSize_t
PerlIOCrlf_get_cnt(pTHX_ PerlIO *f)
{
PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
if (!b->buf)
PerlIO_get_base(f);
if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && (!c->nl || *c->nl == 0xd)) {
STDCHAR *nl = (c->nl) ? c->nl : b->ptr;
scan:
while (nl < b->end && *nl != 0xd)
nl++;
if (nl < b->end && *nl == 0xd) {
test:
if (nl + 1 < b->end) {
if (nl[1] == 0xa) {
*nl = '\n';
c->nl = nl;
}
else {
/*
* Not CR,LF but just CR
*/
nl++;
goto scan;
}
}
else {
/*
* Blast - found CR as last char in buffer
*/
if (b->ptr < nl) {
/*
* They may not care, defer work as long as
* possible
*/
c->nl = nl;
return (nl - b->ptr);
}
else {
int code;
b->ptr++; /* say we have read it as far as
* flush() is concerned */
b->buf++; /* Leave space in front of buffer */
/* Note as we have moved buf up flush's
posn += ptr-buf
will naturally make posn point at CR
*/
b->bufsiz--; /* Buffer is thus smaller */
code = PerlIO_fill(f); /* Fetch some more */
b->bufsiz++; /* Restore size for next time */
b->buf--; /* Point at space */
b->ptr = nl = b->buf; /* Which is what we hand
* off */
*nl = 0xd; /* Fill in the CR */
if (code == 0)
goto test; /* fill() call worked */
/*
* CR at EOF - just fall through
*/
/* Should we clear EOF though ??? */
}
}
}
}
return (((c->nl) ? (c->nl + 1) : b->end) - b->ptr);
}
return 0;
}
void
PerlIOCrlf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
{
PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
if (!b->buf)
PerlIO_get_base(f);
if (!ptr) {
if (c->nl) {
ptr = c->nl + 1;
if (ptr == b->end && *c->nl == 0xd) {
/* Deferred CR at end of buffer case - we lied about count */
ptr--;
}
}
else {
ptr = b->end;
}
ptr -= cnt;
}
else {
NOOP;
#if 0
/*
* Test code - delete when it works ...
*/
IV flags = PerlIOBase(f)->flags;
STDCHAR *chk = (c->nl) ? (c->nl+1) : b->end;
if (ptr+cnt == c->nl && c->nl+1 == b->end && *c->nl == 0xd) {
/* 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", (void*)ptr, (void*)chk,
flags, c->nl, b->end, cnt);
}
#endif
}
if (c->nl) {
if (ptr > c->nl) {
/*
* They have taken what we lied about
*/
*(c->nl) = 0xd;
c->nl = NULL;
ptr++;
}
}
b->ptr = ptr;
PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
}
SSize_t
PerlIOCrlf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
{
if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
return PerlIOBuf_write(aTHX_ f, vbuf, count);
else {
PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
const STDCHAR *buf = (const STDCHAR *) vbuf;
const STDCHAR * const ebuf = buf + count;
if (!b->buf)
PerlIO_get_base(f);
if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
return 0;
while (buf < ebuf) {
const STDCHAR * const eptr = b->buf + b->bufsiz;
PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
while (buf < ebuf && b->ptr < eptr) {
if (*buf == '\n') {
if ((b->ptr + 2) > eptr) {
/*
* Not room for both
*/
PerlIO_flush(f);
break;
}
else {
*(b->ptr)++ = 0xd; /* CR */
*(b->ptr)++ = 0xa; /* LF */
buf++;
if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
PerlIO_flush(f);
break;
}
}
}
else {
*(b->ptr)++ = *buf++;
}
if (b->ptr >= eptr) {
PerlIO_flush(f);
break;
}
}
}
if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
PerlIO_flush(f);
return (buf - (STDCHAR *) vbuf);
}
}
IV
PerlIOCrlf_flush(pTHX_ PerlIO *f)
{
PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
if (c->nl) {
*(c->nl) = 0xd;
c->nl = NULL;
}
return PerlIOBuf_flush(aTHX_ f);
}
IV
PerlIOCrlf_binmode(pTHX_ PerlIO *f)
{
if ((PerlIOBase(f)->flags & PERLIO_F_CRLF)) {
/* In text mode - flush any pending stuff and flip it */
PerlIOBase(f)->flags &= ~PERLIO_F_CRLF;
#ifndef PERLIO_USING_CRLF
/* CRLF is unusual case - if this is just the :crlf layer pop it */
PerlIO_pop(aTHX_ f);
#endif
}
return 0;
}
PERLIO_FUNCS_DECL(PerlIO_crlf) = {
sizeof(PerlIO_funcs),
"crlf",
sizeof(PerlIOCrlf),
PERLIO_K_BUFFERED | PERLIO_K_CANCRLF | PERLIO_K_RAW,
PerlIOCrlf_pushed,
PerlIOBuf_popped, /* popped */
PerlIOBuf_open,
PerlIOCrlf_binmode, /* binmode */
NULL,
PerlIOBase_fileno,
PerlIOBuf_dup,
PerlIOBuf_read, /* generic read works with ptr/cnt lies */
PerlIOCrlf_unread, /* Put CR,LF in buffer for each '\n' */
PerlIOCrlf_write, /* Put CR,LF in buffer for each '\n' */
PerlIOBuf_seek,
PerlIOBuf_tell,
PerlIOBuf_close,
PerlIOCrlf_flush,
PerlIOBuf_fill,
PerlIOBase_eof,
PerlIOBase_error,
PerlIOBase_clearerr,
PerlIOBase_setlinebuf,
PerlIOBuf_get_base,
PerlIOBuf_bufsiz,
PerlIOBuf_get_ptr,
PerlIOCrlf_get_cnt,
PerlIOCrlf_set_ptrcnt,
};
PerlIO *
Perl_PerlIO_stdin(pTHX)
{
dVAR;
if (!PL_perlio) {
PerlIO_stdstreams(aTHX);
}
return (PerlIO*)&PL_perlio[1];
}
PerlIO *
Perl_PerlIO_stdout(pTHX)
{
dVAR;
if (!PL_perlio) {
PerlIO_stdstreams(aTHX);
}
return (PerlIO*)&PL_perlio[2];
}
PerlIO *
Perl_PerlIO_stderr(pTHX)
{
dVAR;
if (!PL_perlio) {
PerlIO_stdstreams(aTHX);
}
return (PerlIO*)&PL_perlio[3];
}
/*--------------------------------------------------------------------------------------*/
char *
PerlIO_getname(PerlIO *f, char *buf)
{
dTHX;
#ifdef VMS
char *name = NULL;
bool exported = FALSE;
FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
if (!stdio) {
stdio = PerlIO_exportFILE(f,0);
exported = TRUE;
}
if (stdio) {
name = fgetname(stdio, buf);
if (exported) PerlIO_releaseFILE(f,stdio);
}
return name;
#else
PERL_UNUSED_ARG(f);
PERL_UNUSED_ARG(buf);
Perl_croak(aTHX_ "Don't know how to get file name");
return NULL;
#endif
}
/*--------------------------------------------------------------------------------------*/
/*
* Functions which can be called on any kind of PerlIO implemented in
* terms of above
*/
#undef PerlIO_fdopen
PerlIO *
PerlIO_fdopen(int fd, const char *mode)
{
dTHX;
return PerlIO_openn(aTHX_ NULL, mode, fd, 0, 0, NULL, 0, NULL);
}
#undef PerlIO_open
PerlIO *
PerlIO_open(const char *path, const char *mode)
{
dTHX;
SV *name = sv_2mortal(newSVpv(path, 0));
return PerlIO_openn(aTHX_ NULL, mode, -1, 0, 0, NULL, 1, &name);
}
#undef Perlio_reopen
PerlIO *
PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
{
dTHX;
SV *name = sv_2mortal(newSVpv(path,0));
return PerlIO_openn(aTHX_ NULL, mode, -1, 0, 0, f, 1, &name);
}
#undef PerlIO_getc
int
PerlIO_getc(PerlIO *f)
{
dTHX;
STDCHAR buf[1];
if ( 1 == PerlIO_read(f, buf, 1) ) {
return (unsigned char) buf[0];
}
return EOF;
}
#undef PerlIO_ungetc
int
PerlIO_ungetc(PerlIO *f, int ch)
{
dTHX;
if (ch != EOF) {
STDCHAR buf = ch;
if (PerlIO_unread(f, &buf, 1) == 1)
return ch;
}
return EOF;
}
#undef PerlIO_putc
int
PerlIO_putc(PerlIO *f, int ch)
{
dTHX;
STDCHAR buf = ch;
return PerlIO_write(f, &buf, 1);
}
#undef PerlIO_puts
int
PerlIO_puts(PerlIO *f, const char *s)
{
dTHX;
return PerlIO_write(f, s, strlen(s));
}
#undef PerlIO_rewind
void
PerlIO_rewind(PerlIO *f)
{
dTHX;
PerlIO_seek(f, (Off_t) 0, SEEK_SET);
PerlIO_clearerr(f);
}
#undef PerlIO_vprintf
int
PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
{
dTHX;
SV * sv;
const char *s;
STRLEN len;
SSize_t wrote;
#ifdef NEED_VA_COPY
va_list apc;
Perl_va_copy(ap, apc);
sv = vnewSVpvf(fmt, &apc);
#else
sv = vnewSVpvf(fmt, &ap);
#endif
s = SvPV_const(sv, len);
wrote = PerlIO_write(f, s, len);
SvREFCNT_dec(sv);
return wrote;
}
#undef PerlIO_printf
int
PerlIO_printf(PerlIO *f, const char *fmt, ...)
{
va_list ap;
int result;
va_start(ap, fmt);
result = PerlIO_vprintf(f, fmt, ap);
va_end(ap);
return result;
}
#undef PerlIO_stdoutf
int
PerlIO_stdoutf(const char *fmt, ...)
{
dTHX;
va_list ap;
int result;
va_start(ap, fmt);
result = PerlIO_vprintf(PerlIO_stdout(), fmt, ap);
va_end(ap);
return result;
}
#undef PerlIO_tmpfile
PerlIO *
PerlIO_tmpfile(void)
{
dTHX;
PerlIO *f = NULL;
#ifdef WIN32
const int fd = win32_tmpfd();
if (fd >= 0)
f = PerlIO_fdopen(fd, "w+b");
#else /* WIN32 */
# if defined(HAS_MKSTEMP) && ! defined(VMS) && ! defined(OS2)
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
*/
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(sv ? SvPVX_const(sv) : tempname);
}
SvREFCNT_dec(sv);
# else /* !HAS_MKSTEMP, fallback to stdio tmpfile(). */
FILE * const stdio = PerlSIO_tmpfile();
if (stdio)
f = PerlIO_fdopen(fileno(stdio), "w+");
# endif /* else HAS_MKSTEMP */
#endif /* else WIN32 */
return f;
}
#undef HAS_FSETPOS
#undef HAS_FGETPOS
#endif /* USE_SFIO */
#endif /* PERLIO_IS_STDIO */
/*======================================================================================*/
/*
* Now some functions in terms of above which may be needed even if we are
* not in true PerlIO mode
*/
const char *
Perl_PerlIO_context_layers(pTHX_ const char *mode)
{
dVAR;
const char *direction = NULL;
SV *layers;
/*
* Need to supply default layer info from open.pm
*/
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<";
}
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;
}
#ifndef HAS_FSETPOS
#undef PerlIO_setpos
int
PerlIO_setpos(PerlIO *f, SV *pos)
{
dTHX;
if (SvOK(pos)) {
STRLEN len;
const Off_t * const posn = (Off_t *) SvPV(pos, len);
if (f && len == sizeof(Off_t))
return PerlIO_seek(f, *posn, SEEK_SET);
}
SETERRNO(EINVAL, SS_IVCHAN);
return -1;
}
#else
#undef PerlIO_setpos
int
PerlIO_setpos(PerlIO *f, SV *pos)
{
dTHX;
if (SvOK(pos)) {
STRLEN len;
Fpos_t * const fpos = (Fpos_t *) SvPV(pos, len);
if (f && len == sizeof(Fpos_t)) {
#if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
return fsetpos64(f, fpos);
#else
return fsetpos(f, fpos);
#endif
}
}
SETERRNO(EINVAL, SS_IVCHAN);
return -1;
}
#endif
#ifndef HAS_FGETPOS
#undef PerlIO_getpos
int
PerlIO_getpos(PerlIO *f, SV *pos)
{
dTHX;
Off_t posn = PerlIO_tell(f);
sv_setpvn(pos, (char *) &posn, sizeof(posn));
return (posn == (Off_t) - 1) ? -1 : 0;
}
#else
#undef PerlIO_getpos
int
PerlIO_getpos(PerlIO *f, SV *pos)
{
dTHX;
Fpos_t fpos;
int code;
#if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
code = fgetpos64(f, &fpos);
#else
code = fgetpos(f, &fpos);
#endif
sv_setpvn(pos, (char *) &fpos, sizeof(fpos));
return code;
}
#endif
#if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
int
vprintf(char *pat, char *args)
{
_doprnt(pat, args, stdout);
return 0; /* wrong, but perl doesn't use the return
* value */
}
int
vfprintf(FILE *fd, char *pat, char *args)
{
_doprnt(pat, args, fd);
return 0; /* wrong, but perl doesn't use the return
* value */
}
#endif
#ifndef PerlIO_vsprintf
int
PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
{
dTHX;
const int val = my_vsnprintf(s, n > 0 ? n : 0, fmt, ap);
PERL_UNUSED_CONTEXT;
#ifndef PERL_MY_VSNPRINTF_GUARDED
if (val < 0 || (n > 0 ? val >= n : 0)) {
Perl_croak(aTHX_ "panic: my_vsnprintf overflow in PerlIO_vsprintf\n");
}
#endif
return val;
}
#endif
#ifndef PerlIO_sprintf
int
PerlIO_sprintf(char *s, int n, const char *fmt, ...)
{
va_list ap;
int result;
va_start(ap, fmt);
result = PerlIO_vsprintf(s, n, fmt, ap);
va_end(ap);
return result;
}
#endif
/*
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
* indent-tabs-mode: nil
* End:
*
* ex: set ts=8 sts=4 sw=4 et:
*/