Change 16247 by jhi@alpha on 2002/04/28 15:26:39
Integrate perlio;
Builds under -Uuseperlio
Uses PUSHSTACK/POPSTACK in :encoding and :Via
Use (file PerlIO::Layer 'perlio') rather than $Config{useperlio}
as gate on layer tests which fail on -Dusesfio
(ext/XS/Typemap/Typemap.t still fails on -Dusesfio)
Have :encoding() default to perlqq style fallbacks.
Add test for that.
Affected files ...
.... //depot/perl/MANIFEST#865 integrate
.... //depot/perl/ext/Encode/Encode.xs#81 integrate
.... //depot/perl/ext/PerlIO/PerlIO.t#8 integrate
.... //depot/perl/ext/PerlIO/Via/Via.xs#13 integrate
.... //depot/perl/ext/PerlIO/encoding/encoding.pm#8 integrate
.... //depot/perl/ext/PerlIO/encoding/encoding.xs#11 integrate
.... //depot/perl/ext/PerlIO/t/fallback.t#1 branch
.... //depot/perl/lib/open.t#17 integrate
.... //depot/perl/lib/warnings.t#10 integrate
.... //depot/perl/t/io/binmode.t#4 integrate
.... //depot/perl/t/io/crlf.t#3 integrate
Differences ...
==== //depot/perl/MANIFEST#865 (text) ====
Index: perl/MANIFEST
--- perl/MANIFEST.~1~ Sun Apr 28 09:30:05 2002
+++ perl/MANIFEST Sun Apr 28 09:30:05 2002
@@ -526,6 +526,7 @@
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/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
ext/PerlIO/Via/Makefile.PL PerlIO layer for layers in perl
@@ -1041,7 +1042,7 @@
lib/ExtUtils/t/Constant.t See if ExtUtils::Constant works
lib/ExtUtils/t/Embed.t See if ExtUtils::Embed and embedding works
lib/ExtUtils/t/hints.t See if hint files are honored.
-lib/ExtUtils/t/INST.t Check MakeMaker INST_* macros
+lib/ExtUtils/t/INST.t Check MakeMaker INST_* macros
lib/ExtUtils/t/Installed.t See if ExtUtils::Installed works
lib/ExtUtils/t/INST_PREFIX.t See if MakeMaker can apply PREFIXs
lib/ExtUtils/t/Manifest.t See if ExtUtils::Manifest works
==== //depot/perl/ext/Encode/Encode.xs#81 (text) ====
Index: perl/ext/Encode/Encode.xs
--- perl/ext/Encode/Encode.xs.~1~ Sun Apr 28 09:30:05 2002
+++ perl/ext/Encode/Encode.xs Sun Apr 28 09:30:05 2002
@@ -14,11 +14,11 @@
/* set 1 or more to profile. t/encoding.t dumps core because of
Perl_warner and PerlIO don't work well */
-#define ENCODE_XS_PROFILE 0
+#define ENCODE_XS_PROFILE 0
/* set 0 to disable floating point to calculate buffer size for
encode_method(). 1 is recommended. 2 restores NI-S original */
-#define ENCODE_XS_USEFP 1
+#define ENCODE_XS_USEFP 1
#define UNIMPLEMENTED(x,y) y x (SV *sv, char *encoding) {dTHX; \
Perl_croak(aTHX_ "panic_unimplemented"); \
@@ -123,55 +123,55 @@
}
case ENCODE_NOREP:
/* encoding */
- if (dir == enc->f_utf8) {
+ if (dir == enc->f_utf8) {
STRLEN clen;
UV ch =
- utf8n_to_uvuni(s+slen, (SvCUR(src)-slen),
+ utf8n_to_uvuni(s+slen, (SvCUR(src)-slen),
&clen, UTF8_ALLOW_ANY|UTF8_CHECK_ONLY);
if (check & ENCODE_DIE_ON_ERR) {
Perl_croak(
- aTHX_ "\"\\N{U+%" UVxf "}\" does not map to %s, %d",
+ aTHX_ "\"\\N{U+%" UVxf "}\" does not map to %s, %d",
ch, enc->name[0], __LINE__);
}else{
if (check & ENCODE_RETURN_ON_ERR){
if (check & ENCODE_WARN_ON_ERR){
Perl_warner(
aTHX_ packWARN(WARN_UTF8),
- "\"\\N{U+%" UVxf "}\" does not map to %s",
+ "\"\\N{U+%" UVxf "}\" does not map to %s",
ch,enc->name[0]);
}
goto ENCODE_SET_SRC;
}else if (check & ENCODE_PERLQQ){
- SV* perlqq =
+ SV* perlqq =
sv_2mortal(newSVpvf("\\x{%04"UVxf"}", ch));
sdone += slen + clen;
ddone += dlen + SvCUR(perlqq);
sv_catsv(dst, perlqq);
}else if (check & ENCODE_HTMLCREF){
- SV* htmlcref =
+ SV* htmlcref =
sv_2mortal(newSVpvf("&#%" UVuf ";", ch));
sdone += slen + clen;
ddone += dlen + SvCUR(htmlcref);
sv_catsv(dst, htmlcref);
}else if (check & ENCODE_XMLCREF){
- SV* xmlcref =
+ SV* xmlcref =
sv_2mortal(newSVpvf("&#x%" UVxf ";", ch));
sdone += slen + clen;
ddone += dlen + SvCUR(xmlcref);
sv_catsv(dst, xmlcref);
- } else {
+ } else {
/* fallback char */
sdone += slen + clen;
- ddone += dlen + enc->replen;
- sv_catpvn(dst, (char*)enc->rep, enc->replen);
+ ddone += dlen + enc->replen;
+ sv_catpvn(dst, (char*)enc->rep, enc->replen);
}
- }
+ }
}
/* decoding */
- else {
+ else {
if (check & ENCODE_DIE_ON_ERR){
Perl_croak(
- aTHX_ "%s \"\\x%02" UVXf
+ aTHX_ "%s \"\\x%02" UVXf
"\" does not map to Unicode (%d)",
enc->name[0], (U8) s[slen], code);
}else{
@@ -179,29 +179,29 @@
if (check & ENCODE_WARN_ON_ERR){
Perl_warner(
aTHX_ packWARN(WARN_UTF8),
- "%s \"\\x%02" UVXf
+ "%s \"\\x%02" UVXf
"\" does not map to Unicode (%d)",
enc->name[0], (U8) s[slen], code);
}
goto ENCODE_SET_SRC;
- }else if (check &
+ }else if (check &
(ENCODE_PERLQQ|ENCODE_HTMLCREF|ENCODE_XMLCREF)){
- SV* perlqq =
+ SV* perlqq =
sv_2mortal(newSVpvf("\\x%02" UVXf, s[slen]));
sdone += slen + 1;
ddone += dlen + SvCUR(perlqq);
sv_catsv(dst, perlqq);
} else {
sdone += slen + 1;
- ddone += dlen + strlen(FBCHAR_UTF8);
- sv_catpv(dst, FBCHAR_UTF8);
+ ddone += dlen + strlen(FBCHAR_UTF8);
+ sv_catpv(dst, FBCHAR_UTF8);
}
}
}
/* settle variables when fallback */
d = (U8 *)SvEND(dst);
dlen = SvLEN(dst) - ddone - 1;
- s = (U8*)SvPVX(src) + sdone;
+ s = (U8*)SvPVX(src) + sdone;
slen = tlen - sdone;
break;
@@ -221,10 +221,10 @@
SvCUR_set(src, sdone);
}
/* warn("check = 0x%X, code = 0x%d\n", check, code); */
-
+
SvCUR_set(dst, dlen+ddone);
SvPOK_only(dst);
-
+
#if ENCODE_XS_PROFILE
if (SvCUR(dst) > SvCUR(src)){
Perl_warn(aTHX_
@@ -233,7 +233,7 @@
(SvLEN(dst) - SvCUR(dst))*1.0/SvLEN(dst)*100.0);
}
#endif
-
+
ENCODE_END:
*SvEND(dst) = '\0';
return dst;
@@ -317,7 +317,7 @@
CODE:
{
SV * encoding = items == 2 ? ST(1) : Nullsv;
-
+
if (encoding)
RETVAL = _encoded_bytes_to_utf8(sv, SvPV_nolen(encoding));
else {
@@ -354,7 +354,7 @@
/* Must do things the slow way */
U8 *dest;
/* We need a copy to pass to check() */
- U8 *src = (U8*)savepv((char *)s);
+ U8 *src = (U8*)savepv((char *)s);
U8 *send = s + len;
New(83, dest, len, U8); /* I think */
@@ -379,8 +379,8 @@
/* Note change to utf8.c variable naming, for variety */
while (ulen--) {
- if ((*s & 0xc0) != 0x80){
- goto failure;
+ if ((*s & 0xc0) != 0x80){
+ goto failure;
} else {
uv = (uv << 6) | (*s++ & 0x3f);
}
@@ -463,7 +463,7 @@
OUTPUT:
RETVAL
-int
+int
WARN_ON_ERR()
CODE:
RETVAL = ENCODE_WARN_ON_ERR;
==== //depot/perl/ext/PerlIO/PerlIO.t#8 (text) ====
Index: perl/ext/PerlIO/PerlIO.t
--- perl/ext/PerlIO/PerlIO.t.~1~ Sun Apr 28 09:30:05 2002
+++ perl/ext/PerlIO/PerlIO.t Sun Apr 28 09:30:05 2002
@@ -2,7 +2,7 @@
chdir 't' if -d 't';
@INC = '../lib';
require Config; import Config;
- unless ($Config{'useperlio'}) {
+ unless (find PerlIO::Layer 'perlio') {
print "1..0 # Skip: PerlIO not used\n";
exit 0;
}
==== //depot/perl/ext/PerlIO/Via/Via.xs#13 (text) ====
Index: perl/ext/PerlIO/Via/Via.xs
--- perl/ext/PerlIO/Via/Via.xs.~1~ Sun Apr 28 09:30:05 2002
+++ perl/ext/PerlIO/Via/Via.xs Sun Apr 28 09:30:05 2002
@@ -76,7 +76,9 @@
IV count;
dSP;
SV *arg;
+ PUSHSTACKi(PERLSI_MAGIC);
ENTER;
+ SPAGAIN;
PUSHMARK(sp);
XPUSHs(s->obj);
while ((arg = va_arg(ap,SV *)))
@@ -113,6 +115,7 @@
result = &PL_sv_undef;
}
LEAVE;
+ POPSTACK;
}
va_end(ap);
return result;
==== //depot/perl/ext/PerlIO/encoding/encoding.pm#8 (text) ====
Index: perl/ext/PerlIO/encoding/encoding.pm
--- perl/ext/PerlIO/encoding/encoding.pm.~1~ Sun Apr 28 09:30:05 2002
+++ perl/ext/PerlIO/encoding/encoding.pm Sun Apr 28 09:30:05 2002
@@ -1,18 +1,19 @@
package PerlIO::encoding;
use strict;
-our $VERSION = '0.05';
+our $VERSION = '0.06';
our $DEBUG = 0;
$DEBUG and warn __PACKAGE__, " called by ", join(", ", caller), "\n";
#
-# Equivalent of these are done in encoding.xs - do not uncomment them.
+# Equivalent of this is done in encoding.xs - do not uncomment.
#
# use Encode ();
-# our $check;
use XSLoader ();
XSLoader::load(__PACKAGE__, $VERSION);
+our $fallback = Encode::PERLQQ()|Encode::WARN_ON_ERR;
+
1;
__END__
==== //depot/perl/ext/PerlIO/encoding/encoding.xs#11 (text) ====
Index: perl/ext/PerlIO/encoding/encoding.xs
--- perl/ext/PerlIO/encoding/encoding.xs.~1~ Sun Apr 28 09:30:05 2002
+++ perl/ext/PerlIO/encoding/encoding.xs Sun Apr 28 09:30:05 2002
@@ -49,7 +49,7 @@
} PerlIOEncode;
#define NEEDS_LINES 1
-#define OUR_DEFAULT_FB "Encode::FB_QUIET"
+#define OUR_DEFAULT_FB "Encode::PERLQQ"
SV *
PerlIOEncode_getarg(pTHX_ PerlIO * f, CLONE_PARAMS * param, int flags)
@@ -58,6 +58,9 @@
SV *sv = &PL_sv_undef;
if (e->enc) {
dSP;
+ /* Not 100% sure stack swap is right thing to do during dup ... */
+ PUSHSTACKi(PERLSI_MAGIC);
+ SPAGAIN;
ENTER;
SAVETMPS;
PUSHMARK(sp);
@@ -68,6 +71,9 @@
sv = newSVsv(POPs);
PUTBACK;
}
+ FREETMPS;
+ LEAVE;
+ POPSTACK;
}
return sv;
}
@@ -80,6 +86,9 @@
IV code = PerlIOBuf_pushed(aTHX_ f, mode, Nullsv);
SV *result = Nullsv;
+ PUSHSTACKi(PERLSI_MAGIC);
+ SPAGAIN;
+
ENTER;
SAVETMPS;
@@ -136,10 +145,11 @@
PerlIOBase(f)->flags |= PERLIO_F_UTF8;
}
- e->chk = newSVsv(get_sv("PerlIO::encoding::check", 0));
+ e->chk = newSVsv(get_sv("PerlIO::encoding::fallback", 0));
FREETMPS;
LEAVE;
+ POPSTACK;
return code;
}
@@ -224,6 +234,8 @@
Perl_die(aTHX_ "panic: cannot push :perlio for %p",f);
}
}
+ PUSHSTACKi(PERLSI_MAGIC);
+ SPAGAIN;
ENTER;
SAVETMPS;
retry:
@@ -363,18 +375,19 @@
PerlIO_set_ptrcnt(n, ptr+use, (avail-use));
goto retry;
}
- FREETMPS;
- LEAVE;
- return code;
}
else {
end_of_file:
+ code = -1;
if (avail == 0)
PerlIOBase(f)->flags |= PERLIO_F_EOF;
else
PerlIOBase(f)->flags |= PERLIO_F_ERROR;
- return -1;
}
+ FREETMPS;
+ LEAVE;
+ POPSTACK;
+ return code;
}
IV
@@ -391,6 +404,8 @@
SSize_t count = 0;
if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) {
/* Write case encode the buffer and write() to layer below */
+ PUSHSTACKi(PERLSI_MAGIC);
+ SPAGAIN;
ENTER;
SAVETMPS;
PUSHMARK(sp);
@@ -413,6 +428,7 @@
}
FREETMPS;
LEAVE;
+ POPSTACK;
if (PerlIO_flush(PerlIONext(f)) != 0) {
code = -1;
}
@@ -437,6 +453,8 @@
/* Bother - have unread data.
re-encode and unread() to layer below
*/
+ PUSHSTACKi(PERLSI_MAGIC);
+ SPAGAIN;
ENTER;
SAVETMPS;
str = sv_newmortal();
@@ -464,6 +482,7 @@
}
FREETMPS;
LEAVE;
+ POPSTACK;
}
}
e->base.ptr = e->base.end = e->base.buf;
@@ -588,12 +607,14 @@
BOOT:
{
- SV *chk = get_sv("PerlIO::encoding::check", GV_ADD|GV_ADDMULTI);
+ SV *chk = get_sv("PerlIO::encoding::fallback", GV_ADD|GV_ADDMULTI);
/*
* we now "use Encode ()" here instead of
* PerlIO/encoding.pm. This avoids SEGV when ":encoding()"
* is invoked without prior "use Encode". -- dankogai
*/
+ PUSHSTACKi(PERLSI_MAGIC);
+ SPAGAIN;
if (!gv_stashpvn("Encode", 6, FALSE)) {
#if 0
/* This would just be an irritant now loading works */
@@ -607,6 +628,7 @@
SPAGAIN;
LEAVE;
}
+#ifdef PERLIO_LAYERS
PUSHMARK(sp);
PUTBACK;
if (call_pv(OUR_DEFAULT_FB, G_SCALAR) != 1) {
@@ -616,7 +638,7 @@
SPAGAIN;
sv_setsv(chk, POPs);
PUTBACK;
-#ifdef PERLIO_LAYERS
PerlIO_define_layer(aTHX_ &PerlIO_encode);
#endif
+ POPSTACK;
}
==== //depot/perl/lib/open.t#17 (text) ====
Index: perl/lib/open.t
--- perl/lib/open.t.~1~ Sun Apr 28 09:30:05 2002
+++ perl/lib/open.t Sun Apr 28 09:30:05 2002
@@ -18,11 +18,11 @@
# this should fail
eval { import() };
-like( $@, qr/needs explicit list of disciplines/,
+like( $@, qr/needs explicit list of disciplines/,
'import should fail without args' );
# the hint bits shouldn't be set yet
-is( $^H & $open::hint_bits, 0,
+is( $^H & $open::hint_bits, 0,
'hint bits should not be set in $^H before open import' );
# prevent it from loading I18N::Langinfo, so we can test encoding failures
@@ -39,11 +39,11 @@
$warn = '';
eval q{ use warnings 'layer'; use open IN => ':macguffin' ; };
-like( $warn, qr/Unknown discipline layer/,
+like( $warn, qr/Unknown discipline layer/,
'should warn about unknown discipline with bad discipline provided' );
SKIP: {
- skip("no perlio, no :utf8", 1) unless $Config{useperlio};
+ skip("no perlio, no :utf8", 1) unless (find PerlIO::Layer 'perlio');
# now load a real-looking locale
$ENV{LC_ALL} = ' .utf8';
import( 'IN', 'locale' );
@@ -53,7 +53,7 @@
# and see if it sets the magic variables appropriately
import( 'IN', ':crlf' );
-ok( $^H & $open::hint_bits,
+ok( $^H & $open::hint_bits,
'hint bits should be set in $^H after open import' );
is( $^H{'open_IN'}, 'crlf', 'should have set crlf layer' );
@@ -72,7 +72,7 @@
is( $^H{'open_IO'}, 'crlf', 'should record last layer set in %^H' );
SKIP: {
- skip("no perlio, no :utf8", 4) unless $Config{'useperlio'};
+ skip("no perlio, no :utf8", 4) unless (find PerlIO::Layer 'perlio');
eval <<EOE;
use open ':utf8';
==== //depot/perl/lib/warnings.t#10 (text) ====
Index: perl/lib/warnings.t
--- perl/lib/warnings.t.~1~ Sun Apr 28 09:30:05 2002
+++ perl/lib/warnings.t Sun Apr 28 09:30:05 2002
@@ -31,7 +31,7 @@
foreach my $file (@w_files) {
next if $file =~ /(~|\.orig|,v)$/;
- next if $file =~ /perlio$/ && !$Config{useperlio};
+ next if $file =~ /perlio$/ && !(find PerlIO::Layer 'perlio');
open F, "<$file" or die "Cannot open $file: $!\n" ;
my $line = 0;
@@ -132,7 +132,7 @@
foreach my $option (split(' ', $1)) {
if ($option eq 'regex') { # allow regular expressions
$option_regex = 1;
- }
+ }
elsif ($option eq 'random') { # all lines match, but in any order
$option_random = 1;
}
==== //depot/perl/t/io/binmode.t#4 (text) ====
Index: perl/t/io/binmode.t
--- perl/t/io/binmode.t.~1~ Sun Apr 28 09:30:05 2002
+++ perl/t/io/binmode.t Sun Apr 28 09:30:05 2002
@@ -11,20 +11,20 @@
plan(tests => 8);
ok( binmode(STDERR), 'STDERR made binary' );
-if ($Config{useperlio}) {
+if (find PerlIO::Layer 'perlio') {
ok( binmode(STDERR, ":unix"), ' with unix discipline' );
} else {
- ok(1, ' skip unix discipline for -Uuseperlio' );
+ ok(1, ' skip unix discipline without PerlIO layers' );
}
ok( binmode(STDERR, ":raw"), ' raw' );
ok( binmode(STDERR, ":crlf"), ' and crlf' );
# If this one fails, we're in trouble. So we just bail out.
ok( binmode(STDOUT), 'STDOUT made binary' ) || exit(1);
-if ($Config{useperlio}) {
+if (find PerlIO::Layer 'perlio') {
ok( binmode(STDOUT, ":unix"), ' with unix discipline' );
} else {
- ok(1, ' skip unix discipline for -Uuseperlio' );
+ ok(1, ' skip unix discipline without PerlIO layers' );
}
ok( binmode(STDOUT, ":raw"), ' raw' );
ok( binmode(STDOUT, ":crlf"), ' and crlf' );
==== //depot/perl/t/io/crlf.t#3 (text) ====
Index: perl/t/io/crlf.t
--- perl/t/io/crlf.t.~1~ Sun Apr 28 09:30:05 2002
+++ perl/t/io/crlf.t Sun Apr 28 09:30:05 2002
@@ -14,7 +14,7 @@
unlink($file);
}
-if ($Config{useperlio}) {
+if (find PerlIO::Layer 'perlio') {
plan(tests => 6);
ok(open(FOO,">:crlf",$file));
ok(print FOO 'a'.((('a' x 14).qq{\n}) x 2000) || close(FOO));
==== //depot/perl/ext/PerlIO/t/fallback.t#1 (text) ====
Index: perl/ext/PerlIO/t/fallback.t
--- perl/ext/PerlIO/t/fallback.t.~1~ Sun Apr 28 09:30:05 2002
+++ perl/ext/PerlIO/t/fallback.t Sun Apr 28 09:30:05 2002
@@ -0,0 +1,63 @@
+#!./perl
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require "../t/test.pl";
+ skip_all("No perlio") unless (find PerlIO::Layer 'perlio');
+ plan (8);
+}
+use Encode qw(:fallback_all);
+
+# $PerlIO::encoding = 0; # WARN_ON_ERR|PERLQQ;
+
+my $file = "fallback$$.txt";
+
+$PerlIO::encoding::fallback = Encode::PERLQQ;
+
+ok(open(my $fh,">encoding(iso-8859-1)",$file),"opened iso-8859-1 file");
+my $str = "\x{20AC}";
+print $fh $str,"0.02\n";
+close($fh);
+
+open($fh,$file) || die "File cannot be re-opened";
+my $line = <$fh>;
+is($line,"\\x{20ac}0.02\n","perlqq escapes");
+close($fh);
+
+$PerlIO::encoding::fallback = Encode::HTMLCREF;
+
+ok(open(my $fh,">encoding(iso-8859-1)",$file),"opened iso-8859-1 file");
+my $str = "\x{20AC}";
+print $fh $str,"0.02\n";
+close($fh);
+
+open($fh,$file) || die "File cannot be re-opened";
+my $line = <$fh>;
+is($line,"€0.02\n","HTML escapes");
+close($fh);
+
+open($fh,">$file") || die "File cannot be re-opened";
+print $fh "�0.02\n";
+close($fh);
+
+ok(open($fh,"<encoding(US-ASCII)",$file),"Opened as ASCII");
+my $line = <$fh>;
+printf "# %x\n",ord($line);
+is($line,"\\xA30.02\n","Escaped non-mapped char");
+close($fh);
+
+$PerlIO::encoding::fallback = Encode::WARN_ON_ERROR;
+
+ok(open($fh,"<encoding(US-ASCII)",$file),"Opened as ASCII");
+my $line = <$fh>;
+printf "# %x\n",ord($line);
+is($line,"\x{FFFD}0.02\n","Unicode replacement char");
+close($fh);
+
+END {
+# unlink($file);
+}
+
+
+
End of Patch.
