diff options
| -rw-r--r-- | MANIFEST | 1 | ||||
| -rw-r--r-- | ext/PerlIO/t/fail.t | 45 | ||||
| -rw-r--r-- | perlio.c | 13 |
3 files changed, 57 insertions, 2 deletions
@@ -529,6 +529,7 @@ ext/PerlIO/Scalar/Makefile.PL PerlIO layer for scalars ext/PerlIO/Scalar/Scalar.pm PerlIO layer for scalars ext/PerlIO/Scalar/Scalar.xs PerlIO layer for scalars ext/PerlIO/t/encoding.t See if PerlIO encoding conversion works +ext/PerlIO/t/fail.t See if bad layers fail ext/PerlIO/t/fallback.t See if PerlIO fallbacks work ext/PerlIO/t/scalar.t See if PerlIO::Scalar works ext/PerlIO/t/via.t See if PerlIO::Via works diff --git a/ext/PerlIO/t/fail.t b/ext/PerlIO/t/fail.t new file mode 100644 index 0000000000..87d27642da --- /dev/null +++ b/ext/PerlIO/t/fail.t @@ -0,0 +1,45 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; + require "../t/test.pl"; + skip_all("No perlio") unless (find PerlIO::Layer 'perlio'); + plan (16); +} + +use warnings 'layer'; +my $warn; +my $file = "fail$$"; +$SIG{__WARN__} = sub { $warn = shift }; + +END { 1 while unlink($file) } + +ok(open(FH,">",$file),"Create works"); +close(FH); +ok(open(FH,"<",$file),"Normal open works"); + +$warn = ''; $! = 0; +ok(!binmode(FH,":-)"),"All punctuation fails binmode"); +like($!,'Invalid',"Got errno"); +like($warn,qr/in layer/,"Got warning"); + +$warn = ''; $! = 0; +ok(!binmode(FH,":nonesuch"),"Bad package fails binmode"); +like($!,'No such',"Got errno"); +like($warn,qr/nonesuch/,"Got warning"); +close(FH); + +$warn = ''; $! = 0; +ok(!open(FH,"<:-)",$file),"All punctuation fails open"); +like($!,"Invalid","Got errno"); +like($warn,qr/in layer/,"Got warning"); +isnt($!,"","Got errno"); + +$warn = ''; $! = 0; +ok(!open(FH,"<:nonesuch",$file),"Bad package fails open"); +like($!,"No such","Got errno"); +like($warn,qr/nonesuch/,"Got warning"); + +ok(open(FH,"<",$file),"Normal open (still) works"); +close(FH); @@ -805,6 +805,7 @@ PerlIO_parse_layers(pTHX_ PerlIO_list_t *av, const char *names) Perl_warner(aTHX_ packWARN(WARN_LAYER), "perlio: invalid separator character %c%c%c in layer specification list %s", q, *s, q, s); + SETERRNO(EINVAL, LIB$_INVARG); return -1; } do { @@ -1287,8 +1288,13 @@ PerlIO_resolve_layers(pTHX_ const char *layers, else { av = def; } - PerlIO_parse_layers(aTHX_ av, layers); - return av; + if (PerlIO_parse_layers(aTHX_ av, layers) == 0) { + return av; + } + else { + PerlIO_list_free(aTHX_ av); + return (PerlIO_list_t *) NULL; + } } else { if (incdef) @@ -1330,6 +1336,9 @@ PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd, } else { layera = PerlIO_resolve_layers(aTHX_ layers, mode, narg, args); + if (!layera) { + return NULL; + } } /* * Start at "top" of layer stack |