From: Nick Ing-Simmons Date: Sat, 18 Nov 2000 20:17:22 +0000 (+0000) Subject: Lexical use open ... support: X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=ac27b0f573239284c298fcf96fb6c966551ef207;p=p5sagit%2Fp5-mst-13.2.git Lexical use open ... support: add ->cop_io to COP structure in cop.h. Make mg.c and gv.c associate it with ${^OPEN}. Make lib/open.pm set it. Have sv.c, perl.c, pp_ctl.c, op.c manipulate it in a manner manner similar to ->cop_warnings. Have doio.c's do_open9 and pp_sys.c's pp_backticks use it as default and call new PerlIO_apply_layers(). Declare latter in perlio.h and define in perlio.c p4raw-id: //depot/perlio@7740 --- diff --git a/cop.h b/cop.h index 6e8bd91..e1b89c7 100644 --- a/cop.h +++ b/cop.h @@ -21,6 +21,7 @@ struct cop { I32 cop_arybase; /* array base this line was compiled with */ line_t cop_line; /* line # of this command */ SV * cop_warnings; /* lexical warnings bitmask */ + SV * cop_io; /* lexical IO defaults */ }; #define Nullcop Null(COP*) diff --git a/doio.c b/doio.c index 84a647f..14e48b2 100644 --- a/doio.c +++ b/doio.c @@ -510,11 +510,29 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw, IoIFP(io) = fp; if (!num_svs) { /* Need to supply default type info from open.pm */ + SV *layers = PL_curcop->cop_io; type = NULL; + if (layers) { + STRLEN len; + type = SvPV(layers,len); + if (type && mode[0] != 'r') { + /* Skip to write part */ + char *s = strchr(type,0); + if (s && (s-type) < len) { + type = s+1; + } + } + } + else if (O_BINARY != O_TEXT) { + type = ":crlf"; + } } if (type) { while (isSPACE(*type)) type++; if (*type) { + if (PerlIO_apply_layers(aTHX_ IoIFP(io),mode,type) != 0) { + goto say_false; + } } } @@ -530,6 +548,15 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw, IoIFP(io) = Nullfp; goto say_false; } + if (type && *type) { + if (PerlIO_apply_layers(aTHX_ IoOFP(io),mode,type) != 0) { + PerlIO_close(IoOFP(io)); + PerlIO_close(fp); + IoIFP(io) = Nullfp; + IoOFP(io) = Nullfp; + goto say_false; + } + } } else IoOFP(io) = fp; diff --git a/gv.c b/gv.c index 768824d..86d8e79 100644 --- a/gv.c +++ b/gv.c @@ -848,12 +848,15 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) case '\006': /* $^F */ case '\010': /* $^H */ case '\011': /* $^I, NOT \t in EBCDIC */ - case '\017': /* $^O */ case '\020': /* $^P */ case '\024': /* $^T */ if (len > 1) break; goto magicalize; + case '\017': /* $^O & $^OPEN */ + if (len > 1 && strNE(name, "\017PEN")) + break; + goto magicalize; case '\023': /* $^S */ if (len > 1) break; @@ -1672,6 +1675,13 @@ Perl_is_gv_magical(pTHX_ char *name, STRLEN len, U32 flags) if (len == 3 && strEQ(name, "SIG")) goto yes; break; + case '\017': /* $^O & $^OPEN */ + if (len == 1 + || (len == 4 && strEQ(name, "\027PEN"))) + { + goto yes; + } + break; case '\027': /* $^W & $^WARNING_BITS */ if (len == 1 || (len == 12 && strEQ(name, "\027ARNING_BITS")) @@ -1715,7 +1725,6 @@ Perl_is_gv_magical(pTHX_ char *name, STRLEN len, U32 flags) case '\010': /* $^H */ case '\011': /* $^I, NOT \t in EBCDIC */ case '\014': /* $^L */ - case '\017': /* $^O */ case '\020': /* $^P */ case '\023': /* $^S */ case '\024': /* $^T */ diff --git a/lib/open.pm b/lib/open.pm index cdd20ac..82b043a 100644 --- a/lib/open.pm +++ b/lib/open.pm @@ -1,23 +1,43 @@ package open; +use Carp; $open::hint_bits = 0x20000; +use vars qw(%layers @layers); + +# Populate hash in non-PerlIO case +%layers = (crlf => 1, raw => 0) unless (@layers); + sub import { shift; die "`use open' needs explicit list of disciplines" unless @_; $^H |= $open::hint_bits; + my ($in,$out) = split(/\0/,(${^OPEN} || '\0')); + my @in = split(/\s+/,$in); + my @out = split(/\s+/,$out); while (@_) { my $type = shift; - if ($type =~ /^(IN|OUT)\z/s) { - my $discp = shift; - unless ($discp =~ /^\s*:(raw|crlf)\s*\z/s) { - die "Unknown discipline '$discp'"; + my $discp = shift; + my @val; + foreach my $layer (split(/\s+:?/,$discp)) { + unless(exists $layers{$layer}) { + croak "Unknown discipline layer '$layer'"; + } + push(@val,":$layer"); + if ($layer =~ /^(crlf|raw)$/) { + $^H{"open_$type"} = $layer; } - $^H{"open_$type"} = $discp; + } + if ($type eq 'IN') { + $in = join(' ',@val); + } + elsif ($type eq 'OUT') { + $out = join(' ',@val); } else { - die "Unknown discipline class '$type'"; + croak "Unknown discipline class '$type'"; } } + ${^OPEN} = join('\0',$in,$out); } 1; diff --git a/mg.c b/mg.c index 923915d..867cf38 100644 --- a/mg.c +++ b/mg.c @@ -200,7 +200,7 @@ Perl_mg_size(pTHX_ SV *sv) { MAGIC* mg; I32 len; - + for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { MGVTBL* vtbl = mg->mg_virtual; if (vtbl && vtbl->svt_len) { @@ -348,7 +348,7 @@ Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg) else /* @- */ return rx->lastparen; } - + return (U32)-1; } @@ -498,7 +498,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) #ifdef MACOS_TRADITIONAL { char msg[256]; - + sv_setnv(sv,(double)gMacPerl_OSErr); sv_setpv(sv, gMacPerl_OSErr ? GetSysErrText(gMacPerl_OSErr, msg) : ""); } @@ -563,8 +563,16 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) else sv_setsv(sv, &PL_sv_undef); break; - case '\017': /* ^O */ - sv_setpv(sv, PL_osname); + case '\017': /* ^O & ^OPEN */ + if (*(mg->mg_ptr+1) == '\0') + sv_setpv(sv, PL_osname); + else if (strEQ(mg->mg_ptr, "\017PEN")) { + if (!PL_compiling.cop_io) + sv_setsv(sv, &PL_sv_undef); + else { + sv_setsv(sv, PL_compiling.cop_io); + } + } break; case '\020': /* ^P */ sv_setiv(sv, (IV)PL_perldb); @@ -596,10 +604,10 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) } else if (PL_compiling.cop_warnings == pWARN_ALL) { sv_setpvn(sv, WARN_ALLstring, WARNsize) ; - } + } else { sv_setsv(sv, PL_compiling.cop_warnings); - } + } SvPOK_only(sv); } else if (strEQ(mg->mg_ptr, "\027IDE_SYSTEM_CALLS")) @@ -1120,7 +1128,7 @@ Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg) hv_ksplit((HV*)LvTARG(sv), SvIV(sv)); } return 0; -} +} /* caller is responsible for stack switching/cleanup */ STATIC int @@ -1131,7 +1139,7 @@ S_magic_methcall(pTHX_ SV *sv, MAGIC *mg, char *meth, I32 flags, int n, SV *val) PUSHMARK(SP); EXTEND(SP, n); PUSHs(SvTIED_obj(sv, mg)); - if (n > 1) { + if (n > 1) { if (mg->mg_ptr) { if (mg->mg_len >= 0) PUSHs(sv_2mortal(newSVpvn(mg->mg_ptr, mg->mg_len))); @@ -1199,7 +1207,7 @@ Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg) U32 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg) -{ +{ dSP; U32 retval = 0; @@ -1261,7 +1269,7 @@ int Perl_magic_existspack(pTHX_ SV *sv, MAGIC *mg) { return magic_methpack(sv,mg,"EXISTS"); -} +} int Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg) @@ -1302,7 +1310,7 @@ int Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg) { SV* lsv = LvTARG(sv); - + if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) { mg = mg_find(lsv, 'g'); if (mg && mg->mg_len >= 0) { @@ -1328,7 +1336,7 @@ Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg) dTHR; mg = 0; - + if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) mg = mg_find(lsv, 'g'); if (!mg) { @@ -1708,12 +1716,20 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) PL_inplace = Nullch; break; case '\017': /* ^O */ - if (PL_osname) - Safefree(PL_osname); - if (SvOK(sv)) - PL_osname = savepv(SvPV(sv,len)); - else - PL_osname = Nullch; + if (*(mg->mg_ptr+1) == '\0') { + if (PL_osname) + Safefree(PL_osname); + if (SvOK(sv)) + PL_osname = savepv(SvPV(sv,len)); + else + PL_osname = Nullch; + } + else if (strEQ(mg->mg_ptr, "\017PEN")) { + if (!PL_compiling.cop_io) + PL_compiling.cop_io = newSVsv(sv); + else + sv_setsv(PL_compiling.cop_io,sv); + } break; case '\020': /* ^P */ PL_perldb = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); @@ -1731,7 +1747,7 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) if (*(mg->mg_ptr+1) == '\0') { if ( ! (PL_dowarn & G_WARN_ALL_MASK)) { i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); - PL_dowarn = (PL_dowarn & ~G_WARN_ON) + PL_dowarn = (PL_dowarn & ~G_WARN_ON) | (i ? G_WARN_ON : G_WARN_OFF) ; } } @@ -2037,7 +2053,7 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) if (PL_origargv[i] == s + 1 #ifdef OS2 || PL_origargv[i] == s + 2 -#endif +#endif ) { ++s; @@ -2050,7 +2066,7 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) if (PL_origenviron && (PL_origenviron[0] == s + 1 #ifdef OS2 || (PL_origenviron[0] == s + 9 && (s += 8)) -#endif +#endif )) { my_setenv("NoNe SuCh", Nullch); /* force copy of environment */ @@ -2153,7 +2169,7 @@ Perl_sighandler(int sig) #if defined(WIN32) && defined(PERL_IMPLICIT_CONTEXT) PERL_SET_THX(aTHXo); /* fake TLS, see above */ #endif - + if (PL_savestack_ix + 15 <= PL_savestack_max) flags |= 1; if (PL_markstack_ptr < PL_markstack_max - 2) @@ -2174,7 +2190,7 @@ Perl_sighandler(int sig) o_save_i = PL_savestack_ix; SAVEDESTRUCTOR_X(unwind_handler_stack, (void*)&flags); } - if (flags & 4) + if (flags & 4) PL_markstack_ptr++; /* Protect mark. */ if (flags & 8) { PL_retstack_ix++; @@ -2183,7 +2199,7 @@ Perl_sighandler(int sig) if (flags & 16) PL_scopestack_ix += 1; /* sv_2cv is too complicated, try a simpler variant first: */ - if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig])) + if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig])) || SvTYPE(cv) != SVt_PVCV) cv = sv_2cv(PL_psig_ptr[sig],&st,&gv,TRUE); @@ -2217,16 +2233,16 @@ Perl_sighandler(int sig) cleanup: if (flags & 1) PL_savestack_ix -= 8; /* Unprotect save in progress. */ - if (flags & 4) + if (flags & 4) PL_markstack_ptr--; - if (flags & 8) + if (flags & 8) PL_retstack_ix--; if (flags & 16) PL_scopestack_ix -= 1; if (flags & 64) SvREFCNT_dec(sv); PL_op = myop; /* Apparently not needed... */ - + PL_Sv = tSv; /* Restore global temporaries. */ PL_Xpv = tXpv; return; diff --git a/op.c b/op.c index 659627c..07d147d 100644 --- a/op.c +++ b/op.c @@ -853,6 +853,8 @@ S_cop_free(pTHX_ COP* cop) #endif if (! specialWARN(cop->cop_warnings)) SvREFCNT_dec(cop->cop_warnings); + if (! specialCopIO(cop->cop_io)) + SvREFCNT_dec(cop->cop_io); } STATIC void @@ -2075,6 +2077,11 @@ Perl_block_start(pTHX_ int full) PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ; SAVEFREESV(PL_compiling.cop_warnings) ; } + SAVESPTR(PL_compiling.cop_io); + if (! specialCopIO(PL_compiling.cop_io)) { + PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ; + SAVEFREESV(PL_compiling.cop_io) ; + } return retval; } @@ -3535,6 +3542,10 @@ Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o) cop->cop_warnings = PL_curcop->cop_warnings ; else cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ; + if (specialCopIO(PL_curcop->cop_io)) + cop->cop_io = PL_curcop->cop_io; + else + cop->cop_io = newSVsv(PL_curcop->cop_io) ; if (PL_copline == NOLINE) diff --git a/perl.c b/perl.c index b65bdb9..932c344 100644 --- a/perl.c +++ b/perl.c @@ -157,7 +157,7 @@ perl_construct(pTHXx) #ifdef MULTIPLICITY init_interp(); - PL_perl_destruct_level = 1; + PL_perl_destruct_level = 1; #else if (PL_perl_destruct_level > 0) init_interp(); @@ -344,7 +344,7 @@ perl_destruct(pTHXx) DEBUG_S(PerlIO_printf(Perl_debug_log, "perl_destruct: detaching thread %p\n", t)); ThrSETSTATE(t, THRf_R_DETACHED); - /* + /* * We unlock threads_mutex and t->mutex in the opposite order * from which we locked them just so that DETACH won't * deadlock if it panics. It's only a breach of good style @@ -434,7 +434,7 @@ perl_destruct(pTHXx) if (destruct_level == 0){ DEBUG_P(debprofdump()); - + /* The exit() function will do everything that needs doing. */ return; } @@ -603,6 +603,9 @@ perl_destruct(pTHXx) if (!specialWARN(PL_compiling.cop_warnings)) SvREFCNT_dec(PL_compiling.cop_warnings); PL_compiling.cop_warnings = Nullsv; + if (!specialCopIO(PL_compiling.cop_io)) + SvREFCNT_dec(PL_compiling.cop_io); + PL_compiling.cop_io = Nullsv; #ifdef USE_ITHREADS Safefree(CopFILE(&PL_compiling)); CopFILE(&PL_compiling) = Nullch; @@ -724,7 +727,7 @@ perl_destruct(pTHXx) Safefree(PL_psig_name); nuke_stacks(); PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */ - + DEBUG_P(debprofdump()); #ifdef USE_THREADS MUTEX_DESTROY(&PL_strtab_mutex); @@ -986,7 +989,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) #ifdef MACOS_TRADITIONAL /* ignore -e for Dev:Pseudo argument */ if (argv[1] && !strcmp(argv[1], "Dev:Pseudo")) - break; + break; #endif if (PL_euid != PL_uid || PL_egid != PL_gid) Perl_croak(aTHX_ "No -e allowed in setuid scripts"); @@ -1267,7 +1270,7 @@ print \" \\@INC:\\n @INC\\n\";"); # else SOCKSinit(argv[0]); # endif -#endif +#endif init_predump_symbols(); /* init_postdump_symbols not currently designed to be called */ @@ -1434,7 +1437,7 @@ S_run_body(pTHX_ I32 oldscope) my_exit(0); } if (PERLDB_SINGLE && PL_DBsingle) - sv_setiv(PL_DBsingle, 1); + sv_setiv(PL_DBsingle, 1); if (PL_initav) call_list(oldscope, PL_initav); } @@ -1569,7 +1572,7 @@ Performs a callback to the specified Perl sub. See L. I32 Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv) - + /* See G_* flags in cop.h */ /* null terminated arg list */ { @@ -1694,15 +1697,15 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags) { register PERL_CONTEXT *cx; I32 gimme = GIMME_V; - + ENTER; SAVETMPS; - + push_return(Nullop); PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp); PUSHEVAL(cx, 0, 0); PL_eval_root = PL_op; /* Only needed so that goto works right. */ - + PL_in_eval = EVAL_INEVAL; if (flags & G_KEEPERR) PL_in_eval |= EVAL_KEEPERR; @@ -1821,7 +1824,7 @@ Tells Perl to C the string in the SV. I32 Perl_eval_sv(pTHX_ SV *sv, I32 flags) - + /* See G_* flags in cop.h */ { dSP; @@ -2117,7 +2120,7 @@ Perl_moreswitches(pTHX_ char *s) return s; } case 'h': - usage(PL_origargv[0]); + usage(PL_origargv[0]); PerlProc_exit(0); case 'i': if (PL_inplace) @@ -2329,16 +2332,16 @@ Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n"); PerlProc_exit(0); case 'w': if (! (PL_dowarn & G_WARN_ALL_MASK)) - PL_dowarn |= G_WARN_ON; + PL_dowarn |= G_WARN_ON; s++; return s; case 'W': - PL_dowarn = G_WARN_ALL_ON|G_WARN_ON; + PL_dowarn = G_WARN_ALL_ON|G_WARN_ON; PL_compiling.cop_warnings = pWARN_ALL ; s++; return s; case 'X': - PL_dowarn = G_WARN_ALL_OFF; + PL_dowarn = G_WARN_ALL_OFF; PL_compiling.cop_warnings = pWARN_NONE ; s++; return s; @@ -2496,7 +2499,7 @@ S_init_main_stash(pTHX) #endif HvSHAREKEYS_off(PL_strtab); /* mandatory */ hv_ksplit(PL_strtab, 512); - + PL_curstash = PL_defstash = newHV(); PL_curstname = newSVpvn("main",4); gv = gv_fetchpv("main::",TRUE, SVt_PVHV); @@ -2719,7 +2722,7 @@ S_fd_on_nosuid_fs(pTHX_ int fd) check_okay = fstatvfs(fd, &stfs) == 0; on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID); # endif /* fstatvfs */ - + # if !defined(FD_ON_NOSUID_CHECK_OKAY) && \ defined(PERL_MOUNT_NOSUID) && \ defined(HAS_FSTATFS) && \ @@ -2789,7 +2792,7 @@ S_fd_on_nosuid_fs(pTHX_ int fd) fclose(mtab); # endif /* getmntent+hasmntopt */ - if (!check_okay) + if (!check_okay) Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid", PL_origfilename); return on_nosuid; } @@ -3046,7 +3049,7 @@ S_find_beginning(pTHX) forbid_setid("-x"); #ifdef MACOS_TRADITIONAL /* Since the Mac OS does not honor !# arguments for us, we do it ourselves */ - + while (PL_doextract || gMacPerl_AlwaysExtract) { if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch) { if (!gMacPerl_AlwaysExtract) @@ -3060,7 +3063,7 @@ S_find_beginning(pTHX) /* Pater peccavi, file does not have #! */ PerlIO_rewind(PL_rsfp); - + break; } #else @@ -3123,11 +3126,11 @@ Perl_init_debugger(pTHX) PL_DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV)); sv_upgrade(GvSV(PL_DBsub), SVt_IV); /* IVX accessed if PERLDB_SUB_NN */ PL_DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV))); - sv_setiv(PL_DBsingle, 0); + sv_setiv(PL_DBsingle, 0); PL_DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV))); - sv_setiv(PL_DBtrace, 0); + sv_setiv(PL_DBtrace, 0); PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV))); - sv_setiv(PL_DBsignal, 0); + sv_setiv(PL_DBsignal, 0); PL_curstash = ostash; } @@ -3404,7 +3407,7 @@ S_init_perllib(pTHX) Perl_sv_setpvf(aTHX_ privdir, "%ssite_perl:", macperl); if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode)) incpush(SvPVX(privdir), TRUE, FALSE); - + SvREFCNT_dec(privdir); } if (!PL_tainting) @@ -3413,7 +3416,7 @@ S_init_perllib(pTHX) #ifndef PRIVLIB_EXP # define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl" #endif -#if defined(WIN32) +#if defined(WIN32) incpush(PRIVLIB_EXP, TRUE, FALSE); #else incpush(PRIVLIB_EXP, FALSE, FALSE); @@ -3483,7 +3486,7 @@ S_init_perllib(pTHX) #endif #ifndef PERLLIB_MANGLE # define PERLLIB_MANGLE(s,n) (s) -#endif +#endif STATIC void S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers) @@ -3559,7 +3562,7 @@ S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers) #define PERL_ARCH_FMT "/%s" #endif /* .../version/archname if -d .../version/archname */ - Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_AV_SUFFIX_FMT PERL_FS_VER_FMT PERL_ARCH_FMT, + Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_AV_SUFFIX_FMT PERL_FS_VER_FMT PERL_ARCH_FMT, libdir, (int)PERL_REVISION, (int)PERL_VERSION, (int)PERL_SUBVERSION, ARCHNAME); @@ -3823,7 +3826,7 @@ Perl_my_failure_exit(pTHX) if (errno & 255) STATUS_POSIX_SET(errno); else { - exitstatus = STATUS_POSIX >> 8; + exitstatus = STATUS_POSIX >> 8; if (exitstatus & 255) STATUS_POSIX_SET(exitstatus); else diff --git a/perlio.c b/perlio.c index 0ca7a7a..710403f 100644 --- a/perlio.c +++ b/perlio.c @@ -28,6 +28,14 @@ #define PERL_IN_PERLIO_C #include "perl.h" +#ifndef PERLIO_LAYERS +int +PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names) +{ + Perl_croak(aTHX_ "Cannot apply \"%s\" in non-PerlIO perl",names); +} +#endif + #if !defined(PERL_IMPLICIT_SYS) #ifdef PERLIO_IS_STDIO @@ -232,7 +240,7 @@ XS(XS_perlio_unimport) } SV * -PerlIO_find_layer(char *name, STRLEN len) +PerlIO_find_layer(const char *name, STRLEN len) { dTHX; SV **svp; @@ -313,7 +321,7 @@ XS(XS_io_MODIFY_SCALAR_ATTRIBUTES) for (i=2; i < items; i++) { STRLEN len; - char *name = SvPV(ST(i),len); + const char *name = SvPV(ST(i),len); SV *layer = PerlIO_find_layer(name,len); if (layer) { @@ -348,7 +356,7 @@ PerlIO_default_layer(I32 n) int len; if (!PerlIO_layer_hv) { - char *s = PerlEnv_getenv("PERLIO"); + const char *s = PerlEnv_getenv("PERLIO"); newXS("perlio::import",XS_perlio_import,__FILE__); newXS("perlio::unimport",XS_perlio_unimport,__FILE__); #if 0 @@ -371,10 +379,12 @@ PerlIO_default_layer(I32 n) s++; if (*s) { - char *e = s; + const char *e = s; SV *layer; while (*e && !isSPACE((unsigned char)*e)) e++; + if (*s == ':') + s++; layer = PerlIO_find_layer(s,e-s); if (layer) { @@ -412,6 +422,46 @@ PerlIO_default_layer(I32 n) return tab; } +int +PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names) +{ + if (names) + { + const char *s = names; + while (*s) + { + while (isSPACE(*s)) + s++; + if (*s == ':') + s++; + if (*s) + { + const char *e = s; + while (*e && *e != ':' && !isSPACE(*e)) + e++; + if (e > s) + { + SV *layer = PerlIO_find_layer(s,e-s); + if (layer) + { + PerlIO_funcs *tab = INT2PTR(PerlIO_funcs *, SvIV(layer)); + if (tab) + { + PerlIO *new = PerlIO_push(f,tab,mode); + if (!new) + return -1; + } + } + else + Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",(e-s),s); + } + s = e; + } + } + } + return 0; +} + #define PerlIO_default_top() PerlIO_default_layer(-1) #define PerlIO_default_btm() PerlIO_default_layer(0) diff --git a/perlio.h b/perlio.h index fd9aa3b..91e2efa 100644 --- a/perlio.h +++ b/perlio.h @@ -81,7 +81,7 @@ typedef PerlIOl *PerlIO; #define PERLIO_LAYERS 1 extern void PerlIO_define_layer (PerlIO_funcs *tab); -extern SV * PerlIO_find_layer(char *name, STRLEN len); +extern SV * PerlIO_find_layer (const char *name, STRLEN len); extern PerlIO * PerlIO_push (PerlIO *f,PerlIO_funcs *tab,const char *mode); extern void PerlIO_pop (PerlIO *f); @@ -130,6 +130,8 @@ extern void PerlIO_pop (PerlIO *f); #endif /* ifndef PERLIO_NOT_STDIO */ #endif /* PERLIO_IS_STDIO */ +#define specialCopIO(sv) ((sv) != Nullsv) + /* ----------- fill in things that have not got #define'd ---------- */ #ifndef Fpos_t @@ -306,5 +308,8 @@ extern PerlIO * PerlIO_fdupopen (PerlIO *); #ifndef PerlIO_isutf8 extern int PerlIO_isutf8 (PerlIO *); #endif +#ifndef PerlIO_isutf8 +extern int PerlIO_apply_layers (pTHX_ PerlIO *f,const char *mode, const char *names); +#endif #endif /* _PERLIO_H */ diff --git a/pp_ctl.c b/pp_ctl.c index fce163f..86dd843 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -654,8 +654,8 @@ PP(pp_formline) #if defined(USE_LONG_DOUBLE) if (arg & 256) { sprintf(t, "%#0*.*" PERL_PRIfldbl, - (int) fieldsize, (int) arg & 255, value); -/* is this legal? I don't have long doubles */ + (int) fieldsize, (int) arg & 255, value); +/* is this legal? I don't have long doubles */ } else { sprintf(t, "%0*.0" PERL_PRIfldbl, (int) fieldsize, value); } @@ -672,7 +672,7 @@ PP(pp_formline) } t += fieldsize; break; - + case FF_NEWLINE: f++; while (t-- > linemark && *t == ' ') ; @@ -782,7 +782,7 @@ PP(pp_mapwhile) I32 count; I32 shift; SV** src; - SV** dst; + SV** dst; /* first, move source pointer to the next item in the source list */ ++PL_markstack_ptr[-1]; @@ -814,7 +814,7 @@ PP(pp_mapwhile) * irrelevant. --jhi */ if (shift < count) shift = count; /* Avoid shifting too often --Ben Tilly */ - + EXTEND(SP,shift); src = SP; dst = (SP += shift); @@ -824,9 +824,9 @@ PP(pp_mapwhile) *dst-- = *src--; } /* copy the new items down to the destination list */ - dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1; + dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1; while (items--) - *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs); + *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs); } LEAVE; /* exit inner scope */ @@ -1169,27 +1169,27 @@ S_dopoptolabel(pTHX_ char *label) switch (CxTYPE(cx)) { case CXt_SUBST: if (ckWARN(WARN_EXITING)) - Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s", + Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s", PL_op_name[PL_op->op_type]); break; case CXt_SUB: if (ckWARN(WARN_EXITING)) - Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s", + Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s", PL_op_name[PL_op->op_type]); break; case CXt_FORMAT: if (ckWARN(WARN_EXITING)) - Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s", + Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s", PL_op_name[PL_op->op_type]); break; case CXt_EVAL: if (ckWARN(WARN_EXITING)) - Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s", + Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s", PL_op_name[PL_op->op_type]); break; case CXt_NULL: if (ckWARN(WARN_EXITING)) - Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s", + Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s", PL_op_name[PL_op->op_type]); return -1; case CXt_LOOP: @@ -1295,27 +1295,27 @@ S_dopoptoloop(pTHX_ I32 startingblock) switch (CxTYPE(cx)) { case CXt_SUBST: if (ckWARN(WARN_EXITING)) - Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s", + Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s", PL_op_name[PL_op->op_type]); break; case CXt_SUB: if (ckWARN(WARN_EXITING)) - Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s", + Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s", PL_op_name[PL_op->op_type]); break; case CXt_FORMAT: if (ckWARN(WARN_EXITING)) - Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s", + Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s", PL_op_name[PL_op->op_type]); break; case CXt_EVAL: if (ckWARN(WARN_EXITING)) - Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s", + Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s", PL_op_name[PL_op->op_type]); break; case CXt_NULL: if (ckWARN(WARN_EXITING)) - Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s", + Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s", PL_op_name[PL_op->op_type]); return -1; case CXt_LOOP: @@ -1668,10 +1668,10 @@ PP(pp_caller) SV * mask ; SV * old_warnings = cx->blk_oldcop->cop_warnings ; - if (old_warnings == pWARN_NONE || + if (old_warnings == pWARN_NONE || (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0)) mask = newSVpvn(WARN_NONEstring, WARNsize) ; - else if (old_warnings == pWARN_ALL || + else if (old_warnings == pWARN_ALL || (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) mask = newSVpvn(WARN_ALLstring, WARNsize) ; else @@ -2238,7 +2238,7 @@ PP(pp_goto) if (cxix < cxstack_ix) dounwind(cxix); TOPBLOCK(cx); - if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL) + if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL) DIE(aTHX_ "Can't goto subroutine from an eval-string"); mark = PL_stack_sp; if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) { @@ -2306,7 +2306,7 @@ PP(pp_goto) PL_stack_sp--; /* There is no cv arg. */ /* Push a mark for the start of arglist */ - PUSHMARK(mark); + PUSHMARK(mark); (void)(*CvXSUB(cv))(aTHXo_ cv); /* Pop the current context like a decent sub should */ POPBLOCK(cx, PL_curpm); @@ -2380,14 +2380,14 @@ PP(pp_goto) #ifdef USE_THREADS if (!cx->blk_sub.hasargs) { AV* av = (AV*)PL_curpad[0]; - + items = AvFILLp(av) + 1; if (items) { /* Mark is at the end of the stack. */ EXTEND(SP, items); Copy(AvARRAY(av), SP + 1, items, SV*); SP += items; - PUTBACK ; + PUTBACK ; } } #endif /* USE_THREADS */ @@ -2437,7 +2437,7 @@ PP(pp_goto) */ SV *sv = GvSV(PL_DBsub); CV *gotocv; - + if (PERLDB_SUB_NN) { SvIVX(sv) = PTR2IV(cv); /* Already upgraded, saved */ } else { @@ -3103,7 +3103,7 @@ PP(pp_require) if (!tryrsfp && name[0] == ':' && name[1] != ':' && strchr(name+2, ':')) goto trylocal; } - else + else trylocal: { #else } @@ -3312,8 +3312,10 @@ trylocal: { PL_compiling.cop_warnings = pWARN_ALL ; else if (PL_dowarn & G_WARN_ALL_OFF) PL_compiling.cop_warnings = pWARN_NONE ; - else + else PL_compiling.cop_warnings = pWARN_STD ; + SAVESPTR(PL_compiling.cop_io); + PL_compiling.cop_io = Nullsv; if (filter_sub || filter_child_proc) { SV *datasv = filter_add(run_user_filter, Nullsv); @@ -3367,7 +3369,7 @@ PP(pp_entereval) ENTER; lex_start(sv); SAVETMPS; - + /* switch to eval mode */ if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) { @@ -3399,6 +3401,13 @@ PP(pp_entereval) PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings); SAVEFREESV(PL_compiling.cop_warnings); } + SAVESPTR(PL_compiling.cop_io); + if (specialCopIO(PL_curcop->cop_io)) + PL_compiling.cop_io = PL_curcop->cop_io; + else { + PL_compiling.cop_io = newSVsv(PL_curcop->cop_io); + SAVEFREESV(PL_compiling.cop_io); + } push_return(PL_op->op_next); PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP); @@ -3582,7 +3591,7 @@ S_doparseform(pTHX_ SV *sv) if (len == 0) Perl_croak(aTHX_ "Null picture in formline"); - + New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */ fpc = fops; @@ -3610,7 +3619,7 @@ S_doparseform(pTHX_ SV *sv) case ' ': case '\t': skipspaces++; continue; - + case '\n': case 0: arg = s - base; skipspaces++; @@ -3766,7 +3775,7 @@ S_doparseform(pTHX_ SV *sv) * Research Group at University of California, Berkeley. * * See also: "Optimistic Merge Sort" (SODA '92) - * + * * The integration to Perl is by John P. Linderman . * * The code can be distributed under the same terms as Perl itself. diff --git a/pp_sys.c b/pp_sys.c index 43b3f66..9e6d065 100644 --- a/pp_sys.c +++ b/pp_sys.c @@ -302,6 +302,16 @@ PP(pp_backtick) mode = "rt"; fp = PerlProc_popen(tmps, mode); if (fp) { + char *type = NULL; + if (PL_curcop->cop_io) { + type = SvPV_nolen(PL_curcop->cop_io); + } + else if (O_BINARY != O_TEXT) { + type = ":crlf"; + } + if (type && *type) + PerlIO_apply_layers(aTHX_ fp,mode,type); + if (gimme == G_VOID) { char tmpbuf[256]; while (PerlIO_read(fp, tmpbuf, sizeof tmpbuf) > 0) diff --git a/sv.c b/sv.c index 9e6a336..375b956 100644 --- a/sv.c +++ b/sv.c @@ -7832,6 +7832,8 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling); if (!specialWARN(PL_compiling.cop_warnings)) PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings); + if (!specialCopIO(PL_compiling.cop_io)) + PL_compiling.cop_io = sv_dup_inc(PL_compiling.cop_io); PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl); /* pseudo environmental stuff */