/*
- * perlio.c Copyright (c) 1996-2006, Nick Ing-Simmons You may distribute
- * under the terms of either the GNU General Public License or the
- * Artistic License, as specified in the README file.
+ * perlio.c
+ * Copyright (c) 1996-2006, Nick Ing-Simmons
+ * Copyright (c) 2006, 2007, 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.
*/
/*
*/
#ifdef DOSISH
# if defined(atarist) || defined(__MINT__)
+ PERL_UNUSED_ARG(iotype);
if (!fflush(fp)) {
if (mode & O_BINARY)
((FILE *) fp)->_flag |= _IOBIN;
return 0;
# else
dTHX;
+ PERL_UNUSED_ARG(iotype);
#ifdef NETWARE
if (PerlLIO_setmode(fp, mode) != -1) {
#else
#else
# if defined(USEMYBINMODE)
dTHX;
+# if defined(__CYGWIN__)
+ PERL_UNUSED_ARG(iotype);
+# endif
if (my_binmode(fp, iotype, mode) != FALSE)
return 1;
else
#else
const char *s = CopFILE(PL_curcop);
STRLEN len;
- SV * const sv = newSVpvs("");
- Perl_sv_catpvf(aTHX_ sv, "%s:%" IVdf " ", s ? s : "(none)",
- (IV) CopLINE(PL_curcop));
+ SV * const sv = Perl_newSVpvf(aTHX_ "%s:%" IVdf " ", s ? s : "(none)",
+ (IV) CopLINE(PL_curcop));
Perl_sv_vcatpvf(aTHX_ sv, fmt, &ap);
s = SvPV_const(sv, len);
int i;
list = PerlIO_list_alloc(aTHX);
for (i=0; i < proto->cur; i++) {
- SV *arg = NULL;
- if (proto->array[i].arg)
- arg = PerlIO_sv_dup(aTHX_ proto->array[i].arg,param);
+ SV *arg = proto->array[i].arg;
+#ifdef sv_dup
+ if (arg && param)
+ arg = sv_dup(arg, param);
+#else
+ PERL_UNUSED_ARG(param);
+#endif
PerlIO_list_push(aTHX_ list, proto->array[i].funcs, arg);
}
}
} else {
SV * const pkgsv = newSVpvs("PerlIO");
SV * const layer = newSVpvn(name, len);
- CV * const cv = get_cv("PerlIO::Layer::NoWarnings", FALSE);
+ CV * const cv = Perl_get_cvn_flags(aTHX_ STR_WITH_LEN("PerlIO::Layer::NoWarnings"), 0);
ENTER;
SAVEINT(PL_in_load_module);
if (cv) {
SV *
PerlIO_tab_sv(pTHX_ PerlIO_funcs *tab)
{
- HV * const stash = gv_stashpvs("PerlIO::Layer", TRUE);
+ HV * const stash = gv_stashpvs("PerlIO::Layer", GV_ADD);
SV * const sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))), stash);
return sv;
}
*/
dVAR;
dXSARGS;
+ PERL_UNUSED_ARG(cv);
if (items)
PerlIO_debug("warning:%s\n",SvPV_nolen_const(ST(0)));
XSRETURN(0);
{
dVAR;
dXSARGS;
+ PERL_UNUSED_ARG(cv);
if (items < 2)
Perl_croak(aTHX_ "Usage class->find(name[,load])");
else {
PerlIO_funcs * const layer =
PerlIO_find_layer(aTHX_ s, llen, 1);
if (layer) {
+ SV *arg = NULL;
+ if (as)
+ arg = newSVpvn(as, alen);
PerlIO_list_push(aTHX_ av, layer,
- (as) ? newSVpvn(as,
- alen) :
- &PL_sv_undef);
+ (arg) ? arg : &PL_sv_undef);
+ if (arg)
+ SvREFCNT_dec(arg);
}
else {
if (ckWARN(WARN_LAYER))
if (layers && *layers) {
PerlIO_list_t *av;
if (incdef) {
- IV i;
- av = PerlIO_list_alloc(aTHX);
- for (i = 0; i < def->cur; i++) {
- PerlIO_list_push(aTHX_ av, def->array[i].funcs,
- def->array[i].arg);
- }
+ av = PerlIO_clone_list(aTHX_ def, NULL);
}
else {
av = def;
PerlIOl *l = *f;
layera = PerlIO_list_alloc(aTHX);
while (l) {
- SV * const arg = (l->tab->Getarg)
- ? (*l->tab->Getarg) (aTHX_ &l, NULL, 0)
- : &PL_sv_undef;
- PerlIO_list_push(aTHX_ layera, l->tab, arg);
+ SV *arg = NULL;
+ if (l->tab->Getarg)
+ arg = (*l->tab->Getarg) (aTHX_ &l, NULL, 0);
+ PerlIO_list_push(aTHX_ layera, l->tab,
+ (arg) ? arg : &PL_sv_undef);
+ if (arg)
+ SvREFCNT_dec(arg);
l = *PerlIONext(&l);
}
}
return NULL;
#ifdef sv_dup
if (param) {
- return sv_dup(arg, param);
+ arg = sv_dup(arg, param);
+ SvREFCNT_inc_simple_void_NN(arg);
+ return arg;
}
else {
return newSVsv(arg);
}
if (f) {
PerlIO_funcs * const self = PerlIOBase(o)->tab;
- SV *arg;
+ SV *arg = NULL;
char buf[8];
PerlIO_debug("PerlIOBase_dup %s f=%p o=%p param=%p\n",
self->name, (void*)f, (void*)o, (void*)param);
if (self->Getarg)
arg = (*self->Getarg)(aTHX_ o, param, flags);
- else {
- arg = NULL;
- }
f = PerlIO_push(aTHX_ f, self, PerlIO_modestr(o,buf), arg);
- if (arg) {
+ if (PerlIOBase(o)->flags & PERLIO_F_UTF8)
+ PerlIOBase(f)->flags |= PERLIO_F_UTF8;
+ if (arg)
SvREFCNT_dec(arg);
- }
}
return f;
}
}
}
-void PerlIO_teardown(pTHX) /* Call only from PERL_SYS_TERM(). */
+void PerlIO_teardown() /* Call only from PERL_SYS_TERM(). */
{
dVAR;
+#if 0
+/* XXX we can't rely on an interpreter being present at this late stage,
+ XXX so we can't use a function like PerlLIO_write that relies on one
+ being present (at least in win32) :-(.
+ Disable for now.
+*/
#ifdef DEBUGGING
{
/* By now all filehandles should have been closed, so any
* stray (non-STD-)filehandles indicate *possible* (PerlIO)
* errors. */
+#define PERLIO_TEARDOWN_MESSAGE_BUF_SIZE 64
+#define PERLIO_TEARDOWN_MESSAGE_FD 2
+ char buf[PERLIO_TEARDOWN_MESSAGE_BUF_SIZE];
int i;
for (i = 3; i < PL_perlio_fd_refcnt_size; i++) {
- if (PL_perlio_fd_refcnt[i])
- PerlIO_debug("PerlIO_cleanup: fd %d refcnt=%d\n",
- i, PL_perlio_fd_refcnt[i]);
+ if (PL_perlio_fd_refcnt[i]) {
+ const STRLEN len =
+ my_snprintf(buf, sizeof(buf),
+ "PerlIO_teardown: fd %d refcnt=%d\n",
+ i, PL_perlio_fd_refcnt[i]);
+ PerlLIO_write(PERLIO_TEARDOWN_MESSAGE_FD, buf, len);
+ }
}
}
#endif
+#endif
/* Not bothering with PL_perlio_mutex since by now
* all the interpreters are gone. */
if (PL_perlio_fd_refcnt_size /* Assuming initial size of zero. */
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;
if (PerlSIO_fflush(stdio) != 0)
return EOF;
}
- c = PerlSIO_fgetc(stdio);
- if (c == EOF)
- return EOF;
+ for (;;) {
+ c = PerlSIO_fgetc(stdio);
+ if (c != EOF)
+ break;
+ if (! PerlSIO_ferror(stdio) || errno != EINTR)
+ return EOF;
+ PERL_ASYNC_CHECK();
+ SETERRNO(0,0);
+ }
#if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
if ((f2 = PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_stdio), buf, NULL))) {
PerlIOStdio *s = PerlIOSelf((f = f2), PerlIOStdio);
s->stdio = stdio;
+ PerlIOUnix_refcnt_inc(fileno(stdio));
/* Link previous lower layers under new one */
*PerlIONext(f) = l;
}
PerlIO_findFILE(PerlIO *f)
{
PerlIOl *l = *f;
+ FILE *stdio;
while (l) {
if (l->tab == &PerlIO_stdio) {
PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
l = *PerlIONext(&l);
}
/* Uses fallback "mode" via PerlIO_modestr() in PerlIO_exportFILE */
- return PerlIO_exportFILE(f, NULL);
+ /* However, we're not really exporting a FILE * to someone else (who
+ becomes responsible for closing it, or calling PerlIO_releaseFILE())
+ So we need to undo its refernce count increase on the underlying file
+ descriptor. We have to do this, because if the loop above returns you
+ the FILE *, then *it* didn't increase any reference count. So there's
+ only one way to be consistent. */
+ stdio = PerlIO_exportFILE(f, NULL);
+ if (stdio) {
+ const int fd = fileno(stdio);
+ if (fd >= 0)
+ PerlIOUnix_refcnt_dec(fd);
+ }
+ return stdio;
}
/* Use this to reverse PerlIO_exportFILE calls. */
PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
if (s->stdio == f) {
dTHX;
+ const int fd = fileno(f);
+ if (fd >= 0)
+ PerlIOUnix_refcnt_dec(fd);
PerlIO_pop(aTHX_ p);
return;
}
PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
{
dTHX;
- SV * const sv = newSVpvs("");
+ SV * sv;
const char *s;
STRLEN len;
SSize_t wrote;
#ifdef NEED_VA_COPY
va_list apc;
Perl_va_copy(ap, apc);
- sv_vcatpvf(sv, fmt, &apc);
+ sv = vnewSVpvf(fmt, &apc);
#else
- sv_vcatpvf(sv, fmt, &ap);
+ sv = vnewSVpvf(fmt, &ap);
#endif
s = SvPV_const(sv, len);
wrote = PerlIO_write(f, s, len);
if (f)
PerlIOBase(f)->flags |= PERLIO_F_TEMP;
PerlLIO_unlink(SvPVX_const(sv));
- SvREFCNT_dec(sv);
}
+ SvREFCNT_dec(sv);
# else /* !HAS_MKSTEMP, fallback to stdio tmpfile(). */
FILE * const stdio = PerlSIO_tmpfile();
Perl_PerlIO_context_layers(pTHX_ const char *mode)
{
dVAR;
- const char *type = NULL;
+ const char *direction = NULL;
+ SV *layers;
/*
* Need to supply default layer info from open.pm
*/
- if (PL_curcop && PL_curcop->cop_hints & HINT_LEXICAL_IO) {
- SV * const layers
- = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash, 0,
- "open", 4, 0, 0);
- assert(layers);
- if (SvOK(layers)) {
- STRLEN len;
- type = SvPV_const(layers, len);
- if (type && mode && mode[0] != 'r') {
- /*
- * Skip to write part, which is separated by a '\0'
- */
- STRLEN read_len = strlen(type);
- if (read_len < len) {
- type += read_len + 1;
- }
- }
- }
+
+ if (!PL_curcop)
+ return NULL;
+
+ if (mode && mode[0] != 'r') {
+ if (PL_curcop->cop_hints & HINT_LEXICAL_IO_OUT)
+ direction = "open>";
+ } else {
+ if (PL_curcop->cop_hints & HINT_LEXICAL_IO_IN)
+ direction = "open<";
}
- return type;
+ if (!direction)
+ return NULL;
+
+ layers = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash,
+ 0, direction, 5, 0, 0);
+
+ assert(layers);
+ return SvOK(layers) ? SvPV_nolen_const(layers) : NULL;
}
https://perl5.git.perl.org / perl5.git / blobdiff