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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 0ca7a7a..710403f 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 43b3f66..9e6d065 100644 (file)
--- 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 (file)
--- 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 */