diff options
| -rw-r--r-- | embedvar.h | 6 | ||||
| -rw-r--r-- | intrpvar.h | 2 | ||||
| -rw-r--r-- | perl.c | 13 | ||||
| -rw-r--r-- | perlapi.h | 4 | ||||
| -rw-r--r-- | perlio.c | 147 | ||||
| -rw-r--r-- | perlio.h | 11 | ||||
| -rw-r--r-- | perliol.h | 4 | ||||
| -rw-r--r-- | sv.c | 4 |
8 files changed, 103 insertions, 88 deletions
diff --git a/embedvar.h b/embedvar.h index 066bec428c..2eb540791e 100644 --- a/embedvar.h +++ b/embedvar.h @@ -223,6 +223,7 @@ #define PL_dbargs (PERL_GET_INTERP->Idbargs) #define PL_debstash (PERL_GET_INTERP->Idebstash) #define PL_debug (PERL_GET_INTERP->Idebug) +#define PL_def_layerlist (PERL_GET_INTERP->Idef_layerlist) #define PL_defgv (PERL_GET_INTERP->Idefgv) #define PL_diehook (PERL_GET_INTERP->Idiehook) #define PL_doextract (PERL_GET_INTERP->Idoextract) @@ -266,6 +267,7 @@ #define PL_incgv (PERL_GET_INTERP->Iincgv) #define PL_initav (PERL_GET_INTERP->Iinitav) #define PL_inplace (PERL_GET_INTERP->Iinplace) +#define PL_known_layers (PERL_GET_INTERP->Iknown_layers) #define PL_last_lop (PERL_GET_INTERP->Ilast_lop) #define PL_last_lop_op (PERL_GET_INTERP->Ilast_lop_op) #define PL_last_swash_hv (PERL_GET_INTERP->Ilast_swash_hv) @@ -512,6 +514,7 @@ #define PL_dbargs (vTHX->Idbargs) #define PL_debstash (vTHX->Idebstash) #define PL_debug (vTHX->Idebug) +#define PL_def_layerlist (vTHX->Idef_layerlist) #define PL_defgv (vTHX->Idefgv) #define PL_diehook (vTHX->Idiehook) #define PL_doextract (vTHX->Idoextract) @@ -555,6 +558,7 @@ #define PL_incgv (vTHX->Iincgv) #define PL_initav (vTHX->Iinitav) #define PL_inplace (vTHX->Iinplace) +#define PL_known_layers (vTHX->Iknown_layers) #define PL_last_lop (vTHX->Ilast_lop) #define PL_last_lop_op (vTHX->Ilast_lop_op) #define PL_last_swash_hv (vTHX->Ilast_swash_hv) @@ -804,6 +808,7 @@ #define PL_Idbargs PL_dbargs #define PL_Idebstash PL_debstash #define PL_Idebug PL_debug +#define PL_Idef_layerlist PL_def_layerlist #define PL_Idefgv PL_defgv #define PL_Idiehook PL_diehook #define PL_Idoextract PL_doextract @@ -847,6 +852,7 @@ #define PL_Iincgv PL_incgv #define PL_Iinitav PL_initav #define PL_Iinplace PL_inplace +#define PL_Iknown_layers PL_known_layers #define PL_Ilast_lop PL_last_lop #define PL_Ilast_lop_op PL_last_lop_op #define PL_Ilast_swash_hv PL_last_swash_hv diff --git a/intrpvar.h b/intrpvar.h index b6b4f07388..c224ff7c5d 100644 --- a/intrpvar.h +++ b/intrpvar.h @@ -495,6 +495,8 @@ PERLVAR(Icustom_op_descs, HV*) /* Descriptions of user defined ops */ #ifdef PERLIO_LAYERS PERLVARI(Iperlio, PerlIO *,NULL) +PERLVARI(Iknown_layers, PerlIO_list_t *,NULL) +PERLVARI(Idef_layerlist, PerlIO_list_t *,NULL) #endif /* New variables must be added to the very end for binary compatibility. @@ -258,7 +258,7 @@ perl_construct(pTHXx) sys_intern_init(); #endif - PerlIO_init(); /* Hook to IO system */ + PerlIO_init(aTHX); /* Hook to IO system */ PL_fdpid = newAV(); /* for remembering popen pids by fd */ PL_modglobal = newHV(); /* pointers to per-interpreter module globals */ @@ -498,7 +498,7 @@ perl_destruct(pTHXx) * flag is set in regexec.c:S_regtry */ SvFLAGS(resv) &= ~SVf_BREAK; - } + } else if(SvREPADTMP(resv)) { SvREPADTMP_off(resv); } @@ -800,6 +800,11 @@ perl_destruct(pTHXx) if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL)) Perl_warner(aTHX_ WARN_INTERNAL,"Scalars leaked: %ld\n", (long)PL_sv_count); +#if 1 && defined(PERLIO_LAYERS) + /* No more IO - including error messages ! */ + PerlIO_cleanup(aTHX); +#endif + Safefree(PL_origfilename); Safefree(PL_reg_start_tmp); if (PL_reg_curpm) @@ -946,7 +951,7 @@ setuid perl scripts securely.\n"); { /* we copy rather than point to argv * since perl_clone will copy and perl_destruct - * has no way of knowing if we've made a copy or + * has no way of knowing if we've made a copy or * just point to argv */ int i = PL_origargc; @@ -1517,7 +1522,7 @@ perl_run(pTHXx) LEAVE; FREETMPS; PL_curstash = PL_defstash; - if (!(PL_exit_flags & PERL_EXIT_DESTRUCT_END) && + if (!(PL_exit_flags & PERL_EXIT_DESTRUCT_END) && PL_endav && !PL_minus_c) call_list(oldscope, PL_endav); #ifdef MYMALLOC @@ -183,6 +183,8 @@ END_EXTERN_C #define PL_debstash (*Perl_Idebstash_ptr(aTHX)) #undef PL_debug #define PL_debug (*Perl_Idebug_ptr(aTHX)) +#undef PL_def_layerlist +#define PL_def_layerlist (*Perl_Idef_layerlist_ptr(aTHX)) #undef PL_defgv #define PL_defgv (*Perl_Idefgv_ptr(aTHX)) #undef PL_diehook @@ -269,6 +271,8 @@ END_EXTERN_C #define PL_initav (*Perl_Iinitav_ptr(aTHX)) #undef PL_inplace #define PL_inplace (*Perl_Iinplace_ptr(aTHX)) +#undef PL_known_layers +#define PL_known_layers (*Perl_Iknown_layers_ptr(aTHX)) #undef PL_last_lop #define PL_last_lop (*Perl_Ilast_lop_ptr(aTHX)) #undef PL_last_lop_op @@ -425,7 +425,7 @@ PerlIO_allocate(pTHX) } } } - f = PerlMemShared_calloc(PERLIO_TABLE_SIZE, sizeof(PerlIO)); + Newz('I',f,PERLIO_TABLE_SIZE,PerlIO); if (!f) { return NULL; } @@ -451,25 +451,6 @@ PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param) } void -PerlIO_clone(pTHX_ PerlIO *proto, CLONE_PARAMS *param) -{ - PerlIO **table = &proto; - PerlIO *f; - PL_perlio = NULL; - PerlIO_allocate(aTHX); /* root slot is never used */ - while ((f = *table)) { - int i; - table = (PerlIO **) (f++); - for (i = 1; i < PERLIO_TABLE_SIZE; i++) { - if (*f) { - PerlIO_fdupopen(aTHX_ f, param); - } - f++; - } - } -} - -void PerlIO_cleantable(pTHX_ PerlIO **tablep) { PerlIO *table = *tablep; @@ -482,16 +463,14 @@ PerlIO_cleantable(pTHX_ PerlIO **tablep) PerlIO_close(f); } } - PerlMemShared_free(table); + Safefree(table); *tablep = NULL; } } -PerlIO_list_t *PerlIO_known_layers; -PerlIO_list_t *PerlIO_def_layerlist; PerlIO_list_t * -PerlIO_list_alloc(void) +PerlIO_list_alloc(pTHX) { PerlIO_list_t *list; Newz('L', list, 1, PerlIO_list_t); @@ -500,12 +479,11 @@ PerlIO_list_alloc(void) } void -PerlIO_list_free(PerlIO_list_t *list) +PerlIO_list_free(pTHX_ PerlIO_list_t *list) { if (list) { if (--list->refcnt == 0) { if (list->array) { - dTHX; IV i; for (i = 0; i < list->cur; i++) { if (list->array[i].arg) @@ -519,9 +497,8 @@ PerlIO_list_free(PerlIO_list_t *list) } void -PerlIO_list_push(PerlIO_list_t *list, PerlIO_funcs *funcs, SV *arg) +PerlIO_list_push(pTHX_ PerlIO_list_t *list, PerlIO_funcs *funcs, SV *arg) { - dTHX; PerlIO_pair_t *p; if (list->cur >= list->len) { list->len += 8; @@ -537,20 +514,44 @@ PerlIO_list_push(PerlIO_list_t *list, PerlIO_funcs *funcs, SV *arg) } } +PerlIO_list_t * +PerlIO_clone_list(pTHX_ PerlIO_list_t *proto, CLONE_PARAMS *param) +{ + int i; + PerlIO_list_t *list = PerlIO_list_alloc(aTHX); + for (i=0; i < proto->cur; i++) { + SV *arg = Nullsv; + if (proto->array[i].arg) + arg = sv_dup(proto->array[i].arg,param); + PerlIO_list_push(aTHX_ list, proto->array[i].funcs, arg); + } + return list; +} void -PerlIO_cleanup_layers(pTHX_ void *data) +PerlIO_clone(pTHX_ PerlInterpreter *proto, CLONE_PARAMS *param) { -#if 0 - PerlIO_known_layers = Nullhv; - PerlIO_def_layerlist = Nullav; -#endif + PerlIO **table = &proto->Iperlio; + PerlIO *f; + PL_perlio = NULL; + PL_known_layers = PerlIO_clone_list(aTHX_ proto->Iknown_layers, param); + PL_def_layerlist = PerlIO_clone_list(aTHX_ proto->Idef_layerlist, param); + PerlIO_allocate(aTHX); /* root slot is never used */ + while ((f = *table)) { + int i; + table = (PerlIO **) (f++); + for (i = 1; i < PERLIO_TABLE_SIZE; i++) { + if (*f) { + PerlIO_fdupopen(aTHX_ f, param); + } + f++; + } + } } void -PerlIO_cleanup() +PerlIO_cleanup(pTHX) { - dTHX; PerlIO_cleantable(aTHX_ &PL_perlio); } @@ -578,6 +579,10 @@ PerlIO_destruct(pTHX) f++; } } + PerlIO_list_free(aTHX_ PL_known_layers); + PL_known_layers = NULL; + PerlIO_list_free(aTHX_ PL_def_layerlist); + PL_def_layerlist = NULL; } void @@ -596,7 +601,7 @@ PerlIO_pop(pTHX_ PerlIO *f) return; } *f = l->next;; - PerlMemShared_free(l); + Safefree(l); } } @@ -611,15 +616,15 @@ PerlIO_find_layer(pTHX_ const char *name, STRLEN len, int load) IV i; if ((SSize_t) len <= 0) len = strlen(name); - for (i = 0; i < PerlIO_known_layers->cur; i++) { - PerlIO_funcs *f = PerlIO_known_layers->array[i].funcs; + for (i = 0; i < PL_known_layers->cur; i++) { + PerlIO_funcs *f = PL_known_layers->array[i].funcs; if (memEQ(f->name, name, len)) { PerlIO_debug("%.*s => %p\n", (int) len, name, f); return f; } } - if (load && PL_subname && PerlIO_def_layerlist - && PerlIO_def_layerlist->cur >= 2) { + if (load && PL_subname && PL_def_layerlist + && PL_def_layerlist->cur >= 2) { SV *pkgsv = newSVpvn("PerlIO", 6); SV *layer = newSVpvn(name, len); ENTER; @@ -742,9 +747,9 @@ XS(XS_PerlIO__Layer__find) void PerlIO_define_layer(pTHX_ PerlIO_funcs *tab) { - if (!PerlIO_known_layers) - PerlIO_known_layers = PerlIO_list_alloc(); - PerlIO_list_push(PerlIO_known_layers, tab, Nullsv); + if (!PL_known_layers) + PL_known_layers = PerlIO_list_alloc(aTHX); + PerlIO_list_push(aTHX_ PL_known_layers, tab, Nullsv); PerlIO_debug("define %s %p\n", tab->name, tab); } @@ -819,7 +824,7 @@ PerlIO_parse_layers(pTHX_ PerlIO_list_t *av, const char *names) PerlIO_funcs *layer = PerlIO_find_layer(aTHX_ s, llen, 1); if (layer) { - PerlIO_list_push(av, layer, + PerlIO_list_push(aTHX_ av, layer, (as) ? newSVpvn(as, alen) : &PL_sv_undef); @@ -850,7 +855,7 @@ PerlIO_default_buffer(pTHX_ PerlIO_list_t *av) } } PerlIO_debug("Pushing %s\n", tab->name); - PerlIO_list_push(av, PerlIO_find_layer(aTHX_ tab->name, 0, 0), + PerlIO_list_push(aTHX_ av, PerlIO_find_layer(aTHX_ tab->name, 0, 0), &PL_sv_undef); } @@ -876,10 +881,10 @@ PerlIO_layer_fetch(pTHX_ PerlIO_list_t *av, IV n, PerlIO_funcs *def) PerlIO_list_t * PerlIO_default_layers(pTHX) { - if (!PerlIO_def_layerlist) { + if (!PL_def_layerlist) { const char *s = (PL_tainting) ? Nullch : PerlEnv_getenv("PERLIO"); PerlIO_funcs *osLayer = &PerlIO_unix; - PerlIO_def_layerlist = PerlIO_list_alloc(); + PL_def_layerlist = PerlIO_list_alloc(aTHX); PerlIO_define_layer(aTHX_ & PerlIO_unix); #if defined(WIN32) && !defined(UNDER_CE) PerlIO_define_layer(aTHX_ & PerlIO_win32); @@ -896,20 +901,20 @@ PerlIO_default_layers(pTHX) #endif PerlIO_define_layer(aTHX_ & PerlIO_utf8); PerlIO_define_layer(aTHX_ & PerlIO_byte); - PerlIO_list_push(PerlIO_def_layerlist, + PerlIO_list_push(aTHX_ PL_def_layerlist, PerlIO_find_layer(aTHX_ osLayer->name, 0, 0), &PL_sv_undef); if (s) { - PerlIO_parse_layers(aTHX_ PerlIO_def_layerlist, s); + PerlIO_parse_layers(aTHX_ PL_def_layerlist, s); } else { - PerlIO_default_buffer(aTHX_ PerlIO_def_layerlist); + PerlIO_default_buffer(aTHX_ PL_def_layerlist); } } - if (PerlIO_def_layerlist->cur < 2) { - PerlIO_default_buffer(aTHX_ PerlIO_def_layerlist); + if (PL_def_layerlist->cur < 2) { + PerlIO_default_buffer(aTHX_ PL_def_layerlist); } - return PerlIO_def_layerlist; + return PL_def_layerlist; } void @@ -949,7 +954,7 @@ PerlIO * PerlIO_push(pTHX_ PerlIO *f, PerlIO_funcs *tab, const char *mode, SV *arg) { PerlIOl *l = NULL; - l = PerlMemShared_calloc(tab->size, sizeof(char)); + Newc('L',l,tab->size,char,PerlIOl); if (l) { Zero(l, tab->size, char); l->next = *f; @@ -1035,12 +1040,12 @@ PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names) { int code = 0; if (names) { - PerlIO_list_t *layers = PerlIO_list_alloc(); + PerlIO_list_t *layers = PerlIO_list_alloc(aTHX); code = PerlIO_parse_layers(aTHX_ layers, names); if (code == 0) { code = PerlIO_apply_layera(aTHX_ f, mode, layers, 0); } - PerlIO_list_free(layers); + PerlIO_list_free(aTHX_ layers); } return code; } @@ -1179,8 +1184,8 @@ PerlIO_resolve_layers(pTHX_ const char *layers, if (SvROK(arg) && !sv_isobject(arg)) { PerlIO_funcs *handler = PerlIO_layer_from_ref(aTHX_ SvRV(arg)); if (handler) { - def = PerlIO_list_alloc(); - PerlIO_list_push(def, handler, &PL_sv_undef); + def = PerlIO_list_alloc(aTHX); + PerlIO_list_push(aTHX_ def, handler, &PL_sv_undef); incdef = 0; } /* @@ -1196,9 +1201,9 @@ PerlIO_resolve_layers(pTHX_ const char *layers, PerlIO_list_t *av; if (incdef) { IV i = def->cur; - av = PerlIO_list_alloc(); + av = PerlIO_list_alloc(aTHX); for (i = 0; i < def->cur; i++) { - PerlIO_list_push(av, def->array[i].funcs, + PerlIO_list_push(aTHX_ av, def->array[i].funcs, def->array[i].arg); } } @@ -1237,12 +1242,12 @@ PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd, * yet */ PerlIOl *l = *f; - layera = PerlIO_list_alloc(); + layera = PerlIO_list_alloc(aTHX); while (l) { SV *arg = (l->tab->Getarg) ? (*l->tab-> Getarg) (&l) : &PL_sv_undef; - PerlIO_list_push(layera, l->tab, arg); + PerlIO_list_push(aTHX_ layera, l->tab, arg); l = *PerlIONext(&l); } } @@ -1283,7 +1288,7 @@ PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd, } } } - PerlIO_list_free(layera); + PerlIO_list_free(aTHX_ layera); } return f; } @@ -3076,7 +3081,7 @@ PerlIOBuf_close(PerlIO *f) IV code = PerlIOBase_close(f); PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf); if (b->buf && b->buf != (STDCHAR *) & b->oneword) { - safefree(b->buf); + Safefree(b->buf); } b->buf = NULL; b->ptr = b->end = b->buf; @@ -3226,7 +3231,7 @@ PerlIOPending_flush(PerlIO *f) dTHX; PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf); if (b->buf && b->buf != (STDCHAR *) & b->oneword) { - PerlMemShared_free(b->buf); + Safefree(b->buf); b->buf = NULL; } PerlIO_pop(aTHX_ f); @@ -3914,17 +3919,9 @@ PerlIO_funcs PerlIO_mmap = { #endif /* HAS_MMAP */ void -PerlIO_init(void) +PerlIO_init(pTHX) { - dTHX; -#ifndef WIN32 - call_atexit(PerlIO_cleanup_layers, NULL); -#endif - if (!PL_perlio) { -#ifndef WIN32 - atexit(&PerlIO_cleanup); -#endif - } + /* Place holder for stdstreams call ??? */ } #undef PerlIO_stdin @@ -93,7 +93,7 @@ extern PerlIO_funcs *PerlIO_find_layer(pTHX_ const char *name, STRLEN len, extern PerlIO *PerlIO_push(pTHX_ PerlIO *f, PerlIO_funcs *tab, const char *mode, SV *arg); extern void PerlIO_pop(pTHX_ PerlIO *f); -extern void PerlIO_clone(pTHX_ PerlIO *proto, CLONE_PARAMS *param); +extern void PerlIO_clone(pTHX_ PerlInterpreter *proto, CLONE_PARAMS *param); #endif /* PerlIO */ @@ -185,7 +185,7 @@ START_EXTERN_C #endif #endif #ifndef PerlIO_init -extern void PerlIO_init(void); +extern void PerlIO_init(pTHX); #endif #ifndef PerlIO_stdoutf extern int PerlIO_stdoutf(const char *, ...) @@ -349,11 +349,12 @@ extern void PerlIO_destruct(pTHX); extern int PerlIO_intmode2str(int rawmode, char *mode, int *writing); -#ifndef PERLIO_IS_STDIO - -extern void PerlIO_cleanup(void); +#ifdef PERLIO_LAYERS +extern void PerlIO_cleanup(pTHX); extern void PerlIO_debug(const char *fmt, ...); +typedef struct PerlIO_list_s PerlIO_list_t; + #endif @@ -6,12 +6,12 @@ typedef struct { SV *arg; } PerlIO_pair_t; -typedef struct { +struct PerlIO_list_s { IV refcnt; IV cur; IV len; PerlIO_pair_t *array; -} PerlIO_list_t; +}; struct _PerlIO_funcs { char *name; @@ -9768,8 +9768,8 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, param->stashes = newAV(); /* Setup array of objects to call clone on */ #ifdef PERLIO_LAYERS - /* Clone PerlIO table as soon as we can handle general xx_dup() */ - PerlIO_clone(aTHX_ proto_perl->Iperlio, param); + /* Clone PerlIO tables as soon as we can handle general xx_dup() */ + PerlIO_clone(aTHX_ proto_perl, param); #endif PL_envgv = gv_dup(proto_perl->Ienvgv, param); |