/*
* perlio.c Copyright (c) 1996-2004, Nick Ing-Simmons You may distribute
* under the terms of either the GNU General Public License or the
* Artistic License, as specified in the README file.
*/
/*
* Hour after hour for nearly three weary days he had jogged up and down,
* over passes, and through long dales, and across many streams.
*/
/*
* 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
#else
#endif
#ifdef PERL_MICRO
# include "uconfig.h"
#else
# include "config.h"
#endif
#define PERLIO_NOT_STDIO 0
#if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
/*
* #define PerlIO FILE
*/
#endif
/*
* This file provides those parts of PerlIO abstraction
* which are not #defined in perlio.h.
* Which these are depends on various Configure #ifdef's
*/
#include "EXTERN.h"
#define PERL_IN_PERLIO_C
#include "perl.h"
#ifdef PERL_IMPLICIT_CONTEXT
#endif
#include "XSUB.h"
#ifdef __Lynx__
/* Missing proto on LynxOS */
int mkstemp(char*);
#endif
/* Call the callback or PerlIOBase, and return failure. */
if (PerlIOValid(f)) { \
else \
} \
else \
return failure
/* Call the callback or fail, and return failure. */
if (PerlIOValid(f)) { \
} \
else \
return failure
/* Call the callback or PerlIOBase, and be void. */
if (PerlIOValid(f)) { \
else \
} \
else \
/* Call the callback or fail, and be void. */
if (PerlIOValid(f)) { \
else \
} \
else \
int
{
/*
* This used to be contents of do_binmode in doio.c
*/
#ifdef DOSISH
else
return 1;
}
return 0;
# else
dTHX;
#ifdef NETWARE
#else
#endif
# if defined(WIN32) && defined(__BORLANDC__)
/*
* The translation mode of the stream is maintained independent of
* the translation mode of the fd in the Borland RTL (heavy
* digging through their runtime sources reveal). User has to set
* the mode explicitly for the stream (though they don't document
* this anywhere). GSAR 97-5-24
*/
else
# endif
return 1;
}
else
return 0;
# endif
#else
# if defined(USEMYBINMODE)
dTHX;
return 1;
else
return 0;
# else
return 1;
# endif
#endif
}
#ifndef O_ACCMODE
#endif
int
{
int ix = 0;
int ptype;
switch (result) {
case O_RDONLY:
break;
case O_WRONLY:
break;
case O_RDWR:
default:
ptype = IoTYPE_RDWR;
break;
}
if (writing)
}
#ifdef O_APPEND
}
#endif
else {
else {
}
}
return ptype;
}
#ifndef PERLIO_LAYERS
int
{
) {
return 0;
}
/*
* NOTREACHED
*/
return -1;
}
void
{
}
int
{
#ifdef USE_SFIO
return 1;
#else
#endif
}
PerlIO *
{
#ifdef PERL_MICRO
return NULL;
#else
#ifdef PERL_IMPLICIT_SYS
return PerlSIO_fdupopen(f);
#else
#ifdef WIN32
return win32_fdupopen(f);
#else
if (f) {
if (fd >= 0) {
char mode[8];
#ifdef DJGPP
omode = djgpp_get_stream_mode(f);
#endif
/* the r+ is a hack */
}
return NULL;
}
else {
}
#endif
return NULL;
#endif
#endif
}
/*
* De-mux PerlIO_openn() into fdopen, freopen and fopen type entries
*/
PerlIO *
{
if (narg) {
if (narg > 1) {
}
if (*args == &PL_sv_undef)
return PerlIO_tmpfile();
else {
if (*mode == IoTYPE_NUMERIC) {
if (fd >= 0)
}
else if (old) {
}
else {
}
}
}
else {
}
return NULL;
}
{
if (items < 2)
else {
XSRETURN(1);
}
}
void
{
}
#endif
#ifdef PERLIO_IS_STDIO
void
{
/*
* 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
*/
}
PerlIO *
PerlIO_tmpfile(void)
{
return tmpfile();
}
#else /* PERLIO_IS_STDIO */
#ifdef USE_SFIO
/*
* This section is just to make sure these functions get pulled in from
* libsfio.a
*/
PerlIO *
PerlIO_tmpfile(void)
{
return sftmp(0);
}
void
{
/*
* 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.
*/
}
/* This is not the reverse of PerlIO_exportFILE(), PerlIO_releaseFILE() is. */
PerlIO *
{
mode = "r+";
}
}
FILE *
{
return f;
}
#else /* USE_SFIO */
/*======================================================================================*/
/*
* Implement all the PerlIO interface ourselves.
*/
#include "perliol.h"
/*
* We _MUST_ have <unistd.h> if we are using lseek() and may have large
* files
*/
#ifdef I_UNISTD
#include <unistd.h>
#endif
#ifdef HAS_MMAP
#endif
/*
* Why is this here - not in perlio.h? RMB
*/
void PerlIO_debug(const char *fmt, ...)
void
{
static int dbg = 0;
dSYS;
if (!dbg) {
char *s = PerlEnv_getenv("PERLIO_DEBUG");
if (s && *s)
else
dbg = -1;
}
if (dbg > 0) {
dTHX;
#ifdef USE_ITHREADS
/* Use fixed buffer as sv_catpvf etc. needs SVs */
char *s;
if (!s)
s = "(none)";
#else
char *s;
if (!s)
s = "(none)";
#endif
}
}
/*--------------------------------------------------------------------------------------*/
/*
* Inner level routines
*/
/*
* Table of pointers to the PerlIO structs (malloc'ed)
*/
PerlIO *
{
/*
* Find a free slot in the table, allocating new table as necessary
*/
PerlIO *f;
while ((f = *last)) {
int i;
for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
if (!*++f) {
return f;
}
}
}
if (!f) {
return NULL;
}
*last = f;
return f + 1;
}
PerlIO *
{
if (PerlIOValid(f)) {
else {
}
}
else
return NULL;
}
void
{
if (table) {
int i;
for (i = PERLIO_TABLE_SIZE - 1; i > 0; i--) {
if (*f) {
PerlIO_close(f);
}
}
}
}
{
return list;
}
void
{
if (list) {
IV i;
}
}
}
}
}
void
{
PerlIO_pair_t *p;
else
}
}
}
{
if (proto) {
int i;
}
}
return list;
}
void
{
#ifdef USE_ITHREADS
PerlIO *f;
while ((f = *table)) {
int i;
for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
if (*f) {
}
f++;
}
}
#endif
}
void
{
PerlIO *f;
#ifdef USE_ITHREADS
#endif
while ((f = *table)) {
int i;
for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
PerlIO *x = f;
PerlIOl *l;
while ((l = *x)) {
PerlIO_flush(x);
PerlIO_pop(aTHX_ x);
}
else {
x = PerlIONext(x);
}
}
f++;
}
}
}
void
{
PerlIOl *l = *f;
if (l) {
/*
* 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
*/
return;
}
*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 *
{
if (PerlIOValid(f)) {
PerlIOl *l = PerlIOBase(f);
while (l) {
l = l->next;
}
}
return av;
}
/*--------------------------------------------------------------------------------------*/
/*
* XS Interface for perl code
*/
{
IV i;
for (i = 0; i < PL_known_layers->cur; i++) {
return f;
}
}
if (PL_in_load_module) {
return NULL;
} else {
if (cv) {
}
/*
* The two SVs are magically freed by load_module
*/
}
}
return NULL;
}
#ifdef USE_ATTRIBUTES_FOR_PERLIO
static int
{
}
return 0;
}
static int
{
}
return 0;
}
static int
{
return 0;
}
static int
{
return 0;
}
NULL, /* len */
};
{
int count = 0;
int i;
mg_magical(sv);
for (i = 2; i < items; i++) {
if (layer) {
}
else {
count++;
}
}
}
#endif /* USE_ATTIBUTES_FOR_PERLIO */
SV *
{
return sv;
}
{
/* This is used as a %SIG{__WARN__} handler to supress warnings
during loading of layers.
*/
if (items)
XSRETURN(0);
}
{
if (items < 2)
else {
ST(0) =
XSRETURN(1);
}
}
void
{
if (!PL_known_layers)
}
int
{
if (names) {
const char *s = names;
while (*s) {
while (isSPACE(*s) || *s == ':')
s++;
if (*s) {
const char *e = s;
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.
*/
char q = ((*s == '\'') ? '"' : '\'');
if (ckWARN(WARN_LAYER))
"Invalid separator character %c%c%c in PerlIO layer specification %s",
q, *s, q, s);
return -1;
}
do {
e++;
} while (isALNUM(*e));
llen = e - s;
if (*e == '(') {
as = ++e;
while (nesting) {
switch (*e++) {
case ')':
if (--nesting == 0)
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--;
if (ckWARN(WARN_LAYER))
"Argument list not closed for PerlIO layer \"%.*s\"",
(int) (e - s), s);
return -1;
default:
/*
* boring.
*/
break;
}
}
}
if (e > s) {
if (layer) {
alen) :
&PL_sv_undef);
}
else {
if (warn_layer)
(int) llen, s);
return -1;
}
}
s = e;
}
}
}
return 0;
}
void
{
#ifdef PERLIO_USING_CRLF
tab = &PerlIO_crlf;
#else
if (PerlIO_stdio.Set_ptrcnt)
tab = &PerlIO_stdio;
#endif
&PL_sv_undef);
}
SV *
{
}
{
}
if (!def)
return def;
}
{
if (PerlIOValid(f)) {
PerlIO_flush(f);
PerlIO_pop(aTHX_ f);
return 0;
}
return -1;
}
sizeof(PerlIO_funcs),
"pop",
0,
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 */
};
{
if (!PL_def_layerlist) {
#if defined(WIN32)
#if 0
osLayer = &PerlIO_win32;
#endif
#endif
#ifdef HAS_MMAP
#endif
&PL_sv_undef);
if (s) {
}
else {
}
}
}
return PL_def_layerlist;
}
void
{
#ifdef USE_ATTRIBUTES_FOR_PERLIO
__FILE__);
#endif
}
{
if (n < 0)
}
void
{
if (!PL_perlio) {
}
}
PerlIO *
{
}
goto mismatch;
}
/* Real layer with a data area */
if (l && f) {
l->next = *f;
*f = l;
PerlIO_pop(aTHX_ f);
return NULL;
}
}
}
else if (f) {
/* Pseudo-layer where push does its own stack adjust */
return NULL;
}
}
return f;
}
{
if (PerlIOValid(f)) {
/* Is layer suitable for raw stream ? */
/* Yes - turn off UTF-8-ness, to undo UTF-8 locale effects */
}
else {
/* Not suitable - pop it */
PerlIO_pop(aTHX_ f);
}
return 0;
}
return -1;
}
{
if (PerlIOValid(f)) {
PerlIO *t;
PerlIOl *l;
PerlIO_flush(f);
/*
* Strip all layers that are not suitable for a raw stream
*/
t = f;
while (t && (l = *t)) {
/* Has a handler - normal case */
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)) {
return 0;
}
}
return -1;
}
int
{
int code = 0;
while (n < max) {
if (tab) {
code = -1;
break;
}
}
n++;
}
return code;
}
int
{
int code = 0;
if (f && names) {
if (code == 0) {
}
}
return code;
}
/*--------------------------------------------------------------------------------------*/
/*
* Given the abstraction above the public API functions
*/
int
{
PerlIO_debug("PerlIO_binmode f=%p %s %c %x %s\n",
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.
*/
}
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.
*/
/* 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
*/
/* Not in text mode - flush any pending stuff and flip it */
PerlIO_flush(f);
}
/* 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().
*/
}
}
int
{
if (PerlIOValid(f)) {
else
return PerlIOBase_close(aTHX_ f);
}
else {
return -1;
}
}
int
{
while (PerlIOValid(f)) {
PerlIO_pop(aTHX_ f);
}
return code;
}
int
{
}
static const char *
{
/*
* Need to supply default layer info from open.pm
*/
if (PL_curcop) {
if (layers) {
/*
* Skip to write part
*/
type = s + 1;
}
}
}
}
return type;
}
static PerlIO_funcs *
{
/*
* For any scalar type load the handler which is bundled with perl
*/
/*
* For other types allow if layer is known but don't try and load it
*/
case SVt_PVAV:
case SVt_PVHV:
case SVt_PVCV:
case SVt_PVGV:
}
return NULL;
}
{
if (!PL_perlio)
if (narg) {
/*
* If it is a reference but not an object see if we have a handler
* for it
*/
if (handler) {
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)
if (incdef) {
}
}
else {
}
return av;
}
else {
return (PerlIO_list_t *) NULL;
}
}
else {
if (incdef)
return def;
}
}
PerlIO *
{
if ((f = PerlIO_tmpfile())) {
if (!layers)
}
}
else {
IV n;
if (PerlIOValid(f)) {
/*
* This is "reopen" - it is not tested as perl does not use it
* yet
*/
PerlIOl *l = *f;
while (l) {
: &PL_sv_undef;
l = *PerlIONext(&l);
}
}
else {
if (!layera) {
return NULL;
}
}
/*
* Start at "top" of layer stack
*/
while (n >= 0) {
if (t && t->Open) {
tab = t;
break;
}
n--;
}
if (tab) {
/*
* Found that layer 'n' can do opens - call it
*/
}
PerlIO_debug("openn(%s,'%s','%s',%d,%x,%o,%p,%d,%p)\n",
else {
f = NULL;
}
if (f) {
/*
* More layers above the one that we used to open -
* apply them now
*/
/* If pushing layers fails close the file */
PerlIO_close(f);
f = NULL;
}
}
}
}
}
return f;
}
{
}
{
}
{
}
int
{
}
{
}
int
{
if (f) {
if (*f) {
else
return 0; /* If no Flush defined, silently succeed. */
}
else {
PerlIO_debug("Cannot flush f=%p\n", (void*)f);
return -1;
}
}
else {
/*
* Is it good API design to do flush-all on NULL, a potentially
* errorneous input? Maybe some magical value (PerlIO*
* PERLIO_FLUSH_ALL = (PerlIO*)-1;)? Yes, stdio does similar
* things on fflush(NULL), but should we be bound by their design
* decisions? --jhi
*/
int code = 0;
while ((f = *table)) {
int i;
for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
if (*f && PerlIO_flush(f) != 0)
code = -1;
f++;
}
}
return code;
}
}
void
{
PerlIO *f;
while ((f = *table)) {
int i;
for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
if (*f
&& (PerlIOBase(f)->
== (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE))
PerlIO_flush(f);
f++;
}
}
}
int
{
}
int
{
if (PerlIOValid(f))
else
return -1;
}
int
{
}
int
{
}
void
{
}
void
{
}
int
{
if (PerlIOValid(f)) {
if (tab)
}
else
return 0;
}
int
{
if (tab)
}
else
return 0;
}
int
{
if (PerlIOValid(f)) {
if (tab)
}
else
return 0;
}
int
{
if (PerlIOValid(f)) {
if (tab)
}
else
return 0;
}
STDCHAR *
{
}
int
{
}
STDCHAR *
{
}
int
{
}
void
{
}
void
{
}
/*--------------------------------------------------------------------------------------*/
/*
* utf8 and raw dummy layers
*/
{
if (PerlIOValid(f)) {
else
return 0;
}
return -1;
}
sizeof(PerlIO_funcs),
"utf8",
0,
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 */
};
sizeof(PerlIO_funcs),
"bytes",
0,
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 *
{
return NULL;
}
sizeof(PerlIO_funcs),
"raw",
0,
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"
*/
{
}
char *
{
char *s = buf;
if (PerlIOValid(f)) {
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;
}
{
PerlIOl *l = PerlIOBase(f);
#if 0
char temp[8];
#endif
l->flags |= PERLIO_F_FASTGETS;
if (mode) {
mode++;
switch (*mode++) {
case 'r':
l->flags |= PERLIO_F_CANREAD;
break;
case 'a':
break;
case 'w':
break;
default:
return -1;
}
while (*mode) {
switch (*mode++) {
case '+':
break;
case 'b':
l->flags &= ~PERLIO_F_CRLF;
break;
case 't':
l->flags |= PERLIO_F_CRLF;
break;
default:
return -1;
}
}
}
else {
if (l->next) {
}
}
#if 0
#endif
return 0;
}
{
return 0;
}
{
/*
* Save the position as current head considers it
*/
return done;
}
{
if (f) {
return 0;
}
while (count > 0) {
if (avail > 0)
if (take > 0) {
}
if (PerlIO_fill(f) != 0)
break;
}
}
}
return 0;
}
{
return 0;
}
{
return -1;
}
{
if (PerlIOValid(f)) {
PerlIO *n = PerlIONext(f);
code = PerlIO_flush(f);
PerlIOBase(f)->flags &=
while (PerlIOValid(n)) {
code = -1;
break;
}
else {
PerlIOBase(n)->flags &=
}
n = PerlIONext(n);
}
}
else {
}
return code;
}
{
if (PerlIOValid(f)) {
}
return 1;
}
{
if (PerlIOValid(f)) {
}
return 1;
}
void
{
if (PerlIOValid(f)) {
PerlIO *n = PerlIONext(f);
if (PerlIOValid(n))
PerlIO_clearerr(n);
}
}
void
{
if (PerlIOValid(f)) {
}
}
SV *
{
if (!arg)
return Nullsv;
#ifdef sv_dup
if (param) {
}
else {
}
#else
#endif
}
PerlIO *
{
if (PerlIOValid(nexto)) {
else
}
if (f) {
PerlIO_debug("PerlIOBase_dup %s f=%p o=%p param=%p\n",
else {
}
if (arg) {
}
}
return f;
}
#ifdef USE_THREADS
#endif
void
{
/* Place holder for stdstreams call ??? */
#ifdef USE_THREADS
#endif
}
void
{
#ifdef USE_THREADS
#endif
PerlIO_fd_refcnt[fd]++;
#ifdef USE_THREADS
#endif
}
}
int
{
int cnt = 0;
#ifdef USE_THREADS
#endif
#ifdef USE_THREADS
#endif
}
return cnt;
}
void
{
int i;
#ifdef USE_ITHREADS
#else
PerlIO_debug("Cleanup layers\n");
#endif
/* Raise STDIN..STDERR refcount so we don't close them */
for (i=0; i < 3; i++)
/* Restore STDIN..STDERR refcount */
for (i=0; i < 3; i++)
if (PL_known_layers) {
}
if(PL_def_layerlist) {
}
}
/*--------------------------------------------------------------------------------------*/
/*
* Bottom-most level for UNIX-like case
*/
typedef struct {
} PerlIOUnix;
int
{
mode++;
switch (*mode) {
case 'r':
if (*++mode == '+') {
mode++;
}
break;
case 'w':
if (*++mode == '+') {
mode++;
}
else
break;
case 'a':
if (*++mode == '+') {
mode++;
}
else
break;
}
if (*mode == 'b') {
mode++;
}
else if (*mode == 't') {
mode++;
}
/*
* Always open in binary mode
*/
oflags = -1;
}
return oflags;
}
{
}
static void
{
#if defined(WIN32)
}
else {
}
}
#endif
}
{
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?
*/
}
return code;
}
{
#ifdef ESPIPE
#else
#endif
return -1;
}
{
return -1;
}
return 0;
}
PerlIO *
{
if (PerlIOValid(f)) {
}
if (narg > 0) {
if (*mode == IoTYPE_NUMERIC)
mode++;
else {
perm = 0666;
}
if (imode != -1) {
}
}
if (fd >= 0) {
if (*mode == IoTYPE_IMPLICIT)
mode++;
if (!f) {
f = PerlIO_allocate(aTHX);
}
if (!PerlIOValid(f)) {
return NULL;
}
}
if (*mode == IoTYPE_APPEND)
return f;
}
else {
if (f) {
/*
* FIXME: pop layers ???
*/
}
return NULL;
}
}
PerlIO *
{
if (flags & PERLIO_DUP_FD) {
}
if (f) {
/* If all went well overwrite fd in dup'ed lay with the dup()'ed fd */
return f;
}
}
return NULL;
}
{
return 0;
}
while (1) {
if (len < 0) {
}
}
SETERRNO(0,0);
}
return len;
}
}
}
{
while (1) {
if (len < 0) {
}
}
return len;
}
}
}
{
}
{
int code = 0;
if (PerlIOUnix_refcnt_dec(fd) > 0) {
return 0;
}
}
else {
return -1;
}
while (PerlLIO_close(fd) != 0) {
code = -1;
break;
}
}
if (code == 0) {
}
return code;
}
sizeof(PerlIO_funcs),
"unix",
sizeof(PerlIOUnix),
PerlIOBase_binmode, /* binmode */
NULL,
PerlIOBase_noop_ok, /* flush */
PerlIOBase_noop_fail, /* fill */
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 {
} PerlIOStdio;
{
FILE *s;
return PerlSIO_fileno(s);
}
return -1;
}
char *
{
if (mode) {
while (*mode) {
}
}
#if defined(PERLIO_USING_CRLF) || defined(__CYGWIN__)
*tmode++ = 'b';
#endif
*tmode = '\0';
return ret;
}
{
PerlIO *n;
/* Top is already stdio - pop self (duplicate) and use original */
PerlIO_pop(aTHX_ f);
return 0;
} else {
/* We never call down so do any pending stuff now */
PerlIO_flush(PerlIONext(f));
}
else {
return -1;
}
}
}
}
PerlIO *
{
dTHX;
if (stdio) {
PerlIOStdio *s;
/* We need to probe to see how we can open the stream
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.
*/
if (!f2) {
}
if (!f2) {
}
if (!f2) {
/* Don't seem to be able to open */
return f;
}
}
s = PerlIOSelf(f, PerlIOStdio);
}
}
return f;
}
PerlIO *
{
if (PerlIOValid(f)) {
s->stdio);
if (!s->stdio)
return NULL;
return f;
}
else {
if (narg > 0) {
if (*mode == IoTYPE_NUMERIC) {
mode++;
}
else {
#ifdef __CYGWIN__
/* Cygwin wants its 'b' early. */
#endif
if (stdio) {
PerlIOStdio *s;
if (!f) {
f = PerlIO_allocate(aTHX);
}
if (!appended)
if (f) {
s = PerlIOSelf(f, PerlIOStdio);
}
return f;
}
else {
return NULL;
}
}
}
if (fd >= 0) {
int init = 0;
if (*mode == IoTYPE_IMPLICIT) {
init = 1;
mode++;
}
if (init) {
switch (fd) {
case 0:
break;
case 1:
break;
case 2:
break;
}
}
else {
}
if (stdio) {
PerlIOStdio *s;
if (!f) {
f = PerlIO_allocate(aTHX);
}
s = PerlIOSelf(f, PerlIOStdio);
}
return f;
}
}
}
return NULL;
}
PerlIO *
{
/* This assumes no layers underneath - which is what
happens, but is not how I remember it. NI-S 2001/10/16
*/
if (flags & PERLIO_DUP_FD) {
if (dfd >= 0) {
goto set_this;
}
else {
/* FIXME: To avoid messy error recovery if dup fails
re-use the existing stdio as though flag was not set
*/
}
}
}
return f;
}
static int
{
/* XXX this could use PerlIO_canset_fileno() and
* PerlIO_set_fileno() support from Configure
*/
# if 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;
return 0;
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.]
*/
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;
/* 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;
# if defined(__BORLANDC__)
/* 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
(which isn't thread safe) instead
*/
# error "Don't know how to set FILE.fileno on your platform"
#endif
return 0;
# endif
}
{
if (!stdio) {
return -1;
}
else {
int socksfd = 0;
int invalidate = 0;
int saveerr = 0;
int dupfd = 0;
#ifdef SOCKS5_VERSION_NAME
/* Socks lib overrides close() but stdio isn't linked to
that library (though we are) - so we must call close()
on sockets on stdio's behalf.
*/
int optval;
socksfd = 1;
invalidate = 1;
}
#endif
if (PerlIOUnix_refcnt_dec(fd) > 0) {
/* File descriptor still in use */
invalidate = 1;
socksfd = 0;
}
if (invalidate) {
/* For STD* handles don't close the stdio at all
this is because we have shared the FILE * too
*/
/* Some stdios are buggy fflush-ing inputs */
return 0;
}
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);
}
}
/* We treat error from stdio as success if we invalidated
errno may NOT be expected EBADF
*/
if (invalidate && result != 0) {
result = 0;
}
if (socksfd) {
/* in SOCKS case let close() determine return value */
}
if (dupfd) {
}
return result;
}
}
{
for (;;) {
if (count == 1) {
/*
* Perl is expecting PerlIO_getc() to fill the buffer Linux's
* stdio does not do that for fread()
*/
got = 1;
}
}
else
if (got == 0 && PerlSIO_ferror(s))
got = -1;
break;
SETERRNO(0,0); /* just in case */
}
return got;
}
{
#ifdef STDIO_BUFFER_WRITABLE
if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
if (avail > 0) {
}
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
*/
while (count > 0) {
/* ungetc did not work */
break;
}
/* Did not change pointer as expected */
fgetc(s); /* get char back again */
break;
}
/* It worked ! */
count--;
unread++;
}
}
if (count > 0) {
}
return unread;
}
{
for (;;) {
break;
SETERRNO(0,0); /* just in case */
}
return got;
}
{
}
{
return PerlSIO_ftell(stdio);
}
{
return PerlSIO_fflush(stdio);
}
else {
#if 0
/*
* FIXME: This discards ungetc() and pre-read stuff which is not
* right if this is just a "sync" from a layer above Suspect right
* design is to do _this_ but not have layer above flush this
* layer read-to-read
*/
/*
* Not writeable - sync by attempting a seek
*/
#endif
}
return 0;
}
{
}
{
}
void
{
}
void
{
#ifdef HAS_SETLINEBUF
#else
#endif
}
#ifdef FILE_base
STDCHAR *
{
}
{
return PerlSIO_get_bufsiz(stdio);
}
#endif
#ifdef USE_STDIO_PTR
STDCHAR *
{
}
{
return PerlSIO_get_cnt(stdio);
}
void
{
#ifdef STDIO_PTR_LVALUE
#ifdef STDIO_PTR_LVAL_SETS_CNT
}
#endif
#if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
/*
* Setting ptr _does_ change cnt - we are done
*/
return;
#endif
#else /* STDIO_PTR_LVALUE */
#endif /* STDIO_PTR_LVALUE */
}
/*
* Now (or only) set cnt
*/
#ifdef STDIO_CNT_LVALUE
#else /* STDIO_CNT_LVALUE */
#if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
cnt));
#else /* STDIO_PTR_LVAL_SETS_CNT */
#endif /* STDIO_PTR_LVAL_SETS_CNT */
#endif /* STDIO_CNT_LVALUE */
}
#endif
{
int c;
/*
* fflush()ing read-only streams can cause trouble on some stdio-s
*/
if (PerlSIO_fflush(stdio) != 0)
return EOF;
}
c = PerlSIO_fgetc(stdio);
if (c == EOF)
return EOF;
#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
*/
if (PerlSIO_feof(stdio))
return 0;
}
}
else
#endif
if (PerlIO_has_cntptr(f)) {
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
*/
#else
/* If buffer snoop scheme above fails fall back to
using ungetc().
*/
if (PerlSIO_ungetc(c, stdio) != c)
return EOF;
#endif
return 0;
}
sizeof(PerlIO_funcs),
"stdio",
sizeof(PerlIOStdio),
PerlIOBase_binmode, /* binmode */
NULL,
#ifdef FILE_base
#else
NULL,
NULL,
#endif
#ifdef USE_STDIO_PTR
# if defined(HAS_FAST_STDIO) && defined(USE_FAST_STDIO)
# 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 *
{
dTHX;
if (PerlIOValid(f)) {
PerlIO_flush(f);
}
if (stdio) {
PerlIOl *l = *f;
/* De-link any lower layers so new :stdio sticks */
*f = NULL;
/* Link previous lower layers under new one */
*PerlIONext(f) = l;
}
else {
/* restore layers list */
*f = l;
}
}
}
return stdio;
}
FILE *
{
PerlIOl *l = *f;
while (l) {
if (l->tab == &PerlIO_stdio) {
return s->stdio;
}
l = *PerlIONext(&l);
}
/* Uses fallback "mode" via PerlIO_modestr() in PerlIO_exportFILE */
return PerlIO_exportFILE(f, Nullch);
}
/* Use this to reverse PerlIO_exportFILE calls. */
void
{
PerlIOl *l;
while ((l = *p)) {
if (l->tab == &PerlIO_stdio) {
if (s->stdio == f) {
dTHX;
PerlIO_pop(aTHX_ p);
return;
}
}
p = PerlIONext(p);
}
return;
}
/*--------------------------------------------------------------------------------------*/
/*
* perlio buffer layer
*/
{
}
if (*PerlIONext(f)) {
}
}
}
PerlIO *
{
if (PerlIOValid(f)) {
next =
return NULL;
}
}
else {
int init = 0;
if (*mode == IoTYPE_IMPLICIT) {
init = 1;
/*
* mode++;
*/
}
else
if (f) {
/*
* if push fails during open, open fails. close will pop us.
*/
PerlIO_close (f);
return NULL;
} else {
fd = PerlIO_fileno(f);
/*
* Initial stderr is unbuffered
*/
}
#ifdef PERLIO_USING_CRLF
# ifdef PERLIO_IS_BINMODE_FD
if (PERLIO_IS_BINMODE_FD(fd))
else
# endif
/*
* do something about failing setmode()? --jhi
*/
#endif
}
}
}
return f;
}
/*
* This "flush" is akin to sfio's sync in that it handles files in either
* read or write state
*/
{
int code = 0;
PerlIO *n = PerlIONext(f);
/*
* write() the buffer
*/
while (p < b->ptr) {
if (count > 0) {
p += count;
}
else if (count < 0 || PerlIO_error(n)) {
code = -1;
break;
}
}
}
/*
* Note position change
*/
/* We did not consume all of it - try and seek downstream to
our logical position
*/
/* Reload n as some layers may pop themselves on seek */
}
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
*/
return code;
}
}
}
/* 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;
}
{
PerlIO *n = PerlIONext(f);
/*
* 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)
return -1;
if (!b->buf)
PerlIO_get_base(f); /* allocate via vtable */
if (!PerlIOValid(n)) {
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) {
}
}
else {
}
if (avail <= 0) {
if (avail == 0)
else
return -1;
}
return 0;
}
{
if (PerlIOValid(f)) {
if (!b->ptr)
PerlIO_get_base(f);
}
return 0;
}
{
PerlIO_flush(f);
if (!b->buf)
PerlIO_get_base(f);
if (b->buf) {
/*
* Buffer is already a read buffer, we can overwrite any chars
* which have been read back to buffer start
*/
}
else {
/*
* Buffer is idle, set it up so whole buffer is available for
* unread
*/
/*
* Buffer extends _back_ from where we are now
*/
}
/*
* If we have space for more than count, just move count
*/
}
if (avail > 0) {
/*
* In simple stdio-like ungetc() case chars will be already
* there
*/
}
}
}
if (count > 0) {
}
return unread;
}
{
if (!b->buf)
PerlIO_get_base(f);
return 0;
if (PerlIO_flush(f) != 0) {
return 0;
}
}
--flushptr;
}
while (count > 0) {
if (avail) {
PerlIO_flush(f);
}
PerlIO_flush(f);
}
PerlIO_flush(f);
return written;
}
{
if ((code = PerlIO_flush(f)) == 0) {
if (code == 0) {
}
}
return code;
}
{
/*
* b->posn is file position where b->buf was read, or will be written
*/
#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 */
#endif
}
if (b->buf) {
/*
* If buffer is valid adjust position by amount in buffer
*/
}
return posn;
}
{
}
return code;
}
{
}
return code;
}
STDCHAR *
{
if (!b->buf)
PerlIO_get_base(f);
return b->ptr;
}
{
if (!b->buf)
PerlIO_get_base(f);
return 0;
}
STDCHAR *
{
if (!b->buf) {
if (!b->bufsiz)
b->bufsiz = 4096;
b->buf =
if (!b->buf) {
}
}
return b->buf;
}
{
if (!b->buf)
PerlIO_get_base(f);
}
void
{
if (!b->buf)
PerlIO_get_base(f);
}
}
PerlIO *
{
}
sizeof(PerlIO_funcs),
"perlio",
sizeof(PerlIOBuf),
PerlIOBase_binmode, /* binmode */
NULL,
};
/*--------------------------------------------------------------------------------------*/
/*
* Temp layer to hold unread chars when cannot do it any other way
*/
{
/*
* Should never happen
*/
PerlIO_flush(f);
return 0;
}
{
/*
* A tad tricky - flush pops us, then we close new top
*/
PerlIO_flush(f);
return PerlIO_close(f);
}
{
/*
* A tad tricky - flush pops us, then we seek new top
*/
PerlIO_flush(f);
}
{
}
PerlIO_pop(aTHX_ f);
return 0;
}
void
{
if (cnt <= 0) {
PerlIO_flush(f);
}
else {
}
}
{
PerlIOl *l = PerlIOBase(f);
/*
* Our PerlIO_fast_gets must match what we are pushed on, or sv_gets()
* etc. get muddled when it changes mid-string when we auto-pop.
*/
(PerlIOBase(PerlIONext(f))->
return code;
}
{
if (avail > 0)
}
return got;
}
sizeof(PerlIO_funcs),
"pending",
sizeof(PerlIOBuf),
NULL,
PerlIOBase_binmode, /* binmode */
NULL,
};
/*--------------------------------------------------------------------------------------*/
/*
* crlf - translation On read translate CR,LF to "\n" we do this by
* record of which nl we "lied" about. On write translate "\n" to CR,LF
*/
typedef struct {
* buffer */
} PerlIOCrlf;
{
#if 0
PerlIOBase(f)->flags);
#endif
{
/* Enable the first CRLF capable layer you can find, but if none
* found, the one we just pushed is fine. This results in at
* any given moment at most one CRLF-capable layer being enabled
* in the whole layer stack. */
PerlIO *g = PerlIONext(f);
while (g && *g) {
PerlIOl *b = PerlIOBase(g);
if (b && b->tab == &PerlIO_crlf) {
if (!(b->flags & PERLIO_F_CRLF))
b->flags |= PERLIO_F_CRLF;
PerlIO_pop(aTHX_ f);
return code;
}
g = PerlIONext(g);
}
}
return code;
}
{
if (c->nl) {
*(c->nl) = 0xd;
}
else {
PerlIO_flush(f);
if (!b->buf)
PerlIO_get_base(f);
if (b->buf) {
}
if (ch == '\n') {
*--(b->ptr) = 0xa;
*--(b->ptr) = 0xd;
unread++;
count--;
}
else {
buf++;
break;
}
}
else {
unread++;
count--;
}
}
}
return unread;
}
}
{
if (!b->buf)
PerlIO_get_base(f);
scan:
nl++;
test:
*nl = '\n';
}
else {
/*
* Not CR,LF but just CR
*/
nl++;
goto scan;
}
}
else {
/*
* Blast - found CR as last char in buffer
*/
/*
* They may not care, defer work as long as
* possible
*/
}
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 */
b->bufsiz++; /* Restore size for next time */
b->buf--; /* Point at space */
* off */
if (code == 0)
goto test; /* fill() call worked */
/*
* CR at EOF - just fall through
*/
/* Should we clear EOF though ??? */
}
}
}
}
}
return 0;
}
void
{
if (!b->buf)
PerlIO_get_base(f);
if (!ptr) {
if (c->nl) {
/* Defered CR at end of buffer case - we lied about count */
ptr--;
}
}
else {
}
}
else {
#if 0
/*
* Test code - delete when it works ...
*/
/* Defered CR at end of buffer case - we lied about count */
chk--;
}
}
#endif
}
if (c->nl) {
/*
* They have taken what we lied about
*/
*(c->nl) = 0xd;
ptr++;
}
}
}
{
else {
if (!b->buf)
PerlIO_get_base(f);
return 0;
if (*buf == '\n') {
/*
* Not room for both
*/
PerlIO_flush(f);
break;
}
else {
buf++;
PerlIO_flush(f);
break;
}
}
}
else {
}
PerlIO_flush(f);
break;
}
}
}
PerlIO_flush(f);
}
}
{
if (c->nl) {
*(c->nl) = 0xd;
}
return PerlIOBuf_flush(aTHX_ f);
}
{
/* In text mode - flush any pending stuff and flip it */
#ifndef PERLIO_USING_CRLF
/* CRLF is unusual case - if this is just the :crlf layer pop it */
PerlIO_pop(aTHX_ f);
}
#endif
}
return 0;
}
sizeof(PerlIO_funcs),
"crlf",
sizeof(PerlIOCrlf),
PerlIOBuf_popped, /* popped */
PerlIOCrlf_binmode, /* binmode */
NULL,
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' */
};
#ifdef HAS_MMAP
/*--------------------------------------------------------------------------------------*/
/*
* mmap as "buffer" layer
*/
typedef struct {
} PerlIOMmap;
{
if (m->len)
abort();
if (flags & PERLIO_F_CANREAD) {
if (len > 0) {
if (!page_size) {
{
# ifdef _SC_PAGESIZE
# else
# endif
if ((long) page_size < 0) {
if (errno) {
char *msg;
msg);
}
else
"panic: sysconf: pagesize unknown");
}
}
#else
# ifdef HAS_GETPAGESIZE
page_size = getpagesize();
# else
# if defined(I_SYS_PARAM) && defined(PAGESIZE)
# endif
# endif
#endif
}
if (b->posn < 0) {
/*
* This is a hack - should never happen - open should
* have set it !
*/
}
#if 0 && defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
#endif
#if 0 && defined(HAS_MADVISE) && defined(MADV_WILLNEED)
#endif
PerlIOBase(f)->flags =
}
else {
}
}
else {
PerlIOBase(f)->flags =
code = -1;
}
}
}
return code;
}
{
if (m->len) {
if (b->buf) {
m->len = 0;
code = -1;
}
}
return code;
}
STDCHAR *
{
/*
* Already have a readbuffer in progress
*/
return b->buf;
}
if (b->buf) {
/*
* We have a write buffer or flushed PerlIOBuf read buffer
*/
}
if (!b->buf) {
if (!b->buf) {
/*
* Map did not work - recover PerlIOBuf buffer if we have one
*/
}
}
if (b->buf)
return b->buf;
return PerlIOBuf_get_base(aTHX_ f);
}
{
PerlIO_flush(f);
return count;
}
if (m->len) {
/*
* Loose the unwritable mapped buffer
*/
PerlIO_flush(f);
/*
* If flush took the "buffer" see if we have one from before
*/
if (!b->buf) {
}
}
}
{
/*
* No, or wrong sort of, buffer
*/
if (m->len) {
if (PerlIOMmap_unmap(aTHX_ f) != 0)
return 0;
}
/*
* If unmap took the "buffer" see if we have one from before
*/
if (!b->buf) {
}
}
}
{
/*
* Now we are "synced" at PerlIOBuf level
*/
if (b->buf) {
if (m->len) {
/*
* Unmap the buffer
*/
if (PerlIOMmap_unmap(aTHX_ f) != 0)
code = -1;
}
else {
/*
* We seem to have a PerlIOBuf buffer which was not mapped
* remember it in case we need one later
*/
}
}
return code;
}
{
}
}
return code;
}
{
if (m->bbuf) {
}
if (PerlIOBuf_close(aTHX_ f) != 0)
code = -1;
return code;
}
PerlIO *
{
}
sizeof(PerlIO_funcs),
"mmap",
sizeof(PerlIOMmap),
PerlIOBase_binmode, /* binmode */
NULL,
};
#endif /* HAS_MMAP */
PerlIO *
{
if (!PL_perlio) {
}
return &PL_perlio[1];
}
PerlIO *
{
if (!PL_perlio) {
}
return &PL_perlio[2];
}
PerlIO *
{
if (!PL_perlio) {
}
return &PL_perlio[3];
}
/*--------------------------------------------------------------------------------------*/
char *
{
dTHX;
#ifdef VMS
if (!stdio) {
stdio = PerlIO_exportFILE(f,0);
}
if (stdio) {
}
#else
#endif
return name;
}
/*--------------------------------------------------------------------------------------*/
/*
* Functions which can be called on any kind of PerlIO implemented in
* terms of above
*/
PerlIO *
{
dTHX;
}
PerlIO *
{
dTHX;
}
PerlIO *
{
dTHX;
}
int
{
dTHX;
if (count == 1) {
return (unsigned char) buf[0];
}
return EOF;
}
int
{
dTHX;
return ch;
}
return EOF;
}
int
{
dTHX;
}
int
{
dTHX;
return PerlIO_write(f, s, len);
}
void
{
dTHX;
PerlIO_clearerr(f);
}
int
{
dTHX;
char *s;
#ifdef NEED_VA_COPY
#else
#endif
return wrote;
}
int
{
int result;
return result;
}
int
{
dTHX;
int result;
return result;
}
PerlIO *
PerlIO_tmpfile(void)
{
dTHX;
#ifdef WIN32
fd = win32_tmpfd();
if (fd >= 0)
#else /* WIN32 */
/*
* I have no idea how portable mkstemp() is ... NI-S
*/
if (fd >= 0) {
if (f)
}
# else /* !HAS_MKSTEMP, fallback to stdio tmpfile(). */
if (stdio) {
if (s)
}
}
# endif /* else HAS_MKSTEMP */
#endif /* else WIN32 */
return f;
}
#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
*/
#ifndef HAS_FSETPOS
int
{
dTHX;
}
return -1;
}
#else
int
{
dTHX;
#if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
#else
#endif
}
}
return -1;
}
#endif
#ifndef HAS_FGETPOS
int
{
dTHX;
}
#else
int
{
dTHX;
int code;
#if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
#else
#endif
return code;
}
#endif
int
{
return 0; /* wrong, but perl doesn't use the return
* value */
}
int
{
return 0; /* wrong, but perl doesn't use the return
* value */
}
#endif
#ifndef PerlIO_vsprintf
int
{
if (n >= 0) {
dTHX;
(void) PerlIO_puts(Perl_error_log,
"panic: sprintf overflow - memory corrupted!\n");
my_exit(1);
}
}
return val;
}
#endif
#ifndef PerlIO_sprintf
int
{
int result;
return result;
}
#endif