Make (hopefully) the Windows CR CR LF bug go away

by making the CRLF layer repel any other CRLF layers.
In other words: binmode(FH, ":crlf") in e.g. Win32
is effectively a no-op since there already is one
CRLF layer in the stack by default.

p4raw-id: //depot/perl@20674

diff --git a/perlio.c b/perlio.c
index fa2cd83..a508b64 100644 (file)
--- a/perlio.c
+++ b/perlio.c
@@ -4038,6 +4038,23 @@ PerlIOCrlf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
                 f, PerlIOBase(f)->tab->name, (mode) ? mode : "(Null)",
                 PerlIOBase(f)->flags);
 #endif
+    {
+      /* Enable the first CRLF capable layer you can find, but if none
+       * found, the one we just pushed is fine.  This results in at
+       * any given moment at most one CRLF-capable layer being enabled
+       * in the whole layer stack. */
+        PerlIO *g = PerlIONext(f);
+        while (g && *g) {
+             PerlIOl *b = PerlIOBase(g);
+             if (b && b->tab == &PerlIO_crlf) {
+                  if (!(b->flags & PERLIO_F_CRLF))
+                       b->flags |= PERLIO_F_CRLF;
+                  PerlIO_pop(aTHX_ f);
+                  return code;
+             }           
+             g = PerlIONext(g);
+        }
+    }
     return code;
 }
 

diff --git a/pod/perlrun.pod b/pod/perlrun.pod
index d8ed107..3ddb2f8 100644 (file)
--- a/pod/perlrun.pod
+++ b/pod/perlrun.pod
@@ -947,9 +947,23 @@ You perhaps were thinking of C<:crlf:bytes> or C<:perlio:bytes>.
 
 =item :crlf
 
-A layer that implements DOS/Windows like CRLF line endings.
-On read converts pairs of CR,LF to a single "\n" newline character.
-On write converts each "\n" to a CR,LF pair.
+A layer that implements DOS/Windows like CRLF line endings.  On read
+converts pairs of CR,LF to a single "\n" newline character.  On write
+converts each "\n" to a CR,LF pair.  Note that this layer likes to be
+one of its kind: it silently ignores attempts to be pushed into the
+layer stack more than once.
+
+(Gory details follow) To be more exact what happens is this: after
+pushing itself to the stack, the C<:crlf> layer checks all the layers
+below itself to find the first layer that is capable of being a CRLF
+layer but is not yet enabled to be a CRLF layer.  If it finds such a
+layer, it enables the CRLFness of that other deeper layer, and then
+pops itself off the stack.  If not, fine, use the one we just pushed.
+
+The end result is that a C<:crlf> means "please enable the first CRLF
+layer you can find, and if you can't find one, here would be a good
+spot to place a new one."
+
 Based on the C<:perlio> layer.
 
 =item :mmap

diff --git a/t/io/crlf.t b/t/io/crlf.t
index 084be21..2ee7b83 100644 (file)
--- a/t/io/crlf.t
+++ b/t/io/crlf.t
@@ -11,11 +11,11 @@ require "test.pl";
 
 my $file = "crlf$$.dat";
 END {
- unlink($file);
+    1 while unlink($file);
 }
 
 if (find PerlIO::Layer 'perlio') {
- plan(tests => 8);
+ plan(tests => 16);
  ok(open(FOO,">:crlf",$file));
  ok(print FOO 'a'.((('a' x 14).qq{\n}) x 2000) || close(FOO));
  ok(open(FOO,"<:crlf",$file));
@@ -47,6 +47,31 @@ if (find PerlIO::Layer 'perlio') {
  }
 
  ok(close(FOO));
+
+ # binmode :crlf should not cumulate.
+ # Try it first once and then twice so that even UNIXy boxes
+ # get to exercise this, for DOSish boxes even once is enough.
+ # Try also pushing :utf8 first so that there are other layers
+ # in between (this should not matter: CRLF layers still should
+ # not accumulate).
+ for my $utf8 ('', ':utf8') {
+     for my $binmode (1..2) {
+        open(FOO, ">$file");
+        # require PerlIO; print PerlIO::get_layers(FOO), "\n";
+        binmode(FOO, "$utf8:crlf") for 1..$binmode;
+        # require PerlIO; print PerlIO::get_layers(FOO), "\n";
+        print FOO "Hello\n";
+        close FOO;
+        open(FOO, "<$file");
+        binmode(FOO);
+        my $foo = scalar <FOO>;
+        close FOO;
+        print join(" ", "#", map { sprintf("%02x", $_) } unpack("C*", $foo)),
+              "\n";
+        ok($foo =~ /\x0d\x0a$/);
+        ok($foo !~ /\x0d\x0d/);
+     }
+ }
 }
 else {
  skip_all("No perlio, so no :crlf");

diff --git a/t/io/layers.t b/t/io/layers.t
index 31bb13b..904ef93 100644 (file)
--- a/t/io/layers.t
+++ b/t/io/layers.t
@@ -25,8 +25,6 @@ BEGIN {
     $PERLIO = exists $ENV{PERLIO} ? $ENV{PERLIO} : "(undef)";
 }
 
-plan tests => 43;
-
 use Config;
 
 my $DOSISH    = $^O =~ /^(?:MSWin32|os2|dos|NetWare|mint)$/ ? 1 : 0;
@@ -34,6 +32,10 @@ my $DOSISH    = $^O =~ /^(?:MSWin32|os2|dos|NetWare|mint)$/ ? 1 : 0;
 my $NONSTDIO  = exists $ENV{PERLIO} && $ENV{PERLIO} ne 'stdio'     ? 1 : 0;
 my $FASTSTDIO = $Config{d_faststdio} && $Config{usefaststdio}      ? 1 : 0;
 
+my $NTEST = 43 - (($DOSISH || !$FASTSTDIO) ? 7 : 0) - ($DOSISH ? 5 : 0);
+
+plan tests => $NTEST;
+
 print <<__EOH__;
 # PERLIO    = $PERLIO
 # DOSISH    = $DOSISH
@@ -42,7 +44,7 @@ print <<__EOH__;
 __EOH__
 
 SKIP: {
-    skip("This perl does not have Encode", 43)
+    skip("This perl does not have Encode", $NTEST)
        unless " $Config{extensions} " =~ / Encode /;
 
     sub check {
@@ -80,8 +82,14 @@ SKIP: {
                   $result->[0] eq "unix" &&
                   $result->[1] eq "crlf";
        }
+       if ($DOSISH && grep { $_ eq 'crlf' } @$expected) {
+           # 5 tests potentially skipped because
+           # DOSISH systems already have a CRLF layer
+           # which will make new ones not stick.
+           @$expected = grep { $_ ne 'crlf' } @$expected;
+       }
        my $n = scalar @$expected;
-       is($n, scalar @$expected, "$id - layers = $n");
+       is($n, scalar @$expected, "$id - layers == $n");
        for (my $i = 0; $i < $n; $i++) {
            my $j = $expected->[$i];
            if (ref $j eq 'CODE') {
@@ -122,7 +130,6 @@ SKIP: {
          [ "stdio" ],
          ":raw");
 
-    binmode(F, ":pop") if $DOSISH; # Drop one extra :crlf.
     binmode(F, ":utf8");
 
     check([ PerlIO::get_layers(F) ],
@@ -149,9 +156,8 @@ SKIP: {
 
     binmode(F, ":raw :encoding(latin1)"); # "latin1" will be canonized
 
-    SKIP: {
-       skip("too complex layer coreography", 7) if $DOSISH || !$FASTSTDIO;
-
+    # 7 tests potentially skipped.
+    unless ($DOSISH || !$FASTSTDIO) {
        my @results = PerlIO::get_layers(F, details => 1);
 
        # Get rid of the args and the flags.