From: Jarkko Hietaniemi Date: Wed, 13 Aug 2003 11:57:47 +0000 (+0000) Subject: Make (hopefully) the Windows CR CR LF bug go away X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=8229d19fa9e50fd15985d19cead1fb292012b9f9;p=p5sagit%2Fp5-mst-13.2.git 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 --- 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 --- 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 --- 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 ; + 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 --- 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.