summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorNick Ing-Simmons <nik@tiuk.ti.com>2000-11-18 20:17:22 +0000
committerNick Ing-Simmons <nik@tiuk.ti.com>2000-11-18 20:17:22 +0000
commitac27b0f573239284c298fcf96fb6c966551ef207 (patch)
tree13447eed9b72cd6cfd50796c13cabbf22c4383d6
parentb931b1d952313afa398828ff4b2a40af20cfa65a (diff)
downloadperl-ac27b0f573239284c298fcf96fb6c966551ef207.tar.gz
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
-rw-r--r--cop.h1
-rw-r--r--doio.c27
-rw-r--r--gv.c13
-rw-r--r--lib/open.pm32
-rw-r--r--mg.c72
-rw-r--r--op.c11
-rw-r--r--perl.c61
-rw-r--r--perlio.c58
-rw-r--r--perlio.h7
-rw-r--r--pp_ctl.c69
-rw-r--r--pp_sys.c10
-rw-r--r--sv.c2
12 files changed, 263 insertions, 100 deletions
diff --git a/cop.h b/cop.h
index 6e8bd91e42..e1b89c778d 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 84a647f024..14e48b2d8f 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 768824defe..86d8e791a4 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 cdd20ac2c3..82b043afc8 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 923915dd01..867cf38488 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 659627cbba..07d147de64 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 b65bdb91a8..932c3445f2 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<perlcall>.
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<eval> 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 0ca7a7afab..710403fbb6 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 fd9aa3bb0b..91e2efa9b0 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 fce163fc3e..86dd84304d 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 <jpl@research.att.com>.
*
* The code can be distributed under the same terms as Perl itself.
diff --git a/pp_sys.c b/pp_sys.c
index 43b3f66dd7..9e6d065248 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 9e6a3361ae..375b9564fb 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 */