diff options
| author | Nick Ing-Simmons <nik@tiuk.ti.com> | 2002-04-26 17:36:16 +0000 |
|---|---|---|
| committer | Nick Ing-Simmons <nik@tiuk.ti.com> | 2002-04-26 17:36:16 +0000 |
| commit | 5f228b1d3feafe3247efca23709f3c7bd5daf91b (patch) | |
| tree | f917a045995abe71f5d8c726bebf6768680e3d73 | |
| parent | 2583bd17aea1ca96fac50929c91872157a7782b3 (diff) | |
| parent | cb5780feb6b3d31503eb651fb2d3d543cc89f6c6 (diff) | |
| download | perl-5f228b1d3feafe3247efca23709f3c7bd5daf91b.tar.gz | |
Integrate mainline
p4raw-id: //depot/perlio@16194
106 files changed, 3975 insertions, 773 deletions
@@ -28,6 +28,900 @@ example from http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/ Version v5.7.X Development release working toward v5.8 -------------- ____________________________________________________________________________ +[ 16187] By: jhi on 2002/04/26 12:43:48 + Log: Subject: [Encode] s/=over2/=over 2/g + From: Dan Kogai <dankogai@dan.co.jp> + Date: Fri, 26 Apr 2002 14:57:09 +0900 + Message-Id: <721D1832-58DA-11D6-A636-00039301D480@dan.co.jp> + Branch: perl + ! ext/Encode/Encode.pm +____________________________________________________________________________ +[ 16186] By: jhi on 2002/04/26 12:28:18 + Log: Use temp int variable in the W*() since direct casting + to either an int or an IV would not be right. + Branch: perl + ! ext/POSIX/POSIX.xs +____________________________________________________________________________ +[ 16185] By: jhi on 2002/04/26 12:23:02 + Log: The #16182 radiates U32ness. + Branch: perl + ! embed.fnc embed.h proto.h regcomp.c toke.c +____________________________________________________________________________ +[ 16184] By: jhi on 2002/04/26 12:00:04 + Log: Subject: t/TEST ported to VMS + From: "Craig A. Berry" <craigberry@mac.com> + Date: Fri, 26 Apr 2002 00:13:31 -0500 + Message-Id: <a05111705b8ee84f53e79@[172.16.52.1]> + Branch: perl + ! t/TEST +____________________________________________________________________________ +[ 16183] By: jhi on 2002/04/26 11:57:58 + Log: Stop being coy. + Branch: perl + ! pod/perldelta.pod +____________________________________________________________________________ +[ 16182] By: jhi on 2002/04/26 11:53:58 + Log: Subject: Re: binary compatibility + From: Mark-Jason Dominus <mjd@plover.com> + Date: Wed, 24 Apr 2002 17:35:07 -0400 + Message-ID: <20020424213507.7846.qmail@plover.com> + Branch: perl + ! op.h +____________________________________________________________________________ +[ 16181] By: gsar on 2002/04/26 07:39:20 + Log: fix typo that caused pseudo-fork() crashes on win64 (we were only + allocating half of the retstack!) + Branch: perl + ! README.win32 sv.c +____________________________________________________________________________ +[ 16180] By: gsar on 2002/04/26 06:27:11 + Log: temporary variable not wide enough to hold all the bits in + op->op_targ + Branch: perl + ! op.c +____________________________________________________________________________ +[ 16179] By: jhi on 2002/04/26 03:21:50 + Log: Add an idea/question from Damian. + Branch: perl + ! pod/perltodo.pod +____________________________________________________________________________ +[ 16178] By: gsar on 2002/04/26 02:46:52 + Log: build missing utilities on windows; clean stray files + Branch: perl + ! win32/Makefile win32/makefile.mk +____________________________________________________________________________ +[ 16177] By: jhi on 2002/04/26 02:33:19 + Log: Upgrade to Encode 1.61, from Dan Kogai. + Branch: perl + ! ext/Encode/AUTHORS ext/Encode/Changes ext/Encode/Encode.pm + ! ext/Encode/Encode.xs ext/Encode/Unicode/Unicode.xs + ! ext/Encode/lib/Encode/Guess.pm + ! ext/Encode/lib/Encode/MIME/Header.pm ext/Encode/t/CJKT.t + ! ext/Encode/t/guess.t ext/Encode/t/jperl.t + ! ext/Encode/t/mime-header.t +____________________________________________________________________________ +[ 16176] By: jhi on 2002/04/26 01:22:04 + Log: Subject: [PATCH doc] bytes::length TIMTOWTDI + From: andreas.koenig@anima.de (Andreas J. Koenig) + Date: Tue, 23 Apr 2002 04:40:42 +0200 + Message-ID: <m37kmzi1cl.fsf@anima.de> + Branch: perl + ! pod/perluniintro.pod +____________________________________________________________________________ +[ 16175] By: gsar on 2002/04/26 01:10:17 + Log: MD5.xs checksum, ascii only (TODO: someone with access to an EBCDIC + platform needs to fill in the other branch here) + Branch: perl + ! ext/Digest/MD5/t/files.t +____________________________________________________________________________ +[ 16174] By: gsar on 2002/04/26 00:45:36 + Log: MANIFEST is needlessly held open for entire duration of "make test" + Branch: perl + ! t/TEST t/harness +____________________________________________________________________________ +[ 16173] By: gsar on 2002/04/26 00:41:39 + Log: various signed/unsigned mismatch nits + Branch: perl + ! ext/B/B.xs ext/ByteLoader/ByteLoader.xs + ! ext/Data/Dumper/Dumper.xs ext/Devel/DProf/DProf.xs + ! ext/Digest/MD5/MD5.xs ext/Encode/Unicode/Unicode.xs + ! ext/File/Glob/bsd_glob.c ext/IO/IO.xs ext/Opcode/Opcode.xs + ! ext/PerlIO/encoding/encoding.xs ext/Storable/Storable.xs + ! ext/Time/HiRes/HiRes.xs regcomp.c +____________________________________________________________________________ +[ 16172] By: jhi on 2002/04/25 23:48:03 + Log: Subject: [PATCH] Re: [PATCH] another Storable test (Re: perl@16005) + From: Nicholas Clark <nick@unfortu.net> + Date: Thu, 25 Apr 2002 22:41:57 +0100 + Message-ID: <20020425214156.GB295@Bagpuss.unfortu.net> + Branch: perl + + ext/Storable/t/croak.t ext/Storable/t/downgrade.t + + ext/Storable/t/make_downgrade.pl + ! MANIFEST ext/Storable/Storable.pm ext/Storable/Storable.xs + ! ext/Storable/t/malice.t ext/Storable/t/restrict.t + ! ext/Storable/t/utf8hash.t +____________________________________________________________________________ +[ 16171] By: jhi on 2002/04/25 22:16:49 + Log: Extra guidance for JAPH debuggers. + Branch: perl + ! t/japh/abigail.t +____________________________________________________________________________ +[ 16170] By: jhi on 2002/04/25 22:13:02 + Log: Subject: [PATCH] fix vos/vos.c to implement pow(0,0) + From: Paul_GreenVOS@vos.stratus.com + Date: Wed, 24 Apr 02 18:27 edt + Message-Id: <200204242252.SAA07978@mailhub1.stratus.com> + Branch: perl + ! vos/vos.c +____________________________________________________________________________ +[ 16169] By: ams on 2002/04/25 20:33:35 + Log: Subject: [PATCH] don't build B/C twice on VMS + From: "Craig A. Berry" <craigberry@mac.com> + Date: Thu, 25 Apr 2002 16:00:57 -0500 + Message-Id: <a05111702b8ee1bab9144@[172.16.52.1]> + Branch: perl + ! configure.com +____________________________________________________________________________ +[ 16168] By: ams on 2002/04/25 20:31:19 + Log: Subject: Re: POSIX::WEXITSTATUS broken again + From: Andy Dougherty <doughera@lafayette.edu> + Date: Thu, 25 Apr 2002 17:01:08 -0400 (EDT) + Message-Id: <Pine.SOL.4.10.10204251656510.2019-100000@maxwell.phys.lafayette.edu> + Branch: perl + ! ext/POSIX/POSIX.xs +____________________________________________________________________________ +[ 16167] By: ams on 2002/04/25 19:49:09 + Log: Subject: [PATCH] Re: [PATCH] ext/attrs.t getting skipped + From: sthoenna@efn.org (Yitzchak Scott-Thoennes) + Date: Thu, 25 Apr 2002 13:39:35 -0700 + Message-Id: <HmGy8gzkguHW092yn@efn.org> + Branch: perl + ! t/harness +____________________________________________________________________________ +[ 16166] By: ams on 2002/04/25 19:43:06 + Log: $fh->close(); print $fh "foo" would segfault under -w in + report_evil_fh() because $fh doesn't have a name. + Branch: perl + ! util.c +____________________________________________________________________________ +[ 16165] By: gsar on 2002/04/25 18:19:32 + Log: cwd.t wasn't running all the tests because cmd.exe wasn't + being found properly + Branch: perl + ! ext/Cwd/t/cwd.t +____________________________________________________________________________ +[ 16164] By: jhi on 2002/04/25 17:45:03 + Log: Brace yourself from Craig Berry to keep older compilers happy. + Branch: perl + ! vms/vms.c +____________________________________________________________________________ +[ 16163] By: jhi on 2002/04/25 17:43:50 + Log: More %{} overload tests. + Branch: perl + ! lib/overload.t +____________________________________________________________________________ +[ 16162] By: gsar on 2002/04/25 17:41:48 + Log: some extension builds need to find pl2bat.bat on windows + Branch: perl + ! win32/buildext.pl +____________________________________________________________________________ +[ 16161] By: jhi on 2002/04/25 17:26:53 + Log: Subject: [PATCH MM 5.91_02] MM_VMS.pm: handle empty PM_TO_BLIB + From: "Craig A. Berry" <craigberry@mac.com> + Date: Thu, 25 Apr 2002 12:30:06 -0500 + Message-Id: <a05111700b8edeb2f3419@[172.16.52.1]> + Branch: perl + ! lib/ExtUtils/MM_VMS.pm +____________________________________________________________________________ +[ 16160] By: gsar on 2002/04/25 17:04:10 + Log: windows build fails if there is no perlglob.exe in the PATH + Branch: perl + ! win32/buildext.pl +____________________________________________________________________________ +[ 16159] By: jhi on 2002/04/25 16:06:25 + Log: Mysterious setlocale() core dump in ancient Solaris + found by Merijn Broeren. Doesn't look like Perl's fault. + Branch: perl + ! pod/perldelta.pod +____________________________________________________________________________ +[ 16158] By: jhi on 2002/04/25 14:38:13 + Log: Subject: Re: [PATCH] pp_ctl.c:pp_require + From: "Newton, Philip" <Philip.Newton@datenrevision.de> + Date: Thu, 25 Apr 2002 17:35:23 +0200 + Message-ID: <C9A98F2128EDD411B0920008C7B337A13DCC77@hamsem01.de.gedas.vwg> + Branch: perl + ! pp_ctl.c +____________________________________________________________________________ +[ 16157] By: jhi on 2002/04/25 14:30:40 + Log: Subject: [PATCH] pp_ctl.c:pp_require + From: "Newton, Philip" <Philip.Newton@datenrevision.de> + Date: Thu, 25 Apr 2002 16:01:14 +0200 + Message-ID: <C9A98F2128EDD411B0920008C7B337A13DCC76@hamsem01.de.gedas.vwg> + Branch: perl + ! pp_ctl.c +____________________________________________________________________________ +[ 16156] By: jhi on 2002/04/25 14:29:16 + Log: -Wformat cleanups from Robin Barker. + Branch: perl + ! dump.c embed.fnc proto.h sv.c +____________________________________________________________________________ +[ 16155] By: jhi on 2002/04/25 14:27:07 + Log: Subject: [PATCH] Test::Harness 2.01 -> 2.03 + From: Michael G Schwern <schwern@pobox.com> + Date: Thu, 25 Apr 2002 01:51:27 -0400 + Message-ID: <20020425055127.GB3456@blackrider> + Branch: perl + + t/lib/sample-tests/bignum t/lib/sample-tests/die + + t/lib/sample-tests/die_head_end + + t/lib/sample-tests/die_last_minute + ! MANIFEST lib/Test/Harness.pm lib/Test/Harness/Changes + ! lib/Test/Harness/Straps.pm lib/Test/Harness/t/strap-analyze.t + ! lib/Test/Harness/t/test-harness.t t/lib/sample-tests/taint +____________________________________________________________________________ +[ 16154] By: jhi on 2002/04/25 14:24:53 + Log: Subject: [PATCH] Test::Simple/More/Builder 0.42 -> 0.44 + From: Michael G Schwern <schwern@pobox.com> + Date: Thu, 25 Apr 2002 01:32:10 -0400 + Message-ID: <20020425053210.GA3334@blackrider> + Branch: perl + + lib/Test/Simple/t/curr_test.t lib/Test/Simple/t/maybe_regex.t + + lib/Test/Simple/t/strays.t + ! MANIFEST lib/Test/Builder.pm lib/Test/More.pm + ! lib/Test/Simple.pm lib/Test/Simple/Changes + ! lib/Test/Simple/t/Builder.t lib/Test/Simple/t/More.t + ! lib/Test/Simple/t/diag.t lib/Test/Simple/t/exit.t + ! lib/Test/Simple/t/output.t lib/Test/Simple/t/undef.t + ! lib/Test/Simple/t/use_ok.t +____________________________________________________________________________ +[ 16153] By: jhi on 2002/04/25 14:12:35 + Log: Elaborate a bit on Storable. + Branch: perl + ! pod/perldelta.pod +____________________________________________________________________________ +[ 16152] By: jhi on 2002/04/25 12:59:50 + Log: Cleaner Encode tests under -Mutf8. + Branch: perl + ! ext/Encode/t/at-cn.t ext/Encode/t/at-tw.t ext/Encode/t/jperl.t +____________________________________________________________________________ +[ 16151] By: jhi on 2002/04/25 00:57:24 + Log: Subject: [PATCH] installperl + From: Abe Timmerman <abe@ztreet.demon.nl> + Date: Thu, 25 Apr 2002 01:00:00 +0200 + Message-ID: <50eecu0f6jd5vji7s0smqnjbid2e1p0ilk@4ax.com> + Branch: perl + ! installperl +____________________________________________________________________________ +[ 16150] By: jhi on 2002/04/25 00:48:09 + Log: Subject: Re: [Encode] Patch to fix Encod-XML::SAX conflicts + From: Dan Kogai <dankogai@dan.co.jp> + Date: Thu, 25 Apr 2002 10:49:13 +0900 + Message-Id: <A4F06B9C-57EE-11D6-A6E0-00039301D480@dan.co.jp> + Branch: perl + ! ext/PerlIO/encoding/encoding.xs +____________________________________________________________________________ +[ 16149] By: jhi on 2002/04/24 22:57:53 + Log: Stray =back. + Branch: perl + ! README.win32 +____________________________________________________________________________ +[ 16148] By: rgs on 2002/04/24 21:12:40 + Log: Add an untested warning variant. + Branch: perl + ! t/lib/warnings/op +____________________________________________________________________________ +[ 16147] By: jhi on 2002/04/24 20:37:15 + Log: Update Changes. + Branch: perl + ! Changes patchlevel.h +____________________________________________________________________________ +[ 16146] By: jhi on 2002/04/24 20:21:43 + Log: Wrong plan. + Branch: perl + ! ext/Encode/t/mime-header.t +____________________________________________________________________________ +[ 16145] By: jhi on 2002/04/24 20:20:53 + Log: Upgrade to Encode 1.60, from Dan Kogai. + Branch: perl + + ext/Encode/lib/Encode/Guess.pm + + ext/Encode/lib/Encode/MIME/Header.pm ext/Encode/t/guess.t + + ext/Encode/t/mime-header.t + ! MANIFEST ext/Encode/CN/Makefile.PL ext/Encode/Changes + ! ext/Encode/Encode.pm ext/Encode/Encode.xs + ! ext/Encode/Encode/encode.h ext/Encode/JP/Makefile.PL + ! ext/Encode/KR/Makefile.PL ext/Encode/MANIFEST + ! ext/Encode/TW/Makefile.PL ext/Encode/lib/Encode/Config.pm + ! ext/Encode/lib/Encode/JP/JIS7.pm ext/Encode/t/fallback.t +____________________________________________________________________________ +[ 16144] By: gsar on 2002/04/24 18:59:05 + Log: another case of enabling binmode() where it should not be: if the + *.enc files are CRLF terminated, the result gets CRCRLF terminations + Branch: perl + ! ext/Encode/t/CJKT.t +____________________________________________________________________________ +[ 16143] By: jhi on 2002/04/24 18:34:27 + Log: microperl update; boldly assume time() and time_t + (since we assume ANSI and i_time, anyway). + Branch: perl + ! uconfig.h uconfig.sh +____________________________________________________________________________ +[ 16142] By: jhi on 2002/04/24 18:30:14 + Log: Integrate #16136, #16137, #16138 from macperl; + + Silly fix for the SC compiler's fixation with "comp" as a type + + Skip more PerlIO symbols for sfio + + Play nicely in miniperl + Branch: perl + !> ext/Unicode/Normalize/Normalize.xs lib/File/Copy.pm + !> lib/File/Spec/Mac.pm makedef.pl +____________________________________________________________________________ +[ 16141] By: pudge on 2002/04/24 18:15:19 + Log: Sync configpm and config.h for use in 5.8 + (still need to do config.sh) + Branch: macperl + ! macos/config.h macos/configpm +____________________________________________________________________________ +[ 16140] By: pudge on 2002/04/24 18:14:05 + Log: Make MM_MacOS work with new MakeMaker + Branch: macperl + ! macos/lib/ExtUtils/MM_MacOS.pm +____________________________________________________________________________ +[ 16139] By: pudge on 2002/04/24 18:13:34 + Log: Makefile.mk changes for 5.8: additional extensions + and source files; bump version + Branch: macperl + ! macos/MPVersion.r macos/Makefile.mk macos/macperl/Makefile.mk +____________________________________________________________________________ +[ 16138] By: pudge on 2002/04/24 18:12:22 + Log: Play nicely in miniperl + Branch: macperl + ! lib/File/Copy.pm lib/File/Spec/Mac.pm +____________________________________________________________________________ +[ 16137] By: pudge on 2002/04/24 18:10:34 + Log: Skip more PerlIO symbols for sfio + Branch: macperl + ! makedef.pl +____________________________________________________________________________ +[ 16136] By: pudge on 2002/04/24 18:09:37 + Log: Silly fix for the SC compiler's fixation with "comp" as a type + Branch: macperl + ! ext/Unicode/Normalize/Normalize.xs +____________________________________________________________________________ +[ 16135] By: pudge on 2002/04/24 18:08:45 + Log: Merge macperl xsubpp with current xsubpp + Branch: macperl + ! macos/xsubpp +____________________________________________________________________________ +[ 16134] By: nick on 2002/04/24 18:08:37 + Log: Integrate mainline + Branch: perlio + +> lib/ExtUtils/t/00setup_dummy.t lib/ExtUtils/t/VERSION_FROM.t + +> lib/ExtUtils/t/backwards.t lib/ExtUtils/t/zz_cleanup_dummy.t + - lib/ExtUtils/t/Big-Fat-Dummy/Liar/Makefile.PL + - lib/ExtUtils/t/Big-Fat-Dummy/Liar/lib/Big/Fat/Liar.pm + - lib/ExtUtils/t/Big-Fat-Dummy/Makefile.PL + - lib/ExtUtils/t/Big-Fat-Dummy/lib/Big/Fat/Dummy.pm + - lib/ExtUtils/t/Problem-Module/Makefile.PL + - lib/ExtUtils/t/Problem-Module/subdir/Makefile.PL + !> (integrate 44 files) +____________________________________________________________________________ +[ 16133] By: pudge on 2002/04/24 18:05:50 + Log: Delete more included modules from bundled_ext + Branch: macperl + - macos/bundled_ext/Digest/MD5/Changes + - macos/bundled_ext/Digest/MD5/MD5.pm + - macos/bundled_ext/Digest/MD5/MD5.xs + - macos/bundled_ext/Digest/MD5/Makefile.PL + - macos/bundled_ext/Digest/MD5/Makefile.mk + - macos/bundled_ext/Digest/MD5/README + - macos/bundled_ext/Digest/MD5/hints/dec_osf.pl + - macos/bundled_ext/Digest/MD5/hints/irix_6.pl + - macos/bundled_ext/Digest/MD5/rfc1321.txt + - macos/bundled_ext/Digest/MD5/t/badfile.t + - macos/bundled_ext/Digest/MD5/t/files.t + - macos/bundled_ext/Digest/MD5/t/md5-aaa.t + - macos/bundled_ext/Digest/MD5/typemap + - macos/bundled_ext/Filter/Util/Call/Call.pm + - macos/bundled_ext/Filter/Util/Call/Call.xs + - macos/bundled_ext/Filter/Util/Call/Makefile.PL + - macos/bundled_ext/Filter/Util/Call/ppport.h + - macos/bundled_ext/Filter/t/call.t + - macos/bundled_ext/Filter/t/filter-util.pl + - macos/bundled_ext/List/Util/ChangeLog + - macos/bundled_ext/List/Util/Makefile.PL + - macos/bundled_ext/List/Util/README + - macos/bundled_ext/List/Util/Util.xs + - macos/bundled_ext/List/Util/lib/List/Util.pm + - macos/bundled_ext/List/Util/lib/Scalar/Util.pm + - macos/bundled_ext/List/Util/t/blessed.t + - macos/bundled_ext/List/Util/t/dualvar.t + - macos/bundled_ext/List/Util/t/first.t + - macos/bundled_ext/List/Util/t/max.t + - macos/bundled_ext/List/Util/t/maxstr.t + - macos/bundled_ext/List/Util/t/min.t + - macos/bundled_ext/List/Util/t/minstr.t + - macos/bundled_ext/List/Util/t/readonly.t + - macos/bundled_ext/List/Util/t/reduce.t + - macos/bundled_ext/List/Util/t/reftype.t + - macos/bundled_ext/List/Util/t/shuffle.t + - macos/bundled_ext/List/Util/t/sum.t + - macos/bundled_ext/List/Util/t/tainted.t + - macos/bundled_ext/List/Util/t/weak.t + - macos/bundled_ext/MIME/Base64/Base64.pm + - macos/bundled_ext/MIME/Base64/Base64.xs + - macos/bundled_ext/MIME/Base64/Changes + - macos/bundled_ext/MIME/Base64/Makefile.PL + - macos/bundled_ext/MIME/Base64/QuotedPrint.pm + - macos/bundled_ext/MIME/Base64/README + - macos/bundled_ext/MIME/Base64/t/base64.t + - macos/bundled_ext/MIME/Base64/t/quoted-print.t + - macos/bundled_ext/MIME/Base64/t/unicode.t + - macos/bundled_ext/Storable/ChangeLog + - macos/bundled_ext/Storable/Makefile.PL + - macos/bundled_ext/Storable/README + - macos/bundled_ext/Storable/Storable.pm + - macos/bundled_ext/Storable/Storable.xs + - macos/bundled_ext/Storable/t/blessed.t + - macos/bundled_ext/Storable/t/canonical.t + - macos/bundled_ext/Storable/t/compat-0.6.t + - macos/bundled_ext/Storable/t/dclone.t + - macos/bundled_ext/Storable/t/dump.pl + - macos/bundled_ext/Storable/t/forgive.t + - macos/bundled_ext/Storable/t/freeze.t + - macos/bundled_ext/Storable/t/lock.t + - macos/bundled_ext/Storable/t/overload.t + - macos/bundled_ext/Storable/t/recurse.t + - macos/bundled_ext/Storable/t/retrieve.t + - macos/bundled_ext/Storable/t/store.t + - macos/bundled_ext/Storable/t/tied.t + - macos/bundled_ext/Storable/t/tied_hook.t + - macos/bundled_ext/Storable/t/tied_items.t + - macos/bundled_ext/Storable/t/utf8.t + - macos/bundled_ext/Time/HiRes/Changes + - macos/bundled_ext/Time/HiRes/HiRes.pm + - macos/bundled_ext/Time/HiRes/HiRes.t + - macos/bundled_ext/Time/HiRes/HiRes.xs + - macos/bundled_ext/Time/HiRes/Makefile.PL + - macos/bundled_ext/Time/HiRes/hints/dynixptx.pl + - macos/bundled_ext/Time/HiRes/hints/sco.pl +____________________________________________________________________________ +[ 16132] By: jhi on 2002/04/24 17:03:22 + Log: Thou shalt not assume %x works for UVs. + Branch: perl + ! ext/Encode/Encode.xs +____________________________________________________________________________ +[ 16131] By: nick on 2002/04/24 15:50:31 + Log: Submit an old integrate + Branch: perlio + +> (branch 27 files) + - ext/Encode/t/CN.t ext/Encode/t/JP.t ext/Encode/t/KR.t + - ext/Encode/t/TW.t ext/Encode/t/bogus.ucm + - ext/Encode/t/gb2312.euc ext/Encode/t/gb2312.ref + - ext/Encode/t/jisx0201.euc ext/Encode/t/jisx0201.ref + - ext/Encode/t/jisx0208.euc ext/Encode/t/jisx0208.ref + - ext/Encode/t/jisx0212.euc ext/Encode/t/jisx0212.ref + - ext/Encode/t/ksc5601.euc ext/Encode/t/ksc5601.ref + !> (integrate 84 files) +____________________________________________________________________________ +[ 16130] By: jhi on 2002/04/24 15:38:12 + Log: Partially retract #12056, from Craig Berry. + Branch: perl + ! vms/vms.c +____________________________________________________________________________ +[ 16129] By: pudge on 2002/04/24 14:37:10 + Log: Delete more included modules from bundled_lib + Branch: macperl + - macos/bundled_lib/blib/lib/Class/ISA.pm + - macos/bundled_lib/blib/lib/Digest.pm + - macos/bundled_lib/blib/lib/Filter/Simple.pm + - macos/bundled_lib/blib/lib/Memoize.pm + - macos/bundled_lib/blib/lib/Memoize/AnyDBM_File.pm + - macos/bundled_lib/blib/lib/Memoize/Expire.pm + - macos/bundled_lib/blib/lib/Memoize/ExpireFile.pm + - macos/bundled_lib/blib/lib/Memoize/ExpireTest.pm + - macos/bundled_lib/blib/lib/Memoize/NDBM_File.pm + - macos/bundled_lib/blib/lib/Memoize/SDBM_File.pm + - macos/bundled_lib/blib/lib/Memoize/Storable.pm + - macos/bundled_lib/blib/lib/NEXT.pm + - macos/bundled_lib/blib/lib/Net/Cmd.pm + - macos/bundled_lib/blib/lib/Net/Config.pm + - macos/bundled_lib/blib/lib/Net/Domain.pm + - macos/bundled_lib/blib/lib/Net/FTP.pm + - macos/bundled_lib/blib/lib/Net/FTP/A.pm + - macos/bundled_lib/blib/lib/Net/FTP/E.pm + - macos/bundled_lib/blib/lib/Net/FTP/I.pm + - macos/bundled_lib/blib/lib/Net/FTP/L.pm + - macos/bundled_lib/blib/lib/Net/FTP/dataconn.pm + - macos/bundled_lib/blib/lib/Net/HTTP/Methods.pm + - macos/bundled_lib/blib/lib/Net/HTTP/NB.pm + - macos/bundled_lib/blib/lib/Net/NNTP.pm + - macos/bundled_lib/blib/lib/Net/Netrc.pm + - macos/bundled_lib/blib/lib/Net/POP3.pm + - macos/bundled_lib/blib/lib/Net/SMTP.pm + - macos/bundled_lib/blib/lib/Net/Time.pm + - macos/bundled_lib/blib/lib/Net/libnetFAQ.pod + - macos/bundled_lib/blib/lib/Switch.pm + - macos/bundled_lib/t/Class/ISA/test.pl + - macos/bundled_lib/t/Digest/Digest.t + - macos/bundled_lib/t/Filter/Simple/ExportTest.pm + - macos/bundled_lib/t/Filter/Simple/FilterOnlyTest.pm + - macos/bundled_lib/t/Filter/Simple/FilterTest.pm + - macos/bundled_lib/t/Filter/Simple/ImportTest.pm + - macos/bundled_lib/t/Filter/Simple/data.t + - macos/bundled_lib/t/Filter/Simple/export.t + - macos/bundled_lib/t/Filter/Simple/filter.t + - macos/bundled_lib/t/Filter/Simple/filter_only.t + - macos/bundled_lib/t/Filter/Simple/import.t + - macos/bundled_lib/t/Memoize/array.t + - macos/bundled_lib/t/Memoize/array_confusion.t + - macos/bundled_lib/t/Memoize/correctness.t + - macos/bundled_lib/t/Memoize/errors.t + - macos/bundled_lib/t/Memoize/expire.t + - macos/bundled_lib/t/Memoize/expire_file.t + - macos/bundled_lib/t/Memoize/expire_module_n.t + - macos/bundled_lib/t/Memoize/expire_module_t.t + - macos/bundled_lib/t/Memoize/flush.t + - macos/bundled_lib/t/Memoize/normalize.t + - macos/bundled_lib/t/Memoize/prototype.t + - macos/bundled_lib/t/Memoize/speed.t + - macos/bundled_lib/t/Memoize/tie.t + - macos/bundled_lib/t/Memoize/tie_gdbm.t + - macos/bundled_lib/t/Memoize/tie_ndbm.t + - macos/bundled_lib/t/Memoize/tie_sdbm.t + - macos/bundled_lib/t/Memoize/tie_storable.t + - macos/bundled_lib/t/Memoize/tiefeatures.t + - macos/bundled_lib/t/Memoize/unmemoize.t + - macos/bundled_lib/t/NEXT/actual.t + - macos/bundled_lib/t/NEXT/actuns.t + - macos/bundled_lib/t/NEXT/next.t + - macos/bundled_lib/t/NEXT/unseen.t + - macos/bundled_lib/t/Switch/t/given.t + - macos/bundled_lib/t/Switch/t/nested.t + - macos/bundled_lib/t/Switch/t/switch.t + - macos/bundled_lib/t/libnet/config.t + - macos/bundled_lib/t/libnet/ftp.t + - macos/bundled_lib/t/libnet/hostname.t + - macos/bundled_lib/t/libnet/libnet_t.pl + - macos/bundled_lib/t/libnet/netrc.t + - macos/bundled_lib/t/libnet/nntp.t + - macos/bundled_lib/t/libnet/require.t + - macos/bundled_lib/t/libnet/smtp.t +____________________________________________________________________________ +[ 16128] By: pudge on 2002/04/24 14:18:55 + Log: Remove Text::Balanced from bundled_lib (already in lib) + Branch: macperl + - macos/bundled_lib/blib/lib/Text/Balanced.pm + - macos/bundled_lib/t/Text/Balanced/t/extbrk.t + - macos/bundled_lib/t/Text/Balanced/t/extcbk.t + - macos/bundled_lib/t/Text/Balanced/t/extdel.t + - macos/bundled_lib/t/Text/Balanced/t/extmul.t + - macos/bundled_lib/t/Text/Balanced/t/extqlk.t + - macos/bundled_lib/t/Text/Balanced/t/exttag.t + - macos/bundled_lib/t/Text/Balanced/t/extvar.t + - macos/bundled_lib/t/Text/Balanced/t/gentag.t +____________________________________________________________________________ +[ 16127] By: jhi on 2002/04/24 14:17:16 + Log: A word of warning to the users of UTF-8 locales. + Branch: perl + ! pod/perluniintro.pod +____________________________________________________________________________ +[ 16126] By: jhi on 2002/04/24 12:54:17 + Log: Forgotten from #16125. + Branch: perl + ! t/lib/MakeMaker/Test/Utils.pm +____________________________________________________________________________ +[ 16125] By: jhi on 2002/04/24 05:16:09 + Log: Upgrade to MakeMaker 5.91_02, from Michael Schwern. + Branch: perl + + lib/ExtUtils/t/00setup_dummy.t lib/ExtUtils/t/VERSION_FROM.t + + lib/ExtUtils/t/backwards.t lib/ExtUtils/t/zz_cleanup_dummy.t + - lib/ExtUtils/t/Big-Fat-Dummy/Liar/Makefile.PL + - lib/ExtUtils/t/Big-Fat-Dummy/Liar/lib/Big/Fat/Liar.pm + - lib/ExtUtils/t/Big-Fat-Dummy/Makefile.PL + - lib/ExtUtils/t/Big-Fat-Dummy/lib/Big/Fat/Dummy.pm + - lib/ExtUtils/t/Problem-Module/Makefile.PL + - lib/ExtUtils/t/Problem-Module/subdir/Makefile.PL + ! MANIFEST lib/ExtUtils/Changes lib/ExtUtils/Command/MM.pm + ! lib/ExtUtils/MM.pm lib/ExtUtils/MM_Cygwin.pm + ! lib/ExtUtils/MM_NW5.pm lib/ExtUtils/MM_Unix.pm + ! lib/ExtUtils/MM_VMS.pm lib/ExtUtils/MM_Win32.pm + ! lib/ExtUtils/MakeMaker.pm lib/ExtUtils/Manifest.pm + ! lib/ExtUtils/t/INST.t lib/ExtUtils/t/INST_PREFIX.t + ! lib/ExtUtils/t/MM_Unix.t lib/ExtUtils/t/Manifest.t + ! lib/ExtUtils/t/basic.t lib/ExtUtils/t/hints.t + ! lib/ExtUtils/t/prefixify.t lib/ExtUtils/t/problems.t +____________________________________________________________________________ +[ 16124] By: jhi on 2002/04/24 02:03:08 + Log: Subject: New UTF-8 surprise + From: andreas.koenig@anima.de (Andreas J. Koenig) + Date: Mon, 22 Apr 2002 12:08:48 +0200 + Message-ID: <m38z7gjb9r.fsf@anima.de> + Branch: perl + ! pp_hot.c t/op/subst.t +____________________________________________________________________________ +[ 16123] By: gsar on 2002/04/24 01:25:17 + Log: create a //depot/macperl/... branch with a //depot/macperl/macos/... + tree that is branched from //depot/maint-5.6/macperl/macos/... + Branch: macperl + +> (branch 3590 files) +____________________________________________________________________________ +[ 16122] By: jhi on 2002/04/23 23:52:11 + Log: Try to be clearer about perlio. + Branch: perl + ! INSTALL +____________________________________________________________________________ +[ 16121] By: jhi on 2002/04/23 23:45:41 + Log: Subject: Re: binary compatibility + From: Andy Dougherty <doughera@lafayette.edu> + Date: Tue, 23 Apr 2002 16:21:26 -0400 (EDT) + Message-ID: <Pine.SOL.4.10.10204231614020.754-100000@maxwell.phys.lafayette.edu> + Branch: perl + ! INSTALL patchlevel.h +____________________________________________________________________________ +[ 16120] By: jhi on 2002/04/23 23:41:52 + Log: Go on record about the binary backward incompatibility. + Branch: perl + ! pod/perldelta.pod +____________________________________________________________________________ +[ 16119] By: jhi on 2002/04/23 23:09:02 + Log: Subject: [PATCH] was: t/win32/system.t Borland too helpful + From: "Vadim Konovalov" <vkonovalov@peterstar.ru> + Date: Wed, 24 Apr 2002 01:51:43 +0400 + Message-ID: <006e01c1eb11$156d2390$695cc3d9@vad> + Branch: perl + ! t/win32/system.t +____________________________________________________________________________ +[ 16118] By: jhi on 2002/04/23 23:08:12 + Log: Subject: [PATCH: perl@16083] fix lib/locale.t for VMS with many installed locales + From: PPrymmer@factset.com + Date: Tue, 23 Apr 2002 17:14:32 -0400 + Message-ID: <OF099100A8.2627549C-ON85256BA4.007443F3@55.25.11> + Branch: perl + ! lib/locale.t +____________________________________________________________________________ +[ 16117] By: jhi on 2002/04/23 23:07:02 + Log: Subject: [PATCH Redux] Nuke obsolete way to build debugging (etc) perls + From: Paul_GreenVOS@vos.stratus.com + Date: Tue, 23 Apr 02 15:06 edt + Message-Id: <200204231906.PAA26393@mailhub1.stratus.com> + Branch: perl + ! Makefile.SH cflags.SH +____________________________________________________________________________ +[ 16116] By: jhi on 2002/04/23 23:05:14 + Log: metaconfig unit change for #16115. + Branch: metaconfig + ! U/compline/byteorder.U + Branch: perl + ! config_h.SH +____________________________________________________________________________ +[ 16115] By: jhi on 2002/04/23 23:04:24 + Log: Regen Configure to mirror #16111 (with one added tweak). + Branch: perl + ! Configure +____________________________________________________________________________ +[ 16114] By: jhi on 2002/04/23 22:54:46 + Log: Retract #16109. + Branch: perl + ! lib/ExtUtils/MM_Unix.pm +____________________________________________________________________________ +[ 16113] By: jhi on 2002/04/23 22:38:04 + Log: FAQ sync. + Branch: perl + ! pod/perlfaq3.pod pod/perlfaq8.pod +____________________________________________________________________________ +[ 16112] By: jhi on 2002/04/23 22:34:08 + Log: use encoding no more defaults to Latin 1. + Branch: perl + ! pod/perluniintro.pod +____________________________________________________________________________ +[ 16111] By: gsar on 2002/04/23 22:27:07 + Log: Configure test for byteorder loses bits + Branch: perl + ! Configure +____________________________________________________________________________ +[ 16110] By: gsar on 2002/04/23 21:32:03 + Log: hacking around byteorder variance between config.sh and config.h + isn't needed after change#16099 + Branch: perl + ! ext/Storable/t/malice.t +____________________________________________________________________________ +[ 16109] By: jhi on 2002/04/23 17:54:33 + Log: (retracted by #16114) + + Subject: [PATCH] Nuke obsolete way to build debugging (etc) perls + From: "Green, Paul" <Paul.Green@stratus.com> + Date: Tue, 23 Apr 2002 13:47:19 -0400 + Message-ID: <A2A34F15EE916148BC4C4748223E67A4014E24ED@EXNA4.stratus.com> + Branch: perl + ! lib/ExtUtils/MM_Unix.pm +____________________________________________________________________________ +[ 16108] By: jhi on 2002/04/23 14:45:07 + Log: Subject: [PATCH] lib/File/Find.pm for QNX, NTO + From: Norton Allen <allen@huarp.harvard.edu> + Date: Tue, 23 Apr 2002 11:50:07 -0400 (edt) + Message-Id: <200204231550.LAA24648@bottesini.harvard.edu> + Branch: perl + ! lib/File/Find.pm +____________________________________________________________________________ +[ 16107] By: jhi on 2002/04/23 14:44:13 + Log: Subject: [PATCH] README.qnx, hints/qnx.sh + From: Norton Allen <allen@huarp.harvard.edu> + Date: Tue, 23 Apr 2002 11:48:54 -0400 (edt) + Message-Id: <200204231548.LAA24135@bottesini.harvard.edu> + Branch: perl + ! README.qnx hints/qnx.sh +____________________________________________________________________________ +[ 16106] By: jhi on 2002/04/23 13:57:48 + Log: Subject: [PATCH] pod/perlhist.pod + From: Abigail <abigail@foad.org> + Date: Tue, 23 Apr 2002 16:21:31 +0200 + Message-ID: <20020423162131.A7017@gatekeeper.osp.nl> + + (removed 5.005_04 which never happened) + Branch: perl + ! pod/perlhist.pod +____________________________________________________________________________ +[ 16105] By: jhi on 2002/04/23 13:46:31 + Log: Subject: Re: [PATCH abigail.t] another portability attempt + From: Abigail <abigail@foad.org> + Date: Tue, 23 Apr 2002 11:35:54 +0200 + Message-ID: <20020423113554.A25149@gatekeeper.osp.nl> + Branch: perl + ! t/japh/abigail.t +____________________________________________________________________________ +[ 16104] By: jhi on 2002/04/23 13:35:03 + Log: NetWare tweak from C Aditya. + Branch: perl + ! NetWare/Nwmain.c NetWare/nw5.c +____________________________________________________________________________ +[ 16103] By: gsar on 2002/04/23 06:33:25 + Log: fix a typo + Branch: perl + ! regexec.c +____________________________________________________________________________ +[ 16102] By: jhi on 2002/04/23 04:41:43 + Log: Uncurliff. + Branch: perl + ! README.ko +____________________________________________________________________________ +[ 16101] By: jhi on 2002/04/23 04:36:27 + Log: Pointer to UV casting. + Branch: perl + ! regexec.c +____________________________________________________________________________ +[ 16100] By: jhi on 2002/04/23 02:36:09 + Log: metaconfig unit change for #16099. + Branch: metaconfig + ! U/compline/byteorder.U +____________________________________________________________________________ +[ 16099] By: jhi on 2002/04/23 02:35:52 + Log: Use UV (not long) for BYTEORDER. + Branch: perl + ! Configure Porting/Glossary Porting/config.sh Porting/config_H + ! config_h.SH +____________________________________________________________________________ +[ 16098] By: jhi on 2002/04/23 02:18:10 + Log: # cpp commands must start in the first column. + Branch: perl + ! scope.c +____________________________________________________________________________ +[ 16097] By: jhi on 2002/04/23 01:52:36 + Log: Reborn as text. + Branch: perl + + NetWare/interface.cpp +____________________________________________________________________________ +[ 16096] By: jhi on 2002/04/23 01:52:00 + Log: Dead as binary. + Branch: perl + - NetWare/interface.cpp +____________________________________________________________________________ +[ 16095] By: jhi on 2002/04/23 01:49:37 + Log: Undo #16091, a time-warped escapee. + Branch: perl + ! lib/ExtUtils/t/MM_Cygwin.t +____________________________________________________________________________ +[ 16094] By: jhi on 2002/04/23 01:43:42 + Log: *size tweaks from Sarathy. + Branch: perl + ! ext/Storable/t/malice.t +____________________________________________________________________________ +[ 16093] By: jhi on 2002/04/23 01:12:50 + Log: Subject: [PATCH pod/perlguts.pod] remove a redundant =over + From: Stas Bekman <stas@stason.org> + Date: Tue, 23 Apr 2002 01:52:22 +0800 + Message-ID: <3CC44DD6.3090401@stason.org> + Branch: perl + ! pod/perlguts.pod +____________________________________________________________________________ +[ 16092] By: jhi on 2002/04/23 01:05:37 + Log: Subject: [PATCH] (Updated) Work around bug in gcc 2.95.2 on hppa targets + From: Paul_GreenVOS@vos.stratus.com + Date: Mon, 22 Apr 02 20:35 edt + Message-Id: <200204230034.UAA01134@mailhub2.stratus.com> + Branch: perl + + hints/t001.c + ! MANIFEST hints/README.hints hints/vos.sh +____________________________________________________________________________ +[ 16091] By: jhi on 2002/04/23 00:42:12 + Log: (retracted by #16095) + Branch: perl + ! lib/ExtUtils/t/MM_Cygwin.t +____________________________________________________________________________ +[ 16090] By: jhi on 2002/04/23 00:16:09 + Log: Subject: Re: perl@16083 + From: Nicholas Clark <nick@unfortu.net> + Date: Mon, 22 Apr 2002 23:17:45 +0100 + Message-ID: <20020422221744.GF302@Bagpuss.unfortu.net> + Branch: perl + ! ext/Storable/t/malice.t +____________________________________________________________________________ +[ 16089] By: jhi on 2002/04/23 00:12:09 + Log: Upgrade to Encode 1.58. + Branch: perl + + ext/Encode/t/CJKT.t ext/Encode/t/at-cn.t ext/Encode/t/at-tw.t + + ext/Encode/t/big5-eten.enc ext/Encode/t/big5-eten.utf + + ext/Encode/t/big5-hkscs.enc ext/Encode/t/big5-hkscs.utf + + ext/Encode/t/gb2312.enc ext/Encode/t/gb2312.utf + + ext/Encode/t/jisx0201.enc ext/Encode/t/jisx0201.utf + + ext/Encode/t/jisx0208.enc ext/Encode/t/jisx0208.utf + + ext/Encode/t/jisx0212.enc ext/Encode/t/jisx0212.utf + + ext/Encode/t/ksc5601.enc ext/Encode/t/ksc5601.utf + - ext/Encode/t/CN.t ext/Encode/t/JP.t ext/Encode/t/KR.t + - ext/Encode/t/TW.t ext/Encode/t/bogus.ucm + - ext/Encode/t/gb2312.euc ext/Encode/t/gb2312.ref + - ext/Encode/t/jisx0201.euc ext/Encode/t/jisx0201.ref + - ext/Encode/t/jisx0208.euc ext/Encode/t/jisx0208.ref + - ext/Encode/t/jisx0212.euc ext/Encode/t/jisx0212.ref + - ext/Encode/t/ksc5601.euc ext/Encode/t/ksc5601.ref + ! MANIFEST ext/Encode/Changes ext/Encode/Encode.pm + ! ext/Encode/Encode.xs ext/Encode/MANIFEST ext/Encode/TW/TW.pm + ! ext/Encode/bin/ucm2table ext/Encode/t/perlio.t +____________________________________________________________________________ +[ 16088] By: jhi on 2002/04/22 19:55:18 + Log: On Win32 the end.t failure should be gone now. + Branch: perl + ! pod/perldelta.pod +____________________________________________________________________________ +[ 16087] By: jhi on 2002/04/22 19:51:29 + Log: Subject: [PATCH] update VOS-specific pod files + From: Paul_GreenVOS@vos.stratus.com + Date: Mon, 22 Apr 02 16:02 edt + Message-Id: <200204222002.QAA07350@mailhub1.stratus.com> + Branch: perl + ! README.vos pod/perlport.pod +____________________________________________________________________________ +[ 16086] By: jhi on 2002/04/22 19:50:05 + Log: Subject: [PATCH] cleanup ./hints/vos.sh + From: Paul_GreenVOS@vos.stratus.com + Date: Mon, 22 Apr 02 15:26 edt + Message-Id: <200204221926.PAA05539@mailhub1.stratus.com> + Branch: perl + ! hints/vos.sh +____________________________________________________________________________ +[ 16085] By: jhi on 2002/04/22 19:48:20 + Log: Upgrade to Encode 1.57, from Dan Kogai. + Branch: perl + ! ext/Encode/Changes ext/Encode/Encode.pm ext/Encode/Encode.xs + ! ext/Encode/Unicode/Unicode.pm ext/Encode/lib/Encode/CN/HZ.pm + ! ext/Encode/lib/Encode/Encoding.pm + ! ext/Encode/lib/Encode/JP/JIS7.pm + ! ext/Encode/lib/Encode/KR/2022_KR.pm ext/Encode/t/JP.t + ! ext/Encode/t/KR.t ext/Encode/t/jperl.t ext/Encode/t/perlio.t +____________________________________________________________________________ +[ 16084] By: ams on 2002/04/22 18:10:13 + Log: Subject: [PATCH perl5005delta perlhack perlhist] small corrections + From: Stas Bekman <stas@stason.org> + Date: Tue, 23 Apr 2002 01:59:07 +0800 + Message-Id: <3CC44F6B.5010300@stason.org> + Branch: perl + ! pod/perl5005delta.pod pod/perlhack.pod pod/perlhist.pod +____________________________________________________________________________ +[ 16083] By: jhi on 2002/04/22 16:41:03 + Log: Update Changes. + Branch: perl + ! Changes patchlevel.h +____________________________________________________________________________ [ 16082] By: jhi on 2002/04/22 16:22:50 Log: In MANIFEST but not added. Branch: perl @@ -197,71 +197,67 @@ ext/DynaLoader/Makefile.PL Dynamic Loader makefile writer ext/DynaLoader/README Dynamic Loader notes and intro ext/DynaLoader/XSLoader_pm.PL Simple XS Loader perl module ext/Encode/AUTHORS List of authors +ext/Encode/bin/enc2xs Encode module generator +ext/Encode/bin/piconv iconv by perl +ext/Encode/bin/ucm2table Table Generator for testing +ext/Encode/bin/ucmlint A UCM Lint utility +ext/Encode/bin/unidump Unicode Dump like hexdump(1) ext/Encode/Byte/Byte.pm Encode extension ext/Encode/Byte/Makefile.PL Encode extension +ext/Encode/Changes Change Log ext/Encode/CN/CN.pm Encode extension ext/Encode/CN/Makefile.PL Encode extension -ext/Encode/Changes Change Log ext/Encode/EBCDIC/EBCDIC.pm Encode extension ext/Encode/EBCDIC/Makefile.PL Encode extension +ext/Encode/encengine.c Encode extension ext/Encode/Encode.pm Mother of all Encode extensions ext/Encode/Encode.xs Encode extension ext/Encode/Encode/Changes.e2x Skeleton file for enc2xs ext/Encode/Encode/ConfigLocal_PM.e2x Skeleton file for enc2xs +ext/Encode/Encode/encode.h Encode extension header file ext/Encode/Encode/Makefile_PL.e2x Skeleton file for enc2xs ext/Encode/Encode/README.e2x Skeleton file for enc2xs ext/Encode/Encode/_PM.e2x Skeleton file for enc2xs ext/Encode/Encode/_T.e2x Skeleton file for enc2xs -ext/Encode/Encode/encode.h Encode extension header file +ext/Encode/encoding.pm Perl Pragmactic Module ext/Encode/JP/JP.pm Encode extension ext/Encode/JP/Makefile.PL Encode extension ext/Encode/KR/KR.pm Encode extension ext/Encode/KR/Makefile.PL Encode extension -ext/Encode/MANIFEST Encode extension -ext/Encode/Makefile.PL Encode extension makefile writer -ext/Encode/README Encode extension -ext/Encode/Symbol/Makefile.PL Encode extension -ext/Encode/Symbol/Symbol.pm Encode extension -ext/Encode/TW/Makefile.PL Encode extension -ext/Encode/TW/TW.pm Encode extension -ext/Encode/Unicode/Makefile.PL Encode extension -ext/Encode/Unicode/Unicode.pm Encode extension -ext/Encode/Unicode/Unicode.xs Encode extension -ext/Encode/bin/enc2xs Encode module generator -ext/Encode/bin/piconv iconv by perl -ext/Encode/bin/ucm2table Table Generator for testing -ext/Encode/bin/ucmlint A UCM Lint utility -ext/Encode/bin/unidump Unicode Dump like hexdump(1) -ext/Encode/encengine.c Encode extension -ext/Encode/encoding.pm Perl Pragmactic Module ext/Encode/lib/Encode/Alias.pm Encode extension ext/Encode/lib/Encode/CJKConstants.pm Encode extension ext/Encode/lib/Encode/CN/HZ.pm Encode extension ext/Encode/lib/Encode/Config.pm Encode configuration module ext/Encode/lib/Encode/Encoder.pm OO Encoder ext/Encode/lib/Encode/Encoding.pm Encode extension +ext/Encode/lib/Encode/Guess.pm Encode Extension ext/Encode/lib/Encode/JP/H2Z.pm Encode extension ext/Encode/lib/Encode/JP/JIS7.pm Encode extension ext/Encode/lib/Encode/KR/2022_KR.pm Encode extension +ext/Encode/lib/Encode/MIME/Header.pm Encode extension ext/Encode/lib/Encode/PerlIO.pod Documents for Encode & PerlIO ext/Encode/lib/Encode/Supported.pod Documents for supported encodings -ext/Encode/t/unibench.pl benchmark script +ext/Encode/Makefile.PL Encode extension makefile writer +ext/Encode/MANIFEST Encode extension +ext/Encode/README Encode extension +ext/Encode/Symbol/Makefile.PL Encode extension +ext/Encode/Symbol/Symbol.pm Encode extension ext/Encode/t/Aliases.t test script -ext/Encode/t/CJKT.t test script -ext/Encode/t/Encode.t test script -ext/Encode/t/Encoder.t test script -ext/Encode/t/Unicode.t test script ext/Encode/t/at-cn.t test script ext/Encode/t/at-tw.t test script ext/Encode/t/big5-eten.enc test data ext/Encode/t/big5-eten.utf test data ext/Encode/t/big5-hkscs.enc test data ext/Encode/t/big5-hkscs.utf test data +ext/Encode/t/CJKT.t test script +ext/Encode/t/Encode.t test script +ext/Encode/t/Encoder.t test script ext/Encode/t/encoding.t test script ext/Encode/t/fallback.t test script ext/Encode/t/gb2312.enc test data ext/Encode/t/gb2312.utf test data ext/Encode/t/grow.t test script +ext/Encode/t/guess.t test script ext/Encode/t/jisx0201.enc test data ext/Encode/t/jisx0201.utf test data ext/Encode/t/jisx0208.enc test data @@ -271,7 +267,12 @@ ext/Encode/t/jisx0212.utf test data ext/Encode/t/jperl.t test script ext/Encode/t/ksc5601.enc test data ext/Encode/t/ksc5601.utf test data +ext/Encode/t/mime-header.t test script ext/Encode/t/perlio.t test script +ext/Encode/t/unibench.pl benchmark script +ext/Encode/t/Unicode.t test script +ext/Encode/TW/Makefile.PL Encode extension +ext/Encode/TW/TW.pm Encode extension ext/Encode/ucm/8859-1.ucm Unicode Character Map ext/Encode/ucm/8859-10.ucm Unicode Character Map ext/Encode/ucm/8859-11.ucm Unicode Character Map @@ -360,9 +361,9 @@ ext/Encode/ucm/macHebrew.ucm Unicode Character Map ext/Encode/ucm/macIceland.ucm Unicode Character Map ext/Encode/ucm/macJapanese.ucm Unicode Character Map ext/Encode/ucm/macKorean.ucm Unicode Character Map +ext/Encode/ucm/macRoman.ucm Unicode Character Map ext/Encode/ucm/macROMnn.ucm Unicode Character Map ext/Encode/ucm/macRUMnn.ucm Unicode Character Map -ext/Encode/ucm/macRoman.ucm Unicode Character Map ext/Encode/ucm/macSami.ucm Unicode Character Map ext/Encode/ucm/macSymbol.ucm Unicode Character Map ext/Encode/ucm/macThai.ucm Unicode Character Map @@ -373,6 +374,9 @@ ext/Encode/ucm/posix-bc.ucm Unicode Character Map ext/Encode/ucm/shiftjis.ucm Unicode Character Map ext/Encode/ucm/symbol.ucm Unicode Character Map ext/Encode/ucm/viscii.ucm Unicode Character Map +ext/Encode/Unicode/Makefile.PL Encode extension +ext/Encode/Unicode/Unicode.pm Encode extension +ext/Encode/Unicode/Unicode.xs Encode extension ext/Errno/ChangeLog See if Errno works ext/Errno/Errno.t See if Errno works ext/Errno/Errno_pm.PL Errno perl module create script @@ -595,10 +599,13 @@ ext/Storable/Storable.xs Storable extension ext/Storable/t/blessed.t See if Storable works ext/Storable/t/canonical.t See if Storable works ext/Storable/t/compat06.t See if Storable works +ext/Storable/t/croak.t See if Storable works ext/Storable/t/dclone.t See if Storable works +ext/Storable/t/downgrade.t See if Storable works ext/Storable/t/forgive.t See if Storable works ext/Storable/t/freeze.t See if Storable works ext/Storable/t/lock.t See if Storable works +ext/Storable/t/make_downgrade.pl See if Storable works ext/Storable/t/malice.t See if Storable copes with corrupt files ext/Storable/t/overload.t See if Storable works ext/Storable/t/recurse.t See if Storable works @@ -1423,6 +1430,7 @@ lib/Test/Simple/Changes Test::Simple changes lib/Test/Simple/README Test::Simple README lib/Test/Simple/t/buffer.t Test::Builder buffering test lib/Test/Simple/t/Builder.t Test::Builder tests +lib/Test/Simple/t/curr_test.t Test::Builder->curr_test tests lib/Test/Simple/t/diag.t Test::More diag() test lib/Test/Simple/t/exit.t Test::Simple test, exit codes lib/Test/Simple/t/extra.t Test::Simple test @@ -1432,6 +1440,7 @@ lib/Test/Simple/t/fail.t Test::Simple test, test failures lib/Test/Simple/t/filehandles.t Test::Simple test, STDOUT can be played with lib/Test/Simple/t/import.t Test::More test, importing functions lib/Test/Simple/t/is_deeply.t Test::More test, is_deeply() +lib/Test/Simple/t/maybe_regex.t Test::Builder->maybe_regex() tests lib/Test/Simple/t/missing.t Test::Simple test, missing tests lib/Test/Simple/t/More.t Test::More test, basic stuff lib/Test/Simple/t/no_ending.t Test::Builder test, no_ending() @@ -1445,6 +1454,7 @@ lib/Test/Simple/t/plan_skip_all.t Test::More test, plan() w/skip_all lib/Test/Simple/t/simple.t Test::Simple test, basic stuff lib/Test/Simple/t/skip.t Test::More test, SKIP tests lib/Test/Simple/t/skipall.t Test::More test, skip all tests +lib/Test/Simple/t/strays.t Test::Builder stray newline checks lib/Test/Simple/t/todo.t Test::More test, TODO tests lib/Test/Simple/t/undef.t Test::More test, undefs don't cause warnings lib/Test/Simple/t/useing.t Test::More test, compile test @@ -2336,8 +2346,12 @@ t/lib/Math/BigInt/BareCalc.pm Bigint's simulation of Calc t/lib/Math/BigInt/Subclass.pm Empty subclass of BigInt for test t/lib/Math/BigRat/Test.pm Math::BigRat test helper t/lib/sample-tests/bailout Test data for Test::Harness +t/lib/sample-tests/bignum Test data for Test::Harness t/lib/sample-tests/combined Test data for Test::Harness t/lib/sample-tests/descriptive Test data for Test::Harness +t/lib/sample-tests/die Test data for Test::Harness +t/lib/sample-tests/die_head_end Test data for Test::Harness +t/lib/sample-tests/die_last_minute Test data for Test::Harness t/lib/sample-tests/duplicates Test data for Test::Harness t/lib/sample-tests/head_end Test data for Test::Harness t/lib/sample-tests/head_fail Test data for Test::Harness diff --git a/NetWare/Makefile b/NetWare/Makefile index e7f6ce720c..813fbe9295 100644 --- a/NetWare/Makefile +++ b/NetWare/Makefile @@ -277,7 +277,7 @@ SOCKET_NLM = $(AUTODIR)\Socket\Socket.NLM FCNTL_NLM = $(AUTODIR)\Fcntl\Fcntl.NLM IO_NLM = $(AUTODIR)\IO\IO.NLM OPCODE_NLM = $(AUTODIR)\Opcode\Opcode.NLM -SDBM_FILE_NLM = $(AUTODIR)\SDBM_File\SDBM_File.NLM +SDBM_FILE_NLM = $(AUTODIR)\SDBM_File\SDBM_File.NLM POSIX_NLM = $(AUTODIR)\POSIX\POSIX.NLM ATTRS_NLM = $(AUTODIR)\attrs\attrs.NLM THREAD_NLM = $(AUTODIR)\Thread\Thread.NLM @@ -297,7 +297,6 @@ XSTYPEMAP_NLM = $(EXTDIR)\XS\Typemap\Typemap.NLM UNICODENORMALIZE_NLM = $(EXTDIR)\Unicode\Normalize\Normalize.NLM EXTENSION_NLM = \ - $(SDBM_FILE_NLM) \ $(POSIX_NLM) \ $(THREAD_NLM) \ $(DUMPER_NLM) \ @@ -318,8 +317,8 @@ EXTENSION_NLM = \ $(ATTRS_NLM) \ $(BYTELOADER_NLM) \ $(IO_NLM) \ - $(UNICODENORMALIZE_NLM) - + $(UNICODENORMALIZE_NLM) \ + $(SDBM_FILE_NLM) # Begin - Following is required to build NetWare specific extensions CGI2Perl, Perl2UCS and UCSExt CGI2PERL = CGI2Perl\CGI2Perl @@ -922,7 +921,7 @@ $(EXTDIR)\DynaLoader\dl_netware.xs: dl_netware.xs HEADERS : @echo . . . . making stdio.h and string.h - @copy << stdio.h >\nwnul + @copy << stdio.h >\nul /* * (C) Copyright 2002 Novell Inc. All Rights Reserved. @@ -959,7 +958,7 @@ HEADERS : << @copy stdio.h $(COREDIR) - @copy << string.h >\nwnul + @copy << string.h >\nul /* * (C) Copyright 2002 Novell Inc. All Rights Reserved. diff --git a/README.win32 b/README.win32 index 0a1f37abba..4446600626 100644 --- a/README.win32 +++ b/README.win32 @@ -253,13 +253,6 @@ the testsuite (many tests will be skipped). There should be no test failures when running under Windows NT/2000/XP. Many tests I<will> fail under Windows 9x due to the inferior command shell. -The following known test failures under the 64-bit edition of Windows .NET -Server beta 3 are expected to be fixed before the 5.8.0 release: - - Failed Test Stat Wstat Total Fail Failed List of Failed - ------------------------------------------------------------------------ - op/fork.t 18 3 16.67% 2 15 17 - Some test failures may occur if you use a command shell other than the native "cmd.exe", or if you are building from a path that contains spaces. So don't do that. @@ -678,8 +671,6 @@ Here's a diversion: copy "runperl.bat" to "runperl", and type "runperl". Explain the observed behavior, or lack thereof. :) Hint: .gnidnats llits er'uoy fi ,"lrepnur" eteled :tniH -=back - =item Miscellaneous Things A full set of HTML documentation is installed, so you should be diff --git a/configure.com b/configure.com index 7dda531dd2..b4abec42b5 100644 --- a/configure.com +++ b/configure.com @@ -2534,6 +2534,7 @@ $ IF xxx .EQS. "Encode/CN" THEN goto ext_loop ! sub extension - omit $ IF xxx .EQS. "Encode/JP" THEN goto ext_loop ! sub extension - omit $ IF xxx .EQS. "Encode/KR" THEN goto ext_loop ! sub extension - omit $ IF xxx .EQS. "Encode/TW" THEN goto ext_loop ! sub extension - omit +$ IF xxx .EQS. "B/C" THEN goto ext_loop ! sub extension - omit $ IF F$EXTRACT(0,8,line) .EQS. "vms/ext/" THEN - xxx = "VMS/" + F$EXTRACT(8,line_len - 20,line) $ known_extensions = known_extensions + " ''xxx'" @@ -617,7 +617,7 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, OP *o) case OP_GVSV: case OP_GV: #ifdef USE_ITHREADS - Perl_dump_indent(aTHX_ level, file, "PADIX = %d\n", cPADOPo->op_padix); + Perl_dump_indent(aTHX_ level, file, "PADIX = %" IVdf "\n", (IV)cPADOPo->op_padix); #else if (cSVOPo->op_sv) { SV *tmpsv = NEWSV(0,0); @@ -562,7 +562,7 @@ Ap |struct perl_thread* |new_struct_thread|struct perl_thread *t Ap |void |reentrant_size Ap |void |reentrant_init Ap |void |reentrant_free -Afnp |void* |reentrant_retry|const char*|... +Anp |void* |reentrant_retry|const char*|... #endif Ap |void |call_atexit |ATEXIT_t fn|void *ptr Apd |I32 |call_argv |const char* sub_name|I32 flags|char** argv @@ -587,7 +587,7 @@ Ap |void |set_numeric_standard Apd |void |require_pv |const char* pv Apd |void |pack_cat |SV *cat|char *pat|char *patend|SV **beglist|SV **endlist|SV ***next_in_list|U32 flags p |void |pidgone |Pid_t pid|int status -Ap |void |pmflag |U16* pmfl|int ch +Ap |void |pmflag |U32* pmfl|int ch p |OP* |pmruntime |OP* pm|OP* expr|OP* repl p |OP* |pmtrans |OP* o|OP* expr|OP* repl p |OP* |pop_return diff --git a/ext/B/B.xs b/ext/B/B.xs index 6392b9b2cc..111116a21b 100644 --- a/ext/B/B.xs +++ b/ext/B/B.xs @@ -668,7 +668,7 @@ OP_ppaddr(o) CODE: sv_setpvn(sv, "PL_ppaddr[OP_", 13); sv_catpv(sv, PL_op_name[o->op_type]); - for (i=13; i<SvCUR(sv); ++i) + for (i=13; (STRLEN)i < SvCUR(sv); ++i) SvPVX(sv)[i] = toUPPER(SvPVX(sv)[i]); sv_catpv(sv, "]"); ST(0) = sv; diff --git a/ext/ByteLoader/ByteLoader.xs b/ext/ByteLoader/ByteLoader.xs index d559bfe57f..4588b02ef0 100644 --- a/ext/ByteLoader/ByteLoader.xs +++ b/ext/ByteLoader/ByteLoader.xs @@ -11,7 +11,7 @@ int bl_getc(struct byteloader_fdata *data) { dTHX; - if (SvCUR(data->datasv) <= data->next_out) { + if (SvCUR(data->datasv) <= (STRLEN)data->next_out) { int result; /* Run out of buffered data, so attempt to read some more */ *(SvPV_nolen (data->datasv)) = '\0'; diff --git a/ext/Cwd/t/cwd.t b/ext/Cwd/t/cwd.t index bcbcd17b3d..92079c0b10 100644 --- a/ext/Cwd/t/cwd.t +++ b/ext/Cwd/t/cwd.t @@ -28,14 +28,18 @@ eval { fastcwd }; # Must find an external pwd (or equivalent) command. +my $pwd = $^O eq 'MSWin32' ? "cmd" : "pwd"; my $pwd_cmd = - ($^O eq "MSWin32" || $^O eq "NetWare") ? + ($^O eq "NetWare") ? "cd" : - (grep { -x && -f } map { "$_/pwd$Config{exe_ext}" } + (grep { -x && -f } map { "$_/$pwd$Config{exe_ext}" } split m/$Config{path_sep}/, $ENV{PATH})[0]; $pwd_cmd = 'SHOW DEFAULT' if $IsVMS; - +if ($^O eq 'MSWin32') { + $pwd_cmd =~ s,/,\\,g; + $pwd_cmd = "$pwd_cmd /c cd"; +} print "# native pwd = '$pwd_cmd'\n"; SKIP: { diff --git a/ext/Data/Dumper/Dumper.xs b/ext/Data/Dumper/Dumper.xs index 19037a839e..383707a4e3 100644 --- a/ext/Data/Dumper/Dumper.xs +++ b/ext/Data/Dumper/Dumper.xs @@ -147,10 +147,10 @@ esc_q_utf8(pTHX_ SV* sv, register char *src, register STRLEN slen) if (k == '"' || k == '\\' || k == '$' || k == '@') { *r++ = '\\'; - *r++ = k; + *r++ = (char)k; } else if (k < 0x80) - *r++ = k; + *r++ = (char)k; else { r += sprintf(r, "\\x{%"UVxf"}", k); } diff --git a/ext/Devel/DProf/DProf.xs b/ext/Devel/DProf/DProf.xs index 3380d786a5..2219bd2189 100644 --- a/ext/Devel/DProf/DProf.xs +++ b/ext/Devel/DProf/DProf.xs @@ -632,7 +632,7 @@ BOOT: * while we do this. */ { - I32 warn_tmp = PL_dowarn; + bool warn_tmp = PL_dowarn; PL_dowarn = 0; newXS("DB::sub", XS_DB_sub, file); newXS("DB::goto", XS_DB_goto, file); diff --git a/ext/Digest/MD5/MD5.xs b/ext/Digest/MD5/MD5.xs index 5828df3350..0852e526db 100644 --- a/ext/Digest/MD5/MD5.xs +++ b/ext/Digest/MD5/MD5.xs @@ -80,10 +80,10 @@ extern "C" { #ifndef BYTESWAP static void u2s(U32 u, U8* s) { - *s++ = u & 0xFF; - *s++ = (u >> 8) & 0xFF; - *s++ = (u >> 16) & 0xFF; - *s = (u >> 24) & 0xFF; + *s++ = (U8)(u & 0xFF); + *s++ = (U8)((u >> 8) & 0xFF); + *s++ = (U8)((u >> 16) & 0xFF); + *s = (U8)((u >> 24) & 0xFF); } #define s2u(s,u) ((u) = (U32)(*s) | \ diff --git a/ext/Digest/MD5/t/files.t b/ext/Digest/MD5/t/files.t index 67289925b1..1a1f032eae 100644 --- a/ext/Digest/MD5/t/files.t +++ b/ext/Digest/MD5/t/files.t @@ -16,12 +16,12 @@ my $EXPECT; if (ord('A') == 193) { # EBCDIC $EXPECT = <<EOT; ee6a09094632cd610199278bbb0f910e ext/Digest/MD5/MD5.pm -491dfb1027eb154cff18beb609d6068a ext/Digest/MD5/MD5.xs +XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX ext/Digest/MD5/MD5.xs EOT } else { # ASCII $EXPECT = <<EOT; 665ddc08b12d6b1bf85ac6dc5aae68b3 ext/Digest/MD5/MD5.pm -95444a9c6ad17e443e4606c6c7fd9e28 ext/Digest/MD5/MD5.xs +5f21e907b2e7dbffe6aba2c762ea93d0 ext/Digest/MD5/MD5.xs EOT } diff --git a/ext/Encode/AUTHORS b/ext/Encode/AUTHORS index 2ba72f844f..86100126b5 100644 --- a/ext/Encode/AUTHORS +++ b/ext/Encode/AUTHORS @@ -27,6 +27,7 @@ Nicholas Clark <nick@ccl4.org> Nick Ing-Simmons <nick@ing-simmons.net> Paul Marquess <paul_marquess@yahoo.co.uk> Philip Newton <pne@cpan.org> +Robin Barker <rmb1@cise.npl.co.uk> SADAHIRO Tomoyuki <SADAHIRO@cpan.org> Spider Boardman <spider@web.zk3.dec.com> Tatsuhiko Miyagawa <miyagawa@edge.co.jp> diff --git a/ext/Encode/CN/Makefile.PL b/ext/Encode/CN/Makefile.PL index 46b262dacd..775a8f5b38 100644 --- a/ext/Encode/CN/Makefile.PL +++ b/ext/Encode/CN/Makefile.PL @@ -1,6 +1,7 @@ use 5.7.2; use strict; use ExtUtils::MakeMaker; +use strict; my %tables = (euc_cn_t => ['euc-cn.ucm', 'cp936.ucm', @@ -11,6 +12,20 @@ my %tables = (euc_cn_t => ['euc-cn.ucm', ir_165_t => ['ir-165.ucm'], ); +unless ($ENV{AGGREGATE_TABLES}){ + my @ucm; + for my $k (keys %tables){ + push @ucm, @{$tables{$k}}; + } + %tables = (); + my $seq = 0; + for my $ucm (sort @ucm){ + # 8.3 compliance ! + my $t = sprintf ("%s_%02d_t", substr($ucm, 0, 2), $seq++); + $tables{$t} = [ $ucm ]; + } +} + my $name = 'CN'; WriteMakefile( diff --git a/ext/Encode/Changes b/ext/Encode/Changes index 77a5f04120..ad4fabb76a 100644 --- a/ext/Encode/Changes +++ b/ext/Encode/Changes @@ -1,9 +1,53 @@ # Revision history for Perl extension Encode. # -# $Id: Changes,v 1.58 2002/04/22 23:54:22 dankogai Exp $ +# $Id: Changes,v 1.61 2002/04/26 03:02:04 dankogai Exp $ # -$Revision: 1.58 $ $Date: 2002/04/22 23:54:22 $ +$Revision: 1.61 $ $Date: 2002/04/26 03:02:04 $ +! t/mime-header.t + Now does decent tests besides use_ok() +! lib/Encode/Guess.pm t/guess.t + UI streamlined, document added +! Unicode/Unicode.xs + various signed/unsigned mismatch nits (#16173) + http://public.activestate.com/cgi-bin/perlbrowse?patch=16173 +! Encode.pm + POD: utf8-flag-related caveats added. A few sections completely + rewritten. +! Encode.xs +! AUTHORS + Thou shalt not assume %d works, either! + Robin Baker added to AUTHORS for this + Message-Id: <200204251132.MAA28237@tempest.npl.co.uk> +! t/CJKT.t + "Change 16144 by gsar@onru on 2002/04/24 18:59:05" + +1.60 2002/04/24 20:06:52 +! Encode.xs + "Thou shalt not assume %x works." -- jhi + Message-Id: <20020424210618.E24347@alpha.hut.fi> +! CN/Makefile.PL JP/Makefile.PL KR/Makefile.PL TW/Makefile.PL To make + low-memory build machines happy, now *.c is created for each *.ucm + (no table aggregation). You can still override this by setting + $ENV{AGGREGATE_TABLES}. + Message-Id: <00B1B3E4-579F-11D6-A441-00039301D480@dan.co.jp> ++ lib/Encode/Guess.pm ++ lib/Encode/JP/JIS7.pm + Encoding-autodetect (mainly for Japanese encoding) added. In a + course of development, JIS7.pm was improved. ++ lib/Encode/HTML/Header.pm ++ lib/Encode/Config.pm + MIME B/Q Header Encoding Added! +! Encode.pm Encode.xs t/fallback.t + new fallbacks; XMLCREF and HTMLCREF upon Bart's request. + Message-Id: <20020424130709.GA14211@tanglefoot> + +1.59 $ 2002/04/22 23:54:22 +! Encode.pm Encode.xs + needs_lines() and perlio_ok() are added to Internal encodings such + as utf8 so XML::SAX is happy. FB_* stub xsubs are now prototyped. + +1.58 2002/04/22 23:54:22 ! TW/TW.pm s/MacChineseSimp/MacChineseTrad/ # ... oops. ! bin/ucm2text @@ -467,7 +511,7 @@ $Revision: 1.58 $ $Date: 2002/04/22 23:54:22 $ Typo fixes and improvements by jhi Message-Id: <200204010201.FAA03564@alpha.hut.fi>, et al. -1.11 $Date: 2002/04/22 23:54:22 $ +1.11 $Date: 2002/04/26 03:02:04 $ + t/encoding.t + t/jperl.t ! MANIFEST diff --git a/ext/Encode/Encode.pm b/ext/Encode/Encode.pm index b03d93d707..e6c54f0a9f 100644 --- a/ext/Encode/Encode.pm +++ b/ext/Encode/Encode.pm @@ -1,12 +1,12 @@ package Encode; use strict; -our $VERSION = do { my @r = (q$Revision: 1.58 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; +our $VERSION = do { my @r = (q$Revision: 1.61 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; our $DEBUG = 0; use XSLoader (); XSLoader::load 'Encode'; require Exporter; -our @ISA = qw(Exporter); +use base qw/Exporter/; # Public, encouraged API is exported by default @@ -15,8 +15,10 @@ our @EXPORT = qw( encodings find_encoding ); -our @FB_FLAGS = qw(DIE_ON_ERR WARN_ON_ERR RETURN_ON_ERR LEAVE_SRC PERLQQ); -our @FB_CONSTS = qw(FB_DEFAULT FB_QUIET FB_WARN FB_PERLQQ FB_CROAK); +our @FB_FLAGS = qw(DIE_ON_ERR WARN_ON_ERR RETURN_ON_ERR LEAVE_SRC + PERLQQ HTMLCREF XMLCREF); +our @FB_CONSTS = qw(FB_DEFAULT FB_CROAK FB_QUIET FB_WARN + FB_PERLQQ FB_HTMLCREF FB_XMLCREF); our @EXPORT_OK = ( @@ -194,6 +196,11 @@ sub predefine_encodings{ package Encode::UTF_EBCDIC; *name = sub{ shift->{'Name'} }; *new_sequence = sub{ return $_[0] }; + *needs_lines = sub{ 0 }; + *perlio_ok = sub { + eval{ require PerlIO::encoding }; + return $@ ? 0 : 1; + }; *decode = sub{ my ($obj,$str,$chk) = @_; my $res = ''; @@ -221,6 +228,11 @@ sub predefine_encodings{ package Encode::Internal; *name = sub{ shift->{'Name'} }; *new_sequence = sub{ return $_[0] }; + *needs_lines = sub{ 0 }; + *perlio_ok = sub { + eval{ require PerlIO::encoding }; + return $@ ? 0 : 1; + }; *decode = sub{ my ($obj,$str,$chk) = @_; utf8::upgrade($str); @@ -237,6 +249,11 @@ sub predefine_encodings{ package Encode::utf8; *name = sub{ shift->{'Name'} }; *new_sequence = sub{ return $_[0] }; + *needs_lines = sub{ 0 }; + *perlio_ok = sub { + eval{ require PerlIO::encoding }; + return $@ ? 0 : 1; + }; *decode = sub{ my ($obj,$octets,$chk) = @_; my $str = Encode::decode_utf8($octets); @@ -314,7 +331,7 @@ byte has 256 possible values, it easily fits in Perl's much larger =head2 TERMINOLOGY -=over 4 +=over 2 =item * @@ -339,7 +356,7 @@ and such details may change in future releases. =head1 PERL ENCODING API -=over 4 +=over 2 =item $octets = encode(ENCODING, $string[, CHECK]) @@ -351,7 +368,13 @@ For CHECK, see L</"Handling Malformed Data">. For example, to convert (internally UTF-8 encoded) Unicode string to iso-8859-1 (also known as Latin1), - $octets = encode("iso-8859-1", $unicode); + $octets = encode("iso-8859-1", $utf8); + +B<CAVEAT>: When you C<$octets = encode("utf8", $utf8)>, then $octets +B<ne> $utf8. Though they both contain the same data, the utf8 flag +for $octets is B<always> off. When you encode anything, utf8 flag of +the result is always off, even when it contains completely valid utf8 +string. See L</"The UTF-8 flag"> below. =item $string = decode(ENCODING, $octets[, CHECK]) @@ -365,16 +388,22 @@ For example, to convert ISO-8859-1 data to UTF-8: $utf8 = decode("iso-8859-1", $latin1); -=item [$length =] from_to($string, FROM_ENCODING, TO_ENCODING [,CHECK]) +B<CAVEAT>: When you C<$utf8 = encode("utf8", $octets)>, then $utf8 +B<may not be equal to> $utf8. Though they both contain the same data, +the utf8 flag for $utf8 is on unless $octets entirely conststs of +ASCII data (or EBCDIC on EBCDIC machines). See L</"The UTF-8 flag"> +below. -Converts B<in-place> data between two encodings. -For example, to convert ISO-8859-1 data to UTF-8: +=item [$length =] from_to($string, FROM_ENC, TO_ENC [, CHECK]) + +Converts B<in-place> data between two encodings. For example, to +convert ISO-8859-1 data to UTF-8: - from_to($data, "iso-8859-1", "utf-8"); + from_to($data, "iso-8859-1", "utf8"); and to convert it back: - from_to($data, "utf-8", "iso-8859-1"); + from_to($data, "utf8", "iso-8859-1"); Note that because the conversion happens in place, the data to be converted cannot be a string constant; it must be a scalar variable. @@ -382,32 +411,34 @@ converted cannot be a string constant; it must be a scalar variable. from_to() returns the length of the converted string on success, undef otherwise. -=back +B<CAVEAT>: The following operations look the same but not quite so; + + from_to($data, "iso-8859-1", "utf8"); #1 + $data = decode("iso-8859-1", $data); #2 -=head2 UTF-8 / utf8 +Both #1 and #2 makes $data consists of completely valid UTF-8 string +but only #2 turns utf8 flag on. #1 is equivalent to -The Unicode Consortium defines the UTF-8 transformation format as a -way of encoding the entire Unicode repertoire as sequences of octets. -This encoding is expected to become very widespread. Perl can use this -form internally to represent strings, so conversions to and from this -form are particularly efficient (as octets in memory do not have to -change, just the meta-data that tells Perl how to treat them). + $data = encode("utf8", decode("iso-8859-1", $data)); -=over 4 +See L</"The UTF-8 flag"> below. =item $octets = encode_utf8($string); -The characters that comprise $string are encoded in Perl's superset of -UTF-8 and the resulting octets are returned as a sequence of bytes. All -possible characters have a UTF-8 representation so this function cannot -fail. +Equivalent to C<$octets = encode("utf8", $string);> The characters +that comprise $string are encoded in Perl's superset of UTF-8 and the +resulting octets are returned as a sequence of bytes. All possible +characters have a UTF-8 representation so this function cannot fail. + =item $string = decode_utf8($octets [, CHECK]); -The sequence of octets represented by $octets is decoded from UTF-8 -into a sequence of logical characters. Not all sequences of octets -form valid UTF-8 encodings, so it is possible for this call to fail. -For CHECK, see L</"Handling Malformed Data">. +equivalent to C<$string = decode("utf8", $octets [, CHECK])>. +decode_utf8($octets [, CHECK]); The sequence of octets represented by +$octets is decoded from UTF-8 into a sequence of logical +characters. Not all sequences of octets form valid UTF-8 encodings, so +it is possible for this call to fail. For CHECK, see +L</"Handling Malformed Data">. =back @@ -493,7 +524,7 @@ For gory details, see L<Encode::PerlIO>. =head1 Handling Malformed Data -=over 4 +=over 2 The I<CHECK> argument is used as follows. When you omit it, the behaviour is the same as if you had passed a value of 0 for @@ -507,7 +538,7 @@ E<lt>subcharE<gt> will be used. For Unicode, "\x{FFFD}" is used. If the data is supposed to be UTF-8, an optional lexical warning (category utf8) is given. -=item I<CHECK> = Encode::DIE_ON_ERROR (== 1) +=item I<CHECK> = Encode::FB_CROAK ( == 1) If I<CHECK> is 1, methods will die immediately with an error message. Therefore, when I<CHECK> is set to 1, you should trap the @@ -539,6 +570,10 @@ you are debugging the mode above. =item perlqq mode (I<CHECK> = Encode::FB_PERLQQ) +=item HTML charref mode (I<CHECK> = Encode::FB_HTMLCREF) + +=item XML charref mode (I<CHECK> = Encode::FB_XMLCREF) + For encodings that are implemented by Encode::XS, CHECK == Encode::FB_PERLQQ turns (en|de)code into C<perlqq> fallback mode. @@ -548,6 +583,10 @@ decoded to utf8. And when you encode, '\x{I<xxxx>}' will be inserted, where I<xxxx> is the Unicode ID of the character that cannot be found in the character repertoire of the encoding. +HTML/XML character reference modes are about the same, in place of +\x{I<xxxx>}, HTML uses &#I<1234>; where I<1234> is a decimal digit and +XML uses &#xI<abcd>; where I<abcd> is the hexadecimal digit. + =item The bitmask These modes are actually set via a bitmask. Here is how the FB_XX @@ -561,6 +600,8 @@ constants via C<use Encode qw(:fallback_all)>. RETURN_ON_ERR 0x0004 X X LEAVE_SRC 0x0008 PERLQQ 0x0100 X + HTMLCREF 0x0200 + XMLCREF 0x0400 =head2 Unimplemented fallback schemes @@ -581,12 +622,84 @@ arguments are taken as aliases for I<$object>, as for C<define_alias>. See L<Encode::Encoding> for more details. -=head1 Messing with Perl's Internals +=head1 The UTF-8 flag + +Before the introduction of utf8 support in perl, The C<eq> operator +just compares internal data of the scalars. Now C<eq> means internal +data equality AND I<the utf8 flag>. To explain why we made it so, I +will quote page 402 of C<Programming Perl, 3rd ed.> + +=over 2 + +=item Goal #1: + +Old byte-oriented programs should not spontaneously break on the old +byte-oriented data they used to work on. + +=item Goal #2: + +Old byte-oriented programs should magically start working on the new +character-oriented data when appropriate. + +=item Goal #3: + +Programs should run just as fast in the new character-oriented mode +as in the old byte-oriented mode. + +=item Goal #4: + +Perl should remain one language, rather than forking into a +byte-oriented Perl and a character-oriented Perl. + +=back + +Back when C<Programming Perl, 3rd ed.> was written, not even Perl 5.6.0 +was born and many features documented in the book remained +unimplemented. Perl 5.8 hopefully correct this and the introduction +of UTF-8 flag is one of them. You can think this perl notion of +byte-oriented mode (utf8 flag off) and character-oriented mode (utf8 +flag on). + +Here is how Encode takes care of the utf8 flag. + +=over 2 + +=item * + +When you encode, the resulting utf8 flag is always off. + +=item + +When you decode, the resuting utf8 flag is on unless you can +unambiguously represent data. Here is the definition of +dis-ambiguity. + + After C<$utf8 = decode('foo', $octet);>, + + When $octet is... The utf8 flag in $utf8 is + --------------------------------------------- + In ASCII only (or EBCDIC only) OFF + In ISO-8859-1 ON + In any other Encoding ON + --------------------------------------------- + +As you see, there is one exception, In ASCII. That way you can assue +Goal #1. And with Encode Goal #2 is assumed but you still have to be +careful in such cases mentioned in B<CAVEAT> paragraphs. + +This utf8 flag is not visible in perl scripts, exactly for the same +reason you cannot (or you I<don't have to>) see if a scalar contains a +string, integer, or floating point number. But you can still peek +and poke these if you will. See the section below. + +=back + +=head2 Messing with Perl's Internals The following API uses parts of Perl's internals in the current implementation. As such, they are efficient but may change. -=over 4 +=over 2 =item is_utf8(STRING [, CHECK]) @@ -626,8 +739,8 @@ the Perl Unicode Mailing List E<lt>perl-unicode@perl.orgE<gt> =head1 MAINTAINER This project was originated by Nick Ing-Simmons and later maintained -by Dan Kogai E<lt>dankogai@dan.co.jpE<gt>. See AUTHORS for a full list -of people involved. For any questions, use -E<lt>perl-unicode@perl.orgE<gt> so others can share. +by Dan Kogai E<lt>dankogai@dan.co.jpE<gt>. See AUTHORS for a full +list of people involved. For any questions, use +E<lt>perl-unicode@perl.orgE<gt> so we can all share share. =cut diff --git a/ext/Encode/Encode.xs b/ext/Encode/Encode.xs index be69c33352..1311d8dacb 100644 --- a/ext/Encode/Encode.xs +++ b/ext/Encode/Encode.xs @@ -1,5 +1,5 @@ /* - $Id: Encode.xs,v 1.34 2002/04/22 20:27:30 dankogai Exp $ + $Id: Encode.xs,v 1.39 2002/04/26 03:02:04 dankogai Exp $ */ #define PERL_NO_GET_CONTEXT @@ -141,10 +141,22 @@ encode_method(pTHX_ encode_t * enc, encpage_t * dir, SV * src, goto ENCODE_SET_SRC; }else if (check & ENCODE_PERLQQ){ SV* perlqq = - sv_2mortal(newSVpvf("\\x{%04x}", ch)); + 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_2mortal(newSVpvf("&#%" UVuf ";", ch)); + sdone += slen + clen; + ddone += dlen + SvCUR(htmlcref); + sv_catsv(dst, htmlcref); + }else if (check & ENCODE_XMLCREF){ + SV* xmlcref = + sv_2mortal(newSVpvf("&#x%" UVxf ";", ch)); + sdone += slen + clen; + ddone += dlen + SvCUR(xmlcref); + sv_catsv(dst, xmlcref); } else { /* fallback char */ sdone += slen + clen; @@ -168,7 +180,8 @@ encode_method(pTHX_ encode_t * enc, encpage_t * dir, SV * src, enc->name[0], (U8) s[slen], code); } goto ENCODE_SET_SRC; - }else if (check & ENCODE_PERLQQ){ + }else if (check & + (ENCODE_PERLQQ|ENCODE_HTMLCREF|ENCODE_XMLCREF)){ SV* perlqq = sv_2mortal(newSVpvf("\\x%02X", s[slen])); sdone += slen + 1; @@ -441,9 +454,6 @@ CODE: OUTPUT: RETVAL -PROTOTYPES: DISABLE - - int DIE_ON_ERR() CODE: @@ -480,6 +490,20 @@ OUTPUT: RETVAL int +HTMLCREF() +CODE: + RETVAL = ENCODE_HTMLCREF; +OUTPUT: + RETVAL + +int +XMLCREF() +CODE: + RETVAL = ENCODE_XMLCREF; +OUTPUT: + RETVAL + +int FB_DEFAULT() CODE: RETVAL = ENCODE_FB_DEFAULT; @@ -514,6 +538,20 @@ CODE: OUTPUT: RETVAL +int +FB_HTMLCREF() +CODE: + RETVAL = ENCODE_FB_HTMLCREF; +OUTPUT: + RETVAL + +int +FB_XMLCREF() +CODE: + RETVAL = ENCODE_FB_XMLCREF; +OUTPUT: + RETVAL + BOOT: { #include "def_t.h" diff --git a/ext/Encode/Encode/encode.h b/ext/Encode/Encode/encode.h index 04df7f9b38..b860578f22 100644 --- a/ext/Encode/Encode/encode.h +++ b/ext/Encode/Encode/encode.h @@ -94,11 +94,15 @@ extern void Encode_DefineEncoding(encode_t *enc); #define ENCODE_RETURN_ON_ERR 0x0004 /* immediately returns on NOREP */ #define ENCODE_LEAVE_SRC 0x0008 /* $src updated unless set */ #define ENCODE_PERLQQ 0x0100 /* perlqq fallback string */ +#define ENCODE_HTMLCREF 0x0200 /* HTML character ref. fb mode */ +#define ENCODE_XMLCREF 0x0400 /* XML character ref. fb mode */ #define ENCODE_FB_DEFAULT 0x0000 #define ENCODE_FB_CROAK 0x0001 #define ENCODE_FB_QUIET ENCODE_RETURN_ON_ERR #define ENCODE_FB_WARN (ENCODE_RETURN_ON_ERR|ENCODE_WARN_ON_ERR) #define ENCODE_FB_PERLQQ ENCODE_PERLQQ +#define ENCODE_FB_HTMLCREF ENCODE_HTMLCREF +#define ENCODE_FB_XMLCREF ENCODE_XMLCREF #endif /* ENCODE_H */ diff --git a/ext/Encode/JP/Makefile.PL b/ext/Encode/JP/Makefile.PL index ce47d2fc97..a1df35d169 100644 --- a/ext/Encode/JP/Makefile.PL +++ b/ext/Encode/JP/Makefile.PL @@ -1,6 +1,7 @@ use 5.7.2; use strict; use ExtUtils::MakeMaker; +use strict; my %tables = ( euc_jp_t => ['euc-jp.ucm'], @@ -12,6 +13,20 @@ my %tables = ( ], ); +unless ($ENV{AGGREGATE_TABLES}){ + my @ucm; + for my $k (keys %tables){ + push @ucm, @{$tables{$k}}; + } + %tables = (); + my $seq = 0; + for my $ucm (sort @ucm){ + # 8.3 compliance ! + my $t = sprintf ("%s_%02d_t", substr($ucm, 0, 2), $seq++); + $tables{$t} = [ $ucm ]; + } +} + my $name = 'JP'; WriteMakefile( diff --git a/ext/Encode/KR/Makefile.PL b/ext/Encode/KR/Makefile.PL index df0eeb68b2..4ba99ab82d 100644 --- a/ext/Encode/KR/Makefile.PL +++ b/ext/Encode/KR/Makefile.PL @@ -1,6 +1,7 @@ use 5.7.2; use strict; use ExtUtils::MakeMaker; +use strict; my %tables = (euc_kr_t => ['euc-kr.ucm', 'macKorean.ucm', @@ -10,6 +11,20 @@ my %tables = (euc_kr_t => ['euc-kr.ucm', johab_t => ['johab.ucm'], ); +unless ($ENV{AGGREGATE_TABLES}){ + my @ucm; + for my $k (keys %tables){ + push @ucm, @{$tables{$k}}; + } + %tables = (); + my $seq = 0; + for my $ucm (sort @ucm){ + # 8.3 compliance ! + my $t = sprintf ("%s_%02d_t", substr($ucm, 0, 2), $seq++); + $tables{$t} = [ $ucm ]; + } +} + my $name = 'KR'; WriteMakefile( diff --git a/ext/Encode/MANIFEST b/ext/Encode/MANIFEST index 2a35d9f6ec..cc6a1414c9 100644 --- a/ext/Encode/MANIFEST +++ b/ext/Encode/MANIFEST @@ -42,12 +42,13 @@ lib/Encode/CN/HZ.pm Encode extension lib/Encode/Config.pm Encode configuration module lib/Encode/Encoder.pm OO Encoder lib/Encode/Encoding.pm Encode extension +lib/Encode/Guess.pm Encode Extension lib/Encode/JP/H2Z.pm Encode extension lib/Encode/JP/JIS7.pm Encode extension lib/Encode/KR/2022_KR.pm Encode extension +lib/Encode/MIME/Header.pm Encode extension lib/Encode/PerlIO.pod Documents for Encode & PerlIO lib/Encode/Supported.pod Documents for supported encodings -t/unibench.pl benchmark script t/Aliases.t test script t/CJKT.t test script t/Encode.t test script @@ -64,6 +65,7 @@ t/fallback.t test script t/gb2312.enc test data t/gb2312.utf test data t/grow.t test script +t/guess.t test script t/jisx0201.enc test data t/jisx0201.utf test data t/jisx0208.enc test data @@ -73,7 +75,9 @@ t/jisx0212.utf test data t/jperl.t test script t/ksc5601.enc test data t/ksc5601.utf test data +t/mime-header.t test script t/perlio.t test script +t/unibench.pl benchmark script ucm/8859-1.ucm Unicode Character Map ucm/8859-10.ucm Unicode Character Map ucm/8859-11.ucm Unicode Character Map diff --git a/ext/Encode/TW/Makefile.PL b/ext/Encode/TW/Makefile.PL index 4fdae9e3f5..8f12a81aee 100644 --- a/ext/Encode/TW/Makefile.PL +++ b/ext/Encode/TW/Makefile.PL @@ -1,6 +1,7 @@ use 5.7.2; use strict; use ExtUtils::MakeMaker; +use strict; my %tables = (big5_t => ['big5-eten.ucm', 'big5-hkscs.ucm', @@ -8,6 +9,20 @@ my %tables = (big5_t => ['big5-eten.ucm', 'cp950.ucm'], ); +unless ($ENV{AGGREGATE_TABLES}){ + my @ucm; + for my $k (keys %tables){ + push @ucm, @{$tables{$k}}; + } + %tables = (); + my $seq = 0; + for my $ucm (sort @ucm){ + # 8.3 compliance ! + my $t = sprintf ("%s_%02d_t", substr($ucm, 0, 2), $seq++); + $tables{$t} = [ $ucm ]; + } +} + my $name = 'TW'; WriteMakefile( diff --git a/ext/Encode/Unicode/Unicode.xs b/ext/Encode/Unicode/Unicode.xs index 4689b498e1..e3ad82c7f0 100644 --- a/ext/Encode/Unicode/Unicode.xs +++ b/ext/Encode/Unicode/Unicode.xs @@ -1,5 +1,5 @@ /* - $Id: Unicode.xs,v 1.3 2002/04/20 23:43:47 dankogai Exp $ + $Id: Unicode.xs,v 1.4 2002/04/26 03:02:04 dankogai Exp $ */ #define PERL_NO_GET_CONTEXT @@ -61,7 +61,7 @@ enc_pack(pTHX_ SV *result,STRLEN size,U8 endian,UV value) d += SvCUR(result); SvCUR_set(result,SvCUR(result)+size); while (size--) { - *d++ = value & 0xFF; + *d++ = (U8)(value & 0xFF); value >>= 8; } break; @@ -70,7 +70,7 @@ enc_pack(pTHX_ SV *result,STRLEN size,U8 endian,UV value) SvCUR_set(result,SvCUR(result)+size); d += SvCUR(result); while (size--) { - *--d = value & 0xFF; + *--d = (U8)(value & 0xFF); value >>= 8; } break; diff --git a/ext/Encode/lib/Encode/Config.pm b/ext/Encode/lib/Encode/Config.pm index dcbc524b7b..a834967a11 100644 --- a/ext/Encode/lib/Encode/Config.pm +++ b/ext/Encode/lib/Encode/Config.pm @@ -2,7 +2,7 @@ # Demand-load module list # package Encode::Config; -our $VERSION = do { my @r = (q$Revision: 1.5 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; +our $VERSION = do { my @r = (q$Revision: 1.6 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; use strict; @@ -139,6 +139,11 @@ unless (ord("A") == 193){ #'big5plus' => 'Encode::HanExtra', #'euc-tw' => 'Encode::HanExtra', #'gb18030' => 'Encode::HanExtra', + + 'MIME-Header' => 'Encode::MIME::Header', + 'MIME-B' => 'Encode::MIME::Header', + 'MIME-Q' => 'Encode::MIME::Header', + ); } diff --git a/ext/Encode/lib/Encode/Guess.pm b/ext/Encode/lib/Encode/Guess.pm new file mode 100644 index 0000000000..d2aac44565 --- /dev/null +++ b/ext/Encode/lib/Encode/Guess.pm @@ -0,0 +1,297 @@ +package Encode::Guess; +use strict; +use Carp; + +use Encode qw(:fallbacks find_encoding); +our $VERSION = do { my @r = (q$Revision: 1.2 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; + +my $Canon = 'Guess'; +our $DEBUG = 0; +our %DEF_SUSPECTS = map { $_ => find_encoding($_) } qw(ascii utf8); +$Encode::Encoding{$Canon} = + bless { + Name => $Canon, + Suspects => { %DEF_SUSPECTS }, + } => __PACKAGE__; + +sub name { shift->{'Name'} } +sub new_sequence { $_[0] } +sub needs_lines { 1 } +sub perlio_ok { 0 } +sub DESTROY{} + +our @EXPORT = qw(guess_encoding); + +sub import { # Exporter not used so we do it on our own + my $callpkg = caller; + for my $item (@EXPORT){ + no strict 'refs'; + *{"$callpkg\::$item"} = \&{"$item"}; + } + set_suspects(@_); +} + +sub set_suspects{ + my $class = shift; + my $self = ref($class) ? $class : $Encode::Encoding{$Canon}; + $self->{Suspects} = { %DEF_SUSPECTS }; + $self->add_suspects(@_); +} + +sub add_suspects{ + my $class = shift; + my $self = ref($class) ? $class : $Encode::Encoding{$Canon}; + for my $c (@_){ + my $e = find_encoding($c) or die "Unknown encoding: $c"; + $self->{Suspects}{$e->name} = $e; + $DEBUG and warn "Added: ", $e->name; + } +} + +sub decode($$;$){ + my ($obj, $octet, $chk) = @_; + my $guessed = guess($obj, $octet); + ref($guessed) or croak $guessed; + my $utf8 = $guessed->decode($octet, $chk); + $_[1] = $octet if $chk; + return $utf8; +} + +sub encode{ + croak "Tsk, tsk, tsk. You can't be too lazy here!"; +} + +sub guess_encoding{ + guess($Encode::Encoding{$Canon}, @_); +} + +sub guess { + my $class = shift; + my $obj = ref($class) ? $class : $Encode::Encoding{$Canon}; + my $octet = shift; + # cheat 0: utf8 flag; + Encode::is_utf8($octet) and return find_encoding('utf8'); + # cheat 1: BOM + use Encode::Unicode; + my $BOM = unpack('n', $octet); + return find_encoding('UTF-16') + if ($BOM == 0xFeFF or $BOM == 0xFFFe); + $BOM = unpack('N', $octet); + return find_encoding('UTF-32') + if ($BOM == 0xFeFF or $BOM == 0xFFFe0000); + + my %try = %{$obj->{Suspects}}; + for my $c (@_){ + my $e = find_encoding($c) or die "Unknown encoding: $c"; + $try{$e->name} = $e; + $DEBUG and warn "Added: ", $e->name; + } + my $nline = 1; + for my $line (split /\r|\n|\r\n/, $octet){ + # cheat 2 -- \e in the string + if ($line =~ /\e/o){ + my @keys = keys %try; + delete @try{qw/utf8 ascii/}; + for my $k (@keys){ + ref($try{$k}) eq 'Encode::XS' and delete $try{$k}; + } + } + my %ok = %try; + # warn join(",", keys %try); + for my $k (keys %try){ + my $scratch = $line; + $try{$k}->decode($scratch, FB_QUIET); + if ($scratch eq ''){ + $DEBUG and warn sprintf("%4d:%-24s ok\n", $nline, $k); + }else{ + use bytes (); + $DEBUG and + warn sprintf("%4d:%-24s not ok; %d bytes left\n", + $nline, $k, bytes::length($scratch)); + delete $ok{$k}; + + } + } + %ok or return "No appropriate encodings found!"; + if (scalar(keys(%ok)) == 1){ + my ($retval) = values(%ok); + return $retval; + } + %try = %ok; $nline++; + } + $try{ascii} or + return "Encodings too ambiguous: ", join(" or ", keys %try); + return $try{ascii}; +} + + + +1; +__END__ + +=head1 NAME + +Encode::Guess -- Guesses encoding from data + +=head1 SYNOPSIS + + # if you are sure $data won't contain anything bogus + + use Encode::Guess qw/euc-jp shiftjis 7bit-jis/; + my $utf8 = decode("Guess", $data); + my $data = encode("Guess", $utf8); # this doesn't work! + + # more elaborate way + use Encode::Guess, + my $enc = guess_encoding($data, qw/euc-jp shiftjis 7bit-jis/); + ref($enc) or die "Can't guess: $enc"; # trap error this way + $utf8 = $enc->decode($data); + # or + $utf8 = decode($enc->name, $data) + +=head1 ABSTRACT + +Encode::Guess enables you to guess in what encoding a given data is +encoded, or at least tries to. + +=head1 DESCRIPTION + +By default, it checks only ascii, utf8 and UTF-16/32 with BOM. + + use Encode::Guess; # ascii/utf8/BOMed UTF + +To use it more practically, you have to give the names of encodings to +check (I<suspects> as follows). The name of suspects can either be +canonical names or aliases. + + # tries all major Japanese Encodings as well + use Encode::Guess qw/euc-jp shiftjis 7bit-jis/; + +=over 4 + +=item Encode::Guess->set_suspects + +You can also change the internal suspects list via C<set_suspects> +method. + + use Encode::Guess; + Encode::Guess->set_suspects(qw/euc-jp shiftjis 7bit-jis/); + +=item Encode::Guess->add_suspects + +Or you can use C<add_suspects> method. The difference is that +C<set_suspects> flushes the current suspects list while +C<add_suspects> adds. + + use Encode::Guess; + Encode::Guess->add_suspects(qw/euc-jp shiftjis 7bit-jis/); + # now the suspects are euc-jp,shiftjis,7bit-jis, AND + # euc-kr,euc-cn, and big5-eten + Encode::Guess->add_suspects(qw/euc-kr euc-cn big5-eten/); + +=item Encode::decode("Guess" ...) + +When you are content with suspects list, you can now + + my $utf8 = Encode::decode("Guess", $data); + +=item Encode::Guess->guess($data) + +But it will croak if Encode::Guess fails to eliminate all other +suspects but the right one or no suspect was good. So you should +instead try this; + + my $decoder = Encode::Guess->guess($data); + +On success, $decoder is an object that is documented in +L<Encode::Encoding>. So you can now do this; + + my $utf8 = $decoder->decode($data); + +On failure, $decoder now contains an error message so the whole thing +would be as follows; + + my $decoder = Encode::Guess->guess($data); + die $decoder unless ref($decoder); + my $utf8 = $decoder->decode($data); + +=item guess_encoding($data, [, I<list of suspects>]) + +You can also try C<guess_encoding> function which is exported by +default. It takes $data to check and it also takes the list of +suspects by option. The optional suspect list is I<not reflected> to +the internal suspects list. + + my $decoder = guess_encoding($data, qw/euc-jp euc-kr euc-cn/); + die $decoder unless ref($decoder); + my $utf8 = $decoder->decode($data); + # check only ascii and utf8 + my $decoder = guess_encoding($data); + +=back + +=head1 CAVEATS + +=over 4 + +=item * + +Because of the algorithm used, ISO-8859 series and other single-byte +encodings do not work well unless either one of ISO-8859 is the only +one suspect (besides ascii and utf8). + + use Encode::Guess; + # perhaps ok + my $decoder = guess_encoding($data, 'latin1'); + # definitely NOT ok + my $decoder = guess_encoding($data, qw/latin1 greek/); + +The reason is that Encode::Guess guesses encoding by trial and error. +It first splits $data into lines and tries to decode the line for each +suspect. It keeps it going until all but one encoding was eliminated +out of suspects list. ISO-8859 series is just too successful for most +cases (because it fills almost all code points in \x00-\xff). + +=item * + +Do not mix national standard encodings and the corresponding vendor +encodings. + + # a very bad idea + my $decoder + = guess_encoding($data, qw/shiftjis MacJapanese cp932/); + +The reason is that vendor encoding is usually a superset of national +standard so it becomes too ambiguous for most cases. + +=item * + +On the other hand, mixing various national standard encodings +automagically works unless $data is too short to allow for guessing. + + # This is ok if $data is long enough + my $decoder = + guess_encoding($data, qw/euc-cn + euc-jp shiftjis 7bit-jis + euc-kr + big5-eten/); + +=item * + +DO NOT PUT TOO MANY SUSPECTS! Don't you try something like this! + + my $decoder = guess_encoding($data, + Encode->encodings(":all")); + +=back + +It is, after all, just a guess. You should alway be explicit when it +comes to encodings. But there are some, especially Japanese, +environment that guess-coding is a must. Use this module with care. + +=head1 SEE ALSO + +L<Encode>, L<Encode::Encoding> + +=cut + diff --git a/ext/Encode/lib/Encode/JP/JIS7.pm b/ext/Encode/lib/Encode/JP/JIS7.pm index c0a0d0622a..09ec94f9d6 100644 --- a/ext/Encode/lib/Encode/JP/JIS7.pm +++ b/ext/Encode/lib/Encode/JP/JIS7.pm @@ -1,7 +1,7 @@ package Encode::JP::JIS7; use strict; -our $VERSION = do { my @r = (q$Revision: 1.6 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; +our $VERSION = do { my @r = (q$Revision: 1.7 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; use Encode qw(:fallbacks); @@ -42,9 +42,13 @@ our $DEBUG = 0; sub decode($$;$) { - my ($obj,$str,$chk) = @_; - my $residue = jis_euc(\$str); - # This is for PerlIO + my ($obj, $str, $chk) = @_; + my $residue = ''; + if ($chk){ + $str =~ s/([^\x00-\x7f].*)$//so; + $1 and $residue = $1; + } + $residue .= jis_euc(\$str); $_[1] = $residue if $chk; return Encode::decode('euc-jp', $str, FB_PERLQQ); } diff --git a/ext/Encode/lib/Encode/MIME/Header.pm b/ext/Encode/lib/Encode/MIME/Header.pm new file mode 100644 index 0000000000..ce7b872876 --- /dev/null +++ b/ext/Encode/lib/Encode/MIME/Header.pm @@ -0,0 +1,212 @@ +package Encode::MIME::Header; +use strict; +# use warnings; +our $VERSION = do { my @r = (q$Revision: 1.2 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; + +use Encode qw(find_encoding encode_utf8); +use MIME::Base64; +use Carp; + +my %seed = + ( + decode_b => '1', # decodes 'B' encoding ? + decode_q => '1', # decodes 'Q' encoding ? + encode => 'B', # encode with 'B' or 'Q' ? + bpl => 75, # bytes per line + ); + +$Encode::Encoding{'MIME-Header'} = + bless { + %seed, + Name => 'MIME-Header', + } => __PACKAGE__; + +$Encode::Encoding{'MIME-B'} = + bless { + %seed, + decode_q => 0, + Name => 'MIME-B', + } => __PACKAGE__; + +$Encode::Encoding{'MIME-Q'} = + bless { + %seed, + decode_q => 1, + encode => 'Q', + Name => 'MIME-Q', + } => __PACKAGE__; + +sub name { shift->{'Name'} } +sub new_sequence { $_[0] } +sub needs_lines { 1 } +sub perlio_ok{ 0 }; + +sub decode($$;$){ + use utf8; + my ($obj, $str, $chk) = @_; + # zap spaces between encoded words + $str =~ s/\?=\s+=\?/\?==\?/gos; + # multi-line header to single line + $str =~ s/(:?\r|\n|\r\n)[ \t]//gos; + $str =~ + s{ + =\? # begin encoded word + ([0-9A-Za-z\-]+) # charset (encoding) + \?([QqBb])\? # delimiter + (.*?) # Base64-encodede contents + \?= # end encoded word + }{ + if (uc($2) eq 'B'){ + $obj->{decode_b} or croak qq(MIME "B" unsupported); + decode_b($1, $3); + }elsif(uc($2) eq 'Q'){ + $obj->{decode_q} or croak qq(MIME "Q" unsupported); + decode_q($1, $3); + }else{ + croak qq(MIME "$2" encoding is nonexistent!); + } + }egox; + $_[1] = '' if $chk; + return $str; +} + +sub decode_b{ + my $enc = shift; + my $d = find_encoding($enc) or croak(Unknown encoding "$enc"); + my $db64 = decode_base64(shift); + return $d->decode($db64, Encode::FB_PERLQQ); +} + +sub decode_q{ + my ($enc, $q) = @_; + my $d = find_encoding($enc) or croak(Unknown encoding "$enc"); + $q =~ s/_/ /go; + $q =~ s/=([0-9A-Fa-f]{2})/pack("C", hex($1))/ego; + return $d->decode($q, Encode::FB_PERLQQ); +} + +my $especials = + join('|' => + map {quotemeta(chr($_))} + unpack("C*", qq{()<>@,;:\"\'/[]?.=})); + +my $re_especials = qr/$especials/o; + +sub encode($$;$){ + my ($obj, $str, $chk) = @_; + my @line = (); + for my $line (split /\r|\n|\r\n/o, $str){ + my (@word, @subline); + for my $word (split /($re_especials)/o, $line){ + if ($word =~ /[^\x00-\x7f]/o){ + push @word, $obj->_encode($word); + }else{ + push @word, $word; + } + } + my $subline = ''; + for my $word (@word){ + use bytes (); + if (bytes::length($subline) + bytes::length($word) > $obj->{bpl}){ + push @subline, $subline; + $subline = ''; + } + $subline .= $word; + } + $subline and push @subline, $subline; + push @line, join("\n " => @subline); + } + $_[1] = '' if $chk; + return join("\n", @line); +} + +use constant HEAD => '=?UTF-8?'; +use constant TAIL => '?='; +use constant SINGLE => { B => \&_encode_b, Q => \&_encode_q, }; + +sub _encode{ + my ($o, $str) = @_; + my $enc = $o->{encode}; + my $llen = ($o->{bpl} - length(HEAD) - 2 - length(TAIL)); + $llen *= $enc eq 'B' ? 3/4 : 1/3; + my @result = (); + my $chunk = ''; + while(my $chr = substr($str, 0, 1, '')){ + use bytes (); + if (bytes::length($chunk) + bytes::length($chr) > $llen){ + push @result, SINGLE->{$enc}($chunk); + $chunk = ''; + } + $chunk .= $chr; + } + $chunk and push @result, SINGLE->{$enc}($chunk); + return @result; +} + +sub _encode_b{ + HEAD . 'B?' . encode_base64(encode_utf8(shift), '') . TAIL; +} + +sub _encode_q{ + my $chunk = shift; + $chunk =~ s{ + ([^0-9A-Za-z]) + }{ + join("" => map {sprintf "=%02X", $_} unpack("C*", $1)) + }egox; + return HEAD . 'Q?' . $chunk . TAIL; +} + +1; +__END__ + +=head1 NAME + +Encode::MIME::Header -- MIME 'B' and 'Q' header encoding + +=head1 SYNOPSIS + + use Encode qw/encode decode/; + $utf8 = decode('MIME-Header', $header); + $header = encode('MIME-Header', $utf8); + +=head1 ABSTRACT + +This module implements RFC 2047 Mime Header Encoding. There are 3 +variant encoding names; C<MIME-Header>, C<MIME-B> and C<MIME-Q>. The +difference is described below + + decode() encode() + ---------------------------------------------- + MIME-Header Both B and Q =?UTF-8?B?....?= + MIME-B B only; Q croaks =?UTF-8?B?....?= + MIME-Q Q only; B croaks =?UTF-8?Q?....?= + +=head1 DESCRIPTION + +When you decode(=?I<encoding>?I<X>?I<ENCODED WORD>?=), I<ENCODED WORD> +is extracted and decoded for I<X> encoding (B for Base64, Q for +Quoted-Printable). Then the decoded chunk is fed to +decode(I<encoding>). So long as I<encoding> is supported by Encode, +any source encoding is fine. + +When you encode, it just encodes UTF-8 string with I<X> encoding then +quoted with =?UTF-8?I<X>?....?= . The parts that RFC 2047 forbids to +encode are left as is and long lines are folded within 76 bytes per +line. + +=head1 BUGS + +It would be nice to support encoding to non-UTF8, such as =?ISO-2022-JP? +and =?ISO-8859-1?= but that makes the implementation too complicated. +These days major mail agents all support =?UTF-8? so I think it is +just good enough. + +=head1 SEE ALSO + +L<Encode> + +RFC 2047, L<http://www.faqs.org/rfcs/rfc2047.html> and many other +locations. + +=cut diff --git a/ext/Encode/t/CJKT.t b/ext/Encode/t/CJKT.t index 4540034e55..31c0aa1916 100644 --- a/ext/Encode/t/CJKT.t +++ b/ext/Encode/t/CJKT.t @@ -55,7 +55,8 @@ for my $charset (sort keys %Charset){ open $src, "<$src_enc" or die "$src_enc : $!"; - binmode($src); + # binmode($src); # not needed! + $txt = join('',<$src>); close($src); diff --git a/ext/Encode/t/at-cn.t b/ext/Encode/t/at-cn.t index 893c29fa6d..6249feee38 100644 --- a/ext/Encode/t/at-cn.t +++ b/ext/Encode/t/at-cn.t @@ -19,9 +19,11 @@ use strict; use Test::More tests => 29; use Encode; +no utf8; # we have raw Chinese encodings here + use_ok('Encode::CN'); -# Since JP.t already test basic file IO, we will just focus on +# Since JP.t already tests basic file IO, we will just focus on # internal encode / decode test here. Unfortunately, to test # against all the UniHan characters will take a huge disk space, # not to mention the time it will take, and the fact that Perl diff --git a/ext/Encode/t/at-tw.t b/ext/Encode/t/at-tw.t index 830eb8686a..11abbf3807 100644 --- a/ext/Encode/t/at-tw.t +++ b/ext/Encode/t/at-tw.t @@ -21,9 +21,11 @@ use strict; use Test::More tests => 17; use Encode; +no utf8; # we have raw Chinese encodings here + use_ok('Encode::TW'); -# Since JP.t already test basic file IO, we will just focus on +# Since JP.t already tests basic file IO, we will just focus on # internal encode / decode test here. Unfortunately, to test # against all the UniHan characters will take a huge disk space, # not to mention the time it will take, and the fact that Perl diff --git a/ext/Encode/t/fallback.t b/ext/Encode/t/fallback.t index cf867beb01..3b6625851c 100644 --- a/ext/Encode/t/fallback.t +++ b/ext/Encode/t/fallback.t @@ -13,17 +13,18 @@ BEGIN { use strict; #use Test::More qw(no_plan); -use Test::More tests => 15; +use Test::More tests => 19; use Encode q(:all); my $original = ''; my $nofallback = ''; -my ($fallenback, $quiet, $perlqq); +my ($fallenback, $quiet, $perlqq, $htmlcref, $xmlcref); for my $i (0x20..0x7e){ $original .= chr($i); } -$fallenback = $quiet = $perlqq = $nofallback = $original; +$fallenback = $quiet = +$perlqq = $htmlcref = $xmlcref = $nofallback = $original; my $residue = ''; for my $i (0x80..0xff){ @@ -31,6 +32,8 @@ for my $i (0x80..0xff){ $residue .= chr($i); $fallenback .= '?'; $perlqq .= sprintf("\\x{%04x}", $i); + $htmlcref .= sprintf("&#%d;", $i); + $xmlcref .= sprintf("&#x%x;", $i); } utf8::upgrade($original); my $meth = find_encoding('ascii'); @@ -75,3 +78,13 @@ $src = $original; $dst = $meth->encode($src, FB_PERLQQ); is($dst, $perlqq, "FB_PERLQQ"); is($src, '', "FB_PERLQQ residue"); + +$src = $original; +$dst = $meth->encode($src, FB_HTMLCREF); +is($dst, $htmlcref, "FB_HTMLCREF"); +is($src, '', "FB_HTMLCREF residue"); + +$src = $original; +$dst = $meth->encode($src, FB_XMLCREF); +is($dst, $xmlcref, "FB_XMLCREF"); +is($src, '', "FB_XMLCREF residue"); diff --git a/ext/Encode/t/guess.t b/ext/Encode/t/guess.t new file mode 100644 index 0000000000..ace13ddec7 --- /dev/null +++ b/ext/Encode/t/guess.t @@ -0,0 +1,83 @@ +BEGIN { + if ($ENV{'PERL_CORE'}){ + chdir 't'; + unshift @INC, '../lib'; + } + require Config; import Config; + if ($Config{'extensions'} !~ /\bEncode\b/) { + print "1..0 # Skip: Encode was not built\n"; + exit 0; + } + $| = 1; +} + +use strict; +use File::Basename; +use File::Spec; +use Encode qw(decode encode find_encoding _utf8_off); + +#use Test::More qw(no_plan); +use Test::More tests => 17; +use_ok("Encode::Guess"); +{ + no warnings; + $Encode::Guess::DEBUG = shift || 0; +} + +my $ascii = join('' => map {chr($_)}(0x21..0x7e)); +my $latin1 = join('' => map {chr($_)}(0xa1..0xfe)); +my $utf8on = join('' => map {chr($_)}(0x3000..0x30fe)); +my $utf8off = $utf8on; _utf8_off($utf8off); +my $utf16 = encode('UTF-16', $utf8on); +my $utf32 = encode('UTF-32', $utf8on); + +is(guess_encoding($ascii)->name, 'ascii', 'ascii'); +like(guess_encoding($latin1), qr/No appropriate encoding/io, 'no ascii'); +is(guess_encoding($latin1, 'latin1')->name, 'iso-8859-1', 'iso-8859-1'); +is(guess_encoding($utf8on)->name, 'utf8', 'utf8 w/ flag'); +is(guess_encoding($utf8off)->name, 'utf8', 'utf8 w/o flag'); +is(guess_encoding($utf16)->name, 'UTF-16', 'UTF-16'); +is(guess_encoding($utf32)->name, 'UTF-32', 'UTF-32'); + +my $jisx0201 = File::Spec->catfile(dirname(__FILE__), 'jisx0201.utf'); +my $jisx0208 = File::Spec->catfile(dirname(__FILE__), 'jisx0208.utf'); +my $jisx0212 = File::Spec->catfile(dirname(__FILE__), 'jisx0212.utf'); + +open my $fh, $jisx0208 or die "$jisx0208: $!"; +$utf8off = join('' => <$fh>); +close $fh; +$utf8on = decode('utf8', $utf8off); + +my @jp = qw(7bit-jis shiftjis euc-jp); + +Encode::Guess->set_suspects(@jp); + +for my $jp (@jp){ + my $test = encode($jp, $utf8on); + is(guess_encoding($test)->name, $jp, "JP:$jp"); +} + +is (decode('Guess', encode('euc-jp', $utf8on)), $utf8on, "decode('Guess')"); +eval{ encode('Guess', $utf8on) }; +like($@, qr/lazy/io, "no encode()"); + +my %CJKT = + ( + 'euc-cn' => File::Spec->catfile(dirname(__FILE__), 'gb2312.utf'), + 'euc-jp' => File::Spec->catfile(dirname(__FILE__), 'jisx0208.utf'), + 'euc-kr' => File::Spec->catfile(dirname(__FILE__), 'ksc5601.utf'), + 'big5-eten' => File::Spec->catfile(dirname(__FILE__), 'big5-eten.utf'), +); + +Encode::Guess->set_suspects(keys %CJKT); + +for my $name (keys %CJKT){ + open my $fh, $CJKT{$name} or die "$CJKT{$name}: $!"; + $utf8off = join('' => <$fh>); + close $fh; + + my $test = encode($name, decode('utf8', $utf8off)); + is(guess_encoding($test)->name, $name, "CJKT:$name"); +} + +__END__; diff --git a/ext/Encode/t/jperl.t b/ext/Encode/t/jperl.t index faaf743f89..82f7a84dd6 100644 --- a/ext/Encode/t/jperl.t +++ b/ext/Encode/t/jperl.t @@ -1,5 +1,5 @@ # -# $Id: jperl.t,v 1.23 2002/04/22 09:48:07 dankogai Exp $ +# $Id: jperl.t,v 1.24 2002/04/26 03:02:04 dankogai Exp $ # # This script is written in euc-jp @@ -20,6 +20,8 @@ BEGIN { $| = 1; } +no utf8; # we have raw Japanese encodings here + use strict; use Test::More tests => 18; my $Debug = shift; diff --git a/ext/Encode/t/mime-header.t b/ext/Encode/t/mime-header.t new file mode 100644 index 0000000000..826efbfddd --- /dev/null +++ b/ext/Encode/t/mime-header.t @@ -0,0 +1,77 @@ +# +# $Id: mime-header.t,v 1.3 2002/04/26 03:07:59 dankogai Exp $ +# This script is written in utf8 +# +BEGIN { + if ($ENV{'PERL_CORE'}){ + chdir 't'; + unshift @INC, '../lib'; + } + require Config; import Config; + if ($Config{'extensions'} !~ /\bEncode\b/) { + print "1..0 # Skip: Encode was not built\n"; + exit 0; + } + $| = 1; +} + +use strict; +#use Test::More qw(no_plan); +use Test::More tests => 6; +use_ok("Encode::MIME::Header"); + +my $eheader =<<'EOS'; +From: =?US-ASCII?Q?Keith_Moore?= <moore@cs.utk.edu> +To: =?ISO-8859-1?Q?Keld_J=F8rn_Simonsen?= <keld@dkuug.dk> +CC: =?ISO-8859-1?Q?Andr=E9?= Pirard <PIRARD@vm1.ulg.ac.be> +Subject: =?ISO-8859-1?B?SWYgeW91IGNhbiByZWFkIHRoaXMgeW8=?= + =?ISO-8859-2?B?dSB1bmRlcnN0YW5kIHRoZSBleGFtcGxlLg==?= +EOS + +my $dheader=<<"EOS"; +From: Keith Moore <moore\@cs.utk.edu> +To: Keld J\xF8rn Simonsen <keld\@dkuug.dk> +CC: Andr\xE9 Pirard <PIRARD\@vm1.ulg.ac.be> +Subject: If you can read this you understand the example. +EOS + +is(Encode::decode('MIME-Header', $eheader), $dheader, "decode (RFC2047)"); + +use utf8; + +$dheader=<<'EOS'; +From: 小飼 弾 <dankogai@dan.co.jp> +To: dankogai@dan.co.jp (小飼=Kogai, 弾=Dan) +Subject: 漢字、カタカナ、ひらがなを含む、非常に長いタイトル行が一体全体どのようにしてEncodeされるのか？ +EOS + +my $bheader =<<'EOS'; +From:=?UTF-8?B?IOWwj+mjvCDlvL4g?=<dankogai@dan.co.jp> +To: dankogai@dan.co.jp (=?UTF-8?B?5bCP6aO8?==Kogai,=?UTF-8?B?IOW8vg==?==Dan + ) +Subject: + =?UTF-8?B?IOa8ouWtl+OAgeOCq+OCv+OCq+ODiuOAgeOBsuOCieOBjOOBquOCkuWQq+OCgA==?= + =?UTF-8?B?44CB6Z2e5bi444Gr6ZW344GE44K/44Kk44OI44Or6KGM44GM5LiA5L2T5YWo?= + =?UTF-8?B?5L2T44Gp44Gu44KI44GG44Gr44GX44GmRW5jb2Rl44GV44KM44KL44Gu44GL?= + =?UTF-8?B?77yf?= +EOS + +my $qheader=<<'EOS'; +From:=?UTF-8?Q?=20=E5=B0=8F=E9=A3=BC=20=E5=BC=BE=20?=<dankogai@dan.co.jp> +To: dankogai@dan.co.jp (=?UTF-8?Q?=E5=B0=8F=E9=A3=BC?==Kogai, + =?UTF-8?Q?=20=E5=BC=BE?==Dan) +Subject: + =?UTF-8?Q?=20=E6=BC=A2=E5=AD=97=E3=80=81=E3=82=AB=E3=82=BF=E3=82=AB?= + =?UTF-8?Q?=E3=83=8A=E3=80=81=E3=81=B2=E3=82=89=E3=81=8C=E3=81=AA=E3=82=92?= + =?UTF-8?Q?=E5=90=AB=E3=82=80=E3=80=81=E9=9D=9E=E5=B8=B8=E3=81=AB=E9=95=B7?= + =?UTF-8?Q?=E3=81=84=E3=82=BF=E3=82=A4=E3=83=88=E3=83=AB=E8=A1=8C=E3=81=8C?= + =?UTF-8?Q?=E4=B8=80=E4=BD=93=E5=85=A8=E4=BD=93=E3=81=A9=E3=81=AE=E3=82=88?= + =?UTF-8?Q?=E3=81=86=E3=81=AB=E3=81=97=E3=81=A6Encode=E3=81=95?= + =?UTF-8?Q?=E3=82=8C=E3=82=8B=E3=81=AE=E3=81=8B=EF=BC=9F?= +EOS + +is(Encode::decode('MIME-Header', $bheader), $dheader, "decode B"); +is(Encode::decode('MIME-Header', $qheader), $dheader, "decode Q"); +is(Encode::encode('MIME-B', $dheader)."\n", $bheader, "encode B"); +is(Encode::encode('MIME-Q', $dheader)."\n", $qheader, "encode Q"); +__END__; diff --git a/ext/File/Glob/bsd_glob.c b/ext/File/Glob/bsd_glob.c index 14af31cba2..7ec58aa489 100644 --- a/ext/File/Glob/bsd_glob.c +++ b/ext/File/Glob/bsd_glob.c @@ -520,7 +520,7 @@ globtilde(const Char *pattern, Char *patbuf, size_t patbuf_len, glob_t *pglob) /* Copy up to the end of the string or / */ eb = &patbuf[patbuf_len - 1]; for (p = pattern + 1, h = (char *) patbuf; - h < (char*)eb && *p && *p != BG_SLASH; *h++ = *p++) + h < (char*)eb && *p && *p != BG_SLASH; *h++ = (char)*p++) ; *h = BG_EOS; @@ -1164,7 +1164,7 @@ static int g_Ctoc(register const Char *str, char *buf, STRLEN len) { while (len--) { - if ((*buf++ = *str++) == BG_EOS) + if ((*buf++ = (char)*str++) == BG_EOS) return (0); } return (1); diff --git a/ext/IO/IO.xs b/ext/IO/IO.xs index 7edbf2c3e3..26b332b6a4 100644 --- a/ext/IO/IO.xs +++ b/ext/IO/IO.xs @@ -242,7 +242,7 @@ PPCODE: for(i=1, j=0 ; j < nfd ; j++) { fds[j].fd = SvIV(ST(i)); i++; - fds[j].events = SvIV(ST(i)); + fds[j].events = (short)SvIV(ST(i)); i++; fds[j].revents = 0; } diff --git a/ext/Opcode/Opcode.xs b/ext/Opcode/Opcode.xs index 6ad7107966..66710edeb7 100644 --- a/ext/Opcode/Opcode.xs +++ b/ext/Opcode/Opcode.xs @@ -151,7 +151,7 @@ verify_opset(pTHX_ SV *opset, int fatal) if (!SvOK(opset)) err = "undefined"; else if (!SvPOK(opset)) err = "wrong type"; - else if (SvCUR(opset) != opset_len) err = "wrong size"; + else if (SvCUR(opset) != (STRLEN)opset_len) err = "wrong size"; if (err && fatal) { croak("Invalid opset: %s", err); } @@ -178,7 +178,7 @@ set_opset_bits(pTHX_ char *bitmap, SV *bitspec, int on, char *opname) else bitmap[offset] &= ~(1 << bit); } - else if (SvPOK(bitspec) && SvCUR(bitspec) == opset_len) { + else if (SvPOK(bitspec) && SvCUR(bitspec) == (STRLEN)opset_len) { STRLEN len; char *specbits = SvPV(bitspec, len); @@ -464,7 +464,7 @@ PPCODE: croak("panic: opcode %d (%s) out of range",myopcode,opname); XPUSHs(sv_2mortal(newSVpv(op_desc[myopcode], 0))); } - else if (SvPOK(bitspec) && SvCUR(bitspec) == opset_len) { + else if (SvPOK(bitspec) && SvCUR(bitspec) == (STRLEN)opset_len) { int b, j; STRLEN n_a; char *bitmap = SvPV(bitspec,n_a); diff --git a/ext/POSIX/POSIX.xs b/ext/POSIX/POSIX.xs index 2d1abf3060..c92c389788 100644 --- a/ext/POSIX/POSIX.xs +++ b/ext/POSIX/POSIX.xs @@ -457,7 +457,8 @@ __END__ if (memEQ(name, "WSTOPSIG", 8)) { /* ^ */ #ifdef WSTOPSIG - *arg_result = WSTOPSIG(WMUNGE(*arg_result)); + int i = *arg_result; + *arg_result = WSTOPSIG(WMUNGE(i)); return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; @@ -468,7 +469,8 @@ __END__ if (memEQ(name, "WTERMSIG", 8)) { /* ^ */ #ifdef WTERMSIG - *arg_result = WTERMSIG(WMUNGE(*arg_result)); + int i = *arg_result; + *arg_result = WTERMSIG(WMUNGE(i)); return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; @@ -491,7 +493,8 @@ __END__ case 9: if (memEQ(name, "WIFEXITED", 9)) { #ifdef WIFEXITED - *arg_result = WIFEXITED(WMUNGE(*arg_result)); + int i = *arg_result; + *arg_result = WIFEXITED(WMUNGE(i)); return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; @@ -501,7 +504,8 @@ __END__ case 10: if (memEQ(name, "WIFSTOPPED", 10)) { #ifdef WIFSTOPPED - *arg_result = WIFSTOPPED(WMUNGE(*arg_result)); + int i = *arg_result; + *arg_result = WIFSTOPPED(WMUNGE(i)); return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; @@ -517,7 +521,8 @@ __END__ if (memEQ(name, "WEXITSTATUS", 11)) { /* ^ */ #ifdef WEXITSTATUS - *arg_result = WEXITSTATUS(WMUNGE(*arg_result)); + int i = *arg_result; + *arg_result = WEXITSTATUS(WMUNGE(i)); return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; @@ -528,7 +533,8 @@ __END__ if (memEQ(name, "WIFSIGNALED", 11)) { /* ^ */ #ifdef WIFSIGNALED - *arg_result = WIFSIGNALED(WMUNGE(*arg_result)); + int i = *arg_result; + *arg_result = WIFSIGNALED(WMUNGE(i)); return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; diff --git a/ext/PerlIO/encoding/encoding.xs b/ext/PerlIO/encoding/encoding.xs index a9b74354d0..bff16e73f6 100644 --- a/ext/PerlIO/encoding/encoding.xs +++ b/ext/PerlIO/encoding/encoding.xs @@ -145,7 +145,7 @@ PerlIOEncode_pushed(pTHX_ PerlIO * f, const char *mode, SV * arg) if (SvIV(result = get_sv("PerlIO::encoding::check", 1)) == 0){ PUSHMARK(sp); PUTBACK; - if (call_pv("Encode::FB_QUIET", G_SCALAR|G_NOARGS) != 1) { + if (call_pv("Encode::FB_QUIET", G_SCALAR) != 1) { /* should never happen */ Perl_die(aTHX_ "Encode::FB_QUIET did not return a value"); return -1; @@ -317,7 +317,7 @@ PerlIOEncode_fill(pTHX_ PerlIO * f) if (SvLEN(e->dataSV) && SvPVX(e->dataSV)) { Safefree(SvPVX(e->dataSV)); } - if (use > e->base.bufsiz) { + if (use > (SSize_t)e->base.bufsiz) { if (e->flags & NEEDS_LINES) { /* Have to grow buffer */ e->base.bufsiz = use; @@ -427,7 +427,7 @@ PerlIOEncode_flush(pTHX_ PerlIO * f) PUTBACK; s = SvPV(str, len); count = PerlIO_write(PerlIONext(f),s,len); - if (count != len) { + if ((STRLEN)count != len) { code = -1; } FREETMPS; @@ -447,7 +447,7 @@ PerlIOEncode_flush(pTHX_ PerlIO * f) if (e->dataSV && SvCUR(e->dataSV)) { s = SvPV(e->dataSV, len); count = PerlIO_unread(PerlIONext(f),s,len); - if (count != len) { + if ((STRLEN)count != len) { code = -1; } } @@ -478,7 +478,7 @@ PerlIOEncode_flush(pTHX_ PerlIO * f) PUTBACK; s = SvPV(str, len); count = PerlIO_unread(PerlIONext(f),s,len); - if (count != len) { + if ((STRLEN)count != len) { code = -1; } FREETMPS; diff --git a/ext/Storable/Storable.pm b/ext/Storable/Storable.pm index 2f352f30b7..1ac12e189d 100644 --- a/ext/Storable/Storable.pm +++ b/ext/Storable/Storable.pm @@ -79,18 +79,7 @@ $VERSION = '1.015'; eval "use Log::Agent"; -unless (defined @Log::Agent::EXPORT) { - eval q{ - sub logcroak { - require Carp; - Carp::croak(@_); - } - sub logcarp { - require Carp; - Carp::carp(@_); - } - }; -} +require Carp; # # They might miss :flock in Fcntl @@ -107,22 +96,33 @@ BEGIN { } } -sub logcroak; -sub logcarp; - # Can't Autoload cleanly as this clashes 8.3 with &retrieve sub retrieve_fd { &fd_retrieve } # Backward compatibility +# By default restricted hashes are downgraded on earlier perls. + +$Storable::downgrade_restricted = 1; bootstrap Storable; 1; __END__ +# +# Use of Log::Agent is optional. If it hasn't imported these subs then +# Autoloader will kindly supply our fallback implementation. +# + +sub logcroak { + Carp::croak(@_); +} + +sub logcarp { + Carp::carp(@_); +} # # Determine whether locking is possible, but only when needed. # -sub CAN_FLOCK { - my $CAN_FLOCK if 0; +sub CAN_FLOCK; my $CAN_FLOCK; sub CAN_FLOCK { return $CAN_FLOCK if defined $CAN_FLOCK; require Config; import Config; return $CAN_FLOCK = diff --git a/ext/Storable/Storable.xs b/ext/Storable/Storable.xs index 6098d70763..d3cb8072d5 100644 --- a/ext/Storable/Storable.xs +++ b/ext/Storable/Storable.xs @@ -58,7 +58,7 @@ #include <patchlevel.h> /* Perl's one, needed since 5.6 */ #include <XSUB.h> -#if 0 +#if 1 #define DEBUGME /* Debug mode, turns assertions on as well */ #define DASSERT /* Assertion mode */ #endif @@ -272,6 +272,39 @@ typedef unsigned long stag_t; /* Used by pre-0.6 binary format */ #define MY_VERSION "Storable(" XS_VERSION ")" + +/* + * Conditional UTF8 support. + * + */ +#ifdef SvUTF8_on +#define STORE_UTF8STR(pv, len) STORE_PV_LEN(pv, len, SX_UTF8STR, SX_LUTF8STR) +#define HAS_UTF8_SCALARS +#ifdef HeKUTF8 +#define HAS_UTF8_HASHES +#define HAS_UTF8_ALL +#else +/* 5.6 perl has utf8 scalars but not hashes */ +#endif +#else +#define SvUTF8(sv) 0 +#define STORE_UTF8STR(pv, len) CROAK(("panic: storing UTF8 in non-UTF8 perl")) +#endif +#ifndef HAS_UTF8_ALL +#define UTF8_CROAK() CROAK(("Cannot retrieve UTF8 data in non-UTF8 perl")) +#endif + +#ifdef HvPLACEHOLDERS +#define HAS_RESTRICTED_HASHES +#else +#define HVhek_PLACEHOLD 0x200 +#define RESTRICTED_HASH_CROAK() CROAK(("Cannot retrieve restricted hash")) +#endif + +#ifdef HvHASKFLAGS +#define HAS_HASH_KEY_FLAGS +#endif + /* * Fields s_tainted and s_dirty are prefixed with s_ because Perl's include * files remap tainted and dirty when threading is enabled. That's bad for @@ -293,6 +326,12 @@ typedef struct stcxt { int s_tainted; /* true if input source is tainted, at retrieve time */ int forgive_me; /* whether to be forgiving... */ int canonical; /* whether to store hashes sorted by key */ +#ifndef HAS_RESTRICTED_HASHES + int derestrict; /* whether to downgrade restrcted hashes */ +#endif +#ifndef HAS_UTF8_ALL + int use_bytes; /* whether to bytes-ify utf8 */ +#endif int s_dirty; /* context is dirty due to CROAK() -- can be cleaned */ int membuf_ro; /* true means membuf is read-only and msaved is rw */ struct extendable keybuf; /* for hash key retrieval */ @@ -658,15 +697,23 @@ static stcxt_t *Context_ptr = &Context; static char old_magicstr[] = "perl-store"; /* Magic number before 0.6 */ static char magicstr[] = "pst0"; /* Used as a magic number */ + #define STORABLE_BIN_MAJOR 2 /* Binary major "version" */ +#define STORABLE_BIN_MINOR 5 /* Binary minor "version" */ + +/* If we aren't 5.7.3 or later, we won't be writing out files that use the + * new flagged hash introdued in 2.5, so put 2.4 in the binary header to + * maximise ease of interoperation with older Storables. + * Could we write 2.3s if we're on 5.005_03? NWC + */ #if (PATCHLEVEL <= 6) -#define STORABLE_BIN_MINOR 4 /* Binary minor "version" */ +#define STORABLE_BIN_WRITE_MINOR 4 #else /* * As of perl 5.7.3, utf8 hash key is introduced. * So this must change -- dankogai */ -#define STORABLE_BIN_MINOR 5 /* Binary minor "version" */ +#define STORABLE_BIN_WRITE_MINOR 5 #endif /* (PATCHLEVEL <= 6) */ /* @@ -731,19 +778,6 @@ static char magicstr[] = "pst0"; /* Used as a magic number */ #define STORE_SCALAR(pv, len) STORE_PV_LEN(pv, len, SX_SCALAR, SX_LSCALAR) /* - * Conditional UTF8 support. - * On non-UTF8 perls, UTF8 strings are returned as normal strings. - * - */ -#ifdef SvUTF8_on -#define STORE_UTF8STR(pv, len) STORE_PV_LEN(pv, len, SX_UTF8STR, SX_LUTF8STR) -#else -#define SvUTF8(sv) 0 -#define STORE_UTF8STR(pv, len) CROAK(("panic: storing UTF8 in non-UTF8 perl")) -#define SvUTF8_on(sv) CROAK(("Cannot retrieve UTF8 data in non-UTF8 perl")) -#endif - -/* * Store undef in arrays and hashes without recursing through store(). */ #define STORE_UNDEF() do { \ @@ -1202,6 +1236,12 @@ static void init_retrieve_context(stcxt_t *cxt, int optype, int is_tainted) cxt->optype = optype; cxt->s_tainted = is_tainted; cxt->entry = 1; /* No recursion yet */ +#ifndef HAS_RESTRICTED_HASHES + cxt->derestrict = -1; /* Fetched from perl if needed */ +#endif +#ifndef HAS_UTF8_ALL + cxt->use_bytes = -1; /* Fetched from perl if needed */ +#endif } /* @@ -1902,12 +1942,21 @@ sortcmp(const void *a, const void *b) */ static int store_hash(stcxt_t *cxt, HV *hv) { - I32 len = HvTOTALKEYS(hv); + I32 len = +#ifdef HAS_RESTRICTED_HASHES + HvTOTALKEYS(hv); +#else + HvKEYS(hv); +#endif I32 i; int ret = 0; I32 riter; HE *eiter; - int flagged_hash = ((SvREADONLY(hv) || HvHASKFLAGS(hv)) ? 1 : 0); + int flagged_hash = ((SvREADONLY(hv) +#ifdef HAS_HASH_KEY_FLAGS + || HvHASKFLAGS(hv) +#endif + ) ? 1 : 0); unsigned char hash_flags = (SvREADONLY(hv) ? SHV_RESTRICTED : 0); if (flagged_hash) { @@ -1969,7 +2018,11 @@ static int store_hash(stcxt_t *cxt, HV *hv) TRACEME(("using canonical order")); for (i = 0; i < len; i++) { +#ifdef HAS_RESTRICTED_HASHES HE *he = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS); +#else + HE *he = hv_iternext(hv); +#endif SV *key = hv_iterkeysv(he); av_store(av, AvFILLp(av)+1, key); /* av_push(), really */ } @@ -2015,6 +2068,12 @@ static int store_hash(stcxt_t *cxt, HV *hv) keyval = SvPV(key, keylen_tmp); keylen = keylen_tmp; +#ifdef HAS_UTF8_HASHES + /* If you build without optimisation on pre 5.6 + then nothing spots that SvUTF8(key) is always 0, + so the block isn't optimised away, at which point + the linker dislikes the reference to + bytes_from_utf8. */ if (SvUTF8(key)) { const char *keysave = keyval; bool is_utf8 = TRUE; @@ -2039,6 +2098,7 @@ static int store_hash(stcxt_t *cxt, HV *hv) flags |= SHV_K_UTF8; } } +#endif if (flagged_hash) { PUTMARK(flags); @@ -2072,7 +2132,11 @@ static int store_hash(stcxt_t *cxt, HV *hv) char *key; I32 len; unsigned char flags; +#ifdef HV_ITERNEXT_WANTPLACEHOLDERS HE *he = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS); +#else + HE *he = hv_iternext(hv); +#endif SV *val = (he ? hv_iterval(hv, he) : 0); SV *key_sv = NULL; HEK *hek; @@ -2111,10 +2175,12 @@ static int store_hash(stcxt_t *cxt, HV *hv) flags |= SHV_K_ISSV; } else { /* Regular string key. */ +#ifdef HAS_HASH_KEY_FLAGS if (HEK_UTF8(hek)) flags |= SHV_K_UTF8; if (HEK_WASUTF8(hek)) flags |= SHV_K_WASUTF8; +#endif key = HEK_KEY(hek); } /* @@ -2629,7 +2695,7 @@ static int store_hook( PUTMARK(clen); } if (len2) - WRITE(pv, len2); /* Final \0 is omitted */ + WRITE(pv, (SSize_t)len2); /* Final \0 is omitted */ /* [<len3> <object-IDs>] */ if (flags & SHF_HAS_LIST) { @@ -2993,7 +3059,7 @@ static int magic_write(stcxt_t *cxt) : -1)); if (cxt->fio) - WRITE(magicstr, strlen(magicstr)); /* Don't write final \0 */ + WRITE(magicstr, (SSize_t)strlen(magicstr)); /* Don't write final \0 */ /* * Starting with 0.6, the "use_network_order" byte flag is also used to @@ -3011,7 +3077,7 @@ static int magic_write(stcxt_t *cxt) * introduced, for instance, but when backward compatibility is preserved. */ - PUTMARK((unsigned char) STORABLE_BIN_MINOR); + PUTMARK((unsigned char) STORABLE_BIN_WRITE_MINOR); if (use_network_order) return 0; /* Don't bother with byte ordering */ @@ -3019,7 +3085,7 @@ static int magic_write(stcxt_t *cxt) sprintf(buf, "%lx", (unsigned long) BYTEORDER); c = (unsigned char) strlen(buf); PUTMARK(c); - WRITE(buf, (unsigned int) c); /* Don't write final \0 */ + WRITE(buf, (SSize_t)c); /* Don't write final \0 */ PUTMARK((unsigned char) sizeof(int)); PUTMARK((unsigned char) sizeof(long)); PUTMARK((unsigned char) sizeof(char *)); @@ -4098,15 +4164,25 @@ static SV *retrieve_scalar(stcxt_t *cxt, char *cname) */ static SV *retrieve_utf8str(stcxt_t *cxt, char *cname) { - SV *sv; + SV *sv; - TRACEME(("retrieve_utf8str")); + TRACEME(("retrieve_utf8str")); - sv = retrieve_scalar(cxt, cname); - if (sv) - SvUTF8_on(sv); + sv = retrieve_scalar(cxt, cname); + if (sv) { +#ifdef HAS_UTF8_SCALARS + SvUTF8_on(sv); +#else + if (cxt->use_bytes < 0) + cxt->use_bytes + = (SvTRUE(perl_get_sv("Storable::drop_utf8", TRUE)) + ? 1 : 0); + if (cxt->use_bytes == 0) + UTF8_CROAK(); +#endif + } - return sv; + return sv; } /* @@ -4117,15 +4193,24 @@ static SV *retrieve_utf8str(stcxt_t *cxt, char *cname) */ static SV *retrieve_lutf8str(stcxt_t *cxt, char *cname) { - SV *sv; - - TRACEME(("retrieve_lutf8str")); + SV *sv; - sv = retrieve_lscalar(cxt, cname); - if (sv) - SvUTF8_on(sv); + TRACEME(("retrieve_lutf8str")); - return sv; + sv = retrieve_lscalar(cxt, cname); + if (sv) { +#ifdef HAS_UTF8_SCALARS + SvUTF8_on(sv); +#else + if (cxt->use_bytes < 0) + cxt->use_bytes + = (SvTRUE(perl_get_sv("Storable::drop_utf8", TRUE)) + ? 1 : 0); + if (cxt->use_bytes == 0) + UTF8_CROAK(); +#endif + } + return sv; } /* @@ -4394,7 +4479,7 @@ static SV *retrieve_hash(stcxt_t *cxt, char *cname) */ RLEN(size); /* Get key size */ - KBUFCHK(size); /* Grow hash key read pool if needed */ + KBUFCHK((STRLEN)size); /* Grow hash key read pool if needed */ if (size) READ(kbuf, size); kbuf[size] = '\0'; /* Mark string end, just in case */ @@ -4434,11 +4519,22 @@ static SV *retrieve_flag_hash(stcxt_t *cxt, char *cname) int hash_flags; GETMARK(hash_flags); - TRACEME(("retrieve_flag_hash (#%d)", cxt->tagnum)); + TRACEME(("retrieve_flag_hash (#%d)", cxt->tagnum)); /* * Read length, allocate table. */ +#ifndef HAS_RESTRICTED_HASHES + if (hash_flags & SHV_RESTRICTED) { + if (cxt->derestrict < 0) + cxt->derestrict + = (SvTRUE(perl_get_sv("Storable::downgrade_restricted", TRUE)) + ? 1 : 0); + if (cxt->derestrict == 0) + RESTRICTED_HASH_CROAK(); + } +#endif + RLEN(len); TRACEME(("size = %d, flags = %d", len, hash_flags)); hv = newHV(); @@ -4464,8 +4560,10 @@ static SV *retrieve_flag_hash(stcxt_t *cxt, char *cname) return (SV *) 0; GETMARK(flags); +#ifdef HAS_RESTRICTED_HASHES if ((hash_flags & SHV_RESTRICTED) && (flags & SHV_K_LOCKED)) SvREADONLY_on(sv); +#endif if (flags & SHV_K_ISSV) { /* XXX you can't set a placeholder with an SV key. @@ -4493,13 +4591,25 @@ static SV *retrieve_flag_hash(stcxt_t *cxt, char *cname) sv = &PL_sv_undef; store_flags |= HVhek_PLACEHOLD; } - if (flags & SHV_K_UTF8) + if (flags & SHV_K_UTF8) { +#ifdef HAS_UTF8_HASHES store_flags |= HVhek_UTF8; +#else + if (cxt->use_bytes < 0) + cxt->use_bytes + = (SvTRUE(perl_get_sv("Storable::drop_utf8", TRUE)) + ? 1 : 0); + if (cxt->use_bytes == 0) + UTF8_CROAK(); +#endif + } +#ifdef HAS_UTF8_HASHES if (flags & SHV_K_WASUTF8) store_flags |= HVhek_WASUTF8; +#endif RLEN(size); /* Get key size */ - KBUFCHK(size); /* Grow hash key read pool if needed */ + KBUFCHK((STRLEN)size); /* Grow hash key read pool if needed */ if (size) READ(kbuf, size); kbuf[size] = '\0'; /* Mark string end, just in case */ @@ -4510,12 +4620,20 @@ static SV *retrieve_flag_hash(stcxt_t *cxt, char *cname) * Enter key/value pair into hash table. */ +#ifdef HAS_RESTRICTED_HASHES if (hv_store_flags(hv, kbuf, size, sv, 0, flags) == 0) return (SV *) 0; +#else + if (!(store_flags & HVhek_PLACEHOLD)) + if (hv_store(hv, kbuf, size, sv, 0) == 0) + return (SV *) 0; +#endif } } +#ifdef HAS_RESTRICTED_HASHES if (hash_flags & SHV_RESTRICTED) SvREADONLY_on(hv); +#endif TRACEME(("ok (retrieve_hash at 0x%"UVxf")", PTR2UV(hv))); @@ -4655,7 +4773,7 @@ static SV *old_retrieve_hash(stcxt_t *cxt, char *cname) if (c != SX_KEY) (void) retrieve_other((stcxt_t *) 0, 0); /* Will croak out */ RLEN(size); /* Get key size */ - KBUFCHK(size); /* Grow hash key read pool if needed */ + KBUFCHK((STRLEN)size); /* Grow hash key read pool if needed */ if (size) READ(kbuf, size); kbuf[size] = '\0'; /* Mark string end, just in case */ @@ -4708,7 +4826,7 @@ static SV *magic_check(stcxt_t *cxt) STRLEN len = sizeof(magicstr) - 1; STRLEN old_len; - READ(buf, len); /* Not null-terminated */ + READ(buf, (SSize_t)len); /* Not null-terminated */ buf[len] = '\0'; /* Is now */ if (0 == strcmp(buf, magicstr)) @@ -4720,7 +4838,7 @@ static SV *magic_check(stcxt_t *cxt) */ old_len = sizeof(old_magicstr) - 1; - READ(&buf[len], old_len - len); + READ(&buf[len], (SSize_t)(old_len - len)); buf[old_len] = '\0'; /* Is now null-terminated */ if (strcmp(buf, old_magicstr)) @@ -4765,10 +4883,14 @@ magic_ok: version_major > STORABLE_BIN_MAJOR || (version_major == STORABLE_BIN_MAJOR && version_minor > STORABLE_BIN_MINOR) - ) + ) { + TRACEME(("but I am version is %d.%d", STORABLE_BIN_MAJOR, + STORABLE_BIN_MINOR)); + CROAK(("Storable binary image v%d.%d more recent than I am (v%d.%d)", version_major, version_minor, STORABLE_BIN_MAJOR, STORABLE_BIN_MINOR)); + } /* * If they stored using network order, there's no byte ordering @@ -4783,6 +4905,8 @@ magic_ok: READ(buf, c); /* Not null-terminated */ buf[c] = '\0'; /* Is now */ + TRACEME(("byte order '%s'", buf)); + if (strcmp(buf, byteorder)) CROAK(("Byte order is not compatible")); @@ -4941,7 +5065,7 @@ first_time: /* Will disappear when support for old format is dropped */ default: return (SV *) 0; /* Failed */ } - KBUFCHK(len); /* Grow buffer as necessary */ + KBUFCHK((STRLEN)len); /* Grow buffer as necessary */ if (len) READ(kbuf, len); kbuf[len] = '\0'; /* Mark string end */ diff --git a/ext/Storable/t/croak.t b/ext/Storable/t/croak.t new file mode 100644 index 0000000000..ad07f3ad03 --- /dev/null +++ b/ext/Storable/t/croak.t @@ -0,0 +1,41 @@ +#!./perl -w + +# Please keep this test this simple. (ie just one test.) +# There's some sort of not-croaking properly problem in Storable when built +# with 5.005_03. This test shows it up, whereas malice.t does not. +# In particular, don't use Test; as this covers up the problem. + +sub BEGIN { + if ($ENV{PERL_CORE}){ + chdir('t') if -d 't'; + @INC = '.'; + push @INC, '../lib'; + } + require Config; import Config; + if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) { + print "1..0 # Skip: Storable was not built\n"; + exit 0; + } + # require 'lib/st-dump.pl'; +} + +use strict; + +BEGIN { + die "Oi! No! Don't change this test so that Carp is used before Storable" + if defined &Carp::carp; +} +use Storable qw(freeze thaw); + +print "1..2\n"; + +for my $test (1,2) { + eval {thaw "\xFF\xFF"}; + if ($@ =~ /Storable binary image v127.255 more recent than I am \(v2\.\d+\)/) + { + print "ok $test\n"; + } else { + chomp $@; + print "not ok $test # Expected a meaningful croak. Got '$@'\n"; + } +} diff --git a/ext/Storable/t/downgrade.t b/ext/Storable/t/downgrade.t new file mode 100644 index 0000000000..af5de4a62c --- /dev/null +++ b/ext/Storable/t/downgrade.t @@ -0,0 +1,378 @@ +#!./perl -w + +# +# Copyright 2002, Larry Wall. +# +# You may redistribute only under the same terms as Perl 5, as specified +# in the README file that comes with the distribution. +# + +# I ought to keep this test easily backwards compatible to 5.004, so no +# qr//; + +# This test checks downgrade behaviour on pre-5.8 perls when new 5.8 features +# are encountered. + +sub BEGIN { + if ($ENV{PERL_CORE}){ + chdir('t') if -d 't'; + @INC = '.'; + push @INC, '../lib'; + } + require Config; import Config; + if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) { + print "1..0 # Skip: Storable was not built\n"; + exit 0; + } + # require 'lib/st-dump.pl'; +} + +BEGIN { + if (ord 'A' != 65) { + die <<'EBCDIC'; +This test doesn't have EBCDIC data yet. Please run t/make_downgrade.pl using +perl 5.8 (or later) and append its output to the end of the test. +Please also mail the output to perlbug@perl.org so that the CPAN copy of +Storable can be updated. +EBCDIC + } +} +use Test::More; +use Storable 'thaw'; + +use strict; +use vars qw(@RESTRICT_TESTS %R_HASH %U_HASH $UTF8_CROAK $RESTRICTED_CROAK); + +@RESTRICT_TESTS = ('Locked hash', 'Locked hash placeholder', + 'Locked keys', 'Locked keys placeholder', + ); +%R_HASH = (perl => 'rules'); + +if ($] >= 5.007003) { + my $utf8 = "Schlo\xdf" . chr 256; + chop $utf8; + + %U_HASH = (map {$_, $_} 'castle', "ch\xe5teau", $utf8, chr 0x57CE); + plan tests => 169; +} elsif ($] >= 5.006) { + plan tests => 59; +} else { + plan tests => 67; +} + +$UTF8_CROAK = qr/^Cannot retrieve UTF8 data in non-UTF8 perl/; +$RESTRICTED_CROAK = qr/^Cannot retrieve restricted hash/; + +my %tests; +{ + local $/ = "\n\nend\n"; + while (<DATA>) { + next unless /\S/s; + unless (/begin ([0-7]{3}) ([^\n]*)\n(.*)$/s) { + s/\n.*//s; + warn "Dodgy data in section starting '$_'"; + next; + } + next unless oct $1 == ord 'A'; # Skip ASCII on EBCDIC, and vice versa + my $data = unpack 'u', $3; + $tests{$2} = $data; + } +} + +# use Data::Dumper; $Data::Dumper::Useqq = 1; print Dumper \%tests; +sub thaw_hash { + my ($name, $expected) = @_; + my $hash = eval {thaw $tests{$name}}; + is ($@, '', "Thawed $name without error?"); + isa_ok ($hash, 'HASH'); + ok (defined $hash && eq_hash($hash, $expected), + "And it is the hash we expected?"); + $hash; +} + +sub thaw_scalar { + my ($name, $expected) = @_; + my $scalar = eval {thaw $tests{$name}}; + is ($@, '', "Thawed $name without error?"); + isa_ok ($scalar, 'SCALAR', "Thawed $name?"); + is ($$scalar, $expected, "And it is the data we expected?"); + $scalar; +} + +sub thaw_fail { + my ($name, $expected) = @_; + my $thing = eval {thaw $tests{$name}}; + is ($thing, undef, "Thawed $name failed as expected?"); + like ($@, $expected, "Error as predicted?"); +} + +sub test_locked_hash { + my $hash = shift; + my @keys = keys %$hash; + my ($key, $value) = each %$hash; + eval {$hash->{$key} = reverse $value}; + like( $@, qr/^Modification of a read-only value attempted/, + 'trying to change a locked key' ); + is ($hash->{$key}, $value, "hash should not change?"); + eval {$hash->{use} = 'perl'}; + like( $@, qr/^Attempt to access disallowed key 'use' in a restricted hash/, + 'trying to add another key' ); + ok (eq_array([keys %$hash], \@keys), "Still the same keys?"); +} + +sub test_restricted_hash { + my $hash = shift; + my @keys = keys %$hash; + my ($key, $value) = each %$hash; + eval {$hash->{$key} = reverse $value}; + is( $@, '', + 'trying to change a restricted key' ); + is ($hash->{$key}, reverse ($value), "hash should change"); + eval {$hash->{use} = 'perl'}; + like( $@, qr/^Attempt to access disallowed key 'use' in a restricted hash/, + 'trying to add another key' ); + ok (eq_array([keys %$hash], \@keys), "Still the same keys?"); +} + +sub test_placeholder { + my $hash = shift; + eval {$hash->{rules} = 42}; + is ($@, '', 'No errors'); + is ($hash->{rules}, 42, "New value added"); +} + +sub test_newkey { + my $hash = shift; + eval {$hash->{nms} = "http://nms-cgi.sourceforge.net/"}; + is ($@, '', 'No errors'); + is ($hash->{nms}, "http://nms-cgi.sourceforge.net/", "New value added"); +} + +# $Storable::DEBUGME = 1; +thaw_hash ('Hash with utf8 flag but no utf8 keys', \%R_HASH); + +if (eval "use Hash::Util; 1") { + print "# We have Hash::Util, so test that the restricted hashes in <DATA> are valid\n"; + for $Storable::downgrade_restricted (0, 1, undef, "cheese") { + my $hash = thaw_hash ('Locked hash', \%R_HASH); + test_locked_hash ($hash); + $hash = thaw_hash ('Locked hash placeholder', \%R_HASH); + test_locked_hash ($hash); + test_placeholder ($hash); + + $hash = thaw_hash ('Locked keys', \%R_HASH); + test_restricted_hash ($hash); + $hash = thaw_hash ('Locked keys placeholder', \%R_HASH); + test_restricted_hash ($hash); + test_placeholder ($hash); + } +} else { + print "# We don't have Hash::Util, so test that the restricted hashes downgrade\n"; + my $hash = thaw_hash ('Locked hash', \%R_HASH); + test_newkey ($hash); + $hash = thaw_hash ('Locked hash placeholder', \%R_HASH); + test_newkey ($hash); + $hash = thaw_hash ('Locked keys', \%R_HASH); + test_newkey ($hash); + $hash = thaw_hash ('Locked keys placeholder', \%R_HASH); + test_newkey ($hash); + local $Storable::downgrade_restricted = 0; + thaw_fail ('Locked hash', $RESTRICTED_CROAK); + thaw_fail ('Locked hash placeholder', $RESTRICTED_CROAK); + thaw_fail ('Locked keys', $RESTRICTED_CROAK); + thaw_fail ('Locked keys placeholder', $RESTRICTED_CROAK); +} + +if ($] >= 5.006) { + print "# We have utf8 scalars, so test that the utf8 scalars in <DATA> are valid\n"; + print "# These seem to fail on 5.6 - you should seriously consider upgrading to 5.6.1\n" if $] == 5.006; + thaw_scalar ('Short 8 bit utf8 data', "\xDF"); + thaw_scalar ('Long 8 bit utf8 data', "\xDF" x 256); + thaw_scalar ('Short 24 bit utf8 data', chr 0xC0FFEE); + thaw_scalar ('Long 24 bit utf8 data', chr (0xC0FFEE) x 256); +} else { + print "# We don't have utf8 scalars, so test that the utf8 scalars downgrade\n"; + thaw_fail ('Short 8 bit utf8 data', $UTF8_CROAK); + thaw_fail ('Long 8 bit utf8 data', $UTF8_CROAK); + thaw_fail ('Short 24 bit utf8 data', $UTF8_CROAK); + thaw_fail ('Long 24 bit utf8 data', $UTF8_CROAK); + local $Storable::drop_utf8 = 1; + my $bytes = thaw $tests{'Short 8 bit utf8 data as bytes'}; + thaw_scalar ('Short 8 bit utf8 data', $$bytes); + thaw_scalar ('Long 8 bit utf8 data', $$bytes x 256); + $bytes = thaw $tests{'Short 24 bit utf8 data as bytes'}; + thaw_scalar ('Short 24 bit utf8 data', $$bytes); + thaw_scalar ('Long 24 bit utf8 data', $$bytes x 256); +} + +if ($] >= 5.007003) { + print "# We have utf8 hashes, so test that the utf8 hashes in <DATA> are valid\n"; + my $hash = thaw_hash ('Hash with utf8 keys', \%U_HASH); + for (keys %$hash) { + my $l = 0 + /^\w+$/; + my $r = 0 + $hash->{$_} =~ /^\w+$/; + cmp_ok ($l, '==', $r, sprintf "key length %d", length $_); + cmp_ok ($l, '==', $_ eq "ch\xe5teau" ? 0 : 1); + } + if (eval "use Hash::Util; 1") { + print "# We have Hash::Util, so test that the restricted utf8 hash is valid\n"; + my $hash = thaw_hash ('Locked hash with utf8 keys', \%U_HASH); + for (keys %$hash) { + my $l = 0 + /^\w+$/; + my $r = 0 + $hash->{$_} =~ /^\w+$/; + cmp_ok ($l, '==', $r, sprintf "key length %d", length $_); + cmp_ok ($l, '==', $_ eq "ch\xe5teau" ? 0 : 1); + } + test_locked_hash ($hash); + } else { + print "# We don't have Hash::Util, so test that the utf8 hash downgrades\n"; + fail ("You can't get here [perl version $]]. This is a bug in the test. +# Please send the output of perl -V to perlbug\@perl.org"); + } +} else { + print "# We don't have utf8 hashes, so test that the utf8 hashes downgrade\n"; + thaw_fail ('Hash with utf8 keys', $UTF8_CROAK); + thaw_fail ('Locked hash with utf8 keys', $UTF8_CROAK); + local $Storable::drop_utf8 = 1; + my $what = $] < 5.006 ? 'pre 5.6' : '5.6'; + my $expect = thaw $tests{"Hash with utf8 keys for $what"}; + thaw_hash ('Hash with utf8 keys', $expect); + #foreach (keys %$expect) { print "'$_':\t'$expect->{$_}'\n"; } + #foreach (keys %$got) { print "'$_':\t'$got->{$_}'\n"; } + if (eval "use Hash::Util; 1") { + print "# We have Hash::Util, so test that the restricted hashes in <DATA> are valid\n"; + fail ("You can't get here [perl version $]]. This is a bug in the test. +# Please send the output of perl -V to perlbug\@perl.org"); + } else { + print "# We don't have Hash::Util, so test that the restricted hashes downgrade\n"; + my $hash = thaw_hash ('Locked hash with utf8 keys', $expect); + test_newkey ($hash); + local $Storable::downgrade_restricted = 0; + thaw_fail ('Locked hash with utf8 keys', $RESTRICTED_CROAK); + # Which croak comes first is a bit of an implementation issue :-) + local $Storable::drop_utf8 = 0; + thaw_fail ('Locked hash with utf8 keys', $RESTRICTED_CROAK); + } +} +__END__ +# A whole run of 2.x nfreeze data, uuencoded. The "mode bits" are the octal +# value of 'A', the "file name" is the test name. Use make_downgrade.pl to +# generate these. +begin 101 Locked hash +8!049`0````$*!7)U;&5S!`````1P97)L + +end + +begin 101 Locked hash placeholder +C!049`0````(*!7)U;&5S!`````1P97)L#A0````%<G5L97,` + +end + +begin 101 Locked keys +8!049`0````$*!7)U;&5S``````1P97)L + +end + +begin 101 Locked keys placeholder +C!049`0````(*!7)U;&5S``````1P97)L#A0````%<G5L97,` + +end + +begin 101 Short 8 bit utf8 data +&!047`L.? + +end + +begin 101 Short 8 bit utf8 data as bytes +&!04*`L.? + +end + +begin 101 Long 8 bit utf8 data +M!048```"`,.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.? +MPY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_# +MG\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.? +MPY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_# +MG\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.? +MPY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_# +MG\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.? +MPY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_# +MG\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.? +MPY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_# +MG\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.? +8PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.? + +end + +begin 101 Short 24 bit utf8 data +)!047!?BPC[^N + +end + +begin 101 Short 24 bit utf8 data as bytes +)!04*!?BPC[^N + +end + +begin 101 Long 24 bit utf8 data +M!048```%`/BPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/ +MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/ +MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/ +MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/ +MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/ +MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/ +MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/ +MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/ +MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/ +MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/ +MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/ +MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/ +MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/ +MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/ +MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/ +MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/ +MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/ +MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/ +MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/ +MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/ +MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/ +MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/ +MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/ +MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/ +MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/ +MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/ +MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/ +MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/ +;OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N + +end + +begin 101 Hash with utf8 flag but no utf8 keys +8!049``````$*!7)U;&5S``````1P97)L + +end + +begin 101 Hash with utf8 keys +M!049``````0*!F-A<W1L90`````&8V%S=&QE"@=C:.5T96%U``````=C:.5T +D96%U%P/EGXX!`````^6?CA<'4V-H;&_#GP(````&4V-H;&_? + +end + +begin 101 Locked hash with utf8 keys +M!049`0````0*!F-A<W1L900````&8V%S=&QE"@=C:.5T96%U!`````=C:.5T +D96%U%P/EGXX%`````^6?CA<'4V-H;&_#GP8````&4V-H;&_? + +end + +begin 101 Hash with utf8 keys for pre 5.6 +M!049``````0*!F-A<W1L90`````&8V%S=&QE"@=C:.5T96%U``````=C:.5T +D96%U"@/EGXX``````^6?C@H'4V-H;&_#GP(````&4V-H;&_? + +end + +begin 101 Hash with utf8 keys for 5.6 +M!049``````0*!F-A<W1L90`````&8V%S=&QE"@=C:.5T96%U``````=C:.5T +D96%U%P/EGXX``````^6?CA<'4V-H;&_#GP(````&4V-H;&_? + +end + diff --git a/ext/Storable/t/make_downgrade.pl b/ext/Storable/t/make_downgrade.pl new file mode 100644 index 0000000000..d806ebbaa1 --- /dev/null +++ b/ext/Storable/t/make_downgrade.pl @@ -0,0 +1,103 @@ +#!/usr/local/bin/perl -w +use strict; + +use 5.007003; +use Hash::Util qw(lock_hash unlock_hash lock_keys); +use Storable qw(nfreeze); + +# If this looks like a hack, it's probably because it is :-) +sub uuencode_it { + my ($data, $name) = @_; + my $frozen = nfreeze $data; + + my $uu = pack 'u', $frozen; + + printf "begin %3o $name\n", ord 'A'; + print $uu; + print "\nend\n\n"; +} + + +my %hash = (perl=>"rules"); + +lock_hash %hash; + +uuencode_it (\%hash, "Locked hash"); + +unlock_hash %hash; + +lock_keys %hash, 'perl', 'rules'; +lock_hash %hash; + +uuencode_it (\%hash, "Locked hash placeholder"); + +unlock_hash %hash; + +lock_keys %hash, 'perl'; + +uuencode_it (\%hash, "Locked keys"); + +unlock_hash %hash; + +lock_keys %hash, 'perl', 'rules'; + +uuencode_it (\%hash, "Locked keys placeholder"); + +unlock_hash %hash; + +my $utf8 = "\x{DF}\x{100}"; +chop $utf8; + +uuencode_it (\$utf8, "Short 8 bit utf8 data"); + +utf8::encode ($utf8); + +uuencode_it (\$utf8, "Short 8 bit utf8 data as bytes"); + +$utf8 x= 256; + +uuencode_it (\$utf8, "Long 8 bit utf8 data"); + +$utf8 = "\x{C0FFEE}"; + +uuencode_it (\$utf8, "Short 24 bit utf8 data"); + +utf8::encode ($utf8); + +uuencode_it (\$utf8, "Short 24 bit utf8 data as bytes"); + +$utf8 x= 256; + +uuencode_it (\$utf8, "Long 24 bit utf8 data"); + +# Hash which has the utf8 bit set, but no longer has any utf8 keys +my %uhash = ("\x{100}", "gone", "perl", "rules"); +delete $uhash{"\x{100}"}; + +# use Devel::Peek; Dump \%uhash; +uuencode_it (\%uhash, "Hash with utf8 flag but no utf8 keys"); + +$utf8 = "Schlo\xdf" . chr 256; +chop $utf8; +%uhash = (map {$_, $_} 'castle', "ch\xe5teau", $utf8, "\x{57CE}"); + +uuencode_it (\%uhash, "Hash with utf8 keys"); + +lock_hash %uhash; + +uuencode_it (\%uhash, "Locked hash with utf8 keys"); + +my (%pre56, %pre58); + +while (my ($key, $val) = each %uhash) { + # hash keys are always stored downgraded to bytes if possible, with a flag + # to say "promote back to utf8" + # Whereas scalars are stored as is. + utf8::encode ($key) if ord $key > 256; + $pre58{$key} = $val; + utf8::encode ($val) unless $val eq "ch\xe5teau"; + $pre56{$key} = $val; + +} +uuencode_it (\%pre56, "Hash with utf8 keys for pre 5.6"); +uuencode_it (\%pre58, "Hash with utf8 keys for 5.6"); diff --git a/ext/Storable/t/malice.t b/ext/Storable/t/malice.t index 54c0ea4c1c..9f1d8ff201 100644 --- a/ext/Storable/t/malice.t +++ b/ext/Storable/t/malice.t @@ -30,14 +30,14 @@ sub BEGIN { } use strict; -use vars qw($file_magic_str $other_magic $network_magic $major $minor); - -# header size depends on the size of the byteorder string +use vars qw($file_magic_str $other_magic $network_magic $major $minor + $minor_write); $file_magic_str = 'pst0'; $other_magic = 7 + length($Config{byteorder}); $network_magic = 2; $major = 2; $minor = 5; +$minor_write = $] > 5.007 ? 5 : 4; use Test; BEGIN { plan tests => 334 + length($Config{byteorder}) * 4} @@ -63,7 +63,7 @@ sub test_header { my ($header, $isfile, $isnetorder) = @_; ok (!!$header->{file}, !!$isfile, "is file"); ok ($header->{major}, $major, "major number"); - ok ($header->{minor}, $minor, "minor number"); + ok ($header->{minor}, $minor_write, "minor number"); ok (!!$header->{netorder}, !!$isnetorder, "is network order"); if ($isnetorder) { # Skip these @@ -148,24 +148,34 @@ sub test_things { } $copy = $contents; - my $minor1 = $header->{minor} + 1; - substr ($copy, $file_magic + 1, 1) = chr $minor1; + # Needs to be more than 1, as we're already coding a spread of 1 minor version + # number on writes (2.5, 2.4). May increase to 2 if we figure we can do 2.3 + # on 5.005_03 (No utf8). + # 4 allows for a small safety margin + # (Joke: + # Question: What is the value of pi? + # Mathematician answers "It's pi, isn't it" + # Physicist answers "3.1, within experimental error" + # Engineer answers "Well, allowing for a small safety margin, 18" + # ) + my $minor4 = $header->{minor} + 4; + substr ($copy, $file_magic + 1, 1) = chr $minor4; test_corrupt ($copy, $sub, - "/^Storable binary image v$header->{major}\.$minor1 more recent than I am \\(v$header->{major}\.$header->{minor}\\)/", + "/^Storable binary image v$header->{major}\.$minor4 more recent than I am \\(v$header->{major}\.$minor\\)/", "higher minor"); $copy = $contents; my $major1 = $header->{major} + 1; substr ($copy, $file_magic, 1) = chr 2*$major1; test_corrupt ($copy, $sub, - "/^Storable binary image v$major1\.$header->{minor} more recent than I am \\(v$header->{major}\.$header->{minor}\\)/", + "/^Storable binary image v$major1\.$header->{minor} more recent than I am \\(v$header->{major}\.$minor\\)/", "higher major"); # Continue messing with the previous copy - $minor1 = $header->{minor} - 1; + my $minor1 = $header->{minor} - 1; substr ($copy, $file_magic + 1, 1) = chr $minor1; test_corrupt ($copy, $sub, - "/^Storable binary image v$major1\.$minor1 more recent than I am \\(v$header->{major}\.$header->{minor}\\)/", + "/^Storable binary image v$major1\.$minor1 more recent than I am \\(v$header->{major}\.$minor\\)/", "higher major, lower minor"); my $where; diff --git a/ext/Storable/t/restrict.t b/ext/Storable/t/restrict.t index 0eb299ff52..841baab3c8 100644 --- a/ext/Storable/t/restrict.t +++ b/ext/Storable/t/restrict.t @@ -1,4 +1,4 @@ -#!./perl +#!./perl -w # # Copyright 2002, Larry Wall. @@ -8,13 +8,24 @@ # sub BEGIN { - chdir('t') if -d 't'; - @INC = '.'; - push @INC, '../lib'; - require Config; import Config; - if ($Config{'extensions'} !~ /\bStorable\b/) { - print "1..0 # Skip: Storable was not built\n"; - exit 0; + if ($ENV{PERL_CORE}){ + chdir('t') if -d 't'; + @INC = '.'; + push @INC, '../lib'; + require Config; + if ($Config::Config{'extensions'} !~ /\bStorable\b/) { + print "1..0 # Skip: Storable was not built\n"; + exit 0; + } + } else { + unless (eval "require Hash::Util") { + if ($@ =~ /Can\'t locate Hash\/Util\.pm in \@INC/) { + print "1..0 # Skip: No Hash::Util\n"; + exit 0; + } else { + die; + } + } } require 'lib/st-dump.pl'; } @@ -67,7 +78,7 @@ sub testit { unless (ok ++$test, !$@, "Can assign to reserved key 'extra'?") { my $diag = $@; $diag =~ s/\n.*\z//s; - print "# \$@: $diag\n"; + print "# \$\@: $diag\n"; } eval { $copy->{nono} = 7 } ; diff --git a/ext/Storable/t/utf8hash.t b/ext/Storable/t/utf8hash.t index 5e93914799..25d5307399 100644 --- a/ext/Storable/t/utf8hash.t +++ b/ext/Storable/t/utf8hash.t @@ -38,6 +38,8 @@ use bytes (); use Encode qw(is_utf8); my %utf8hash; +$Storable::canonical = $Storable::canonical; # Shut up a used only once warning. + for $Storable::canonical (0, 1) { # first we generate a nasty hash which keys include both utf8 diff --git a/ext/Time/HiRes/HiRes.xs b/ext/Time/HiRes/HiRes.xs index 529223160e..9d3586dee8 100644 --- a/ext/Time/HiRes/HiRes.xs +++ b/ext/Time/HiRes/HiRes.xs @@ -618,7 +618,7 @@ sleep(...) if (items > 0) { NV seconds = SvNV(ST(0)); if (seconds >= 0.0) { - UV useconds = 1E6 * (seconds - (UV)seconds); + UV useconds = (UV)(1E6 * (seconds - (UV)seconds)); if (seconds >= 1.0) sleep((UV)seconds); usleep(useconds); diff --git a/ext/Unicode/Normalize/Normalize.xs b/ext/Unicode/Normalize/Normalize.xs index 3cb221fd75..93cb471a5d 100644 --- a/ext/Unicode/Normalize/Normalize.xs +++ b/ext/Unicode/Normalize/Normalize.xs @@ -553,10 +553,10 @@ getComposite(uv, uv2) UV uv2 PROTOTYPE: $$ PREINIT: - UV comp; + UV composite; CODE: - comp = composite_uv(uv, uv2); - RETVAL = comp ? newSVuv(comp) : &PL_sv_undef; + composite = composite_uv(uv, uv2); + RETVAL = composite ? newSVuv(composite) : &PL_sv_undef; OUTPUT: RETVAL diff --git a/installperl b/installperl index 3379369ccd..dcc92a5ecb 100755 --- a/installperl +++ b/installperl @@ -258,7 +258,7 @@ if (($Is_W32 and ! $Is_NetWare) or $Is_Cygwin) { chmod(0755, "$installbin/ld2"); }; } else { - $perldll = 'perl57.' . $dlext; + $perldll = 'perl58.' . $dlext; } if ($dlsrc ne "dl_none.xs") { diff --git a/lib/ExtUtils/MM_NW5.pm b/lib/ExtUtils/MM_NW5.pm index b9932e2a15..86c3192deb 100644 --- a/lib/ExtUtils/MM_NW5.pm +++ b/lib/ExtUtils/MM_NW5.pm @@ -31,13 +31,14 @@ use ExtUtils::MakeMaker qw( &neatvalue ); $ENV{EMXSHELL} = 'sh'; # to run `commands` -$BORLAND = 1 if $Config{'cc'} =~ /^bcc/i; -$GCC = 1 if $Config{'cc'} =~ /^gcc/i; -$DMAKE = 1 if $Config{'make'} =~ /^dmake/i; -$NMAKE = 1 if $Config{'make'} =~ /^nmake/i; +$BORLAND = 1 if $Config{'cc'} =~ /^bcc/i; +$GCC = 1 if $Config{'cc'} =~ /^gcc/i; +$DMAKE = 1 if $Config{'make'} =~ /^dmake/i; +$NMAKE = 1 if $Config{'make'} =~ /^nmake/i; $PERLMAKE = 1 if $Config{'make'} =~ /^pmake/i; + sub init_others { my ($self) = @_; @@ -70,10 +71,10 @@ sub const_cccmd { my($self,$libperl)=@_; return $self->{CONST_CCCMD} if $self->{CONST_CCCMD}; return '' unless $self->needs_linking(); - return $self->{CONST_CCCMD} = + return $self->{CONST_CCCMD} = q{CCCMD = $(CC) $(CCFLAGS) $(INC) $(OPTIMIZE) \\ $(PERLTYPE) $(MPOLLUTE) -o $@ \\ - -DVERSION="$(VERSION)" -DXS_VERSION="$(XS_VERSION)"}; + -DVERSION=\"$(VERSION)\" -DXS_VERSION=\"$(XS_VERSION)\"}; } sub constants { @@ -93,26 +94,27 @@ sub constants { PERL_ARCHLIB SITELIBEXP SITEARCHEXP LIBPERL_A MYEXTLIB FIRST_MAKEFILE MAKE_APERL_FILE PERLMAINCC PERL_SRC PERL_INC PERL FULLPERL LIBPTH BASE_IMPORT PERLRUN - FULLPERLRUN PERLRUNINST FULLPERLRUNINST - FULL_AR PERL_CORE NLM_VERSION MPKTOOL TOOLPATH - + FULLPERLRUN PERLRUNINST FULL_AR PERL_CORE FULLPERLRUNINST + NLM_VERSION MPKTOOL TOOLPATH + / ) { next unless defined $self->{$tmp}; push @m, "$tmp = $self->{$tmp}\n"; } - (my $boot = $self->{'NAME'}) =~ s/:/_/g; - $self->{'BOOT_SYMBOL'}=$boot; - push @m, "BOOT_SYMBOL = $self->{'BOOT_SYMBOL'}\n"; - - # If the final binary name is greater than 8 chars, - # truncate it here and rename it after creation - # otherwise, Watcom Linker fails - if(length($self->{'BASEEXT'}) > 8) { - $self->{'NLM_SHORT_NAME'} = substr($self->{'BASEEXT'},0,8); - push @m, "NLM_SHORT_NAME = $self->{'NLM_SHORT_NAME'}\n"; - } - + (my $boot = $self->{'NAME'}) =~ s/:/_/g; + $self->{'BOOT_SYMBOL'}=$boot; + push @m, "BOOT_SYMBOL = $self->{'BOOT_SYMBOL'}\n"; + + # If the final binary name is greater than 8 chars, + # truncate it here and rename it after creation + # otherwise, Watcom Linker fails + + if(length($self->{'BASEEXT'}) > 8) { + $self->{'NLM_SHORT_NAME'} = substr($self->{'BASEEXT'},0,8); + push @m, "NLM_SHORT_NAME = $self->{'NLM_SHORT_NAME'}\n"; + } + push @m, qq{ VERSION_MACRO = VERSION DEFINE_VERSION = -D\$(VERSION_MACRO)=\\\"\$(VERSION)\\\" @@ -120,17 +122,16 @@ XS_VERSION_MACRO = XS_VERSION XS_DEFINE_VERSION = -D\$(XS_VERSION_MACRO)=\\\"\$(XS_VERSION)\\\" }; - # Get the include path and replace the spaces with ; - # Copy this to makefile as INCLUDE = d:\...;d:\; - (my $inc = $Config{'incpath'}) =~ s/([ ]*)-I/;/g; + # Get the include path and replace the spaces with ; + # Copy this to makefile as INCLUDE = d:\...;d:\; + (my $inc = $Config{'incpath'}) =~ s/([ ]*)-I/;/g; - push @m, qq{ +push @m, qq{ INCLUDE = $inc; }; - - # Set the path to CodeWarrior binaries which might not have been set in - # any other place - push @m, qq{ + # Set the path to CodeWarrior binaries which might not have been set in + # any other place + push @m, qq{ PATH = \$(PATH);\$(TOOLPATH) }; @@ -247,6 +248,118 @@ PM_TO_BLIB = }.join(" \\\n\t", %{$self->{PM}}).q{ join('',@m); } +sub static_lib { + my($self, %attribs) = @_; + return '' unless $self->needs_linking(); #might be because of a subdir + + return '' unless $self->has_link_code; + + my($otherldflags) = $attribs{OTHERLDFLAGS} || ($BORLAND ? 'c0d32.obj': ''); + my($inst_dynamic_dep) = $attribs{INST_DYNAMIC_DEP} || ""; + my($ldfrom) = '$(LDFROM)'; + my(@m); + (my $boot = $self->{NAME}) =~ s/:/_/g; + my ($mpk); + push(@m,' +# This section creates the dynamically loadable $(INST_DYNAMIC) +# from $(OBJECT) and possibly $(MYEXTLIB). +OTHERLDFLAGS = '.$otherldflags.' +INST_DYNAMIC_DEP = '.$inst_dynamic_dep.' + +$(INST_STATIC): $(OBJECT) $(MYEXTLIB) $(BOOTSTRAP) +'); +# push(@m, +# q{ $(LD) -out:$@ $(LDDLFLAGS) }.$ldfrom.q{ $(OTHERLDFLAGS) } +# .q{$(MYEXTLIB) $(PERL_ARCHIVE) $(LDLOADLIBS) -def:$(EXPORT_LIST)}); + + # Create xdc data for an MT safe NLM in case of mpk build +# if ( scalar(keys %XS) == 0 ) { return; } + + push(@m, + q{ @echo $(BASE_IMPORT) >> $(BASEEXT).def +}); + push(@m, + q{ @echo Import @$(PERL_INC)\perl.imp >> $(BASEEXT).def +}); + + if ( $self->{CCFLAGS} =~ m/ -DMPK_ON /) { + $mpk=1; + push @m, ' $(MPKTOOL) $(XDCFLAGS) $(BASEEXT).xdc +'; + push @m, ' @echo xdcdata $(BASEEXT).xdc >> $(BASEEXT).def +'; + } else { + $mpk=0; + } + + push(@m, + q{ $(LD) $(LDFLAGS) $(OBJECT:.obj=.obj) } + ); + + push(@m, + q{ -desc "Perl 5.7.3 Extension ($(BASEEXT)) XS_VERSION: $(XS_VERSION)" -nlmversion $(NLM_VERSION) } + ); + + # Taking care of long names like FileHandle, ByteLoader, SDBM_File etc + if($self->{NLM_SHORT_NAME}) { + # In case of nlms with names exceeding 8 chars, build nlm in the + # current dir, rename and move to auto\lib. If we create in auto\lib + # in the first place, we can't rename afterwards. + push(@m, + q{ -o $(NLM_SHORT_NAME).$(DLEXT)} + ); + } else { + push(@m, + q{ -o $(INST_AUTODIR)\\$(BASEEXT).$(DLEXT)} + ); + } + + +# if ($mpk) { +# push (@m, +# q{ Option XDCDATA=$(BASEEXT).xdc } +# ); +# } + + # Add additional lib files if any (SDBM_File) + if($self->{MYEXTLIB}) { + push(@m, + q{ $(MYEXTLIB) } + ); + } + +#For now lets comment all the Watcom lib calls +#q{ LibPath $(LIBPTH) Library plib3s.lib Library math3s.lib Library clib3s.lib Library emu387.lib Library $(PERL_ARCHIVE) Library $(PERL_INC)\Main.lib} + + + push(@m, + q{ $(PERL_INC)\Main.lib} + .q{ -commandfile $(BASEEXT).def } + ); + + # If it is having a short name, rename it + if($self->{NLM_SHORT_NAME}) { + push @m, ' + if exist $(INST_AUTODIR)\\$(BASEEXT).$(DLEXT) del $(INST_AUTODIR)\\$(BASEEXT).$(DLEXT)'; + push @m, ' + rename $(NLM_SHORT_NAME).$(DLEXT) $(BASEEXT).$(DLEXT)'; + push @m, ' + move $(BASEEXT).$(DLEXT) $(INST_AUTODIR)'; + } + + push @m, ' + $(CHMOD) 755 $@ +'; + + push @m, $self->dir_target('$(INST_ARCHAUTODIR)'); +# } else { +# push @m, ' +# @$(NOOP) +#'; +# } + join('',@m); +} + =item dynamic_lib (o) @@ -255,7 +368,7 @@ Defines how to produce the *.so (or equivalent) files. =cut sub dynamic_lib { - my($self, %attribs) = @_; + my($self, %attribs) = @_; return '' unless $self->needs_linking(); #might be because of a subdir return '' unless $self->has_link_code; @@ -264,8 +377,8 @@ sub dynamic_lib { my($inst_dynamic_dep) = $attribs{INST_DYNAMIC_DEP} || ""; my($ldfrom) = '$(LDFROM)'; my(@m); - (my $boot = $self->{NAME}) =~ s/:/_/g; - + (my $boot = $self->{NAME}) =~ s/:/_/g; + my ($mpk); push(@m,' # This section creates the dynamically loadable $(INST_DYNAMIC) # from $(OBJECT) and possibly $(MYEXTLIB). @@ -274,77 +387,86 @@ INST_DYNAMIC_DEP = '.$inst_dynamic_dep.' $(INST_DYNAMIC): $(OBJECT) $(MYEXTLIB) $(BOOTSTRAP) '); - - my ($mpk); - # Create xdc data for an MT safe NLM in case of mpk build - push(@m, - q{@echo Export boot_$(BOOT_SYMBOL) > $(BASEEXT).def - }); - push(@m, - q{@echo $(BASE_IMPORT) >> $(BASEEXT).def - }); - push(@m, - q{@echo Import @$(PERL_INC)\perl.imp >> $(BASEEXT).def - }); - - - if ( $self->{CCFLAGS} =~ m/ -DMPK_ON /) { - $mpk=1; - push @m, qq{\t\$(MPKTOOL) \$(XDCFLAGS) \$(BASEEXT).xdc\n}, - qq{\t\@echo xdcdata $(BASEEXT).xdc >> $(BASEEXT).def\n}; - } else { - $mpk=0; - } - - push(@m, - q{$(LD) $(LDFLAGS) $(OBJECT:.obj=.obj) } - ); - - push(@m, - qq{\t-desc "Perl 5.7.3 Extension (\$(BASEEXT)) XS_VERSION: \$(XS_VERSION)" -nlmversion \$(NLM_VERSION) } - ); - - # Taking care of long names like FileHandle, ByteLoader, SDBM_File etc - if($self->{NLM_SHORT_NAME}) { - # In case of nlms with names exceeding 8 chars, build nlm in the - # current dir, rename and move to auto\lib. If we create in auto\lib - # in the first place, we can't rename afterwards. - push(@m, - q{ -o $(NLM_SHORT_NAME).$(DLEXT)} - ); - } else { - push(@m, - q{ -o $(INST_AUTODIR)\\$(BASEEXT).$(DLEXT)} - ); - } - - # Add additional lib files if any (SDBM_File) - if($self->{MYEXTLIB}) { - push(@m, - q{ $(MYEXTLIB) } - ); - } - - push(@m, - q{ $(PERL_INC)\Main.lib}. - q{ -commandfile $(BASEEXT).def } - ); - - # If it is having a short name, rename it - if($self->{NLM_SHORT_NAME}) { - push @m, ' +# push(@m, +# q{ $(LD) -out:$@ $(LDDLFLAGS) }.$ldfrom.q{ $(OTHERLDFLAGS) } +# .q{$(MYEXTLIB) $(PERL_ARCHIVE) $(LDLOADLIBS) -def:$(EXPORT_LIST)}); + + # Create xdc data for an MT safe NLM in case of mpk build +# if ( scalar(keys %XS) == 0 ) { return; } + push(@m, + q{ @echo Export boot_$(BOOT_SYMBOL) > $(BASEEXT).def +}); + push(@m, + q{ @echo $(BASE_IMPORT) >> $(BASEEXT).def +}); + push(@m, + q{ @echo Import @$(PERL_INC)\perl.imp >> $(BASEEXT).def +}); + + if ( $self->{CCFLAGS} =~ m/ -DMPK_ON /) { + $mpk=1; + push @m, ' $(MPKTOOL) $(XDCFLAGS) $(BASEEXT).xdc +'; + push @m, ' @echo xdcdata $(BASEEXT).xdc >> $(BASEEXT).def +'; + } else { + $mpk=0; + } + + push(@m, + q{ $(LD) $(LDFLAGS) $(OBJECT:.obj=.obj) } + ); + + push(@m, + q{ -desc "Perl 5.7.3 Extension ($(BASEEXT)) XS_VERSION: $(XS_VERSION)" -nlmversion $(NLM_VERSION) } + ); + + # Taking care of long names like FileHandle, ByteLoader, SDBM_File etc + if($self->{NLM_SHORT_NAME}) { + # In case of nlms with names exceeding 8 chars, build nlm in the + # current dir, rename and move to auto\lib. If we create in auto\lib + # in the first place, we can't rename afterwards. + push(@m, + q{ -o $(NLM_SHORT_NAME).$(DLEXT)} + ); + } else { + push(@m, + q{ -o $(INST_AUTODIR)\\$(BASEEXT).$(DLEXT)} + ); + } + + # Add additional lib files if any (SDBM_File) + if($self->{MYEXTLIB}) { + push(@m, + q{ $(MYEXTLIB) } + ); + } + +#For now lets comment all the Watcom lib calls +#q{ LibPath $(LIBPTH) Library plib3s.lib Library math3s.lib Library clib3s.lib Library emu387.lib Library $(PERL_ARCHIVE) Library $(PERL_INC)\Main.lib} + + + push(@m, + q{ $(PERL_INC)\Main.lib} + .q{ -commandfile $(BASEEXT).def } + ); + + # If it is having a short name, rename it + if($self->{NLM_SHORT_NAME}) { + push @m, ' if exist $(INST_AUTODIR)\\$(BASEEXT).$(DLEXT) del $(INST_AUTODIR)\\$(BASEEXT).$(DLEXT)'; - push @m, ' + push @m, ' rename $(NLM_SHORT_NAME).$(DLEXT) $(BASEEXT).$(DLEXT)'; - push @m, ' + push @m, ' move $(BASEEXT).$(DLEXT) $(INST_AUTODIR)'; - } + } push @m, ' $(CHMOD) 755 $@ '; push @m, $self->dir_target('$(INST_ARCHAUTODIR)'); + join('',@m); } @@ -356,4 +478,3 @@ __END__ =cut - diff --git a/lib/ExtUtils/MM_Unix.pm b/lib/ExtUtils/MM_Unix.pm index 836d3475e9..9a8c4dc73f 100644 --- a/lib/ExtUtils/MM_Unix.pm +++ b/lib/ExtUtils/MM_Unix.pm @@ -12,7 +12,7 @@ use File::Spec; use DirHandle; use strict; use vars qw($VERSION @ISA - $Is_Mac $Is_OS2 $Is_VMS $Is_Win32 $Is_Dos $Is_VOS + $Is_Mac $Is_OS2 $Is_VMS $Is_Win32 $Is_Dos $Is_VOS $Is_NetWare $Verbose %pm %static $Xsubpp_Version %Config_Override ); @@ -26,7 +26,7 @@ require ExtUtils::MM_Any; $Is_OS2 = $^O eq 'os2'; $Is_Mac = $^O eq 'MacOS'; -$Is_Win32 = $^O eq 'MSWin32' || $Config{osname} eq 'NetWare'; +$Is_Win32 = $^O eq 'MSWin32' || $Config{'osname'} eq 'NetWare'; $Is_Dos = $^O eq 'dos'; $Is_VOS = $^O eq 'vos'; $Is_VMS = $^O eq 'VMS'; diff --git a/lib/ExtUtils/MM_VMS.pm b/lib/ExtUtils/MM_VMS.pm index 787fda697d..d3c9ede1a6 100644 --- a/lib/ExtUtils/MM_VMS.pm +++ b/lib/ExtUtils/MM_VMS.pm @@ -745,29 +745,28 @@ sub pm_to_blib { pm_to_blib : pm_to_blib.ts $(NOECHO) $(NOOP) -}; - - push @m, <<'MAKE_FRAG', # As always, keep under DCL's 255-char limit pm_to_blib.ts : $(TO_INST_PM) - $(NOECHO) $(RM_F) .MM_tmp -MAKE_FRAG +}; - $line = ''; # avoid uninitialized var warning - while ($from = shift(@files),$to = shift(@files)) { + if (scalar(@files) > 0) { # protect ourselves from empty PM_TO_BLIB + + push(@m,qq[\t\$(NOECHO) \$(RM_F) .MM_tmp\n]); + $line = ''; # avoid uninitialized var warning + while ($from = shift(@files),$to = shift(@files)) { $line .= " $from $to"; if (length($line) > 128) { push(@m,"\t\$(NOECHO) \$(PERL) -e \"print '$line'\" >>.MM_tmp\n"); $line = ''; } - } - push(@m,"\t\$(NOECHO) \$(PERL) -e \"print '$line'\" >>.MM_tmp\n") if $line; + } + push(@m,"\t\$(NOECHO) \$(PERL) -e \"print '$line'\" >>.MM_tmp\n") if $line; - push(@m,q[ $(PERLRUN) "-MExtUtils::Install" -e "pm_to_blib({split(' ',<STDIN>)},'].$autodir.q[','$(PM_FILTER)')" <.MM_tmp]); - push(@m,qq[ - \$(NOECHO) Delete/NoLog/NoConfirm .MM_tmp; - \$(NOECHO) \$(TOUCH) pm_to_blib.ts -]); + push(@m,q[ $(PERLRUN) "-MExtUtils::Install" -e "pm_to_blib({split(' ',<STDIN>)},'].$autodir.q[','$(PM_FILTER)')" <.MM_tmp]); + push(@m,qq[\n\t\$(NOECHO) \$(RM_F) .MM_tmp\n]); + + } + push(@m,qq[\t\$(NOECHO) \$(TOUCH) pm_to_blib.ts]); join('',@m); } diff --git a/lib/File/Copy.pm b/lib/File/Copy.pm index 31fad2ac5d..08da5e5d31 100644 --- a/lib/File/Copy.pm +++ b/lib/File/Copy.pm @@ -33,6 +33,13 @@ require Exporter; $Too_Big = 1024 * 1024 * 2; +my $macfiles; +if ($^O eq 'MacOS') { + $macfiles = eval { require Mac::MoreFiles }; + warn 'Mac::MoreFiles could not be loaded; using non-native syscopy' + if $^W; +} + sub _catname { my($from, $to) = @_; if (not defined &basename) { @@ -230,8 +237,7 @@ unless (defined &syscopy) { return 0 unless @_ == 2; return Win32::CopyFile(@_, 1); }; - } elsif ($^O eq 'MacOS') { - require Mac::MoreFiles; + } elsif ($macfiles) { *syscopy = sub { my($from, $to) = @_; my($dir, $toname); @@ -338,6 +344,9 @@ VMS systems, this calls the C<rmscopy> routine (see below). For OS/2 systems, this calls the C<syscopy> XSUB directly. For Win32 systems, this calls C<Win32::CopyFile>. +On Mac OS (Classic), C<syscopy> calls C<Mac::MoreFiles::FSpFileCopy>, +if available. + =head2 Special behaviour if C<syscopy> is defined (OS/2, VMS and Win32) If both arguments to C<copy> are not file handles, diff --git a/lib/File/Spec/Mac.pm b/lib/File/Spec/Mac.pm index c3ae7aff6b..000da91b1a 100644 --- a/lib/File/Spec/Mac.pm +++ b/lib/File/Spec/Mac.pm @@ -9,6 +9,10 @@ $VERSION = '1.3'; @ISA = qw(File::Spec::Unix); use Cwd; +my $macfiles; +if ($^O eq 'MacOS') { + $macfiles = eval { require Mac::Files }; +} =head1 NAME @@ -339,6 +343,8 @@ concept, although other volumes aren't rooted there. The name has a trailing ":", because that's the correct specification for a volume name on Mac OS. +If Mac::Files could not be loaded, the empty string is returned. + =cut sub rootdir { @@ -346,9 +352,9 @@ sub rootdir { # There's no real root directory on Mac OS. The name of the startup # volume is returned, since that's the closest in concept. # - require Mac::Files; - my $system = Mac::Files::FindFolder(&Mac::Files::kOnSystemDisk, - &Mac::Files::kSystemFolderType); + return '' unless $macfiles; + my $system = Mac::Files::FindFolder(&Mac::Files::kOnSystemDisk, + &Mac::Files::kSystemFolderType); $system =~ s/:.*\Z(?!\n)/:/s; return $system; } diff --git a/lib/Test/Builder.pm b/lib/Test/Builder.pm index da63506b0b..7c710bf00f 100644 --- a/lib/Test/Builder.pm +++ b/lib/Test/Builder.pm @@ -8,7 +8,7 @@ $^C ||= 0; use strict; use vars qw($VERSION $CLASS); -$VERSION = '0.12'; +$VERSION = '0.14'; $CLASS = __PACKAGE__; my $IsVMS = $^O eq 'VMS'; @@ -55,9 +55,6 @@ Test::Builder - Backend for building test libraries =head1 DESCRIPTION -I<THIS IS ALPHA GRADE SOFTWARE> Meaning the underlying code is well -tested, yet the interface is subject to change. - Test::Simple and Test::More have proven to be popular testing modules, but they're not always flexible enough. Test::Builder provides the a building block upon which to write your own test libraries I<which can @@ -152,6 +149,12 @@ sub plan { die "You said to run 0 tests! You've got to run something.\n"; } } + else { + require Carp; + my @args = grep { defined } ($cmd, $arg); + Carp::croak("plan() doesn't understand @args"); + } + } =item B<expected_tests> @@ -239,7 +242,8 @@ sub ok { my($self, $test, $name) = @_; unless( $Have_Plan ) { - die "You tried to run a test without a plan! Gotta have a plan.\n"; + require Carp; + Carp::croak("You tried to run a test without a plan! Gotta have a plan."); } $Curr_Test++; @@ -354,7 +358,7 @@ sub _is_diag { } } - $self->diag(sprintf <<DIAGNOSTIC, $got, $expect); + return $self->diag(sprintf <<DIAGNOSTIC, $got, $expect); got: %s expected: %s DIAGNOSTIC @@ -443,25 +447,57 @@ sub unlike { $self->_regex_ok($this, $regex, '!~', $name); } -sub _regex_ok { - my($self, $this, $regex, $cmp, $name) = @_; +=item B<maybe_regex> - local $Level = $Level + 1; + $Test->maybe_regex(qr/$regex/); + $Test->maybe_regex('/$regex/'); - my $ok = 0; - my $usable_regex; +Convenience method for building testing functions that take regular +expressions as arguments, but need to work before perl 5.005. + +Takes a quoted regular expression produced by qr//, or a string +representing a regular expression. + +Returns a Perl value which may be used instead of the corresponding +regular expression, or undef if it's argument is not recognised. + +For example, a version of like(), sans the useful diagnostic messages, +could be written as: + + sub laconic_like { + my ($self, $this, $regex, $name) = @_; + my $usable_regex = $self->maybe_regex($regex); + die "expecting regex, found '$regex'\n" + unless $usable_regex; + $self->ok($this =~ m/$usable_regex/, $name); + } + +=cut + + +sub maybe_regex { + my ($self, $regex) = @_; + my $usable_regex = undef; if( ref $regex eq 'Regexp' ) { $usable_regex = $regex; } # Check if it looks like '/foo/' elsif( my($re, $opts) = $regex =~ m{^ /(.*)/ (\w*) $ }sx ) { - $usable_regex = "(?$opts)$re"; - } - else { - $ok = $self->ok( 0, $name ); + $usable_regex = length $opts ? "(?$opts)$re" : $re; + }; + return($usable_regex) +}; - $self->diag(" '$regex' doesn't look much like a regex to me."); +sub _regex_ok { + my($self, $this, $regex, $cmp, $name) = @_; + local $Level = $Level + 1; + + my $ok = 0; + my $usable_regex = $self->maybe_regex($regex); + unless (defined $usable_regex) { + $ok = $self->ok( 0, $name ); + $self->diag(" '$regex' doesn't look much like a regex to me."); return $ok; } @@ -524,7 +560,7 @@ sub _cmp_diag { $got = defined $got ? "'$got'" : 'undef'; $expect = defined $expect ? "'$expect'" : 'undef'; - $self->diag(sprintf <<DIAGNOSTIC, $got, $type, $expect); + return $self->diag(sprintf <<DIAGNOSTIC, $got, $type, $expect); %s %s %s @@ -564,7 +600,8 @@ sub skip { $why ||= ''; unless( $Have_Plan ) { - die "You tried to run tests without a plan! Gotta have a plan.\n"; + require Carp; + Carp::croak("You tried to run tests without a plan! Gotta have a plan."); } $Curr_Test++; @@ -598,7 +635,8 @@ sub todo_skip { $why ||= ''; unless( $Have_Plan ) { - die "You tried to run tests without a plan! Gotta have a plan.\n"; + require Carp; + Carp::croak("You tried to run tests without a plan! Gotta have a plan."); } $Curr_Test++; @@ -607,7 +645,7 @@ sub todo_skip { my $out = "not ok"; $out .= " $Curr_Test" if $self->use_numbers; - $out .= " # TODO $why\n"; + $out .= " # TODO & SKIP $why\n"; $Test->_print($out); @@ -765,6 +803,14 @@ already. We encourage using this rather than calling print directly. +Returns false. Why? Because diag() is often used in conjunction with +a failing test (C<ok() || diag()>) it "passes through" the failure. + + return ok(...) || diag(...); + +=for blame transfer +Mark Fowler <mark@twoshortplanks.com> + =cut sub diag { @@ -776,6 +822,7 @@ sub diag { # Escape each line with a #. foreach (@msgs) { + $_ = 'undef' unless defined; s/^/# /gms; } @@ -785,6 +832,8 @@ sub diag { my $fh = $self->todo ? $self->todo_output : $self->failure_output; local($\, $", $,) = (undef, ' ', ''); print $fh @msgs; + + return 0; } =begin _private @@ -808,6 +857,15 @@ sub _print { local($\, $", $,) = (undef, ' ', ''); my $fh = $self->output; + + # Escape each line after the first with a # so we don't + # confuse Test::Harness. + foreach (@msgs) { + s/\n(.)/\n# $1/sg; + } + + push @msgs, "\n" unless $msgs[-1] =~ /\n\Z/; + print $fh @msgs; } @@ -933,9 +991,16 @@ sub current_test { my($self, $num) = @_; if( defined $num ) { + + unless( $Have_Plan ) { + require Carp; + Carp::croak("Can't change the current test number without a plan!"); + } + $Curr_Test = $num; if( $num > @Test_Results ) { - for ($#Test_Results..$num-1) { + my $start = @Test_Results ? $#Test_Results : 0; + for ($start..$num-1) { $Test_Results[$_] = 1; } } diff --git a/lib/Test/Harness.pm b/lib/Test/Harness.pm index 23e7ed89a4..788042ada3 100644 --- a/lib/Test/Harness.pm +++ b/lib/Test/Harness.pm @@ -1,5 +1,5 @@ # -*- Mode: cperl; cperl-indent-level: 4 -*- -# $Id: Harness.pm,v 1.14.2.13 2002/01/07 22:34:32 schwern Exp $ +# $Id: Harness.pm,v 1.14.2.18 2002/04/25 05:04:35 schwern Exp $ package Test::Harness; @@ -22,7 +22,7 @@ use vars qw($VERSION $Verbose $Switches $Have_Devel_Corestack $Curtest $Have_Devel_Corestack = 0; -$VERSION = '2.01'; +$VERSION = '2.03'; $ENV{HARNESS_ACTIVE} = 1; @@ -36,16 +36,13 @@ my $Ignore_Exitcode = $ENV{HARNESS_IGNORE_EXITCODE}; my $Files_In_Dir = $ENV{HARNESS_FILELEAK_IN_DIR}; -my $Running_In_Perl_Tree = 0; -++$Running_In_Perl_Tree if -d "../t" and -f "../sv.c"; - my $Strap = Test::Harness::Straps->new; @ISA = ('Exporter'); @EXPORT = qw(&runtests); @EXPORT_OK = qw($verbose $switches); -$Verbose = 0; +$Verbose = $ENV{HARNESS_VERBOSE} || 0; $Switches = "-w"; $Columns = $ENV{HARNESS_COLUMNS} || $ENV{COLUMNS} || 80; $Columns--; # Some shells have trouble with a full line of text. @@ -90,15 +87,16 @@ test program. =item B<'1..M'> -This header tells how many tests there will be. It should be the -first line output by your test program (but it is okay if it is preceded -by comments). +This header tells how many tests there will be. For example, C<1..10> +means you plan on running 10 tests. This is a safeguard in case your +test dies quietly in the middle of its run. + +It should be the first non-comment line output by your test program. -In certain instanced, you may not know how many tests you will -ultimately be running. In this case, it is permitted (but not -encouraged) for the 1..M header to appear as the B<last> line output -by your test (again, it can be followed by further comments). But we -strongly encourage you to put it first. +In certain instances, you may not know how many tests you will +ultimately be running. In this case, it is permitted for the 1..M +header to appear as the B<last> line output by your test (again, it +can be followed by further comments). Under B<no> circumstances should 1..M appear in the middle of your output or more than once. @@ -152,7 +150,7 @@ variations in spacing and case) after C<ok> or C<ok NUMBER>, it is counted as a skipped test. If the whole testscript succeeds, the count of skipped tests is included in the generated output. C<Test::Harness> reports the text after C< # Skip\S*\s+> as a reason -for skipping. +for skipping. ok 23 # skip Insufficient flogiston pressure. @@ -457,6 +455,8 @@ sub _run_all_tests { my $fh = _open_test($tfile); + $tot{files}++; + # state of the current test. my %test = ( ok => 0, @@ -602,11 +602,7 @@ sub _mk_leader { chomp($te); $te =~ s/\.\w+$/./; - if ($^O eq 'VMS') { - $te =~ s/^.*\.t\./\[.t./s; - } - $te =~ s,\\,/,g if $^O eq 'MSWin32'; - $te =~ s,^\.\./,/, if $Running_In_Perl_Tree; + if ($^O eq 'VMS') { $te =~ s/^.*\.t\./\[.t./s; } my $blank = (' ' x 77); my $leader = "$te" . '.' x ($width - length($te)); my $ml = ""; @@ -632,15 +628,12 @@ sub _leader_width { foreach (@_) { my $suf = /\.(\w+)$/ ? $1 : ''; my $len = length; - $len -= 2 if $Running_In_Perl_Tree and m{^\.\.[/\\]}; my $suflen = length $suf; $maxlen = $len if $len > $maxlen; $maxsuflen = $suflen if $suflen > $maxsuflen; } - # we want three dots between the test name and the "ok" for - # typical lengths, and just two dots if longer than 30 characters - $maxlen -= $maxsuflen; - return $maxlen + ($maxlen >= 30 ? 2 : 3); + # + 3 : we want three dots between the test name and the "ok" + return $maxlen + 3 - $maxsuflen; } @@ -703,7 +696,6 @@ sub _parse_header { $tot->{max} += $test->{max}; - $tot->{files}++; } else { $is_header = 0; @@ -718,11 +710,13 @@ sub _open_test { my $s = _set_switches($test); + my $perl = -x $^X ? $^X : $Config{perlpath}; + # XXX This is WAY too core specific! my $cmd = ($ENV{'HARNESS_COMPILE_TEST'}) ? "./perl -I../lib ../utils/perlcc $test " . "-r 2>> ./compilelog |" - : "$^X $s $test|"; + : "$perl $s $test|"; $cmd = "MCR $cmd" if $^O eq 'VMS'; if( open(PERL, $cmd) ) { @@ -756,17 +750,14 @@ sub _parse_test_line { } $test->{todo}{$this} = 1 if $istodo; + if( $test->{todo}{$this} ) { + $tot->{todo}++; + $test->{bonus}++, $tot->{bonus}++ unless $not; + } - $tot->{todo}++ if $test->{todo}{$this}; - - if( $not ) { + if( $not && !$test->{todo}{$this} ) { print "$test->{ml}NOK $this" if $test->{ml}; - if (!$test->{todo}{$this}) { - push @{$test->{failed}}, $this; - } else { - $test->{ok}++; - $tot->{ok}++; - } + push @{$test->{failed}}, $this; } else { print "$test->{ml}ok $this/$test->{max}" if $test->{ml}; @@ -783,13 +774,18 @@ sub _parse_test_line { } elsif (defined $reason) { $test->{skip_reason} = $reason; } - - $test->{bonus}++, $tot->{bonus}++ if $test->{todo}{$this}; } if ($this > $test->{'next'}) { print "Test output counter mismatch [test $this]\n"; - push @{$test->{failed}}, $test->{'next'}..$this-1; + + # Guard against resource starvation. + if( $this > 100000 ) { + print "Enourmous test number seen [test $this]\n"; + } + else { + push @{$test->{failed}}, $test->{'next'}..$this-1; + } } elsif ($this < $test->{'next'}) { #we have seen more "ok" lines than the number suggests @@ -971,13 +967,17 @@ sub _create_fmts { sub corestatus { my($st) = @_; - eval {require 'wait.ph'}; - my $ret = defined &WCOREDUMP ? WCOREDUMP($st) : $st & 0200; + eval { + local $^W = 0; # *.ph files are often *very* noisy + require 'wait.ph' + }; + return if $@; + my $did_core = defined &WCOREDUMP ? WCOREDUMP($st) : $st & 0200; eval { require Devel::CoreStack; $Have_Devel_Corestack++ } unless $tried_devel_corestack++; - $ret; + return $did_core; } } @@ -1079,17 +1079,18 @@ the script dies with this message. =over 4 -=item C<HARNESS_IGNORE_EXITCODE> +=item C<HARNESS_ACTIVE> -Makes harness ignore the exit status of child processes when defined. +Harness sets this before executing the individual tests. This allows +the tests to determine if they are being executed through the harness +or by any other means. -=item C<HARNESS_NOTTY> +=item C<HARNESS_COLUMNS> -When set to a true value, forces it to behave as though STDOUT were -not a console. You may need to set this if you don't want harness to -output more frequent progress messages using carriage returns. Some -consoles may not handle carriage returns properly (which results in a -somewhat messy output). +This value will be used for the width of the terminal. If it is not +set then it will default to C<COLUMNS>. If this is not set, it will +default to 80. Note that users of Bourne-sh based shells will need to +C<export COLUMNS> for this module to use that variable. =item C<HARNESS_COMPILE_TEST> @@ -1110,24 +1111,28 @@ If relative, directory name is with respect to the current directory at the moment runtests() was called. Putting absolute path into C<HARNESS_FILELEAK_IN_DIR> may give more predictable results. +=item C<HARNESS_IGNORE_EXITCODE> + +Makes harness ignore the exit status of child processes when defined. + +=item C<HARNESS_NOTTY> + +When set to a true value, forces it to behave as though STDOUT were +not a console. You may need to set this if you don't want harness to +output more frequent progress messages using carriage returns. Some +consoles may not handle carriage returns properly (which results in a +somewhat messy output). + =item C<HARNESS_PERL_SWITCHES> Its value will be prepended to the switches used to invoke perl on each test. For example, setting C<HARNESS_PERL_SWITCHES> to C<-W> will run all tests with all warnings enabled. -=item C<HARNESS_COLUMNS> +=item C<HARNESS_VERBOSE> -This value will be used for the width of the terminal. If it is not -set then it will default to C<COLUMNS>. If this is not set, it will -default to 80. Note that users of Bourne-sh based shells will need to -C<export COLUMNS> for this module to use that variable. - -=item C<HARNESS_ACTIVE> - -Harness sets this before executing the individual tests. This allows -the tests to determine if they are being executed through the harness -or by any other means. +If true, Test::Harness will output the verbose results of running +its tests. Setting $Test::Harness::verbose will override this. =back @@ -1167,7 +1172,7 @@ Current maintainer is Michael G Schwern E<lt>schwern@pobox.comE<gt> Provide a way of running tests quietly (ie. no printing) for automated validation of tests. This will probably take the form of a version of runtests() which rather than printing its output returns raw data -on the state of the tests. +on the state of the tests. (Partially done in Test::Harness::Straps) Fix HARNESS_COMPILE_TEST without breaking its core usage. @@ -1175,8 +1180,6 @@ Figure a way to report test names in the failure summary. Rework the test summary so long test names are not truncated as badly. -Merge back into bleadperl. - Deal with VMS's "not \nok 4\n" mistake. Add option for coverage analysis. @@ -1189,13 +1192,7 @@ Clean up how the summary is printed. Get rid of those damned formats. =head1 BUGS -Test::Harness uses $^X to determine the perl binary to run the tests -with. Test scripts running via the shebang (C<#!>) line may not be -portable because $^X is not consistent for shebang scripts across -platforms. This is no problem when Test::Harness is run with an -absolute path to the perl binary or when $^X can be found in the path. - -HARNESS_COMPILE_TEST currently assumes it is run from the Perl source +HARNESS_COMPILE_TEST currently assumes it's run from the Perl source directory. =cut diff --git a/lib/Test/Harness/Changes b/lib/Test/Harness/Changes index fcd8bb2468..7ba77b1df0 100644 --- a/lib/Test/Harness/Changes +++ b/lib/Test/Harness/Changes @@ -1,5 +1,24 @@ Revision history for Perl extension Test::Harness +2.03 Thu Apr 25 01:01:34 EDT 2002 + * $^X fix made safer. + - Noise from loading wait.ph to analyze core files supressed + - MJD found a situation where a test could run Test::Harness + out of memory. Protecting against that specific case. + - Made the 1..M docs a bit clearer. + - Fixed TODO tests so Test::Harness does not display a NOK for + them. + - Test::Harness::Straps->analyze_file() docs were not clear as to + its effects + +2.02 Thu Mar 14 18:06:04 EST 2002 + * Ken Williams fixed the long standing $^X bug. + * Added HARNESS_VERBOSE + * Fixed a bug where Test::Harness::Straps was considering a test that + is ok but died as passing. + - Added the exit and wait codes of the test to the + analyze_file() results. + 2.01 Thu Dec 27 18:54:36 EST 2001 * Added 'passing' to the results to tell you if the test passed * Added Test::Harness::Straps example (examples/mini_harness.plx) diff --git a/lib/Test/Harness/Straps.pm b/lib/Test/Harness/Straps.pm index 27f46bf37e..481637b036 100644 --- a/lib/Test/Harness/Straps.pm +++ b/lib/Test/Harness/Straps.pm @@ -1,12 +1,12 @@ # -*- Mode: cperl; cperl-indent-level: 4 -*- -# $Id: Straps.pm,v 1.1.2.17 2002/01/07 22:34:33 schwern Exp $ +# $Id: Straps.pm,v 1.1.2.20 2002/04/25 05:04:35 schwern Exp $ package Test::Harness::Straps; use strict; use vars qw($VERSION); use Config; -$VERSION = '0.08'; +$VERSION = '0.09'; use Test::Harness::Assert; use Test::Harness::Iterator; @@ -147,13 +147,14 @@ sub _analyze_iterator { last if $self->{saw_bailout}; } + $totals{skip_all} = $self->{skip_all} if defined $self->{skip_all}; + my $passed = $totals{skip_all} || - ($totals{max} == $totals{seen} && + ($totals{max} && $totals{seen} && + $totals{max} == $totals{seen} && $totals{max} == $totals{ok}); $totals{passing} = $passed ? 1 : 0; - $totals{skip_all} = $self->{skip_all} if defined $self->{skip_all}; - $self->{totals}{$name} = \%totals; return %totals; } @@ -205,8 +206,14 @@ sub _analyze_line { $totals->{ok}++ if $pass; - $totals->{details}[$result{number} - 1] = + if( $result{number} > 100000 ) { + warn "Enourmous test number seen [test $result{number}]\n"; + warn "Can't detailize, too big.\n"; + } + else { + $totals->{details}[$result{number} - 1] = {$self->_detailize($pass, \%result)}; + } # XXX handle counter mismatch } @@ -242,8 +249,8 @@ sub analyze_fh { my %results = $strap->analyze_file($test_file); -Like C<analyze>, but it reads from the given $test_file. It will also -use that name for the total report. +Like C<analyze>, but it runs the given $test_file and parses it's +results. It will also use that name for the total report. =cut @@ -264,7 +271,10 @@ sub analyze_file { } my %results = $self->analyze_fh($file, \*FILE); - close FILE; + my $exit = close FILE; + $results{'wait'} = $?; + $results{'exit'} = $? / 256; + $results{passing} = 0 unless $? == 0; $self->_restore_PERL5LIB(); @@ -558,6 +568,9 @@ The %results returned from analyze() contain the following information: passing true if the whole test is considered a pass (or skipped), false if its a failure + exit the exit code of the test run, if from a file + wait the wait code of the test run, if from a file + max total tests which should have been run seen total tests actually seen skip_all if the whole test was skipped, this will diff --git a/lib/Test/Harness/t/strap-analyze.t b/lib/Test/Harness/t/strap-analyze.t index 06addd6a23..3a5c64f728 100644 --- a/lib/Test/Harness/t/strap-analyze.t +++ b/lib/Test/Harness/t/strap-analyze.t @@ -14,7 +14,7 @@ my $SAMPLE_TESTS = $ENV{PERL_CORE} ? 'lib/sample-tests' : 't/sample-tests'; use strict; -use Test::More tests => 27; +use Test::More tests => 35; use_ok('Test::Harness::Straps'); @@ -24,6 +24,9 @@ my %samples = ( combined => { passing => 0, + 'exit' => 0, + 'wait' => 0, + max => 10, seen => 10, @@ -59,6 +62,9 @@ my %samples = ( descriptive => { passing => 1, + 'wait' => 0, + 'exit' => 0, + max => 5, seen => 5, @@ -88,6 +94,9 @@ my %samples = ( duplicates => { passing => 0, + 'exit' => 0, + 'wait' => 0, + max => 10, seen => 11, @@ -103,6 +112,9 @@ my %samples = ( head_end => { passing => 1, + 'exit' => 0, + 'wait' => 0, + max => 4, seen => 4, @@ -118,6 +130,9 @@ my %samples = ( lone_not_bug => { passing => 1, + 'exit' => 0, + 'wait' => 0, + max => 4, seen => 4, @@ -133,6 +148,9 @@ my %samples = ( head_fail => { passing => 0, + 'exit' => 0, + 'wait' => 0, + max => 4, seen => 4, @@ -150,6 +168,9 @@ my %samples = ( simple => { passing => 1, + 'exit' => 0, + 'wait' => 0, + max => 5, seen => 5, @@ -165,6 +186,9 @@ my %samples = ( simple_fail => { passing => 0, + 'exit' => 0, + 'wait' => 0, + max => 5, seen => 5, @@ -184,6 +208,9 @@ my %samples = ( 'skip' => { passing => 1, + 'exit' => 0, + 'wait' => 0, + max => 5, seen => 5, @@ -204,6 +231,9 @@ my %samples = ( skip_all => { passing => 1, + 'exit' => 0, + 'wait' => 0, + max => 0, seen => 0, skip_all => 'rope', @@ -219,6 +249,9 @@ my %samples = ( 'todo' => { passing => 1, + 'exit' => 0, + 'wait' => 0, + max => 5, seen => 5, @@ -238,6 +271,9 @@ my %samples = ( taint => { passing => 1, + 'exit' => 0, + 'wait' => 0, + max => 1, seen => 1, @@ -254,6 +290,9 @@ my %samples = ( vms_nit => { passing => 0, + 'exit' => 0, + 'wait' => 0, + max => 2, seen => 2, @@ -265,17 +304,92 @@ my %samples = ( details => [ { 'ok' => 0, actual_ok => 0 }, { 'ok' => 1, actual_ok => 1 }, ], - }, + }, + 'die' => { + passing => 0, + + 'exit' => 1, + 'wait' => 256, + + max => 0, + seen => 0, + + 'ok' => 0, + 'todo' => 0, + 'skip' => 0, + bonus => 0, + + details => [] + }, + + die_head_end => { + passing => 0, + + 'exit' => 1, + 'wait' => 256, + + max => 0, + seen => 4, + + 'ok' => 4, + 'todo' => 0, + 'skip' => 0, + bonus => 0, + + details => [ ({ 'ok' => 1, actual_ok => 1 }) x 4 + ], + }, + + die_last_minute => { + passing => 0, + + 'exit' => 1, + 'wait' => 256, + + max => 4, + seen => 4, + + 'ok' => 4, + 'todo' => 0, + 'skip' => 0, + bonus => 0, + + details => [ ({ 'ok' => 1, actual_ok => 1 }) x 4 + ], + }, + + bignum => { + passing => 0, + + 'exit' => 0, + 'wait' => 0, + + max => 2, + seen => 4, + + 'ok' => 4, + 'todo' => 0, + 'skip' => 0, + bonus => 0, + + details => [ { 'ok' => 1, actual_ok => 1 }, + { 'ok' => 1, actual_ok => 1 }, + ] + }, ); +$SIG{__WARN__} = sub { + warn @_ unless $_[0] =~ /^Enourmous test number/ || + $_[0] =~ /^Can't detailize/ +}; while( my($test, $expect) = each %samples ) { my $strap = Test::Harness::Straps->new; my %results = $strap->analyze_file("$SAMPLE_TESTS/$test"); - is_deeply($expect->{details}, $results{details}, "$test details" ); + is_deeply($results{details}, $expect->{details}, "$test details" ); delete $expect->{details}; delete $results{details}; - is_deeply($expect, \%results, " the rest" ); + is_deeply(\%results, $expect, " the rest" ); } diff --git a/lib/Test/Harness/t/test-harness.t b/lib/Test/Harness/t/test-harness.t index be15009010..f50861907a 100644 --- a/lib/Test/Harness/t/test-harness.t +++ b/lib/Test/Harness/t/test-harness.t @@ -1,9 +1,12 @@ -#!/usr/bin/perl +#!/usr/bin/perl -w BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; - @INC = '../lib'; + @INC = ('../lib', 'lib'); + } + else { + unshift @INC, 't/lib'; } } @@ -30,41 +33,14 @@ sub GETC {} package main; -# Utility testing functions. -my $test_num = 1; -sub ok ($;$) { - my($test, $name) = @_; - my $okstring = ''; - $okstring = "not " unless $test; - $okstring .= "ok $test_num"; - $okstring .= " - $name" if defined $name; - print "$okstring\n"; - $test_num++; -} - -sub eqhash { - my($a1, $a2) = @_; - return 0 unless keys %$a1 == keys %$a2; - - my $ok = 1; - foreach my $k (keys %$a1) { - $ok = $a1->{$k} eq $a2->{$k}; - last unless $ok; - } - - return $ok; -} +use Test::More; use vars qw($Total_tests %samples); -my $loaded; -BEGIN { $| = 1; $^W = 1; } -END {print "not ok $test_num\n" unless $loaded;} -print "1..$Total_tests\n"; +plan tests => $Total_tests; use Test::Harness; -$loaded = 1; -ok(1, 'compile'); -######################### End of black magic. +use_ok('Test::Harness'); + BEGIN { %samples = ( @@ -78,7 +54,7 @@ BEGIN { good => 1, tests => 1, sub_skipped=> 0, - todo => 0, + 'todo' => 0, skipped => 0, }, failed => { }, @@ -94,7 +70,7 @@ BEGIN { good => 0, tests => 1, sub_skipped => 0, - todo => 0, + 'todo' => 0, skipped => 0, }, failed => { @@ -112,7 +88,7 @@ BEGIN { good => 1, tests => 1, sub_skipped=> 0, - todo => 0, + 'todo' => 0, skipped => 0, }, failed => { }, @@ -128,7 +104,7 @@ BEGIN { good => 0, tests => 1, sub_skipped=> 0, - todo => 0, + 'todo' => 0, skipped => 0, }, failed => { @@ -136,7 +112,7 @@ BEGIN { }, all_ok => 0, }, - todo => { + 'todo' => { total => { bonus => 1, max => 5, @@ -146,7 +122,7 @@ BEGIN { good => 1, tests => 1, sub_skipped=> 0, - todo => 2, + 'todo' => 2, skipped => 0, }, failed => { }, @@ -162,13 +138,13 @@ BEGIN { good => 1, tests => 1, sub_skipped => 0, - todo => 2, + 'todo' => 2, skipped => 0, }, failed => { }, all_ok => 1, }, - skip => { + 'skip' => { total => { bonus => 0, max => 5, @@ -178,7 +154,7 @@ BEGIN { good => 1, tests => 1, sub_skipped=> 1, - todo => 0, + 'todo' => 0, skipped => 0, }, failed => { }, @@ -195,7 +171,7 @@ BEGIN { good => 0, tests => 1, sub_skipped=> 1, - todo => 2, + 'todo' => 2, skipped => 0 }, failed => { @@ -213,7 +189,7 @@ BEGIN { good => 0, tests => 1, sub_skipped=> 0, - todo => 0, + 'todo' => 0, skipped => 0, }, failed => { @@ -231,7 +207,7 @@ BEGIN { good => 1, tests => 1, sub_skipped=> 0, - todo => 0, + 'todo' => 0, skipped => 0, }, failed => { }, @@ -247,7 +223,7 @@ BEGIN { good => 0, tests => 1, sub_skipped=> 0, - todo => 0, + 'todo' => 0, skipped => 0, }, failed => { @@ -265,7 +241,7 @@ BEGIN { good => 1, tests => 1, sub_skipped=> 0, - todo => 0, + 'todo' => 0, skipped => 1, }, failed => { }, @@ -281,7 +257,7 @@ BEGIN { good => 1, tests => 1, sub_skipped=> 0, - todo => 4, + 'todo' => 4, skipped => 0, }, failed => { }, @@ -297,15 +273,102 @@ BEGIN { good => 1, tests => 1, sub_skipped=> 0, - todo => 0, + 'todo' => 0, skipped => 0, }, failed => { }, all_ok => 1, }, + + 'die' => { + total => { + bonus => 0, + max => 0, + 'ok' => 0, + files => 1, + bad => 1, + good => 0, + tests => 1, + sub_skipped=> 0, + 'todo' => 0, + skipped => 0, + }, + failed => { + estat => 1, + wstat => 256, + max => '??', + failed => '??', + canon => '??', + }, + all_ok => 0, + }, + + die_head_end => { + total => { + bonus => 0, + max => 0, + 'ok' => 4, + files => 1, + bad => 1, + good => 0, + tests => 1, + sub_skipped=> 0, + 'todo' => 0, + skipped => 0, + }, + failed => { + estat => 1, + wstat => 256, + max => '??', + failed => '??', + canon => '??', + }, + all_ok => 0, + }, + + die_last_minute => { + total => { + bonus => 0, + max => 4, + 'ok' => 4, + files => 1, + bad => 1, + good => 0, + tests => 1, + sub_skipped=> 0, + 'todo' => 0, + skipped => 0, + }, + failed => { + estat => 1, + wstat => 256, + max => 4, + failed => 0, + canon => '??', + }, + all_ok => 0, + }, + bignum => { + total => { + bonus => 0, + max => 2, + 'ok' => 4, + files => 1, + bad => 1, + good => 0, + tests => 1, + sub_skipped=> 0, + 'todo' => 0, + skipped => 0, + }, + failed => { + canon => '??', + }, + all_ok => 0, + }, ); - $Total_tests = (keys(%samples) * 4); + $Total_tests = (keys(%samples) * 4) + 1; } tie *NULL, 'My::Dev::Null' or die $!; @@ -321,21 +384,21 @@ while (my($test, $expect) = each %samples) { select STDOUT; unless( $@ ) { - ok( Test::Harness::_all_ok($totals) == $expect->{all_ok}, + is( Test::Harness::_all_ok($totals), $expect->{all_ok}, "$test - all ok" ); ok( defined $expect->{total}, "$test - has total" ); - ok( eqhash( $expect->{total}, - {map { $_=>$totals->{$_} } keys %{$expect->{total}}} ), + is_deeply( {map { $_=>$totals->{$_} } keys %{$expect->{total}}}, + $expect->{total}, "$test - totals" ); - ok( eqhash( $expect->{failed}, - {map { $_=>$failed->{"$SAMPLE_TESTS/$test"}{$_} } - keys %{$expect->{failed}}} ), + is_deeply( {map { $_=>$failed->{"$SAMPLE_TESTS/$test"}{$_} } + keys %{$expect->{failed}}}, + $expect->{failed}, "$test - failed" ); } else { # special case for bailout - ok( ($test eq 'bailout' and $@ =~ /Further testing stopped: GERONI/i), - $test ); - ok( 1, 'skipping for bailout' ); - ok( 1, 'skipping for bailout' ); + is( $test, 'bailout' ); + like( $@, '/Further testing stopped: GERONI/i', $test ); + pass( 'skipping for bailout' ); + pass( 'skipping for bailout' ); } } diff --git a/lib/Test/More.pm b/lib/Test/More.pm index c33518774c..b97f967ff7 100644 --- a/lib/Test/More.pm +++ b/lib/Test/More.pm @@ -18,7 +18,7 @@ sub _carp { require Exporter; use vars qw($VERSION @ISA @EXPORT %EXPORT_TAGS $TODO); -$VERSION = '0.42'; +$VERSION = '0.44'; @ISA = qw(Exporter); @EXPORT = qw(ok use_ok require_ok is isnt like unlike is_deeply @@ -176,16 +176,18 @@ sub plan { my $caller = caller; $Test->exported_to($caller); - $Test->plan(@plan); my @imports = (); foreach my $idx (0..$#plan) { if( $plan[$idx] eq 'import' ) { - @imports = @{$plan[$idx+1]}; + my($tag, $imports) = splice @plan, $idx, 2; + @imports = @$imports; last; } } + $Test->plan(@plan); + __PACKAGE__->_export_to_level(1, __PACKAGE__, @imports); } @@ -455,7 +457,7 @@ as one test. If you desire otherwise, use: sub can_ok ($@) { my($proto, @methods) = @_; - my $class= ref $proto || $proto; + my $class = ref $proto || $proto; unless( @methods ) { my $ok = $Test->ok( 0, "$class->can(...)" ); @@ -465,10 +467,9 @@ sub can_ok ($@) { my @nok = (); foreach my $method (@methods) { - my $test = "'$class'->can('$method')"; local($!, $@); # don't interfere with caller's $@ # eval sometimes resets $! - eval $test || push @nok, $method; + eval { $proto->can($method) } || push @nok, $method; } my $name; @@ -645,7 +646,7 @@ C<use_ok> and C<require_ok>. BEGIN { use_ok($module, @imports); } These simply use the given $module and test to make sure the load -happened ok. It is recommended that you run use_ok() inside a BEGIN +happened ok. It's recommended that you run use_ok() inside a BEGIN block so its functions are exported at compile-time and prototypes are properly honored. @@ -670,7 +671,7 @@ sub use_ok ($;@) { eval <<USE; package $pack; require $module; -$module->import(\@imports); +'$module'->import(\@imports); USE my $ok = $Test->ok( !$@, "use $module;" ); @@ -764,12 +765,12 @@ easiest way to illustrate: If pigs cannot fly, the whole block of tests will be skipped completely. Test::More will output special ok's which Test::Harness -interprets as skipped tests. It is important to include $how_many tests +interprets as skipped tests. It's important to include $how_many tests are in the block so the total number of tests comes out right (unless you're using C<no_plan>, in which case you can leave $how_many off if you like). -It is perfectly safe to nest SKIP blocks. +It's perfectly safe to nest SKIP blocks. Tests are skipped when you B<never> expect them to B<ever> pass. Like an optional module is not installed or the operating system doesn't @@ -849,7 +850,7 @@ When the block is empty, delete it. ...normal testing code... } -With todo tests, it is best to have the tests actually run. That way +With todo tests, it's best to have the tests actually run. That way you'll know when they start passing. Sometimes this isn't possible. Often a failing test will cause the whole program to die or hang, even inside an C<eval BLOCK> with and using C<alarm>. In these extreme @@ -1181,7 +1182,7 @@ magic side-effects are kept to a minimum. WYSIWYG. =head1 SEE ALSO L<Test::Simple> if all this confuses you and you just want to write -some tests. You can upgrade to Test::More later (it is forward +some tests. You can upgrade to Test::More later (it's forward compatible). L<Test::Differences> for more ways to test complex data structures. diff --git a/lib/Test/Simple.pm b/lib/Test/Simple.pm index 1f50036e15..ee59bd30c0 100644 --- a/lib/Test/Simple.pm +++ b/lib/Test/Simple.pm @@ -4,7 +4,7 @@ use 5.004; use strict 'vars'; use vars qw($VERSION); -$VERSION = '0.42'; +$VERSION = '0.44'; use Test::Builder; @@ -61,8 +61,8 @@ You must have a plan. ok( $foo eq $bar, $name ); ok( $foo eq $bar ); -ok() is given an expression (in this case C<$foo eq $bar>). If it is -true, the test passed. If it is false, it didn't. That's about it. +ok() is given an expression (in this case C<$foo eq $bar>). If it's +true, the test passed. If it's false, it didn't. That's about it. ok() prints out either "ok" or "not ok" along with a test number (it keeps track of that for you). @@ -73,7 +73,7 @@ keeps track of that for you). If you provide a $name, that will be printed along with the "ok/not ok" to make it easier to find your test when if fails (just search for the name). It also makes it easier for the next guy to understand -what your test is for. It is highly recommended you use test names. +what your test is for. It's highly recommended you use test names. All tests are run in scalar context. So this: @@ -112,7 +112,7 @@ So the exit codes are... If you fail more than 254 tests, it will be reported as 254. This module is by no means trying to be a complete testing system. -It's just to get you started. Once you're off the ground it is +It's just to get you started. Once you're off the ground its recommended you look at L<Test::More>. diff --git a/lib/Test/Simple/Changes b/lib/Test/Simple/Changes index 2de6efcf2e..38cbb48821 100644 --- a/lib/Test/Simple/Changes +++ b/lib/Test/Simple/Changes @@ -1,5 +1,22 @@ Revision history for Perl extension Test::Simple +0.44 Thu Apr 25 00:27:27 EDT 2002 + - names containing newlines no longer produce confusing output + (from chromatic) + - chromatic provided a fix so can_ok() honors can() overrides. + - Nick Ing-Simmons suggested todo_skip() be a bit clearer about + the skipping part. + - Making plan() vomit if it gets something it doesn't understand. + - Tatsuhiko Miyagawa fixed use_ok() with pragmata on older perls. + - quieting diag(undef) + +0.43 Thu Apr 11 22:55:23 EDT 2002 + - Adrian Howard added TB->maybe_regex() + - Adding Mark Fowler's suggestion to make diag() return + false. + - TB->current_test() still not working when no tests were run via + TB itself. Fixed by Dave Rolsky. + 0.42 Wed Mar 6 15:00:24 EST 2002 - Setting Test::Builder->current_test() now works (see what happens when you forget to test things?) diff --git a/lib/Test/Simple/t/Builder.t b/lib/Test/Simple/t/Builder.t index a5bfd155a6..e10252e9df 100644 --- a/lib/Test/Simple/t/Builder.t +++ b/lib/Test/Simple/t/Builder.t @@ -10,7 +10,7 @@ BEGIN { use Test::Builder; my $Test = Test::Builder->new; -$Test->plan( tests => 7 ); +$Test->plan( tests => 9 ); my $default_lvl = $Test->level; $Test->level(0); @@ -28,3 +28,9 @@ $Test->current_test( $test_num ); print "ok $test_num - current_test() set\n"; $Test->ok( 1, 'counter still good' ); + +eval { $Test->plan(7); }; +$Test->like( $@, q{/^plan\(\) doesn't understand 7/}, 'bad plan()' ); + +eval { $Test->plan(wibble => 7); }; +$Test->like( $@, q{/^plan\(\) doesn't understand wibble 7/}, 'bad plan()' ); diff --git a/lib/Test/Simple/t/More.t b/lib/Test/Simple/t/More.t index bee2fb4c8c..df8c5fea17 100644 --- a/lib/Test/Simple/t/More.t +++ b/lib/Test/Simple/t/More.t @@ -7,7 +7,7 @@ BEGIN { } } -use Test::More tests => 37; +use Test::More tests => 41; # Make sure we don't mess with $@ or $!. Test at bottom. my $Err = "this should not be touched"; @@ -38,11 +38,28 @@ can_ok('Test::More', qw(require_ok use_ok ok is isnt like skip can_ok can_ok(bless({}, "Test::More"), qw(require_ok use_ok ok is isnt like skip can_ok pass fail eq_array eq_hash eq_set)); + isa_ok(bless([], "Foo"), "Foo"); isa_ok([], 'ARRAY'); isa_ok(\42, 'SCALAR'); +# can_ok() & isa_ok should call can() & isa() on the given object, not +# just class, in case of custom can() +{ + local *Foo::can; + local *Foo::isa; + *Foo::can = sub { $_[0]->[0] }; + *Foo::isa = sub { $_[0]->[0] }; + my $foo = bless([0], 'Foo'); + ok( ! $foo->can('bar') ); + ok( ! $foo->isa('bar') ); + $foo->[0] = 1; + can_ok( $foo, 'blah'); + isa_ok( $foo, 'blah'); +} + + pass('pass() passed'); ok( eq_array([qw(this that whatever)], [qw(this that whatever)]), diff --git a/lib/Test/Simple/t/curr_test.t b/lib/Test/Simple/t/curr_test.t new file mode 100644 index 0000000000..edd201c0e9 --- /dev/null +++ b/lib/Test/Simple/t/curr_test.t @@ -0,0 +1,11 @@ +#!/usr/bin/perl -w + +# Dave Rolsky found a bug where if current_test() is used and no +# tests are run via Test::Builder it will blow up. + +use Test::Builder; +$TB = Test::Builder->new; +$TB->plan(tests => 2); +print "ok 1\n"; +print "ok 2\n"; +$TB->current_test(2); diff --git a/lib/Test/Simple/t/diag.t b/lib/Test/Simple/t/diag.t index 0d6769b79c..453984b3c6 100644 --- a/lib/Test/Simple/t/diag.t +++ b/lib/Test/Simple/t/diag.t @@ -9,7 +9,7 @@ BEGIN { use strict; -use Test::More tests => 5; +use Test::More tests => 7; my $Test = Test::More->builder; @@ -17,8 +17,10 @@ my $Test = Test::More->builder; my $output; tie *FAKEOUT, 'FakeOut', \$output; -# force diagnostic output to a filehandle, glad I added this to Test::Builder :) +# force diagnostic output to a filehandle, glad I added this to +# Test::Builder :) my @lines; +my $ret; { local $TODO = 1; $Test->todo_output(\*FAKEOUT); @@ -28,7 +30,7 @@ my @lines; push @lines, $output; $output = ''; - diag("multiple\n", "lines"); + $ret = diag("multiple\n", "lines"); push @lines, split(/\n/, $output); } @@ -36,14 +38,16 @@ is( @lines, 3, 'diag() should send messages to its filehandle' ); like( $lines[0], '/^#\s+/', ' should add comment mark to all lines' ); is( $lines[0], "# a single line\n", ' should send exact message' ); is( $output, "# multiple\n# lines\n", ' should append multi messages'); +ok( !$ret, 'diag returns false' ); { - local $TODO = 1; + $Test->failure_output(\*FAKEOUT); $output = ''; - diag("# foo"); + $ret = diag("# foo"); } +$Test->failure_output(\*STDERR); is( $output, "# # foo\n", "diag() adds a # even if there's one already" ); - +ok( !$ret, 'diag returns false' ); package FakeOut; diff --git a/lib/Test/Simple/t/exit.t b/lib/Test/Simple/t/exit.t index dcc4565277..25e6259628 100644 --- a/lib/Test/Simple/t/exit.t +++ b/lib/Test/Simple/t/exit.t @@ -54,6 +54,14 @@ my %Tests = ( print "1..".keys(%Tests)."\n"; +eval { require POSIX; &POSIX::WEXITSTATUS(0) }; +if( $@ ) { + *exitstatus = sub { $_[0] >> 8 }; +} +else { + *exitstatus = sub { POSIX::WEXITSTATUS($_[0]) } +} + chdir 't'; my $lib = File::Spec->catdir(qw(lib Test Simple sample_tests)); while( my($test_name, $exit_codes) = each %Tests ) { @@ -72,7 +80,7 @@ while( my($test_name, $exit_codes) = each %Tests ) { my $file = File::Spec->catfile($lib, $test_name); my $wait_stat = system(qq{$Perl -"I../blib/lib" -"I../lib" -"I../t/lib" $file}); - my $actual_exit = $wait_stat >> 8; + my $actual_exit = exitstatus($wait_stat); My::Test::ok( $actual_exit == $exit_code, "$test_name exited with $actual_exit (expected $exit_code)"); diff --git a/lib/Test/Simple/t/maybe_regex.t b/lib/Test/Simple/t/maybe_regex.t new file mode 100644 index 0000000000..dcc84f41c2 --- /dev/null +++ b/lib/Test/Simple/t/maybe_regex.t @@ -0,0 +1,50 @@ +#!/usr/bin/perl -w + +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = ('../lib', 'lib'); + } + else { + unshift @INC, 't/lib'; + } +} + +use strict; +use Test::More tests => 10; + +use Test::Builder; +my $Test = Test::Builder->new; + +SKIP: { + skip "qr// added in 5.005", 3 if $] < 5.005; + + # 5.004 can't even see qr// or it pukes in compile. + eval q{ + my $r = $Test->maybe_regex(qr/^FOO$/i); + ok(defined $r, 'qr// detected'); + ok(('foo' =~ /$r/), 'qr// good match'); + ok(('bar' !~ /$r/), 'qr// bad match'); + }; + die $@ if $@; +} + +{ + my $r = $Test->maybe_regex('/^BAR$/i'); + ok(defined $r, '"//" detected'); + ok(('bar' =~ m/$r/), '"//" good match'); + ok(('foo' !~ m/$r/), '"//" bad match'); +}; + +{ + my $r = $Test->maybe_regex('not a regex'); + ok(!defined $r, 'non-regex detected'); +}; + + +{ + my $r = $Test->maybe_regex('/0/'); + ok(defined $r, 'non-regex detected'); + ok(('f00' =~ m/$r/), '"//" good match'); + ok(('b4r' !~ m/$r/), '"//" bad match'); +}; diff --git a/lib/Test/Simple/t/output.t b/lib/Test/Simple/t/output.t index 82dea28833..dd051c15a6 100644 --- a/lib/Test/Simple/t/output.t +++ b/lib/Test/Simple/t/output.t @@ -3,12 +3,15 @@ BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; - @INC = '../lib'; + @INC = ('../lib', 'lib'); + } + else { + unshift @INC, 't/lib'; } } # Can't use Test.pm, that's a 5.005 thing. -print "1..3\n"; +print "1..4\n"; my $test_num = 1; # Utility testing functions. @@ -21,8 +24,11 @@ sub ok ($;$) { $ok .= "\n"; print $ok; $test_num++; + + return $test; } +use TieOut; use Test::Builder; my $Test = Test::Builder->new(); @@ -55,3 +61,32 @@ close IN; ok($lines[1] =~ /Hello!/); unlink('foo'); + + +# Ensure stray newline in name escaping works. +$out = tie *FAKEOUT, 'TieOut'; +$Test->output(\*FAKEOUT); +$Test->exported_to(__PACKAGE__); +$Test->no_ending(1); +$Test->plan(tests => 5); + +$Test->ok(1, "ok"); +$Test->ok(1, "ok\n"); +$Test->ok(1, "ok, like\nok"); +$Test->skip("wibble\nmoof"); +$Test->todo_skip("todo\nskip\n"); + +my $output = $out->read; +ok( $output eq <<OUTPUT ) || print STDERR $output; +1..5 +ok 1 - ok +ok 2 - ok +# +ok 3 - ok, like +# ok +ok 4 # skip wibble +# moof +not ok 5 # TODO & SKIP todo +# skip +# +OUTPUT diff --git a/lib/Test/Simple/t/strays.t b/lib/Test/Simple/t/strays.t new file mode 100644 index 0000000000..8d5cecad79 --- /dev/null +++ b/lib/Test/Simple/t/strays.t @@ -0,0 +1,41 @@ +#!/usr/bin/perl -w + +# Check that stray newlines in test output are probably handed. + +BEGIN { + print "1..0 # Skip not completed\n"; + exit 0; +} + +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = ('../lib', 'lib'); + } + else { + unshift @INC, 't/lib'; + } +} +chdir 't'; + +use TieOut; +local *FAKEOUT; +my $out = tie *FAKEOUT, 'TieOut'; + + +use Test::Builder; +my $Test = Test::Builder->new; +my $orig_out = $Test->output; +my $orig_err = $Test->failure_output; +my $orig_todo = $Test->todo_output; + +$Test->output(\*FAKEOUT); +$Test->failure_output(\*FAKEOUT); +$Test->todo_output(\*FAKEOUT); +$Test->no_plan(); + +$Test->ok(1, "name\n"); +$Test->ok(0, "foo\nbar\nbaz"); +$Test->skip("\nmoofer"); +$Test->todo_skip("foo\n\n"); + diff --git a/lib/Test/Simple/t/undef.t b/lib/Test/Simple/t/undef.t index 5251264849..00ce8b1937 100644 --- a/lib/Test/Simple/t/undef.t +++ b/lib/Test/Simple/t/undef.t @@ -1,12 +1,18 @@ +#!/usr/bin/perl -w + BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; - @INC = '../lib'; + @INC = ('../lib', 'lib'); + } + else { + unshift @INC, 't/lib'; } } use strict; -use Test::More tests => 12; +use Test::More tests => 14; +use TieOut; BEGIN { $^W = 1; } @@ -41,3 +47,14 @@ eq_hash ( { foo => undef, bar => { baz => undef, moo => 23 } }, is( $warnings, '', 'eq_hash() no warnings' ); +my $tb = Test::More->builder; + +use TieOut; +my $caught = tie *CATCH, 'TieOut'; +my $old_fail = $tb->failure_output; +$tb->failure_output(\*CATCH); +diag(undef); +$tb->failure_output($old_fail); + +is( $caught->read, "# undef\n" ); +is( $warnings, '', 'diag(undef) no warnings' ); diff --git a/lib/Test/Simple/t/use_ok.t b/lib/Test/Simple/t/use_ok.t index f1d7bed6b7..e944628176 100644 --- a/lib/Test/Simple/t/use_ok.t +++ b/lib/Test/Simple/t/use_ok.t @@ -1,3 +1,5 @@ +#!/usr/bin/perl -w + BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @@ -5,7 +7,7 @@ BEGIN { } } -use Test::More tests => 7; +use Test::More tests => 10; # Using Symbol because it's core and exports lots of stuff. { @@ -26,3 +28,11 @@ use Test::More tests => 7; ::use_ok("Symbol", qw(gensym ungensym)); ::ok( defined &gensym && defined &ungensym, ' multiple args' ); } + +{ + package Foo::four; + my $warn; local $SIG{__WARN__} = sub { $warn .= shift; }; + ::use_ok("constant", qw(foo bar)); + ::ok( defined &foo, 'constant' ); + ::is( $warn, undef, 'no warning'); +} diff --git a/lib/overload.t b/lib/overload.t index cf49eac45a..4db647dbee 100644 --- a/lib/overload.t +++ b/lib/overload.t @@ -1066,5 +1066,23 @@ package main; my $utfvar = new utf8_o 200.2.1; test("$utfvar" eq 200.2.1); # 223 +# 224..226 -- more %{} tests. Hangs in 5.6.0, okay in later releases. +# Basically this example implements strong encapsulation: if Hderef::import() +# were to eval the overload code in the caller's namespace, the privatisation +# would be quite transparent. +package Hderef; +use overload '%{}' => sub { (caller(0))[0] eq 'Foo' ? $_[0] : die "zap" }; +package Foo; +@Foo::ISA = 'Hderef'; +sub new { bless {}, shift } +sub xet { @_ == 2 ? $_[0]->{$_[1]} : + @_ == 3 ? ($_[0]->{$_[1]} = $_[2]) : undef } +package main; +my $a = Foo->new; +$a->xet('b', 42); +print $a->xet('b') == 42 ? "ok 224\n" : "not ok 224\n"; +print defined eval { $a->{b} } ? "not ok 225\n" : "ok 225\n"; +print $@ =~ /zap/ ? "ok 226\n" : "not ok 226\n"; + # Last test is: -sub last {223} +sub last {226} diff --git a/makedef.pl b/makedef.pl index 330d6a23dc..4ee99f3552 100644 --- a/makedef.pl +++ b/makedef.pl @@ -769,6 +769,29 @@ if ($define{'USE_PERLIO'}) { PerlIO_ungetc PerlIO_vprintf PerlIO_write + PerlIO_perlio + Perl_PerlIO_clearerr + Perl_PerlIO_close + Perl_PerlIO_eof + Perl_PerlIO_error + Perl_PerlIO_fileno + Perl_PerlIO_fill + Perl_PerlIO_flush + Perl_PerlIO_get_base + Perl_PerlIO_get_bufsiz + Perl_PerlIO_get_cnt + Perl_PerlIO_get_ptr + Perl_PerlIO_read + Perl_PerlIO_seek + Perl_PerlIO_set_cnt + Perl_PerlIO_set_ptrcnt + Perl_PerlIO_setlinebuf + Perl_PerlIO_stderr + Perl_PerlIO_stdin + Perl_PerlIO_stdout + Perl_PerlIO_tell + Perl_PerlIO_unread + Perl_PerlIO_write )]; } } else { @@ -4241,7 +4241,7 @@ Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *blo { LOOP *loop; OP *wop; - int padoff = 0; + PADOFFSET padoff = 0; I32 iterflags = 0; if (sv) { @@ -251,7 +251,7 @@ struct pmop { #else REGEXP * op_pmregexp; /* compiled expression */ #endif - U16 op_pmflags; + U32 op_pmflags; U16 op_pmpermflags; U8 op_pmdynflags; #ifdef USE_ITHREADS @@ -282,7 +282,7 @@ struct pmop { #define PMf_RETAINT 0x0001 /* taint $1 etc. if target tainted */ #define PMf_ONCE 0x0002 /* use pattern only once per reset */ -#define PMf_REVERSED 0x0004 /* Should be matched right->left */ +#define PMf_UNUSED 0x0004 /* free for use */ #define PMf_MAYBE_CONST 0x0008 /* replacement contains variables */ #define PMf_SKIPWHITE 0x0010 /* skip leading whitespace for split */ #define PMf_WHITE 0x0020 /* pattern is \s+ */ diff --git a/patchlevel.h b/patchlevel.h index 43f732cc4a..ceb08bec3a 100644 --- a/patchlevel.h +++ b/patchlevel.h @@ -79,7 +79,7 @@ #if !defined(PERL_PATCHLEVEL_H_IMPLICIT) && !defined(LOCAL_PATCH_COUNT) static char *local_patches[] = { NULL - ,"DEVEL16080" + ,"DEVEL16187" ,NULL }; diff --git a/pod/perldelta.pod b/pod/perldelta.pod index 02ddf8856a..6ebef876a3 100644 --- a/pod/perldelta.pod +++ b/pod/perldelta.pod @@ -48,19 +48,25 @@ More Extensive Regression Testing =head2 Binary Incompatibility -Perl 5.8 has not been designed to be binary compatible with earlier -releases of Perl. While the compatibility has not been intentionally -broken, it has not been intentionally protected, either. The major -reason for the discontinity is the new IO architecture called PerlIO. -The PerlIO is the default configuration because without it many new -features of Perl 5.8 cannot be used. In other words: you just have -to recompile your modules, sorry about that. +B<Perl 5.8 is not binary compatible with earlier releases of Perl.> + +B<You have to recompile your XS modules.> + +(Pure Perl modules should continue to work.) + +The major reason for the discontinity is the new IO architecture +called PerlIO. The PerlIO is the default configuration because +without it many new features of Perl 5.8 cannot be used. In other +words: you just have to recompile your modules, sorry about that. In future releases of Perl non-PerlIO aware XS modules may become completely unsupported. This shouldn't be too difficult for module authors, however: PerlIO has been designed as a drop-in replacement (at the source code level) for the stdio interface. +Depending on your platform, there are also other reasons why +we decided to break binary compatibility, please read on. + =head2 64-bit platforms and malloc If your pointers are 64 bits wide, the Perl malloc is no longer being @@ -879,7 +885,12 @@ C<sort> is a new pragma for controlling the behaviour of sort(). C<Storable> gives persistence to Perl data structures by allowing the storage and retrieval of Perl data to and from files in a fast and -compact binary format, from Raphael Manfredi. See L<Storable>. +compact binary format. Because in effect Storable does serialisation +of Perl data structues, with it you can also clone deep, hierarchical +datastructures. Storable was created by Raphael Manfredi but it is +now maintained by the Perl development team. Storable has been +enhanced to understand the two new hash features, Unicode keys and +restricted hashes. See L<Storable>. =item * @@ -2739,6 +2750,12 @@ be exact. (They produce something other than "1" and "-1" when formatting 0.6 and -0.6 using the printf format "%.0f", most often they produce "0" and "-0".) +=head2 Solaris 2.5 + +In case you are still using Solaris 2.5 (aka SunOS 5.5), you may +experience failures (the test core dumping) in lib/locale.t. +The suggested cure is to upgrade your Solaris. + =head2 Failure of Thread (5.005-style) tests B<Note that support for 5.005-style threading remains experimental diff --git a/pod/perltodo.pod b/pod/perltodo.pod index e715a6145a..60be5b9c2f 100644 --- a/pod/perltodo.pod +++ b/pod/perltodo.pod @@ -542,6 +542,12 @@ even with the same keys. This should be allowed if the new keyset is a subset of the old keyset. May require more extra code than we'd like in pp_aassign. +=head2 Should overload be inheritable? + +Should overload be 'contagious' through @ISA so that derived classes +would inherit their base classes' overload definitions? What to do +in case of overload conflicts? + =head1 Vague ideas Ideas which have been discussed, and which may or may not happen. diff --git a/pod/perluniintro.pod b/pod/perluniintro.pod index 84bfb983a1..d6eae60c4b 100644 --- a/pod/perluniintro.pod +++ b/pod/perluniintro.pod @@ -624,13 +624,16 @@ the output string will be UTF-8-encoded "ab\x80c\x{100}\n", but note that C<$a> will stay single byte encoded. Sometimes you might really need to know the byte length of a string -instead of the character length. For that use the C<bytes> pragma -and its only defined function C<length()>: +instead of the character length. For that use either the +C<Encode::encode_utf8()> function or the C<bytes> pragma and its only +defined function C<length()>: my $unicode = chr(0x100); print length($unicode), "\n"; # will print 1 + require Encode; + print length(Encode::encode_utf8($unicode)), "\n"; # will print 2 use bytes; - print length($unicode), "\n"; # will print 2 (the 0xC4 0x80 of the UTF-8) + print length($unicode), "\n"; # will also print 2 (the 0xC4 0x80 of the UTF-8) =item @@ -2945,11 +2945,11 @@ PP(pp_require) /* help out with the "use 5.6" confusion */ if (sver == 0 && (rev > 5 || (rev == 5 && ver >= 100))) { - DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--" - "this is only v%d.%d.%d, stopped" - " (did you mean v%"UVuf".%03"UVuf"?)", - rev, ver, sver, PERL_REVISION, PERL_VERSION, - PERL_SUBVERSION, rev, ver/100); + DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required" + " (did you mean v%"UVuf".%03"UVuf"?)--" + "this is only v%d.%d.%d, stopped", + rev, ver, sver, rev, ver/100, + PERL_REVISION, PERL_VERSION, PERL_SUBVERSION); } else { DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--" @@ -602,11 +602,7 @@ PERL_CALLCONV struct perl_thread* Perl_new_struct_thread(pTHX_ struct perl_threa PERL_CALLCONV void Perl_reentrant_size(pTHX); PERL_CALLCONV void Perl_reentrant_init(pTHX); PERL_CALLCONV void Perl_reentrant_free(pTHX); -PERL_CALLCONV void* Perl_reentrant_retry(const char*, ...) -#ifdef CHECK_FORMAT - __attribute__((format(printf,1,2))) -#endif -; +PERL_CALLCONV void* Perl_reentrant_retry(const char*, ...); #endif PERL_CALLCONV void Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr); PERL_CALLCONV I32 Perl_call_argv(pTHX_ const char* sub_name, I32 flags, char** argv); @@ -631,7 +627,7 @@ PERL_CALLCONV void Perl_set_numeric_standard(pTHX); PERL_CALLCONV void Perl_require_pv(pTHX_ const char* pv); PERL_CALLCONV void Perl_pack_cat(pTHX_ SV *cat, char *pat, char *patend, SV **beglist, SV **endlist, SV ***next_in_list, U32 flags); PERL_CALLCONV void Perl_pidgone(pTHX_ Pid_t pid, int status); -PERL_CALLCONV void Perl_pmflag(pTHX_ U16* pmfl, int ch); +PERL_CALLCONV void Perl_pmflag(pTHX_ U32* pmfl, int ch); PERL_CALLCONV OP* Perl_pmruntime(pTHX_ OP* pm, OP* expr, OP* repl); PERL_CALLCONV OP* Perl_pmtrans(pTHX_ OP* o, OP* expr, OP* repl); PERL_CALLCONV OP* Perl_pop_return(pTHX); @@ -2149,8 +2149,8 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp) /* Make an OPEN node, if parenthesized. */ if (paren) { if (*RExC_parse == '?') { /* (?...) */ - U16 posflags = 0, negflags = 0; - U16 *flagsp = &posflags; + U32 posflags = 0, negflags = 0; + U32 *flagsp = &posflags; int logical = 0; char *seqstart = RExC_parse; @@ -4775,7 +4775,6 @@ Perl_regprop(pTHX_ SV *sv, regnode *o) if (lv) { if (sw) { - UV i; U8 s[UTF8_MAXLEN+1]; for (i = 0; i <= 256; i++) { /* just the first 256 */ @@ -9389,7 +9389,7 @@ Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param) CvFILE(dstr) = CvXSUB(sstr) ? CvFILE(sstr) : SAVEPV(CvFILE(sstr)); break; default: - Perl_croak(aTHX_ "Bizarre SvTYPE [%d]", SvTYPE(sstr)); + Perl_croak(aTHX_ "Bizarre SvTYPE [%" IVdf "]", (IV)SvTYPE(sstr)); break; } @@ -10412,7 +10412,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_retstack_ix = proto_perl->Tretstack_ix; PL_retstack_max = proto_perl->Tretstack_max; Newz(54, PL_retstack, PL_retstack_max, OP*); - Copy(proto_perl->Tretstack, PL_retstack, PL_retstack_ix, I32); + Copy(proto_perl->Tretstack, PL_retstack, PL_retstack_ix, OP*); /* NOTE: si_dup() looks at PL_markstack */ PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo, param); @@ -9,6 +9,9 @@ $| = 1; # which live dual lives on CPAN. $ENV{PERL_CORE} = 1; +# remove empty elements due to insertion of empty symbols via "''p1'" syntax +@ARGV = grep($_,@ARGV) if $^O eq 'VMS'; + # Cheesy version of Getopt::Std. Maybe we should replace it with that. @argv = (); if ($#ARGV >= 0) { @@ -64,31 +67,46 @@ sub _find_tests { foreach my $f (sort { $a cmp $b } readdir DIR) { next if $f eq $curdir or $f eq $updir; - my $fullpath = File::Spec->catdir($dir, $f); + my $fullpath = File::Spec->catfile($dir, $f); _find_tests($fullpath) if -d $fullpath; + $fullpath = VMS::Filespec::unixify($fullpath) if $^O eq 'VMS'; push @ARGV, $fullpath if $f =~ /\.t$/; } } +sub _quote_args { + my ($args) = @_; + my $argstring = ''; + + foreach (split(/\s+/,$args)) { + # In VMS protect with doublequotes because otherwise + # DCL will lowercase -- unless already doublequoted. + $_ = q(").$_.q(") if ($^O eq 'VMS') && !/^\"/ && length($_) > 0; + $argstring .= ' ' . $_; + } + return $argstring; +} + unless (@ARGV) { foreach my $dir (qw(base comp cmd run io op uni)) { _find_tests($dir); } _find_tests("lib") unless $core; - my $mani = File::Spec->catdir($updir, "MANIFEST"); + my $mani = File::Spec->catfile($updir, "MANIFEST"); if (open(MANI, $mani)) { while (<MANI>) { # similar code in t/harness if (m!^(ext/\S+/?([^/]+\.t|test\.pl)|lib/\S+?(\.t|test\.pl))\s!) { $t = $1; if (!$core || $t =~ m!^lib/[a-z]!) { - $path = File::Spec->catdir($updir, $t); + $path = File::Spec->catfile($updir, $t); push @ARGV, $path; $name{$path} = $t; } } } + close MANI; } else { warn "$0: cannot open $mani: $!\n"; } @@ -139,8 +157,12 @@ EOT $files = 0; $totmax = 0; - foreach (@tests) { - $name{$_} = File::Spec->catdir('t',$_) unless exists $name{$_}; + foreach my $t (@tests) { + unless (exists $name{$t}) { + my $tname = File::Spec->catfile('t',$t); + $tname = VMS::Filespec::unixify($tname) if $^O eq 'VMS'; + $name{$t} = $tname; + } } my $maxlen = 0; foreach (@name{@tests}) { @@ -169,8 +191,12 @@ EOT next; } } - $te = $name{$test}; - print "$te" . '.' x ($dotdotdot - length($te)); + $te = $name{$test} . '.' x ($dotdotdot - length($name{$test})); + + if ($^O ne 'VMS') { # defer printing on VMS due to piping bug + print $te; + $te = ''; + } $test = $OVER{$test} if exists $OVER{$test}; @@ -208,7 +234,8 @@ EOT } elsif ($type eq 'perl') { my $perl = $ENV{PERL} || './perl'; - my $run = "$perl $testswitch $switch $utf $test |"; + my $redir = ($^O eq 'VMS' ? '2>&1' : ''); + my $run = "$perl" . _quote_args("$testswitch $switch $utf") . " $test $redir|"; open(RESULTS,$run) or print "can't run '$run': $!.\n"; } else { @@ -246,6 +273,7 @@ EOT $ok = 0; $next = 0; while (<RESULTS>) { + next if /^\s*$/; # skip blank lines if ($verbose) { print $_; } @@ -304,17 +332,17 @@ EOT } if ($ok && $next == $max ) { if ($max) { - print "ok\n"; + print "${te}ok\n"; $good = $good + 1; } else { - print "skipping test on this platform\n"; + print "${te}skipping test on this platform\n"; $files -= 1; } } else { $next += 1; - print "FAILED at test $next\n"; + print "${te}FAILED at test $next\n"; $bad = $bad + 1; $_ = $test; if (/^base/) { @@ -63,10 +63,11 @@ if (@ARGV) { my $mani = File::Spec->catfile(File::Spec->updir, "MANIFEST"); if (open(MANI, $mani)) { while (<MANI>) { # similar code in t/TEST - if (m!^(ext/\S+/([^/]+\.t|test\.pl)|lib/\S+?(\.t|test\.pl))\s!) { + if (m!^(ext/\S+/?([^/]+\.t|test\.pl)|lib/\S+?(\.t|test\.pl))\s!) { push @tests, File::Spec->catfile($updir, $1); } } + close MANI; } else { warn "$0: cannot open $mani: $!\n"; } diff --git a/t/japh/abigail.t b/t/japh/abigail.t index 2ece031f03..06bba7a0ab 100644 --- a/t/japh/abigail.t +++ b/t/japh/abigail.t @@ -13,7 +13,14 @@ # disable the test!) # # Getting everything to run well on the myriad of platforms Perl runs on -# is unfortunally, not a trivial task. +# is unfortunately not a trivial task. +# +# WARNING: these tests are obfuscated. Do not get frustrated. +# Ask Abigail <abigail@foad.org>, or use the Deparse or Concise +# modules (the former parses Perl to Perl, the latter shows the +# op syntax tree) like this: +# ./perl -Ilib -MO=Deparse foo.pl +# ./perl -Ilib -MO=Concise foo.pl # BEGIN { diff --git a/t/lib/sample-tests/bignum b/t/lib/sample-tests/bignum new file mode 100644 index 0000000000..3f51d38a42 --- /dev/null +++ b/t/lib/sample-tests/bignum @@ -0,0 +1,7 @@ +print <<DUMMY; +1..2 +ok 1 +ok 2 +ok 100001 +ok 136211425 +DUMMY diff --git a/t/lib/sample-tests/die b/t/lib/sample-tests/die new file mode 100644 index 0000000000..e5bbd441ba --- /dev/null +++ b/t/lib/sample-tests/die @@ -0,0 +1 @@ +exit 1; # exit because die() can be noisy diff --git a/t/lib/sample-tests/die_head_end b/t/lib/sample-tests/die_head_end new file mode 100644 index 0000000000..f1f72e44c3 --- /dev/null +++ b/t/lib/sample-tests/die_head_end @@ -0,0 +1,8 @@ +print <<DUMMY_TEST; +ok 1 +ok 2 +ok 3 +ok 4 +DUMMY_TEST + +exit 1; diff --git a/t/lib/sample-tests/die_last_minute b/t/lib/sample-tests/die_last_minute new file mode 100644 index 0000000000..2f870d3e18 --- /dev/null +++ b/t/lib/sample-tests/die_last_minute @@ -0,0 +1,9 @@ +print <<DUMMY_TEST; +ok 1 +ok 2 +ok 3 +ok 4 +1..4 +DUMMY_TEST + +exit 1; diff --git a/t/lib/warnings/op b/t/lib/warnings/op index 9b20a8c256..387e620efa 100644 --- a/t/lib/warnings/op +++ b/t/lib/warnings/op @@ -130,10 +130,13 @@ __END__ use warnings 'misc' ; my $x ; my $x ; +my $y = my $y ; no warnings 'misc' ; my $x ; +my $y ; EXPECT "my" variable $x masks earlier declaration in same scope at - line 4. +"my" variable $y masks earlier declaration in same statement at - line 5. ######## # op.c use warnings 'closure' ; @@ -6247,7 +6247,7 @@ S_scan_ident(pTHX_ register char *s, register char *send, char *dest, STRLEN des } void -Perl_pmflag(pTHX_ U16 *pmfl, int ch) +Perl_pmflag(pTHX_ U32* pmfl, int ch) { if (ch == 'i') *pmfl |= PMf_FOLD; @@ -1024,7 +1024,7 @@ /* BYTEORDER: * This symbol holds the hexadecimal constant defined in byteorder, - * i.e. 0x1234 or 0x4321, etc... + * in a UV, i.e. 0x1234 or 0x4321 or 0x12345678, etc... * If the compiler supports cross-compiling or multiple-architecture * binaries (eg. on NeXT systems), use compiler-defined macros to * determine the byte order. @@ -2480,12 +2480,16 @@ */ /*#define HAS_TELLDIR_PROTO / **/ +/* HAS_TIME: + * This symbol, if defined, indicates that the time() routine exists. + */ /* Time_t: * This symbol holds the type returned by time(). It can be long, * or time_t on BSD sites (in which case <sys/types.h> should be * included). */ -#define Time_t int /* Time type */ +#define HAS_TIME /**/ +#define Time_t time_t /* Time type */ /* HAS_TIMES: * This symbol, if defined, indicates that the times() routine exists. diff --git a/uconfig.sh b/uconfig.sh index 4fedcfc6ab..ba3d253ee6 100755 --- a/uconfig.sh +++ b/uconfig.sh @@ -382,7 +382,7 @@ d_tcgetpgrp='undef' d_tcsetpgrp='undef' d_telldir='undef' d_telldirproto='undef' -d_time='undef' +d_time='define' d_times='undef' d_tm_tm_gmtoff='undef' d_tm_tm_zone='undef' @@ -654,7 +654,7 @@ stdio_filbuf='' stdio_ptr='((fp)->_IO_read_ptr)' stdio_stream_array='' strerror_r_proto='0' -timetype=int +timetype=time_t tmpnam_r_proto='0' touch='touch' ttyname_r_proto='0' @@ -3447,7 +3447,8 @@ Perl_report_evil_fh(pTHX_ GV *gv, IO *io, I32 op) if (gv && isGV(gv)) { SV *sv = sv_newmortal(); gv_efullname4(sv, gv, Nullch, FALSE); - name = SvPVX(sv); + if (SvOK(sv)) + name = SvPVX(sv); } if (op == OP_phoney_OUTPUT_ONLY || op == OP_phoney_INPUT_ONLY) { diff --git a/vms/test.com b/vms/test.com index 6dbed1f671..3c4ce9339d 100644 --- a/vms/test.com +++ b/vms/test.com @@ -1,25 +1,24 @@ -$! Test.Com - DCL driver for perl5 regression tests +$! Test.Com - DCL wrapper for perl5 regression test driver +$! +$! Version 2.0 25-April-2002 Craig Berry craigberry@mac.com +$! (and many other hands in the last 7+ years) +$! The most significant difference is that we now run the external t/TEST +$! rather than keeping a separately maintained test driver embedded here. $! $! Version 1.1 4-Dec-1995 $! Charles Bailey bailey@newman.upenn.edu $! -$! A little basic setup +$! Set up error handler and save things we'll restore later. +$ On Control_Y Then Goto Control_Y_exit $ On Error Then Goto wrapup $ olddef = F$Environment("Default") $ oldmsg = F$Environment("Message") -$ If F$Search("t.dir").nes."" -$ Then -$ Set Default [.t] -$ Else -$ If F$TrnLNm("Perl_Root").nes."" -$ Then -$ Set Default Perl_Root:[t] -$ Else -$ Write Sys$Error "Can't find test directory" -$ Exit 44 -$ EndIf -$ EndIf -$ Set Message /NoFacility/NoSeverity/NoIdentification/NoText +$ oldpriv = F$SetPrv("NOALL") ! downgrade privs for safety +$ discard = F$SetPrv("NETMBX,TMPMBX") ! only need these to run tests +$! +$! Process arguments. P1 is the file extension of the Perl images. P2, +$! when not empty, indicates that we are testing a version of Perl built for +$! the VMS debugger. The other arguments are passed directly to t/TEST. $! $ exe = ".Exe" $ If p1.nes."" Then exe = p1 @@ -30,7 +29,8 @@ $ Write Sys$Error "The first parameter passed to Test.Com must be the file t $ Write Sys$Error "images produced when you built Perl (i.e. "".Exe"", unless you edited" $ Write Sys$Error "Descrip.MMS or used the AXE=1 macro in the MM[SK] command line." $ Write Sys$Error "" -$ Exit 44 +$ $status = 44 +$ goto wrapup $ EndIf $! $! "debug" perl if second parameter is nonblank @@ -40,6 +40,21 @@ $ ndbg = "" $ if p2.nes."" then dbg = "dbg" $ if p2.nes."" then ndbg = "ndbg" $! +$! Make sure we are where we need to be. +$ If F$Search("t.dir").nes."" +$ Then +$ Set Default [.t] +$ Else +$ If F$TrnLNm("Perl_Root").nes."" +$ Then +$ Set Default Perl_Root:[t] +$ Else +$ Write Sys$Error "Can't find test directory" +$ $status = 44 +$ goto wrapup +$ EndIf +$ EndIf +$! $! Pick up a copy of perl to use for the tests $ If F$Search("Perl.").nes."" Then Delete/Log/NoConfirm Perl.;* $ Copy/Log/NoConfirm [-]'ndbg'Perl'exe' []Perl. @@ -52,174 +67,23 @@ $! This may be set for the C compiler in descrip.mms, but it confuses the File: $ if f$trnlnm("sys") .nes. "" then DeAssign sys $! $! And do it +$ Set Message /NoFacility/NoSeverity/NoIdentification/NoText $ Show Process/Accounting $ testdir = "Directory/NoHead/NoTrail/Column=1" $ PerlShr_filespec = f$parse("Sys$Disk:[-]''dbg'PerlShr''exe'") $ Define 'dbg'Perlshr 'PerlShr_filespec' -$ if f$mode() .nes. "INTERACTIVE" then Define PERL_SKIP_TTY_TEST 1 -$ MCR Sys$Disk:[]Perl. "-I[-.lib]" - "''p3'" "''p4'" "''p5'" "''p6'" -$ Deck/Dollar=$$END-OF-TEST$$ -# -# The bulk of the below code is scheduled for deletion. test.com -# will shortly use t/TEST. -# - -use Config; -use File::Spec; - -$| = 1; - -# Let tests know they're running in the perl core. Useful for modules -# which live dual lives on CPAN. -$ENV{PERL_CORE} = 1; - -@ARGV = grep($_,@ARGV); # remove empty elements due to "''p1'" syntax - -if (lc($ARGV[0]) eq '-v') { - $verbose = 1; - shift; -} - -chdir 't' if -f 't/TEST'; - -if ($ARGV[0] eq '') { - foreach (<[.*]*.t>, <[-.ext...]*.t>, <[-.lib...]*.t>) { - $_ = File::Spec->abs2rel($_); - s/\[([a-z]+)/[.$1/; # hmm, abs2rel doesn't do subdirs of the cwd - ($fname = $_) =~ s/.*\]//; - push(@ARGV,$_); - } -} - -$bad = 0; -$good = 0; -$extra_skip = 0; -$total = @ARGV; -while ($test = shift) { - if ($test =~ /^$/) { - next; - } - $te = $test; - chop($te); - $te .= '.' x (40 - length($te)); - open(script,"$test") || die "Can't run $test.\n"; - $_ = <script>; - close(script); - if (/#!.*\bperl.*-\w*([tT])/) { - $switch = qq{"-$1"}; - } else { - $switch = ''; - } - open(results,"\$ MCR Sys\$Disk:[]Perl. \"-I[-.lib]\" $switch $test 2>&1|") || (print "can't run.\n"); - $ok = 0; - $next = 0; - $pending_not = 0; - while (<results>) { - if ($verbose) { - print "$te$_"; - $te = ''; - } - unless (/^#/) { - if (/^1\.\.([0-9]+)( todo ([\d ]+))?/) { - $max = $1; - %todo = map { $_ => 1 } split / /, $3 if $3; - $totmax += $max; - $files += 1; - $next = 1; - $ok = 1; - } else { - # our 'echo' substitute produces one more \n than Unix' - next if /^\s*$/; - - - if (/^(not )?ok (\d+)[^#]*(\s*#.*)?/ && - $2 == $next) - { - my($not, $num, $extra) = ($1, $2, $3); - my($istodo) = $extra =~ /^\s*#\s*TODO/ if $extra; - $istodo = 1 if $todo{$num}; - - if( $not && !$istodo ) { - $ok = 0; - $next = $num; - last; - } - elsif( $pending_not ) { - $next = $num; - $ok = 0; - } - else { - $next = $next + 1; - } - } - elsif(/^not $/) { - # VMS has this problem. It sometimes adds newlines - # between prints. This sometimes means you get - # "not \nok 42" - $pending_not = 1; - } - elsif (/^Bail out!\s*(.*)/i) { # magic words - die "FAILED--Further testing stopped" . ($1 ? ": $1\n" : ".\n"); - } - else { - $ok = 0; - } - - } - } - } - $next = $next - 1; - if ($ok && $next == $max) { - if ($max) { - print "${te}ok\n"; - $good = $good + 1; - } else { - print "${te}skipping test on this platform\n"; - $files -= 1; - $extra_skip = $extra_skip + 1; - } - } else { - $next += 1; - print "${te}FAILED on test $next\n"; - $bad = $bad + 1; - $_ = $test; - if (/^base/) { - die "Failed a basic test--cannot continue.\n"; - } - } -} - -if ($bad == 0) { - if ($ok) { - print "All tests successful.\n"; - } else { - die "FAILED--no tests were run for some reason.\n"; - } -} else { - # $pct = sprintf("%.2f", $good / $total * 100); - $gtotal = $total - $extra_skip; - if ($gtotal <= 0) { $gtotal = $total; } - $pct = sprintf("%.2f", $good / $gtotal * 100); - if ($bad == 1) { - warn "Failed 1 test, $pct% okay.\n"; - } else { - if ($extra_skip > 0) { - warn "Total tests: $total, Passed $good, Skipped $extra_skip.\n"; - warn "Failed $bad/$gtotal tests, $pct% okay.\n"; - } - else { - warn "Total tests: $total, Passed $good.\n"; - warn "Failed $bad/$gtotal tests, $pct% okay.\n"; - } - } -} -($user,$sys,$cuser,$csys) = times; -print sprintf("u=%g s=%g cu=%g cs=%g scripts=%d tests=%d\n", - $user,$sys,$cuser,$csys,$files,$totmax); -$$END-OF-TEST$$ +$ If F$Mode() .nes. "INTERACTIVE" Then Define/Nolog PERL_SKIP_TTY_TEST 1 +$ MCR Sys$Disk:[]Perl. "-I[-.lib]" TEST. "''p3'" "''p4'" "''p5'" "''p6'" +$ goto wrapup +$! +$ Control_Y_exit: +$ $status = 1552 ! %SYSTEM-W-CONTROLY +$! $ wrapup: -$ deassign 'dbg'Perlshr +$ status = $status +$ If f$trnlnm("''dbg'PerlShr") .nes. "" Then DeAssign 'dbg'PerlShr $ Show Process/Accounting -$ Set Default &olddef -$ Set Message 'oldmsg' -$ Exit +$ If f$type(olddef) .nes. "" Then Set Default &olddef +$ If f$type(oldmsg) .nes. "" Then Set Message 'oldmsg' +$ If f$type(oldpriv) .nes. "" Then discard = F$SetPrv(oldpriv) +$ Exit status @@ -2714,6 +2714,7 @@ Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags) #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70100322 */ + { $DESCRIPTOR(intdsc,"0 00:00:01"); unsigned long int ownercode = JPI$_OWNER, ownerpid; unsigned long int pidcode = JPI$_PID, mypid; @@ -2774,7 +2775,7 @@ Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags) _ckvmssts(sts); return pid; - + } } /* end of waitpid() */ /*}}}*/ /*}}}*/ @@ -2,6 +2,8 @@ /* Written 02-01-02 by Nick Ing-Simmons (nick@ing-simmons.net) */ /* Modified 02-03-27 by Paul Green (Paul.Green@stratus.com) to add socketpair() dummy. */ +/* Modified 02-04-24 by Paul Green (Paul.Green@stratus.com) to + have pow(0,0) return 1, avoiding c-1471. */ /* End of modification history */ #include <errno.h> @@ -35,3 +37,22 @@ socketpair (int family, int type, int protocol, int fd[2]) { errno = ENOSYS; return -1; } + +/* Supply a private version of the power function that returns 1 + for x**0. This avoids c-1471. Abigail's Japh tests depend + on this fix. We leave all the other cases to the VOS C + runtime. */ + +double s_crt_pow(double *x, double *y); + +double pow(x,y) +double x, y; +{ + if (y == 0e0) /* c-1471 */ + { + errno = EDOM; + return (1e0); + } + + return(s_crt_pow(&x,&y)); +} diff --git a/win32/Makefile b/win32/Makefile index e8a35c0cf6..5c81d6e93d 100644 --- a/win32/Makefile +++ b/win32/Makefile @@ -453,11 +453,14 @@ UTILS = \ ..\utils\perlbug \ ..\utils\pl2pm \ ..\utils\c2ph \ + ..\utils\pstruct \ ..\utils\h2xs \ ..\utils\perldoc \ ..\utils\perlcc \ ..\utils\perlivp \ ..\utils\libnetcfg \ + ..\utils\enc2xs \ + ..\utils\piconv \ ..\pod\checkpods \ ..\pod\pod2html \ ..\pod\pod2latex \ @@ -467,6 +470,7 @@ UTILS = \ ..\pod\podchecker \ ..\pod\podselect \ ..\x2p\find2perl \ + ..\x2p\psed \ ..\x2p\s2p \ ..\lib\ExtUtils\xsubpp \ bin\exetype.pl \ @@ -1040,18 +1044,22 @@ distclean: clean perlwin32.pod pod2html pod2latex pod2man pod2text pod2usage \ podchecker podselect cd ..\utils - -del /f h2ph splain perlbug pl2pm c2ph h2xs perldoc perlivp dprofpp + -del /f h2ph splain perlbug pl2pm c2ph pstruct h2xs perldoc perlivp \ + dprofpp perlcc libnetcfg enc2xs piconv -del /f *.bat cd ..\win32 cd ..\x2p - -del /f find2perl s2p + -del /f find2perl s2p psed -del /f *.bat cd ..\win32 -del /f ..\config.sh ..\splittree.pl perlmain.c dlutils.c config.h.new -del /f $(CONFIGPM) -del /f bin\*.bat + cd .. + -del /s *.lib *.map *.pdb *.ilk *.bs *$(o) .exists pm_to_blib + cd win32 cd $(EXTDIR) - -del /s *.lib *.def *.map *.pdb *.bs Makefile *$(o) pm_to_blib + -del /s *.def Makefile Makefile.old cd ..\win32 -if exist $(AUTODIR) rmdir /s /q $(AUTODIR) -rmdir /s $(AUTODIR) diff --git a/win32/buildext.pl b/win32/buildext.pl index b5fd4d40c9..7125753709 100644 --- a/win32/buildext.pl +++ b/win32/buildext.pl @@ -28,6 +28,16 @@ if ($perl =~ m#^\.\.#) { $perl = "$here\\$perl"; } +(my $topdir = $perl) =~ s/\\[^\\]+$//; +# miniperl needs to find perlglob and pl2bat +$ENV{PATH} = "$topdir;$topdir\\win32\\bin;$ENV{PATH}"; +#print "PATH=$ENV{PATH}\n"; +my $pl2bat = "$topdir\\win32\\bin\\pl2bat"; +unless (-f "$pl2bat.bat") { + my @args = ($perl, ("$pl2bat.pl") x 2); + print "@args\n"; + system(@args); +} my $make = shift; $make .= " ".shift while $ARGV[0]=~/^-/; my $dep = shift; diff --git a/win32/makefile.mk b/win32/makefile.mk index 35a9eb350f..c5c761aae6 100644 --- a/win32/makefile.mk +++ b/win32/makefile.mk @@ -589,11 +589,14 @@ UTILS = \ ..\utils\perlbug \ ..\utils\pl2pm \ ..\utils\c2ph \ + ..\utils\pstruct \ ..\utils\h2xs \ ..\utils\perldoc \ ..\utils\perlcc \ ..\utils\perlivp \ ..\utils\libnetcfg \ + ..\utils\enc2xs \ + ..\utils\piconv \ ..\pod\checkpods \ ..\pod\pod2html \ ..\pod\pod2latex \ @@ -603,6 +606,7 @@ UTILS = \ ..\pod\podchecker \ ..\pod\podselect \ ..\x2p\find2perl \ + ..\x2p\psed \ ..\x2p\s2p \ ..\lib\ExtUtils\xsubpp \ bin\exetype.pl \ @@ -1179,14 +1183,14 @@ distclean: clean perlvmesa.pod perlvms.pod perlvos.pod \ perlwin32.pod pod2html pod2latex pod2man pod2text pod2usage \ podchecker podselect - -cd ..\utils && del /f h2ph splain perlbug pl2pm c2ph h2xs perldoc \ - perlivp dprofpp *.bat - -cd ..\x2p && del /f find2perl s2p *.bat + -cd ..\utils && del /f h2ph splain perlbug pl2pm c2ph pstruct h2xs \ + perldoc perlivp dprofpp perlcc libnetcfg enc2xs piconv *.bat + -cd ..\x2p && del /f find2perl s2p psed *.bat -del /f ..\config.sh ..\splittree.pl perlmain.c dlutils.c config.h.new -del /f $(CONFIGPM) -del /f bin\*.bat - -cd $(EXTDIR) && del /s *$(a) *.def *.map *.pdb *.bs Makefile *$(o) \ - pm_to_blib + -cd .. && del /s *$(a) *.map *.pdb *.ilk *.bs *$(o) .exists pm_to_blib + -cd $(EXTDIR) && del /s *.def Makefile Makefile.old -if exist $(AUTODIR) rmdir /s /q $(AUTODIR) || rmdir /s $(AUTODIR) -if exist $(COREDIR) rmdir /s /q $(COREDIR) || rmdir /s $(COREDIR) |