/*
- * 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.
*/
/*
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) {
IO * const io = GvIOn((GV *) SvRV(sv));
PerlIO * const ifp = IoIFP(io);
PerlIO * const ofp = IoOFP(io);
- Perl_warn(aTHX_ "set %" SVf " %p %p %p", sv, io, ifp, ofp);
+ Perl_warn(aTHX_ "set %" SVf " %p %p %p",
+ SVfARG(sv), (void*)io, (void*)ifp, (void*)ofp);
}
return 0;
}
IO * const io = GvIOn((GV *) SvRV(sv));
PerlIO * const ifp = IoIFP(io);
PerlIO * const ofp = IoOFP(io);
- Perl_warn(aTHX_ "get %" SVf " %p %p %p", sv, io, ifp, ofp);
+ 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, sv);
+ Perl_warn(aTHX_ "clear %" SVf, SVfARG(sv));
return 0;
}
static int
perlio_mg_free(pTHX_ SV *sv, MAGIC *mg)
{
- Perl_warn(aTHX_ "free %" SVf, sv);
+ Perl_warn(aTHX_ "free %" SVf, SVfARG(sv));
return 0;
}
mg = mg_find(sv, PERL_MAGIC_ext);
mg->mg_virtual = &perlio_vtab;
mg_magical(sv);
- Perl_warn(aTHX_ "attrib %" SVf, 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 *
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;
}
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);
}
}
}
#if 0
PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08" UVxf " (%s)\n",
- f, PerlIOBase(f)->tab->name, (omode) ? omode : "(Null)",
+ (void*)f, PerlIOBase(f)->tab->name, (omode) ? omode : "(Null)",
l->flags, PerlIO_modestr(f, temp));
#endif
return 0;
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 (arg)
SvREFCNT_dec(arg);
- }
}
return f;
}
assert (new_max > new_fd);
- new_array =
- (int*) PerlMemShared_realloc(PL_perlio_fd_refcnt, new_max * sizeof(int));
+ /* 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
void PerlIO_teardown(pTHX) /* Call only from PERL_SYS_TERM(). */
{
+ dVAR;
#ifdef DEBUGGING
{
/* By now all filehandles should have been closed, so any
}
}
#endif
-#ifdef USE_ITHREADS
- MUTEX_LOCK(&PL_perlio_mutex);
-#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) {
-#ifdef PERL_TRACK_MEMPOOL
- Malloc_t ptr = (Malloc_t)((char*)PL_perlio_fd_refcnt-sTHX);
- struct perl_memory_debug_header *const header
- = (struct perl_memory_debug_header *)ptr;
- /* Only the thread that allocated us can free us. */
- if (header->interpreter == aTHX)
-#endif
- {
- PerlMemShared_free(PL_perlio_fd_refcnt); /* Not Safefree() because was allocated with PerlMemShared_realloc(). */
- PL_perlio_fd_refcnt = NULL;
- PL_perlio_fd_refcnt_size = 0;
- }
+ free(PL_perlio_fd_refcnt); /* To match realloc() in S_more_refcounted_fds(). */
+ PL_perlio_fd_refcnt = NULL;
+ PL_perlio_fd_refcnt_size = 0;
}
-#ifdef USE_ITHREADS
- MUTEX_UNLOCK(&PL_perlio_mutex);
-#endif
}
-
-
/*--------------------------------------------------------------------------------------*/
/*
* Bottom-most level for UNIX-like case
FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
if (ptr != NULL) {
#ifdef STDIO_PTR_LVALUE
- PerlSIO_set_ptr(stdio, (void*)ptr); /* LHS STDCHAR* cast non-portable */
+ PerlSIO_set_ptr(stdio, ptr); /* LHS STDCHAR* cast non-portable */
#ifdef STDIO_PTR_LVAL_SETS_CNT
if (PerlSIO_get_cnt(stdio) != (cnt)) {
assert(PerlSIO_get_cnt(stdio) == (cnt));
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)))
code = PerlIOBuf_pushed(aTHX_ f, mode, arg, tab);
#if 0
PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08" UVxf "\n",
- f, PerlIOBase(f)->tab->name, (mode) ? mode : "(Null)",
+ (void*)f, PerlIOBase(f)->tab->name, (mode) ? mode : "(Null)",
PerlIOBase(f)->flags);
#endif
{
if (ptr != chk ) {
Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08" UVxf
- " nl=%p e=%p for %d", ptr, chk, flags, c->nl,
- b->end, cnt);
+ " nl=%p e=%p for %d", (void*)ptr, (void*)chk,
+ flags, c->nl, b->end, cnt);
}
#endif
}
}
posn = (b->posn / PL_mmap_page_size) * PL_mmap_page_size;
len = st.st_size - posn;
- m->mptr = mmap(NULL, len, PROT_READ, MAP_SHARED, fd, posn);
+ m->mptr = (Mmap_t)mmap(NULL, len, PROT_READ, MAP_SHARED, fd, posn);
if (m->mptr && m->mptr != (Mmap_t) - 1) {
#if 0 && defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
madvise(m->mptr, len, MADV_SEQUENTIAL);
projects / p5sagit/p5-mst-13.2.git / blobdiff