From bfc39307a33e1105792ff93b6fad2c52e38c41ee Mon Sep 17 00:00:00 2001 From: Reini Urban Date: Thu, 22 Oct 2015 10:16:53 +0200 Subject: [PATCH] CORE: version-specific coretests as submodule See https://github.com/rurban/perl-compiler/issues/332 Submodule stored at https://github.com/perl11/p5-coretests initialized with t/core-init.sh --- .gitmodules | 3 + Changes | 2 + MANIFEST | 621 +---- Makefile.PL | 20 +- t/C-COMPILED/CORE--base--cond.t | 1 - t/C-COMPILED/CORE--base--if.t | 1 - t/C-COMPILED/CORE--base--lex.t | 1 - t/C-COMPILED/CORE--base--num.t | 1 - t/C-COMPILED/CORE--base--pat.t | 1 - t/C-COMPILED/CORE--base--rs.t | 1 - t/C-COMPILED/CORE--base--term.t | 1 - t/C-COMPILED/CORE--base--while.t | 1 - t/C-COMPILED/CORE--cmd--elsif.t | 1 - t/C-COMPILED/CORE--cmd--for.t | 1 - t/C-COMPILED/CORE--cmd--mod.t | 1 - t/C-COMPILED/CORE--cmd--subval.t | 1 - t/C-COMPILED/CORE--cmd--switch.t | 1 - t/C-COMPILED/CORE--cmd--while.t | 1 - t/C-COMPILED/CORE--comp--bproto.t | 1 - t/C-COMPILED/CORE--comp--cmdopt.t | 1 - t/C-COMPILED/CORE--comp--colon.t | 1 - t/C-COMPILED/CORE--comp--decl.t | 1 - t/C-COMPILED/CORE--comp--fold.t | 1 - t/C-COMPILED/CORE--comp--form_scope.t | 1 - t/C-COMPILED/CORE--comp--line_debug.t | 1 - t/C-COMPILED/CORE--comp--multiline.t | 1 - t/C-COMPILED/CORE--comp--opsubs.t | 1 - t/C-COMPILED/CORE--comp--our.t | 1 - t/C-COMPILED/CORE--comp--package.t | 1 - t/C-COMPILED/CORE--comp--package_block.t | 1 - t/C-COMPILED/CORE--comp--parser.t | 1 - t/C-COMPILED/CORE--comp--proto.t | 1 - t/C-COMPILED/CORE--comp--redef.t | 1 - t/C-COMPILED/CORE--comp--require.t | 1 - t/C-COMPILED/CORE--comp--retainedlines.t | 1 - t/C-COMPILED/CORE--comp--term.t | 1 - t/C-COMPILED/CORE--comp--uproto.t | 1 - t/C-COMPILED/CORE--comp--use.t | 1 - t/C-COMPILED/CORE--comp--utf.t | 1 - t/C-COMPILED/CORE--io--argv.t | 1 - t/C-COMPILED/CORE--io--binmode.t | 1 - t/C-COMPILED/CORE--io--bom.t | 1 - t/C-COMPILED/CORE--io--crlf.t | 1 - t/C-COMPILED/CORE--io--crlf_through.t | 1 - t/C-COMPILED/CORE--io--data.t | 1 - t/C-COMPILED/CORE--io--defout.t | 1 - t/C-COMPILED/CORE--io--dup.t | 1 - t/C-COMPILED/CORE--io--eintr.t | 1 - t/C-COMPILED/CORE--io--errno.t | 1 - t/C-COMPILED/CORE--io--errnosig.t | 1 - t/C-COMPILED/CORE--io--fflush.t | 1 - t/C-COMPILED/CORE--io--fs.t | 1 - t/C-COMPILED/CORE--io--inplace.t | 1 - t/C-COMPILED/CORE--io--iofile.t | 1 - t/C-COMPILED/CORE--io--iprefix.t | 1 - t/C-COMPILED/CORE--io--layers==BADTEST-203.t | 1 - t/C-COMPILED/CORE--io--nargv.t | 1 - t/C-COMPILED/CORE--io--open.t | 1 - t/C-COMPILED/CORE--io--openpid.t | 1 - t/C-COMPILED/CORE--io--perlio.t | 1 - t/C-COMPILED/CORE--io--perlio_fail.t | 1 - t/C-COMPILED/CORE--io--perlio_leaks.t | 1 - t/C-COMPILED/CORE--io--perlio_open.t | 1 - t/C-COMPILED/CORE--io--pipe.t | 1 - t/C-COMPILED/CORE--io--print.t | 1 - t/C-COMPILED/CORE--io--pvbm.t | 1 - t/C-COMPILED/CORE--io--read.t | 1 - t/C-COMPILED/CORE--io--say.t | 1 - t/C-COMPILED/CORE--io--tell.t | 1 - t/C-COMPILED/CORE--io--through.t | 1 - t/C-COMPILED/CORE--io--utf8==BADTEST-319.t | 1 - t/C-COMPILED/CORE--mro--basic.t | 1 - t/C-COMPILED/CORE--mro--basic_01_c3.t | 1 - t/C-COMPILED/CORE--mro--basic_01_dfs.t | 1 - t/C-COMPILED/CORE--mro--basic_02_c3.t | 1 - t/C-COMPILED/CORE--mro--basic_02_dfs.t | 1 - t/C-COMPILED/CORE--mro--basic_03_c3.t | 1 - t/C-COMPILED/CORE--mro--basic_03_dfs.t | 1 - t/C-COMPILED/CORE--mro--basic_04_c3.t | 1 - t/C-COMPILED/CORE--mro--basic_04_dfs.t | 1 - t/C-COMPILED/CORE--mro--basic_05_c3.t | 1 - t/C-COMPILED/CORE--mro--basic_05_dfs.t | 1 - t/C-COMPILED/CORE--mro--c3_with_overload.t | 1 - t/C-COMPILED/CORE--mro--complex_c3.t | 1 - t/C-COMPILED/CORE--mro--complex_dfs.t | 1 - t/C-COMPILED/CORE--mro--dbic_c3.t | 1 - t/C-COMPILED/CORE--mro--dbic_dfs.t | 1 - t/C-COMPILED/CORE--mro--inconsistent_c3.t | 1 - t/C-COMPILED/CORE--mro--isa_aliases.t | 1 - t/C-COMPILED/CORE--mro--isa_c3.t | 1 - t/C-COMPILED/CORE--mro--isa_dfs.t | 1 - t/C-COMPILED/CORE--mro--isarev==BADTEST-353.t | 1 - t/C-COMPILED/CORE--mro--method_caching.t | 1 - t/C-COMPILED/CORE--mro--next_NEXT.t | 1 - t/C-COMPILED/CORE--mro--next_edgecases.t | 1 - t/C-COMPILED/CORE--mro--next_goto.t | 1 - t/C-COMPILED/CORE--mro--next_inanon.t | 1 - t/C-COMPILED/CORE--mro--next_ineval.t | 1 - t/C-COMPILED/CORE--mro--next_method.t | 1 - t/C-COMPILED/CORE--mro--next_skip.t | 1 - t/C-COMPILED/CORE--mro--overload_c3.t | 1 - t/C-COMPILED/CORE--mro--overload_dfs.t | 1 - t/C-COMPILED/CORE--mro--package_aliases.t | 1 - t/C-COMPILED/CORE--mro--pkg_gen.t | 1 - t/C-COMPILED/CORE--mro--recursion_c3.t | 1 - t/C-COMPILED/CORE--mro--recursion_dfs.t | 1 - t/C-COMPILED/CORE--mro--vulcan_c3.t | 1 - t/C-COMPILED/CORE--mro--vulcan_dfs.t | 1 - t/C-COMPILED/CORE--op--64bitint.t | 1 - t/C-COMPILED/CORE--op--alarm.t | 1 - t/C-COMPILED/CORE--op--anonsub.t | 1 - t/C-COMPILED/CORE--op--append.t | 1 - t/C-COMPILED/CORE--op--args.t | 1 - t/C-COMPILED/CORE--op--arith.t | 1 - t/C-COMPILED/CORE--op--array.t | 1 - t/C-COMPILED/CORE--op--array_base.t | 1 - t/C-COMPILED/CORE--op--assignwarn.t | 1 - .../CORE--op--attrhand==BADPLAN-169.t | 1 - t/C-COMPILED/CORE--op--attrs.t | 1 - t/C-COMPILED/CORE--op--auto.t | 1 - t/C-COMPILED/CORE--op--avhv.t | 1 - t/C-COMPILED/CORE--op--bless.t | 1 - t/C-COMPILED/CORE--op--bop.t | 1 - t/C-COMPILED/CORE--op--caller.t | 1 - t/C-COMPILED/CORE--op--chars.t | 1 - t/C-COMPILED/CORE--op--chdir.t | 1 - t/C-COMPILED/CORE--op--chop.t | 1 - t/C-COMPILED/CORE--op--chr.t | 1 - t/C-COMPILED/CORE--op--closure.t | 1 - t/C-COMPILED/CORE--op--cmp.t | 1 - t/C-COMPILED/CORE--op--concat.t | 1 - t/C-COMPILED/CORE--op--concat2.t | 1 - t/C-COMPILED/CORE--op--cond.t | 1 - t/C-COMPILED/CORE--op--context.t | 1 - t/C-COMPILED/CORE--op--cproto.t | 1 - t/C-COMPILED/CORE--op--crypt.t | 1 - t/C-COMPILED/CORE--op--dbm.t | 1 - t/C-COMPILED/CORE--op--defins.t | 1 - t/C-COMPILED/CORE--op--delete.t | 1 - t/C-COMPILED/CORE--op--die.t | 1 - t/C-COMPILED/CORE--op--die_except.t | 1 - t/C-COMPILED/CORE--op--die_exit.t | 1 - t/C-COMPILED/CORE--op--die_keeperr.t | 1 - t/C-COMPILED/CORE--op--die_unwind.t | 1 - t/C-COMPILED/CORE--op--do.t | 1 - t/C-COMPILED/CORE--op--dor.t | 1 - t/C-COMPILED/CORE--op--each.t | 1 - t/C-COMPILED/CORE--op--each_array.t | 1 - t/C-COMPILED/CORE--op--eval.t | 1 - t/C-COMPILED/CORE--op--exec.t | 1 - .../CORE--op--exists_sub==BADTEST-251.t | 1 - t/C-COMPILED/CORE--op--exp.t | 1 - t/C-COMPILED/CORE--op--fh.t | 1 - t/C-COMPILED/CORE--op--filehandle.t | 1 - t/C-COMPILED/CORE--op--filetest.t | 1 - t/C-COMPILED/CORE--op--filetest_stack_ok.t | 1 - t/C-COMPILED/CORE--op--filetest_t.t | 1 - t/C-COMPILED/CORE--op--flip.t | 1 - t/C-COMPILED/CORE--op--fork.t | 1 - t/C-COMPILED/CORE--op--getpid.t | 1 - t/C-COMPILED/CORE--op--getppid.t | 1 - t/C-COMPILED/CORE--op--gmagic.t | 1 - t/C-COMPILED/CORE--op--goto.t | 1 - t/C-COMPILED/CORE--op--grent.t | 1 - t/C-COMPILED/CORE--op--grep.t | 1 - t/C-COMPILED/CORE--op--groups.t | 1 - t/C-COMPILED/CORE--op--gv.t | 1 - t/C-COMPILED/CORE--op--hash.t | 1 - t/C-COMPILED/CORE--op--hashassign.t | 1 - t/C-COMPILED/CORE--op--hashwarn.t | 1 - t/C-COMPILED/CORE--op--inc.t | 1 - t/C-COMPILED/CORE--op--inccode-tie.t | 1 - t/C-COMPILED/CORE--op--inccode.t | 1 - t/C-COMPILED/CORE--op--incfilter.t | 1 - t/C-COMPILED/CORE--op--index==BADTEST-247.t | 1 - t/C-COMPILED/CORE--op--int.t | 1 - t/C-COMPILED/CORE--op--join.t | 1 - t/C-COMPILED/CORE--op--kill0.t | 1 - t/C-COMPILED/CORE--op--lc.t | 1 - t/C-COMPILED/CORE--op--lc_user.t | 1 - t/C-COMPILED/CORE--op--leaky-magic.t | 1 - t/C-COMPILED/CORE--op--length.t | 1 - t/C-COMPILED/CORE--op--lex.t | 1 - t/C-COMPILED/CORE--op--lex_assign.t | 1 - t/C-COMPILED/CORE--op--lfs.t | 1 - t/C-COMPILED/CORE--op--list.t | 1 - t/C-COMPILED/CORE--op--local.t | 1 - t/C-COMPILED/CORE--op--localref.t | 1 - t/C-COMPILED/CORE--op--loopctl.t | 1 - t/C-COMPILED/CORE--op--lop.t | 1 - t/C-COMPILED/CORE--op--magic-27839.t | 1 - t/C-COMPILED/CORE--op--magic.t | 1 - t/C-COMPILED/CORE--op--magic_phase.t | 1 - t/C-COMPILED/CORE--op--method.t | 1 - t/C-COMPILED/CORE--op--mkdir.t | 1 - t/C-COMPILED/CORE--op--my.t | 1 - t/C-COMPILED/CORE--op--my_stash.t | 1 - t/C-COMPILED/CORE--op--mydef.t | 1 - t/C-COMPILED/CORE--op--negate.t | 1 - t/C-COMPILED/CORE--op--not.t | 1 - t/C-COMPILED/CORE--op--numconvert.t | 1 - t/C-COMPILED/CORE--op--oct.t | 1 - t/C-COMPILED/CORE--op--or.t | 1 - t/C-COMPILED/CORE--op--ord.t | 1 - t/C-COMPILED/CORE--op--overload_integer.t | 1 - t/C-COMPILED/CORE--op--override.t | 1 - t/C-COMPILED/CORE--op--pack.t | 1 - .../CORE--op--packagev==BADTEST-249.t | 1 - t/C-COMPILED/CORE--op--pos.t | 1 - t/C-COMPILED/CORE--op--pow.t | 1 - t/C-COMPILED/CORE--op--print.t | 1 - t/C-COMPILED/CORE--op--protowarn.t | 1 - t/C-COMPILED/CORE--op--push.t | 1 - t/C-COMPILED/CORE--op--pwent.t | 1 - t/C-COMPILED/CORE--op--qq.t | 1 - t/C-COMPILED/CORE--op--qr.t | 1 - t/C-COMPILED/CORE--op--quotemeta.t | 1 - t/C-COMPILED/CORE--op--rand.t | 1 - t/C-COMPILED/CORE--op--range.t | 1 - t/C-COMPILED/CORE--op--read.t | 1 - t/C-COMPILED/CORE--op--readdir.t | 1 - t/C-COMPILED/CORE--op--readline.t | 1 - t/C-COMPILED/CORE--op--recurse.t | 1 - .../CORE--op--ref==BADTEST-197-285-286.t | 1 - t/C-COMPILED/CORE--op--repeat.t | 1 - t/C-COMPILED/CORE--op--require_errors.t | 1 - t/C-COMPILED/CORE--op--reset.t | 1 - t/C-COMPILED/CORE--op--reverse.t | 1 - t/C-COMPILED/CORE--op--runlevel.t | 1 - t/C-COMPILED/CORE--op--setpgrpstack.t | 1 - t/C-COMPILED/CORE--op--sigdispatch.t | 1 - t/C-COMPILED/CORE--op--sleep.t | 1 - t/C-COMPILED/CORE--op--smartkve.t | 1 - .../CORE--op--smartmatch==BADTEST-179.t | 1 - t/C-COMPILED/CORE--op--sort.t | 1 - t/C-COMPILED/CORE--op--splice.t | 1 - t/C-COMPILED/CORE--op--split.t | 1 - t/C-COMPILED/CORE--op--split_unicode.t | 1 - t/C-COMPILED/CORE--op--sprintf.t | 1 - t/C-COMPILED/CORE--op--sprintf2.t | 1 - t/C-COMPILED/CORE--op--srand.t | 1 - t/C-COMPILED/CORE--op--sselect.t | 1 - t/C-COMPILED/CORE--op--stash.t | 1 - t/C-COMPILED/CORE--op--stat.t | 1 - t/C-COMPILED/CORE--op--state.t | 1 - t/C-COMPILED/CORE--op--study.t | 1 - t/C-COMPILED/CORE--op--studytied.t | 1 - t/C-COMPILED/CORE--op--sub.t | 1 - t/C-COMPILED/CORE--op--sub_lval.t | 1 - t/C-COMPILED/CORE--op--svleak.t | 1 - t/C-COMPILED/CORE--op--switch==BADTEST-180.t | 1 - t/C-COMPILED/CORE--op--symbolcache.t | 1 - t/C-COMPILED/CORE--op--sysio.t | 1 - ...CORE--op--taint==BADPLAN-288+BADTEST-288.t | 1 - t/C-COMPILED/CORE--op--tie.t | 1 - t/C-COMPILED/CORE--op--tie_fetch_count.t | 1 - t/C-COMPILED/CORE--op--tiearray.t | 1 - t/C-COMPILED/CORE--op--tiehandle.t | 1 - t/C-COMPILED/CORE--op--time.t | 1 - t/C-COMPILED/CORE--op--time_loop.t | 1 - t/C-COMPILED/CORE--op--tr.t | 1 - t/C-COMPILED/CORE--op--turkish.t | 1 - t/C-COMPILED/CORE--op--undef.t | 1 - .../CORE--op--universal==BADTEST-299.t | 1 - t/C-COMPILED/CORE--op--unshift.t | 1 - t/C-COMPILED/CORE--op--upgrade.t | 1 - t/C-COMPILED/CORE--op--utf8cache.t | 1 - t/C-COMPILED/CORE--op--utf8decode.t | 1 - t/C-COMPILED/CORE--op--utf8magic.t | 1 - t/C-COMPILED/CORE--op--utfhash.t | 1 - t/C-COMPILED/CORE--op--utftaint.t | 1 - t/C-COMPILED/CORE--op--vec.t | 1 - t/C-COMPILED/CORE--op--ver.t | 1 - t/C-COMPILED/CORE--op--wantarray.t | 1 - t/C-COMPILED/CORE--op--warn.t | 1 - t/C-COMPILED/CORE--op--while_readdir.t | 1 - t/C-COMPILED/CORE--op--write==BADTEST-238.t | 1 - t/C-COMPILED/CORE--op--yadayada.t | 1 - t/C-COMPILED/CORE--re--charset.t | 1 - t/C-COMPILED/CORE--re--fold_grind.t | 1 - t/C-COMPILED/CORE--re--no_utf8_pm.t | 1 - .../CORE--re--overload==BADTEST-335.t | 1 - t/C-COMPILED/CORE--re--pat==BADTEST-274.t | 1 - t/C-COMPILED/CORE--re--pat_advanced.t | 1 - t/C-COMPILED/CORE--re--pat_psycho.t | 1 - t/C-COMPILED/CORE--re--pat_re_eval==SIG-332.t | 1 - t/C-COMPILED/CORE--re--pat_rt_report.t | 1 - t/C-COMPILED/CORE--re--pat_special_cc.t | 1 - t/C-COMPILED/CORE--re--qr-72922.t | 1 - t/C-COMPILED/CORE--re--qr.t | 1 - t/C-COMPILED/CORE--re--qr_gc.t | 1 - t/C-COMPILED/CORE--re--qrstack.t | 1 - t/C-COMPILED/CORE--re--reg_60508.t | 1 - t/C-COMPILED/CORE--re--reg_email.t | 1 - t/C-COMPILED/CORE--re--reg_eval.t | 1 - t/C-COMPILED/CORE--re--reg_eval_scope.t | 1 - t/C-COMPILED/CORE--re--reg_fold.t | 1 - t/C-COMPILED/CORE--re--reg_mesg.t | 1 - t/C-COMPILED/CORE--re--reg_namedcapture.t | 1 - t/C-COMPILED/CORE--re--reg_nc_tie.t | 1 - t/C-COMPILED/CORE--re--reg_pmod.t | 1 - t/C-COMPILED/CORE--re--reg_posixcc.t | 1 - t/C-COMPILED/CORE--re--regexp_unicode_prop.t | 1 - t/C-COMPILED/CORE--re--rxcode.t | 1 - t/C-COMPILED/CORE--re--subst.t | 1 - t/C-COMPILED/CORE--re--subst_amp.t | 1 - t/C-COMPILED/CORE--re--substr.t | 1 - t/C-COMPILED/template.pl | 181 -- t/C-COMPILED/testc.pl | 127 - t/CORE | 1 + t/CORE/CaseFolding.txt | 1211 --------- t/CORE/Cname.pm | 42 - t/CORE/TEST | 809 ------ t/CORE/base/cond.t | 17 - t/CORE/base/if.t | 9 - t/CORE/base/lex.t | 275 --- t/CORE/base/num.t | 211 -- t/CORE/base/pat.t | 9 - t/CORE/base/rs.t | 245 -- t/CORE/base/term.t | 50 - t/CORE/base/while.t | 33 - t/CORE/cmd/elsif.t | 23 - t/CORE/cmd/for.t | 670 ----- t/CORE/cmd/mod.t | 57 - t/CORE/cmd/subval.t | 184 -- t/CORE/cmd/switch.t | 73 - t/CORE/cmd/while.t | 213 -- t/CORE/comp/bproto.t | 43 - t/CORE/comp/cmdopt.t | 88 - t/CORE/comp/colon.t | 135 - t/CORE/comp/decl.t | 61 - t/CORE/comp/fold.t | 120 - t/CORE/comp/form_scope.t | 18 - t/CORE/comp/hints.aux | 4 - t/CORE/comp/hints.t | 286 --- t/CORE/comp/line_debug.t | 30 - t/CORE/comp/line_debug_0.aux | 20 - t/CORE/comp/multiline.t | 90 - t/CORE/comp/opsubs.t | 209 -- t/CORE/comp/our.t | 75 - t/CORE/comp/package.t | 76 - t/CORE/comp/package_block.t | 92 - t/CORE/comp/parser.t | 453 ---- t/CORE/comp/proto.t | 852 ------- t/CORE/comp/redef.t | 86 - t/CORE/comp/require.t | 312 --- t/CORE/comp/retainedlines.t | 161 -- t/CORE/comp/term.t | 72 - t/CORE/comp/uproto.t | 134 - t/CORE/comp/use.t | 265 -- t/CORE/comp/utf.t | 102 - t/CORE/io/argv.t | 140 -- t/CORE/io/binmode.t | 35 - t/CORE/io/bom.t | 13 - t/CORE/io/crlf.t | 74 - t/CORE/io/crlf_through.t | 13 - t/CORE/io/data.t | 80 - t/CORE/io/defout.t | 52 - t/CORE/io/dup.t | 143 -- t/CORE/io/eintr.t | 142 -- t/CORE/io/errno.t | 46 - t/CORE/io/errnosig.t | 29 - t/CORE/io/fflush.t | 131 - t/CORE/io/fs.t | 454 ---- t/CORE/io/inplace.t | 92 - t/CORE/io/iofile.t | 24 - t/CORE/io/iprefix.t | 37 - t/CORE/io/layers.t | 258 -- t/CORE/io/nargv.t | 73 - t/CORE/io/open.t | 357 --- t/CORE/io/openpid.t | 83 - t/CORE/io/perlio.t | 207 -- t/CORE/io/perlio_fail.t | 47 - t/CORE/io/perlio_leaks.t | 33 - t/CORE/io/perlio_open.t | 33 - t/CORE/io/pipe.t | 250 -- t/CORE/io/print.t | 62 - t/CORE/io/pvbm.t | 83 - t/CORE/io/read.t | 31 - t/CORE/io/say.t | 49 - t/CORE/io/tell.t | 161 -- t/CORE/io/through.t | 147 -- t/CORE/io/utf8.t | 347 --- t/CORE/lib/test_use.pm | 11 - t/CORE/lib/test_use_14937.pm | 1 - t/CORE/mro/basic.t | 330 --- t/CORE/mro/basic_01_c3.t | 47 - t/CORE/mro/basic_01_dfs.t | 47 - t/CORE/mro/basic_02_c3.t | 115 - t/CORE/mro/basic_02_dfs.t | 115 - t/CORE/mro/basic_03_c3.t | 101 - t/CORE/mro/basic_03_dfs.t | 101 - t/CORE/mro/basic_04_c3.t | 34 - t/CORE/mro/basic_04_dfs.t | 34 - t/CORE/mro/basic_05_c3.t | 55 - t/CORE/mro/basic_05_dfs.t | 55 - t/CORE/mro/c3_with_overload.t | 47 - t/CORE/mro/complex_c3.t | 142 -- t/CORE/mro/complex_dfs.t | 137 - t/CORE/mro/dbic_c3.t | 119 - t/CORE/mro/dbic_dfs.t | 119 - t/CORE/mro/inconsistent_c3.t | 46 - t/CORE/mro/isa_aliases.t | 43 - t/CORE/mro/isa_c3.t | 68 - t/CORE/mro/isa_dfs.t | 64 - t/CORE/mro/isarev.t | 149 -- t/CORE/mro/method_caching.t | 59 - t/CORE/mro/next_NEXT.t | 48 - t/CORE/mro/next_edgecases.t | 96 - t/CORE/mro/next_goto.t | 35 - t/CORE/mro/next_inanon.t | 57 - t/CORE/mro/next_ineval.t | 44 - t/CORE/mro/next_method.t | 65 - t/CORE/mro/next_skip.t | 75 - t/CORE/mro/overload_c3.t | 51 - t/CORE/mro/overload_dfs.t | 51 - t/CORE/mro/package_aliases.t | 398 --- t/CORE/mro/pkg_gen.t | 41 - t/CORE/mro/recursion_c3.t | 95 - t/CORE/mro/recursion_dfs.t | 82 - t/CORE/mro/vulcan_c3.t | 66 - t/CORE/mro/vulcan_dfs.t | 66 - t/CORE/op/64bitint.t | 367 --- t/CORE/op/alarm.t | 61 - t/CORE/op/anonsub.t | 85 - t/CORE/op/append.t | 72 - t/CORE/op/args.t | 106 - t/CORE/op/arith.t | 325 --- t/CORE/op/array.t | 455 ---- t/CORE/op/array_base.aux | 5 - t/CORE/op/array_base.t | 82 - t/CORE/op/assignwarn.t | 68 - t/CORE/op/attrhand.t | 63 - t/CORE/op/attrs.t | 329 --- t/CORE/op/auto.t | 56 - t/CORE/op/avhv.t | 283 --- t/CORE/op/bless.t | 143 -- t/CORE/op/bop.t | 558 ----- t/CORE/op/caller.pl | 175 -- t/CORE/op/caller.t | 240 -- t/CORE/op/chars.t | 74 - t/CORE/op/chdir.t | 232 -- t/CORE/op/chop.t | 264 -- t/CORE/op/chr.t | 64 - t/CORE/op/closure.t | 691 ------ t/CORE/op/cmp.t | 317 --- t/CORE/op/concat.t | 162 -- t/CORE/op/concat2.t | 20 - t/CORE/op/cond.t | 10 - t/CORE/op/context.t | 26 - t/CORE/op/cproto.t | 265 -- t/CORE/op/crypt.t | 33 - t/CORE/op/dbm.t | 73 - t/CORE/op/defins.t | 160 -- t/CORE/op/delete.t | 142 -- t/CORE/op/die.t | 74 - t/CORE/op/die_except.t | 81 - t/CORE/op/die_exit.t | 83 - t/CORE/op/die_keeperr.t | 43 - t/CORE/op/die_unwind.t | 73 - t/CORE/op/do.t | 201 -- t/CORE/op/dor.t | 72 - t/CORE/op/each.t | 239 -- t/CORE/op/each_array.t | 101 - t/CORE/op/eval.t | 564 ----- t/CORE/op/exec.t | 145 -- t/CORE/op/exists_sub.t | 45 - t/CORE/op/exp.t | 58 - t/CORE/op/fh.t | 28 - t/CORE/op/filehandle.t | 24 - t/CORE/op/filetest.t | 201 -- t/CORE/op/filetest_stack_ok.t | 45 - t/CORE/op/filetest_t.t | 30 - t/CORE/op/flip.t | 65 - t/CORE/op/fork.t | 484 ---- t/CORE/op/getpid.t | 26 - t/CORE/op/getppid.t | 68 - t/CORE/op/gmagic.t | 103 - t/CORE/op/goto.t | 597 ----- t/CORE/op/grent.t | 187 -- t/CORE/op/grep.t | 215 -- t/CORE/op/groups.t | 407 --- t/CORE/op/gv.t | 909 ------- t/CORE/op/hash.t | 157 -- t/CORE/op/hashassign.t | 322 --- t/CORE/op/hashwarn.t | 69 - t/CORE/op/inc.t | 271 -- t/CORE/op/inccode-tie.t | 15 - t/CORE/op/inccode.t | 304 --- t/CORE/op/incfilter.t | 244 -- t/CORE/op/index.t | 226 -- t/CORE/op/int.t | 68 - t/CORE/op/join.t | 113 - t/CORE/op/kill0.t | 51 - t/CORE/op/lc.t | 207 -- t/CORE/op/lc_user.t | 32 - t/CORE/op/leaky-magic.t | 137 - t/CORE/op/length.t | 236 -- t/CORE/op/lex.t | 47 - t/CORE/op/lex_assign.t | 353 --- t/CORE/op/lfs.t | 239 -- t/CORE/op/list.t | 176 -- t/CORE/op/local.t | 801 ------ t/CORE/op/localref.t | 98 - t/CORE/op/loopctl.t | 995 -------- t/CORE/op/lop.t | 64 - t/CORE/op/magic-27839.t | 40 - t/CORE/op/magic.t | 569 ----- t/CORE/op/magic_phase.t | 61 - t/CORE/op/method.t | 327 --- t/CORE/op/mkdir.t | 56 - t/CORE/op/my.t | 132 - t/CORE/op/my_stash.t | 31 - t/CORE/op/mydef.t | 217 -- t/CORE/op/negate.t | 30 - t/CORE/op/not.t | 48 - t/CORE/op/numconvert.t | 262 -- t/CORE/op/oct.t | 137 - t/CORE/op/or.t | 67 - t/CORE/op/ord.t | 68 - t/CORE/op/overload_integer.t | 55 - t/CORE/op/override.t | 135 - t/CORE/op/pack.t | 2000 --------------- t/CORE/op/packagev.t | 189 -- t/CORE/op/pos.t | 48 - t/CORE/op/pow.t | 71 - t/CORE/op/print.t | 12 - t/CORE/op/protowarn.t | 86 - t/CORE/op/push.t | 124 - t/CORE/op/pwent.t | 241 -- t/CORE/op/qq.t | 72 - t/CORE/op/qr.t | 58 - t/CORE/op/quotemeta.t | 54 - t/CORE/op/rand.t | 243 -- t/CORE/op/range.t | 418 ---- t/CORE/op/read.t | 95 - t/CORE/op/readdir.t | 258 -- t/CORE/op/readline.t | 247 -- t/CORE/op/recurse.t | 145 -- t/CORE/op/ref.t | 768 ------ t/CORE/op/repeat.t | 155 -- t/CORE/op/require_errors.t | 35 - t/CORE/op/reset.t | 135 - t/CORE/op/reverse.t | 104 - t/CORE/op/runlevel.t | 367 --- t/CORE/op/setpgrpstack.t | 15 - t/CORE/op/sigdispatch.t | 122 - t/CORE/op/sleep.t | 21 - t/CORE/op/smartkve.t | 414 ---- t/CORE/op/smartmatch.t | 518 ---- t/CORE/op/sort.t | 937 ------- t/CORE/op/splice.t | 99 - t/CORE/op/split.t | 418 ---- t/CORE/op/split_unicode.t | 64 - t/CORE/op/sprintf.t | 711 ------ t/CORE/op/sprintf2.t | 181 -- t/CORE/op/srand.t | 80 - t/CORE/op/sselect.t | 45 - t/CORE/op/stash.t | 319 --- t/CORE/op/stat.t | 567 ----- t/CORE/op/state.t | 417 ---- t/CORE/op/study.t | 86 - t/CORE/op/studytied.t | 50 - t/CORE/op/sub.t | 42 - t/CORE/op/sub_lval.t | 601 ----- t/CORE/op/svleak.t | 141 -- t/CORE/op/switch.t | 1203 --------- t/CORE/op/symbolcache.t | 45 - t/CORE/op/sysio.t | 243 -- t/CORE/op/taint.t | 2198 ----------------- t/CORE/op/tie.t | 1031 -------- t/CORE/op/tie_fetch_count.t | 260 -- t/CORE/op/tiearray.t | 299 --- t/CORE/op/tiehandle.t | 302 --- t/CORE/op/time.t | 236 -- t/CORE/op/time_loop.t | 16 - t/CORE/op/tr.t | 506 ---- t/CORE/op/turkish.t | 99 - t/CORE/op/undef.t | 131 - t/CORE/op/universal.t | 316 --- t/CORE/op/unshift.t | 101 - t/CORE/op/upgrade.t | 49 - t/CORE/op/utf8cache.t | 35 - t/CORE/op/utf8decode.t | 182 -- t/CORE/op/utf8magic.t | 24 - t/CORE/op/utfhash.t | 220 -- t/CORE/op/utftaint.t | 150 -- t/CORE/op/vec.t | 108 - t/CORE/op/ver.t | 274 -- t/CORE/op/wantarray.t | 53 - t/CORE/op/warn.t | 150 -- t/CORE/op/while_readdir.t | 179 -- t/CORE/op/write.t | 812 ------ t/CORE/op/yadayada.t | 49 - t/CORE/re/charset.t | 273 -- t/CORE/re/fold_grind.t | 610 ----- t/CORE/re/no_utf8_pm.t | 12 - t/CORE/re/overload.t | 34 - t/CORE/re/pat.t | 1193 --------- t/CORE/re/pat_advanced.t | 2127 ---------------- t/CORE/re/pat_psycho.t | 161 -- t/CORE/re/pat_re_eval.t | 344 --- t/CORE/re/pat_rt_report.t | 1145 --------- t/CORE/re/pat_special_cc.t | 55 - t/CORE/re/qr-72922.t | 37 - t/CORE/re/qr.t | 81 - t/CORE/re/qr_gc.t | 30 - t/CORE/re/qrstack.t | 9 - t/CORE/re/re_tests | 1535 ------------ t/CORE/re/reg_60508.t | 38 - t/CORE/re/reg_email.t | 102 - t/CORE/re/reg_eval.t | 85 - t/CORE/re/reg_eval_scope.t | 155 -- t/CORE/re/reg_fold.t | 127 - t/CORE/re/reg_mesg.t | 147 -- t/CORE/re/reg_namedcapture.t | 21 - t/CORE/re/reg_nc_tie.t | 83 - t/CORE/re/reg_pmod.t | 47 - t/CORE/re/reg_posixcc.t | 149 -- t/CORE/re/regexp_unicode_prop.t | 355 --- t/CORE/re/rxcode.t | 87 - t/CORE/re/subst.t | 758 ------ t/CORE/re/subst_amp.t | 96 - t/CORE/re/substr.t | 748 ------ t/CORE/test.pl | 1534 ------------ t/core-init.sh | 25 + t/coreall.sh | 3 +- t/testc.sh | 9 +- 628 files changed, 53 insertions(+), 68048 deletions(-) create mode 100644 .gitmodules delete mode 120000 t/C-COMPILED/CORE--base--cond.t delete mode 120000 t/C-COMPILED/CORE--base--if.t delete mode 120000 t/C-COMPILED/CORE--base--lex.t delete mode 120000 t/C-COMPILED/CORE--base--num.t delete mode 120000 t/C-COMPILED/CORE--base--pat.t delete mode 120000 t/C-COMPILED/CORE--base--rs.t delete mode 120000 t/C-COMPILED/CORE--base--term.t delete mode 120000 t/C-COMPILED/CORE--base--while.t delete mode 120000 t/C-COMPILED/CORE--cmd--elsif.t delete mode 120000 t/C-COMPILED/CORE--cmd--for.t delete mode 120000 t/C-COMPILED/CORE--cmd--mod.t delete mode 120000 t/C-COMPILED/CORE--cmd--subval.t delete mode 120000 t/C-COMPILED/CORE--cmd--switch.t delete mode 120000 t/C-COMPILED/CORE--cmd--while.t delete mode 120000 t/C-COMPILED/CORE--comp--bproto.t delete mode 120000 t/C-COMPILED/CORE--comp--cmdopt.t delete mode 120000 t/C-COMPILED/CORE--comp--colon.t delete mode 120000 t/C-COMPILED/CORE--comp--decl.t delete mode 120000 t/C-COMPILED/CORE--comp--fold.t delete mode 120000 t/C-COMPILED/CORE--comp--form_scope.t delete mode 120000 t/C-COMPILED/CORE--comp--line_debug.t delete mode 120000 t/C-COMPILED/CORE--comp--multiline.t delete mode 120000 t/C-COMPILED/CORE--comp--opsubs.t delete mode 120000 t/C-COMPILED/CORE--comp--our.t delete mode 120000 t/C-COMPILED/CORE--comp--package.t delete mode 120000 t/C-COMPILED/CORE--comp--package_block.t delete mode 120000 t/C-COMPILED/CORE--comp--parser.t delete mode 120000 t/C-COMPILED/CORE--comp--proto.t delete mode 120000 t/C-COMPILED/CORE--comp--redef.t delete mode 120000 t/C-COMPILED/CORE--comp--require.t delete mode 120000 t/C-COMPILED/CORE--comp--retainedlines.t delete mode 120000 t/C-COMPILED/CORE--comp--term.t delete mode 120000 t/C-COMPILED/CORE--comp--uproto.t delete mode 120000 t/C-COMPILED/CORE--comp--use.t delete mode 120000 t/C-COMPILED/CORE--comp--utf.t delete mode 120000 t/C-COMPILED/CORE--io--argv.t delete mode 120000 t/C-COMPILED/CORE--io--binmode.t delete mode 120000 t/C-COMPILED/CORE--io--bom.t delete mode 120000 t/C-COMPILED/CORE--io--crlf.t delete mode 120000 t/C-COMPILED/CORE--io--crlf_through.t delete mode 120000 t/C-COMPILED/CORE--io--data.t delete mode 120000 t/C-COMPILED/CORE--io--defout.t delete mode 120000 t/C-COMPILED/CORE--io--dup.t delete mode 120000 t/C-COMPILED/CORE--io--eintr.t delete mode 120000 t/C-COMPILED/CORE--io--errno.t delete mode 120000 t/C-COMPILED/CORE--io--errnosig.t delete mode 120000 t/C-COMPILED/CORE--io--fflush.t delete mode 120000 t/C-COMPILED/CORE--io--fs.t delete mode 120000 t/C-COMPILED/CORE--io--inplace.t delete mode 120000 t/C-COMPILED/CORE--io--iofile.t delete mode 120000 t/C-COMPILED/CORE--io--iprefix.t delete mode 120000 t/C-COMPILED/CORE--io--layers==BADTEST-203.t delete mode 120000 t/C-COMPILED/CORE--io--nargv.t delete mode 120000 t/C-COMPILED/CORE--io--open.t delete mode 120000 t/C-COMPILED/CORE--io--openpid.t delete mode 120000 t/C-COMPILED/CORE--io--perlio.t delete mode 120000 t/C-COMPILED/CORE--io--perlio_fail.t delete mode 120000 t/C-COMPILED/CORE--io--perlio_leaks.t delete mode 120000 t/C-COMPILED/CORE--io--perlio_open.t delete mode 120000 t/C-COMPILED/CORE--io--pipe.t delete mode 120000 t/C-COMPILED/CORE--io--print.t delete mode 120000 t/C-COMPILED/CORE--io--pvbm.t delete mode 120000 t/C-COMPILED/CORE--io--read.t delete mode 120000 t/C-COMPILED/CORE--io--say.t delete mode 120000 t/C-COMPILED/CORE--io--tell.t delete mode 120000 t/C-COMPILED/CORE--io--through.t delete mode 120000 t/C-COMPILED/CORE--io--utf8==BADTEST-319.t delete mode 120000 t/C-COMPILED/CORE--mro--basic.t delete mode 120000 t/C-COMPILED/CORE--mro--basic_01_c3.t delete mode 120000 t/C-COMPILED/CORE--mro--basic_01_dfs.t delete mode 120000 t/C-COMPILED/CORE--mro--basic_02_c3.t delete mode 120000 t/C-COMPILED/CORE--mro--basic_02_dfs.t delete mode 120000 t/C-COMPILED/CORE--mro--basic_03_c3.t delete mode 120000 t/C-COMPILED/CORE--mro--basic_03_dfs.t delete mode 120000 t/C-COMPILED/CORE--mro--basic_04_c3.t delete mode 120000 t/C-COMPILED/CORE--mro--basic_04_dfs.t delete mode 120000 t/C-COMPILED/CORE--mro--basic_05_c3.t delete mode 120000 t/C-COMPILED/CORE--mro--basic_05_dfs.t delete mode 120000 t/C-COMPILED/CORE--mro--c3_with_overload.t delete mode 120000 t/C-COMPILED/CORE--mro--complex_c3.t delete mode 120000 t/C-COMPILED/CORE--mro--complex_dfs.t delete mode 120000 t/C-COMPILED/CORE--mro--dbic_c3.t delete mode 120000 t/C-COMPILED/CORE--mro--dbic_dfs.t delete mode 120000 t/C-COMPILED/CORE--mro--inconsistent_c3.t delete mode 120000 t/C-COMPILED/CORE--mro--isa_aliases.t delete mode 120000 t/C-COMPILED/CORE--mro--isa_c3.t delete mode 120000 t/C-COMPILED/CORE--mro--isa_dfs.t delete mode 120000 t/C-COMPILED/CORE--mro--isarev==BADTEST-353.t delete mode 120000 t/C-COMPILED/CORE--mro--method_caching.t delete mode 120000 t/C-COMPILED/CORE--mro--next_NEXT.t delete mode 120000 t/C-COMPILED/CORE--mro--next_edgecases.t delete mode 120000 t/C-COMPILED/CORE--mro--next_goto.t delete mode 120000 t/C-COMPILED/CORE--mro--next_inanon.t delete mode 120000 t/C-COMPILED/CORE--mro--next_ineval.t delete mode 120000 t/C-COMPILED/CORE--mro--next_method.t delete mode 120000 t/C-COMPILED/CORE--mro--next_skip.t delete mode 120000 t/C-COMPILED/CORE--mro--overload_c3.t delete mode 120000 t/C-COMPILED/CORE--mro--overload_dfs.t delete mode 120000 t/C-COMPILED/CORE--mro--package_aliases.t delete mode 120000 t/C-COMPILED/CORE--mro--pkg_gen.t delete mode 120000 t/C-COMPILED/CORE--mro--recursion_c3.t delete mode 120000 t/C-COMPILED/CORE--mro--recursion_dfs.t delete mode 120000 t/C-COMPILED/CORE--mro--vulcan_c3.t delete mode 120000 t/C-COMPILED/CORE--mro--vulcan_dfs.t delete mode 120000 t/C-COMPILED/CORE--op--64bitint.t delete mode 120000 t/C-COMPILED/CORE--op--alarm.t delete mode 120000 t/C-COMPILED/CORE--op--anonsub.t delete mode 120000 t/C-COMPILED/CORE--op--append.t delete mode 120000 t/C-COMPILED/CORE--op--args.t delete mode 120000 t/C-COMPILED/CORE--op--arith.t delete mode 120000 t/C-COMPILED/CORE--op--array.t delete mode 120000 t/C-COMPILED/CORE--op--array_base.t delete mode 120000 t/C-COMPILED/CORE--op--assignwarn.t delete mode 120000 t/C-COMPILED/CORE--op--attrhand==BADPLAN-169.t delete mode 120000 t/C-COMPILED/CORE--op--attrs.t delete mode 120000 t/C-COMPILED/CORE--op--auto.t delete mode 120000 t/C-COMPILED/CORE--op--avhv.t delete mode 120000 t/C-COMPILED/CORE--op--bless.t delete mode 120000 t/C-COMPILED/CORE--op--bop.t delete mode 120000 t/C-COMPILED/CORE--op--caller.t delete mode 120000 t/C-COMPILED/CORE--op--chars.t delete mode 120000 t/C-COMPILED/CORE--op--chdir.t delete mode 120000 t/C-COMPILED/CORE--op--chop.t delete mode 120000 t/C-COMPILED/CORE--op--chr.t delete mode 120000 t/C-COMPILED/CORE--op--closure.t delete mode 120000 t/C-COMPILED/CORE--op--cmp.t delete mode 120000 t/C-COMPILED/CORE--op--concat.t delete mode 120000 t/C-COMPILED/CORE--op--concat2.t delete mode 120000 t/C-COMPILED/CORE--op--cond.t delete mode 120000 t/C-COMPILED/CORE--op--context.t delete mode 120000 t/C-COMPILED/CORE--op--cproto.t delete mode 120000 t/C-COMPILED/CORE--op--crypt.t delete mode 120000 t/C-COMPILED/CORE--op--dbm.t delete mode 120000 t/C-COMPILED/CORE--op--defins.t delete mode 120000 t/C-COMPILED/CORE--op--delete.t delete mode 120000 t/C-COMPILED/CORE--op--die.t delete mode 120000 t/C-COMPILED/CORE--op--die_except.t delete mode 120000 t/C-COMPILED/CORE--op--die_exit.t delete mode 120000 t/C-COMPILED/CORE--op--die_keeperr.t delete mode 120000 t/C-COMPILED/CORE--op--die_unwind.t delete mode 120000 t/C-COMPILED/CORE--op--do.t delete mode 120000 t/C-COMPILED/CORE--op--dor.t delete mode 120000 t/C-COMPILED/CORE--op--each.t delete mode 120000 t/C-COMPILED/CORE--op--each_array.t delete mode 120000 t/C-COMPILED/CORE--op--eval.t delete mode 120000 t/C-COMPILED/CORE--op--exec.t delete mode 120000 t/C-COMPILED/CORE--op--exists_sub==BADTEST-251.t delete mode 120000 t/C-COMPILED/CORE--op--exp.t delete mode 120000 t/C-COMPILED/CORE--op--fh.t delete mode 120000 t/C-COMPILED/CORE--op--filehandle.t delete mode 120000 t/C-COMPILED/CORE--op--filetest.t delete mode 120000 t/C-COMPILED/CORE--op--filetest_stack_ok.t delete mode 120000 t/C-COMPILED/CORE--op--filetest_t.t delete mode 120000 t/C-COMPILED/CORE--op--flip.t delete mode 120000 t/C-COMPILED/CORE--op--fork.t delete mode 120000 t/C-COMPILED/CORE--op--getpid.t delete mode 120000 t/C-COMPILED/CORE--op--getppid.t delete mode 120000 t/C-COMPILED/CORE--op--gmagic.t delete mode 120000 t/C-COMPILED/CORE--op--goto.t delete mode 120000 t/C-COMPILED/CORE--op--grent.t delete mode 120000 t/C-COMPILED/CORE--op--grep.t delete mode 120000 t/C-COMPILED/CORE--op--groups.t delete mode 120000 t/C-COMPILED/CORE--op--gv.t delete mode 120000 t/C-COMPILED/CORE--op--hash.t delete mode 120000 t/C-COMPILED/CORE--op--hashassign.t delete mode 120000 t/C-COMPILED/CORE--op--hashwarn.t delete mode 120000 t/C-COMPILED/CORE--op--inc.t delete mode 120000 t/C-COMPILED/CORE--op--inccode-tie.t delete mode 120000 t/C-COMPILED/CORE--op--inccode.t delete mode 120000 t/C-COMPILED/CORE--op--incfilter.t delete mode 120000 t/C-COMPILED/CORE--op--index==BADTEST-247.t delete mode 120000 t/C-COMPILED/CORE--op--int.t delete mode 120000 t/C-COMPILED/CORE--op--join.t delete mode 120000 t/C-COMPILED/CORE--op--kill0.t delete mode 120000 t/C-COMPILED/CORE--op--lc.t delete mode 120000 t/C-COMPILED/CORE--op--lc_user.t delete mode 120000 t/C-COMPILED/CORE--op--leaky-magic.t delete mode 120000 t/C-COMPILED/CORE--op--length.t delete mode 120000 t/C-COMPILED/CORE--op--lex.t delete mode 120000 t/C-COMPILED/CORE--op--lex_assign.t delete mode 120000 t/C-COMPILED/CORE--op--lfs.t delete mode 120000 t/C-COMPILED/CORE--op--list.t delete mode 120000 t/C-COMPILED/CORE--op--local.t delete mode 120000 t/C-COMPILED/CORE--op--localref.t delete mode 120000 t/C-COMPILED/CORE--op--loopctl.t delete mode 120000 t/C-COMPILED/CORE--op--lop.t delete mode 120000 t/C-COMPILED/CORE--op--magic-27839.t delete mode 120000 t/C-COMPILED/CORE--op--magic.t delete mode 120000 t/C-COMPILED/CORE--op--magic_phase.t delete mode 120000 t/C-COMPILED/CORE--op--method.t delete mode 120000 t/C-COMPILED/CORE--op--mkdir.t delete mode 120000 t/C-COMPILED/CORE--op--my.t delete mode 120000 t/C-COMPILED/CORE--op--my_stash.t delete mode 120000 t/C-COMPILED/CORE--op--mydef.t delete mode 120000 t/C-COMPILED/CORE--op--negate.t delete mode 120000 t/C-COMPILED/CORE--op--not.t delete mode 120000 t/C-COMPILED/CORE--op--numconvert.t delete mode 120000 t/C-COMPILED/CORE--op--oct.t delete mode 120000 t/C-COMPILED/CORE--op--or.t delete mode 120000 t/C-COMPILED/CORE--op--ord.t delete mode 120000 t/C-COMPILED/CORE--op--overload_integer.t delete mode 120000 t/C-COMPILED/CORE--op--override.t delete mode 120000 t/C-COMPILED/CORE--op--pack.t delete mode 120000 t/C-COMPILED/CORE--op--packagev==BADTEST-249.t delete mode 120000 t/C-COMPILED/CORE--op--pos.t delete mode 120000 t/C-COMPILED/CORE--op--pow.t delete mode 120000 t/C-COMPILED/CORE--op--print.t delete mode 120000 t/C-COMPILED/CORE--op--protowarn.t delete mode 120000 t/C-COMPILED/CORE--op--push.t delete mode 120000 t/C-COMPILED/CORE--op--pwent.t delete mode 120000 t/C-COMPILED/CORE--op--qq.t delete mode 120000 t/C-COMPILED/CORE--op--qr.t delete mode 120000 t/C-COMPILED/CORE--op--quotemeta.t delete mode 120000 t/C-COMPILED/CORE--op--rand.t delete mode 120000 t/C-COMPILED/CORE--op--range.t delete mode 120000 t/C-COMPILED/CORE--op--read.t delete mode 120000 t/C-COMPILED/CORE--op--readdir.t delete mode 120000 t/C-COMPILED/CORE--op--readline.t delete mode 120000 t/C-COMPILED/CORE--op--recurse.t delete mode 120000 t/C-COMPILED/CORE--op--ref==BADTEST-197-285-286.t delete mode 120000 t/C-COMPILED/CORE--op--repeat.t delete mode 120000 t/C-COMPILED/CORE--op--require_errors.t delete mode 120000 t/C-COMPILED/CORE--op--reset.t delete mode 120000 t/C-COMPILED/CORE--op--reverse.t delete mode 120000 t/C-COMPILED/CORE--op--runlevel.t delete mode 120000 t/C-COMPILED/CORE--op--setpgrpstack.t delete mode 120000 t/C-COMPILED/CORE--op--sigdispatch.t delete mode 120000 t/C-COMPILED/CORE--op--sleep.t delete mode 120000 t/C-COMPILED/CORE--op--smartkve.t delete mode 120000 t/C-COMPILED/CORE--op--smartmatch==BADTEST-179.t delete mode 120000 t/C-COMPILED/CORE--op--sort.t delete mode 120000 t/C-COMPILED/CORE--op--splice.t delete mode 120000 t/C-COMPILED/CORE--op--split.t delete mode 120000 t/C-COMPILED/CORE--op--split_unicode.t delete mode 120000 t/C-COMPILED/CORE--op--sprintf.t delete mode 120000 t/C-COMPILED/CORE--op--sprintf2.t delete mode 120000 t/C-COMPILED/CORE--op--srand.t delete mode 120000 t/C-COMPILED/CORE--op--sselect.t delete mode 120000 t/C-COMPILED/CORE--op--stash.t delete mode 120000 t/C-COMPILED/CORE--op--stat.t delete mode 120000 t/C-COMPILED/CORE--op--state.t delete mode 120000 t/C-COMPILED/CORE--op--study.t delete mode 120000 t/C-COMPILED/CORE--op--studytied.t delete mode 120000 t/C-COMPILED/CORE--op--sub.t delete mode 120000 t/C-COMPILED/CORE--op--sub_lval.t delete mode 120000 t/C-COMPILED/CORE--op--svleak.t delete mode 120000 t/C-COMPILED/CORE--op--switch==BADTEST-180.t delete mode 120000 t/C-COMPILED/CORE--op--symbolcache.t delete mode 120000 t/C-COMPILED/CORE--op--sysio.t delete mode 120000 t/C-COMPILED/CORE--op--taint==BADPLAN-288+BADTEST-288.t delete mode 120000 t/C-COMPILED/CORE--op--tie.t delete mode 120000 t/C-COMPILED/CORE--op--tie_fetch_count.t delete mode 120000 t/C-COMPILED/CORE--op--tiearray.t delete mode 120000 t/C-COMPILED/CORE--op--tiehandle.t delete mode 120000 t/C-COMPILED/CORE--op--time.t delete mode 120000 t/C-COMPILED/CORE--op--time_loop.t delete mode 120000 t/C-COMPILED/CORE--op--tr.t delete mode 120000 t/C-COMPILED/CORE--op--turkish.t delete mode 120000 t/C-COMPILED/CORE--op--undef.t delete mode 120000 t/C-COMPILED/CORE--op--universal==BADTEST-299.t delete mode 120000 t/C-COMPILED/CORE--op--unshift.t delete mode 120000 t/C-COMPILED/CORE--op--upgrade.t delete mode 120000 t/C-COMPILED/CORE--op--utf8cache.t delete mode 120000 t/C-COMPILED/CORE--op--utf8decode.t delete mode 120000 t/C-COMPILED/CORE--op--utf8magic.t delete mode 120000 t/C-COMPILED/CORE--op--utfhash.t delete mode 120000 t/C-COMPILED/CORE--op--utftaint.t delete mode 120000 t/C-COMPILED/CORE--op--vec.t delete mode 120000 t/C-COMPILED/CORE--op--ver.t delete mode 120000 t/C-COMPILED/CORE--op--wantarray.t delete mode 120000 t/C-COMPILED/CORE--op--warn.t delete mode 120000 t/C-COMPILED/CORE--op--while_readdir.t delete mode 120000 t/C-COMPILED/CORE--op--write==BADTEST-238.t delete mode 120000 t/C-COMPILED/CORE--op--yadayada.t delete mode 120000 t/C-COMPILED/CORE--re--charset.t delete mode 120000 t/C-COMPILED/CORE--re--fold_grind.t delete mode 120000 t/C-COMPILED/CORE--re--no_utf8_pm.t delete mode 120000 t/C-COMPILED/CORE--re--overload==BADTEST-335.t delete mode 120000 t/C-COMPILED/CORE--re--pat==BADTEST-274.t delete mode 120000 t/C-COMPILED/CORE--re--pat_advanced.t delete mode 120000 t/C-COMPILED/CORE--re--pat_psycho.t delete mode 120000 t/C-COMPILED/CORE--re--pat_re_eval==SIG-332.t delete mode 120000 t/C-COMPILED/CORE--re--pat_rt_report.t delete mode 120000 t/C-COMPILED/CORE--re--pat_special_cc.t delete mode 120000 t/C-COMPILED/CORE--re--qr-72922.t delete mode 120000 t/C-COMPILED/CORE--re--qr.t delete mode 120000 t/C-COMPILED/CORE--re--qr_gc.t delete mode 120000 t/C-COMPILED/CORE--re--qrstack.t delete mode 120000 t/C-COMPILED/CORE--re--reg_60508.t delete mode 120000 t/C-COMPILED/CORE--re--reg_email.t delete mode 120000 t/C-COMPILED/CORE--re--reg_eval.t delete mode 120000 t/C-COMPILED/CORE--re--reg_eval_scope.t delete mode 120000 t/C-COMPILED/CORE--re--reg_fold.t delete mode 120000 t/C-COMPILED/CORE--re--reg_mesg.t delete mode 120000 t/C-COMPILED/CORE--re--reg_namedcapture.t delete mode 120000 t/C-COMPILED/CORE--re--reg_nc_tie.t delete mode 120000 t/C-COMPILED/CORE--re--reg_pmod.t delete mode 120000 t/C-COMPILED/CORE--re--reg_posixcc.t delete mode 120000 t/C-COMPILED/CORE--re--regexp_unicode_prop.t delete mode 120000 t/C-COMPILED/CORE--re--rxcode.t delete mode 120000 t/C-COMPILED/CORE--re--subst.t delete mode 120000 t/C-COMPILED/CORE--re--subst_amp.t delete mode 120000 t/C-COMPILED/CORE--re--substr.t delete mode 100644 t/C-COMPILED/template.pl delete mode 100755 t/C-COMPILED/testc.pl create mode 160000 t/CORE delete mode 100644 t/CORE/CaseFolding.txt delete mode 100644 t/CORE/Cname.pm delete mode 100755 t/CORE/TEST delete mode 100644 t/CORE/base/cond.t delete mode 100644 t/CORE/base/if.t delete mode 100644 t/CORE/base/lex.t delete mode 100644 t/CORE/base/num.t delete mode 100644 t/CORE/base/pat.t delete mode 100644 t/CORE/base/rs.t delete mode 100644 t/CORE/base/term.t delete mode 100644 t/CORE/base/while.t delete mode 100644 t/CORE/cmd/elsif.t delete mode 100644 t/CORE/cmd/for.t delete mode 100644 t/CORE/cmd/mod.t delete mode 100644 t/CORE/cmd/subval.t delete mode 100644 t/CORE/cmd/switch.t delete mode 100644 t/CORE/cmd/while.t delete mode 100644 t/CORE/comp/bproto.t delete mode 100644 t/CORE/comp/cmdopt.t delete mode 100644 t/CORE/comp/colon.t delete mode 100644 t/CORE/comp/decl.t delete mode 100644 t/CORE/comp/fold.t delete mode 100644 t/CORE/comp/form_scope.t delete mode 100644 t/CORE/comp/hints.aux delete mode 100644 t/CORE/comp/hints.t delete mode 100644 t/CORE/comp/line_debug.t delete mode 100644 t/CORE/comp/line_debug_0.aux delete mode 100644 t/CORE/comp/multiline.t delete mode 100644 t/CORE/comp/opsubs.t delete mode 100644 t/CORE/comp/our.t delete mode 100644 t/CORE/comp/package.t delete mode 100644 t/CORE/comp/package_block.t delete mode 100644 t/CORE/comp/parser.t delete mode 100644 t/CORE/comp/proto.t delete mode 100644 t/CORE/comp/redef.t delete mode 100644 t/CORE/comp/require.t delete mode 100644 t/CORE/comp/retainedlines.t delete mode 100644 t/CORE/comp/term.t delete mode 100644 t/CORE/comp/uproto.t delete mode 100644 t/CORE/comp/use.t delete mode 100644 t/CORE/comp/utf.t delete mode 100644 t/CORE/io/argv.t delete mode 100644 t/CORE/io/binmode.t delete mode 100644 t/CORE/io/bom.t delete mode 100644 t/CORE/io/crlf.t delete mode 100644 t/CORE/io/crlf_through.t delete mode 100644 t/CORE/io/data.t delete mode 100644 t/CORE/io/defout.t delete mode 100644 t/CORE/io/dup.t delete mode 100644 t/CORE/io/eintr.t delete mode 100644 t/CORE/io/errno.t delete mode 100644 t/CORE/io/errnosig.t delete mode 100644 t/CORE/io/fflush.t delete mode 100644 t/CORE/io/fs.t delete mode 100644 t/CORE/io/inplace.t delete mode 100644 t/CORE/io/iofile.t delete mode 100644 t/CORE/io/iprefix.t delete mode 100644 t/CORE/io/layers.t delete mode 100644 t/CORE/io/nargv.t delete mode 100644 t/CORE/io/open.t delete mode 100644 t/CORE/io/openpid.t delete mode 100644 t/CORE/io/perlio.t delete mode 100644 t/CORE/io/perlio_fail.t delete mode 100644 t/CORE/io/perlio_leaks.t delete mode 100644 t/CORE/io/perlio_open.t delete mode 100644 t/CORE/io/pipe.t delete mode 100644 t/CORE/io/print.t delete mode 100644 t/CORE/io/pvbm.t delete mode 100644 t/CORE/io/read.t delete mode 100644 t/CORE/io/say.t delete mode 100644 t/CORE/io/tell.t delete mode 100644 t/CORE/io/through.t delete mode 100644 t/CORE/io/utf8.t delete mode 100644 t/CORE/lib/test_use.pm delete mode 100644 t/CORE/lib/test_use_14937.pm delete mode 100644 t/CORE/mro/basic.t delete mode 100644 t/CORE/mro/basic_01_c3.t delete mode 100644 t/CORE/mro/basic_01_dfs.t delete mode 100644 t/CORE/mro/basic_02_c3.t delete mode 100644 t/CORE/mro/basic_02_dfs.t delete mode 100644 t/CORE/mro/basic_03_c3.t delete mode 100644 t/CORE/mro/basic_03_dfs.t delete mode 100644 t/CORE/mro/basic_04_c3.t delete mode 100644 t/CORE/mro/basic_04_dfs.t delete mode 100644 t/CORE/mro/basic_05_c3.t delete mode 100644 t/CORE/mro/basic_05_dfs.t delete mode 100644 t/CORE/mro/c3_with_overload.t delete mode 100644 t/CORE/mro/complex_c3.t delete mode 100644 t/CORE/mro/complex_dfs.t delete mode 100644 t/CORE/mro/dbic_c3.t delete mode 100644 t/CORE/mro/dbic_dfs.t delete mode 100644 t/CORE/mro/inconsistent_c3.t delete mode 100644 t/CORE/mro/isa_aliases.t delete mode 100644 t/CORE/mro/isa_c3.t delete mode 100644 t/CORE/mro/isa_dfs.t delete mode 100644 t/CORE/mro/isarev.t delete mode 100644 t/CORE/mro/method_caching.t delete mode 100644 t/CORE/mro/next_NEXT.t delete mode 100644 t/CORE/mro/next_edgecases.t delete mode 100644 t/CORE/mro/next_goto.t delete mode 100644 t/CORE/mro/next_inanon.t delete mode 100644 t/CORE/mro/next_ineval.t delete mode 100644 t/CORE/mro/next_method.t delete mode 100644 t/CORE/mro/next_skip.t delete mode 100644 t/CORE/mro/overload_c3.t delete mode 100644 t/CORE/mro/overload_dfs.t delete mode 100644 t/CORE/mro/package_aliases.t delete mode 100644 t/CORE/mro/pkg_gen.t delete mode 100644 t/CORE/mro/recursion_c3.t delete mode 100644 t/CORE/mro/recursion_dfs.t delete mode 100644 t/CORE/mro/vulcan_c3.t delete mode 100644 t/CORE/mro/vulcan_dfs.t delete mode 100644 t/CORE/op/64bitint.t delete mode 100644 t/CORE/op/alarm.t delete mode 100644 t/CORE/op/anonsub.t delete mode 100644 t/CORE/op/append.t delete mode 100644 t/CORE/op/args.t delete mode 100644 t/CORE/op/arith.t delete mode 100644 t/CORE/op/array.t delete mode 100644 t/CORE/op/array_base.aux delete mode 100644 t/CORE/op/array_base.t delete mode 100644 t/CORE/op/assignwarn.t delete mode 100644 t/CORE/op/attrhand.t delete mode 100644 t/CORE/op/attrs.t delete mode 100644 t/CORE/op/auto.t delete mode 100644 t/CORE/op/avhv.t delete mode 100644 t/CORE/op/bless.t delete mode 100644 t/CORE/op/bop.t delete mode 100644 t/CORE/op/caller.pl delete mode 100644 t/CORE/op/caller.t delete mode 100644 t/CORE/op/chars.t delete mode 100644 t/CORE/op/chdir.t delete mode 100644 t/CORE/op/chop.t delete mode 100644 t/CORE/op/chr.t delete mode 100644 t/CORE/op/closure.t delete mode 100644 t/CORE/op/cmp.t delete mode 100644 t/CORE/op/concat.t delete mode 100644 t/CORE/op/concat2.t delete mode 100644 t/CORE/op/cond.t delete mode 100644 t/CORE/op/context.t delete mode 100644 t/CORE/op/cproto.t delete mode 100644 t/CORE/op/crypt.t delete mode 100644 t/CORE/op/dbm.t delete mode 100644 t/CORE/op/defins.t delete mode 100644 t/CORE/op/delete.t delete mode 100644 t/CORE/op/die.t delete mode 100644 t/CORE/op/die_except.t delete mode 100644 t/CORE/op/die_exit.t delete mode 100644 t/CORE/op/die_keeperr.t delete mode 100644 t/CORE/op/die_unwind.t delete mode 100644 t/CORE/op/do.t delete mode 100644 t/CORE/op/dor.t delete mode 100644 t/CORE/op/each.t delete mode 100644 t/CORE/op/each_array.t delete mode 100644 t/CORE/op/eval.t delete mode 100644 t/CORE/op/exec.t delete mode 100644 t/CORE/op/exists_sub.t delete mode 100644 t/CORE/op/exp.t delete mode 100644 t/CORE/op/fh.t delete mode 100644 t/CORE/op/filehandle.t delete mode 100644 t/CORE/op/filetest.t delete mode 100644 t/CORE/op/filetest_stack_ok.t delete mode 100644 t/CORE/op/filetest_t.t delete mode 100644 t/CORE/op/flip.t delete mode 100644 t/CORE/op/fork.t delete mode 100644 t/CORE/op/getpid.t delete mode 100644 t/CORE/op/getppid.t delete mode 100644 t/CORE/op/gmagic.t delete mode 100644 t/CORE/op/goto.t delete mode 100644 t/CORE/op/grent.t delete mode 100644 t/CORE/op/grep.t delete mode 100644 t/CORE/op/groups.t delete mode 100644 t/CORE/op/gv.t delete mode 100644 t/CORE/op/hash.t delete mode 100644 t/CORE/op/hashassign.t delete mode 100644 t/CORE/op/hashwarn.t delete mode 100644 t/CORE/op/inc.t delete mode 100644 t/CORE/op/inccode-tie.t delete mode 100644 t/CORE/op/inccode.t delete mode 100644 t/CORE/op/incfilter.t delete mode 100644 t/CORE/op/index.t delete mode 100644 t/CORE/op/int.t delete mode 100644 t/CORE/op/join.t delete mode 100644 t/CORE/op/kill0.t delete mode 100644 t/CORE/op/lc.t delete mode 100644 t/CORE/op/lc_user.t delete mode 100644 t/CORE/op/leaky-magic.t delete mode 100644 t/CORE/op/length.t delete mode 100644 t/CORE/op/lex.t delete mode 100644 t/CORE/op/lex_assign.t delete mode 100644 t/CORE/op/lfs.t delete mode 100644 t/CORE/op/list.t delete mode 100644 t/CORE/op/local.t delete mode 100644 t/CORE/op/localref.t delete mode 100644 t/CORE/op/loopctl.t delete mode 100644 t/CORE/op/lop.t delete mode 100644 t/CORE/op/magic-27839.t delete mode 100644 t/CORE/op/magic.t delete mode 100644 t/CORE/op/magic_phase.t delete mode 100644 t/CORE/op/method.t delete mode 100644 t/CORE/op/mkdir.t delete mode 100644 t/CORE/op/my.t delete mode 100644 t/CORE/op/my_stash.t delete mode 100644 t/CORE/op/mydef.t delete mode 100644 t/CORE/op/negate.t delete mode 100644 t/CORE/op/not.t delete mode 100644 t/CORE/op/numconvert.t delete mode 100644 t/CORE/op/oct.t delete mode 100644 t/CORE/op/or.t delete mode 100644 t/CORE/op/ord.t delete mode 100644 t/CORE/op/overload_integer.t delete mode 100644 t/CORE/op/override.t delete mode 100644 t/CORE/op/pack.t delete mode 100644 t/CORE/op/packagev.t delete mode 100644 t/CORE/op/pos.t delete mode 100644 t/CORE/op/pow.t delete mode 100644 t/CORE/op/print.t delete mode 100644 t/CORE/op/protowarn.t delete mode 100644 t/CORE/op/push.t delete mode 100644 t/CORE/op/pwent.t delete mode 100644 t/CORE/op/qq.t delete mode 100644 t/CORE/op/qr.t delete mode 100644 t/CORE/op/quotemeta.t delete mode 100644 t/CORE/op/rand.t delete mode 100644 t/CORE/op/range.t delete mode 100644 t/CORE/op/read.t delete mode 100644 t/CORE/op/readdir.t delete mode 100644 t/CORE/op/readline.t delete mode 100644 t/CORE/op/recurse.t delete mode 100644 t/CORE/op/ref.t delete mode 100644 t/CORE/op/repeat.t delete mode 100644 t/CORE/op/require_errors.t delete mode 100644 t/CORE/op/reset.t delete mode 100644 t/CORE/op/reverse.t delete mode 100644 t/CORE/op/runlevel.t delete mode 100644 t/CORE/op/setpgrpstack.t delete mode 100644 t/CORE/op/sigdispatch.t delete mode 100644 t/CORE/op/sleep.t delete mode 100644 t/CORE/op/smartkve.t delete mode 100644 t/CORE/op/smartmatch.t delete mode 100644 t/CORE/op/sort.t delete mode 100644 t/CORE/op/splice.t delete mode 100644 t/CORE/op/split.t delete mode 100644 t/CORE/op/split_unicode.t delete mode 100644 t/CORE/op/sprintf.t delete mode 100644 t/CORE/op/sprintf2.t delete mode 100644 t/CORE/op/srand.t delete mode 100644 t/CORE/op/sselect.t delete mode 100644 t/CORE/op/stash.t delete mode 100644 t/CORE/op/stat.t delete mode 100644 t/CORE/op/state.t delete mode 100644 t/CORE/op/study.t delete mode 100644 t/CORE/op/studytied.t delete mode 100644 t/CORE/op/sub.t delete mode 100644 t/CORE/op/sub_lval.t delete mode 100644 t/CORE/op/svleak.t delete mode 100644 t/CORE/op/switch.t delete mode 100644 t/CORE/op/symbolcache.t delete mode 100644 t/CORE/op/sysio.t delete mode 100644 t/CORE/op/taint.t delete mode 100644 t/CORE/op/tie.t delete mode 100644 t/CORE/op/tie_fetch_count.t delete mode 100644 t/CORE/op/tiearray.t delete mode 100644 t/CORE/op/tiehandle.t delete mode 100644 t/CORE/op/time.t delete mode 100644 t/CORE/op/time_loop.t delete mode 100644 t/CORE/op/tr.t delete mode 100644 t/CORE/op/turkish.t delete mode 100644 t/CORE/op/undef.t delete mode 100644 t/CORE/op/universal.t delete mode 100644 t/CORE/op/unshift.t delete mode 100644 t/CORE/op/upgrade.t delete mode 100644 t/CORE/op/utf8cache.t delete mode 100644 t/CORE/op/utf8decode.t delete mode 100644 t/CORE/op/utf8magic.t delete mode 100644 t/CORE/op/utfhash.t delete mode 100644 t/CORE/op/utftaint.t delete mode 100644 t/CORE/op/vec.t delete mode 100644 t/CORE/op/ver.t delete mode 100644 t/CORE/op/wantarray.t delete mode 100644 t/CORE/op/warn.t delete mode 100644 t/CORE/op/while_readdir.t delete mode 100644 t/CORE/op/write.t delete mode 100644 t/CORE/op/yadayada.t delete mode 100644 t/CORE/re/charset.t delete mode 100644 t/CORE/re/fold_grind.t delete mode 100644 t/CORE/re/no_utf8_pm.t delete mode 100644 t/CORE/re/overload.t delete mode 100644 t/CORE/re/pat.t delete mode 100644 t/CORE/re/pat_advanced.t delete mode 100644 t/CORE/re/pat_psycho.t delete mode 100644 t/CORE/re/pat_re_eval.t delete mode 100644 t/CORE/re/pat_rt_report.t delete mode 100644 t/CORE/re/pat_special_cc.t delete mode 100644 t/CORE/re/qr-72922.t delete mode 100644 t/CORE/re/qr.t delete mode 100644 t/CORE/re/qr_gc.t delete mode 100644 t/CORE/re/qrstack.t delete mode 100644 t/CORE/re/re_tests delete mode 100644 t/CORE/re/reg_60508.t delete mode 100644 t/CORE/re/reg_email.t delete mode 100644 t/CORE/re/reg_eval.t delete mode 100644 t/CORE/re/reg_eval_scope.t delete mode 100644 t/CORE/re/reg_fold.t delete mode 100644 t/CORE/re/reg_mesg.t delete mode 100644 t/CORE/re/reg_namedcapture.t delete mode 100644 t/CORE/re/reg_nc_tie.t delete mode 100644 t/CORE/re/reg_pmod.t delete mode 100644 t/CORE/re/reg_posixcc.t delete mode 100644 t/CORE/re/regexp_unicode_prop.t delete mode 100644 t/CORE/re/rxcode.t delete mode 100644 t/CORE/re/subst.t delete mode 100644 t/CORE/re/subst_amp.t delete mode 100644 t/CORE/re/substr.t delete mode 100644 t/CORE/test.pl create mode 100755 t/core-init.sh diff --git a/.gitmodules b/.gitmodules new file mode 100644 index 000000000..b2695deb8 --- /dev/null +++ b/.gitmodules @@ -0,0 +1,3 @@ +[submodule "t/CORE"] + path = t/CORE + url = git://github.com/perl11/p5-coretests.git diff --git a/Changes b/Changes index c5b95b2bc..8946b634e 100644 --- a/Changes +++ b/Changes @@ -41,6 +41,8 @@ the Regexp dynamically (GH #252) * CC (1.16_01): Encode unicode labels (GH#318) * Stackobj (1.12_01): fix Inf/NaN support for CC (GH#287) + * t/CORE: versioned the core tests and moved to a external submodule + (GH #332) 1.52 2014-09-09 rurban * C: Protect against empty SV ptr in SV magic (\0) with $` with 5.20 (#370) diff --git a/MANIFEST b/MANIFEST index 52383d832..46e4671ce 100644 --- a/MANIFEST +++ b/MANIFEST @@ -139,626 +139,6 @@ script/perlcc.PL script/pl2exe.pl status_upd store_rpt -t/C-COMPILED/CORE--base--cond.t -t/C-COMPILED/CORE--base--if.t -t/C-COMPILED/CORE--base--lex.t -t/C-COMPILED/CORE--base--num.t -t/C-COMPILED/CORE--base--pat.t -t/C-COMPILED/CORE--base--rs.t -t/C-COMPILED/CORE--base--term.t -t/C-COMPILED/CORE--base--while.t -t/C-COMPILED/CORE--cmd--elsif.t -t/C-COMPILED/CORE--cmd--for.t -t/C-COMPILED/CORE--cmd--mod.t -t/C-COMPILED/CORE--cmd--subval.t -t/C-COMPILED/CORE--cmd--switch.t -t/C-COMPILED/CORE--cmd--while.t -t/C-COMPILED/CORE--comp--bproto.t -t/C-COMPILED/CORE--comp--cmdopt.t -t/C-COMPILED/CORE--comp--colon.t -t/C-COMPILED/CORE--comp--decl.t -t/C-COMPILED/CORE--comp--fold.t -t/C-COMPILED/CORE--comp--form_scope.t -t/C-COMPILED/CORE--comp--line_debug.t -t/C-COMPILED/CORE--comp--multiline.t -t/C-COMPILED/CORE--comp--opsubs.t -t/C-COMPILED/CORE--comp--our.t -t/C-COMPILED/CORE--comp--package.t -t/C-COMPILED/CORE--comp--package_block.t -t/C-COMPILED/CORE--comp--parser.t -t/C-COMPILED/CORE--comp--proto.t -t/C-COMPILED/CORE--comp--redef.t -t/C-COMPILED/CORE--comp--require.t -t/C-COMPILED/CORE--comp--retainedlines.t -t/C-COMPILED/CORE--comp--term.t -t/C-COMPILED/CORE--comp--uproto.t -t/C-COMPILED/CORE--comp--use.t -t/C-COMPILED/CORE--comp--utf.t -t/C-COMPILED/CORE--io--argv.t -t/C-COMPILED/CORE--io--binmode.t -t/C-COMPILED/CORE--io--bom.t -t/C-COMPILED/CORE--io--crlf.t -t/C-COMPILED/CORE--io--crlf_through.t -t/C-COMPILED/CORE--io--data.t -t/C-COMPILED/CORE--io--defout.t -t/C-COMPILED/CORE--io--dup.t -t/C-COMPILED/CORE--io--eintr.t -t/C-COMPILED/CORE--io--errno.t -t/C-COMPILED/CORE--io--errnosig.t -t/C-COMPILED/CORE--io--fflush.t -t/C-COMPILED/CORE--io--fs.t -t/C-COMPILED/CORE--io--inplace.t -t/C-COMPILED/CORE--io--iofile.t -t/C-COMPILED/CORE--io--iprefix.t -t/C-COMPILED/CORE--io--layers==BADTEST-203.t -t/C-COMPILED/CORE--io--nargv.t -t/C-COMPILED/CORE--io--open.t -t/C-COMPILED/CORE--io--openpid.t -t/C-COMPILED/CORE--io--perlio.t -t/C-COMPILED/CORE--io--perlio_fail.t -t/C-COMPILED/CORE--io--perlio_leaks.t -t/C-COMPILED/CORE--io--perlio_open.t -t/C-COMPILED/CORE--io--pipe.t -t/C-COMPILED/CORE--io--print.t -t/C-COMPILED/CORE--io--pvbm.t -t/C-COMPILED/CORE--io--read.t -t/C-COMPILED/CORE--io--say.t -t/C-COMPILED/CORE--io--tell.t -t/C-COMPILED/CORE--io--through.t -t/C-COMPILED/CORE--io--utf8==BADTEST-319.t -t/C-COMPILED/CORE--mro--basic.t -t/C-COMPILED/CORE--mro--basic_01_c3.t -t/C-COMPILED/CORE--mro--basic_01_dfs.t -t/C-COMPILED/CORE--mro--basic_02_c3.t -t/C-COMPILED/CORE--mro--basic_02_dfs.t -t/C-COMPILED/CORE--mro--basic_03_c3.t -t/C-COMPILED/CORE--mro--basic_03_dfs.t -t/C-COMPILED/CORE--mro--basic_04_c3.t -t/C-COMPILED/CORE--mro--basic_04_dfs.t -t/C-COMPILED/CORE--mro--basic_05_c3.t -t/C-COMPILED/CORE--mro--basic_05_dfs.t -t/C-COMPILED/CORE--mro--c3_with_overload.t -t/C-COMPILED/CORE--mro--complex_c3.t -t/C-COMPILED/CORE--mro--complex_dfs.t -t/C-COMPILED/CORE--mro--dbic_c3.t -t/C-COMPILED/CORE--mro--dbic_dfs.t -t/C-COMPILED/CORE--mro--inconsistent_c3.t -t/C-COMPILED/CORE--mro--isa_aliases.t -t/C-COMPILED/CORE--mro--isa_c3.t -t/C-COMPILED/CORE--mro--isa_dfs.t -t/C-COMPILED/CORE--mro--isarev==BADTEST-353.t -t/C-COMPILED/CORE--mro--method_caching.t -t/C-COMPILED/CORE--mro--next_NEXT.t -t/C-COMPILED/CORE--mro--next_edgecases.t -t/C-COMPILED/CORE--mro--next_goto.t -t/C-COMPILED/CORE--mro--next_inanon.t -t/C-COMPILED/CORE--mro--next_ineval.t -t/C-COMPILED/CORE--mro--next_method.t -t/C-COMPILED/CORE--mro--next_skip.t -t/C-COMPILED/CORE--mro--overload_c3.t -t/C-COMPILED/CORE--mro--overload_dfs.t -t/C-COMPILED/CORE--mro--package_aliases.t -t/C-COMPILED/CORE--mro--pkg_gen.t -t/C-COMPILED/CORE--mro--recursion_c3.t -t/C-COMPILED/CORE--mro--recursion_dfs.t -t/C-COMPILED/CORE--mro--vulcan_c3.t -t/C-COMPILED/CORE--mro--vulcan_dfs.t -t/C-COMPILED/CORE--op--64bitint.t -t/C-COMPILED/CORE--op--alarm.t -t/C-COMPILED/CORE--op--anonsub.t -t/C-COMPILED/CORE--op--append.t -t/C-COMPILED/CORE--op--args.t -t/C-COMPILED/CORE--op--arith.t -t/C-COMPILED/CORE--op--array.t -t/C-COMPILED/CORE--op--array_base.t -t/C-COMPILED/CORE--op--assignwarn.t -t/C-COMPILED/CORE--op--attrhand==BADPLAN-169.t -t/C-COMPILED/CORE--op--attrs.t -t/C-COMPILED/CORE--op--auto.t -t/C-COMPILED/CORE--op--avhv.t -t/C-COMPILED/CORE--op--bless.t -t/C-COMPILED/CORE--op--bop.t -t/C-COMPILED/CORE--op--caller.t -t/C-COMPILED/CORE--op--chars.t -t/C-COMPILED/CORE--op--chdir.t -t/C-COMPILED/CORE--op--chop.t -t/C-COMPILED/CORE--op--chr.t -t/C-COMPILED/CORE--op--closure.t -t/C-COMPILED/CORE--op--cmp.t -t/C-COMPILED/CORE--op--concat.t -t/C-COMPILED/CORE--op--concat2.t -t/C-COMPILED/CORE--op--cond.t -t/C-COMPILED/CORE--op--context.t -t/C-COMPILED/CORE--op--cproto.t -t/C-COMPILED/CORE--op--crypt.t -t/C-COMPILED/CORE--op--dbm.t -t/C-COMPILED/CORE--op--defins.t -t/C-COMPILED/CORE--op--delete.t -t/C-COMPILED/CORE--op--die.t -t/C-COMPILED/CORE--op--die_except.t -t/C-COMPILED/CORE--op--die_exit.t -t/C-COMPILED/CORE--op--die_keeperr.t -t/C-COMPILED/CORE--op--die_unwind.t -t/C-COMPILED/CORE--op--do.t -t/C-COMPILED/CORE--op--dor.t -t/C-COMPILED/CORE--op--each.t -t/C-COMPILED/CORE--op--each_array.t -t/C-COMPILED/CORE--op--eval.t -t/C-COMPILED/CORE--op--exec.t -t/C-COMPILED/CORE--op--exists_sub==BADTEST-251.t -t/C-COMPILED/CORE--op--exp.t -t/C-COMPILED/CORE--op--fh.t -t/C-COMPILED/CORE--op--filehandle.t -t/C-COMPILED/CORE--op--filetest.t -t/C-COMPILED/CORE--op--filetest_stack_ok.t -t/C-COMPILED/CORE--op--filetest_t.t -t/C-COMPILED/CORE--op--flip.t -t/C-COMPILED/CORE--op--fork.t -t/C-COMPILED/CORE--op--getpid.t -t/C-COMPILED/CORE--op--getppid.t -t/C-COMPILED/CORE--op--gmagic.t -t/C-COMPILED/CORE--op--goto.t -t/C-COMPILED/CORE--op--grent.t -t/C-COMPILED/CORE--op--grep.t -t/C-COMPILED/CORE--op--groups.t -t/C-COMPILED/CORE--op--gv.t -t/C-COMPILED/CORE--op--hash.t -t/C-COMPILED/CORE--op--hashassign.t -t/C-COMPILED/CORE--op--hashwarn.t -t/C-COMPILED/CORE--op--inc.t -t/C-COMPILED/CORE--op--inccode-tie.t -t/C-COMPILED/CORE--op--inccode.t -t/C-COMPILED/CORE--op--incfilter.t -t/C-COMPILED/CORE--op--index==BADTEST-247.t -t/C-COMPILED/CORE--op--int.t -t/C-COMPILED/CORE--op--join.t -t/C-COMPILED/CORE--op--kill0.t -t/C-COMPILED/CORE--op--lc.t -t/C-COMPILED/CORE--op--lc_user.t -t/C-COMPILED/CORE--op--leaky-magic.t -t/C-COMPILED/CORE--op--length.t -t/C-COMPILED/CORE--op--lex.t -t/C-COMPILED/CORE--op--lex_assign.t -t/C-COMPILED/CORE--op--lfs.t -t/C-COMPILED/CORE--op--list.t -t/C-COMPILED/CORE--op--local.t -t/C-COMPILED/CORE--op--localref.t -t/C-COMPILED/CORE--op--loopctl.t -t/C-COMPILED/CORE--op--lop.t -t/C-COMPILED/CORE--op--magic-27839.t -t/C-COMPILED/CORE--op--magic.t -t/C-COMPILED/CORE--op--magic_phase.t -t/C-COMPILED/CORE--op--method.t -t/C-COMPILED/CORE--op--mkdir.t -t/C-COMPILED/CORE--op--my.t -t/C-COMPILED/CORE--op--my_stash.t -t/C-COMPILED/CORE--op--mydef.t -t/C-COMPILED/CORE--op--negate.t -t/C-COMPILED/CORE--op--not.t -t/C-COMPILED/CORE--op--numconvert.t -t/C-COMPILED/CORE--op--oct.t -t/C-COMPILED/CORE--op--or.t -t/C-COMPILED/CORE--op--ord.t -t/C-COMPILED/CORE--op--overload_integer.t -t/C-COMPILED/CORE--op--override.t -t/C-COMPILED/CORE--op--pack.t -t/C-COMPILED/CORE--op--packagev==BADTEST-249.t -t/C-COMPILED/CORE--op--pos.t -t/C-COMPILED/CORE--op--pow.t -t/C-COMPILED/CORE--op--print.t -t/C-COMPILED/CORE--op--protowarn.t -t/C-COMPILED/CORE--op--push.t -t/C-COMPILED/CORE--op--pwent.t -t/C-COMPILED/CORE--op--qq.t -t/C-COMPILED/CORE--op--qr.t -t/C-COMPILED/CORE--op--quotemeta.t -t/C-COMPILED/CORE--op--rand.t -t/C-COMPILED/CORE--op--range.t -t/C-COMPILED/CORE--op--read.t -t/C-COMPILED/CORE--op--readdir.t -t/C-COMPILED/CORE--op--readline.t -t/C-COMPILED/CORE--op--recurse.t -t/C-COMPILED/CORE--op--ref==BADTEST-197-285-286.t -t/C-COMPILED/CORE--op--repeat.t -t/C-COMPILED/CORE--op--require_errors.t -t/C-COMPILED/CORE--op--reset.t -t/C-COMPILED/CORE--op--reverse.t -t/C-COMPILED/CORE--op--runlevel.t -t/C-COMPILED/CORE--op--setpgrpstack.t -t/C-COMPILED/CORE--op--sigdispatch.t -t/C-COMPILED/CORE--op--sleep.t -t/C-COMPILED/CORE--op--smartkve.t -t/C-COMPILED/CORE--op--smartmatch==BADTEST-179.t -t/C-COMPILED/CORE--op--sort.t -t/C-COMPILED/CORE--op--splice.t -t/C-COMPILED/CORE--op--split.t -t/C-COMPILED/CORE--op--split_unicode.t -t/C-COMPILED/CORE--op--sprintf.t -t/C-COMPILED/CORE--op--sprintf2.t -t/C-COMPILED/CORE--op--srand.t -t/C-COMPILED/CORE--op--sselect.t -t/C-COMPILED/CORE--op--stash.t -t/C-COMPILED/CORE--op--stat.t -t/C-COMPILED/CORE--op--state.t -t/C-COMPILED/CORE--op--study.t -t/C-COMPILED/CORE--op--studytied.t -t/C-COMPILED/CORE--op--sub.t -t/C-COMPILED/CORE--op--sub_lval.t -t/C-COMPILED/CORE--op--svleak.t -t/C-COMPILED/CORE--op--switch==BADTEST-180.t -t/C-COMPILED/CORE--op--symbolcache.t -t/C-COMPILED/CORE--op--sysio.t -t/C-COMPILED/CORE--op--taint==BADPLAN-288+BADTEST-288.t -t/C-COMPILED/CORE--op--tie.t -t/C-COMPILED/CORE--op--tie_fetch_count.t -t/C-COMPILED/CORE--op--tiearray.t -t/C-COMPILED/CORE--op--tiehandle.t -t/C-COMPILED/CORE--op--time.t -t/C-COMPILED/CORE--op--time_loop.t -t/C-COMPILED/CORE--op--tr.t -t/C-COMPILED/CORE--op--turkish.t -t/C-COMPILED/CORE--op--undef.t -t/C-COMPILED/CORE--op--universal==BADTEST-299.t -t/C-COMPILED/CORE--op--unshift.t -t/C-COMPILED/CORE--op--upgrade.t -t/C-COMPILED/CORE--op--utf8cache.t -t/C-COMPILED/CORE--op--utf8decode.t -t/C-COMPILED/CORE--op--utf8magic.t -t/C-COMPILED/CORE--op--utfhash.t -t/C-COMPILED/CORE--op--utftaint.t -t/C-COMPILED/CORE--op--vec.t -t/C-COMPILED/CORE--op--ver.t -t/C-COMPILED/CORE--op--wantarray.t -t/C-COMPILED/CORE--op--warn.t -t/C-COMPILED/CORE--op--while_readdir.t -t/C-COMPILED/CORE--op--write==BADTEST-238.t -t/C-COMPILED/CORE--op--yadayada.t -t/C-COMPILED/CORE--re--charset.t -t/C-COMPILED/CORE--re--fold_grind.t -t/C-COMPILED/CORE--re--no_utf8_pm.t -t/C-COMPILED/CORE--re--overload==BADTEST-335.t -t/C-COMPILED/CORE--re--pat==BADTEST-274.t -t/C-COMPILED/CORE--re--pat_advanced.t -t/C-COMPILED/CORE--re--pat_psycho.t -t/C-COMPILED/CORE--re--pat_re_eval==SIG-332.t -t/C-COMPILED/CORE--re--pat_rt_report.t -t/C-COMPILED/CORE--re--pat_special_cc.t -t/C-COMPILED/CORE--re--qr-72922.t -t/C-COMPILED/CORE--re--qr.t -t/C-COMPILED/CORE--re--qr_gc.t -t/C-COMPILED/CORE--re--qrstack.t -t/C-COMPILED/CORE--re--reg_60508.t -t/C-COMPILED/CORE--re--reg_email.t -t/C-COMPILED/CORE--re--reg_eval.t -t/C-COMPILED/CORE--re--reg_eval_scope.t -t/C-COMPILED/CORE--re--reg_fold.t -t/C-COMPILED/CORE--re--reg_mesg.t -t/C-COMPILED/CORE--re--reg_namedcapture.t -t/C-COMPILED/CORE--re--reg_nc_tie.t -t/C-COMPILED/CORE--re--reg_pmod.t -t/C-COMPILED/CORE--re--reg_posixcc.t -t/C-COMPILED/CORE--re--regexp_unicode_prop.t -t/C-COMPILED/CORE--re--rxcode.t -t/C-COMPILED/CORE--re--subst.t -t/C-COMPILED/CORE--re--subst_amp.t -t/C-COMPILED/CORE--re--substr.t -t/C-COMPILED/template.pl -t/C-COMPILED/testc.pl -t/CORE/CaseFolding.txt -t/CORE/Cname.pm -t/CORE/TEST -t/CORE/base/cond.t -t/CORE/base/if.t -t/CORE/base/lex.t -t/CORE/base/num.t -t/CORE/base/pat.t -t/CORE/base/rs.t -t/CORE/base/term.t -t/CORE/base/while.t -t/CORE/cmd/elsif.t -t/CORE/cmd/for.t -t/CORE/cmd/mod.t -t/CORE/cmd/subval.t -t/CORE/cmd/switch.t -t/CORE/cmd/while.t -t/CORE/comp/bproto.t -t/CORE/comp/cmdopt.t -t/CORE/comp/colon.t -t/CORE/comp/decl.t -t/CORE/comp/fold.t -t/CORE/comp/form_scope.t -t/CORE/comp/hints.aux -t/CORE/comp/hints.t -t/CORE/comp/line_debug.t -t/CORE/comp/line_debug_0.aux -t/CORE/comp/multiline.t -t/CORE/comp/opsubs.t -t/CORE/comp/our.t -t/CORE/comp/package.t -t/CORE/comp/package_block.t -t/CORE/comp/parser.t -t/CORE/comp/proto.t -t/CORE/comp/redef.t -t/CORE/comp/require.t -t/CORE/comp/retainedlines.t -t/CORE/comp/term.t -t/CORE/comp/uproto.t -t/CORE/comp/use.t -t/CORE/comp/utf.t -t/CORE/io/argv.t -t/CORE/io/binmode.t -t/CORE/io/bom.t -t/CORE/io/crlf.t -t/CORE/io/crlf_through.t -t/CORE/io/data.t -t/CORE/io/defout.t -t/CORE/io/dup.t -t/CORE/io/eintr.t -t/CORE/io/errno.t -t/CORE/io/errnosig.t -t/CORE/io/fflush.t -t/CORE/io/fs.t -t/CORE/io/inplace.t -t/CORE/io/iofile.t -t/CORE/io/iprefix.t -t/CORE/io/layers.t -t/CORE/io/nargv.t -t/CORE/io/open.t -t/CORE/io/openpid.t -t/CORE/io/perlio.t -t/CORE/io/perlio_fail.t -t/CORE/io/perlio_leaks.t -t/CORE/io/perlio_open.t -t/CORE/io/pipe.t -t/CORE/io/print.t -t/CORE/io/pvbm.t -t/CORE/io/read.t -t/CORE/io/say.t -t/CORE/io/tell.t -t/CORE/io/through.t -t/CORE/io/utf8.t -t/CORE/lib/test_use.pm -t/CORE/lib/test_use_14937.pm -t/CORE/mro/basic.t -t/CORE/mro/basic_01_c3.t -t/CORE/mro/basic_01_dfs.t -t/CORE/mro/basic_02_c3.t -t/CORE/mro/basic_02_dfs.t -t/CORE/mro/basic_03_c3.t -t/CORE/mro/basic_03_dfs.t -t/CORE/mro/basic_04_c3.t -t/CORE/mro/basic_04_dfs.t -t/CORE/mro/basic_05_c3.t -t/CORE/mro/basic_05_dfs.t -t/CORE/mro/c3_with_overload.t -t/CORE/mro/complex_c3.t -t/CORE/mro/complex_dfs.t -t/CORE/mro/dbic_c3.t -t/CORE/mro/dbic_dfs.t -t/CORE/mro/inconsistent_c3.t -t/CORE/mro/isa_aliases.t -t/CORE/mro/isa_c3.t -t/CORE/mro/isa_dfs.t -t/CORE/mro/isarev.t -t/CORE/mro/method_caching.t -t/CORE/mro/next_NEXT.t -t/CORE/mro/next_edgecases.t -t/CORE/mro/next_goto.t -t/CORE/mro/next_inanon.t -t/CORE/mro/next_ineval.t -t/CORE/mro/next_method.t -t/CORE/mro/next_skip.t -t/CORE/mro/overload_c3.t -t/CORE/mro/overload_dfs.t -t/CORE/mro/package_aliases.t -t/CORE/mro/pkg_gen.t -t/CORE/mro/recursion_c3.t -t/CORE/mro/recursion_dfs.t -t/CORE/mro/vulcan_c3.t -t/CORE/mro/vulcan_dfs.t -t/CORE/op/64bitint.t -t/CORE/op/alarm.t -t/CORE/op/anonsub.t -t/CORE/op/append.t -t/CORE/op/args.t -t/CORE/op/arith.t -t/CORE/op/array.t -t/CORE/op/array_base.aux -t/CORE/op/array_base.t -t/CORE/op/assignwarn.t -t/CORE/op/attrhand.t -t/CORE/op/attrs.t -t/CORE/op/auto.t -t/CORE/op/avhv.t -t/CORE/op/bless.t -t/CORE/op/bop.t -t/CORE/op/caller.pl -t/CORE/op/caller.t -t/CORE/op/chars.t -t/CORE/op/chdir.t -t/CORE/op/chop.t -t/CORE/op/chr.t -t/CORE/op/closure.t -t/CORE/op/cmp.t -t/CORE/op/concat.t -t/CORE/op/concat2.t -t/CORE/op/cond.t -t/CORE/op/context.t -t/CORE/op/cproto.t -t/CORE/op/crypt.t -t/CORE/op/dbm.t -t/CORE/op/defins.t -t/CORE/op/delete.t -t/CORE/op/die.t -t/CORE/op/die_except.t -t/CORE/op/die_exit.t -t/CORE/op/die_keeperr.t -t/CORE/op/die_unwind.t -t/CORE/op/do.t -t/CORE/op/dor.t -t/CORE/op/each.t -t/CORE/op/each_array.t -t/CORE/op/eval.t -t/CORE/op/exec.t -t/CORE/op/exists_sub.t -t/CORE/op/exp.t -t/CORE/op/fh.t -t/CORE/op/filehandle.t -t/CORE/op/filetest.t -t/CORE/op/filetest_stack_ok.t -t/CORE/op/filetest_t.t -t/CORE/op/flip.t -t/CORE/op/fork.t -t/CORE/op/getpid.t -t/CORE/op/getppid.t -t/CORE/op/gmagic.t -t/CORE/op/goto.t -t/CORE/op/grent.t -t/CORE/op/grep.t -t/CORE/op/groups.t -t/CORE/op/gv.t -t/CORE/op/hash.t -t/CORE/op/hashassign.t -t/CORE/op/hashwarn.t -t/CORE/op/inc.t -t/CORE/op/inccode-tie.t -t/CORE/op/inccode.t -t/CORE/op/incfilter.t -t/CORE/op/index.t -t/CORE/op/int.t -t/CORE/op/join.t -t/CORE/op/kill0.t -t/CORE/op/lc.t -t/CORE/op/lc_user.t -t/CORE/op/leaky-magic.t -t/CORE/op/length.t -t/CORE/op/lex.t -t/CORE/op/lex_assign.t -t/CORE/op/lfs.t -t/CORE/op/list.t -t/CORE/op/local.t -t/CORE/op/localref.t -t/CORE/op/loopctl.t -t/CORE/op/lop.t -t/CORE/op/magic-27839.t -t/CORE/op/magic.t -t/CORE/op/magic_phase.t -t/CORE/op/method.t -t/CORE/op/mkdir.t -t/CORE/op/my.t -t/CORE/op/my_stash.t -t/CORE/op/mydef.t -t/CORE/op/negate.t -t/CORE/op/not.t -t/CORE/op/numconvert.t -t/CORE/op/oct.t -t/CORE/op/or.t -t/CORE/op/ord.t -t/CORE/op/overload_integer.t -t/CORE/op/override.t -t/CORE/op/pack.t -t/CORE/op/packagev.t -t/CORE/op/pos.t -t/CORE/op/pow.t -t/CORE/op/print.t -t/CORE/op/protowarn.t -t/CORE/op/push.t -t/CORE/op/pwent.t -t/CORE/op/qq.t -t/CORE/op/qr.t -t/CORE/op/quotemeta.t -t/CORE/op/rand.t -t/CORE/op/range.t -t/CORE/op/read.t -t/CORE/op/readdir.t -t/CORE/op/readline.t -t/CORE/op/recurse.t -t/CORE/op/ref.t -t/CORE/op/repeat.t -t/CORE/op/require_errors.t -t/CORE/op/reset.t -t/CORE/op/reverse.t -t/CORE/op/runlevel.t -t/CORE/op/setpgrpstack.t -t/CORE/op/sigdispatch.t -t/CORE/op/sleep.t -t/CORE/op/smartkve.t -t/CORE/op/smartmatch.t -t/CORE/op/sort.t -t/CORE/op/splice.t -t/CORE/op/split.t -t/CORE/op/split_unicode.t -t/CORE/op/sprintf.t -t/CORE/op/sprintf2.t -t/CORE/op/srand.t -t/CORE/op/sselect.t -t/CORE/op/stash.t -t/CORE/op/stat.t -t/CORE/op/state.t -t/CORE/op/study.t -t/CORE/op/studytied.t -t/CORE/op/sub.t -t/CORE/op/sub_lval.t -t/CORE/op/svleak.t -t/CORE/op/switch.t -t/CORE/op/symbolcache.t -t/CORE/op/sysio.t -t/CORE/op/taint.t -t/CORE/op/tie.t -t/CORE/op/tie_fetch_count.t -t/CORE/op/tiearray.t -t/CORE/op/tiehandle.t -t/CORE/op/time.t -t/CORE/op/time_loop.t -t/CORE/op/tr.t -t/CORE/op/turkish.t -t/CORE/op/undef.t -t/CORE/op/universal.t -t/CORE/op/unshift.t -t/CORE/op/upgrade.t -t/CORE/op/utf8cache.t -t/CORE/op/utf8decode.t -t/CORE/op/utf8magic.t -t/CORE/op/utfhash.t -t/CORE/op/utftaint.t -t/CORE/op/vec.t -t/CORE/op/ver.t -t/CORE/op/wantarray.t -t/CORE/op/warn.t -t/CORE/op/while_readdir.t -t/CORE/op/write.t -t/CORE/op/yadayada.t -t/CORE/re/charset.t -t/CORE/re/fold_grind.t -t/CORE/re/no_utf8_pm.t -t/CORE/re/overload.t -t/CORE/re/pat.t -t/CORE/re/pat_advanced.t -t/CORE/re/pat_psycho.t -t/CORE/re/pat_re_eval.t -t/CORE/re/pat_rt_report.t -t/CORE/re/pat_special_cc.t -t/CORE/re/qr-72922.t -t/CORE/re/qr.t -t/CORE/re/qr_gc.t -t/CORE/re/qrstack.t -t/CORE/re/re_tests -t/CORE/re/reg_60508.t -t/CORE/re/reg_email.t -t/CORE/re/reg_eval.t -t/CORE/re/reg_eval_scope.t -t/CORE/re/reg_fold.t -t/CORE/re/reg_mesg.t -t/CORE/re/reg_namedcapture.t -t/CORE/re/reg_nc_tie.t -t/CORE/re/reg_pmod.t -t/CORE/re/reg_posixcc.t -t/CORE/re/regexp_unicode_prop.t -t/CORE/re/rxcode.t -t/CORE/re/subst.t -t/CORE/re/subst_amp.t -t/CORE/re/substr.t -t/CORE/test.pl t/Mock.pm t/TESTS t/asmdata.t @@ -776,6 +156,7 @@ t/cc.t t/cc_last.t t/cc_o1.t t/cc_o2.t +t/core-init.sh t/coreall.sh t/coverage.sh t/critical.sh diff --git a/Makefile.PL b/Makefile.PL index 302b4f222..1f60b0214 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -167,7 +167,9 @@ WriteMakefile( "lib/B/Asmdata.pm script/perlcc ccode* cccode* Ccode* ". "*.core *.stackdump a.out a.exe *.cee *.c *.asm *.dbg *.plc *.obj ". "*.concise *~ dll.base dll.exp mod.pl pcc* *.bak *.a ". - "t/CORE/*/*.bin t/CORE/*/*.c Io_argv* t/CORE/*/*.subtest.*.t t/CORE/tmp* tmp*" + "t/CORE/v5.*/*/*.bin t/CORE/v5.*/*/*.c Io_argv* t/CORE/v5.*/*/*.subtest.*.t". + "t/CORE/v5.*/xtestc* t/CORE/v5.*/C-COMPILED/xtestc/*.t". + "t/CORE/v5.*/tmp* tmp*" }, ); @@ -369,7 +371,10 @@ TAGS : $asmdata } sub test { - shift->SUPER::test(@_) . q( + shift->SUPER::test(@_) . +" +PERL_VER = v5.".substr($],3,2) . + q( testmod :: pure_all PERL_DL_NONLAZY=1 $(FULLPERLRUN) -Iblib/arch -Iblib/lib t/modules.t testmodall :: pure_all @@ -391,10 +396,13 @@ teststatus :: pure_all ./status_upd -fqd testrelease :: pure_all $(ECHO) run t/release-testing.sh and perlall testvm --all -testcore :: pure_all - $(FULLPERLRUN) -S prove -b -j10 -f t/C-COMPILED -testcore-log :: pure_all - $(FULLPERLRUN) -S prove -b -j10 -f t/C-COMPILED | tee log.test-core-).$].q(-`git describe --tags` +testcore_init :: t/CORE + t/core-init.sh +testcore :: pure_all testcore_init + $(FULLPERLRUN) -S prove -b -j10 -f t/CORE/$(PERL_VER)/C-COMPILED/*/ +testcore-log :: pure_all testcore_init + $(FULLPERLRUN) -S prove -b -j10 -f t/CORE/$(PERL_VER)/C-COMPILED/*/ | \ + tee log.test-core-$(PERL_VER)-`git describe --tags` ) } diff --git a/t/C-COMPILED/CORE--base--cond.t b/t/C-COMPILED/CORE--base--cond.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--base--cond.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--base--if.t b/t/C-COMPILED/CORE--base--if.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--base--if.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--base--lex.t b/t/C-COMPILED/CORE--base--lex.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--base--lex.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--base--num.t b/t/C-COMPILED/CORE--base--num.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--base--num.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--base--pat.t b/t/C-COMPILED/CORE--base--pat.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--base--pat.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--base--rs.t b/t/C-COMPILED/CORE--base--rs.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--base--rs.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--base--term.t b/t/C-COMPILED/CORE--base--term.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--base--term.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--base--while.t b/t/C-COMPILED/CORE--base--while.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--base--while.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--cmd--elsif.t b/t/C-COMPILED/CORE--cmd--elsif.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--cmd--elsif.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--cmd--for.t b/t/C-COMPILED/CORE--cmd--for.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--cmd--for.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--cmd--mod.t b/t/C-COMPILED/CORE--cmd--mod.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--cmd--mod.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--cmd--subval.t b/t/C-COMPILED/CORE--cmd--subval.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--cmd--subval.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--cmd--switch.t b/t/C-COMPILED/CORE--cmd--switch.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--cmd--switch.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--cmd--while.t b/t/C-COMPILED/CORE--cmd--while.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--cmd--while.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--comp--bproto.t b/t/C-COMPILED/CORE--comp--bproto.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--comp--bproto.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--comp--cmdopt.t b/t/C-COMPILED/CORE--comp--cmdopt.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--comp--cmdopt.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--comp--colon.t b/t/C-COMPILED/CORE--comp--colon.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--comp--colon.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--comp--decl.t b/t/C-COMPILED/CORE--comp--decl.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--comp--decl.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--comp--fold.t b/t/C-COMPILED/CORE--comp--fold.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--comp--fold.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--comp--form_scope.t b/t/C-COMPILED/CORE--comp--form_scope.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--comp--form_scope.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--comp--line_debug.t b/t/C-COMPILED/CORE--comp--line_debug.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--comp--line_debug.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--comp--multiline.t b/t/C-COMPILED/CORE--comp--multiline.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--comp--multiline.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--comp--opsubs.t b/t/C-COMPILED/CORE--comp--opsubs.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--comp--opsubs.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--comp--our.t b/t/C-COMPILED/CORE--comp--our.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--comp--our.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--comp--package.t b/t/C-COMPILED/CORE--comp--package.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--comp--package.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--comp--package_block.t b/t/C-COMPILED/CORE--comp--package_block.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--comp--package_block.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--comp--parser.t b/t/C-COMPILED/CORE--comp--parser.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--comp--parser.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--comp--proto.t b/t/C-COMPILED/CORE--comp--proto.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--comp--proto.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--comp--redef.t b/t/C-COMPILED/CORE--comp--redef.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--comp--redef.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--comp--require.t b/t/C-COMPILED/CORE--comp--require.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--comp--require.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--comp--retainedlines.t b/t/C-COMPILED/CORE--comp--retainedlines.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--comp--retainedlines.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--comp--term.t b/t/C-COMPILED/CORE--comp--term.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--comp--term.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--comp--uproto.t b/t/C-COMPILED/CORE--comp--uproto.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--comp--uproto.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--comp--use.t b/t/C-COMPILED/CORE--comp--use.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--comp--use.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--comp--utf.t b/t/C-COMPILED/CORE--comp--utf.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--comp--utf.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--io--argv.t b/t/C-COMPILED/CORE--io--argv.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--io--argv.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--io--binmode.t b/t/C-COMPILED/CORE--io--binmode.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--io--binmode.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--io--bom.t b/t/C-COMPILED/CORE--io--bom.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--io--bom.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--io--crlf.t b/t/C-COMPILED/CORE--io--crlf.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--io--crlf.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--io--crlf_through.t b/t/C-COMPILED/CORE--io--crlf_through.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--io--crlf_through.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--io--data.t b/t/C-COMPILED/CORE--io--data.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--io--data.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--io--defout.t b/t/C-COMPILED/CORE--io--defout.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--io--defout.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--io--dup.t b/t/C-COMPILED/CORE--io--dup.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--io--dup.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--io--eintr.t b/t/C-COMPILED/CORE--io--eintr.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--io--eintr.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--io--errno.t b/t/C-COMPILED/CORE--io--errno.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--io--errno.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--io--errnosig.t b/t/C-COMPILED/CORE--io--errnosig.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--io--errnosig.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--io--fflush.t b/t/C-COMPILED/CORE--io--fflush.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--io--fflush.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--io--fs.t b/t/C-COMPILED/CORE--io--fs.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--io--fs.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--io--inplace.t b/t/C-COMPILED/CORE--io--inplace.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--io--inplace.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--io--iofile.t b/t/C-COMPILED/CORE--io--iofile.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--io--iofile.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--io--iprefix.t b/t/C-COMPILED/CORE--io--iprefix.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--io--iprefix.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--io--layers==BADTEST-203.t b/t/C-COMPILED/CORE--io--layers==BADTEST-203.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--io--layers==BADTEST-203.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--io--nargv.t b/t/C-COMPILED/CORE--io--nargv.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--io--nargv.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--io--open.t b/t/C-COMPILED/CORE--io--open.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--io--open.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--io--openpid.t b/t/C-COMPILED/CORE--io--openpid.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--io--openpid.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--io--perlio.t b/t/C-COMPILED/CORE--io--perlio.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--io--perlio.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--io--perlio_fail.t b/t/C-COMPILED/CORE--io--perlio_fail.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--io--perlio_fail.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--io--perlio_leaks.t b/t/C-COMPILED/CORE--io--perlio_leaks.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--io--perlio_leaks.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--io--perlio_open.t b/t/C-COMPILED/CORE--io--perlio_open.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--io--perlio_open.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--io--pipe.t b/t/C-COMPILED/CORE--io--pipe.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--io--pipe.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--io--print.t b/t/C-COMPILED/CORE--io--print.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--io--print.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--io--pvbm.t b/t/C-COMPILED/CORE--io--pvbm.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--io--pvbm.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--io--read.t b/t/C-COMPILED/CORE--io--read.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--io--read.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--io--say.t b/t/C-COMPILED/CORE--io--say.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--io--say.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--io--tell.t b/t/C-COMPILED/CORE--io--tell.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--io--tell.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--io--through.t b/t/C-COMPILED/CORE--io--through.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--io--through.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--io--utf8==BADTEST-319.t b/t/C-COMPILED/CORE--io--utf8==BADTEST-319.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--io--utf8==BADTEST-319.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--mro--basic.t b/t/C-COMPILED/CORE--mro--basic.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--mro--basic.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--mro--basic_01_c3.t b/t/C-COMPILED/CORE--mro--basic_01_c3.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--mro--basic_01_c3.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--mro--basic_01_dfs.t b/t/C-COMPILED/CORE--mro--basic_01_dfs.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--mro--basic_01_dfs.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--mro--basic_02_c3.t b/t/C-COMPILED/CORE--mro--basic_02_c3.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--mro--basic_02_c3.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--mro--basic_02_dfs.t b/t/C-COMPILED/CORE--mro--basic_02_dfs.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--mro--basic_02_dfs.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--mro--basic_03_c3.t b/t/C-COMPILED/CORE--mro--basic_03_c3.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--mro--basic_03_c3.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--mro--basic_03_dfs.t b/t/C-COMPILED/CORE--mro--basic_03_dfs.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--mro--basic_03_dfs.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--mro--basic_04_c3.t b/t/C-COMPILED/CORE--mro--basic_04_c3.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--mro--basic_04_c3.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--mro--basic_04_dfs.t b/t/C-COMPILED/CORE--mro--basic_04_dfs.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--mro--basic_04_dfs.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--mro--basic_05_c3.t b/t/C-COMPILED/CORE--mro--basic_05_c3.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--mro--basic_05_c3.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--mro--basic_05_dfs.t b/t/C-COMPILED/CORE--mro--basic_05_dfs.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--mro--basic_05_dfs.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--mro--c3_with_overload.t b/t/C-COMPILED/CORE--mro--c3_with_overload.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--mro--c3_with_overload.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--mro--complex_c3.t b/t/C-COMPILED/CORE--mro--complex_c3.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--mro--complex_c3.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--mro--complex_dfs.t b/t/C-COMPILED/CORE--mro--complex_dfs.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--mro--complex_dfs.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--mro--dbic_c3.t b/t/C-COMPILED/CORE--mro--dbic_c3.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--mro--dbic_c3.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--mro--dbic_dfs.t b/t/C-COMPILED/CORE--mro--dbic_dfs.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--mro--dbic_dfs.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--mro--inconsistent_c3.t b/t/C-COMPILED/CORE--mro--inconsistent_c3.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--mro--inconsistent_c3.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--mro--isa_aliases.t b/t/C-COMPILED/CORE--mro--isa_aliases.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--mro--isa_aliases.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--mro--isa_c3.t b/t/C-COMPILED/CORE--mro--isa_c3.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--mro--isa_c3.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--mro--isa_dfs.t b/t/C-COMPILED/CORE--mro--isa_dfs.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--mro--isa_dfs.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--mro--isarev==BADTEST-353.t b/t/C-COMPILED/CORE--mro--isarev==BADTEST-353.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--mro--isarev==BADTEST-353.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--mro--method_caching.t b/t/C-COMPILED/CORE--mro--method_caching.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--mro--method_caching.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--mro--next_NEXT.t b/t/C-COMPILED/CORE--mro--next_NEXT.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--mro--next_NEXT.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--mro--next_edgecases.t b/t/C-COMPILED/CORE--mro--next_edgecases.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--mro--next_edgecases.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--mro--next_goto.t b/t/C-COMPILED/CORE--mro--next_goto.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--mro--next_goto.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--mro--next_inanon.t b/t/C-COMPILED/CORE--mro--next_inanon.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--mro--next_inanon.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--mro--next_ineval.t b/t/C-COMPILED/CORE--mro--next_ineval.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--mro--next_ineval.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--mro--next_method.t b/t/C-COMPILED/CORE--mro--next_method.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--mro--next_method.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--mro--next_skip.t b/t/C-COMPILED/CORE--mro--next_skip.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--mro--next_skip.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--mro--overload_c3.t b/t/C-COMPILED/CORE--mro--overload_c3.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--mro--overload_c3.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--mro--overload_dfs.t b/t/C-COMPILED/CORE--mro--overload_dfs.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--mro--overload_dfs.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--mro--package_aliases.t b/t/C-COMPILED/CORE--mro--package_aliases.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--mro--package_aliases.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--mro--pkg_gen.t b/t/C-COMPILED/CORE--mro--pkg_gen.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--mro--pkg_gen.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--mro--recursion_c3.t b/t/C-COMPILED/CORE--mro--recursion_c3.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--mro--recursion_c3.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--mro--recursion_dfs.t b/t/C-COMPILED/CORE--mro--recursion_dfs.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--mro--recursion_dfs.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--mro--vulcan_c3.t b/t/C-COMPILED/CORE--mro--vulcan_c3.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--mro--vulcan_c3.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--mro--vulcan_dfs.t b/t/C-COMPILED/CORE--mro--vulcan_dfs.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--mro--vulcan_dfs.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--64bitint.t b/t/C-COMPILED/CORE--op--64bitint.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--64bitint.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--alarm.t b/t/C-COMPILED/CORE--op--alarm.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--alarm.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--anonsub.t b/t/C-COMPILED/CORE--op--anonsub.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--anonsub.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--append.t b/t/C-COMPILED/CORE--op--append.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--append.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--args.t b/t/C-COMPILED/CORE--op--args.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--args.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--arith.t b/t/C-COMPILED/CORE--op--arith.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--arith.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--array.t b/t/C-COMPILED/CORE--op--array.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--array.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--array_base.t b/t/C-COMPILED/CORE--op--array_base.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--array_base.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--assignwarn.t b/t/C-COMPILED/CORE--op--assignwarn.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--assignwarn.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--attrhand==BADPLAN-169.t b/t/C-COMPILED/CORE--op--attrhand==BADPLAN-169.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--attrhand==BADPLAN-169.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--attrs.t b/t/C-COMPILED/CORE--op--attrs.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--attrs.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--auto.t b/t/C-COMPILED/CORE--op--auto.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--auto.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--avhv.t b/t/C-COMPILED/CORE--op--avhv.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--avhv.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--bless.t b/t/C-COMPILED/CORE--op--bless.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--bless.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--bop.t b/t/C-COMPILED/CORE--op--bop.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--bop.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--caller.t b/t/C-COMPILED/CORE--op--caller.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--caller.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--chars.t b/t/C-COMPILED/CORE--op--chars.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--chars.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--chdir.t b/t/C-COMPILED/CORE--op--chdir.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--chdir.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--chop.t b/t/C-COMPILED/CORE--op--chop.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--chop.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--chr.t b/t/C-COMPILED/CORE--op--chr.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--chr.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--closure.t b/t/C-COMPILED/CORE--op--closure.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--closure.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--cmp.t b/t/C-COMPILED/CORE--op--cmp.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--cmp.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--concat.t b/t/C-COMPILED/CORE--op--concat.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--concat.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--concat2.t b/t/C-COMPILED/CORE--op--concat2.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--concat2.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--cond.t b/t/C-COMPILED/CORE--op--cond.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--cond.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--context.t b/t/C-COMPILED/CORE--op--context.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--context.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--cproto.t b/t/C-COMPILED/CORE--op--cproto.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--cproto.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--crypt.t b/t/C-COMPILED/CORE--op--crypt.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--crypt.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--dbm.t b/t/C-COMPILED/CORE--op--dbm.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--dbm.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--defins.t b/t/C-COMPILED/CORE--op--defins.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--defins.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--delete.t b/t/C-COMPILED/CORE--op--delete.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--delete.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--die.t b/t/C-COMPILED/CORE--op--die.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--die.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--die_except.t b/t/C-COMPILED/CORE--op--die_except.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--die_except.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--die_exit.t b/t/C-COMPILED/CORE--op--die_exit.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--die_exit.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--die_keeperr.t b/t/C-COMPILED/CORE--op--die_keeperr.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--die_keeperr.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--die_unwind.t b/t/C-COMPILED/CORE--op--die_unwind.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--die_unwind.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--do.t b/t/C-COMPILED/CORE--op--do.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--do.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--dor.t b/t/C-COMPILED/CORE--op--dor.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--dor.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--each.t b/t/C-COMPILED/CORE--op--each.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--each.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--each_array.t b/t/C-COMPILED/CORE--op--each_array.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--each_array.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--eval.t b/t/C-COMPILED/CORE--op--eval.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--eval.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--exec.t b/t/C-COMPILED/CORE--op--exec.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--exec.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--exists_sub==BADTEST-251.t b/t/C-COMPILED/CORE--op--exists_sub==BADTEST-251.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--exists_sub==BADTEST-251.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--exp.t b/t/C-COMPILED/CORE--op--exp.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--exp.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--fh.t b/t/C-COMPILED/CORE--op--fh.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--fh.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--filehandle.t b/t/C-COMPILED/CORE--op--filehandle.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--filehandle.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--filetest.t b/t/C-COMPILED/CORE--op--filetest.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--filetest.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--filetest_stack_ok.t b/t/C-COMPILED/CORE--op--filetest_stack_ok.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--filetest_stack_ok.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--filetest_t.t b/t/C-COMPILED/CORE--op--filetest_t.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--filetest_t.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--flip.t b/t/C-COMPILED/CORE--op--flip.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--flip.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--fork.t b/t/C-COMPILED/CORE--op--fork.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--fork.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--getpid.t b/t/C-COMPILED/CORE--op--getpid.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--getpid.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--getppid.t b/t/C-COMPILED/CORE--op--getppid.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--getppid.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--gmagic.t b/t/C-COMPILED/CORE--op--gmagic.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--gmagic.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--goto.t b/t/C-COMPILED/CORE--op--goto.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--goto.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--grent.t b/t/C-COMPILED/CORE--op--grent.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--grent.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--grep.t b/t/C-COMPILED/CORE--op--grep.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--grep.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--groups.t b/t/C-COMPILED/CORE--op--groups.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--groups.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--gv.t b/t/C-COMPILED/CORE--op--gv.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--gv.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--hash.t b/t/C-COMPILED/CORE--op--hash.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--hash.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--hashassign.t b/t/C-COMPILED/CORE--op--hashassign.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--hashassign.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--hashwarn.t b/t/C-COMPILED/CORE--op--hashwarn.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--hashwarn.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--inc.t b/t/C-COMPILED/CORE--op--inc.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--inc.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--inccode-tie.t b/t/C-COMPILED/CORE--op--inccode-tie.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--inccode-tie.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--inccode.t b/t/C-COMPILED/CORE--op--inccode.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--inccode.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--incfilter.t b/t/C-COMPILED/CORE--op--incfilter.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--incfilter.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--index==BADTEST-247.t b/t/C-COMPILED/CORE--op--index==BADTEST-247.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--index==BADTEST-247.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--int.t b/t/C-COMPILED/CORE--op--int.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--int.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--join.t b/t/C-COMPILED/CORE--op--join.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--join.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--kill0.t b/t/C-COMPILED/CORE--op--kill0.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--kill0.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--lc.t b/t/C-COMPILED/CORE--op--lc.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--lc.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--lc_user.t b/t/C-COMPILED/CORE--op--lc_user.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--lc_user.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--leaky-magic.t b/t/C-COMPILED/CORE--op--leaky-magic.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--leaky-magic.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--length.t b/t/C-COMPILED/CORE--op--length.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--length.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--lex.t b/t/C-COMPILED/CORE--op--lex.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--lex.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--lex_assign.t b/t/C-COMPILED/CORE--op--lex_assign.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--lex_assign.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--lfs.t b/t/C-COMPILED/CORE--op--lfs.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--lfs.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--list.t b/t/C-COMPILED/CORE--op--list.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--list.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--local.t b/t/C-COMPILED/CORE--op--local.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--local.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--localref.t b/t/C-COMPILED/CORE--op--localref.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--localref.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--loopctl.t b/t/C-COMPILED/CORE--op--loopctl.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--loopctl.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--lop.t b/t/C-COMPILED/CORE--op--lop.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--lop.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--magic-27839.t b/t/C-COMPILED/CORE--op--magic-27839.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--magic-27839.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--magic.t b/t/C-COMPILED/CORE--op--magic.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--magic.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--magic_phase.t b/t/C-COMPILED/CORE--op--magic_phase.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--magic_phase.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--method.t b/t/C-COMPILED/CORE--op--method.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--method.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--mkdir.t b/t/C-COMPILED/CORE--op--mkdir.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--mkdir.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--my.t b/t/C-COMPILED/CORE--op--my.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--my.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--my_stash.t b/t/C-COMPILED/CORE--op--my_stash.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--my_stash.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--mydef.t b/t/C-COMPILED/CORE--op--mydef.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--mydef.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--negate.t b/t/C-COMPILED/CORE--op--negate.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--negate.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--not.t b/t/C-COMPILED/CORE--op--not.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--not.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--numconvert.t b/t/C-COMPILED/CORE--op--numconvert.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--numconvert.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--oct.t b/t/C-COMPILED/CORE--op--oct.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--oct.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--or.t b/t/C-COMPILED/CORE--op--or.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--or.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--ord.t b/t/C-COMPILED/CORE--op--ord.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--ord.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--overload_integer.t b/t/C-COMPILED/CORE--op--overload_integer.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--overload_integer.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--override.t b/t/C-COMPILED/CORE--op--override.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--override.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--pack.t b/t/C-COMPILED/CORE--op--pack.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--pack.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--packagev==BADTEST-249.t b/t/C-COMPILED/CORE--op--packagev==BADTEST-249.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--packagev==BADTEST-249.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--pos.t b/t/C-COMPILED/CORE--op--pos.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--pos.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--pow.t b/t/C-COMPILED/CORE--op--pow.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--pow.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--print.t b/t/C-COMPILED/CORE--op--print.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--print.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--protowarn.t b/t/C-COMPILED/CORE--op--protowarn.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--protowarn.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--push.t b/t/C-COMPILED/CORE--op--push.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--push.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--pwent.t b/t/C-COMPILED/CORE--op--pwent.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--pwent.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--qq.t b/t/C-COMPILED/CORE--op--qq.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--qq.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--qr.t b/t/C-COMPILED/CORE--op--qr.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--qr.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--quotemeta.t b/t/C-COMPILED/CORE--op--quotemeta.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--quotemeta.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--rand.t b/t/C-COMPILED/CORE--op--rand.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--rand.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--range.t b/t/C-COMPILED/CORE--op--range.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--range.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--read.t b/t/C-COMPILED/CORE--op--read.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--read.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--readdir.t b/t/C-COMPILED/CORE--op--readdir.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--readdir.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--readline.t b/t/C-COMPILED/CORE--op--readline.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--readline.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--recurse.t b/t/C-COMPILED/CORE--op--recurse.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--recurse.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--ref==BADTEST-197-285-286.t b/t/C-COMPILED/CORE--op--ref==BADTEST-197-285-286.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--ref==BADTEST-197-285-286.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--repeat.t b/t/C-COMPILED/CORE--op--repeat.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--repeat.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--require_errors.t b/t/C-COMPILED/CORE--op--require_errors.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--require_errors.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--reset.t b/t/C-COMPILED/CORE--op--reset.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--reset.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--reverse.t b/t/C-COMPILED/CORE--op--reverse.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--reverse.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--runlevel.t b/t/C-COMPILED/CORE--op--runlevel.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--runlevel.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--setpgrpstack.t b/t/C-COMPILED/CORE--op--setpgrpstack.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--setpgrpstack.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--sigdispatch.t b/t/C-COMPILED/CORE--op--sigdispatch.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--sigdispatch.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--sleep.t b/t/C-COMPILED/CORE--op--sleep.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--sleep.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--smartkve.t b/t/C-COMPILED/CORE--op--smartkve.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--smartkve.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--smartmatch==BADTEST-179.t b/t/C-COMPILED/CORE--op--smartmatch==BADTEST-179.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--smartmatch==BADTEST-179.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--sort.t b/t/C-COMPILED/CORE--op--sort.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--sort.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--splice.t b/t/C-COMPILED/CORE--op--splice.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--splice.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--split.t b/t/C-COMPILED/CORE--op--split.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--split.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--split_unicode.t b/t/C-COMPILED/CORE--op--split_unicode.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--split_unicode.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--sprintf.t b/t/C-COMPILED/CORE--op--sprintf.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--sprintf.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--sprintf2.t b/t/C-COMPILED/CORE--op--sprintf2.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--sprintf2.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--srand.t b/t/C-COMPILED/CORE--op--srand.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--srand.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--sselect.t b/t/C-COMPILED/CORE--op--sselect.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--sselect.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--stash.t b/t/C-COMPILED/CORE--op--stash.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--stash.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--stat.t b/t/C-COMPILED/CORE--op--stat.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--stat.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--state.t b/t/C-COMPILED/CORE--op--state.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--state.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--study.t b/t/C-COMPILED/CORE--op--study.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--study.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--studytied.t b/t/C-COMPILED/CORE--op--studytied.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--studytied.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--sub.t b/t/C-COMPILED/CORE--op--sub.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--sub.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--sub_lval.t b/t/C-COMPILED/CORE--op--sub_lval.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--sub_lval.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--svleak.t b/t/C-COMPILED/CORE--op--svleak.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--svleak.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--switch==BADTEST-180.t b/t/C-COMPILED/CORE--op--switch==BADTEST-180.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--switch==BADTEST-180.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--symbolcache.t b/t/C-COMPILED/CORE--op--symbolcache.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--symbolcache.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--sysio.t b/t/C-COMPILED/CORE--op--sysio.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--sysio.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--taint==BADPLAN-288+BADTEST-288.t b/t/C-COMPILED/CORE--op--taint==BADPLAN-288+BADTEST-288.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--taint==BADPLAN-288+BADTEST-288.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--tie.t b/t/C-COMPILED/CORE--op--tie.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--tie.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--tie_fetch_count.t b/t/C-COMPILED/CORE--op--tie_fetch_count.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--tie_fetch_count.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--tiearray.t b/t/C-COMPILED/CORE--op--tiearray.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--tiearray.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--tiehandle.t b/t/C-COMPILED/CORE--op--tiehandle.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--tiehandle.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--time.t b/t/C-COMPILED/CORE--op--time.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--time.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--time_loop.t b/t/C-COMPILED/CORE--op--time_loop.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--time_loop.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--tr.t b/t/C-COMPILED/CORE--op--tr.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--tr.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--turkish.t b/t/C-COMPILED/CORE--op--turkish.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--turkish.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--undef.t b/t/C-COMPILED/CORE--op--undef.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--undef.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--universal==BADTEST-299.t b/t/C-COMPILED/CORE--op--universal==BADTEST-299.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--universal==BADTEST-299.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--unshift.t b/t/C-COMPILED/CORE--op--unshift.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--unshift.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--upgrade.t b/t/C-COMPILED/CORE--op--upgrade.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--upgrade.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--utf8cache.t b/t/C-COMPILED/CORE--op--utf8cache.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--utf8cache.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--utf8decode.t b/t/C-COMPILED/CORE--op--utf8decode.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--utf8decode.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--utf8magic.t b/t/C-COMPILED/CORE--op--utf8magic.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--utf8magic.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--utfhash.t b/t/C-COMPILED/CORE--op--utfhash.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--utfhash.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--utftaint.t b/t/C-COMPILED/CORE--op--utftaint.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--utftaint.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--vec.t b/t/C-COMPILED/CORE--op--vec.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--vec.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--ver.t b/t/C-COMPILED/CORE--op--ver.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--ver.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--wantarray.t b/t/C-COMPILED/CORE--op--wantarray.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--wantarray.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--warn.t b/t/C-COMPILED/CORE--op--warn.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--warn.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--while_readdir.t b/t/C-COMPILED/CORE--op--while_readdir.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--while_readdir.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--write==BADTEST-238.t b/t/C-COMPILED/CORE--op--write==BADTEST-238.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--write==BADTEST-238.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--op--yadayada.t b/t/C-COMPILED/CORE--op--yadayada.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--op--yadayada.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--re--charset.t b/t/C-COMPILED/CORE--re--charset.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--re--charset.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--re--fold_grind.t b/t/C-COMPILED/CORE--re--fold_grind.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--re--fold_grind.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--re--no_utf8_pm.t b/t/C-COMPILED/CORE--re--no_utf8_pm.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--re--no_utf8_pm.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--re--overload==BADTEST-335.t b/t/C-COMPILED/CORE--re--overload==BADTEST-335.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--re--overload==BADTEST-335.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--re--pat==BADTEST-274.t b/t/C-COMPILED/CORE--re--pat==BADTEST-274.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--re--pat==BADTEST-274.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--re--pat_advanced.t b/t/C-COMPILED/CORE--re--pat_advanced.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--re--pat_advanced.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--re--pat_psycho.t b/t/C-COMPILED/CORE--re--pat_psycho.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--re--pat_psycho.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--re--pat_re_eval==SIG-332.t b/t/C-COMPILED/CORE--re--pat_re_eval==SIG-332.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--re--pat_re_eval==SIG-332.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--re--pat_rt_report.t b/t/C-COMPILED/CORE--re--pat_rt_report.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--re--pat_rt_report.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--re--pat_special_cc.t b/t/C-COMPILED/CORE--re--pat_special_cc.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--re--pat_special_cc.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--re--qr-72922.t b/t/C-COMPILED/CORE--re--qr-72922.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--re--qr-72922.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--re--qr.t b/t/C-COMPILED/CORE--re--qr.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--re--qr.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--re--qr_gc.t b/t/C-COMPILED/CORE--re--qr_gc.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--re--qr_gc.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--re--qrstack.t b/t/C-COMPILED/CORE--re--qrstack.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--re--qrstack.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--re--reg_60508.t b/t/C-COMPILED/CORE--re--reg_60508.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--re--reg_60508.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--re--reg_email.t b/t/C-COMPILED/CORE--re--reg_email.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--re--reg_email.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--re--reg_eval.t b/t/C-COMPILED/CORE--re--reg_eval.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--re--reg_eval.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--re--reg_eval_scope.t b/t/C-COMPILED/CORE--re--reg_eval_scope.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--re--reg_eval_scope.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--re--reg_fold.t b/t/C-COMPILED/CORE--re--reg_fold.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--re--reg_fold.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--re--reg_mesg.t b/t/C-COMPILED/CORE--re--reg_mesg.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--re--reg_mesg.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--re--reg_namedcapture.t b/t/C-COMPILED/CORE--re--reg_namedcapture.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--re--reg_namedcapture.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--re--reg_nc_tie.t b/t/C-COMPILED/CORE--re--reg_nc_tie.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--re--reg_nc_tie.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--re--reg_pmod.t b/t/C-COMPILED/CORE--re--reg_pmod.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--re--reg_pmod.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--re--reg_posixcc.t b/t/C-COMPILED/CORE--re--reg_posixcc.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--re--reg_posixcc.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--re--regexp_unicode_prop.t b/t/C-COMPILED/CORE--re--regexp_unicode_prop.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--re--regexp_unicode_prop.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--re--rxcode.t b/t/C-COMPILED/CORE--re--rxcode.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--re--rxcode.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--re--subst.t b/t/C-COMPILED/CORE--re--subst.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--re--subst.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--re--subst_amp.t b/t/C-COMPILED/CORE--re--subst_amp.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--re--subst_amp.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/CORE--re--substr.t b/t/C-COMPILED/CORE--re--substr.t deleted file mode 120000 index 29c56be30..000000000 --- a/t/C-COMPILED/CORE--re--substr.t +++ /dev/null @@ -1 +0,0 @@ -template.pl \ No newline at end of file diff --git a/t/C-COMPILED/template.pl b/t/C-COMPILED/template.pl deleted file mode 100644 index 7ad767527..000000000 --- a/t/C-COMPILED/template.pl +++ /dev/null @@ -1,181 +0,0 @@ -#!perl - -use strict; -use warnings; - -use TAP::Harness (); -use IO::Scalar; - -use Test::More; - -#my @optimizations = ( '-O2,-fno-fold', '-O1' ); -my @optimizations = $ENV{BC_OPT} ? split(/\s+/,$ENV{BC_OPT}) : ('-O0','-O3'); -my $todo = ''; - -# Setup file_to_test to be the file we actually want to test. -my $file_to_test = $0; -if ( $file_to_test =~ s{==(.*)\.t$}{.t} ) { - my $options = $1; - $todo .= "B::C Fails to generate c code. Issues: $1." if $options =~ /BC-([\d-]+)/; - $todo .= "gcc cannot compile generated c code. Issues: $1." if $options =~ /GCC-([\d-]+)/; - $todo .= "Compiled binary exits with signal. Issues: $1." if $options =~ /SIG-([\d-]+)/; - $todo .= "Test ends before completion. Issues: $1." if $options =~ /BADPLAN-([\d-]+)/; - $todo .= "Fails tests when compiled with perlcc. Issues: $1." if $options =~ /BADTEST-([\d-]+)/; - $todo .= "Tests out of sequence. Issues: $1." if $options =~ /SEQ-([\d-]+)/; - $todo .= "TODO test unexpectedly passing. Issues: $1." if $options =~ /TODO-([\d-]+)/; -} - -$file_to_test =~ s{--}{/}g; -$file_to_test =~ s{C-COMPILED/}{}; # Strip the BINARY dir off to look for this test elsewhere. -if ($file_to_test =~ m{^t/xtestc/} and !-f $file_to_test) { - mkdir 't/xtestc'; - my ($num) = $file_to_test =~ m{xtestc/(\d+).t}; - `t/testc.sh -X $num > $file_to_test`; -} - -if ( $] < 5.014 && $file_to_test =~ m{^t/CORE/} ) { - plan skip_all => "Perl CORE tests only supported since 5.14 right now."; -} -else { - plan tests => 3 + 10 * scalar @optimizations; -} - -ok( !-z $file_to_test, "$file_to_test exists" ); - -open( my $fh, '<', $file_to_test ) or die("Can't open $file_to_test"); -my $taint = <$fh>; -close $fh; -$taint = ( ( $taint =~ m/\s\-T/ ) ? '-T' : '' ); -pass( $taint ? "Taint mode!" : "Not in taint mode" ); - -( my $c_file = $file_to_test ) =~ s/\.t$/.c/; -( my $bin_file = $file_to_test ) =~ s/\.t$/.bin/; -unlink $bin_file, $c_file; - -my $PERL = $^X =~ m/\s/ ? qq{"$^X"} : $^X; - -my $check = `$PERL -c $taint '$file_to_test' 2>&1`; -like( $check, qr/syntax OK/, "$PERL -c $taint $file_to_test" ); - -$ENV{HARNESS_NOTTY} = 1; - -my %SIGNALS = qw( 11 SEGV 6 SIGABRT 1 SIGHUP 13 SIGPIPE); -$SIGNALS{0} = ''; - -foreach my $optimization (@optimizations) { -TODO: { - SKIP: { - local $TODO = $todo if ( $todo =~ /B::C Fails to generate c code/ ); - local $ENV{BC_OPT} = $optimization; - - my $b = $optimization; # protect against parallel test name clashes - #$b =~ s/-(D.*|f.*|v),//g; - #$b =~ s/-/_/g; - #$b =~ s/[, ]//g; - #$b =~ s/_O0$//; - #$b = lc($b); - $b = ''; # need to check $0 diagnostics - ( $c_file = $file_to_test ) =~ s/\.t$/$b.c/; - $b = '.bin'; # need to check $0 diagnostics - ( $bin_file = $file_to_test ) =~ s/\.t$/$b/; - unlink $bin_file, $c_file; - - # Generate the C code at $optimization level - my $cmd = "$PERL $taint -Iblib/arch -Iblib/lib -MO=-qq,C,$optimization,-o$c_file $file_to_test 2>&1"; - - diag $cmd if $ENV{TEST_VERBOSE}; - my $BC_output = `$cmd`; - note $BC_output if ($BC_output); - ok( !-z $c_file, "$c_file is generated ($optimization)" ); - - if ( -z $c_file ) { - unlink $c_file; - skip( "Can't test further due to failure to create a c file.", 9 ); - } - - # gcc the c code. - local $TODO = $todo if ( $todo =~ /gcc cannot compile generated c code/ ); - - $cmd = "$PERL -Iblib/arch -Iblib/lib script/cc_harness -q $c_file -o $bin_file 2>&1"; - diag $cmd if $ENV{TEST_VERBOSE}; - my $compile_output = `$cmd`; - note $compile_output if $compile_output; - - # Validate compiles - ok( -x $bin_file, "$bin_file is compiled and ready to run." ); - - if ( !-x $bin_file ) { - unlink $c_file, $bin_file unless $ENV{BC_DEVELOPING}; - skip( "Can't test further due to failure to create a binary file.", 8 ); - } - - # Parse through TAP::Harness - my $out = ''; - my $out_fh = new IO::Scalar \$out; - - my %args = ( - verbosity => 1, - lib => [], - merge => 1, - stdout => $out_fh, - ); - my $harness = TAP::Harness->new( \%args ); - my $res = $harness->runtests($bin_file); - close $out_fh; - - my $parser = $res->{parser_for}->{$bin_file}; - ok( $parser, "Output parsed by TAP::Harness" ); - - my $signal = $res->{wait} % 256; - if ( $todo =~ /Compiled binary exits with signal/ ) { - local $TODO = "$todo"; - my $sig_name = $SIGNALS{$signal}; - ok( $signal == 0, "Exit signal is $signal ($sig_name)" ); - note $out if ($out); - skip( "Test failures irrelevant if exits premature with $sig_name", 6 ); - } - else { - ok( $signal == 0, "Exit signal is $signal" ); - } - - if ( $todo =~ m/Test ends before completion/ ) { - local $TODO = $todo; - ok( $parser->{is_good_plan}, "Plan was valid" ); - note $out; - skip( "TAP parse is unpredictable when plan is invalid", 5 ); - } - else { - ok( $parser->{is_good_plan}, "Plan was valid" ); - } - - ok( $parser->{exit} == 0, "Exit code is $parser->{exit}" ); - - local $TODO = "Tests don't pass at the moment - $todo" - if ( $todo =~ /Fails tests when compiled with perlcc/ ); - ok( !scalar @{ $parser->{failed} }, "Test results:" ); - print " $_\n" foreach ( split( "\n", $out ) ); - - if (!ok( !scalar @{ $parser->{failed} }, "No test failures $optimization" )) { - note( "Failed $optimization tests: " . join( ", ", @{ $parser->{failed} } ) ); - $ENV{BC_DEVELOPING} = 1; # keep temp files - } - - skip( "Don't care about test sequence if tests are failing", 2 ) - if ( $todo =~ /Fails tests when compiled with perlcc/ ); - - local $TODO = $todo if ( $todo =~ m/Tests out of sequence/ ); - if (!ok( !scalar @{ $parser->{parse_errors} }, "Tests are in sequence" )) { - note explain $parser->{parse_errors}; - $ENV{BC_DEVELOPING} = 1; # keep temp files - } - - local $TODO = "tests unexpectedly passing" if scalar @{ $parser->{todo_passed} }; - if (!ok( !scalar @{ $parser->{todo_passed} }, "No TODO tests passed $optimization" )) { - note( "TODO Passed: " . join( ", ", @{ $parser->{todo_passed} } ) ); - $ENV{BC_DEVELOPING} = 1; # keep temp files - } - $TODO = ''; - } - } - unlink $bin_file, $c_file unless $ENV{BC_DEVELOPING}; -} diff --git a/t/C-COMPILED/testc.pl b/t/C-COMPILED/testc.pl deleted file mode 100755 index a38e42920..000000000 --- a/t/C-COMPILED/testc.pl +++ /dev/null @@ -1,127 +0,0 @@ -#!perl - -use strict; -use warnings; -use open ':std', ':encoding(utf8)'; - -use IO::Scalar; -use Cwd; -use File::Basename; -use Test::More; - -if ( $0 =~ m{/testc\.pl$} ) { - plan q{skip_all} => "This program is not designed to be called directly"; - exit; -} - -my @optimizations = $ENV{'BC_TEST_OPTIMIZATIONS'} || ('-O3', '-O0'); -$optimizations[0] .= ',-v' if $ENV{VERBOSE}; -$optimizations[0] .= ',-fwalkall' if $ENV{BC_WALK}; - -# Setup file_to_test to be the file we actually want to test. -my ( $file_to_test, $path ) = fileparse($0); -my ( $before, $after ) = split( 'C-COMPILED/', $path ); -my $short_path = $path; -$short_path =~ s{^.*C-COMPILED/+}{}; -$file_to_test = $short_path . $file_to_test; - -# The relative path our symlinks will point to. -my $base_dir = dirname($path); - -my $current_t_file = $file_to_test; -my $to_skip = 0; - -plan tests => scalar @optimizations; - -# need to run CORE test suite in C-COMPILED -$file_to_test =~ m/0*(\d+?)\.t/ or - die("$file_to_test cannot be recognized as a testc test!"); -my $testc_test = $1; -my $test_code = `t/testc.sh -X $testc_test 2>/dev/null`; - -### RESULT:133 -$test_code =~ s/### RESULT:(.+)$//ms; -my $want = $1; - -( my $perl_file = $file_to_test ) =~ s/xtestc-(.*)\.t$/ccode-xt$1.pl/; -( my $c_file = $file_to_test ) =~ s/xtestc-(.*)\.t$/ccode-xt$1.c/; -( my $bin_file = $file_to_test ) =~ s/xtestc-(.*)\.t$/ccode-xt$1.bin/; - -END { unlink $bin_file, $c_file, $perl_file unless $ENV{BC_DEVEL}; } - -open( my $fh, '>', $perl_file ) or die "Can't write $perl_file"; -print {$fh} $test_code; -close $fh; - -my $PERL = $^X =~ m/\s/ ? qq{"$^X"} : $^X; -my $blib = ( grep { m{blib/} } @INC ) ? '-Iblib/arch -Iblib/lib' : ''; - -SKIP: { - - my $check = qx{$PERL -c '$perl_file' 2>&1}; - unless ( $check =~ qr/syntax OK/ ) { - skip( "Cannot compile with perl -c", 5 ); - exit; - } - - $ENV{HARNESS_NOTTY} = 1; - - my %SIGNALS = qw( 11 SEGV 6 SIGABRT 1 SIGHUP 13 SIGPIPE); - $SIGNALS{0} = ''; - - foreach my $optimization (@optimizations) { - TODO: SKIP: { - local $TODO; - - # lazy way to count and keep the skip counter up to date - $to_skip = 5; - - # Generate the C code at $optimization level - my $cmd = "$PERL $blib -MO=-qq,C,$optimization,-o$c_file $perl_file 2>&1"; - - diag $cmd if $ENV{VERBOSE}; - my $BC_output = `$cmd`; - note $BC_output if ($BC_output); - unless ( -e $c_file && !-z _) { - unlink $c_file unless $ENV{BC_DEVEL}; - skip( "Can't test further due to failure to create a c file.", $to_skip ); - } - - # gcc the c code. - my $harness_opts = ''; - $harness_opts = '-Wall' if $ENV{VERBOSE} && $ENV{WARNINGS}; - $harness_opts .= $ENV{VERBOSE} ? '' : ' -q'; - $cmd = "$PERL $blib script/cc_harness $harness_opts $c_file -o $bin_file 2>&1"; - diag $cmd if $ENV{VERBOSE}; - my $compile_output = qx{$cmd}; - note $compile_output if ($compile_output); - - # Validate compiles - unless ( -x $bin_file ) { - unlink $c_file, $bin_file unless $ENV{BC_DEVEL}; - skip( "Can't test further due to failure to create a binary file.", - $to_skip ); - } - - # Parse through TAP::Harness - my $out = qx{./$bin_file 2>&1} || ""; - my $signal = $? % 256; - my $exit_code = $? >> 8; - chomp $want; - chomp $out; - - if (!is($out, $want, $file_to_test)) { - $out = `$PERL $perl_file 2>&1`; - chomp $out; - diag "pure perl fails also" if $out ne $want; - } - - my $sig_name = $SIGNALS{$signal} || ''; - unless ( $signal == 0 ) { - note $out if ($out); - skip( "Test failures irrelevant if exits premature with $sig_name", - $to_skip ); - }} - } -} -exit; diff --git a/t/CORE b/t/CORE new file mode 160000 index 000000000..9d232e5f0 --- /dev/null +++ b/t/CORE @@ -0,0 +1 @@ +Subproject commit 9d232e5f016c19c7d6fc8646be937cf5cb046d43 diff --git a/t/CORE/CaseFolding.txt b/t/CORE/CaseFolding.txt deleted file mode 100644 index ffe6173d7..000000000 --- a/t/CORE/CaseFolding.txt +++ /dev/null @@ -1,1211 +0,0 @@ -# CaseFolding-6.0.0.txt -# Date: 2010-05-18, 00:48:57 GMT [MD] -# -# Unicode Character Database -# Copyright (c) 1991-2010 Unicode, Inc. -# For terms of use, see http://www.unicode.org/terms_of_use.html -# For documentation, see http://www.unicode.org/reports/tr44/ -# -# Case Folding Properties -# -# This file is a supplement to the UnicodeData file. -# It provides a case folding mapping generated from the Unicode Character Database. -# If all characters are mapped according to the full mapping below, then -# case differences (according to UnicodeData.txt and SpecialCasing.txt) -# are eliminated. -# -# The data supports both implementations that require simple case foldings -# (where string lengths don't change), and implementations that allow full case folding -# (where string lengths may grow). Note that where they can be supported, the -# full case foldings are superior: for example, they allow "MASSE" and "Maße" to match. -# -# All code points not listed in this file map to themselves. -# -# NOTE: case folding does not preserve normalization formats! -# -# For information on case folding, including how to have case folding -# preserve normalization formats, see Section 3.13 Default Case Algorithms in -# The Unicode Standard, Version 5.0. -# -# ================================================================================ -# Format -# ================================================================================ -# The entries in this file are in the following machine-readable format: -# -# ; ; ; # -# -# The status field is: -# C: common case folding, common mappings shared by both simple and full mappings. -# F: full case folding, mappings that cause strings to grow in length. Multiple characters are separated by spaces. -# S: simple case folding, mappings to single characters where different from F. -# T: special case for uppercase I and dotted uppercase I -# - For non-Turkic languages, this mapping is normally not used. -# - For Turkic languages (tr, az), this mapping can be used instead of the normal mapping for these characters. -# Note that the Turkic mappings do not maintain canonical equivalence without additional processing. -# See the discussions of case mapping in the Unicode Standard for more information. -# -# Usage: -# A. To do a simple case folding, use the mappings with status C + S. -# B. To do a full case folding, use the mappings with status C + F. -# -# The mappings with status T can be used or omitted depending on the desired case-folding -# behavior. (The default option is to exclude them.) -# -# ================================================================= -# @missing 0000..10FFFF; -0041; C; 0061; # LATIN CAPITAL LETTER A -0042; C; 0062; # LATIN CAPITAL LETTER B -0043; C; 0063; # LATIN CAPITAL LETTER C -0044; C; 0064; # LATIN CAPITAL LETTER D -0045; C; 0065; # LATIN CAPITAL LETTER E -0046; C; 0066; # LATIN CAPITAL LETTER F -0047; C; 0067; # LATIN CAPITAL LETTER G -0048; C; 0068; # LATIN CAPITAL LETTER H -0049; C; 0069; # LATIN CAPITAL LETTER I -0049; T; 0131; # LATIN CAPITAL LETTER I -004A; C; 006A; # LATIN CAPITAL LETTER J -004B; C; 006B; # LATIN CAPITAL LETTER K -004C; C; 006C; # LATIN CAPITAL LETTER L -004D; C; 006D; # LATIN CAPITAL LETTER M -004E; C; 006E; # LATIN CAPITAL LETTER N -004F; C; 006F; # LATIN CAPITAL LETTER O -0050; C; 0070; # LATIN CAPITAL LETTER P -0051; C; 0071; # LATIN CAPITAL LETTER Q -0052; C; 0072; # LATIN CAPITAL LETTER R -0053; C; 0073; # LATIN CAPITAL LETTER S -0054; C; 0074; # LATIN CAPITAL LETTER T -0055; C; 0075; # LATIN CAPITAL LETTER U -0056; C; 0076; # LATIN CAPITAL LETTER V -0057; C; 0077; # LATIN CAPITAL LETTER W -0058; C; 0078; # LATIN CAPITAL LETTER X -0059; C; 0079; # LATIN CAPITAL LETTER Y -005A; C; 007A; # LATIN CAPITAL LETTER Z -00B5; C; 03BC; # MICRO SIGN -00C0; C; 00E0; # LATIN CAPITAL LETTER A WITH GRAVE -00C1; C; 00E1; # LATIN CAPITAL LETTER A WITH ACUTE -00C2; C; 00E2; # LATIN CAPITAL LETTER A WITH CIRCUMFLEX -00C3; C; 00E3; # LATIN CAPITAL LETTER A WITH TILDE -00C4; C; 00E4; # LATIN CAPITAL LETTER A WITH DIAERESIS -00C5; C; 00E5; # LATIN CAPITAL LETTER A WITH RING ABOVE -00C6; C; 00E6; # LATIN CAPITAL LETTER AE -00C7; C; 00E7; # LATIN CAPITAL LETTER C WITH CEDILLA -00C8; C; 00E8; # LATIN CAPITAL LETTER E WITH GRAVE -00C9; C; 00E9; # LATIN CAPITAL LETTER E WITH ACUTE -00CA; C; 00EA; # LATIN CAPITAL LETTER E WITH CIRCUMFLEX -00CB; C; 00EB; # LATIN CAPITAL LETTER E WITH DIAERESIS -00CC; C; 00EC; # LATIN CAPITAL LETTER I WITH GRAVE -00CD; C; 00ED; # LATIN CAPITAL LETTER I WITH ACUTE -00CE; C; 00EE; # LATIN CAPITAL LETTER I WITH CIRCUMFLEX -00CF; C; 00EF; # LATIN CAPITAL LETTER I WITH DIAERESIS -00D0; C; 00F0; # LATIN CAPITAL LETTER ETH -00D1; C; 00F1; # LATIN CAPITAL LETTER N WITH TILDE -00D2; C; 00F2; # LATIN CAPITAL LETTER O WITH GRAVE -00D3; C; 00F3; # LATIN CAPITAL LETTER O WITH ACUTE -00D4; C; 00F4; # LATIN CAPITAL LETTER O WITH CIRCUMFLEX -00D5; C; 00F5; # LATIN CAPITAL LETTER O WITH TILDE -00D6; C; 00F6; # LATIN CAPITAL LETTER O WITH DIAERESIS -00D8; C; 00F8; # LATIN CAPITAL LETTER O WITH STROKE -00D9; C; 00F9; # LATIN CAPITAL LETTER U WITH GRAVE -00DA; C; 00FA; # LATIN CAPITAL LETTER U WITH ACUTE -00DB; C; 00FB; # LATIN CAPITAL LETTER U WITH CIRCUMFLEX -00DC; C; 00FC; # LATIN CAPITAL LETTER U WITH DIAERESIS -00DD; C; 00FD; # LATIN CAPITAL LETTER Y WITH ACUTE -00DE; C; 00FE; # LATIN CAPITAL LETTER THORN -00DF; F; 0073 0073; # LATIN SMALL LETTER SHARP S -0100; C; 0101; # LATIN CAPITAL LETTER A WITH MACRON -0102; C; 0103; # LATIN CAPITAL LETTER A WITH BREVE -0104; C; 0105; # LATIN CAPITAL LETTER A WITH OGONEK -0106; C; 0107; # LATIN CAPITAL LETTER C WITH ACUTE -0108; C; 0109; # LATIN CAPITAL LETTER C WITH CIRCUMFLEX -010A; C; 010B; # LATIN CAPITAL LETTER C WITH DOT ABOVE -010C; C; 010D; # LATIN CAPITAL LETTER C WITH CARON -010E; C; 010F; # LATIN CAPITAL LETTER D WITH CARON -0110; C; 0111; # LATIN CAPITAL LETTER D WITH STROKE -0112; C; 0113; # LATIN CAPITAL LETTER E WITH MACRON -0114; C; 0115; # LATIN CAPITAL LETTER E WITH BREVE -0116; C; 0117; # LATIN CAPITAL LETTER E WITH DOT ABOVE -0118; C; 0119; # LATIN CAPITAL LETTER E WITH OGONEK -011A; C; 011B; # LATIN CAPITAL LETTER E WITH CARON -011C; C; 011D; # LATIN CAPITAL LETTER G WITH CIRCUMFLEX -011E; C; 011F; # LATIN CAPITAL LETTER G WITH BREVE -0120; C; 0121; # LATIN CAPITAL LETTER G WITH DOT ABOVE -0122; C; 0123; # LATIN CAPITAL LETTER G WITH CEDILLA -0124; C; 0125; # LATIN CAPITAL LETTER H WITH CIRCUMFLEX -0126; C; 0127; # LATIN CAPITAL LETTER H WITH STROKE -0128; C; 0129; # LATIN CAPITAL LETTER I WITH TILDE -012A; C; 012B; # LATIN CAPITAL LETTER I WITH MACRON -012C; C; 012D; # LATIN CAPITAL LETTER I WITH BREVE -012E; C; 012F; # LATIN CAPITAL LETTER I WITH OGONEK -0130; F; 0069 0307; # LATIN CAPITAL LETTER I WITH DOT ABOVE -0130; T; 0069; # LATIN CAPITAL LETTER I WITH DOT ABOVE -0132; C; 0133; # LATIN CAPITAL LIGATURE IJ -0134; C; 0135; # LATIN CAPITAL LETTER J WITH CIRCUMFLEX -0136; C; 0137; # LATIN CAPITAL LETTER K WITH CEDILLA -0139; C; 013A; # LATIN CAPITAL LETTER L WITH ACUTE -013B; C; 013C; # LATIN CAPITAL LETTER L WITH CEDILLA -013D; C; 013E; # LATIN CAPITAL LETTER L WITH CARON -013F; C; 0140; # LATIN CAPITAL LETTER L WITH MIDDLE DOT -0141; C; 0142; # LATIN CAPITAL LETTER L WITH STROKE -0143; C; 0144; # LATIN CAPITAL LETTER N WITH ACUTE -0145; C; 0146; # LATIN CAPITAL LETTER N WITH CEDILLA -0147; C; 0148; # LATIN CAPITAL LETTER N WITH CARON -0149; F; 02BC 006E; # LATIN SMALL LETTER N PRECEDED BY APOSTROPHE -014A; C; 014B; # LATIN CAPITAL LETTER ENG -014C; C; 014D; # LATIN CAPITAL LETTER O WITH MACRON -014E; C; 014F; # LATIN CAPITAL LETTER O WITH BREVE -0150; C; 0151; # LATIN CAPITAL LETTER O WITH DOUBLE ACUTE -0152; C; 0153; # LATIN CAPITAL LIGATURE OE -0154; C; 0155; # LATIN CAPITAL LETTER R WITH ACUTE -0156; C; 0157; # LATIN CAPITAL LETTER R WITH CEDILLA -0158; C; 0159; # LATIN CAPITAL LETTER R WITH CARON -015A; C; 015B; # LATIN CAPITAL LETTER S WITH ACUTE -015C; C; 015D; # LATIN CAPITAL LETTER S WITH CIRCUMFLEX -015E; C; 015F; # LATIN CAPITAL LETTER S WITH CEDILLA -0160; C; 0161; # LATIN CAPITAL LETTER S WITH CARON -0162; C; 0163; # LATIN CAPITAL LETTER T WITH CEDILLA -0164; C; 0165; # LATIN CAPITAL LETTER T WITH CARON -0166; C; 0167; # LATIN CAPITAL LETTER T WITH STROKE -0168; C; 0169; # LATIN CAPITAL LETTER U WITH TILDE -016A; C; 016B; # LATIN CAPITAL LETTER U WITH MACRON -016C; C; 016D; # LATIN CAPITAL LETTER U WITH BREVE -016E; C; 016F; # LATIN CAPITAL LETTER U WITH RING ABOVE -0170; C; 0171; # LATIN CAPITAL LETTER U WITH DOUBLE ACUTE -0172; C; 0173; # LATIN CAPITAL LETTER U WITH OGONEK -0174; C; 0175; # LATIN CAPITAL LETTER W WITH CIRCUMFLEX -0176; C; 0177; # LATIN CAPITAL LETTER Y WITH CIRCUMFLEX -0178; C; 00FF; # LATIN CAPITAL LETTER Y WITH DIAERESIS -0179; C; 017A; # LATIN CAPITAL LETTER Z WITH ACUTE -017B; C; 017C; # LATIN CAPITAL LETTER Z WITH DOT ABOVE -017D; C; 017E; # LATIN CAPITAL LETTER Z WITH CARON -017F; C; 0073; # LATIN SMALL LETTER LONG S -0181; C; 0253; # LATIN CAPITAL LETTER B WITH HOOK -0182; C; 0183; # LATIN CAPITAL LETTER B WITH TOPBAR -0184; C; 0185; # LATIN CAPITAL LETTER TONE SIX -0186; C; 0254; # LATIN CAPITAL LETTER OPEN O -0187; C; 0188; # LATIN CAPITAL LETTER C WITH HOOK -0189; C; 0256; # LATIN CAPITAL LETTER AFRICAN D -018A; C; 0257; # LATIN CAPITAL LETTER D WITH HOOK -018B; C; 018C; # LATIN CAPITAL LETTER D WITH TOPBAR -018E; C; 01DD; # LATIN CAPITAL LETTER REVERSED E -018F; C; 0259; # LATIN CAPITAL LETTER SCHWA -0190; C; 025B; # LATIN CAPITAL LETTER OPEN E -0191; C; 0192; # LATIN CAPITAL LETTER F WITH HOOK -0193; C; 0260; # LATIN CAPITAL LETTER G WITH HOOK -0194; C; 0263; # LATIN CAPITAL LETTER GAMMA -0196; C; 0269; # LATIN CAPITAL LETTER IOTA -0197; C; 0268; # LATIN CAPITAL LETTER I WITH STROKE -0198; C; 0199; # LATIN CAPITAL LETTER K WITH HOOK -019C; C; 026F; # LATIN CAPITAL LETTER TURNED M -019D; C; 0272; # LATIN CAPITAL LETTER N WITH LEFT HOOK -019F; C; 0275; # LATIN CAPITAL LETTER O WITH MIDDLE TILDE -01A0; C; 01A1; # LATIN CAPITAL LETTER O WITH HORN -01A2; C; 01A3; # LATIN CAPITAL LETTER OI -01A4; C; 01A5; # LATIN CAPITAL LETTER P WITH HOOK -01A6; C; 0280; # LATIN LETTER YR -01A7; C; 01A8; # LATIN CAPITAL LETTER TONE TWO -01A9; C; 0283; # LATIN CAPITAL LETTER ESH -01AC; C; 01AD; # LATIN CAPITAL LETTER T WITH HOOK -01AE; C; 0288; # LATIN CAPITAL LETTER T WITH RETROFLEX HOOK -01AF; C; 01B0; # LATIN CAPITAL LETTER U WITH HORN -01B1; C; 028A; # LATIN CAPITAL LETTER UPSILON -01B2; C; 028B; # LATIN CAPITAL LETTER V WITH HOOK -01B3; C; 01B4; # LATIN CAPITAL LETTER Y WITH HOOK -01B5; C; 01B6; # LATIN CAPITAL LETTER Z WITH STROKE -01B7; C; 0292; # LATIN CAPITAL LETTER EZH -01B8; C; 01B9; # LATIN CAPITAL LETTER EZH REVERSED -01BC; C; 01BD; # LATIN CAPITAL LETTER TONE FIVE -01C4; C; 01C6; # LATIN CAPITAL LETTER DZ WITH CARON -01C5; C; 01C6; # LATIN CAPITAL LETTER D WITH SMALL LETTER Z WITH CARON -01C7; C; 01C9; # LATIN CAPITAL LETTER LJ -01C8; C; 01C9; # LATIN CAPITAL LETTER L WITH SMALL LETTER J -01CA; C; 01CC; # LATIN CAPITAL LETTER NJ -01CB; C; 01CC; # LATIN CAPITAL LETTER N WITH SMALL LETTER J -01CD; C; 01CE; # LATIN CAPITAL LETTER A WITH CARON -01CF; C; 01D0; # LATIN CAPITAL LETTER I WITH CARON -01D1; C; 01D2; # LATIN CAPITAL LETTER O WITH CARON -01D3; C; 01D4; # LATIN CAPITAL LETTER U WITH CARON -01D5; C; 01D6; # LATIN CAPITAL LETTER U WITH DIAERESIS AND MACRON -01D7; C; 01D8; # LATIN CAPITAL LETTER U WITH DIAERESIS AND ACUTE -01D9; C; 01DA; # LATIN CAPITAL LETTER U WITH DIAERESIS AND CARON -01DB; C; 01DC; # LATIN CAPITAL LETTER U WITH DIAERESIS AND GRAVE -01DE; C; 01DF; # LATIN CAPITAL LETTER A WITH DIAERESIS AND MACRON -01E0; C; 01E1; # LATIN CAPITAL LETTER A WITH DOT ABOVE AND MACRON -01E2; C; 01E3; # LATIN CAPITAL LETTER AE WITH MACRON -01E4; C; 01E5; # LATIN CAPITAL LETTER G WITH STROKE -01E6; C; 01E7; # LATIN CAPITAL LETTER G WITH CARON -01E8; C; 01E9; # LATIN CAPITAL LETTER K WITH CARON -01EA; C; 01EB; # LATIN CAPITAL LETTER O WITH OGONEK -01EC; C; 01ED; # LATIN CAPITAL LETTER O WITH OGONEK AND MACRON -01EE; C; 01EF; # LATIN CAPITAL LETTER EZH WITH CARON -01F0; F; 006A 030C; # LATIN SMALL LETTER J WITH CARON -01F1; C; 01F3; # LATIN CAPITAL LETTER DZ -01F2; C; 01F3; # LATIN CAPITAL LETTER D WITH SMALL LETTER Z -01F4; C; 01F5; # LATIN CAPITAL LETTER G WITH ACUTE -01F6; C; 0195; # LATIN CAPITAL LETTER HWAIR -01F7; C; 01BF; # LATIN CAPITAL LETTER WYNN -01F8; C; 01F9; # LATIN CAPITAL LETTER N WITH GRAVE -01FA; C; 01FB; # LATIN CAPITAL LETTER A WITH RING ABOVE AND ACUTE -01FC; C; 01FD; # LATIN CAPITAL LETTER AE WITH ACUTE -01FE; C; 01FF; # LATIN CAPITAL LETTER O WITH STROKE AND ACUTE -0200; C; 0201; # LATIN CAPITAL LETTER A WITH DOUBLE GRAVE -0202; C; 0203; # LATIN CAPITAL LETTER A WITH INVERTED BREVE -0204; C; 0205; # LATIN CAPITAL LETTER E WITH DOUBLE GRAVE -0206; C; 0207; # LATIN CAPITAL LETTER E WITH INVERTED BREVE -0208; C; 0209; # LATIN CAPITAL LETTER I WITH DOUBLE GRAVE -020A; C; 020B; # LATIN CAPITAL LETTER I WITH INVERTED BREVE -020C; C; 020D; # LATIN CAPITAL LETTER O WITH DOUBLE GRAVE -020E; C; 020F; # LATIN CAPITAL LETTER O WITH INVERTED BREVE -0210; C; 0211; # LATIN CAPITAL LETTER R WITH DOUBLE GRAVE -0212; C; 0213; # LATIN CAPITAL LETTER R WITH INVERTED BREVE -0214; C; 0215; # LATIN CAPITAL LETTER U WITH DOUBLE GRAVE -0216; C; 0217; # LATIN CAPITAL LETTER U WITH INVERTED BREVE -0218; C; 0219; # LATIN CAPITAL LETTER S WITH COMMA BELOW -021A; C; 021B; # LATIN CAPITAL LETTER T WITH COMMA BELOW -021C; C; 021D; # LATIN CAPITAL LETTER YOGH -021E; C; 021F; # LATIN CAPITAL LETTER H WITH CARON -0220; C; 019E; # LATIN CAPITAL LETTER N WITH LONG RIGHT LEG -0222; C; 0223; # LATIN CAPITAL LETTER OU -0224; C; 0225; # LATIN CAPITAL LETTER Z WITH HOOK -0226; C; 0227; # LATIN CAPITAL LETTER A WITH DOT ABOVE -0228; C; 0229; # LATIN CAPITAL LETTER E WITH CEDILLA -022A; C; 022B; # LATIN CAPITAL LETTER O WITH DIAERESIS AND MACRON -022C; C; 022D; # LATIN CAPITAL LETTER O WITH TILDE AND MACRON -022E; C; 022F; # LATIN CAPITAL LETTER O WITH DOT ABOVE -0230; C; 0231; # LATIN CAPITAL LETTER O WITH DOT ABOVE AND MACRON -0232; C; 0233; # LATIN CAPITAL LETTER Y WITH MACRON -023A; C; 2C65; # LATIN CAPITAL LETTER A WITH STROKE -023B; C; 023C; # LATIN CAPITAL LETTER C WITH STROKE -023D; C; 019A; # LATIN CAPITAL LETTER L WITH BAR -023E; C; 2C66; # LATIN CAPITAL LETTER T WITH DIAGONAL STROKE -0241; C; 0242; # LATIN CAPITAL LETTER GLOTTAL STOP -0243; C; 0180; # LATIN CAPITAL LETTER B WITH STROKE -0244; C; 0289; # LATIN CAPITAL LETTER U BAR -0245; C; 028C; # LATIN CAPITAL LETTER TURNED V -0246; C; 0247; # LATIN CAPITAL LETTER E WITH STROKE -0248; C; 0249; # LATIN CAPITAL LETTER J WITH STROKE -024A; C; 024B; # LATIN CAPITAL LETTER SMALL Q WITH HOOK TAIL -024C; C; 024D; # LATIN CAPITAL LETTER R WITH STROKE -024E; C; 024F; # LATIN CAPITAL LETTER Y WITH STROKE -0345; C; 03B9; # COMBINING GREEK YPOGEGRAMMENI -0370; C; 0371; # GREEK CAPITAL LETTER HETA -0372; C; 0373; # GREEK CAPITAL LETTER ARCHAIC SAMPI -0376; C; 0377; # GREEK CAPITAL LETTER PAMPHYLIAN DIGAMMA -0386; C; 03AC; # GREEK CAPITAL LETTER ALPHA WITH TONOS -0388; C; 03AD; # GREEK CAPITAL LETTER EPSILON WITH TONOS -0389; C; 03AE; # GREEK CAPITAL LETTER ETA WITH TONOS -038A; C; 03AF; # GREEK CAPITAL LETTER IOTA WITH TONOS -038C; C; 03CC; # GREEK CAPITAL LETTER OMICRON WITH TONOS -038E; C; 03CD; # GREEK CAPITAL LETTER UPSILON WITH TONOS -038F; C; 03CE; # GREEK CAPITAL LETTER OMEGA WITH TONOS -0390; F; 03B9 0308 0301; # GREEK SMALL LETTER IOTA WITH DIALYTIKA AND TONOS -0391; C; 03B1; # GREEK CAPITAL LETTER ALPHA -0392; C; 03B2; # GREEK CAPITAL LETTER BETA -0393; C; 03B3; # GREEK CAPITAL LETTER GAMMA -0394; C; 03B4; # GREEK CAPITAL LETTER DELTA -0395; C; 03B5; # GREEK CAPITAL LETTER EPSILON -0396; C; 03B6; # GREEK CAPITAL LETTER ZETA -0397; C; 03B7; # GREEK CAPITAL LETTER ETA -0398; C; 03B8; # GREEK CAPITAL LETTER THETA -0399; C; 03B9; # GREEK CAPITAL LETTER IOTA -039A; C; 03BA; # GREEK CAPITAL LETTER KAPPA -039B; C; 03BB; # GREEK CAPITAL LETTER LAMDA -039C; C; 03BC; # GREEK CAPITAL LETTER MU -039D; C; 03BD; # GREEK CAPITAL LETTER NU -039E; C; 03BE; # GREEK CAPITAL LETTER XI -039F; C; 03BF; # GREEK CAPITAL LETTER OMICRON -03A0; C; 03C0; # GREEK CAPITAL LETTER PI -03A1; C; 03C1; # GREEK CAPITAL LETTER RHO -03A3; C; 03C3; # GREEK CAPITAL LETTER SIGMA -03A4; C; 03C4; # GREEK CAPITAL LETTER TAU -03A5; C; 03C5; # GREEK CAPITAL LETTER UPSILON -03A6; C; 03C6; # GREEK CAPITAL LETTER PHI -03A7; C; 03C7; # GREEK CAPITAL LETTER CHI -03A8; C; 03C8; # GREEK CAPITAL LETTER PSI -03A9; C; 03C9; # GREEK CAPITAL LETTER OMEGA -03AA; C; 03CA; # GREEK CAPITAL LETTER IOTA WITH DIALYTIKA -03AB; C; 03CB; # GREEK CAPITAL LETTER UPSILON WITH DIALYTIKA -03B0; F; 03C5 0308 0301; # GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND TONOS -03C2; C; 03C3; # GREEK SMALL LETTER FINAL SIGMA -03CF; C; 03D7; # GREEK CAPITAL KAI SYMBOL -03D0; C; 03B2; # GREEK BETA SYMBOL -03D1; C; 03B8; # GREEK THETA SYMBOL -03D5; C; 03C6; # GREEK PHI SYMBOL -03D6; C; 03C0; # GREEK PI SYMBOL -03D8; C; 03D9; # GREEK LETTER ARCHAIC KOPPA -03DA; C; 03DB; # GREEK LETTER STIGMA -03DC; C; 03DD; # GREEK LETTER DIGAMMA -03DE; C; 03DF; # GREEK LETTER KOPPA -03E0; C; 03E1; # GREEK LETTER SAMPI -03E2; C; 03E3; # COPTIC CAPITAL LETTER SHEI -03E4; C; 03E5; # COPTIC CAPITAL LETTER FEI -03E6; C; 03E7; # COPTIC CAPITAL LETTER KHEI -03E8; C; 03E9; # COPTIC CAPITAL LETTER HORI -03EA; C; 03EB; # COPTIC CAPITAL LETTER GANGIA -03EC; C; 03ED; # COPTIC CAPITAL LETTER SHIMA -03EE; C; 03EF; # COPTIC CAPITAL LETTER DEI -03F0; C; 03BA; # GREEK KAPPA SYMBOL -03F1; C; 03C1; # GREEK RHO SYMBOL -03F4; C; 03B8; # GREEK CAPITAL THETA SYMBOL -03F5; C; 03B5; # GREEK LUNATE EPSILON SYMBOL -03F7; C; 03F8; # GREEK CAPITAL LETTER SHO -03F9; C; 03F2; # GREEK CAPITAL LUNATE SIGMA SYMBOL -03FA; C; 03FB; # GREEK CAPITAL LETTER SAN -03FD; C; 037B; # GREEK CAPITAL REVERSED LUNATE SIGMA SYMBOL -03FE; C; 037C; # GREEK CAPITAL DOTTED LUNATE SIGMA SYMBOL -03FF; C; 037D; # GREEK CAPITAL REVERSED DOTTED LUNATE SIGMA SYMBOL -0400; C; 0450; # CYRILLIC CAPITAL LETTER IE WITH GRAVE -0401; C; 0451; # CYRILLIC CAPITAL LETTER IO -0402; C; 0452; # CYRILLIC CAPITAL LETTER DJE -0403; C; 0453; # CYRILLIC CAPITAL LETTER GJE -0404; C; 0454; # CYRILLIC CAPITAL LETTER UKRAINIAN IE -0405; C; 0455; # CYRILLIC CAPITAL LETTER DZE -0406; C; 0456; # CYRILLIC CAPITAL LETTER BYELORUSSIAN-UKRAINIAN I -0407; C; 0457; # CYRILLIC CAPITAL LETTER YI -0408; C; 0458; # CYRILLIC CAPITAL LETTER JE -0409; C; 0459; # CYRILLIC CAPITAL LETTER LJE -040A; C; 045A; # CYRILLIC CAPITAL LETTER NJE -040B; C; 045B; # CYRILLIC CAPITAL LETTER TSHE -040C; C; 045C; # CYRILLIC CAPITAL LETTER KJE -040D; C; 045D; # CYRILLIC CAPITAL LETTER I WITH GRAVE -040E; C; 045E; # CYRILLIC CAPITAL LETTER SHORT U -040F; C; 045F; # CYRILLIC CAPITAL LETTER DZHE -0410; C; 0430; # CYRILLIC CAPITAL LETTER A -0411; C; 0431; # CYRILLIC CAPITAL LETTER BE -0412; C; 0432; # CYRILLIC CAPITAL LETTER VE -0413; C; 0433; # CYRILLIC CAPITAL LETTER GHE -0414; C; 0434; # CYRILLIC CAPITAL LETTER DE -0415; C; 0435; # CYRILLIC CAPITAL LETTER IE -0416; C; 0436; # CYRILLIC CAPITAL LETTER ZHE -0417; C; 0437; # CYRILLIC CAPITAL LETTER ZE -0418; C; 0438; # CYRILLIC CAPITAL LETTER I -0419; C; 0439; # CYRILLIC CAPITAL LETTER SHORT I -041A; C; 043A; # CYRILLIC CAPITAL LETTER KA -041B; C; 043B; # CYRILLIC CAPITAL LETTER EL -041C; C; 043C; # CYRILLIC CAPITAL LETTER EM -041D; C; 043D; # CYRILLIC CAPITAL LETTER EN -041E; C; 043E; # CYRILLIC CAPITAL LETTER O -041F; C; 043F; # CYRILLIC CAPITAL LETTER PE -0420; C; 0440; # CYRILLIC CAPITAL LETTER ER -0421; C; 0441; # CYRILLIC CAPITAL LETTER ES -0422; C; 0442; # CYRILLIC CAPITAL LETTER TE -0423; C; 0443; # CYRILLIC CAPITAL LETTER U -0424; C; 0444; # CYRILLIC CAPITAL LETTER EF -0425; C; 0445; # CYRILLIC CAPITAL LETTER HA -0426; C; 0446; # CYRILLIC CAPITAL LETTER TSE -0427; C; 0447; # CYRILLIC CAPITAL LETTER CHE -0428; C; 0448; # CYRILLIC CAPITAL LETTER SHA -0429; C; 0449; # CYRILLIC CAPITAL LETTER SHCHA -042A; C; 044A; # CYRILLIC CAPITAL LETTER HARD SIGN -042B; C; 044B; # CYRILLIC CAPITAL LETTER YERU -042C; C; 044C; # CYRILLIC CAPITAL LETTER SOFT SIGN -042D; C; 044D; # CYRILLIC CAPITAL LETTER E -042E; C; 044E; # CYRILLIC CAPITAL LETTER YU -042F; C; 044F; # CYRILLIC CAPITAL LETTER YA -0460; C; 0461; # CYRILLIC CAPITAL LETTER OMEGA -0462; C; 0463; # CYRILLIC CAPITAL LETTER YAT -0464; C; 0465; # CYRILLIC CAPITAL LETTER IOTIFIED E -0466; C; 0467; # CYRILLIC CAPITAL LETTER LITTLE YUS -0468; C; 0469; # CYRILLIC CAPITAL LETTER IOTIFIED LITTLE YUS -046A; C; 046B; # CYRILLIC CAPITAL LETTER BIG YUS -046C; C; 046D; # CYRILLIC CAPITAL LETTER IOTIFIED BIG YUS -046E; C; 046F; # CYRILLIC CAPITAL LETTER KSI -0470; C; 0471; # CYRILLIC CAPITAL LETTER PSI -0472; C; 0473; # CYRILLIC CAPITAL LETTER FITA -0474; C; 0475; # CYRILLIC CAPITAL LETTER IZHITSA -0476; C; 0477; # CYRILLIC CAPITAL LETTER IZHITSA WITH DOUBLE GRAVE ACCENT -0478; C; 0479; # CYRILLIC CAPITAL LETTER UK -047A; C; 047B; # CYRILLIC CAPITAL LETTER ROUND OMEGA -047C; C; 047D; # CYRILLIC CAPITAL LETTER OMEGA WITH TITLO -047E; C; 047F; # CYRILLIC CAPITAL LETTER OT -0480; C; 0481; # CYRILLIC CAPITAL LETTER KOPPA -048A; C; 048B; # CYRILLIC CAPITAL LETTER SHORT I WITH TAIL -048C; C; 048D; # CYRILLIC CAPITAL LETTER SEMISOFT SIGN -048E; C; 048F; # CYRILLIC CAPITAL LETTER ER WITH TICK -0490; C; 0491; # CYRILLIC CAPITAL LETTER GHE WITH UPTURN -0492; C; 0493; # CYRILLIC CAPITAL LETTER GHE WITH STROKE -0494; C; 0495; # CYRILLIC CAPITAL LETTER GHE WITH MIDDLE HOOK -0496; C; 0497; # CYRILLIC CAPITAL LETTER ZHE WITH DESCENDER -0498; C; 0499; # CYRILLIC CAPITAL LETTER ZE WITH DESCENDER -049A; C; 049B; # CYRILLIC CAPITAL LETTER KA WITH DESCENDER -049C; C; 049D; # CYRILLIC CAPITAL LETTER KA WITH VERTICAL STROKE -049E; C; 049F; # CYRILLIC CAPITAL LETTER KA WITH STROKE -04A0; C; 04A1; # CYRILLIC CAPITAL LETTER BASHKIR KA -04A2; C; 04A3; # CYRILLIC CAPITAL LETTER EN WITH DESCENDER -04A4; C; 04A5; # CYRILLIC CAPITAL LIGATURE EN GHE -04A6; C; 04A7; # CYRILLIC CAPITAL LETTER PE WITH MIDDLE HOOK -04A8; C; 04A9; # CYRILLIC CAPITAL LETTER ABKHASIAN HA -04AA; C; 04AB; # CYRILLIC CAPITAL LETTER ES WITH DESCENDER -04AC; C; 04AD; # CYRILLIC CAPITAL LETTER TE WITH DESCENDER -04AE; C; 04AF; # CYRILLIC CAPITAL LETTER STRAIGHT U -04B0; C; 04B1; # CYRILLIC CAPITAL LETTER STRAIGHT U WITH STROKE -04B2; C; 04B3; # CYRILLIC CAPITAL LETTER HA WITH DESCENDER -04B4; C; 04B5; # CYRILLIC CAPITAL LIGATURE TE TSE -04B6; C; 04B7; # CYRILLIC CAPITAL LETTER CHE WITH DESCENDER -04B8; C; 04B9; # CYRILLIC CAPITAL LETTER CHE WITH VERTICAL STROKE -04BA; C; 04BB; # CYRILLIC CAPITAL LETTER SHHA -04BC; C; 04BD; # CYRILLIC CAPITAL LETTER ABKHASIAN CHE -04BE; C; 04BF; # CYRILLIC CAPITAL LETTER ABKHASIAN CHE WITH DESCENDER -04C0; C; 04CF; # CYRILLIC LETTER PALOCHKA -04C1; C; 04C2; # CYRILLIC CAPITAL LETTER ZHE WITH BREVE -04C3; C; 04C4; # CYRILLIC CAPITAL LETTER KA WITH HOOK -04C5; C; 04C6; # CYRILLIC CAPITAL LETTER EL WITH TAIL -04C7; C; 04C8; # CYRILLIC CAPITAL LETTER EN WITH HOOK -04C9; C; 04CA; # CYRILLIC CAPITAL LETTER EN WITH TAIL -04CB; C; 04CC; # CYRILLIC CAPITAL LETTER KHAKASSIAN CHE -04CD; C; 04CE; # CYRILLIC CAPITAL LETTER EM WITH TAIL -04D0; C; 04D1; # CYRILLIC CAPITAL LETTER A WITH BREVE -04D2; C; 04D3; # CYRILLIC CAPITAL LETTER A WITH DIAERESIS -04D4; C; 04D5; # CYRILLIC CAPITAL LIGATURE A IE -04D6; C; 04D7; # CYRILLIC CAPITAL LETTER IE WITH BREVE -04D8; C; 04D9; # CYRILLIC CAPITAL LETTER SCHWA -04DA; C; 04DB; # CYRILLIC CAPITAL LETTER SCHWA WITH DIAERESIS -04DC; C; 04DD; # CYRILLIC CAPITAL LETTER ZHE WITH DIAERESIS -04DE; C; 04DF; # CYRILLIC CAPITAL LETTER ZE WITH DIAERESIS -04E0; C; 04E1; # CYRILLIC CAPITAL LETTER ABKHASIAN DZE -04E2; C; 04E3; # CYRILLIC CAPITAL LETTER I WITH MACRON -04E4; C; 04E5; # CYRILLIC CAPITAL LETTER I WITH DIAERESIS -04E6; C; 04E7; # CYRILLIC CAPITAL LETTER O WITH DIAERESIS -04E8; C; 04E9; # CYRILLIC CAPITAL LETTER BARRED O -04EA; C; 04EB; # CYRILLIC CAPITAL LETTER BARRED O WITH DIAERESIS -04EC; C; 04ED; # CYRILLIC CAPITAL LETTER E WITH DIAERESIS -04EE; C; 04EF; # CYRILLIC CAPITAL LETTER U WITH MACRON -04F0; C; 04F1; # CYRILLIC CAPITAL LETTER U WITH DIAERESIS -04F2; C; 04F3; # CYRILLIC CAPITAL LETTER U WITH DOUBLE ACUTE -04F4; C; 04F5; # CYRILLIC CAPITAL LETTER CHE WITH DIAERESIS -04F6; C; 04F7; # CYRILLIC CAPITAL LETTER GHE WITH DESCENDER -04F8; C; 04F9; # CYRILLIC CAPITAL LETTER YERU WITH DIAERESIS -04FA; C; 04FB; # CYRILLIC CAPITAL LETTER GHE WITH STROKE AND HOOK -04FC; C; 04FD; # CYRILLIC CAPITAL LETTER HA WITH HOOK -04FE; C; 04FF; # CYRILLIC CAPITAL LETTER HA WITH STROKE -0500; C; 0501; # CYRILLIC CAPITAL LETTER KOMI DE -0502; C; 0503; # CYRILLIC CAPITAL LETTER KOMI DJE -0504; C; 0505; # CYRILLIC CAPITAL LETTER KOMI ZJE -0506; C; 0507; # CYRILLIC CAPITAL LETTER KOMI DZJE -0508; C; 0509; # CYRILLIC CAPITAL LETTER KOMI LJE -050A; C; 050B; # CYRILLIC CAPITAL LETTER KOMI NJE -050C; C; 050D; # CYRILLIC CAPITAL LETTER KOMI SJE -050E; C; 050F; # CYRILLIC CAPITAL LETTER KOMI TJE -0510; C; 0511; # CYRILLIC CAPITAL LETTER REVERSED ZE -0512; C; 0513; # CYRILLIC CAPITAL LETTER EL WITH HOOK -0514; C; 0515; # CYRILLIC CAPITAL LETTER LHA -0516; C; 0517; # CYRILLIC CAPITAL LETTER RHA -0518; C; 0519; # CYRILLIC CAPITAL LETTER YAE -051A; C; 051B; # CYRILLIC CAPITAL LETTER QA -051C; C; 051D; # CYRILLIC CAPITAL LETTER WE -051E; C; 051F; # CYRILLIC CAPITAL LETTER ALEUT KA -0520; C; 0521; # CYRILLIC CAPITAL LETTER EL WITH MIDDLE HOOK -0522; C; 0523; # CYRILLIC CAPITAL LETTER EN WITH MIDDLE HOOK -0524; C; 0525; # CYRILLIC CAPITAL LETTER PE WITH DESCENDER -0526; C; 0527; # CYRILLIC CAPITAL LETTER SHHA WITH DESCENDER -0531; C; 0561; # ARMENIAN CAPITAL LETTER AYB -0532; C; 0562; # ARMENIAN CAPITAL LETTER BEN -0533; C; 0563; # ARMENIAN CAPITAL LETTER GIM -0534; C; 0564; # ARMENIAN CAPITAL LETTER DA -0535; C; 0565; # ARMENIAN CAPITAL LETTER ECH -0536; C; 0566; # ARMENIAN CAPITAL LETTER ZA -0537; C; 0567; # ARMENIAN CAPITAL LETTER EH -0538; C; 0568; # ARMENIAN CAPITAL LETTER ET -0539; C; 0569; # ARMENIAN CAPITAL LETTER TO -053A; C; 056A; # ARMENIAN CAPITAL LETTER ZHE -053B; C; 056B; # ARMENIAN CAPITAL LETTER INI -053C; C; 056C; # ARMENIAN CAPITAL LETTER LIWN -053D; C; 056D; # ARMENIAN CAPITAL LETTER XEH -053E; C; 056E; # ARMENIAN CAPITAL LETTER CA -053F; C; 056F; # ARMENIAN CAPITAL LETTER KEN -0540; C; 0570; # ARMENIAN CAPITAL LETTER HO -0541; C; 0571; # ARMENIAN CAPITAL LETTER JA -0542; C; 0572; # ARMENIAN CAPITAL LETTER GHAD -0543; C; 0573; # ARMENIAN CAPITAL LETTER CHEH -0544; C; 0574; # ARMENIAN CAPITAL LETTER MEN -0545; C; 0575; # ARMENIAN CAPITAL LETTER YI -0546; C; 0576; # ARMENIAN CAPITAL LETTER NOW -0547; C; 0577; # ARMENIAN CAPITAL LETTER SHA -0548; C; 0578; # ARMENIAN CAPITAL LETTER VO -0549; C; 0579; # ARMENIAN CAPITAL LETTER CHA -054A; C; 057A; # ARMENIAN CAPITAL LETTER PEH -054B; C; 057B; # ARMENIAN CAPITAL LETTER JHEH -054C; C; 057C; # ARMENIAN CAPITAL LETTER RA -054D; C; 057D; # ARMENIAN CAPITAL LETTER SEH -054E; C; 057E; # ARMENIAN CAPITAL LETTER VEW -054F; C; 057F; # ARMENIAN CAPITAL LETTER TIWN -0550; C; 0580; # ARMENIAN CAPITAL LETTER REH -0551; C; 0581; # ARMENIAN CAPITAL LETTER CO -0552; C; 0582; # ARMENIAN CAPITAL LETTER YIWN -0553; C; 0583; # ARMENIAN CAPITAL LETTER PIWR -0554; C; 0584; # ARMENIAN CAPITAL LETTER KEH -0555; C; 0585; # ARMENIAN CAPITAL LETTER OH -0556; C; 0586; # ARMENIAN CAPITAL LETTER FEH -0587; F; 0565 0582; # ARMENIAN SMALL LIGATURE ECH YIWN -10A0; C; 2D00; # GEORGIAN CAPITAL LETTER AN -10A1; C; 2D01; # GEORGIAN CAPITAL LETTER BAN -10A2; C; 2D02; # GEORGIAN CAPITAL LETTER GAN -10A3; C; 2D03; # GEORGIAN CAPITAL LETTER DON -10A4; C; 2D04; # GEORGIAN CAPITAL LETTER EN -10A5; C; 2D05; # GEORGIAN CAPITAL LETTER VIN -10A6; C; 2D06; # GEORGIAN CAPITAL LETTER ZEN -10A7; C; 2D07; # GEORGIAN CAPITAL LETTER TAN -10A8; C; 2D08; # GEORGIAN CAPITAL LETTER IN -10A9; C; 2D09; # GEORGIAN CAPITAL LETTER KAN -10AA; C; 2D0A; # GEORGIAN CAPITAL LETTER LAS -10AB; C; 2D0B; # GEORGIAN CAPITAL LETTER MAN -10AC; C; 2D0C; # GEORGIAN CAPITAL LETTER NAR -10AD; C; 2D0D; # GEORGIAN CAPITAL LETTER ON -10AE; C; 2D0E; # GEORGIAN CAPITAL LETTER PAR -10AF; C; 2D0F; # GEORGIAN CAPITAL LETTER ZHAR -10B0; C; 2D10; # GEORGIAN CAPITAL LETTER RAE -10B1; C; 2D11; # GEORGIAN CAPITAL LETTER SAN -10B2; C; 2D12; # GEORGIAN CAPITAL LETTER TAR -10B3; C; 2D13; # GEORGIAN CAPITAL LETTER UN -10B4; C; 2D14; # GEORGIAN CAPITAL LETTER PHAR -10B5; C; 2D15; # GEORGIAN CAPITAL LETTER KHAR -10B6; C; 2D16; # GEORGIAN CAPITAL LETTER GHAN -10B7; C; 2D17; # GEORGIAN CAPITAL LETTER QAR -10B8; C; 2D18; # GEORGIAN CAPITAL LETTER SHIN -10B9; C; 2D19; # GEORGIAN CAPITAL LETTER CHIN -10BA; C; 2D1A; # GEORGIAN CAPITAL LETTER CAN -10BB; C; 2D1B; # GEORGIAN CAPITAL LETTER JIL -10BC; C; 2D1C; # GEORGIAN CAPITAL LETTER CIL -10BD; C; 2D1D; # GEORGIAN CAPITAL LETTER CHAR -10BE; C; 2D1E; # GEORGIAN CAPITAL LETTER XAN -10BF; C; 2D1F; # GEORGIAN CAPITAL LETTER JHAN -10C0; C; 2D20; # GEORGIAN CAPITAL LETTER HAE -10C1; C; 2D21; # GEORGIAN CAPITAL LETTER HE -10C2; C; 2D22; # GEORGIAN CAPITAL LETTER HIE -10C3; C; 2D23; # GEORGIAN CAPITAL LETTER WE -10C4; C; 2D24; # GEORGIAN CAPITAL LETTER HAR -10C5; C; 2D25; # GEORGIAN CAPITAL LETTER HOE -1E00; C; 1E01; # LATIN CAPITAL LETTER A WITH RING BELOW -1E02; C; 1E03; # LATIN CAPITAL LETTER B WITH DOT ABOVE -1E04; C; 1E05; # LATIN CAPITAL LETTER B WITH DOT BELOW -1E06; C; 1E07; # LATIN CAPITAL LETTER B WITH LINE BELOW -1E08; C; 1E09; # LATIN CAPITAL LETTER C WITH CEDILLA AND ACUTE -1E0A; C; 1E0B; # LATIN CAPITAL LETTER D WITH DOT ABOVE -1E0C; C; 1E0D; # LATIN CAPITAL LETTER D WITH DOT BELOW -1E0E; C; 1E0F; # LATIN CAPITAL LETTER D WITH LINE BELOW -1E10; C; 1E11; # LATIN CAPITAL LETTER D WITH CEDILLA -1E12; C; 1E13; # LATIN CAPITAL LETTER D WITH CIRCUMFLEX BELOW -1E14; C; 1E15; # LATIN CAPITAL LETTER E WITH MACRON AND GRAVE -1E16; C; 1E17; # LATIN CAPITAL LETTER E WITH MACRON AND ACUTE -1E18; C; 1E19; # LATIN CAPITAL LETTER E WITH CIRCUMFLEX BELOW -1E1A; C; 1E1B; # LATIN CAPITAL LETTER E WITH TILDE BELOW -1E1C; C; 1E1D; # LATIN CAPITAL LETTER E WITH CEDILLA AND BREVE -1E1E; C; 1E1F; # LATIN CAPITAL LETTER F WITH DOT ABOVE -1E20; C; 1E21; # LATIN CAPITAL LETTER G WITH MACRON -1E22; C; 1E23; # LATIN CAPITAL LETTER H WITH DOT ABOVE -1E24; C; 1E25; # LATIN CAPITAL LETTER H WITH DOT BELOW -1E26; C; 1E27; # LATIN CAPITAL LETTER H WITH DIAERESIS -1E28; C; 1E29; # LATIN CAPITAL LETTER H WITH CEDILLA -1E2A; C; 1E2B; # LATIN CAPITAL LETTER H WITH BREVE BELOW -1E2C; C; 1E2D; # LATIN CAPITAL LETTER I WITH TILDE BELOW -1E2E; C; 1E2F; # LATIN CAPITAL LETTER I WITH DIAERESIS AND ACUTE -1E30; C; 1E31; # LATIN CAPITAL LETTER K WITH ACUTE -1E32; C; 1E33; # LATIN CAPITAL LETTER K WITH DOT BELOW -1E34; C; 1E35; # LATIN CAPITAL LETTER K WITH LINE BELOW -1E36; C; 1E37; # LATIN CAPITAL LETTER L WITH DOT BELOW -1E38; C; 1E39; # LATIN CAPITAL LETTER L WITH DOT BELOW AND MACRON -1E3A; C; 1E3B; # LATIN CAPITAL LETTER L WITH LINE BELOW -1E3C; C; 1E3D; # LATIN CAPITAL LETTER L WITH CIRCUMFLEX BELOW -1E3E; C; 1E3F; # LATIN CAPITAL LETTER M WITH ACUTE -1E40; C; 1E41; # LATIN CAPITAL LETTER M WITH DOT ABOVE -1E42; C; 1E43; # LATIN CAPITAL LETTER M WITH DOT BELOW -1E44; C; 1E45; # LATIN CAPITAL LETTER N WITH DOT ABOVE -1E46; C; 1E47; # LATIN CAPITAL LETTER N WITH DOT BELOW -1E48; C; 1E49; # LATIN CAPITAL LETTER N WITH LINE BELOW -1E4A; C; 1E4B; # LATIN CAPITAL LETTER N WITH CIRCUMFLEX BELOW -1E4C; C; 1E4D; # LATIN CAPITAL LETTER O WITH TILDE AND ACUTE -1E4E; C; 1E4F; # LATIN CAPITAL LETTER O WITH TILDE AND DIAERESIS -1E50; C; 1E51; # LATIN CAPITAL LETTER O WITH MACRON AND GRAVE -1E52; C; 1E53; # LATIN CAPITAL LETTER O WITH MACRON AND ACUTE -1E54; C; 1E55; # LATIN CAPITAL LETTER P WITH ACUTE -1E56; C; 1E57; # LATIN CAPITAL LETTER P WITH DOT ABOVE -1E58; C; 1E59; # LATIN CAPITAL LETTER R WITH DOT ABOVE -1E5A; C; 1E5B; # LATIN CAPITAL LETTER R WITH DOT BELOW -1E5C; C; 1E5D; # LATIN CAPITAL LETTER R WITH DOT BELOW AND MACRON -1E5E; C; 1E5F; # LATIN CAPITAL LETTER R WITH LINE BELOW -1E60; C; 1E61; # LATIN CAPITAL LETTER S WITH DOT ABOVE -1E62; C; 1E63; # LATIN CAPITAL LETTER S WITH DOT BELOW -1E64; C; 1E65; # LATIN CAPITAL LETTER S WITH ACUTE AND DOT ABOVE -1E66; C; 1E67; # LATIN CAPITAL LETTER S WITH CARON AND DOT ABOVE -1E68; C; 1E69; # LATIN CAPITAL LETTER S WITH DOT BELOW AND DOT ABOVE -1E6A; C; 1E6B; # LATIN CAPITAL LETTER T WITH DOT ABOVE -1E6C; C; 1E6D; # LATIN CAPITAL LETTER T WITH DOT BELOW -1E6E; C; 1E6F; # LATIN CAPITAL LETTER T WITH LINE BELOW -1E70; C; 1E71; # LATIN CAPITAL LETTER T WITH CIRCUMFLEX BELOW -1E72; C; 1E73; # LATIN CAPITAL LETTER U WITH DIAERESIS BELOW -1E74; C; 1E75; # LATIN CAPITAL LETTER U WITH TILDE BELOW -1E76; C; 1E77; # LATIN CAPITAL LETTER U WITH CIRCUMFLEX BELOW -1E78; C; 1E79; # LATIN CAPITAL LETTER U WITH TILDE AND ACUTE -1E7A; C; 1E7B; # LATIN CAPITAL LETTER U WITH MACRON AND DIAERESIS -1E7C; C; 1E7D; # LATIN CAPITAL LETTER V WITH TILDE -1E7E; C; 1E7F; # LATIN CAPITAL LETTER V WITH DOT BELOW -1E80; C; 1E81; # LATIN CAPITAL LETTER W WITH GRAVE -1E82; C; 1E83; # LATIN CAPITAL LETTER W WITH ACUTE -1E84; C; 1E85; # LATIN CAPITAL LETTER W WITH DIAERESIS -1E86; C; 1E87; # LATIN CAPITAL LETTER W WITH DOT ABOVE -1E88; C; 1E89; # LATIN CAPITAL LETTER W WITH DOT BELOW -1E8A; C; 1E8B; # LATIN CAPITAL LETTER X WITH DOT ABOVE -1E8C; C; 1E8D; # LATIN CAPITAL LETTER X WITH DIAERESIS -1E8E; C; 1E8F; # LATIN CAPITAL LETTER Y WITH DOT ABOVE -1E90; C; 1E91; # LATIN CAPITAL LETTER Z WITH CIRCUMFLEX -1E92; C; 1E93; # LATIN CAPITAL LETTER Z WITH DOT BELOW -1E94; C; 1E95; # LATIN CAPITAL LETTER Z WITH LINE BELOW -1E96; F; 0068 0331; # LATIN SMALL LETTER H WITH LINE BELOW -1E97; F; 0074 0308; # LATIN SMALL LETTER T WITH DIAERESIS -1E98; F; 0077 030A; # LATIN SMALL LETTER W WITH RING ABOVE -1E99; F; 0079 030A; # LATIN SMALL LETTER Y WITH RING ABOVE -1E9A; F; 0061 02BE; # LATIN SMALL LETTER A WITH RIGHT HALF RING -1E9B; C; 1E61; # LATIN SMALL LETTER LONG S WITH DOT ABOVE -1E9E; F; 0073 0073; # LATIN CAPITAL LETTER SHARP S -1E9E; S; 00DF; # LATIN CAPITAL LETTER SHARP S -1EA0; C; 1EA1; # LATIN CAPITAL LETTER A WITH DOT BELOW -1EA2; C; 1EA3; # LATIN CAPITAL LETTER A WITH HOOK ABOVE -1EA4; C; 1EA5; # LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND ACUTE -1EA6; C; 1EA7; # LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND GRAVE -1EA8; C; 1EA9; # LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND HOOK ABOVE -1EAA; C; 1EAB; # LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND TILDE -1EAC; C; 1EAD; # LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND DOT BELOW -1EAE; C; 1EAF; # LATIN CAPITAL LETTER A WITH BREVE AND ACUTE -1EB0; C; 1EB1; # LATIN CAPITAL LETTER A WITH BREVE AND GRAVE -1EB2; C; 1EB3; # LATIN CAPITAL LETTER A WITH BREVE AND HOOK ABOVE -1EB4; C; 1EB5; # LATIN CAPITAL LETTER A WITH BREVE AND TILDE -1EB6; C; 1EB7; # LATIN CAPITAL LETTER A WITH BREVE AND DOT BELOW -1EB8; C; 1EB9; # LATIN CAPITAL LETTER E WITH DOT BELOW -1EBA; C; 1EBB; # LATIN CAPITAL LETTER E WITH HOOK ABOVE -1EBC; C; 1EBD; # LATIN CAPITAL LETTER E WITH TILDE -1EBE; C; 1EBF; # LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND ACUTE -1EC0; C; 1EC1; # LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND GRAVE -1EC2; C; 1EC3; # LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND HOOK ABOVE -1EC4; C; 1EC5; # LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND TILDE -1EC6; C; 1EC7; # LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND DOT BELOW -1EC8; C; 1EC9; # LATIN CAPITAL LETTER I WITH HOOK ABOVE -1ECA; C; 1ECB; # LATIN CAPITAL LETTER I WITH DOT BELOW -1ECC; C; 1ECD; # LATIN CAPITAL LETTER O WITH DOT BELOW -1ECE; C; 1ECF; # LATIN CAPITAL LETTER O WITH HOOK ABOVE -1ED0; C; 1ED1; # LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND ACUTE -1ED2; C; 1ED3; # LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND GRAVE -1ED4; C; 1ED5; # LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND HOOK ABOVE -1ED6; C; 1ED7; # LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND TILDE -1ED8; C; 1ED9; # LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND DOT BELOW -1EDA; C; 1EDB; # LATIN CAPITAL LETTER O WITH HORN AND ACUTE -1EDC; C; 1EDD; # LATIN CAPITAL LETTER O WITH HORN AND GRAVE -1EDE; C; 1EDF; # LATIN CAPITAL LETTER O WITH HORN AND HOOK ABOVE -1EE0; C; 1EE1; # LATIN CAPITAL LETTER O WITH HORN AND TILDE -1EE2; C; 1EE3; # LATIN CAPITAL LETTER O WITH HORN AND DOT BELOW -1EE4; C; 1EE5; # LATIN CAPITAL LETTER U WITH DOT BELOW -1EE6; C; 1EE7; # LATIN CAPITAL LETTER U WITH HOOK ABOVE -1EE8; C; 1EE9; # LATIN CAPITAL LETTER U WITH HORN AND ACUTE -1EEA; C; 1EEB; # LATIN CAPITAL LETTER U WITH HORN AND GRAVE -1EEC; C; 1EED; # LATIN CAPITAL LETTER U WITH HORN AND HOOK ABOVE -1EEE; C; 1EEF; # LATIN CAPITAL LETTER U WITH HORN AND TILDE -1EF0; C; 1EF1; # LATIN CAPITAL LETTER U WITH HORN AND DOT BELOW -1EF2; C; 1EF3; # LATIN CAPITAL LETTER Y WITH GRAVE -1EF4; C; 1EF5; # LATIN CAPITAL LETTER Y WITH DOT BELOW -1EF6; C; 1EF7; # LATIN CAPITAL LETTER Y WITH HOOK ABOVE -1EF8; C; 1EF9; # LATIN CAPITAL LETTER Y WITH TILDE -1EFA; C; 1EFB; # LATIN CAPITAL LETTER MIDDLE-WELSH LL -1EFC; C; 1EFD; # LATIN CAPITAL LETTER MIDDLE-WELSH V -1EFE; C; 1EFF; # LATIN CAPITAL LETTER Y WITH LOOP -1F08; C; 1F00; # GREEK CAPITAL LETTER ALPHA WITH PSILI -1F09; C; 1F01; # GREEK CAPITAL LETTER ALPHA WITH DASIA -1F0A; C; 1F02; # GREEK CAPITAL LETTER ALPHA WITH PSILI AND VARIA -1F0B; C; 1F03; # GREEK CAPITAL LETTER ALPHA WITH DASIA AND VARIA -1F0C; C; 1F04; # GREEK CAPITAL LETTER ALPHA WITH PSILI AND OXIA -1F0D; C; 1F05; # GREEK CAPITAL LETTER ALPHA WITH DASIA AND OXIA -1F0E; C; 1F06; # GREEK CAPITAL LETTER ALPHA WITH PSILI AND PERISPOMENI -1F0F; C; 1F07; # GREEK CAPITAL LETTER ALPHA WITH DASIA AND PERISPOMENI -1F18; C; 1F10; # GREEK CAPITAL LETTER EPSILON WITH PSILI -1F19; C; 1F11; # GREEK CAPITAL LETTER EPSILON WITH DASIA -1F1A; C; 1F12; # GREEK CAPITAL LETTER EPSILON WITH PSILI AND VARIA -1F1B; C; 1F13; # GREEK CAPITAL LETTER EPSILON WITH DASIA AND VARIA -1F1C; C; 1F14; # GREEK CAPITAL LETTER EPSILON WITH PSILI AND OXIA -1F1D; C; 1F15; # GREEK CAPITAL LETTER EPSILON WITH DASIA AND OXIA -1F28; C; 1F20; # GREEK CAPITAL LETTER ETA WITH PSILI -1F29; C; 1F21; # GREEK CAPITAL LETTER ETA WITH DASIA -1F2A; C; 1F22; # GREEK CAPITAL LETTER ETA WITH PSILI AND VARIA -1F2B; C; 1F23; # GREEK CAPITAL LETTER ETA WITH DASIA AND VARIA -1F2C; C; 1F24; # GREEK CAPITAL LETTER ETA WITH PSILI AND OXIA -1F2D; C; 1F25; # GREEK CAPITAL LETTER ETA WITH DASIA AND OXIA -1F2E; C; 1F26; # GREEK CAPITAL LETTER ETA WITH PSILI AND PERISPOMENI -1F2F; C; 1F27; # GREEK CAPITAL LETTER ETA WITH DASIA AND PERISPOMENI -1F38; C; 1F30; # GREEK CAPITAL LETTER IOTA WITH PSILI -1F39; C; 1F31; # GREEK CAPITAL LETTER IOTA WITH DASIA -1F3A; C; 1F32; # GREEK CAPITAL LETTER IOTA WITH PSILI AND VARIA -1F3B; C; 1F33; # GREEK CAPITAL LETTER IOTA WITH DASIA AND VARIA -1F3C; C; 1F34; # GREEK CAPITAL LETTER IOTA WITH PSILI AND OXIA -1F3D; C; 1F35; # GREEK CAPITAL LETTER IOTA WITH DASIA AND OXIA -1F3E; C; 1F36; # GREEK CAPITAL LETTER IOTA WITH PSILI AND PERISPOMENI -1F3F; C; 1F37; # GREEK CAPITAL LETTER IOTA WITH DASIA AND PERISPOMENI -1F48; C; 1F40; # GREEK CAPITAL LETTER OMICRON WITH PSILI -1F49; C; 1F41; # GREEK CAPITAL LETTER OMICRON WITH DASIA -1F4A; C; 1F42; # GREEK CAPITAL LETTER OMICRON WITH PSILI AND VARIA -1F4B; C; 1F43; # GREEK CAPITAL LETTER OMICRON WITH DASIA AND VARIA -1F4C; C; 1F44; # GREEK CAPITAL LETTER OMICRON WITH PSILI AND OXIA -1F4D; C; 1F45; # GREEK CAPITAL LETTER OMICRON WITH DASIA AND OXIA -1F50; F; 03C5 0313; # GREEK SMALL LETTER UPSILON WITH PSILI -1F52; F; 03C5 0313 0300; # GREEK SMALL LETTER UPSILON WITH PSILI AND VARIA -1F54; F; 03C5 0313 0301; # GREEK SMALL LETTER UPSILON WITH PSILI AND OXIA -1F56; F; 03C5 0313 0342; # GREEK SMALL LETTER UPSILON WITH PSILI AND PERISPOMENI -1F59; C; 1F51; # GREEK CAPITAL LETTER UPSILON WITH DASIA -1F5B; C; 1F53; # GREEK CAPITAL LETTER UPSILON WITH DASIA AND VARIA -1F5D; C; 1F55; # GREEK CAPITAL LETTER UPSILON WITH DASIA AND OXIA -1F5F; C; 1F57; # GREEK CAPITAL LETTER UPSILON WITH DASIA AND PERISPOMENI -1F68; C; 1F60; # GREEK CAPITAL LETTER OMEGA WITH PSILI -1F69; C; 1F61; # GREEK CAPITAL LETTER OMEGA WITH DASIA -1F6A; C; 1F62; # GREEK CAPITAL LETTER OMEGA WITH PSILI AND VARIA -1F6B; C; 1F63; # GREEK CAPITAL LETTER OMEGA WITH DASIA AND VARIA -1F6C; C; 1F64; # GREEK CAPITAL LETTER OMEGA WITH PSILI AND OXIA -1F6D; C; 1F65; # GREEK CAPITAL LETTER OMEGA WITH DASIA AND OXIA -1F6E; C; 1F66; # GREEK CAPITAL LETTER OMEGA WITH PSILI AND PERISPOMENI -1F6F; C; 1F67; # GREEK CAPITAL LETTER OMEGA WITH DASIA AND PERISPOMENI -1F80; F; 1F00 03B9; # GREEK SMALL LETTER ALPHA WITH PSILI AND YPOGEGRAMMENI -1F81; F; 1F01 03B9; # GREEK SMALL LETTER ALPHA WITH DASIA AND YPOGEGRAMMENI -1F82; F; 1F02 03B9; # GREEK SMALL LETTER ALPHA WITH PSILI AND VARIA AND YPOGEGRAMMENI -1F83; F; 1F03 03B9; # GREEK SMALL LETTER ALPHA WITH DASIA AND VARIA AND YPOGEGRAMMENI -1F84; F; 1F04 03B9; # GREEK SMALL LETTER ALPHA WITH PSILI AND OXIA AND YPOGEGRAMMENI -1F85; F; 1F05 03B9; # GREEK SMALL LETTER ALPHA WITH DASIA AND OXIA AND YPOGEGRAMMENI -1F86; F; 1F06 03B9; # GREEK SMALL LETTER ALPHA WITH PSILI AND PERISPOMENI AND YPOGEGRAMMENI -1F87; F; 1F07 03B9; # GREEK SMALL LETTER ALPHA WITH DASIA AND PERISPOMENI AND YPOGEGRAMMENI -1F88; F; 1F00 03B9; # GREEK CAPITAL LETTER ALPHA WITH PSILI AND PROSGEGRAMMENI -1F88; S; 1F80; # GREEK CAPITAL LETTER ALPHA WITH PSILI AND PROSGEGRAMMENI -1F89; F; 1F01 03B9; # GREEK CAPITAL LETTER ALPHA WITH DASIA AND PROSGEGRAMMENI -1F89; S; 1F81; # GREEK CAPITAL LETTER ALPHA WITH DASIA AND PROSGEGRAMMENI -1F8A; F; 1F02 03B9; # GREEK CAPITAL LETTER ALPHA WITH PSILI AND VARIA AND PROSGEGRAMMENI -1F8A; S; 1F82; # GREEK CAPITAL LETTER ALPHA WITH PSILI AND VARIA AND PROSGEGRAMMENI -1F8B; F; 1F03 03B9; # GREEK CAPITAL LETTER ALPHA WITH DASIA AND VARIA AND PROSGEGRAMMENI -1F8B; S; 1F83; # GREEK CAPITAL LETTER ALPHA WITH DASIA AND VARIA AND PROSGEGRAMMENI -1F8C; F; 1F04 03B9; # GREEK CAPITAL LETTER ALPHA WITH PSILI AND OXIA AND PROSGEGRAMMENI -1F8C; S; 1F84; # GREEK CAPITAL LETTER ALPHA WITH PSILI AND OXIA AND PROSGEGRAMMENI -1F8D; F; 1F05 03B9; # GREEK CAPITAL LETTER ALPHA WITH DASIA AND OXIA AND PROSGEGRAMMENI -1F8D; S; 1F85; # GREEK CAPITAL LETTER ALPHA WITH DASIA AND OXIA AND PROSGEGRAMMENI -1F8E; F; 1F06 03B9; # GREEK CAPITAL LETTER ALPHA WITH PSILI AND PERISPOMENI AND PROSGEGRAMMENI -1F8E; S; 1F86; # GREEK CAPITAL LETTER ALPHA WITH PSILI AND PERISPOMENI AND PROSGEGRAMMENI -1F8F; F; 1F07 03B9; # GREEK CAPITAL LETTER ALPHA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI -1F8F; S; 1F87; # GREEK CAPITAL LETTER ALPHA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI -1F90; F; 1F20 03B9; # GREEK SMALL LETTER ETA WITH PSILI AND YPOGEGRAMMENI -1F91; F; 1F21 03B9; # GREEK SMALL LETTER ETA WITH DASIA AND YPOGEGRAMMENI -1F92; F; 1F22 03B9; # GREEK SMALL LETTER ETA WITH PSILI AND VARIA AND YPOGEGRAMMENI -1F93; F; 1F23 03B9; # GREEK SMALL LETTER ETA WITH DASIA AND VARIA AND YPOGEGRAMMENI -1F94; F; 1F24 03B9; # GREEK SMALL LETTER ETA WITH PSILI AND OXIA AND YPOGEGRAMMENI -1F95; F; 1F25 03B9; # GREEK SMALL LETTER ETA WITH DASIA AND OXIA AND YPOGEGRAMMENI -1F96; F; 1F26 03B9; # GREEK SMALL LETTER ETA WITH PSILI AND PERISPOMENI AND YPOGEGRAMMENI -1F97; F; 1F27 03B9; # GREEK SMALL LETTER ETA WITH DASIA AND PERISPOMENI AND YPOGEGRAMMENI -1F98; F; 1F20 03B9; # GREEK CAPITAL LETTER ETA WITH PSILI AND PROSGEGRAMMENI -1F98; S; 1F90; # GREEK CAPITAL LETTER ETA WITH PSILI AND PROSGEGRAMMENI -1F99; F; 1F21 03B9; # GREEK CAPITAL LETTER ETA WITH DASIA AND PROSGEGRAMMENI -1F99; S; 1F91; # GREEK CAPITAL LETTER ETA WITH DASIA AND PROSGEGRAMMENI -1F9A; F; 1F22 03B9; # GREEK CAPITAL LETTER ETA WITH PSILI AND VARIA AND PROSGEGRAMMENI -1F9A; S; 1F92; # GREEK CAPITAL LETTER ETA WITH PSILI AND VARIA AND PROSGEGRAMMENI -1F9B; F; 1F23 03B9; # GREEK CAPITAL LETTER ETA WITH DASIA AND VARIA AND PROSGEGRAMMENI -1F9B; S; 1F93; # GREEK CAPITAL LETTER ETA WITH DASIA AND VARIA AND PROSGEGRAMMENI -1F9C; F; 1F24 03B9; # GREEK CAPITAL LETTER ETA WITH PSILI AND OXIA AND PROSGEGRAMMENI -1F9C; S; 1F94; # GREEK CAPITAL LETTER ETA WITH PSILI AND OXIA AND PROSGEGRAMMENI -1F9D; F; 1F25 03B9; # GREEK CAPITAL LETTER ETA WITH DASIA AND OXIA AND PROSGEGRAMMENI -1F9D; S; 1F95; # GREEK CAPITAL LETTER ETA WITH DASIA AND OXIA AND PROSGEGRAMMENI -1F9E; F; 1F26 03B9; # GREEK CAPITAL LETTER ETA WITH PSILI AND PERISPOMENI AND PROSGEGRAMMENI -1F9E; S; 1F96; # GREEK CAPITAL LETTER ETA WITH PSILI AND PERISPOMENI AND PROSGEGRAMMENI -1F9F; F; 1F27 03B9; # GREEK CAPITAL LETTER ETA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI -1F9F; S; 1F97; # GREEK CAPITAL LETTER ETA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI -1FA0; F; 1F60 03B9; # GREEK SMALL LETTER OMEGA WITH PSILI AND YPOGEGRAMMENI -1FA1; F; 1F61 03B9; # GREEK SMALL LETTER OMEGA WITH DASIA AND YPOGEGRAMMENI -1FA2; F; 1F62 03B9; # GREEK SMALL LETTER OMEGA WITH PSILI AND VARIA AND YPOGEGRAMMENI -1FA3; F; 1F63 03B9; # GREEK SMALL LETTER OMEGA WITH DASIA AND VARIA AND YPOGEGRAMMENI -1FA4; F; 1F64 03B9; # GREEK SMALL LETTER OMEGA WITH PSILI AND OXIA AND YPOGEGRAMMENI -1FA5; F; 1F65 03B9; # GREEK SMALL LETTER OMEGA WITH DASIA AND OXIA AND YPOGEGRAMMENI -1FA6; F; 1F66 03B9; # GREEK SMALL LETTER OMEGA WITH PSILI AND PERISPOMENI AND YPOGEGRAMMENI -1FA7; F; 1F67 03B9; # GREEK SMALL LETTER OMEGA WITH DASIA AND PERISPOMENI AND YPOGEGRAMMENI -1FA8; F; 1F60 03B9; # GREEK CAPITAL LETTER OMEGA WITH PSILI AND PROSGEGRAMMENI -1FA8; S; 1FA0; # GREEK CAPITAL LETTER OMEGA WITH PSILI AND PROSGEGRAMMENI -1FA9; F; 1F61 03B9; # GREEK CAPITAL LETTER OMEGA WITH DASIA AND PROSGEGRAMMENI -1FA9; S; 1FA1; # GREEK CAPITAL LETTER OMEGA WITH DASIA AND PROSGEGRAMMENI -1FAA; F; 1F62 03B9; # GREEK CAPITAL LETTER OMEGA WITH PSILI AND VARIA AND PROSGEGRAMMENI -1FAA; S; 1FA2; # GREEK CAPITAL LETTER OMEGA WITH PSILI AND VARIA AND PROSGEGRAMMENI -1FAB; F; 1F63 03B9; # GREEK CAPITAL LETTER OMEGA WITH DASIA AND VARIA AND PROSGEGRAMMENI -1FAB; S; 1FA3; # GREEK CAPITAL LETTER OMEGA WITH DASIA AND VARIA AND PROSGEGRAMMENI -1FAC; F; 1F64 03B9; # GREEK CAPITAL LETTER OMEGA WITH PSILI AND OXIA AND PROSGEGRAMMENI -1FAC; S; 1FA4; # GREEK CAPITAL LETTER OMEGA WITH PSILI AND OXIA AND PROSGEGRAMMENI -1FAD; F; 1F65 03B9; # GREEK CAPITAL LETTER OMEGA WITH DASIA AND OXIA AND PROSGEGRAMMENI -1FAD; S; 1FA5; # GREEK CAPITAL LETTER OMEGA WITH DASIA AND OXIA AND PROSGEGRAMMENI -1FAE; F; 1F66 03B9; # GREEK CAPITAL LETTER OMEGA WITH PSILI AND PERISPOMENI AND PROSGEGRAMMENI -1FAE; S; 1FA6; # GREEK CAPITAL LETTER OMEGA WITH PSILI AND PERISPOMENI AND PROSGEGRAMMENI -1FAF; F; 1F67 03B9; # GREEK CAPITAL LETTER OMEGA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI -1FAF; S; 1FA7; # GREEK CAPITAL LETTER OMEGA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI -1FB2; F; 1F70 03B9; # GREEK SMALL LETTER ALPHA WITH VARIA AND YPOGEGRAMMENI -1FB3; F; 03B1 03B9; # GREEK SMALL LETTER ALPHA WITH YPOGEGRAMMENI -1FB4; F; 03AC 03B9; # GREEK SMALL LETTER ALPHA WITH OXIA AND YPOGEGRAMMENI -1FB6; F; 03B1 0342; # GREEK SMALL LETTER ALPHA WITH PERISPOMENI -1FB7; F; 03B1 0342 03B9; # GREEK SMALL LETTER ALPHA WITH PERISPOMENI AND YPOGEGRAMMENI -1FB8; C; 1FB0; # GREEK CAPITAL LETTER ALPHA WITH VRACHY -1FB9; C; 1FB1; # GREEK CAPITAL LETTER ALPHA WITH MACRON -1FBA; C; 1F70; # GREEK CAPITAL LETTER ALPHA WITH VARIA -1FBB; C; 1F71; # GREEK CAPITAL LETTER ALPHA WITH OXIA -1FBC; F; 03B1 03B9; # GREEK CAPITAL LETTER ALPHA WITH PROSGEGRAMMENI -1FBC; S; 1FB3; # GREEK CAPITAL LETTER ALPHA WITH PROSGEGRAMMENI -1FBE; C; 03B9; # GREEK PROSGEGRAMMENI -1FC2; F; 1F74 03B9; # GREEK SMALL LETTER ETA WITH VARIA AND YPOGEGRAMMENI -1FC3; F; 03B7 03B9; # GREEK SMALL LETTER ETA WITH YPOGEGRAMMENI -1FC4; F; 03AE 03B9; # GREEK SMALL LETTER ETA WITH OXIA AND YPOGEGRAMMENI -1FC6; F; 03B7 0342; # GREEK SMALL LETTER ETA WITH PERISPOMENI -1FC7; F; 03B7 0342 03B9; # GREEK SMALL LETTER ETA WITH PERISPOMENI AND YPOGEGRAMMENI -1FC8; C; 1F72; # GREEK CAPITAL LETTER EPSILON WITH VARIA -1FC9; C; 1F73; # GREEK CAPITAL LETTER EPSILON WITH OXIA -1FCA; C; 1F74; # GREEK CAPITAL LETTER ETA WITH VARIA -1FCB; C; 1F75; # GREEK CAPITAL LETTER ETA WITH OXIA -1FCC; F; 03B7 03B9; # GREEK CAPITAL LETTER ETA WITH PROSGEGRAMMENI -1FCC; S; 1FC3; # GREEK CAPITAL LETTER ETA WITH PROSGEGRAMMENI -1FD2; F; 03B9 0308 0300; # GREEK SMALL LETTER IOTA WITH DIALYTIKA AND VARIA -1FD3; F; 03B9 0308 0301; # GREEK SMALL LETTER IOTA WITH DIALYTIKA AND OXIA -1FD6; F; 03B9 0342; # GREEK SMALL LETTER IOTA WITH PERISPOMENI -1FD7; F; 03B9 0308 0342; # GREEK SMALL LETTER IOTA WITH DIALYTIKA AND PERISPOMENI -1FD8; C; 1FD0; # GREEK CAPITAL LETTER IOTA WITH VRACHY -1FD9; C; 1FD1; # GREEK CAPITAL LETTER IOTA WITH MACRON -1FDA; C; 1F76; # GREEK CAPITAL LETTER IOTA WITH VARIA -1FDB; C; 1F77; # GREEK CAPITAL LETTER IOTA WITH OXIA -1FE2; F; 03C5 0308 0300; # GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND VARIA -1FE3; F; 03C5 0308 0301; # GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND OXIA -1FE4; F; 03C1 0313; # GREEK SMALL LETTER RHO WITH PSILI -1FE6; F; 03C5 0342; # GREEK SMALL LETTER UPSILON WITH PERISPOMENI -1FE7; F; 03C5 0308 0342; # GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND PERISPOMENI -1FE8; C; 1FE0; # GREEK CAPITAL LETTER UPSILON WITH VRACHY -1FE9; C; 1FE1; # GREEK CAPITAL LETTER UPSILON WITH MACRON -1FEA; C; 1F7A; # GREEK CAPITAL LETTER UPSILON WITH VARIA -1FEB; C; 1F7B; # GREEK CAPITAL LETTER UPSILON WITH OXIA -1FEC; C; 1FE5; # GREEK CAPITAL LETTER RHO WITH DASIA -1FF2; F; 1F7C 03B9; # GREEK SMALL LETTER OMEGA WITH VARIA AND YPOGEGRAMMENI -1FF3; F; 03C9 03B9; # GREEK SMALL LETTER OMEGA WITH YPOGEGRAMMENI -1FF4; F; 03CE 03B9; # GREEK SMALL LETTER OMEGA WITH OXIA AND YPOGEGRAMMENI -1FF6; F; 03C9 0342; # GREEK SMALL LETTER OMEGA WITH PERISPOMENI -1FF7; F; 03C9 0342 03B9; # GREEK SMALL LETTER OMEGA WITH PERISPOMENI AND YPOGEGRAMMENI -1FF8; C; 1F78; # GREEK CAPITAL LETTER OMICRON WITH VARIA -1FF9; C; 1F79; # GREEK CAPITAL LETTER OMICRON WITH OXIA -1FFA; C; 1F7C; # GREEK CAPITAL LETTER OMEGA WITH VARIA -1FFB; C; 1F7D; # GREEK CAPITAL LETTER OMEGA WITH OXIA -1FFC; F; 03C9 03B9; # GREEK CAPITAL LETTER OMEGA WITH PROSGEGRAMMENI -1FFC; S; 1FF3; # GREEK CAPITAL LETTER OMEGA WITH PROSGEGRAMMENI -2126; C; 03C9; # OHM SIGN -212A; C; 006B; # KELVIN SIGN -212B; C; 00E5; # ANGSTROM SIGN -2132; C; 214E; # TURNED CAPITAL F -2160; C; 2170; # ROMAN NUMERAL ONE -2161; C; 2171; # ROMAN NUMERAL TWO -2162; C; 2172; # ROMAN NUMERAL THREE -2163; C; 2173; # ROMAN NUMERAL FOUR -2164; C; 2174; # ROMAN NUMERAL FIVE -2165; C; 2175; # ROMAN NUMERAL SIX -2166; C; 2176; # ROMAN NUMERAL SEVEN -2167; C; 2177; # ROMAN NUMERAL EIGHT -2168; C; 2178; # ROMAN NUMERAL NINE -2169; C; 2179; # ROMAN NUMERAL TEN -216A; C; 217A; # ROMAN NUMERAL ELEVEN -216B; C; 217B; # ROMAN NUMERAL TWELVE -216C; C; 217C; # ROMAN NUMERAL FIFTY -216D; C; 217D; # ROMAN NUMERAL ONE HUNDRED -216E; C; 217E; # ROMAN NUMERAL FIVE HUNDRED -216F; C; 217F; # ROMAN NUMERAL ONE THOUSAND -2183; C; 2184; # ROMAN NUMERAL REVERSED ONE HUNDRED -24B6; C; 24D0; # CIRCLED LATIN CAPITAL LETTER A -24B7; C; 24D1; # CIRCLED LATIN CAPITAL LETTER B -24B8; C; 24D2; # CIRCLED LATIN CAPITAL LETTER C -24B9; C; 24D3; # CIRCLED LATIN CAPITAL LETTER D -24BA; C; 24D4; # CIRCLED LATIN CAPITAL LETTER E -24BB; C; 24D5; # CIRCLED LATIN CAPITAL LETTER F -24BC; C; 24D6; # CIRCLED LATIN CAPITAL LETTER G -24BD; C; 24D7; # CIRCLED LATIN CAPITAL LETTER H -24BE; C; 24D8; # CIRCLED LATIN CAPITAL LETTER I -24BF; C; 24D9; # CIRCLED LATIN CAPITAL LETTER J -24C0; C; 24DA; # CIRCLED LATIN CAPITAL LETTER K -24C1; C; 24DB; # CIRCLED LATIN CAPITAL LETTER L -24C2; C; 24DC; # CIRCLED LATIN CAPITAL LETTER M -24C3; C; 24DD; # CIRCLED LATIN CAPITAL LETTER N -24C4; C; 24DE; # CIRCLED LATIN CAPITAL LETTER O -24C5; C; 24DF; # CIRCLED LATIN CAPITAL LETTER P -24C6; C; 24E0; # CIRCLED LATIN CAPITAL LETTER Q -24C7; C; 24E1; # CIRCLED LATIN CAPITAL LETTER R -24C8; C; 24E2; # CIRCLED LATIN CAPITAL LETTER S -24C9; C; 24E3; # CIRCLED LATIN CAPITAL LETTER T -24CA; C; 24E4; # CIRCLED LATIN CAPITAL LETTER U -24CB; C; 24E5; # CIRCLED LATIN CAPITAL LETTER V -24CC; C; 24E6; # CIRCLED LATIN CAPITAL LETTER W -24CD; C; 24E7; # CIRCLED LATIN CAPITAL LETTER X -24CE; C; 24E8; # CIRCLED LATIN CAPITAL LETTER Y -24CF; C; 24E9; # CIRCLED LATIN CAPITAL LETTER Z -2C00; C; 2C30; # GLAGOLITIC CAPITAL LETTER AZU -2C01; C; 2C31; # GLAGOLITIC CAPITAL LETTER BUKY -2C02; C; 2C32; # GLAGOLITIC CAPITAL LETTER VEDE -2C03; C; 2C33; # GLAGOLITIC CAPITAL LETTER GLAGOLI -2C04; C; 2C34; # GLAGOLITIC CAPITAL LETTER DOBRO -2C05; C; 2C35; # GLAGOLITIC CAPITAL LETTER YESTU -2C06; C; 2C36; # GLAGOLITIC CAPITAL LETTER ZHIVETE -2C07; C; 2C37; # GLAGOLITIC CAPITAL LETTER DZELO -2C08; C; 2C38; # GLAGOLITIC CAPITAL LETTER ZEMLJA -2C09; C; 2C39; # GLAGOLITIC CAPITAL LETTER IZHE -2C0A; C; 2C3A; # GLAGOLITIC CAPITAL LETTER INITIAL IZHE -2C0B; C; 2C3B; # GLAGOLITIC CAPITAL LETTER I -2C0C; C; 2C3C; # GLAGOLITIC CAPITAL LETTER DJERVI -2C0D; C; 2C3D; # GLAGOLITIC CAPITAL LETTER KAKO -2C0E; C; 2C3E; # GLAGOLITIC CAPITAL LETTER LJUDIJE -2C0F; C; 2C3F; # GLAGOLITIC CAPITAL LETTER MYSLITE -2C10; C; 2C40; # GLAGOLITIC CAPITAL LETTER NASHI -2C11; C; 2C41; # GLAGOLITIC CAPITAL LETTER ONU -2C12; C; 2C42; # GLAGOLITIC CAPITAL LETTER POKOJI -2C13; C; 2C43; # GLAGOLITIC CAPITAL LETTER RITSI -2C14; C; 2C44; # GLAGOLITIC CAPITAL LETTER SLOVO -2C15; C; 2C45; # GLAGOLITIC CAPITAL LETTER TVRIDO -2C16; C; 2C46; # GLAGOLITIC CAPITAL LETTER UKU -2C17; C; 2C47; # GLAGOLITIC CAPITAL LETTER FRITU -2C18; C; 2C48; # GLAGOLITIC CAPITAL LETTER HERU -2C19; C; 2C49; # GLAGOLITIC CAPITAL LETTER OTU -2C1A; C; 2C4A; # GLAGOLITIC CAPITAL LETTER PE -2C1B; C; 2C4B; # GLAGOLITIC CAPITAL LETTER SHTA -2C1C; C; 2C4C; # GLAGOLITIC CAPITAL LETTER TSI -2C1D; C; 2C4D; # GLAGOLITIC CAPITAL LETTER CHRIVI -2C1E; C; 2C4E; # GLAGOLITIC CAPITAL LETTER SHA -2C1F; C; 2C4F; # GLAGOLITIC CAPITAL LETTER YERU -2C20; C; 2C50; # GLAGOLITIC CAPITAL LETTER YERI -2C21; C; 2C51; # GLAGOLITIC CAPITAL LETTER YATI -2C22; C; 2C52; # GLAGOLITIC CAPITAL LETTER SPIDERY HA -2C23; C; 2C53; # GLAGOLITIC CAPITAL LETTER YU -2C24; C; 2C54; # GLAGOLITIC CAPITAL LETTER SMALL YUS -2C25; C; 2C55; # GLAGOLITIC CAPITAL LETTER SMALL YUS WITH TAIL -2C26; C; 2C56; # GLAGOLITIC CAPITAL LETTER YO -2C27; C; 2C57; # GLAGOLITIC CAPITAL LETTER IOTATED SMALL YUS -2C28; C; 2C58; # GLAGOLITIC CAPITAL LETTER BIG YUS -2C29; C; 2C59; # GLAGOLITIC CAPITAL LETTER IOTATED BIG YUS -2C2A; C; 2C5A; # GLAGOLITIC CAPITAL LETTER FITA -2C2B; C; 2C5B; # GLAGOLITIC CAPITAL LETTER IZHITSA -2C2C; C; 2C5C; # GLAGOLITIC CAPITAL LETTER SHTAPIC -2C2D; C; 2C5D; # GLAGOLITIC CAPITAL LETTER TROKUTASTI A -2C2E; C; 2C5E; # GLAGOLITIC CAPITAL LETTER LATINATE MYSLITE -2C60; C; 2C61; # LATIN CAPITAL LETTER L WITH DOUBLE BAR -2C62; C; 026B; # LATIN CAPITAL LETTER L WITH MIDDLE TILDE -2C63; C; 1D7D; # LATIN CAPITAL LETTER P WITH STROKE -2C64; C; 027D; # LATIN CAPITAL LETTER R WITH TAIL -2C67; C; 2C68; # LATIN CAPITAL LETTER H WITH DESCENDER -2C69; C; 2C6A; # LATIN CAPITAL LETTER K WITH DESCENDER -2C6B; C; 2C6C; # LATIN CAPITAL LETTER Z WITH DESCENDER -2C6D; C; 0251; # LATIN CAPITAL LETTER ALPHA -2C6E; C; 0271; # LATIN CAPITAL LETTER M WITH HOOK -2C6F; C; 0250; # LATIN CAPITAL LETTER TURNED A -2C70; C; 0252; # LATIN CAPITAL LETTER TURNED ALPHA -2C72; C; 2C73; # LATIN CAPITAL LETTER W WITH HOOK -2C75; C; 2C76; # LATIN CAPITAL LETTER HALF H -2C7E; C; 023F; # LATIN CAPITAL LETTER S WITH SWASH TAIL -2C7F; C; 0240; # LATIN CAPITAL LETTER Z WITH SWASH TAIL -2C80; C; 2C81; # COPTIC CAPITAL LETTER ALFA -2C82; C; 2C83; # COPTIC CAPITAL LETTER VIDA -2C84; C; 2C85; # COPTIC CAPITAL LETTER GAMMA -2C86; C; 2C87; # COPTIC CAPITAL LETTER DALDA -2C88; C; 2C89; # COPTIC CAPITAL LETTER EIE -2C8A; C; 2C8B; # COPTIC CAPITAL LETTER SOU -2C8C; C; 2C8D; # COPTIC CAPITAL LETTER ZATA -2C8E; C; 2C8F; # COPTIC CAPITAL LETTER HATE -2C90; C; 2C91; # COPTIC CAPITAL LETTER THETHE -2C92; C; 2C93; # COPTIC CAPITAL LETTER IAUDA -2C94; C; 2C95; # COPTIC CAPITAL LETTER KAPA -2C96; C; 2C97; # COPTIC CAPITAL LETTER LAULA -2C98; C; 2C99; # COPTIC CAPITAL LETTER MI -2C9A; C; 2C9B; # COPTIC CAPITAL LETTER NI -2C9C; C; 2C9D; # COPTIC CAPITAL LETTER KSI -2C9E; C; 2C9F; # COPTIC CAPITAL LETTER O -2CA0; C; 2CA1; # COPTIC CAPITAL LETTER PI -2CA2; C; 2CA3; # COPTIC CAPITAL LETTER RO -2CA4; C; 2CA5; # COPTIC CAPITAL LETTER SIMA -2CA6; C; 2CA7; # COPTIC CAPITAL LETTER TAU -2CA8; C; 2CA9; # COPTIC CAPITAL LETTER UA -2CAA; C; 2CAB; # COPTIC CAPITAL LETTER FI -2CAC; C; 2CAD; # COPTIC CAPITAL LETTER KHI -2CAE; C; 2CAF; # COPTIC CAPITAL LETTER PSI -2CB0; C; 2CB1; # COPTIC CAPITAL LETTER OOU -2CB2; C; 2CB3; # COPTIC CAPITAL LETTER DIALECT-P ALEF -2CB4; C; 2CB5; # COPTIC CAPITAL LETTER OLD COPTIC AIN -2CB6; C; 2CB7; # COPTIC CAPITAL LETTER CRYPTOGRAMMIC EIE -2CB8; C; 2CB9; # COPTIC CAPITAL LETTER DIALECT-P KAPA -2CBA; C; 2CBB; # COPTIC CAPITAL LETTER DIALECT-P NI -2CBC; C; 2CBD; # COPTIC CAPITAL LETTER CRYPTOGRAMMIC NI -2CBE; C; 2CBF; # COPTIC CAPITAL LETTER OLD COPTIC OOU -2CC0; C; 2CC1; # COPTIC CAPITAL LETTER SAMPI -2CC2; C; 2CC3; # COPTIC CAPITAL LETTER CROSSED SHEI -2CC4; C; 2CC5; # COPTIC CAPITAL LETTER OLD COPTIC SHEI -2CC6; C; 2CC7; # COPTIC CAPITAL LETTER OLD COPTIC ESH -2CC8; C; 2CC9; # COPTIC CAPITAL LETTER AKHMIMIC KHEI -2CCA; C; 2CCB; # COPTIC CAPITAL LETTER DIALECT-P HORI -2CCC; C; 2CCD; # COPTIC CAPITAL LETTER OLD COPTIC HORI -2CCE; C; 2CCF; # COPTIC CAPITAL LETTER OLD COPTIC HA -2CD0; C; 2CD1; # COPTIC CAPITAL LETTER L-SHAPED HA -2CD2; C; 2CD3; # COPTIC CAPITAL LETTER OLD COPTIC HEI -2CD4; C; 2CD5; # COPTIC CAPITAL LETTER OLD COPTIC HAT -2CD6; C; 2CD7; # COPTIC CAPITAL LETTER OLD COPTIC GANGIA -2CD8; C; 2CD9; # COPTIC CAPITAL LETTER OLD COPTIC DJA -2CDA; C; 2CDB; # COPTIC CAPITAL LETTER OLD COPTIC SHIMA -2CDC; C; 2CDD; # COPTIC CAPITAL LETTER OLD NUBIAN SHIMA -2CDE; C; 2CDF; # COPTIC CAPITAL LETTER OLD NUBIAN NGI -2CE0; C; 2CE1; # COPTIC CAPITAL LETTER OLD NUBIAN NYI -2CE2; C; 2CE3; # COPTIC CAPITAL LETTER OLD NUBIAN WAU -2CEB; C; 2CEC; # COPTIC CAPITAL LETTER CRYPTOGRAMMIC SHEI -2CED; C; 2CEE; # COPTIC CAPITAL LETTER CRYPTOGRAMMIC GANGIA -A640; C; A641; # CYRILLIC CAPITAL LETTER ZEMLYA -A642; C; A643; # CYRILLIC CAPITAL LETTER DZELO -A644; C; A645; # CYRILLIC CAPITAL LETTER REVERSED DZE -A646; C; A647; # CYRILLIC CAPITAL LETTER IOTA -A648; C; A649; # CYRILLIC CAPITAL LETTER DJERV -A64A; C; A64B; # CYRILLIC CAPITAL LETTER MONOGRAPH UK -A64C; C; A64D; # CYRILLIC CAPITAL LETTER BROAD OMEGA -A64E; C; A64F; # CYRILLIC CAPITAL LETTER NEUTRAL YER -A650; C; A651; # CYRILLIC CAPITAL LETTER YERU WITH BACK YER -A652; C; A653; # CYRILLIC CAPITAL LETTER IOTIFIED YAT -A654; C; A655; # CYRILLIC CAPITAL LETTER REVERSED YU -A656; C; A657; # CYRILLIC CAPITAL LETTER IOTIFIED A -A658; C; A659; # CYRILLIC CAPITAL LETTER CLOSED LITTLE YUS -A65A; C; A65B; # CYRILLIC CAPITAL LETTER BLENDED YUS -A65C; C; A65D; # CYRILLIC CAPITAL LETTER IOTIFIED CLOSED LITTLE YUS -A65E; C; A65F; # CYRILLIC CAPITAL LETTER YN -A660; C; A661; # CYRILLIC CAPITAL LETTER REVERSED TSE -A662; C; A663; # CYRILLIC CAPITAL LETTER SOFT DE -A664; C; A665; # CYRILLIC CAPITAL LETTER SOFT EL -A666; C; A667; # CYRILLIC CAPITAL LETTER SOFT EM -A668; C; A669; # CYRILLIC CAPITAL LETTER MONOCULAR O -A66A; C; A66B; # CYRILLIC CAPITAL LETTER BINOCULAR O -A66C; C; A66D; # CYRILLIC CAPITAL LETTER DOUBLE MONOCULAR O -A680; C; A681; # CYRILLIC CAPITAL LETTER DWE -A682; C; A683; # CYRILLIC CAPITAL LETTER DZWE -A684; C; A685; # CYRILLIC CAPITAL LETTER ZHWE -A686; C; A687; # CYRILLIC CAPITAL LETTER CCHE -A688; C; A689; # CYRILLIC CAPITAL LETTER DZZE -A68A; C; A68B; # CYRILLIC CAPITAL LETTER TE WITH MIDDLE HOOK -A68C; C; A68D; # CYRILLIC CAPITAL LETTER TWE -A68E; C; A68F; # CYRILLIC CAPITAL LETTER TSWE -A690; C; A691; # CYRILLIC CAPITAL LETTER TSSE -A692; C; A693; # CYRILLIC CAPITAL LETTER TCHE -A694; C; A695; # CYRILLIC CAPITAL LETTER HWE -A696; C; A697; # CYRILLIC CAPITAL LETTER SHWE -A722; C; A723; # LATIN CAPITAL LETTER EGYPTOLOGICAL ALEF -A724; C; A725; # LATIN CAPITAL LETTER EGYPTOLOGICAL AIN -A726; C; A727; # LATIN CAPITAL LETTER HENG -A728; C; A729; # LATIN CAPITAL LETTER TZ -A72A; C; A72B; # LATIN CAPITAL LETTER TRESILLO -A72C; C; A72D; # LATIN CAPITAL LETTER CUATRILLO -A72E; C; A72F; # LATIN CAPITAL LETTER CUATRILLO WITH COMMA -A732; C; A733; # LATIN CAPITAL LETTER AA -A734; C; A735; # LATIN CAPITAL LETTER AO -A736; C; A737; # LATIN CAPITAL LETTER AU -A738; C; A739; # LATIN CAPITAL LETTER AV -A73A; C; A73B; # LATIN CAPITAL LETTER AV WITH HORIZONTAL BAR -A73C; C; A73D; # LATIN CAPITAL LETTER AY -A73E; C; A73F; # LATIN CAPITAL LETTER REVERSED C WITH DOT -A740; C; A741; # LATIN CAPITAL LETTER K WITH STROKE -A742; C; A743; # LATIN CAPITAL LETTER K WITH DIAGONAL STROKE -A744; C; A745; # LATIN CAPITAL LETTER K WITH STROKE AND DIAGONAL STROKE -A746; C; A747; # LATIN CAPITAL LETTER BROKEN L -A748; C; A749; # LATIN CAPITAL LETTER L WITH HIGH STROKE -A74A; C; A74B; # LATIN CAPITAL LETTER O WITH LONG STROKE OVERLAY -A74C; C; A74D; # LATIN CAPITAL LETTER O WITH LOOP -A74E; C; A74F; # LATIN CAPITAL LETTER OO -A750; C; A751; # LATIN CAPITAL LETTER P WITH STROKE THROUGH DESCENDER -A752; C; A753; # LATIN CAPITAL LETTER P WITH FLOURISH -A754; C; A755; # LATIN CAPITAL LETTER P WITH SQUIRREL TAIL -A756; C; A757; # LATIN CAPITAL LETTER Q WITH STROKE THROUGH DESCENDER -A758; C; A759; # LATIN CAPITAL LETTER Q WITH DIAGONAL STROKE -A75A; C; A75B; # LATIN CAPITAL LETTER R ROTUNDA -A75C; C; A75D; # LATIN CAPITAL LETTER RUM ROTUNDA -A75E; C; A75F; # LATIN CAPITAL LETTER V WITH DIAGONAL STROKE -A760; C; A761; # LATIN CAPITAL LETTER VY -A762; C; A763; # LATIN CAPITAL LETTER VISIGOTHIC Z -A764; C; A765; # LATIN CAPITAL LETTER THORN WITH STROKE -A766; C; A767; # LATIN CAPITAL LETTER THORN WITH STROKE THROUGH DESCENDER -A768; C; A769; # LATIN CAPITAL LETTER VEND -A76A; C; A76B; # LATIN CAPITAL LETTER ET -A76C; C; A76D; # LATIN CAPITAL LETTER IS -A76E; C; A76F; # LATIN CAPITAL LETTER CON -A779; C; A77A; # LATIN CAPITAL LETTER INSULAR D -A77B; C; A77C; # LATIN CAPITAL LETTER INSULAR F -A77D; C; 1D79; # LATIN CAPITAL LETTER INSULAR G -A77E; C; A77F; # LATIN CAPITAL LETTER TURNED INSULAR G -A780; C; A781; # LATIN CAPITAL LETTER TURNED L -A782; C; A783; # LATIN CAPITAL LETTER INSULAR R -A784; C; A785; # LATIN CAPITAL LETTER INSULAR S -A786; C; A787; # LATIN CAPITAL LETTER INSULAR T -A78B; C; A78C; # LATIN CAPITAL LETTER SALTILLO -A78D; C; 0265; # LATIN CAPITAL LETTER TURNED H -A790; C; A791; # LATIN CAPITAL LETTER N WITH DESCENDER -A7A0; C; A7A1; # LATIN CAPITAL LETTER G WITH OBLIQUE STROKE -A7A2; C; A7A3; # LATIN CAPITAL LETTER K WITH OBLIQUE STROKE -A7A4; C; A7A5; # LATIN CAPITAL LETTER N WITH OBLIQUE STROKE -A7A6; C; A7A7; # LATIN CAPITAL LETTER R WITH OBLIQUE STROKE -A7A8; C; A7A9; # LATIN CAPITAL LETTER S WITH OBLIQUE STROKE -FB00; F; 0066 0066; # LATIN SMALL LIGATURE FF -FB01; F; 0066 0069; # LATIN SMALL LIGATURE FI -FB02; F; 0066 006C; # LATIN SMALL LIGATURE FL -FB03; F; 0066 0066 0069; # LATIN SMALL LIGATURE FFI -FB04; F; 0066 0066 006C; # LATIN SMALL LIGATURE FFL -FB05; F; 0073 0074; # LATIN SMALL LIGATURE LONG S T -FB06; F; 0073 0074; # LATIN SMALL LIGATURE ST -FB13; F; 0574 0576; # ARMENIAN SMALL LIGATURE MEN NOW -FB14; F; 0574 0565; # ARMENIAN SMALL LIGATURE MEN ECH -FB15; F; 0574 056B; # ARMENIAN SMALL LIGATURE MEN INI -FB16; F; 057E 0576; # ARMENIAN SMALL LIGATURE VEW NOW -FB17; F; 0574 056D; # ARMENIAN SMALL LIGATURE MEN XEH -FF21; C; FF41; # FULLWIDTH LATIN CAPITAL LETTER A -FF22; C; FF42; # FULLWIDTH LATIN CAPITAL LETTER B -FF23; C; FF43; # FULLWIDTH LATIN CAPITAL LETTER C -FF24; C; FF44; # FULLWIDTH LATIN CAPITAL LETTER D -FF25; C; FF45; # FULLWIDTH LATIN CAPITAL LETTER E -FF26; C; FF46; # FULLWIDTH LATIN CAPITAL LETTER F -FF27; C; FF47; # FULLWIDTH LATIN CAPITAL LETTER G -FF28; C; FF48; # FULLWIDTH LATIN CAPITAL LETTER H -FF29; C; FF49; # FULLWIDTH LATIN CAPITAL LETTER I -FF2A; C; FF4A; # FULLWIDTH LATIN CAPITAL LETTER J -FF2B; C; FF4B; # FULLWIDTH LATIN CAPITAL LETTER K -FF2C; C; FF4C; # FULLWIDTH LATIN CAPITAL LETTER L -FF2D; C; FF4D; # FULLWIDTH LATIN CAPITAL LETTER M -FF2E; C; FF4E; # FULLWIDTH LATIN CAPITAL LETTER N -FF2F; C; FF4F; # FULLWIDTH LATIN CAPITAL LETTER O -FF30; C; FF50; # FULLWIDTH LATIN CAPITAL LETTER P -FF31; C; FF51; # FULLWIDTH LATIN CAPITAL LETTER Q -FF32; C; FF52; # FULLWIDTH LATIN CAPITAL LETTER R -FF33; C; FF53; # FULLWIDTH LATIN CAPITAL LETTER S -FF34; C; FF54; # FULLWIDTH LATIN CAPITAL LETTER T -FF35; C; FF55; # FULLWIDTH LATIN CAPITAL LETTER U -FF36; C; FF56; # FULLWIDTH LATIN CAPITAL LETTER V -FF37; C; FF57; # FULLWIDTH LATIN CAPITAL LETTER W -FF38; C; FF58; # FULLWIDTH LATIN CAPITAL LETTER X -FF39; C; FF59; # FULLWIDTH LATIN CAPITAL LETTER Y -FF3A; C; FF5A; # FULLWIDTH LATIN CAPITAL LETTER Z -10400; C; 10428; # DESERET CAPITAL LETTER LONG I -10401; C; 10429; # DESERET CAPITAL LETTER LONG E -10402; C; 1042A; # DESERET CAPITAL LETTER LONG A -10403; C; 1042B; # DESERET CAPITAL LETTER LONG AH -10404; C; 1042C; # DESERET CAPITAL LETTER LONG O -10405; C; 1042D; # DESERET CAPITAL LETTER LONG OO -10406; C; 1042E; # DESERET CAPITAL LETTER SHORT I -10407; C; 1042F; # DESERET CAPITAL LETTER SHORT E -10408; C; 10430; # DESERET CAPITAL LETTER SHORT A -10409; C; 10431; # DESERET CAPITAL LETTER SHORT AH -1040A; C; 10432; # DESERET CAPITAL LETTER SHORT O -1040B; C; 10433; # DESERET CAPITAL LETTER SHORT OO -1040C; C; 10434; # DESERET CAPITAL LETTER AY -1040D; C; 10435; # DESERET CAPITAL LETTER OW -1040E; C; 10436; # DESERET CAPITAL LETTER WU -1040F; C; 10437; # DESERET CAPITAL LETTER YEE -10410; C; 10438; # DESERET CAPITAL LETTER H -10411; C; 10439; # DESERET CAPITAL LETTER PEE -10412; C; 1043A; # DESERET CAPITAL LETTER BEE -10413; C; 1043B; # DESERET CAPITAL LETTER TEE -10414; C; 1043C; # DESERET CAPITAL LETTER DEE -10415; C; 1043D; # DESERET CAPITAL LETTER CHEE -10416; C; 1043E; # DESERET CAPITAL LETTER JEE -10417; C; 1043F; # DESERET CAPITAL LETTER KAY -10418; C; 10440; # DESERET CAPITAL LETTER GAY -10419; C; 10441; # DESERET CAPITAL LETTER EF -1041A; C; 10442; # DESERET CAPITAL LETTER VEE -1041B; C; 10443; # DESERET CAPITAL LETTER ETH -1041C; C; 10444; # DESERET CAPITAL LETTER THEE -1041D; C; 10445; # DESERET CAPITAL LETTER ES -1041E; C; 10446; # DESERET CAPITAL LETTER ZEE -1041F; C; 10447; # DESERET CAPITAL LETTER ESH -10420; C; 10448; # DESERET CAPITAL LETTER ZHEE -10421; C; 10449; # DESERET CAPITAL LETTER ER -10422; C; 1044A; # DESERET CAPITAL LETTER EL -10423; C; 1044B; # DESERET CAPITAL LETTER EM -10424; C; 1044C; # DESERET CAPITAL LETTER EN -10425; C; 1044D; # DESERET CAPITAL LETTER ENG -10426; C; 1044E; # DESERET CAPITAL LETTER OI -10427; C; 1044F; # DESERET CAPITAL LETTER EW diff --git a/t/CORE/Cname.pm b/t/CORE/Cname.pm deleted file mode 100644 index 562f59ae6..000000000 --- a/t/CORE/Cname.pm +++ /dev/null @@ -1,42 +0,0 @@ -package Cname; -our $Evil='A'; - -sub translator { - my $str = shift; - if ( $str eq 'EVIL' ) { - # Returns A first time, AB second, ABC third ... A-ZA the 27th time. - (my $c=substr("A".$Evil,-1))++; - my $r=$Evil; - $Evil.=$c; - return $r; - } - if ( $str eq 'EMPTY-STR') { - return ""; - } - if ( $str eq 'NULL') { - return "\0"; - } - if ( $str eq 'LONG-STR') { - return 'A' x 255; - } - # Should exceed limit for regex \N bytes in a sequence. Anyway it will if - # UCHAR_MAX is 255. - if ( $str eq 'TOO-LONG-STR') { - return 'A' x 256; - } - if ($str eq 'MALFORMED') { - $str = "\xDF\xDFabc"; - utf8::upgrade($str); - - # Create a malformed in first and second characters. - $str =~ s/^\C/A/; - $str =~ s/^(\C\C)\C/$1A/; - } - return $str; -} - -sub import { - shift; - $^H{charnames} = \&translator; -} -1; diff --git a/t/CORE/TEST b/t/CORE/TEST deleted file mode 100755 index 3df0d7d04..000000000 --- a/t/CORE/TEST +++ /dev/null @@ -1,809 +0,0 @@ -#!./perl - -# This is written in a peculiar style, since we're trying to avoid -# most of the constructs we'll be testing for. (This comment is -# probably obsolete on the avoidance side, though still currrent -# on the peculiarity side.) - -# t/TEST and t/harness need to share code. The logical way to do this would be -# to have the common code in a file both require or use. However, t/TEST needs -# to still work, to generate test results, even if require isn't working, so -# we cannot do that. t/harness has no such restriction, so it is quite -# acceptable to have it require t/TEST. - -# In which case, we need to stop t/TEST actually running tests, as all -# t/harness needs are its subroutines. - - -# directories with special sets of test switches -my %dir_to_switch = - (base => '', - comp => '', - run => '', - '../ext/File-Glob/t' => '-I.. -MTestInit', # FIXME - tests assume t/ - ); - -# "not absolute" is the the default, as it saves some fakery within TestInit -# which can peturb tests, and takes CPU. Working with the upstream author of -# any of these, to figure out how to remove them from this list, considered -# "a good thing". -my %abs = ( - '../cpan/Archive-Extract' => 1, - '../cpan/Archive-Tar' => 1, - '../cpan/AutoLoader' => 1, - '../cpan/CPAN' => 1, - '../cpan/Class-ISA' => 1, - '../cpan/Devel-PPPort' => 1, - '../cpan/Encode' => 1, - '../cpan/ExtUtils-Constant' => 1, - '../cpan/ExtUtils-MakeMaker' => 1, - '../cpan/File-Fetch' => 1, - '../cpan/IPC-Cmd' => 1, - '../cpan/IPC-SysV' => 1, - '../cpan/Locale-Codes' => 1, - '../cpan/Log-Message' => 1, - '../cpan/Math-Complex' => 1, - '../cpan/Module-Build' => 1, - '../cpan/Module-Load' => 1, - '../cpan/Module-Load-Conditional' => 1, - '../cpan/Object-Accessor' => 1, - '../cpan/Package-Constants' => 1, - '../cpan/Parse-CPAN-Meta' => 1, - '../cpan/Pod-Simple' => 1, - '../cpan/Term-UI' => 1, - '../cpan/Test-Simple' => 1, - '../cpan/Tie-File' => 1, - '../cpan/podlators' => 1, - '../dist/Cwd' => 1, - '../dist/ExtUtils-Command' => 1, - '../dist/ExtUtils-Install' => 1, - '../dist/ExtUtils-Manifest' => 1, - '../dist/ExtUtils-ParseXS' => 1, - ); - -my %temp_no_core = - ('../cpan/B-Debug' => 1, - '../cpan/Compress-Raw-Bzip2' => 1, - '../cpan/Compress-Raw-Zlib' => 1, - '../cpan/Devel-PPPort' => 1, - '../cpan/Getopt-Long' => 1, - '../cpan/IO-Compress' => 1, - '../cpan/MIME-Base64' => 1, - '../cpan/parent' => 1, - '../cpan/Parse-CPAN-Meta' => 1, - '../cpan/Pod-Simple' => 1, - '../cpan/podlators' => 1, - '../cpan/Test-Simple' => 1, - '../cpan/Tie-RefHash' => 1, - '../cpan/Time-HiRes' => 1, - '../cpan/Unicode-Collate' => 1, - '../cpan/Unicode-Normalize' => 1, - ); - -# delete env vars that may influence the results -# but allow override via *_TEST env var if wanted -# (e.g. PERL5OPT_TEST=-d:NYTProf) -for my $envname (qw(PERL5LIB PERLLIB PERL5OPT)) { - my $override = $ENV{"${envname}_TEST"}; - if (defined $override) { - warn "$0: $envname=$override\n"; - $ENV{$envname} = $override; - } - else { - delete $ENV{$envname}; - } -} - -if ($::do_nothing) { - return 1; -} - -# Location to put the Valgrind log. -our $Valgrind_Log; - -$| = 1; - -# for testing TEST only -#BEGIN { require '../lib/strict.pm'; "strict"->import() }; -#BEGIN { require '../lib/warnings.pm'; "warnings"->import() }; - -# remove empty elements due to insertion of empty symbols via "''p1'" syntax -@ARGV = grep($_,@ARGV) if $^O eq 'VMS'; -our $show_elapsed_time = $ENV{HARNESS_TIMER} || 0; - -# Cheesy version of Getopt::Std. We can't replace it with that, because we -# can't rely on require working. -{ - my @argv = (); - foreach my $idx (0..$#ARGV) { - push( @argv, $ARGV[$idx] ), next unless $ARGV[$idx] =~ /^-(\S+)$/; - $::benchmark = 1 if $1 eq 'benchmark'; - $::core = 1 if $1 eq 'core'; - $::verbose = 1 if $1 eq 'v'; - $::torture = 1 if $1 eq 'torture'; - $::with_utf8 = 1 if $1 eq 'utf8'; - $::with_utf16 = 1 if $1 eq 'utf16'; - $::taintwarn = 1 if $1 eq 'taintwarn'; - if ($1 =~ /^deparse(,.+)?$/) { - $::deparse = 1; - $::deparse_opts = $1; - } - } - @ARGV = @argv; -} - -chdir 't' if -f 't/TEST'; -if (-f 'TEST' && -f 'harness' && -d '../lib') { - @INC = '../lib'; -} - -die "You need to run \"make test\" first to set things up.\n" - unless -e 'perl' or -e 'perl.exe' or -e 'perl.pm'; - -if ($ENV{PERL_3LOG}) { # Tru64 third(1) tool, see perlhack - unless (-x 'perl.third') { - unless (-x '../perl.third') { - die "You need to run \"make perl.third first.\n"; - } - else { - print "Symlinking ../perl.third as perl.third...\n"; - die "Failed to symlink: $!\n" - unless symlink("../perl.third", "perl.third"); - die "Symlinked but no executable perl.third: $!\n" - unless -x 'perl.third'; - } - } -} - -# check leakage for embedders -$ENV{PERL_DESTRUCT_LEVEL} = 2 unless exists $ENV{PERL_DESTRUCT_LEVEL}; - -$ENV{EMXSHELL} = 'sh'; # For OS/2 - -if ($show_elapsed_time) { require Time::HiRes } - -my %skip = ( - '.' => 1, - '..' => 1, - 'CVS' => 1, - 'RCS' => 1, - 'SCCS' => 1, - '.svn' => 1, - ); - -# Roll your own File::Find! -sub _find_tests { - my($dir) = @_; - opendir DIR, $dir or die "Trouble opening $dir: $!"; - foreach my $f (sort { $a cmp $b } readdir DIR) { - next if $skip{$f}; - - my $fullpath = "$dir/$f"; - - if (-d $fullpath) { - _find_tests($fullpath); - } elsif ($f =~ /\.t$/) { - push @ARGV, $fullpath; - } - } -} - - -# Scan the text of the test program to find switches and special options -# we might need to apply. -sub _scan_test { - my($test, $type) = @_; - - open(my $script, "<", $test) or die "Can't read $test.\n"; - my $first_line = <$script>; - - $first_line =~ tr/\0//d if $::with_utf16; - - my $switch = ""; - if ($first_line =~ /#!.*\bperl.*\s-\w*([tT])/) { - $switch = "-$1"; - } else { - if ($::taintwarn) { - # not all tests are expected to pass with this option - $switch = '-t'; - } else { - $switch = ''; - } - } - - my $file_opts = ""; - if ($type eq 'deparse') { - # Look for #line directives which change the filename - while (<$script>) { - $file_opts = $file_opts . ",-f$3$4" - if /^#\s*line\s+(\d+)\s+((\w+)|"([^"]+)")/; - } - } - - close $script; - - my $perl = './perl'; - my $lib = '../lib'; - my $run_dir; - my $return_dir; - - $test =~ /^(.+)\/[^\/]+/; - my $dir = $1; - my $testswitch = $dir_to_switch{$dir}; - if (!defined $testswitch) { - if ($test =~ s!^(\.\./(cpan|dist|ext)/[^/]+)/t!t!) { - $run_dir = $1; - $return_dir = '../../t'; - $lib = '../../lib'; - $perl = '../../t/perl'; - $testswitch = "-I../.. -MTestInit=U2T"; - if ($2 eq 'cpan' || $2 eq 'dist') { - if($abs{$run_dir}) { - $testswitch = $testswitch . ',A'; - } - if ($temp_no_core{$run_dir}) { - $testswitch = $testswitch . ',NC'; - } - } - } elsif ($test =~ m!^\.\./lib!) { - $testswitch = '-I.. -MTestInit=U1'; # -T will remove . from @INC - } else { - $testswitch = '-I.. -MTestInit'; # -T will remove . from @INC - } - } - - my $utf8 = ($::with_utf8 || $::with_utf16) ? "-I$lib -Mutf8" : ''; - - my %options = ( - perl => $perl, - lib => $lib, - test => $test, - run_dir => $run_dir, - return_dir => $return_dir, - testswitch => $testswitch, - utf8 => $utf8, - file => $file_opts, - switch => $switch, - ); - - return \%options; -} - -sub _cmd { - my($options, $type) = @_; - - my $test = $options->{test}; - - my $cmd; - if ($type eq 'deparse') { - my $perl = "$options->{perl} $options->{testswitch}"; - my $lib = $options->{lib}; - - $cmd = ( - "$perl $options->{switch} -I$lib -MO=-qq,Deparse,-sv1.,". - "-l$::deparse_opts$options->{file} ". - "$test > $test.dp ". - "&& $perl $options->{switch} -I$lib $test.dp" - ); - } - elsif ($type eq 'perl') { - my $perl = $options->{perl}; - my $redir = $^O eq 'VMS' ? '2>&1' : ''; - - if ($ENV{PERL_VALGRIND}) { - my $perl_supp = $options->{return_dir} ? "$options->{return_dir}/perl.supp" : "perl.supp"; - my $valgrind = $ENV{VALGRIND} // 'valgrind'; - my $vg_opts = $ENV{VG_OPTS} - // "--suppressions=$perl_supp --leak-check=yes " - . "--leak-resolution=high --show-reachable=yes " - . "--num-callers=50 --track-origins=yes"; - $perl = "$valgrind --log-fd=3 $vg_opts $perl"; - $redir = "3>$Valgrind_Log"; - if ($options->{run_dir}) { - $Valgrind_Log = "$options->{run_dir}/$Valgrind_Log"; - } - } - - my $args = "$options->{testswitch} $options->{switch} $options->{utf8}"; - $cmd = $perl . _quote_args($args) . " $test $redir"; - } - - return $cmd; -} - -sub _before_fork { - my ($options) = @_; - - if ($options->{run_dir}) { - my $run_dir = $options->{run_dir}; - chdir $run_dir or die "Can't chdir to '$run_dir': $!"; - } - - return; -} - -sub _after_fork { - my ($options) = @_; - - if ($options->{return_dir}) { - my $return_dir = $options->{return_dir}; - chdir $return_dir - or die "Can't chdir from '$options->{run_dir}' to '$return_dir': $!"; - } - - return; -} - -sub _run_test { - my ($test, $type) = @_; - - my $options = _scan_test($test, $type); - # $test might have changed if we're in ext/Foo, so don't use it anymore - # from now on. Use $options->{test} instead. - - _before_fork($options); - - my $cmd = _cmd($options, $type); - - open(my $results, "$cmd |") or print "can't run '$cmd': $!.\n"; - - _after_fork($options); - - # Our environment may force us to use UTF-8, but we can't be sure that - # anything we're reading from will be generating (well formed) UTF-8 - # This may not be the best way - possibly we should unset ${^OPEN} up - # top? - binmode $results; - - return $results; -} - -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 = $argstring . ' ' . $_; - } - return $argstring; -} - -sub _populate_hash { - return unless defined $_[0]; - return map {$_, 1} split /\s+/, $_[0]; -} - -sub _tests_from_manifest { - my ($extensions, $known_extensions) = @_; - my %skip; - my %extensions = _populate_hash($extensions); - my %known_extensions = _populate_hash($known_extensions); - - foreach (keys %known_extensions) { - $skip{$_} = 1 unless $extensions{$_}; - } - - my @results; - my $mani = '../MANIFEST'; - if (open(MANI, $mani)) { - while () { - if (m!^((?:cpan|dist|ext)/(\S+)/+(?:[^/\s]+\.t|test\.pl)|lib/\S+?(?:\.t|test\.pl))\s!) { - my $t = $1; - my $extension = $2; - if (!$::core || $t =~ m!^lib/[a-z]!) { - if (defined $extension) { - $extension =~ s!/t(:?/\S+)*$!!; - # XXX Do I want to warn that I'm skipping these? - next if $skip{$extension}; - my $flat_extension = $extension; - $flat_extension =~ s!-!/!g; - next if $skip{$flat_extension}; # Foo/Bar may live in Foo-Bar - } - my $path = "../$t"; - push @results, $path; - $::path_to_name{$path} = $t; - } - } - } - close MANI; - } else { - warn "$0: cannot open $mani: $!\n"; - } - return @results; -} - -unless (@ARGV) { - # base first, as TEST bails out if that can't run - # then comp, to validate that require works - # then run, to validate that -M works - # then we know we can -MTestInit for everything else, making life simpler - foreach my $dir (qw(base comp run cmd io re op uni mro)) { - _find_tests($dir); - } - _find_tests("lib") unless $::core; - # Config.pm may be broken for make minitest. And this is only a refinement - # for skipping tests on non-default builds, so it is allowed to fail. - # What we want to to is make a list of extensions which we did not build. - my $configsh = '../config.sh'; - my ($extensions, $known_extensions); - if (-f $configsh) { - open FH, $configsh or die "Can't open $configsh: $!"; - while () { - if (/^extensions=['"](.*)['"]$/) { - $extensions = $1; - } - elsif (/^known_extensions=['"](.*)['"]$/) { - $known_extensions = $1; - } - } - if (!defined $known_extensions) { - warn "No known_extensions line found in $configsh"; - } - if (!defined $extensions) { - warn "No extensions line found in $configsh"; - } - } - # The "complex" constructions of list return from a subroutine, and push of - # a list, might fail if perl is really hosed, but they aren't needed for - # make minitest, and the building of extensions will likely also fail if - # something is that badly wrong. - push @ARGV, _tests_from_manifest($extensions, $known_extensions); - unless ($::core) { - _find_tests('x2p'); - _find_tests('porting'); - _find_tests('japh') if $::torture; - _find_tests('t/benchmark') if $::benchmark or $ENV{PERL_BENCHMARK}; - } -} - -if ($::deparse) { - _testprogs('deparse', '', @ARGV); -} -elsif ($::with_utf16) { - for my $e (0, 1) { - for my $b (0, 1) { - print STDERR "# ENDIAN $e BOM $b\n"; - my @UARGV; - for my $a (@ARGV) { - my $u = $a . "." . ($e ? "l" : "b") . "e" . ($b ? "b" : ""); - my $f = $e ? "v" : "n"; - push @UARGV, $u; - unlink($u); - if (open(A, $a)) { - if (open(U, ">$u")) { - print U pack("$f", 0xFEFF) if $b; - while () { - print U pack("$f*", unpack("C*", $_)); - } - close(U); - } - close(A); - } - } - _testprogs('perl', '', @UARGV); - unlink(@UARGV); - } - } -} -else { - _testprogs('perl', '', @ARGV); -} - -sub _testprogs { - my ($type, $args, @tests) = @_; - - print <<'EOT' if ($type eq 'deparse'); ------------------------------------------------------------------------------- -TESTING DEPARSER ------------------------------------------------------------------------------- -EOT - - $::bad_files = 0; - - foreach my $t (@tests) { - unless (exists $::path_to_name{$t}) { - my $tname = "t/$t"; - $::path_to_name{$t} = $tname; - } - } - my $maxlen = 0; - foreach (@::path_to_name{@tests}) { - s/\.\w+\z/./; - my $len = length ; - $maxlen = $len if $len > $maxlen; - } - # + 3 : we want three dots between the test name and the "ok" - my $dotdotdot = $maxlen + 3 ; - my $valgrind = 0; - my $total_files = @tests; - my $good_files = 0; - my $tested_files = 0; - my $totmax = 0; - my %failed_tests; - - while (my $test = shift @tests) { - my $test_start_time = $show_elapsed_time ? Time::HiRes::time() : 0; - - if ($test =~ /^$/) { - next; - } - if ($type eq 'deparse') { - if ($test eq "comp/redef.t") { - # Redefinition happens at compile time - next; - } - elsif ($test =~ m{lib/Switch/t/}) { - # B::Deparse doesn't support source filtering - next; - } - } - my $te = $::path_to_name{$test} . '.' - x ($dotdotdot - length($::path_to_name{$test})); - - if ($^O ne 'VMS') { # defer printing on VMS due to piping bug - print $te; - $te = ''; - } - - (local $Valgrind_Log = "$test.valgrind-current") =~ s/^.*\///; - my $results = _run_test($test, $type); - - my $failure; - my $next = 0; - my $seen_leader = 0; - my $seen_ok = 0; - my $trailing_leader = 0; - my $max; - my %todo; - while (<$results>) { - next if /^\s*$/; # skip blank lines - if (/^1..$/ && ($^O eq 'VMS')) { - # VMS pipe bug inserts blank lines. - my $l2 = ; - if ($l2 =~ /^\s*$/) { - $l2 = ; - } - $_ = '1..' . $l2; - } - if ($::verbose) { - print $_; - } - unless (/^\#/) { - if ($trailing_leader) { - # shouldn't be anything following a postfix 1..n - $failure = 'FAILED--extra output after trailing 1..n'; - last; - } - if (/^1\.\.([0-9]+)( todo ([\d ]+))?/) { - if ($seen_leader) { - $failure = 'FAILED--seen duplicate leader'; - last; - } - $max = $1; - %todo = map { $_ => 1 } split / /, $3 if $3; - $totmax = $totmax + $max; - $tested_files = $tested_files + 1; - if ($seen_ok) { - # 1..n appears at end of file - $trailing_leader = 1; - if ($next != $max) { - $failure = "FAILED--expected $max tests, saw $next"; - last; - } - } - else { - $next = 0; - } - $seen_leader = 1; - } - else { - if (/^(not )?ok(?: (\d+))?[^\#]*(\s*\#.*)?/) { - unless ($seen_leader) { - unless ($seen_ok) { - $next = 0; - } - } - $seen_ok = 1; - $next = $next + 1; - my($not, $num, $extra, $istodo) = ($1, $2, $3, 0); - $num = $next unless $num; - - if ($num == $next) { - - # SKIP is essentially the same as TODO for t/TEST - # this still conforms to TAP: - # http://search.cpan.org/dist/TAP/TAP.pm - $extra and $istodo = $extra =~ /#\s*(?:TODO|SKIP)\b/; - $istodo = 1 if $todo{$num}; - - if( $not && !$istodo ) { - $failure = "FAILED at test $num"; - last; - } - } - else { - $failure ="FAILED--expected test $next, saw test $num"; - last; - } - } - elsif (/^Bail out!\s*(.*)/i) { # magic words - die "FAILED--Further testing stopped" . ($1 ? ": $1\n" : ".\n"); - } - else { - # module tests are allowed extra output, - # because Test::Harness allows it - next if $test =~ /^\W*(cpan|dist|ext|lib)\b/; - $failure = "FAILED--unexpected output at test $next"; - last; - } - } - } - } - close $results; - - if (not defined $failure) { - $failure = 'FAILED--no leader found' unless $seen_leader; - } - - if ($ENV{PERL_VALGRIND}) { - my @valgrind; - if (-e $Valgrind_Log) { - if (open(V, $Valgrind_Log)) { - @valgrind = ; - close V; - } else { - warn "$0: Failed to open '$Valgrind_Log': $!\n"; - } - } - if ($ENV{VG_OPTS} =~ /cachegrind/) { - if (rename $Valgrind_Log, "$test.valgrind") { - $valgrind = $valgrind + 1; - } else { - warn "$0: Failed to create '$test.valgrind': $!\n"; - } - } - elsif (@valgrind) { - my $leaks = 0; - my $errors = 0; - for my $i (0..$#valgrind) { - local $_ = $valgrind[$i]; - if (/^==\d+== ERROR SUMMARY: (\d+) errors? /) { - $errors = $errors + $1; # there may be multiple error summaries - } elsif (/^==\d+== LEAK SUMMARY:/) { - for my $off (1 .. 4) { - if ($valgrind[$i+$off] =~ - /(?:lost|reachable):\s+\d+ bytes in (\d+) blocks/) { - $leaks = $leaks + $1; - } - } - } - } - if ($errors or $leaks) { - if (rename $Valgrind_Log, "$test.valgrind") { - $valgrind = $valgrind + 1; - } else { - warn "$0: Failed to create '$test.valgrind': $!\n"; - } - } - } else { - warn "No valgrind output?\n"; - } - if (-e $Valgrind_Log) { - unlink $Valgrind_Log - or warn "$0: Failed to unlink '$Valgrind_Log': $!\n"; - } - } - if ($type eq 'deparse') { - unlink "./$test.dp"; - } - if ($ENV{PERL_3LOG}) { - my $tpp = $test; - $tpp =~ s:^\.\./::; - $tpp =~ s:/:_:g; - $tpp =~ s:\.t$:.3log:; - rename("perl.3log", $tpp) || - die "rename: perl3.log to $tpp: $!\n"; - } - if (not defined $failure and $next != $max) { - $failure="FAILED--expected $max tests, saw $next"; - } - - if( !defined $failure # don't mask a test failure - and $? ) - { - $failure = "FAILED--non-zero wait status: $?"; - } - - if (defined $failure) { - print "${te}$failure\n"; - $::bad_files = $::bad_files + 1; - if ($test =~ /^base/) { - die "Failed a basic test ($test) -- cannot continue.\n"; - } - $failed_tests{$test} = 1; - } - else { - if ($max) { - my $elapsed; - if ( $show_elapsed_time ) { - $elapsed = sprintf( " %8.0f ms", (Time::HiRes::time() - $test_start_time) * 1000 ); - } - else { - $elapsed = ""; - } - print "${te}ok$elapsed\n"; - $good_files = $good_files + 1; - } - else { - print "${te}skipped\n"; - $tested_files = $tested_files - 1; - } - } - } # while tests - - if ($::bad_files == 0) { - if ($good_files) { - print "All tests successful.\n"; - # XXX add mention of 'perlbug -ok' ? - } - else { - die "FAILED--no tests were run for some reason.\n"; - } - } - else { - my $pct = $tested_files ? sprintf("%.2f", ($tested_files - $::bad_files) / $tested_files * 100) : "0.00"; - my $s = $::bad_files == 1 ? "" : "s"; - warn "Failed $::bad_files test$s out of $tested_files, $pct% okay.\n"; - for my $test ( sort keys %failed_tests ) { - print "\t$test\n"; - } - warn <<'SHRDLU_1'; -### Since not all tests were successful, you may want to run some of -### them individually and examine any diagnostic messages they produce. -### See the INSTALL document's section on "make test". -SHRDLU_1 - warn <<'SHRDLU_2' if $good_files / $total_files > 0.8; -### You have a good chance to get more information by running -### ./perl harness -### in the 't' directory since most (>=80%) of the tests succeeded. -SHRDLU_2 - if (eval {require Config; import Config; 1}) { - if ($::Config{usedl} && (my $p = $::Config{ldlibpthname})) { - warn <; - -print "ok 18 - was the test for the deprecated use of bare << to mean <<\"\"\n"; -#print <<; # Yow! -#ok 18 -# -## previous line intentionally left blank. - -print < -1; - print "ok 37\n"; -# print "($@)\n" if $@; - - eval 'my $ {^XYZ};'; - print "not " unless index ($@, 'Can\'t use global $^XYZ in "my"') > -1; - print "ok 38\n"; -# print "($@)\n" if $@; - -# Now let's make sure that caret variables are all forced into the main package. - package Someother; - $^Q = 'Someother'; - $ {^Quixote} = 'Someother 2'; - $ {^M} = 'Someother 3'; - package main; - print "not " unless $^Q eq 'Someother'; - print "ok 39\n"; - print "not " unless $ {^Quixote} eq 'Someother 2'; - print "ok 40\n"; - print "not " unless $ {^M} eq 'Someother 3'; - print "ok 41\n"; - - -} - -# see if eval '', s///e, and heredocs mix - -sub T { - my ($where, $num) = @_; - my ($p,$f,$l) = caller; - print "# $p:$f:$l vs /$where/\nnot " unless "$p:$f:$l" =~ /$where/; - print "ok $num\n"; -} - -my $test = 42; - -{ -# line 42 "plink" - local $_ = "not ok "; - eval q{ - s/^not /<@nosuch<" eq "><")) || print "# $@", "not "; - print "ok $test\n"; - ++$test; - - # Look at this! This is going to be a common error in the future: - eval(q("fred@example.com" eq "fred.com")) || print "# $@", "not "; - print "ok $test\n"; - ++$test; - - # Let's make sure that normal array interpolation still works right - # For some reason, this appears not to be tested anywhere else. - my @a = (1,2,3); - print +((">@a<" eq ">1 2 3<") ? '' : 'not '), "ok $test\n"; - ++$test; - - # Ditto. - eval(q{@nosuch = ('a', 'b', 'c'); ">@nosuch<" eq ">a b c<"}) - || print "# $@", "not "; - print "ok $test\n"; - ++$test; - - # This isn't actually a lex test, but it's testing the same feature - sub makearray { - my @array = ('fish', 'dog', 'carrot'); - *R::crackers = \@array; - } - - eval(q{makearray(); ">@R::crackers<" eq ">fish dog carrot<"}) - || print "# $@", "not "; - print "ok $test\n"; - ++$test; -} - -# Tests 52-54 -# => should only quote foo::bar if it isn't a real sub. AMS, 20010621 - -sub xyz::foo { "bar" } -my %str = ( - foo => 1, - xyz::foo => 1, - xyz::bar => 1, -); - -my $test = 52; -print ((exists $str{foo} ? "" : "not ")."ok $test\n"); ++$test; -print ((exists $str{bar} ? "" : "not ")."ok $test\n"); ++$test; -print ((exists $str{xyz::bar} ? "" : "not ")."ok $test\n"); ++$test; - -sub foo::::::bar { print "ok $test\n"; $test++ } -foo::::::bar; - -eval "\$x =\xE2foo"; -if ($@ =~ /Unrecognized character \\xE2; marked by <-- HERE after \$x =<-- HERE near column 5/) { print "ok $test\n"; } else { print "not ok $test\n"; } -$test++; - -# Is "[~" scanned correctly? -@a = (1,2,3); -print "not " unless($a[~~2] == 3); -print "ok 57\n"; diff --git a/t/CORE/base/num.t b/t/CORE/base/num.t deleted file mode 100644 index 8a61fb989..000000000 --- a/t/CORE/base/num.t +++ /dev/null @@ -1,211 +0,0 @@ -#!./perl - -print "1..53\n"; - -# First test whether the number stringification works okay. -# (Testing with == would exercise the IV/NV part, not the PV.) - -$a = 1; "$a"; -print $a eq "1" ? "ok 1\n" : "not ok 1 # $a\n"; - -$a = -1; "$a"; -print $a eq "-1" ? "ok 2\n" : "not ok 2 # $a\n"; - -$a = 1.; "$a"; -print $a eq "1" ? "ok 3\n" : "not ok 3 # $a\n"; - -$a = -1.; "$a"; -print $a eq "-1" ? "ok 4\n" : "not ok 4 # $a\n"; - -$a = 0.1; "$a"; -print $a eq "0.1" ? "ok 5\n" : "not ok 5 # $a\n"; - -$a = -0.1; "$a"; -print $a eq "-0.1" ? "ok 6\n" : "not ok 6 # $a\n"; - -$a = .1; "$a"; -print $a eq "0.1" ? "ok 7\n" : "not ok 7 # $a\n"; - -$a = -.1; "$a"; -print $a eq "-0.1" ? "ok 8\n" : "not ok 8 # $a\n"; - -$a = 10.01; "$a"; -print $a eq "10.01" ? "ok 9\n" : "not ok 9 # $a\n"; - -$a = 1e3; "$a"; -print $a eq "1000" ? "ok 10\n" : "not ok 10 # $a\n"; - -$a = 10.01e3; "$a"; -print $a eq "10010" ? "ok 11\n" : "not ok 11 # $a\n"; - -$a = 0b100; "$a"; -print $a eq "4" ? "ok 12\n" : "not ok 12 # $a\n"; - -$a = 0100; "$a"; -print $a eq "64" ? "ok 13\n" : "not ok 13 # $a\n"; - -$a = 0x100; "$a"; -print $a eq "256" ? "ok 14\n" : "not ok 14 # $a\n"; - -$a = 1000; "$a"; -print $a eq "1000" ? "ok 15\n" : "not ok 15 # $a\n"; - -# more hex and binary tests below starting at 51 - -# Okay, now test the numerics. -# We may be assuming too much, given the painfully well-known floating -# point sloppiness, but the following are still quite reasonable -# assumptions which if not working would confuse people quite badly. - -$a = 1; "$a"; # Keep the stringification as a potential troublemaker. -print $a + 1 == 2 ? "ok 16\n" : "not ok 16 #" . $a + 1 . "\n"; -# Don't know how useful printing the stringification of $a + 1 really is. - -$a = -1; "$a"; -print $a + 1 == 0 ? "ok 17\n" : "not ok 17 #" . $a + 1 . "\n"; - -$a = 1.; "$a"; -print $a + 1 == 2 ? "ok 18\n" : "not ok 18 #" . $a + 1 . "\n"; - -$a = -1.; "$a"; -print $a + 1 == 0 ? "ok 19\n" : "not ok 19 #" . $a + 1 . "\n"; - -sub ok { # Can't assume too much of floating point numbers. - my ($a, $b, $c) = @_; - abs($a - $b) <= $c; -} - -$a = 0.1; "$a"; -print ok($a + 1, 1.1, 0.05) ? "ok 20\n" : "not ok 20 #" . $a + 1 . "\n"; - -$a = -0.1; "$a"; -print ok($a + 1, 0.9, 0.05) ? "ok 21\n" : "not ok 21 #" . $a + 1 . "\n"; - -$a = .1; "$a"; -print ok($a + 1, 1.1, 0.005) ? "ok 22\n" : "not ok 22 #" . $a + 1 . "\n"; - -$a = -.1; "$a"; -print ok($a + 1, 0.9, 0.05) ? "ok 23\n" : "not ok 23 #" . $a + 1 . "\n"; - -$a = 10.01; "$a"; -print ok($a + 1, 11.01, 0.005) ? "ok 24\n" : "not ok 24 #" . $a + 1 . "\n"; - -$a = 1e3; "$a"; -print $a + 1 == 1001 ? "ok 25\n" : "not ok 25 #" . $a + 1 . "\n"; - -$a = 10.01e3; "$a"; -print $a + 1 == 10011 ? "ok 26\n" : "not ok 26 #" . $a + 1 . "\n"; - -$a = 0b100; "$a"; -print $a + 1 == 0b101 ? "ok 27\n" : "not ok 27 #" . $a + 1 . "\n"; - -$a = 0100; "$a"; -print $a + 1 == 0101 ? "ok 28\n" : "not ok 28 #" . $a + 1 . "\n"; - -$a = 0x100; "$a"; -print $a + 1 == 0x101 ? "ok 29\n" : "not ok 29 #" . $a + 1 . "\n"; - -$a = 1000; "$a"; -print $a + 1 == 1001 ? "ok 30\n" : "not ok 30 #" . $a + 1 . "\n"; - -# back to some basic stringify tests -# we expect NV stringification to work according to C sprintf %.*g rules - -if ($^O eq 'os2') { # In the long run, fix this. For 5.8.0, deal. - $a = 0.01; "$a"; - print $a eq "0.01" || $a eq '1e-02' ? "ok 31\n" : "not ok 31 # $a\n"; - - $a = 0.001; "$a"; - print $a eq "0.001" || $a eq '1e-03' ? "ok 32\n" : "not ok 32 # $a\n"; - - $a = 0.0001; "$a"; - print $a eq "0.0001" || $a eq '1e-04' ? "ok 33\n" : "not ok 33 # $a\n"; -} else { - $a = 0.01; "$a"; - print $a eq "0.01" ? "ok 31\n" : "not ok 31 # $a\n"; - - $a = 0.001; "$a"; - print $a eq "0.001" ? "ok 32\n" : "not ok 32 # $a\n"; - - $a = 0.0001; "$a"; - print $a eq "0.0001" ? "ok 33\n" : "not ok 33 # $a\n"; -} - -$a = 0.00009; "$a"; -print $a eq "9e-05" || $a eq "9e-005" ? "ok 34\n" : "not ok 34 # $a\n"; - -$a = 1.1; "$a"; -print $a eq "1.1" ? "ok 35\n" : "not ok 35 # $a\n"; - -$a = 1.01; "$a"; -print $a eq "1.01" ? "ok 36\n" : "not ok 36 # $a\n"; - -$a = 1.001; "$a"; -print $a eq "1.001" ? "ok 37\n" : "not ok 37 # $a\n"; - -$a = 1.0001; "$a"; -print $a eq "1.0001" ? "ok 38\n" : "not ok 38 # $a\n"; - -$a = 1.00001; "$a"; -print $a eq "1.00001" ? "ok 39\n" : "not ok 39 # $a\n"; - -$a = 1.000001; "$a"; -print $a eq "1.000001" ? "ok 40\n" : "not ok 40 # $a\n"; - -$a = 0.; "$a"; -print $a eq "0" ? "ok 41\n" : "not ok 41 # $a\n"; - -$a = 100000.; "$a"; -print $a eq "100000" ? "ok 42\n" : "not ok 42 # $a\n"; - -$a = -100000.; "$a"; -print $a eq "-100000" ? "ok 43\n" : "not ok 43 # $a\n"; - -$a = 123.456; "$a"; -print $a eq "123.456" ? "ok 44\n" : "not ok 44 # $a\n"; - -$a = 1e34; "$a"; -unless ($^O eq 'posix-bc') -{ print $a eq "1e+34" || $a eq "1e+034" ? "ok 45\n" : "not ok 45 # $a\n"; } -else -{ print "ok 45 # skipped on $^O\n"; } - -# see bug #15073 - -$a = 0.00049999999999999999999999999999999999999; -$b = 0.0005000000000000000104; -print $a <= $b ? "ok 46\n" : "not ok 46\n"; - -if ($^O eq 'ultrix' || $^O eq 'VMS') { - # Ultrix enters looong nirvana over this. VMS blows up when configured with - # D_FLOAT (but with G_FLOAT or IEEE works fine). The test should probably - # make the number of 0's a function of NV_DIG, but that's not in Config and - # we probably don't want to suck Config into a base test anyway. - print "ok 47\n"; -} else { - $a = 0.00000000000000000000000000000000000000000000000000000000000000000001; - print $a > 0 ? "ok 47\n" : "not ok 47\n"; -} - -$a = 80000.0000000000000000000000000; -print $a == 80000.0 ? "ok 48\n" : "not ok 48\n"; - -$a = 1.0000000000000000000000000000000000000000000000000000000000000000000e1; -print $a == 10.0 ? "ok 49\n" : "not ok 49\n"; - -# From Math/Trig - number has to be long enough to exceed at least DBL_DIG - -$a = 57.295779513082320876798154814169; -print ok($a*10,572.95779513082320876798154814169,1e-10) ? "ok 50\n" : - "not ok 50 # $a\n"; - -# Allow uppercase base markers (#76296) - -$a = 0Xabcdef; "$a"; -print $a eq "11259375" ? "ok 51\n" : "not ok 51 # $a\n"; - -$a = 0XFEDCBA; "$a"; -print $a eq "16702650" ? "ok 52\n" : "not ok 52 # $a\n"; - -$a = 0B1101; "$a"; -print $a eq "13" ? "ok 53\n" : "not ok 53 # $a\n"; diff --git a/t/CORE/base/pat.t b/t/CORE/base/pat.t deleted file mode 100644 index 9e3f6151e..000000000 --- a/t/CORE/base/pat.t +++ /dev/null @@ -1,9 +0,0 @@ -#!./perl - -print "1..2\n"; - -# first test to see if we can run the tests. - -$_ = 'test'; -if (/^test/) { print "ok 1\n"; } else { print "not ok 1\n";} -if (/^foo/) { print "not ok 2\n"; } else { print "ok 2\n";} diff --git a/t/CORE/base/rs.t b/t/CORE/base/rs.t deleted file mode 100644 index af0413b6c..000000000 --- a/t/CORE/base/rs.t +++ /dev/null @@ -1,245 +0,0 @@ -#!./perl -# Test $! - -print "1..28\n"; - -$test_count = 1; -$teststring = "1\n12\n123\n1234\n1234\n12345\n\n123456\n1234567\n"; -$teststring2 = "1234567890123456789012345678901234567890"; - -# Create our test datafile -1 while unlink 'foo'; # in case junk left around -rmdir 'foo'; -my $TESTFILE; -open $TESTFILE, ">./foo" or die "error $! $^E opening"; -binmode $TESTFILE; -print $TESTFILE $teststring; -close $TESTFILE or die "error $! $^E closing"; - -$test_count_start = $test_count; # Needed to know how many tests to skip -open TESTFILE, "<./foo"; -binmode TESTFILE; -test_string(*TESTFILE); -close TESTFILE; -unlink "./foo"; - -# try the record reading tests. New file so we don't have to worry about -# the size of \n. -open $TESTFILE, ">./foo"; -print $TESTFILE $teststring2; -binmode $TESTFILE; -close $TESTFILE; -open TESTFILE, "<./foo"; -binmode TESTFILE; -test_record(*TESTFILE); -close TESTFILE; -$test_count_end = $test_count; # Needed to know how many tests to skip - - -# Now for the tricky bit--full record reading -if ($^O eq 'VMS') { - # Create a temp file. We jump through these hoops 'cause CREATE really - # doesn't like our methods for some reason. - my $FDLFILE; - open $FDLFILE, "> ./foo.fdl"; - print $FDLFILE "RECORD\n FORMAT VARIABLE\n"; - close $FDLFILE; - open my $CREATEFILE, "> ./foo.com"; - print $CREATEFILE '$ DEFINE/USER SYS$INPUT NL:', "\n"; - print $CREATEFILE '$ DEFINE/USER SYS$OUTPUT NL:', "\n"; - print $CREATEFILE '$ OPEN YOW []FOO.BAR/WRITE', "\n"; - print $CREATEFILE '$ CLOSE YOW', "\n"; - print $CREATEFILE "\$EXIT\n"; - close $CREATEFILE; - $throwaway = `\@\[\]foo`, "\n"; - open(my $TEMPFILE, ">./foo.bar") or print "# open failed $! $^E\n"; - print $TEMPFILE "foo\nfoobar\nbaz\n"; - close $TEMPFILE; - - open TESTFILE, "<./foo.bar"; - $/ = \10; - $bar = ; - if ($bar eq "foo\n") {print "ok $test_count\n";} else {print "not ok $test_count\n";} - $test_count++; - $bar = ; - if ($bar eq "foobar\n") {print "ok $test_count\n";} else {print "not ok $test_count\n";} - $test_count++; - # can we do a short read? - $/ = \2; - $bar = ; - if ($bar eq "ba") {print "ok $test_count\n";} else {print "not ok $test_count\n";} - $test_count++; - # do we get the rest of the record? - $bar = ; - if ($bar eq "z\n") {print "ok $test_count\n";} else {print "not ok $test_count\n";} - $test_count++; - - close TESTFILE; - 1 while unlink qw(foo.bar foo.com foo.fdl); -} else { - # Nobody else does this at the moment (well, maybe OS/390, but they can - # put their own tests in) so we just punt - foreach $test ($test_count..$test_count + 3) { - print "ok $test # skipped on non-VMS system\n"; - $test_count++; - } -} - -$/ = "\n"; - -# see if open/readline/close work on our and my variables -{ - if (open our $T, "./foo") { - my $line = <$T>; - print "# $line\n"; - length($line) == 40 or print "not "; - close $T or print "not "; - } - else { - print "not "; - } - print "ok $test_count # open/readline/close on our variable\n"; - $test_count++; -} - -{ - if (open my $T, "./foo") { - my $line = <$T>; - print "# $line\n"; - length($line) == 40 or print "not "; - close $T or print "not "; - } - else { - print "not "; - } - print "ok $test_count # open/readline/close on my variable\n"; - $test_count++; -} - - -{ - # If we do not include the lib directories, we may end up picking up a - # binary-incompatible previously-installed version. The eval won’t help in - # intercepting a SIGTRAP. - if (not eval q/use PerlIO::scalar; use PerlIO::via::scalar; 1/) { - # In-memory files necessitate PerlIO::via::scalar, thus a perl with - # perlio and dynaloading enabled. miniperl won't be able to run this - # test, so skip it - - # PerlIO::via::scalar has to be tested as well. - # use PerlIO::scalar succeeds with ./TEST and with ./perl harness but not with ./perl - - for $test ($test_count .. $test_count + ($test_count_end - $test_count_start - 1)) { - print "ok $test # skipped - Can't test in memory file with miniperl/without PerlIO::Scalar\n"; - $test_count++; - } - } - else { - # Test if a file in memory behaves the same as a real file (= re-run the test with a file in memory) - open TESTFILE, "<", \$teststring; - test_string(*TESTFILE); - close TESTFILE; - - open TESTFILE, "<", \$teststring2; - test_record(*TESTFILE); - close TESTFILE; - } -} - -# Get rid of the temp file -END { unlink "./foo"; } - -sub test_string { - *FH = shift; - - # Check the default $/ - $bar = ; - if ($bar ne "1\n") {print "not ";} - print "ok $test_count # default \$/\n"; - $test_count++; - - # explicitly set to \n - $/ = "\n"; - $bar = ; - if ($bar ne "12\n") {print "not ";} - print "ok $test_count # \$/ = \"\\n\"\n"; - $test_count++; - - # Try a non line terminator - $/ = 3; - $bar = ; - if ($bar ne "123") {print "not ";} - print "ok $test_count # \$/ = 3\n"; - $test_count++; - - # Eat the line terminator - $/ = "\n"; - $bar = ; - - # How about a larger terminator - $/ = "34"; - $bar = ; - if ($bar ne "1234") {print "not ";} - print "ok $test_count # \$/ = \"34\"\n"; - $test_count++; - - # Eat the line terminator - $/ = "\n"; - $bar = ; - - # Does paragraph mode work? - $/ = ''; - $bar = ; - if ($bar ne "1234\n12345\n\n") {print "not ";} - print "ok $test_count # \$/ = ''\n"; - $test_count++; - - # Try slurping the rest of the file - $/ = undef; - $bar = ; - if ($bar ne "123456\n1234567\n") {print "not ";} - print "ok $test_count # \$/ = undef\n"; - $test_count++; -} - -sub test_record { - *FH = shift; - - # Test straight number - $/ = \2; - $bar = ; - if ($bar ne "12") {print "not ";} - print "ok $test_count # \$/ = \\2\n"; - $test_count++; - - # Test stringified number - $/ = \"2"; - $bar = ; - if ($bar ne "34") {print "not ";} - print "ok $test_count # \$/ = \"2\"\n"; - $test_count++; - - # Integer variable - $foo = 2; - $/ = \$foo; - $bar = ; - if ($bar ne "56") {print "not ";} - print "ok $test_count # \$/ = \\\$foo (\$foo = 2)\n"; - $test_count++; - - # String variable - $foo = "2"; - $/ = \$foo; - $bar = ; - if ($bar ne "78") {print "not ";} - print "ok $test_count # \$/ = \\\$foo (\$foo = \"2\")\n"; - $test_count++; - - # Naughty straight number - should get the rest of the file - $/ = \0; - $bar = ; - if ($bar ne "90123456789012345678901234567890") {print "not ";} - print "ok $test_count # \$/ = \\0\n"; - $test_count++; -} - diff --git a/t/CORE/base/term.t b/t/CORE/base/term.t deleted file mode 100644 index e3715f1c8..000000000 --- a/t/CORE/base/term.t +++ /dev/null @@ -1,50 +0,0 @@ -#!./perl - - - -print "1..7\n"; - -# check "" interpretation - -$x = "\n"; -# 10 is ASCII/Iso Latin, 13 is Mac OS, 21 is EBCDIC. -if ($x eq chr(10)) { print "ok 1\n";} -elsif ($x eq chr(13)) { print "ok 1 # Mac OS\n"; } -elsif ($x eq chr(21)) { print "ok 1 # EBCDIC\n"; } -else {print "not ok 1\n";} - -# check `` processing - -$x = `$^X -le "print 'hi there'"`; -if ($x eq "hi there\n") {print "ok 2\n";} else {print "not ok 2\n";} - -# check $#array - -$x[0] = 'foo'; -$x[1] = 'foo'; -$tmp = $#x; -print "#3\t:$tmp: == :1:\n"; -if ($#x == '1') {print "ok 3\n";} else {print "not ok 3\n";} - -# check numeric literal - -$x = 1; -if ($x == '1') {print "ok 4\n";} else {print "not ok 4\n";} - -$x = '1E2'; -if (($x | 1) == 101) {print "ok 5\n";} else {print "not ok 5\n";} - -# check <> pseudoliteral - -open($try, "/dev/null") || open($try,"nla0:") || (die "Can't open /dev/null."); - -if (<$try> eq '') { - print "ok 6\n"; -} -else { - print "not ok 6\n"; - die "/dev/null IS NOT A CHARACTER SPECIAL FILE!!!!\n" unless -c '/dev/null'; -} - -open($try, "Makefile.PL") || (die "Can't open Makefile.PL."); -if (<$try> ne '') {print "ok 7\n";} else {print "not ok 7\n";} diff --git a/t/CORE/base/while.t b/t/CORE/base/while.t deleted file mode 100644 index fd3797951..000000000 --- a/t/CORE/base/while.t +++ /dev/null @@ -1,33 +0,0 @@ -#!./perl - -print "1..4\n"; - -# very basic tests of while - -$x = 0; -while ($x != 3) { - $x = $x + 1; -} -if ($x == 3) { print "ok 1\n"; } else { print "not ok 1\n";} - -$x = 0; -while (1) { - $x = $x + 1; - last if $x == 3; -} -if ($x == 3) { print "ok 2\n"; } else { print "not ok 2\n";} - -$x = 0; -while ($x != 3) { - $x = $x + 1; - next; - print "not "; -} -print "ok 3\n"; - -$x = 0; -while (0) { - $x = 1; -} -if ($x == 0) { print "ok 4\n"; } else { print "not ok 4\n";} - diff --git a/t/CORE/cmd/elsif.t b/t/CORE/cmd/elsif.t deleted file mode 100644 index 536358c9a..000000000 --- a/t/CORE/cmd/elsif.t +++ /dev/null @@ -1,23 +0,0 @@ -#!./perl - -sub foo { - if ($_[0] == 1) { - 1; - } - elsif ($_[0] == 2) { - 2; - } - elsif ($_[0] == 3) { - 3; - } - else { - 4; - } -} - -print "1..4\n"; - -if (($x = &foo(1)) == 1) {print "ok 1\n";} else {print "not ok 1 '$x'\n";} -if (($x = &foo(2)) == 2) {print "ok 2\n";} else {print "not ok 2 '$x'\n";} -if (($x = &foo(3)) == 3) {print "ok 3\n";} else {print "not ok 3 '$x'\n";} -if (($x = &foo(4)) == 4) {print "ok 4\n";} else {print "not ok 4 '$x'\n";} diff --git a/t/CORE/cmd/for.t b/t/CORE/cmd/for.t deleted file mode 100644 index 184d024fb..000000000 --- a/t/CORE/cmd/for.t +++ /dev/null @@ -1,670 +0,0 @@ -#!./perl - -print "1..118\n"; - -for ($i = 0; $i <= 10; $i++) { - $x[$i] = $i; -} -$y = $x[10]; -print "#1 :$y: eq :10:\n"; -$y = join(' ', @x); -print "#1 :$y: eq :0 1 2 3 4 5 6 7 8 9 10:\n"; -if (join(' ', @x) eq '0 1 2 3 4 5 6 7 8 9 10') { - print "ok 1\n"; -} else { - print "not ok 1\n"; -} - -$i = $c = 0; -for (;;) { - $c++; - last if $i++ > 10; -} -if ($c == 12) {print "ok 2\n";} else {print "not ok 2\n";} - -$foo = 3210; -@ary = (1,2,3,4,5); -foreach $foo (@ary) { - $foo *= 2; -} -if (join('',@ary) eq '246810') {print "ok 3\n";} else {print "not ok 3\n";} - -for (@ary) { - s/(.*)/ok $1\n/; -} - -print $ary[1]; - -# test for internal scratch array generation -# this also tests that $foo was restored to 3210 after test 3 -for (split(' ','a b c d e')) { - $foo .= $_; -} -if ($foo eq '3210abcde') {print "ok 5\n";} else {print "not ok 5 $foo\n";} - -foreach $foo (("ok 6\n","ok 7\n")) { - print $foo; -} - -sub foo { - for $i (1..5) { - return $i if $_[0] == $i; - } -} - -print foo(1) == 1 ? "ok" : "not ok", " 8\n"; -print foo(2) == 2 ? "ok" : "not ok", " 9\n"; -print foo(5) == 5 ? "ok" : "not ok", " 10\n"; - -sub bar { - return (1, 2, 4); -} - -$a = 0; -foreach $b (bar()) { - $a += $b; -} -print $a == 7 ? "ok" : "not ok", " 11\n"; - -$loop_count = 0; -for ("-3" .. "0") { - $loop_count++; -} -print $loop_count == 4 ? "ok" : "not ok", " 12\n"; - -# modifying arrays in loops is a no-no -@a = (3,4); -eval { @a = () for (1,2,@a) }; -print $@ =~ /Use of freed value in iteration/ ? "ok" : "not ok", " 13\n"; - -# [perl #30061] double destory when same iterator variable (eg $_) used in -# DESTROY as used in for loop that triggered the destroy - -{ - - my $x = 0; - sub X::DESTROY { - my $o = shift; - $x++; - 1 for (1); - } - - my %h; - $h{foo} = bless [], 'X'; - delete $h{foo} for $h{foo}, 1; - print $x == 1 ? "ok" : "not ok", " 14 - double destroy, x=$x\n"; -} - -# A lot of tests to check that reversed for works. -my $test = 14; -sub is { - my ($got, $expected, $name) = @_; - ++$test; - if ($got eq $expected) { - print "ok $test # $name\n"; - return 1; - } - print "not ok $test # $name\n"; - print "# got '$got', expected '$expected'\n"; - return 0; -} - -@array = ('A', 'B', 'C'); -for (@array) { - $r .= $_; -} -is ($r, 'ABC', 'Forwards for array'); -$r = ''; -for (1,2,3) { - $r .= $_; -} -is ($r, '123', 'Forwards for list'); -$r = ''; -for (map {$_} @array) { - $r .= $_; -} -is ($r, 'ABC', 'Forwards for array via map'); -$r = ''; -for (map {$_} 1,2,3) { - $r .= $_; -} -is ($r, '123', 'Forwards for list via map'); -$r = ''; -for (1 .. 3) { - $r .= $_; -} -is ($r, '123', 'Forwards for list via ..'); -$r = ''; -for ('A' .. 'C') { - $r .= $_; -} -is ($r, 'ABC', 'Forwards for list via ..'); - -$r = ''; -for (reverse @array) { - $r .= $_; -} -is ($r, 'CBA', 'Reverse for array'); -$r = ''; -for (reverse 1,2,3) { - $r .= $_; -} -is ($r, '321', 'Reverse for list'); -$r = ''; -for (reverse map {$_} @array) { - $r .= $_; -} -is ($r, 'CBA', 'Reverse for array via map'); -$r = ''; -for (reverse map {$_} 1,2,3) { - $r .= $_; -} -is ($r, '321', 'Reverse for list via map'); -$r = ''; -for (reverse 1 .. 3) { - $r .= $_; -} -is ($r, '321', 'Reverse for list via ..'); -$r = ''; -for (reverse 'A' .. 'C') { - $r .= $_; -} -is ($r, 'CBA', 'Reverse for list via ..'); - -$r = ''; -for my $i (@array) { - $r .= $i; -} -is ($r, 'ABC', 'Forwards for array with var'); -$r = ''; -for my $i (1,2,3) { - $r .= $i; -} -is ($r, '123', 'Forwards for list with var'); -$r = ''; -for my $i (map {$_} @array) { - $r .= $i; -} -is ($r, 'ABC', 'Forwards for array via map with var'); -$r = ''; -for my $i (map {$_} 1,2,3) { - $r .= $i; -} -is ($r, '123', 'Forwards for list via map with var'); -$r = ''; -for my $i (1 .. 3) { - $r .= $i; -} -is ($r, '123', 'Forwards for list via .. with var'); -$r = ''; -for my $i ('A' .. 'C') { - $r .= $i; -} -is ($r, 'ABC', 'Forwards for list via .. with var'); - -$r = ''; -for my $i (reverse @array) { - $r .= $i; -} -is ($r, 'CBA', 'Reverse for array with var'); -$r = ''; -for my $i (reverse 1,2,3) { - $r .= $i; -} -is ($r, '321', 'Reverse for list with var'); -$r = ''; -for my $i (reverse map {$_} @array) { - $r .= $i; -} -is ($r, 'CBA', 'Reverse for array via map with var'); -$r = ''; -for my $i (reverse map {$_} 1,2,3) { - $r .= $i; -} -is ($r, '321', 'Reverse for list via map with var'); -$r = ''; -for my $i (reverse 1 .. 3) { - $r .= $i; -} -is ($r, '321', 'Reverse for list via .. with var'); -$r = ''; -for my $i (reverse 'A' .. 'C') { - $r .= $i; -} -is ($r, 'CBA', 'Reverse for list via .. with var'); - -# For some reason the generate optree is different when $_ is implicit. -$r = ''; -for $_ (@array) { - $r .= $_; -} -is ($r, 'ABC', 'Forwards for array with explicit $_'); -$r = ''; -for $_ (1,2,3) { - $r .= $_; -} -is ($r, '123', 'Forwards for list with explicit $_'); -$r = ''; -for $_ (map {$_} @array) { - $r .= $_; -} -is ($r, 'ABC', 'Forwards for array via map with explicit $_'); -$r = ''; -for $_ (map {$_} 1,2,3) { - $r .= $_; -} -is ($r, '123', 'Forwards for list via map with explicit $_'); -$r = ''; -for $_ (1 .. 3) { - $r .= $_; -} -is ($r, '123', 'Forwards for list via .. with var with explicit $_'); -$r = ''; -for $_ ('A' .. 'C') { - $r .= $_; -} -is ($r, 'ABC', 'Forwards for list via .. with var with explicit $_'); - -$r = ''; -for $_ (reverse @array) { - $r .= $_; -} -is ($r, 'CBA', 'Reverse for array with explicit $_'); -$r = ''; -for $_ (reverse 1,2,3) { - $r .= $_; -} -is ($r, '321', 'Reverse for list with explicit $_'); -$r = ''; -for $_ (reverse map {$_} @array) { - $r .= $_; -} -is ($r, 'CBA', 'Reverse for array via map with explicit $_'); -$r = ''; -for $_ (reverse map {$_} 1,2,3) { - $r .= $_; -} -is ($r, '321', 'Reverse for list via map with explicit $_'); -$r = ''; -for $_ (reverse 1 .. 3) { - $r .= $_; -} -is ($r, '321', 'Reverse for list via .. with var with explicit $_'); -$r = ''; -for $_ (reverse 'A' .. 'C') { - $r .= $_; -} -is ($r, 'CBA', 'Reverse for list via .. with var with explicit $_'); - -# I don't think that my is that different from our in the optree. But test a -# few: -$r = ''; -for our $i (reverse @array) { - $r .= $i; -} -is ($r, 'CBA', 'Reverse for array with our var'); -$r = ''; -for our $i (reverse 1,2,3) { - $r .= $i; -} -is ($r, '321', 'Reverse for list with our var'); -$r = ''; -for our $i (reverse map {$_} @array) { - $r .= $i; -} -is ($r, 'CBA', 'Reverse for array via map with our var'); -$r = ''; -for our $i (reverse map {$_} 1,2,3) { - $r .= $i; -} -is ($r, '321', 'Reverse for list via map with our var'); -$r = ''; -for our $i (reverse 1 .. 3) { - $r .= $i; -} -is ($r, '321', 'Reverse for list via .. with our var'); -$r = ''; -for our $i (reverse 'A' .. 'C') { - $r .= $i; -} -is ($r, 'CBA', 'Reverse for list via .. with our var'); - - -$r = ''; -for (1, reverse @array) { - $r .= $_; -} -is ($r, '1CBA', 'Reverse for array with leading value'); -$r = ''; -for ('A', reverse 1,2,3) { - $r .= $_; -} -is ($r, 'A321', 'Reverse for list with leading value'); -$r = ''; -for (1, reverse map {$_} @array) { - $r .= $_; -} -is ($r, '1CBA', 'Reverse for array via map with leading value'); -$r = ''; -for ('A', reverse map {$_} 1,2,3) { - $r .= $_; -} -is ($r, 'A321', 'Reverse for list via map with leading value'); -$r = ''; -for ('A', reverse 1 .. 3) { - $r .= $_; -} -is ($r, 'A321', 'Reverse for list via .. with leading value'); -$r = ''; -for (1, reverse 'A' .. 'C') { - $r .= $_; -} -is ($r, '1CBA', 'Reverse for list via .. with leading value'); - -$r = ''; -for (reverse (@array), 1) { - $r .= $_; -} -is ($r, 'CBA1', 'Reverse for array with trailing value'); -$r = ''; -for (reverse (1,2,3), 'A') { - $r .= $_; -} -is ($r, '321A', 'Reverse for list with trailing value'); -$r = ''; -for (reverse (map {$_} @array), 1) { - $r .= $_; -} -is ($r, 'CBA1', 'Reverse for array via map with trailing value'); -$r = ''; -for (reverse (map {$_} 1,2,3), 'A') { - $r .= $_; -} -is ($r, '321A', 'Reverse for list via map with trailing value'); -$r = ''; -for (reverse (1 .. 3), 'A') { - $r .= $_; -} -is ($r, '321A', 'Reverse for list via .. with trailing value'); -$r = ''; -for (reverse ('A' .. 'C'), 1) { - $r .= $_; -} -is ($r, 'CBA1', 'Reverse for list via .. with trailing value'); - - -$r = ''; -for $_ (1, reverse @array) { - $r .= $_; -} -is ($r, '1CBA', 'Reverse for array with leading value with explicit $_'); -$r = ''; -for $_ ('A', reverse 1,2,3) { - $r .= $_; -} -is ($r, 'A321', 'Reverse for list with leading value with explicit $_'); -$r = ''; -for $_ (1, reverse map {$_} @array) { - $r .= $_; -} -is ($r, '1CBA', - 'Reverse for array via map with leading value with explicit $_'); -$r = ''; -for $_ ('A', reverse map {$_} 1,2,3) { - $r .= $_; -} -is ($r, 'A321', 'Reverse for list via map with leading value with explicit $_'); -$r = ''; -for $_ ('A', reverse 1 .. 3) { - $r .= $_; -} -is ($r, 'A321', 'Reverse for list via .. with leading value with explicit $_'); -$r = ''; -for $_ (1, reverse 'A' .. 'C') { - $r .= $_; -} -is ($r, '1CBA', 'Reverse for list via .. with leading value with explicit $_'); - -$r = ''; -for $_ (reverse (@array), 1) { - $r .= $_; -} -is ($r, 'CBA1', 'Reverse for array with trailing value with explicit $_'); -$r = ''; -for $_ (reverse (1,2,3), 'A') { - $r .= $_; -} -is ($r, '321A', 'Reverse for list with trailing value with explicit $_'); -$r = ''; -for $_ (reverse (map {$_} @array), 1) { - $r .= $_; -} -is ($r, 'CBA1', - 'Reverse for array via map with trailing value with explicit $_'); -$r = ''; -for $_ (reverse (map {$_} 1,2,3), 'A') { - $r .= $_; -} -is ($r, '321A', - 'Reverse for list via map with trailing value with explicit $_'); -$r = ''; -for $_ (reverse (1 .. 3), 'A') { - $r .= $_; -} -is ($r, '321A', 'Reverse for list via .. with trailing value with explicit $_'); -$r = ''; -for $_ (reverse ('A' .. 'C'), 1) { - $r .= $_; -} -is ($r, 'CBA1', 'Reverse for list via .. with trailing value with explicit $_'); - -$r = ''; -for my $i (1, reverse @array) { - $r .= $i; -} -is ($r, '1CBA', 'Reverse for array with leading value and var'); -$r = ''; -for my $i ('A', reverse 1,2,3) { - $r .= $i; -} -is ($r, 'A321', 'Reverse for list with leading value and var'); -$r = ''; -for my $i (1, reverse map {$_} @array) { - $r .= $i; -} -is ($r, '1CBA', 'Reverse for array via map with leading value and var'); -$r = ''; -for my $i ('A', reverse map {$_} 1,2,3) { - $r .= $i; -} -is ($r, 'A321', 'Reverse for list via map with leading value and var'); -$r = ''; -for my $i ('A', reverse 1 .. 3) { - $r .= $i; -} -is ($r, 'A321', 'Reverse for list via .. with leading value and var'); -$r = ''; -for my $i (1, reverse 'A' .. 'C') { - $r .= $i; -} -is ($r, '1CBA', 'Reverse for list via .. with leading value and var'); - -$r = ''; -for my $i (reverse (@array), 1) { - $r .= $i; -} -is ($r, 'CBA1', 'Reverse for array with trailing value and var'); -$r = ''; -for my $i (reverse (1,2,3), 'A') { - $r .= $i; -} -is ($r, '321A', 'Reverse for list with trailing value and var'); -$r = ''; -for my $i (reverse (map {$_} @array), 1) { - $r .= $i; -} -is ($r, 'CBA1', 'Reverse for array via map with trailing value and var'); -$r = ''; -for my $i (reverse (map {$_} 1,2,3), 'A') { - $r .= $i; -} -is ($r, '321A', 'Reverse for list via map with trailing value and var'); -$r = ''; -for my $i (reverse (1 .. 3), 'A') { - $r .= $i; -} -is ($r, '321A', 'Reverse for list via .. with trailing value and var'); -$r = ''; -for my $i (reverse ('A' .. 'C'), 1) { - $r .= $i; -} -is ($r, 'CBA1', 'Reverse for list via .. with trailing value and var'); - - -$r = ''; -for (reverse 1, @array) { - $r .= $_; -} -is ($r, 'CBA1', 'Reverse for value and array'); -$r = ''; -for (reverse map {$_} 1, @array) { - $r .= $_; -} -is ($r, 'CBA1', 'Reverse for value and array via map'); -$r = ''; -for (reverse 1 .. 3, @array) { - $r .= $_; -} -is ($r, 'CBA321', 'Reverse for .. and array'); -$r = ''; -for (reverse 'X' .. 'Z', @array) { - $r .= $_; -} -is ($r, 'CBAZYX', 'Reverse for .. and array'); -$r = ''; -for (reverse map {$_} 1 .. 3, @array) { - $r .= $_; -} -is ($r, 'CBA321', 'Reverse for .. and array via map'); -$r = ''; -for (reverse map {$_} 'X' .. 'Z', @array) { - $r .= $_; -} -is ($r, 'CBAZYX', 'Reverse for .. and array via map'); - -$r = ''; -for (reverse (@array, 1)) { - $r .= $_; -} -is ($r, '1CBA', 'Reverse for array and value'); -$r = ''; -for (reverse (map {$_} @array, 1)) { - $r .= $_; -} -is ($r, '1CBA', 'Reverse for array and value via map'); - -$r = ''; -for $_ (reverse 1, @array) { - $r .= $_; -} -is ($r, 'CBA1', 'Reverse for value and array with explicit $_'); -$r = ''; -for $_ (reverse map {$_} 1, @array) { - $r .= $_; -} -is ($r, 'CBA1', 'Reverse for value and array via map with explicit $_'); -$r = ''; -for $_ (reverse 1 .. 3, @array) { - $r .= $_; -} -is ($r, 'CBA321', 'Reverse for .. and array with explicit $_'); -$r = ''; -for $_ (reverse 'X' .. 'Z', @array) { - $r .= $_; -} -is ($r, 'CBAZYX', 'Reverse for .. and array with explicit $_'); -$r = ''; -for $_ (reverse map {$_} 1 .. 3, @array) { - $r .= $_; -} -is ($r, 'CBA321', 'Reverse for .. and array via map with explicit $_'); -$r = ''; -for $_ (reverse map {$_} 'X' .. 'Z', @array) { - $r .= $_; -} -is ($r, 'CBAZYX', 'Reverse for .. and array via map with explicit $_'); - -$r = ''; -for $_ (reverse (@array, 1)) { - $r .= $_; -} -is ($r, '1CBA', 'Reverse for array and value with explicit $_'); -$r = ''; -for $_ (reverse (map {$_} @array, 1)) { - $r .= $_; -} -is ($r, '1CBA', 'Reverse for array and value via map with explicit $_'); - - -$r = ''; -for my $i (reverse 1, @array) { - $r .= $i; -} -is ($r, 'CBA1', 'Reverse for value and array with var'); -$r = ''; -for my $i (reverse map {$_} 1, @array) { - $r .= $i; -} -is ($r, 'CBA1', 'Reverse for value and array via map with var'); -$r = ''; -for my $i (reverse 1 .. 3, @array) { - $r .= $i; -} -is ($r, 'CBA321', 'Reverse for .. and array with var'); -$r = ''; -for my $i (reverse 'X' .. 'Z', @array) { - $r .= $i; -} -is ($r, 'CBAZYX', 'Reverse for .. and array with var'); -$r = ''; -for my $i (reverse map {$_} 1 .. 3, @array) { - $r .= $i; -} -is ($r, 'CBA321', 'Reverse for .. and array via map with var'); -$r = ''; -for my $i (reverse map {$_} 'X' .. 'Z', @array) { - $r .= $i; -} -is ($r, 'CBAZYX', 'Reverse for .. and array via map with var'); - -$r = ''; -for my $i (reverse (@array, 1)) { - $r .= $i; -} -is ($r, '1CBA', 'Reverse for array and value with var'); -$r = ''; -for my $i (reverse (map {$_} @array, 1)) { - $r .= $i; -} -is ($r, '1CBA', 'Reverse for array and value via map with var'); - -TODO: { - $test++; - local $TODO = "RT #1085: what should be output of perl -we 'print do { foreach (1, 2) { 1; } }'"; - if (do {17; foreach (1, 2) { 1; } } != 17) { - print "not "; - } - print "ok $test # TODO $TODO\n"; -} - -TODO: { - $test++; - no warnings 'reserved'; - local $TODO = "RT #2166: foreach spuriously autovivifies"; - my %h; - foreach (@h{a, b}) {} - if(keys(%h)) { - print "not "; - } - print "ok $test # TODO $TODO\n"; -} diff --git a/t/CORE/cmd/mod.t b/t/CORE/cmd/mod.t deleted file mode 100644 index 852068734..000000000 --- a/t/CORE/cmd/mod.t +++ /dev/null @@ -1,57 +0,0 @@ -#!./perl - -INIT { -} -print "1..13\n"; - -print "ok 1\n" if 1; -print "not ok 1\n" unless 1; - -print "ok 2\n" unless 0; -print "not ok 2\n" if 0; - -1 && (print "not ok 3\n") if 0; -1 && (print "ok 3\n") if 1; -0 || (print "not ok 4\n") if 0; -0 || (print "ok 4\n") if 1; - -$x = 0; -do {$x[$x] = $x;} while ($x++) < 10; -if (join(' ',@x) eq '0 1 2 3 4 5 6 7 8 9 10') { - print "ok 5\n"; -} else { - print "not ok 5 @x\n"; -} - -$x = 15; -$x = 10 while $x < 10; -if ($x == 15) {print "ok 6\n";} else {print "not ok 6\n";} - -$y[$_] = $_ * 2 foreach @x; -if (join(' ',@y) eq '0 2 4 6 8 10 12 14 16 18 20') { - print "ok 7\n"; -} else { - print "not ok 7 @y\n"; -} - -open(foo,'./t/CORE/TEST'); -$x = 0; -$x++ while ; -print $x > 50 && $x < 1000 ? "ok 8\n" : "not ok 8\n"; - -$x = -0.5; -print "not " if scalar($x) < 0 and $x >= 0; -print "ok 9\n"; - -print "not " unless (-(-$x) < 0) == ($x < 0); -print "ok 10\n"; - -print "ok 11\n" if $x < 0; -print "not ok 11\n" unless $x < 0; - -print "ok 12\n" unless $x > 0; -print "not ok 12\n" if $x > 0; - -# This used to cause a segfault -$x = "".("".do{"foo" for (1)}); -print "ok 13\n"; diff --git a/t/CORE/cmd/subval.t b/t/CORE/cmd/subval.t deleted file mode 100644 index 0999ff989..000000000 --- a/t/CORE/cmd/subval.t +++ /dev/null @@ -1,184 +0,0 @@ -#!./perl - -sub foo1 { - 'true1'; - if ($_[0]) { 'true2'; } -} - -sub foo2 { - 'true1'; - if ($_[0]) { return 'true2'; } else { return 'true3'; } - 'true0'; -} - -sub foo3 { - 'true1'; - unless ($_[0]) { 'true2'; } -} - -sub foo4 { - 'true1'; - unless ($_[0]) { 'true2'; } else { 'true3'; } -} - -sub foo5 { - 'true1'; - 'true2' if $_[0]; -} - -sub foo6 { - 'true1'; - 'true2' unless $_[0]; -} - -print "1..36\n"; - -if (&foo1(0) eq '0') {print "ok 1\n";} else {print "not ok 1 $foo\n";} -if (&foo1(1) eq 'true2') {print "ok 2\n";} else {print "not ok 2\n";} -if (&foo2(0) eq 'true3') {print "ok 3\n";} else {print "not ok 3\n";} -if (&foo2(1) eq 'true2') {print "ok 4\n";} else {print "not ok 4\n";} - -if (&foo3(0) eq 'true2') {print "ok 5\n";} else {print "not ok 5\n";} -if (&foo3(1) eq '1') {print "ok 6\n";} else {print "not ok 6\n";} -if (&foo4(0) eq 'true2') {print "ok 7\n";} else {print "not ok 7\n";} -if (&foo4(1) eq 'true3') {print "ok 8\n";} else {print "not ok 8\n";} - -if (&foo5(0) eq '0') {print "ok 9\n";} else {print "not ok 9\n";} -if (&foo5(1) eq 'true2') {print "ok 10\n";} else {print "not ok 10\n";} -if (&foo6(0) eq 'true2') {print "ok 11\n";} else {print "not ok 11\n";} -if (&foo6(1) eq '1') {print "ok 12\n";} else {print "not ok 12 $x\n";} - -# Now test to see that recursion works using a Fibonacci number generator - -sub fib { - my($arg) = @_; - my($foo); - $level++; - if ($arg <= 2) { - $foo = 1; - } - else { - $foo = &fib($arg-1) + &fib($arg-2); - } - $level--; - $foo; -} - -@good = (0,1,1,2,3,5,8,13,21,34,55,89); - -for ($i = 1; $i <= 10; $i++) { - $foo = $i + 12; - if (&fib($i) == $good[$i]) { - print "ok $foo\n"; - } - else { - print "not ok $foo\n"; - } -} - -sub ary1 { - (1,2,3); -} - -print &ary1 eq 3 ? "ok 23\n" : "not ok 23\n"; - -print join(':',&ary1) eq '1:2:3' ? "ok 24\n" : "not ok 24\n"; - -sub ary2 { - do { - return (1,2,3); - (3,2,1); - }; - 0; -} - -print &ary2 eq 3 ? "ok 25\n" : "not ok 25\n"; - -$x = join(':',&ary2); -print $x eq '1:2:3' ? "ok 26\n" : "not ok 26 $x\n"; - -sub somesub { - local($num,$P,$F,$L) = @_; - ($p,$f,$l) = caller; - print "$p:$f:$l" eq "$P:$F:$L" ? "ok $num\n" : "not ok $num $p:$f:$l ne $P:$F:$L\n"; -} - -&somesub(27, 'main', __FILE__, __LINE__); - -package foo; -&main'somesub(28, 'foo', __FILE__, __LINE__); - -package main; -$i = 28; -open(FOO,">Cmd_subval.tmp"); -print FOO "blah blah\n"; -close FOO or die "Can't close Cmd_subval.tmp: $!"; - -&file_main(*F); -close F or die "Can't close: $!"; -&info_main; - -&file_package(*F); -close F or die "Can't close: $!"; -&info_package; - -unlink 'Cmd_subval.tmp'; - -sub file_main { - local(*F) = @_; - - open(F, 'Cmd_subval.tmp') || die "can't open: $!\n"; - $i++; - eof F ? print "not ok $i\n" : print "ok $i\n"; -} - -sub info_main { - local(*F); - - open(F, 'Cmd_subval.tmp') || die "test: can't open: $!\n"; - $i++; - eof F ? print "not ok $i\n" : print "ok $i\n"; - &iseof(*F); - close F or die "Can't close: $!"; -} - -sub iseof { - local(*UNIQ) = @_; - - $i++; - eof UNIQ ? print "(not ok $i)\n" : print "ok $i\n"; -} - -{package foo; - - sub main'file_package { - local(*F) = @_; - - open(F, 'Cmd_subval.tmp') || die "can't open: $!\n"; - $main'i++; - eof F ? print "not ok $main'i\n" : print "ok $main'i\n"; - } - - sub main'info_package { - local(*F); - - open(F, 'Cmd_subval.tmp') || die "can't open: $!\n"; - $main'i++; - eof F ? print "not ok $main'i\n" : print "ok $main'i\n"; - &iseof(*F); - } - - sub iseof { - local(*UNIQ) = @_; - - $main'i++; - eof UNIQ ? print "not ok $main'i\n" : print "ok $main'i\n"; - } -} - -sub autov { $_[0] = 23 }; - -my $href = {}; -print keys %$href ? 'not ' : '', "ok 35\n"; -autov($href->{b}); -print join(':', %$href) eq 'b:23' ? '' : 'not ', "ok 36\n"; diff --git a/t/CORE/cmd/switch.t b/t/CORE/cmd/switch.t deleted file mode 100644 index 4b588d441..000000000 --- a/t/CORE/cmd/switch.t +++ /dev/null @@ -1,73 +0,0 @@ -#!./perl - -print "1..18\n"; - -sub foo1 { - $_ = shift(@_); - $a = 0; - until ($a++) { - next if $_ eq 1; - next if $_ eq 2; - next if $_ eq 3; - next if $_ eq 4; - return 20; - } - continue { - return $_; - } -} - -print foo1(0) == 20 ? "ok 1\n" : "not ok 1\n"; -print foo1(1) == 1 ? "ok 2\n" : "not ok 2\n"; -print foo1(2) == 2 ? "ok 3\n" : "not ok 3\n"; -print foo1(3) == 3 ? "ok 4\n" : "not ok 4\n"; -print foo1(4) == 4 ? "ok 5\n" : "not ok 5\n"; -print foo1(5) == 20 ? "ok 6\n" : "not ok 6\n"; - -sub foo2 { - $_ = shift(@_); - { - last if $_ == 1; - last if $_ == 2; - last if $_ == 3; - last if $_ == 4; - } - continue { - return 20; - } - return $_; -} - -print foo2(0) == 20 ? "ok 7\n" : "not ok 7\n"; -print foo2(1) == 1 ? "ok 8\n" : "not ok 8\n"; -print foo2(2) == 2 ? "ok 9\n" : "not ok 9\n"; -print foo2(3) == 3 ? "ok 10\n" : "not ok 10\n"; -print foo2(4) == 4 ? "ok 11\n" : "not ok 11\n"; -print foo2(5) == 20 ? "ok 12\n" : "not ok 12\n"; - -sub foo3 { - $_ = shift(@_); - if (/^1/) { - return 1; - } - elsif (/^2/) { - return 2; - } - elsif (/^3/) { - return 3; - } - elsif (/^4/) { - return 4; - } - else { - return 20; - } - return 40; -} - -print foo3(0) == 20 ? "ok 13\n" : "not ok 13\n"; -print foo3(1) == 1 ? "ok 14\n" : "not ok 14\n"; -print foo3(2) == 2 ? "ok 15\n" : "not ok 15\n"; -print foo3(3) == 3 ? "ok 16\n" : "not ok 16\n"; -print foo3(4) == 4 ? "ok 17\n" : "not ok 17\n"; -print foo3(5) == 20 ? "ok 18\n" : "not ok 18\n"; diff --git a/t/CORE/cmd/while.t b/t/CORE/cmd/while.t deleted file mode 100644 index da167691d..000000000 --- a/t/CORE/cmd/while.t +++ /dev/null @@ -1,213 +0,0 @@ -#!./perl - - -require 't/CORE/test.pl'; - -plan(25); - -my $tmpfile = tempfile(); -open ($tmp,'>', $tmpfile) || die "Can't create Cmd_while.tmp."; -print $tmp "tvi925\n"; -print $tmp "tvi920\n"; -print $tmp "vt100\n"; -print $tmp "Amiga\n"; -print $tmp "paper\n"; -close $tmp or die "Could not close: $!"; - -# test "last" command - -open(fh, $tmpfile) || die "Can't open Cmd_while.tmp."; -while () { - last if /vt100/; -} -ok(!eof && /vt100/); - -# test "next" command - -$bad = ''; -open(fh, $tmpfile) || die "Can't open Cmd_while.tmp."; -while () { - next if /vt100/; - $bad = 1 if /vt100/; -} -ok(eof && !/vt100/ && !$bad); - -# test "redo" command - -$bad = ''; -open(fh,$tmpfile) || die "Can't open Cmd_while.tmp."; -while () { - if (s/vt100/VT100/g) { - s/VT100/Vt100/g; - redo; - } - $bad = 1 if /vt100/; - $bad = 1 if /VT100/; -} -ok(eof && !$bad); - -# now do the same with a label and a continue block - -# test "last" command - -$badcont = ''; -open(fh,$tmpfile) || die "Can't open Cmd_while.tmp."; -line: while () { - if (/vt100/) {last line;} -} continue { - $badcont = 1 if /vt100/; -} -ok(!eof && /vt100/); -ok(!$badcont); - -# test "next" command - -$bad = ''; -$badcont = 1; -open(fh,$tmpfile) || die "Can't open Cmd_while.tmp."; -entry: while () { - next entry if /vt100/; - $bad = 1 if /vt100/; -} continue { - $badcont = '' if /vt100/; -} -ok(eof && !/vt100/ && !$bad); -ok(!$badcont); - -# test "redo" command - -$bad = ''; -$badcont = ''; -open(fh,$tmpfile) || die "Can't open Cmd_while.tmp."; -loop: while () { - if (s/vt100/VT100/g) { - s/VT100/Vt100/g; - redo loop; - } - $bad = 1 if /vt100/; - $bad = 1 if /VT100/; -} continue { - $badcont = 1 if /vt100/; -} -ok(eof && !$bad); -ok(!$badcont); - -close(fh) || die "Can't close Cmd_while.tmp."; - -$i = 9; -{ - $i++; -} -is($i, 10); - -# Check curpm is reset when jumping out of a scope -$i = 0; -'abc' =~ /b/; -WHILE: -while (1) { - $i++; - is($` . $& . $', "abc"); - { # Localize changes to $` and friends - 'end' =~ /end/; - redo WHILE if $i == 1; - next WHILE if $i == 2; - # 3 do a normal loop - last WHILE if $i == 4; - } -} -is($` . $& . $', "abc"); - -# check that scope cleanup happens right when there's a continue block -{ - my $var = 16; - my (@got_var, @got_i); - while (my $i = ++$var) { - next if $i == 17; - last if $i > 17; - my $i = 0; - } - continue { - ($got_var, $got_i) = ($var, $i); - } - is($got_var, 17); - is($got_i, 17); -} - -{ - my $got_l; - local $l = 18; - { - local $l = 0 - } - continue { - $got_l = $l; - } - is($got_l, 18); -} - -{ - my $got_l; - local $l = 19; - my $x = 0; - while (!$x++) { - local $l = 0 - } - continue { - $got_l = $l; - } - is($got_l, $l); -} - -{ - my $ok = 1; - $i = 20; - while (1) { - my $x; - $ok = 0 if defined $x; - if ($i == 21) { - next; - } - last; - } - continue { - ++$i; - } - ok($ok); -} - -sub save_context { $_[0] = wantarray; $_[1] } - -{ - my $context = -1; - my $p = sub { - my $x = 1; - while ($x--) { - save_context($context, "foo"); - } - }; - is(scalar($p->()), 0); - is($context, undef, "last statement in while block has 'void' context"); -} - -{ - my $context = -1; - my $p = sub { - my $x = 1; - { - save_context($context, "foo"); - } - }; - is(scalar($p->()), "foo"); - is($context, "", "last statement in block has 'scalar' context"); -} - -{ - # test scope is cleaned - my $i = 0; - my @a; - while ($i++ < 2) { - my $x; - push @a, \$x; - } - ok($a[0] ne $a[1]); -} diff --git a/t/CORE/comp/bproto.t b/t/CORE/comp/bproto.t deleted file mode 100644 index b82ddd1f6..000000000 --- a/t/CORE/comp/bproto.t +++ /dev/null @@ -1,43 +0,0 @@ -#!./perl -# -# check if builtins behave as prototyped -# - -BEGIN { - unshift @INC, 't/CORE/lib'; -} - -print "1..10\n"; - -my $i = 1; - -sub foo {} -my $bar = "bar"; - -sub test_too_many { - eval $_[0]; - print "not " unless $@ =~ /^Too many arguments/; - printf "ok %d\n",$i++; -} - -sub test_no_error { - eval $_[0]; - print "not " if $@; - printf "ok %d\n",$i++; -} - -test_too_many($_) for split /\n/, -q[ defined(&foo, $bar); - undef(&foo, $bar); - uc($bar,$bar); -]; - -test_no_error($_) for split /\n/, -q[ scalar(&foo,$bar); - defined &foo, &foo, &foo; - undef &foo, $bar; - uc $bar,$bar; - grep(not($bar), $bar); - grep(not($bar, $bar), $bar); - grep((not $bar, $bar, $bar), $bar); -]; diff --git a/t/CORE/comp/cmdopt.t b/t/CORE/comp/cmdopt.t deleted file mode 100644 index f72ddb30a..000000000 --- a/t/CORE/comp/cmdopt.t +++ /dev/null @@ -1,88 +0,0 @@ -#!./perl - -print "1..44\n"; - -# test the optimization of constants - -if (1) { print "ok 1\n";} else { print "not ok 1\n";} -unless (0) { print "ok 2\n";} else { print "not ok 2\n";} - -if (0) { print "not ok 3\n";} else { print "ok 3\n";} -unless (1) { print "not ok 4\n";} else { print "ok 4\n";} - -unless (!1) { print "ok 5\n";} else { print "not ok 5\n";} -if (!0) { print "ok 6\n";} else { print "not ok 6\n";} - -unless (!0) { print "not ok 7\n";} else { print "ok 7\n";} -if (!1) { print "not ok 8\n";} else { print "ok 8\n";} - -$x = 1; -if (1 && $x) { print "ok 9\n";} else { print "not ok 9\n";} -if (0 && $x) { print "not ok 10\n";} else { print "ok 10\n";} -$x = ''; -if (1 && $x) { print "not ok 11\n";} else { print "ok 11\n";} -if (0 && $x) { print "not ok 12\n";} else { print "ok 12\n";} - -$x = 1; -if (1 || $x) { print "ok 13\n";} else { print "not ok 13\n";} -if (0 || $x) { print "ok 14\n";} else { print "not ok 14\n";} -$x = ''; -if (1 || $x) { print "ok 15\n";} else { print "not ok 15\n";} -if (0 || $x) { print "not ok 16\n";} else { print "ok 16\n";} - - -# test the optimization of variables - -$x = 1; -if ($x) { print "ok 17\n";} else { print "not ok 17\n";} -unless ($x) { print "not ok 18\n";} else { print "ok 18\n";} - -$x = ''; -if ($x) { print "not ok 19\n";} else { print "ok 19\n";} -unless ($x) { print "ok 20\n";} else { print "not ok 20\n";} - -# test optimization of string operations - -$a = 'a'; -if ($a eq 'a') { print "ok 21\n";} else { print "not ok 21\n";} -if ($a ne 'a') { print "not ok 22\n";} else { print "ok 22\n";} - -if ($a =~ /a/) { print "ok 23\n";} else { print "not ok 23\n";} -if ($a !~ /a/) { print "not ok 24\n";} else { print "ok 24\n";} -# test interaction of logicals and other operations - -$a = 'a'; -$x = 1; -if ($a eq 'a' and $x) { print "ok 25\n";} else { print "not ok 25\n";} -if ($a ne 'a' and $x) { print "not ok 26\n";} else { print "ok 26\n";} -$x = ''; -if ($a eq 'a' and $x) { print "not ok 27\n";} else { print "ok 27\n";} -if ($a ne 'a' and $x) { print "not ok 28\n";} else { print "ok 28\n";} - -$x = 1; -if ($a eq 'a' or $x) { print "ok 29\n";} else { print "not ok 29\n";} -if ($a ne 'a' or $x) { print "ok 30\n";} else { print "not ok 30\n";} -$x = ''; -if ($a eq 'a' or $x) { print "ok 31\n";} else { print "not ok 31\n";} -if ($a ne 'a' or $x) { print "not ok 32\n";} else { print "ok 32\n";} - -$x = 1; -if ($a =~ /a/ && $x) { print "ok 33\n";} else { print "not ok 33\n";} -if ($a !~ /a/ && $x) { print "not ok 34\n";} else { print "ok 34\n";} -$x = ''; -if ($a =~ /a/ && $x) { print "not ok 35\n";} else { print "ok 35\n";} -if ($a !~ /a/ && $x) { print "not ok 36\n";} else { print "ok 36\n";} - -$x = 1; -if ($a =~ /a/ || $x) { print "ok 37\n";} else { print "not ok 37\n";} -if ($a !~ /a/ || $x) { print "ok 38\n";} else { print "not ok 38\n";} -$x = ''; -if ($a =~ /a/ || $x) { print "ok 39\n";} else { print "not ok 39\n";} -if ($a !~ /a/ || $x) { print "not ok 40\n";} else { print "ok 40\n";} - -$x = 1; -if ($a eq 'a' xor $x) { print "not ok 41\n";} else { print "ok 41\n";} -if ($a ne 'a' xor $x) { print "ok 42\n";} else { print "not ok 42\n";} -$x = ''; -if ($a eq 'a' xor $x) { print "ok 43\n";} else { print "not ok 43\n";} -if ($a ne 'a' xor $x) { print "not ok 44\n";} else { print "ok 44\n";} diff --git a/t/CORE/comp/colon.t b/t/CORE/comp/colon.t deleted file mode 100644 index e43af3b8e..000000000 --- a/t/CORE/comp/colon.t +++ /dev/null @@ -1,135 +0,0 @@ -#!./perl - -# -# Ensure that syntax using colons (:) is parsed correctly. -# The tests are done on the following tokens (by default): -# ABC LABEL XYZZY m q qq qw qx s tr y AUTOLOAD and alarm -# -- Robin Barker -# - -# Uncomment this for testing, but don't leave it in for "production", as -# we've not yet verified that use works. -# use strict; - -$_ = ''; # to avoid undef warning on m// etc. - -sub ok { - my($test,$ok) = @_; - print "not " unless $ok; - print "ok $test\n"; -} - -$SIG{__WARN__} = sub { 1; }; # avoid some spurious warnings - -print "1..25\n"; - -ok 1, (eval "package ABC; sub zyx {1}; 1;" and - eval "ABC::zyx" and - not eval "ABC:: eq ABC||" and - not eval "ABC::: >= 0"); - -ok 2, (eval "package LABEL; sub zyx {1}; 1;" and - eval "LABEL::zyx" and - not eval "LABEL:: eq LABEL||" and - not eval "LABEL::: >= 0"); - -ok 3, (eval "package XYZZY; sub zyx {1}; 1;" and - eval "XYZZY::zyx" and - not eval "XYZZY:: eq XYZZY||" and - not eval "XYZZY::: >= 0"); - -ok 4, (eval "package m; sub zyx {1}; 1;" and - not eval "m::zyx" and - eval "m:: eq m||" and - not eval "m::: >= 0"); - -ok 5, (eval "package q; sub zyx {1}; 1;" and - not eval "q::zyx" and - eval "q:: eq q||" and - not eval "q::: >= 0"); - -ok 6, (eval "package qq; sub zyx {1}; 1;" and - not eval "qq::zyx" and - eval "qq:: eq qq||" and - not eval "qq::: >= 0"); - -ok 7, (eval "package qw; sub zyx {1}; 1;" and - not eval "qw::zyx" and - eval "qw:: eq qw||" and - not eval "qw::: >= 0"); - -ok 8, (eval "package qx; sub zyx {1}; 1;" and - not eval "qx::zyx" and - eval "qx:: eq qx||" and - not eval "qx::: >= 0"); - -ok 9, (eval "package s; sub zyx {1}; 1;" and - not eval "s::zyx" and - not eval "s:: eq s||" and - eval "s::: >= 0"); - -ok 10, (eval "package tr; sub zyx {1}; 1;" and - not eval "tr::zyx" and - not eval "tr:: eq tr||" and - eval "tr::: >= 0"); - -ok 11, (eval "package y; sub zyx {1}; 1;" and - not eval "y::zyx" and - not eval "y:: eq y||" and - eval "y::: >= 0"); - -ok 12, (eval "ABC:1" and - not eval "ABC:echo: eq ABC|echo|" and - not eval "ABC:echo:ohce: >= 0"); - -ok 13, (eval "LABEL:1" and - not eval "LABEL:echo: eq LABEL|echo|" and - not eval "LABEL:echo:ohce: >= 0"); - -ok 14, (eval "XYZZY:1" and - not eval "XYZZY:echo: eq XYZZY|echo|" and - not eval "XYZZY:echo:ohce: >= 0"); - -ok 15, (not eval "m:1" and - eval "m:echo: eq m|echo|" and - not eval "m:echo:ohce: >= 0"); - -ok 16, (not eval "q:1" and - eval "q:echo: eq q|echo|" and - not eval "q:echo:ohce: >= 0"); - -ok 17, (not eval "qq:1" and - eval "qq:echo: eq qq|echo|" and - not eval "qq:echo:ohce: >= 0"); - -ok 18, (not eval "qw:1" and - eval "qw:echo: eq qw|echo|" and - not eval "qw:echo:ohce: >= 0"); - -ok 19, (not eval "qx:1" and - eval "qx:echo 1: eq qx|echo 1|" and # echo without args may warn - not eval "qx:echo:ohce: >= 0"); - -ok 20, (not eval "s:1" and - not eval "s:echo: eq s|echo|" and - eval "s:echo:ohce: >= 0"); - -ok 21, (not eval "tr:1" and - not eval "tr:echo: eq tr|echo|" and - eval "tr:echo:ohce: >= 0"); - -ok 22, (not eval "y:1" and - not eval "y:echo: eq y|echo|" and - eval "y:echo:ohce: >= 0"); - -ok 23, (eval "AUTOLOAD:1" and - not eval "AUTOLOAD:echo: eq AUTOLOAD|echo|" and - not eval "AUTOLOAD:echo:ohce: >= 0"); - -ok 24, (eval "and:1" and - not eval "and:echo: eq and|echo|" and - not eval "and:echo:ohce: >= 0"); - -ok 25, (eval "alarm:1" and - not eval "alarm:echo: eq alarm|echo|" and - not eval "alarm:echo:ohce: >= 0"); diff --git a/t/CORE/comp/decl.t b/t/CORE/comp/decl.t deleted file mode 100644 index 414b3cd2d..000000000 --- a/t/CORE/comp/decl.t +++ /dev/null @@ -1,61 +0,0 @@ -#!./perl - -# check to see if subroutine declarations work everywhere - -sub one { - print "ok 1\n"; -} -format one = -ok 6 -. - -print "1..9\n"; - -one(); -two(); - -sub two { - print "ok 2\n"; -} -format two = -@<<< -$foo -. - -if ($x eq $x) { - sub three { - print "ok 3\n"; - } - three(); -} - -four(); -five(); -$~ = 'one'; -write; -$~ = 'two'; -$foo = "ok 7"; -write; -$~ = 'three'; -write; - -format three = -ok 8 -. - -if ($x eq $x) { - goto quux; -} - -print "not ok 9\n"; -exit 1; - -sub four { - print "ok 4\n"; -} - -quux: -sub five { - print "ok 5\n"; -} -print "ok 9\n"; diff --git a/t/CORE/comp/fold.t b/t/CORE/comp/fold.t deleted file mode 100644 index ec95f1aed..000000000 --- a/t/CORE/comp/fold.t +++ /dev/null @@ -1,120 +0,0 @@ -#!./perl -w - -# Uncomment this for testing, but don't leave it in for "production", as -# we've not yet verified that use works. -# use strict; - -print "1..19\n"; -my $test = 0; - -# Historically constant folding was performed by evaluating the ops, and if -# they threw an exception compilation failed. This was seen as buggy, because -# even illegal constants in unreachable code would cause failure. So now -# illegal expressions are reported at runtime, if the expression is reached, -# making constant folding consistent with many other languages, and purely an -# optimisation rather than a behaviour change. - - -sub failed { - my ($got, $expected, $name) = @_; - - print "not ok $test - $name\n"; - my @caller = caller(1); - print "# Failed test at $caller[1] line $caller[2]\n"; - if (defined $got) { - print "# Got '$got'\n"; - } else { - print "# Got undef\n"; - } - print "# Expected $expected\n"; - return; -} - -sub like { - my ($got, $pattern, $name) = @_; - $test = $test + 1; - if (defined $got && $got =~ $pattern) { - print "ok $test - $name\n"; - # Principle of least surprise - maintain the expected interface, even - # though we aren't using it here (yet). - return 1; - } - failed($got, $pattern, $name); -} - -sub is { - my ($got, $expect, $name) = @_; - $test = $test + 1; - if (defined $got && $got eq $expect) { - print "ok $test - $name\n"; - return 1; - } - failed($got, "'$expect'", $name); -} - -sub ok { - my ($got, $name) = @_; - $test = $test + 1; - if ($got) { - print "ok $test - $name\n"; - return 1; - } - failed($got, "a true value", $name); -} - -my $a; -$a = eval '$b = 0/0 if 0; 3'; -is ($a, 3, 'constants in conditionals don\'t affect constant folding'); -is ($@, '', 'no error'); - -my $b = 0; -$a = eval 'if ($b) {return sqrt -3} 3'; -is ($a, 3, 'variables in conditionals don\'t affect constant folding'); -is ($@, '', 'no error'); - -$a = eval q{ - $b = eval q{if ($b) {return log 0} 4}; - is ($b, 4, 'inner eval folds constant'); - is ($@, '', 'no error'); - 5; -}; -is ($a, 5, 'outer eval folds constant'); -is ($@, '', 'no error'); - -# warn and die hooks should be disabled during constant folding - -{ - my $c = 0; - local $SIG{__WARN__} = sub { $c++ }; - local $SIG{__DIE__} = sub { $c+= 2 }; - eval q{ - is($c, 0, "premature warn/die: $c"); - my $x = "a"+5; - is($c, 1, "missing warn hook"); - is($x, 5, "a+5"); - $c = 0; - $x = 1/0; - }; - like ($@, qr/division/, "eval caught division"); - is($c, 2, "missing die hook"); -} - -# [perl #20444] Constant folding should not change the meaning of match -# operators. -{ - local *_; - $_="foo"; my $jing = 1; - ok scalar $jing =~ (1 ? /foo/ : /bar/), - 'lone m// is not bound via =~ after ? : folding'; - ok scalar $jing =~ (0 || /foo/), - 'lone m// is not bound via =~ after || folding'; - ok scalar $jing =~ (1 ? s/foo/foo/ : /bar/), - 'lone s/// is not bound via =~ after ? : folding'; - ok scalar $jing =~ (0 || s/foo/foo/), - 'lone s/// is not bound via =~ after || folding'; - $jing = 3; - ok scalar $jing =~ (1 ? y/fo// : /bar/), - 'lone y/// is not bound via =~ after ? : folding'; - ok scalar $jing =~ (0 || y/fo//), - 'lone y/// is not bound via =~ after || folding'; -} diff --git a/t/CORE/comp/form_scope.t b/t/CORE/comp/form_scope.t deleted file mode 100644 index 3ef891e13..000000000 --- a/t/CORE/comp/form_scope.t +++ /dev/null @@ -1,18 +0,0 @@ -#!./perl -# -# Tests bug #22977. Test case from Dave Mitchell. - -print "1..2\n"; - -sub f ($); -sub f ($) { -my $test = $_[0]; -write; -format STDOUT = -ok @<<<<<<< -$test -. -} - -f(1); -f(2); diff --git a/t/CORE/comp/hints.aux b/t/CORE/comp/hints.aux deleted file mode 100644 index bb75d7b7f..000000000 --- a/t/CORE/comp/hints.aux +++ /dev/null @@ -1,4 +0,0 @@ -our($ri1, $rf1, $rfe1); -BEGIN { $ri1 = $^H; $rf1 = $^H{foo}; $rfe1 = exists($^H{foo}); } - -1; diff --git a/t/CORE/comp/hints.t b/t/CORE/comp/hints.t deleted file mode 100644 index a2d458410..000000000 --- a/t/CORE/comp/hints.t +++ /dev/null @@ -1,286 +0,0 @@ -#!./perl - -# Tests the scoping of $^H and %^H - -BEGIN { - unshift @INC, 't/CORE/lib'; - require 't/CORE/test.pl'; -} -# INIT { chdir "t/CORE"; } - -BEGIN { print "1..31\n"; } -BEGIN { - print "not " if exists $^H{foo}; - print "ok 1 - \$^H{foo} doesn't exist initially\n"; - if (${^OPEN}) { - print "not " unless $^H & 0x00020000; - print "ok 2 - \$^H contains HINT_LOCALIZE_HH initially with ${^OPEN}\n"; - } else { - print "not " if $^H & 0x00020000; - print "ok 2 - \$^H doesn't contain HINT_LOCALIZE_HH initially\n"; - } -} -{ - # simulate a pragma -- don't forget HINT_LOCALIZE_HH - BEGIN { $^H |= 0x04020000; $^H{foo} = "a"; } - BEGIN { - print "not " if $^H{foo} ne "a"; - print "ok 3 - \$^H{foo} is now 'a'\n"; - print "not " unless $^H & 0x00020000; - print "ok 4 - \$^H contains HINT_LOCALIZE_HH while compiling\n"; - } - { - BEGIN { $^H |= 0x00020000; $^H{foo} = "b"; } - BEGIN { - print "not " if $^H{foo} ne "b"; - print "ok 5 - \$^H{foo} is now 'b'\n"; - } - } - BEGIN { - print "not " if $^H{foo} ne "a"; - print "ok 6 - \$^H{foo} restored to 'a'\n"; - } - # The pragma settings disappear after compilation - # (test at CHECK-time and at run-time) - CHECK { - print "not " if exists $^H{foo}; - print "ok 9 - \$^H{foo} doesn't exist when compilation complete\n"; - if (${^OPEN}) { - print "not " unless $^H & 0x00020000; - print "ok 10 - \$^H contains HINT_LOCALIZE_HH when compilation complete with ${^OPEN}\n"; - } else { - print "not " if $^H & 0x00020000; - print "ok 10 - \$^H doesn't contain HINT_LOCALIZE_HH when compilation complete\n"; - } - } - print "not " if exists $^H{foo}; - print "ok 11 - \$^H{foo} doesn't exist at runtime\n"; - if (${^OPEN}) { - print "not " unless $^H & 0x00020000; - print "ok 12 - \$^H contains HINT_LOCALIZE_HH at run-time with ${^OPEN}\n"; - } else { - print "not " if $^H & 0x00020000; - print "ok 12 - \$^H doesn't contain HINT_LOCALIZE_HH at run-time\n"; - } - # op_entereval should keep the pragmas it was compiled with - eval q* - BEGIN { - print "not " if $^H{foo} ne "a"; - print "ok 13 - \$^H{foo} is 'a' at eval-\"\" time\n"; - print "not " unless $^H & 0x00020000; - print "ok 14 - \$^H contains HINT_LOCALIZE_HH at eval\"\"-time\n"; - } - *; -} -BEGIN { - print "not " if exists $^H{foo}; - print "ok 7 - \$^H{foo} doesn't exist while finishing compilation\n"; - if (${^OPEN}) { - print "not " unless $^H & 0x00020000; - print "ok 8 - \$^H contains HINT_LOCALIZE_HH while finishing compilation with ${^OPEN}\n"; - } else { - print "not " if $^H & 0x00020000; - print "ok 8 - \$^H doesn't contain HINT_LOCALIZE_HH while finishing compilation\n"; - } -} - -{ - BEGIN{$^H{x}=1}; - for my $tno (15..16) { - eval q( - BEGIN { - print $^H{x}==1 && !$^H{y} ? "ok $tno\n" : "not ok $tno\n"; - } - $^H{y} = 1; - ); - if ($@) { - (my $str = $@)=~s/^/# /gm; - print "not ok $tno\n$str\n"; - } - } -} - -{ - BEGIN { $^H |= 0x04000000; $^H{foo} = "z"; } - - our($ri0, $rf0); BEGIN { $ri0 = $^H; $rf0 = $^H{foo}; } - print +($ri0 & 0x04000000 ? "" : "not "), "ok 17 - \$^H correct before require\n"; - print +($rf0 eq "z" ? "" : "not "), "ok 18 - \$^H{foo} correct before require\n"; - - our($ra1, $ri1, $rf1, $rfe1); - BEGIN { require "t/CORE/comp/hints.aux"; } - print +(!($ri1 & 0x04000000) ? "" : "not "), "ok 19 - \$^H cleared for require\n"; - print +(!defined($rf1) && !$rfe1 ? "" : "not "), "ok 20 - \$^H{foo} cleared for require\n"; - - our($ri2, $rf2); BEGIN { $ri2 = $^H; $rf2 = $^H{foo}; } - print +($ri2 & 0x04000000 ? "" : "not "), "ok 21 - \$^H correct after require\n"; - print +($rf2 eq "z" ? "" : "not "), "ok 22 - \$^H{foo} correct after require\n"; -} - -# [perl #73174] - -{ - my $res; - BEGIN { $^H{73174} = "foo" } - BEGIN { $res = ($^H{73174} // "") } - "" =~ /\x{100}/i; # forces loading of utf8.pm, which used to reset %^H - BEGIN { $res .= '-' . ($^H{73174} // "")} - $res .= '-' . ($^H{73174} // ""); - print $res eq "foo-foo-" ? "" : "not ", - "ok 23 - \$^H{foo} correct after /unicode/i (res=$res)\n"; -} - -# [perl #106282] Crash when tying %^H -# Tying %^H should not result in a crash when the hint hash is cloned. -# Hints should also be copied properly to inner scopes. See also -# [rt.cpan.org #73402]. -eval q` - # Do something naughty enough, and you get your module mentioned in the - # test suite. :-) - package namespace::clean::_TieHintHash; - - sub TIEHASH { bless[] } - sub STORE { $_[0][0]{$_[1]} = $_[2] } - sub FETCH { $_[0][0]{$_[1]} } - sub FIRSTKEY { my $a = scalar keys %{$_[0][0]}; each %{$_[0][0]} } - sub NEXTKEY { each %{$_[0][0]} } - - package main; - - BEGIN { - $^H{foo} = "bar"; # activate localisation magic - tie( %^H, 'namespace::clean::_TieHintHash' ); # sabotage %^H - $^H{foo} = "bar"; # create an element in the tied hash - } - { # clone the tied hint hash on scope entry - BEGIN { - print "not " x ($^H{foo} ne 'bar'), - "ok 24 - tied hint hash is copied to inner scope\n"; - %^H = (); - tie( %^H, 'namespace::clean::_TieHintHash' ); - $^H{foo} = "bar"; - } - { - BEGIN{ - print - "not " x ($^H{foo} ne 'bar'), - "ok 25 - tied empty hint hash is copied to inner scope\n" - } - } - 1; - } - 1; -` or warn $@; -print "ok 26 - no crash when cloning a tied hint hash\n"; - -{ - my $w; - local $SIG{__WARN__} = sub { $w = shift }; - eval q` - package namespace::clean::_TieHintHasi; - - sub TIEHASH { bless[] } - sub STORE { $_[0][0]{$_[1]} = $_[2] } - sub FETCH { $_[0][0]{$_[1]} } - sub FIRSTKEY { my $a = scalar keys %{$_[0][0]}; each %{$_[0][0]} } - # Intentionally commented out: - # sub NEXTKEY { each %{$_[0][0]} } - - package main; - - BEGIN { - $^H{foo} = "bar"; # activate localisation magic - tie( %^H, 'namespace::clean::_TieHintHasi' ); # sabotage %^H - $^H{foo} = "bar"; # create an element in the tied hash - } - { ; } # clone the tied hint hash - `; - print "not " if $w; - print "ok 27 - double-freeing explosive tied hints hash\n"; - print "# got: $w" if $w; -} - -# Setting ${^WARNING_HINTS} to its own value should not change things. -{ - my $w; - local $SIG{__WARN__} = sub { $w++ }; - BEGIN { - # should have no effect: - my $x = ${^WARNING_BITS}; - ${^WARNING_BITS} = $x; - } - { - local $^W = 1; - () = 1 + undef; - } - print "# ", $w//'no', " warnings\nnot " unless $w == 1; - print "ok 28 - ", - "setting \${^WARNING_BITS} to its own value has no effect\n"; -} - -# [perl #112326] -# this code could cause a crash, due to PL_hints continuing to point to th -# hints hash currently being freed - -{ - package Foo; - my @h = qw(a 1 b 2); - BEGIN { - $^H{FOO} = bless {}; - } - sub DESTROY { - @h = %^H; - delete $INC{strict}; require strict; # boom! - } - my $h = join ':', %h; - # this isn't the main point of the test; the main point is that - # it doesn't crash! - print "not " if $h ne ''; - print "ok 29 - #112326\n"; -} - - -# [perl #112444] -# A destructor called while %^H is freed should not be able to stop %^H -# from being magical (due to *^H{HASH} being undef). -{ - BEGIN { - # Make sure %^H is clear and not localised, to begin with - %^H = (); - $^H = 0; - } - DESTROY { %^H } - { - { - BEGIN { - $^H{foom} = bless[]; - } - } # scope exit triggers destructor, which autovivifies a non- - # magical %^H - BEGIN { - # Here we have the %^H created by DESTROY, which is - # not localised - $^H{112444} = 'baz'; - } - } # %^H leaks on scope exit - BEGIN { @keez = keys %^H } -} -print "not " if @keez; -print "ok 30 - %^H does not leak when autovivified in destructor\n"; -print "# keys are: @keez\n" if @keez; - - -# Add new tests above this require, in case it fails. -#require 't/CORE/test.pl'; - -# bug #27040: hints hash was being double-freed -my $result = runperl( - prog => '$^H |= 0x20000; eval q{BEGIN { $^H |= 0x20000 }}', - stderr => 1 -); -print "not " if length $result; -print "ok 31 - double-freeing hints hash\n"; -print "# got: $result\n" if length $result; - -__END__ -# Add new tests above require 'test.pl' diff --git a/t/CORE/comp/line_debug.t b/t/CORE/comp/line_debug.t deleted file mode 100644 index 9168fcd51..000000000 --- a/t/CORE/comp/line_debug.t +++ /dev/null @@ -1,30 +0,0 @@ -#!./perl - - -sub ok { - my($test,$ok) = @_; - print "not " unless $ok; - print "ok $test\n"; -} - -# The auxiliary file contains a bunch of code that systematically exercises -# every place that can call lex_next_chunk() (except for the one that's not -# used by the main Perl parser). -open AUX, "<", "t/CORE/comp/line_debug_0.aux" or die $!; -my @lines = ; -close AUX; -my $nlines = @lines; - -print "1..", 2+$nlines, "\n"; - -$^P = 0x2; -do "t/CORE/comp/line_debug_0.aux"; - -ok 1, scalar(@{"_',$filename) || (die "Can't open $filename: $!"); - -$x = 'now is the time -for all good men -to come to. - - -! - -'; - -$y = 'now is the time' . "\n" . -'for all good men' . "\n" . -'to come to.' . "\n\n\n!\n\n"; - -is($x, $y, 'test data is sane'); - -print $TRY $x; -close $TRY or die "Could not close: $!"; - -open(TRY,$filename) || (die "Can't reopen $filename: $!"); -$count = 0; -$z = ''; -while () { - $z .= $_; - $count = $count + 1; -} - -is($z, $y, 'basic multiline reading'); - -is($count, 7, ' line count'); -is($., 7, ' $.' ); - -$out = (($^O eq 'MSWin32') || $^O eq 'NetWare') ? `type $filename` - : ($^O eq 'VMS') ? `type $filename.;0` # otherwise .LIS is assumed - : `cat $filename`; - -like($out, qr/.*\n.*\n.*\n$/); - -close(TRY) || (die "Can't close $filename: $!"); - -is($out, $y); diff --git a/t/CORE/comp/opsubs.t b/t/CORE/comp/opsubs.t deleted file mode 100644 index 89b1af517..000000000 --- a/t/CORE/comp/opsubs.t +++ /dev/null @@ -1,209 +0,0 @@ -#!./perl -Tw - -# Uncomment this for testing, but don't leave it in for "production", as -# we've not yet verified that use works. -# use strict; - -$|++; - -print "1..36\n"; -my $test = 0; - -sub failed { - my ($got, $expected, $name) = @_; - - if ($::TODO) { - print "not ok $test - $name # TODO: $::TODO\n"; - } - else { - print "not ok $test - $name\n"; - } - my @caller = caller(1); - print "# Failed test at $caller[1] line $caller[2]\n"; - if (defined $got) { - print "# Got '$got'\n"; - } else { - print "# Got undef\n"; - } - print "# Expected $expected\n"; - return; -} - -sub like { - my ($got, $pattern, $name) = @_; - $test = $test + 1; - if (defined $got && $got =~ $pattern) { - if ($::TODO) { - print "ok $test - $name # TODO: $::TODO\n"; - } - else { - print "ok $test - $name\n"; - } - # Principle of least surprise - maintain the expected interface, even - # though we aren't using it here (yet). - return 1; - } - failed($got, $pattern, $name); -} - -sub is { - my ($got, $expect, $name) = @_; - $test = $test + 1; - if (defined $got && $got eq $expect) { - if ($::TODO) { - print "ok $test - $name # TODO: $::TODO\n"; - } - else { - print "ok $test - $name\n"; - } - return 1; - } - failed($got, "'$expect'", $name); -} - -sub isnt { - my ($got, $expect, $name) = @_; - $test = $test + 1; - if (defined $got && $got ne $expect) { - if ($::TODO) { - print "ok $test - $name # TODO: $::TODO\n"; - } - else { - print "ok $test - $name\n"; - } - return 1; - } - failed($got, "not '$expect'", $name); -} - -sub can_ok { - my ($class, $method) = @_; - $test = $test + 1; - if (eval { $class->can($method) }) { - if ($::TODO) { - print "ok $test - $class->can('$method') # TODO: $::TODO\n"; - } - else { - print "ok $test - $class->can('$method')\n"; - } - return 1; - } - my @caller = caller; - print "# Failed test at $caller[1] line $caller[2]\n"; - print "# $class cannot $method\n"; - return; -} - -=pod - -Even if you have a C, calling C will be parsed as the -C operator. Calling C<&q()> or C gets you the function. -This test verifies this behavior for nine different operators. - -=cut - -sub m { return "m-".shift } -sub q { return "q-".shift } -sub qq { return "qq-".shift } -sub qr { return "qr-".shift } -sub qw { return "qw-".shift } -sub qx { return "qx-".shift } -sub s { return "s-".shift } -sub tr { return "tr-".shift } -sub y { return "y-".shift } - -# m operator -can_ok( 'main', "m" ); -SILENCE_WARNING: { # Complains because $_ is undef - local $^W; - isnt( m('unqualified'), "m-unqualified", "m('unqualified') is oper" ); -} -is( main::m('main'), "m-main", "main::m() is func" ); -is( &m('amper'), "m-amper", "&m() is func" ); - -# q operator -can_ok( 'main', "q" ); -isnt( q('unqualified'), "q-unqualified", "q('unqualified') is oper" ); -is( main::q('main'), "q-main", "main::q() is func" ); -is( &q('amper'), "q-amper", "&q() is func" ); - -# qq operator -can_ok( 'main', "qq" ); -isnt( qq('unqualified'), "qq-unqualified", "qq('unqualified') is oper" ); -is( main::qq('main'), "qq-main", "main::qq() is func" ); -is( &qq('amper'), "qq-amper", "&qq() is func" ); - -# qr operator -can_ok( 'main', "qr" ); -isnt( qr('unqualified'), "qr-unqualified", "qr('unqualified') is oper" ); -is( main::qr('main'), "qr-main", "main::qr() is func" ); -is( &qr('amper'), "qr-amper", "&qr() is func" ); - -# qw operator -can_ok( 'main', "qw" ); -isnt( qw('unqualified'), "qw-unqualified", "qw('unqualified') is oper" ); -is( main::qw('main'), "qw-main", "main::qw() is func" ); -is( &qw('amper'), "qw-amper", "&qw() is func" ); - -# qx operator -can_ok( 'main', "qx" ); -eval "qx('unqualified'". - ($^O eq 'MSWin32' ? " 2>&1)" : ")"); -TODO: { - local $::TODO = $^O eq 'MSWin32' ? "Tainting of PATH not working of Windows" : $::TODO; - like( $@, qr/^Insecure/, "qx('unqualified') doesn't work" ); -} -is( main::qx('main'), "qx-main", "main::qx() is func" ); -is( &qx('amper'), "qx-amper", "&qx() is func" ); - -# s operator -can_ok( 'main', "s" ); -eval "s('unqualified')"; -like( $@, qr/^Substitution replacement not terminated/, "s('unqualified') doesn't work" ); -is( main::s('main'), "s-main", "main::s() is func" ); -is( &s('amper'), "s-amper", "&s() is func" ); - -# tr operator -can_ok( 'main', "tr" ); -eval "tr('unqualified')"; -like( $@, qr/^Transliteration replacement not terminated/, "tr('unqualified') doesn't work" ); -is( main::tr('main'), "tr-main", "main::tr() is func" ); -is( &tr('amper'), "tr-amper", "&tr() is func" ); - -# y operator -can_ok( 'main', "y" ); -eval "y('unqualified')"; -like( $@, qr/^Transliteration replacement not terminated/, "y('unqualified') doesn't work" ); -is( main::y('main'), "y-main", "main::y() is func" ); -is( &y('amper'), "y-amper", "&y() is func" ); - -=pod - -from irc://irc.perl.org/p5p 2004/08/12 - - bug or feature? - You decide!!!! - [kane@coke ~]$ perlc -le'sub y{1};y(1)' - Transliteration replacement not terminated at -e line 1. - bug I think - i'll perlbug - feature - smiles at rgs - done - will be closed at not a bug, - like the previous reports of this one - feature being first class and second class keywords? - you have similar ones with q, qq, qr, qx, tr, s and m - one could say 1st class keywords, yes - and I forgot qw - hmm silly... - it's acutally operators, isn't it? - as in you can't call a subroutine with the same name as an - operator unless you have the & ? - or fqpn (fully qualified package name) - main::y() works just fine - as does &y; but not y() - If that's a feature, then let's write a test that it continues - to work like that. - -=cut diff --git a/t/CORE/comp/our.t b/t/CORE/comp/our.t deleted file mode 100644 index d271fe517..000000000 --- a/t/CORE/comp/our.t +++ /dev/null @@ -1,75 +0,0 @@ -#!./perl - -print "1..7\n"; -my $test = 0; - -sub is { - my ($got, $expect, $name) = @_; - $test = $test + 1; - if (defined $got && $got eq $expect) { - print "ok $test - $name\n"; - return 1; - } - - print "not ok $test - $name\n"; - my @caller = caller(0); - print "# Failed test at $caller[1] line $caller[2]\n"; - if (defined $got) { - print "# Got '$got'\n"; - } else { - print "# Got undef\n"; - } - print "# Expected $expect\n"; - return; -} - -{ - package TieAll; - # tie, track, and report what calls are made - my @calls; - sub AUTOLOAD { - for ($AUTOLOAD =~ /TieAll::(.*)/) { - if (/TIE/) { return bless {} } - elsif (/calls/) { return join ',', splice @calls } - else { - push @calls, $_; - # FETCHSIZE doesn't like undef - # if FIRSTKEY, see if NEXTKEY is also called - return 1 if /FETCHSIZE|FIRSTKEY/; - return; - } - } - } -} - -tie $x, 'TieAll'; -tie @x, 'TieAll'; -tie %x, 'TieAll'; - -{our $x;} -is(TieAll->calls, '', 'our $x has no runtime effect'); - -{our ($x);} -is(TieAll->calls, '', 'our ($x) has no runtime effect'); - -{our %x;} -is(TieAll->calls, '', 'our %x has no runtime effect'); - -{our (%x);} -is(TieAll->calls, '', 'our (%x) has no runtime effect'); - -{our @x;} -is(TieAll->calls, '', 'our @x has no runtime effect'); - -{our (@x);} -is(TieAll->calls, '', 'our (@x) has no runtime effect'); - - -$y = 1; -{ - my $y = 2; - { - our $y = $y; - is($y, 2, 'our shouldnt be visible until introduced') - } -} diff --git a/t/CORE/comp/package.t b/t/CORE/comp/package.t deleted file mode 100644 index 0af8cbd42..000000000 --- a/t/CORE/comp/package.t +++ /dev/null @@ -1,76 +0,0 @@ -#!./perl - -print "1..14\n"; - -$blurfl = 123; -$foo = 3; - -package xyz; - -sub new {bless [];} - -$bar = 4; - -{ - package ABC; - $blurfl = 5; - $main'a = $'b; -} - -$ABC'dyick = 6; - -$xyz = 2; - -# perlcc issue 209 + 210 - https://code.google.com/p/perl-compiler/issues/detail?id=210 -$main = join(':', sort(keys %main::)); -$xyz = join(':', sort(keys %xyz::)); -$ABC = join(':', sort(keys %ABC::)); - -if ('a' lt 'A') { - print $xyz eq 'bar:main:new:xyz:ABC' ? "ok 1\n" : "not ok 1 '$xyz'\n"; -} else { - print $xyz eq 'ABC:bar:main:new:xyz' ? "ok 1\n" : "not ok 1 '$xyz'\n"; -} -print $ABC eq 'blurfl:dyick' ? "ok 2\n" : "not ok 2 '$ABC'\n"; -print $main'blurfl == 123 ? "ok 3\n" : "not ok 3\n"; - -package ABC; - -print $blurfl == 5 ? "ok 4\n" : "not ok 4\n"; -# perlcc issue 212 - https://code.google.com/p/perl-compiler/issues/detail?id=212 -eval 'print $blurfl == 5 ? "ok 5\n" : "not ok 5\n";'; -eval 'package main; print $blurfl == 123 ? "ok 6\n" : "not ok 6\n";'; -print $blurfl == 5 ? "ok 7\n" : "not ok 7\n"; - -package main; - -sub c { caller(0) } - -sub foo { - my $s = shift; - if ($s) { - package PQR; - main::c(); - } -} - -print((foo(1))[0] eq 'PQR' ? "ok 8\n" : "not ok 8\n"); - -my $Q = xyz->new(); -undef %xyz::; -eval { $a = *xyz::new{PACKAGE}; }; -print $a eq "__ANON__" ? "ok 9\n" : "not ok 9 #TODO #182 Wontfix '$a'\n"; - -eval { $Q->param; }; -print $@ =~ /^Can't use anonymous symbol table for method lookup/ ? - "ok 10\n" : "not ok 10 # '$@'\n"; - -print "$Q" =~ /^__ANON__=/ ? "ok 11\n" : "not ok 11 # '$Q'\n"; - -print ref $Q eq "__ANON__" ? "ok 12\n" : "not ok 12 # '$Q'\n"; - -package bug32562; - -print __PACKAGE__ eq 'bug32562' ? "ok 13\n" : "not ok 13\n"; -print eval '__PACKAGE__' eq 'bug32562' ? "ok 14\n" : "not ok 14\n"; - diff --git a/t/CORE/comp/package_block.t b/t/CORE/comp/package_block.t deleted file mode 100644 index e3494e575..000000000 --- a/t/CORE/comp/package_block.t +++ /dev/null @@ -1,92 +0,0 @@ -#!./perl - -print "1..7\n"; - -$main::result = ""; -eval q{ - $main::result .= "a(".__PACKAGE__."/".eval("__PACKAGE__").")"; - package Foo { - $main::result .= "b(".__PACKAGE__."/".eval("__PACKAGE__").")"; - package Bar::Baz { - $main::result .= "c(".__PACKAGE__."/".eval("__PACKAGE__").")"; - } - $main::result .= "d(".__PACKAGE__."/".eval("__PACKAGE__").")"; - } - $main::result .= "e(".__PACKAGE__."/".eval("__PACKAGE__").")"; -}; -print $main::result eq - "a(main/main)b(Foo/Foo)c(Bar::Baz/Bar::Baz)d(Foo/Foo)e(main/main)" ? - "ok 1\n" : "not ok 1\n"; - -$main::result = ""; -eval q{ - $main::result .= "a($Foo::VERSION)"; - $main::result .= "b($Bar::VERSION)"; - package Foo 11 { ; } - package Bar 22 { - $main::result .= "c(".__PACKAGE__."/".eval("__PACKAGE__").")"; - } -}; -print $main::result eq "a(11)b(22)c(Bar/Bar)" ? "ok 2\n" : "not ok 2\n"; - -$main::result = ""; -eval q{ - $main::result .= "a(".__PACKAGE__."/".eval("__PACKAGE__").")"; - package Foo { } - $main::result .= "b(".__PACKAGE__."/".eval("__PACKAGE__").")"; -}; -print $main::result eq "a(main/main)b(main/main)" ? "ok 3\n" : "not ok 3\n"; - -eval q[package Foo {]; -print $@ =~ /\AMissing right curly / ? "ok 4\n" : "not ok 4\n"; - -$main::result = ""; -eval q{ - $main::result .= "a(".__LINE__.")"; - package Foo { - $main::result .= "b(".__LINE__.")"; - package Bar::Baz { - $main::result .= "c(".__LINE__.")"; - } - $main::result .= "d(".__LINE__.")"; - } - $main::result .= "e(".__LINE__.")"; - package Quux { } - $main::result .= "f(".__LINE__.")"; -}; -print $main::result eq "a(2)b(4)c(6)d(8)e(10)f(12)" ? "ok 5\n" : "not ok 5\n"; - -$main::result = ""; -$main::warning = ""; -$SIG{__WARN__} = sub { $main::warning .= $_[0]; }; -eval q{ - $main::result .= "a(".__PACKAGE__."/".eval("__PACKAGE__").")"; - goto l0; - $main::result .= "b(".__PACKAGE__."/".eval("__PACKAGE__").")"; - package Foo { - $main::result .= "c(".__PACKAGE__."/".eval("__PACKAGE__").")"; - l0: - $main::result .= "d(".__PACKAGE__."/".eval("__PACKAGE__").")"; - goto l1; - $main::result .= "e(".__PACKAGE__."/".eval("__PACKAGE__").")"; - } - $main::result .= "f(".__PACKAGE__."/".eval("__PACKAGE__").")"; - l1: - $main::result .= "g(".__PACKAGE__."/".eval("__PACKAGE__").")"; - goto l2; - $main::result .= "h(".__PACKAGE__."/".eval("__PACKAGE__").")"; - package Bar { - l2: - $main::result .= "i(".__PACKAGE__."/".eval("__PACKAGE__").")"; - } - $main::result .= "j(".__PACKAGE__."/".eval("__PACKAGE__").")"; -}; -print $main::result eq - "a(main/main)d(Foo/Foo)g(main/main)i(Bar/Bar)j(main/main)" ? - "ok 6\n" : "not ok 6\n"; -print $main::warning =~ /\A - Use\ of\ "goto"\ [^\n]*\ line\ 3\.\n - Use\ of\ "goto"\ [^\n]*\ line\ 15\.\n - \z/x ? "ok 7\n" : "not ok 7\n"; - -1; diff --git a/t/CORE/comp/parser.t b/t/CORE/comp/parser.t deleted file mode 100644 index 8d4d08993..000000000 --- a/t/CORE/comp/parser.t +++ /dev/null @@ -1,453 +0,0 @@ -#!./perl - -# Checks if the parser behaves correctly in edge cases -# (including weird syntax errors) - -print "1..121\n"; - -sub failed { - my ($got, $expected, $name) = @_; - - print "not ok $test - $name\n"; - my @caller = caller(1); - print "# Failed test at $caller[1] line $caller[2]\n"; - if (defined $got) { - print "# Got '$got'\n"; - } else { - print "# Got undef\n"; - } - print "# Expected $expected\n"; - return; -} - -sub like { - my ($got, $pattern, $name) = @_; - $test = $test + 1; - if (defined $got && $got =~ $pattern) { - print "ok $test - $name\n"; - # Principle of least surprise - maintain the expected interface, even - # though we aren't using it here (yet). - return 1; - } - failed($got, $pattern, $name); -} - -sub is { - my ($got, $expect, $name) = @_; - $test = $test + 1; - if (defined $expect) { - if (defined $got && $got eq $expect) { - print "ok $test - $name\n"; - return 1; - } - failed($got, "'$expect'", $name); - } else { - if (!defined $got) { - print "ok $test - $name\n"; - return 1; - } - failed($got, 'undef', $name); - } -} - -eval '%@x=0;'; -like( $@, qr/^Can't modify hash dereference in repeat \(x\)/, '%@x=0' ); - -# Bug 20010422.005 -eval q{{s//${}/; //}}; -like( $@, qr/syntax error/, 'syntax error, used to dump core' ); - -# Bug 20010528.007 -eval q/"\x{"/; -like( $@, qr/^Missing right brace on \\x/, - 'syntax error in string, used to dump core' ); - -eval q/"\N{"/; -like( $@, qr/^Missing right brace on \\N/, - 'syntax error in string with incomplete \N' ); -eval q/"\Nfoo"/; -like( $@, qr/^Missing braces on \\N/, - 'syntax error in string with incomplete \N' ); - -eval "a.b.c.d.e.f;sub"; -like( $@, qr/^Illegal declaration of anonymous subroutine/, - 'found by Markov chain stress testing' ); - -# Bug 20010831.001 -eval '($a, b) = (1, 2);'; -like( $@, qr/^Can't modify constant item in list assignment/, - 'bareword in list assignment' ); - -eval 'tie FOO, "Foo";'; -like( $@, qr/^Can't modify constant item in tie /, - 'tying a bareword causes a segfault in 5.6.1' ); - -eval 'undef foo'; -like( $@, qr/^Can't modify constant item in undef operator /, - 'undefing constant causes a segfault in 5.6.1 [ID 20010906.019]' ); - -eval 'read($bla, FILE, 1);'; -like( $@, qr/^Can't modify constant item in read /, - 'read($var, FILE, 1) segfaults on 5.6.1 [ID 20011025.054]' ); - -# This used to dump core (bug #17920) -eval q{ sub { sub { f1(f2();); my($a,$b,$c) } } }; -like( $@, qr/error/, 'lexical block discarded by yacc' ); - -# bug #18573, used to corrupt memory -eval q{ "\c" }; -like( $@, qr/^Missing control char name in \\c/, q("\c" string) ); - -eval q{ qq(foo$) }; -like( $@, qr/Final \$ should be \\\$ or \$name/, q($ at end of "" string) ); - -# two tests for memory corruption problems in the said variables -# (used to dump core or produce strange results) - -is( "\Q\Q\Q\Q\Q\Q\Q\Q\Q\Q\Q\Q\Qa", "a", "PL_lex_casestack" ); - -eval { -{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{ -{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{ -{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{ -}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}} -}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}} -}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}} -}; -is( $@, '', 'PL_lex_brackstack' ); - -{ - # tests for bug #20716 - undef $a; - undef @b; - my $a="A"; - is("${a}{", "A{", "interpolation, qq//"); - is("${a}[", "A[", "interpolation, qq//"); - my @b=("B"); - is("@{b}{", "B{", "interpolation, qq//"); - is(qr/${a}\{/, '(?^:A\{)', "interpolation, qr//"); - my $c = "A{"; - $c =~ /${a}\{/; - is($&, 'A{', "interpolation, m//"); - $c =~ s/${a}\{/foo/; - is($c, 'foo', "interpolation, s/...//"); - $c =~ s/foo/${a}{/; - is($c, 'A{', "interpolation, s//.../"); - is(<<"${a}{", "A{ A[ B{\n", "interpolation, here doc"); -${a}{ ${a}[ @{b}{ -${a}{ -} - -eval q{ sub a(;; &) { } a { } }; -is($@, '', "';&' sub prototype confuses the lexer"); - -# Bug #21575 -# ensure that the second print statement works, by playing a bit -# with the test output. -my %data = ( foo => "\n" ); -print "#"; -print( -$data{foo}); -$test = $test + 1; -print "ok $test\n"; - -# Bug #21875 -# { q.* => ... } should be interpreted as hash, not block - -foreach my $line (split /\n/, <<'EOF') -1 { foo => 'bar' } -1 { qoo => 'bar' } -1 { q => 'bar' } -1 { qq => 'bar' } -0 { q,'bar', } -0 { q=bar= } -0 { qq=bar= } -1 { q=bar= => 'bar' } -EOF -{ - my ($expect, $eval) = split / /, $line, 2; - my $result = eval $eval; - is($@, '', "eval $eval"); - is(ref $result, $expect ? 'HASH' : '', $eval); -} - -# Bug #24212 -{ - local $SIG{__WARN__} = sub { }; # silence mandatory warning - eval q{ my $x = -F 1; }; - like( $@, qr/(?i:syntax|parse) error .* near "F 1"/, "unknown filetest operators" ); - is( - eval q{ sub F { 42 } -F 1 }, - '-42', - '-F calls the F function' - ); -} - -# Bug #24762 -{ - eval q{ *foo{CODE} ? 1 : 0 }; - is( $@, '', "glob subscript in conditional" ); -} - -# Bug #25824 -{ - eval q{ sub f { @a=@b=@c; {use} } }; - like( $@, qr/syntax error/, "use without body" ); -} - -# [perl #2738] perl segfautls on input -{ - eval q{ sub _ <> {} }; - like($@, qr/Illegal declaration of subroutine main::_/, "readline operator as prototype"); - - eval q{ $s = sub <> {} }; - like($@, qr/Illegal declaration of anonymous subroutine/, "readline operator as prototype"); - - eval q{ sub _ __FILE__ {} }; - like($@, qr/Illegal declaration of subroutine main::_/, "__FILE__ as prototype"); -} - -# tests for "Bad name" -eval q{ foo::$bar }; -like( $@, qr/Bad name after foo::/, 'Bad name after foo::' ); -eval q{ foo''bar }; -like( $@, qr/Bad name after foo'/, 'Bad name after foo\'' ); - -# test for ?: context error -eval q{($a ? $x : ($y)) = 5}; -like( $@, qr/Assignment to both a list and a scalar/, 'Assignment to both a list and a scalar' ); - -eval q{ s/x/#/e }; -is( $@, '', 'comments in s///e' ); - -# these five used to coredump because the op cleanup on parse error could -# be to the wrong pad - -eval q[ - sub { our $a= 1;$a;$a;$a;$a;$a;$a;$a;$a;$a;$a;$a;$a;$a;$a;$a;$a;$a;$a;$a; - sub { my $z -]; - -like($@, qr/Missing right curly/, 'nested sub syntax error' ); - -eval q[ - sub { my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s,$r); - sub { my $z -]; -like($@, qr/Missing right curly/, 'nested sub syntax error 2' ); - -eval q[ - sub { our $a= 1;$a;$a;$a;$a;$a;$a;$a;$a;$a;$a;$a;$a;$a;$a;$a;$a;$a;$a;$a; - use DieDieDie; -]; - -like($@, qr/Can't locate DieDieDie.pm/, 'croak cleanup' ); - -eval q[ - sub { my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s,$r); - use DieDieDie; -]; - -like($@, qr/Can't locate DieDieDie.pm/, 'croak cleanup 2' ); - - -eval q[ - my @a; - my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s,$r); - @a =~ s/a/b/; # compile-time error - use DieDieDie; -]; - -like($@, qr/Can't modify/, 'croak cleanup 3' ); - -# these might leak, or have duplicate frees, depending on the bugginess of -# the parser stack 'fail in reduce' cleanup code. They're here mainly as -# something to be run under valgrind, with PERL_DESTRUCT_LEVEL=1. - -eval q[ BEGIN { } ] for 1..10; -is($@, "", 'BEGIN 1' ); - -eval q[ BEGIN { my $x; $x = 1 } ] for 1..10; -is($@, "", 'BEGIN 2' ); - -eval q[ BEGIN { \&foo1 } ] for 1..10; -is($@, "", 'BEGIN 3' ); - -eval q[ sub foo2 { } ] for 1..10; -is($@, "", 'BEGIN 4' ); - -eval q[ sub foo3 { my $x; $x=1 } ] for 1..10; -is($@, "", 'BEGIN 5' ); - -eval q[ BEGIN { die } ] for 1..10; -like($@, qr/BEGIN failed--compilation aborted/, 'BEGIN 6' ); - -eval q[ BEGIN {\&foo4; die } ] for 1..10; -like($@, qr/BEGIN failed--compilation aborted/, 'BEGIN 7' ); - -{ - # RT #70934 - # check both the specific case in the ticket, and a few other paths into - # S_scan_ident() - # simplify long ids - my $x100 = "x" x 256; - my $xFE = "x" x 254; - my $xFD = "x" x 253; - my $xFC = "x" x 252; - my $xFB = "x" x 251; - - eval qq[ \$#$xFB ]; - is($@, "", "251 character \$# sigil ident ok"); - eval qq[ \$#$xFC ]; - like($@, qr/Identifier too long/, "too long id in \$# sigil ctx"); - - eval qq[ \$$xFB ]; - is($@, "", "251 character \$ sigil ident ok"); - eval qq[ \$$xFC ]; - like($@, qr/Identifier too long/, "too long id in \$ sigil ctx"); - - eval qq[ %$xFB ]; - is($@, "", "251 character % sigil ident ok"); - eval qq[ %$xFC ]; - like($@, qr/Identifier too long/, "too long id in % sigil ctx"); - - # This is too long since 5.18 - #eval qq[ \\&$xFC ]; # take a ref since I don't want to call it - #is($@, "", "252 character & sigil ident ok"); - eval qq[ \\&$xFD ]; - like($@, qr/Identifier too long/, "too long id in & sigil ctx"); - - eval qq[ *$xFC ]; - is($@, "", "252 character glob ident ok"); - eval qq[ *$xFD ]; - like($@, qr/Identifier too long/, "too long id in glob ctx"); - - # This fails since 5.18 - #eval qq[ for $xFD ]; - #like($@, qr/Missing \$ on loop variable/, - # "253 char id ok, but a different error"); - eval qq[ for $xFE; ]; - like($@, qr/Identifier too long/, "too long id in for ctx"); - - # the specific case from the ticket - my $x = "x" x 257; - eval qq[ for $x ]; - like($@, qr/Identifier too long/, "too long id ticket case"); -} - -{ - is(exists &zlonk, '', 'sub not present'); - eval qq[ {sub zlonk} ]; - is($@, '', 'sub declaration followed by a closing curly'); - is(exists &zlonk, 1, 'sub now stubbed'); - is(defined &zlonk, '', 'but no body defined'); -} - -# bug #71748 -eval q{ - $_ = ""; - s/(.)/ - { - # - }->{$1}; - /e; - 1; -}; -is($@, "", "multiline whitespace inside substitute expression"); - -# Add new tests HERE: - -# bug #74022: Loop on characters in \p{OtherIDContinue} -# This test hangs if it fails. -eval chr 0x387; # forces loading of utf8.pm -is(1,1, '[perl #74022] Parser looping on OtherIDContinue chars'); - -# More awkward tests for #line. Keep these at the end, as they will screw -# with sane line reporting for any other test failures - -sub check ($$$) { - my ($file, $line, $name) = @_; - my (undef, $got_file, $got_line) = caller; - like ($got_file, $file, "file of $name"); - is ($got_line, $line, "line of $name"); -} - -my $this_file = qr/parser\.t(?:\.[bl]eb?)?$/; -#line 3 -check($this_file, 3, "bare line"); - -# line 5 -check($this_file, 5, "bare line with leading space"); - -#line 7 -check($this_file, 7, "trailing space still valid"); - -# line 11 -check($this_file, 11, "leading and trailing"); - -# line 13 -check($this_file, 13, "leading tab"); - -#line 17 -check($this_file, 17, "middle tab"); - -#line 19 -check($this_file, 19, "loadsaspaces"); - -#line 23 KASHPRITZA -check(qr/^KASHPRITZA$/, 23, "bare filename"); - -#line 29 "KAHEEEE" -check(qr/^KAHEEEE$/, 29, "filename in quotes"); - -#line 31 "CLINK CLOINK BZZT" -check(qr/^CLINK CLOINK BZZT$/, 31, "filename with spaces in quotes"); - -#line 37 "THOOM THOOM" -check(qr/^THOOM THOOM$/, 37, "filename with tabs in quotes"); - -#line 41 "GLINK PLINK GLUNK DINK" -check(qr/^GLINK PLINK GLUNK DINK$/, 41, "a space after the quotes"); - -#line 43 "BBFRPRAFPGHPP -check(qr/^"BBFRPRAFPGHPP$/, 43, "actually missing a quote is still valid"); - -#line 47 bang eth -check(qr/^"BBFRPRAFPGHPP$/, 46, "but spaces aren't allowed without quotes"); - -#line 77sevenseven -check(qr/^"BBFRPRAFPGHPP$/, 49, "need a space after the line number"); - -eval <<'EOSTANZA'; die $@ if $@; -#line 51 "With wonderful deathless ditties|We build up the world's great cities,|And out of a fabulous story|We fashion an empire's glory:|One man with a dream, at pleasure,|Shall go forth and conquer a crown;|And three with a new song's measure|Can trample a kingdom down." -check(qr/^With.*down\.$/, 51, "Overflow the second small buffer check"); -EOSTANZA - -# And now, turn on the debugger flag for long names -$^P = 0x100; - -#line 53 "For we are afar with the dawning|And the suns that are not yet high,|And out of the infinite morning|Intrepid you hear us cry-|How, spite of your human scorning,|Once more God's future draws nigh,|And already goes forth the warning|That ye of the past must die." -check(qr/^For we.*must die\.$/, 53, "Our long line is set up"); - -eval <<'EOT'; die $@ if $@; -#line 59 " " -check(qr/^ $/, 59, "Overflow the first small buffer check only"); -EOT - -eval <<'EOSTANZA'; die $@ if $@; -#line 61 "Great hail! we cry to the comers|From the dazzling unknown shore;|Bring us hither your sun and your summers;|And renew our world as of yore;|You shall teach us your song's new numbers,|And things that we dreamed not before:|Yea, in spite of a dreamer who slumbers,|And a singer who sings no more." -check(qr/^Great hail!.*no more\.$/, 61, "Overflow both small buffer checks"); -EOSTANZA - -{ - my @x = 'string'; - is(eval q{ "$x[0]->strung" }, 'string->strung', - 'literal -> after an array subscript within ""'); - @x = ['string']; - # this used to give "string" - like("$x[0]-> [0]", qr/^ARRAY\([^)]*\)-> \[0]\z/, - 'literal -> [0] after an array subscript within ""'); -} - -__END__ -# Don't add new tests HERE. See note above diff --git a/t/CORE/comp/proto.t b/t/CORE/comp/proto.t deleted file mode 100644 index 69b3b8b59..000000000 --- a/t/CORE/comp/proto.t +++ /dev/null @@ -1,852 +0,0 @@ -#!./perl -# -# Contributed by Graham Barr -# -# So far there are tests for the following prototypes. -# none, () ($) ($@) ($%) ($;$) (&) (&\@) (&@) (%) (\%) (\@) -# -# It is impossible to test every prototype that can be specified, but -# we should test as many as we can. -# - -BEGIN { - unshift @INC, 't/CORE/lib'; -} - -# We need this, as in places we're testing the interaction of prototypes with -# strict -use strict; - -$| = 1; - -print "1..184\n"; - -my $i = 1; - -sub testing (&$) { - my $p = prototype(shift); - my $c = shift; - my $what = defined $c ? '(' . $p . ')' : 'no prototype'; - print '#' x 25,"\n"; - print '# Testing ',$what,"\n"; - print '#' x 25,"\n"; - print "not " - if((defined($p) && defined($c) && $p ne $c) - || (defined($p) != defined($c))); - printf "ok %d\n",$i++; -} - -@_ = qw(a b c d); -my @array; -my %hash; - -## -## -## - -testing \&no_proto, undef; - -sub no_proto { - print "# \@_ = (",join(",",@_),")\n"; - scalar(@_) -} - -print "not " unless 0 == no_proto(); -printf "ok %d\n",$i++; - -print "not " unless 1 == no_proto(5); -printf "ok %d\n",$i++; - -print "not " unless 4 == &no_proto; -printf "ok %d\n",$i++; - -print "not " unless 1 == no_proto +6; -printf "ok %d\n",$i++; - -print "not " unless 4 == no_proto(@_); -printf "ok %d\n",$i++; - -## -## -## - - -testing \&no_args, ''; - -sub no_args () { - print "# \@_ = (",join(",",@_),")\n"; - scalar(@_) -} - -print "not " unless 0 == no_args(); -printf "ok %d\n",$i++; - -print "not " unless 0 == no_args; -printf "ok %d\n",$i++; - -print "not " unless 5 == no_args +5; -printf "ok %d\n",$i++; - -print "not " unless 4 == &no_args; -printf "ok %d\n",$i++; - -print "not " unless 2 == &no_args(1,2); -printf "ok %d\n",$i++; - -eval "no_args(1)"; -print "not " unless $@; -printf "ok %d\n",$i++; - -## -## -## - -testing \&one_args, '$'; - -sub one_args ($) { - print "# \@_ = (",join(",",@_),")\n"; - scalar(@_) -} - -print "not " unless 1 == one_args(1); -printf "ok %d\n",$i++; - -print "not " unless 1 == one_args +5; -printf "ok %d\n",$i++; - -print "not " unless 4 == &one_args; -printf "ok %d\n",$i++; - -print "not " unless 2 == &one_args(1,2); -printf "ok %d\n",$i++; - -eval "one_args(1,2)"; -print "not " unless $@; -printf "ok %d\n",$i++; - -eval "one_args()"; -print "not " unless $@; -printf "ok %d\n",$i++; - -sub one_a_args ($) { - print "# \@_ = (",join(",",@_),")\n"; - print "not " unless @_ == 1 && $_[0] == 4; - printf "ok %d\n",$i++; -} - -one_a_args(@_); - -## -## -## - -testing \&over_one_args, '$@'; - -sub over_one_args ($@) { - print "# \@_ = (",join(",",@_),")\n"; - scalar(@_) -} - -print "not " unless 1 == over_one_args(1); -printf "ok %d\n",$i++; - -print "not " unless 2 == over_one_args(1,2); -printf "ok %d\n",$i++; - -print "not " unless 1 == over_one_args +5; -printf "ok %d\n",$i++; - -print "not " unless 4 == &over_one_args; -printf "ok %d\n",$i++; - -print "not " unless 2 == &over_one_args(1,2); -printf "ok %d\n",$i++; - -print "not " unless 5 == &over_one_args(1,@_); -printf "ok %d\n",$i++; - -eval "over_one_args()"; -print "not " unless $@; -printf "ok %d\n",$i++; - -sub over_one_a_args ($@) { - print "# \@_ = (",join(",",@_),")\n"; - print "not " unless @_ >= 1 && $_[0] == 4; - printf "ok %d\n",$i++; -} - -over_one_a_args(@_); -over_one_a_args(@_,1); -over_one_a_args(@_,1,2); -over_one_a_args(@_,@_); - -## -## -## - -testing \&scalar_and_hash, '$%'; - -sub scalar_and_hash ($%) { - print "# \@_ = (",join(",",@_),")\n"; - scalar(@_) -} - -print "not " unless 1 == scalar_and_hash(1); -printf "ok %d\n",$i++; - -print "not " unless 3 == scalar_and_hash(1,2,3); -printf "ok %d\n",$i++; - -print "not " unless 1 == scalar_and_hash +5; -printf "ok %d\n",$i++; - -print "not " unless 4 == &scalar_and_hash; -printf "ok %d\n",$i++; - -print "not " unless 2 == &scalar_and_hash(1,2); -printf "ok %d\n",$i++; - -print "not " unless 5 == &scalar_and_hash(1,@_); -printf "ok %d\n",$i++; - -eval "scalar_and_hash()"; -print "not " unless $@; -printf "ok %d\n",$i++; - -sub scalar_and_hash_a ($@) { - print "# \@_ = (",join(",",@_),")\n"; - print "not " unless @_ >= 1 && $_[0] == 4; - printf "ok %d\n",$i++; -} - -scalar_and_hash_a(@_); -scalar_and_hash_a(@_,1); -scalar_and_hash_a(@_,1,2); -scalar_and_hash_a(@_,@_); - -## -## -## - -testing \&one_or_two, '$;$'; - -sub one_or_two ($;$) { - print "# \@_ = (",join(",",@_),")\n"; - scalar(@_) -} - -print "not " unless 1 == one_or_two(1); -printf "ok %d\n",$i++; - -print "not " unless 2 == one_or_two(1,3); -printf "ok %d\n",$i++; - -print "not " unless 1 == one_or_two +5; -printf "ok %d\n",$i++; - -print "not " unless 4 == &one_or_two; -printf "ok %d\n",$i++; - -print "not " unless 3 == &one_or_two(1,2,3); -printf "ok %d\n",$i++; - -print "not " unless 5 == &one_or_two(1,@_); -printf "ok %d\n",$i++; - -eval "one_or_two()"; -print "not " unless $@; -printf "ok %d\n",$i++; - -eval "one_or_two(1,2,3)"; -print "not " unless $@; -printf "ok %d\n",$i++; - -sub one_or_two_a ($;$) { - print "# \@_ = (",join(",",@_),")\n"; - print "not " unless @_ >= 1 && $_[0] == 4; - printf "ok %d\n",$i++; -} - -one_or_two_a(@_); -one_or_two_a(@_,1); -one_or_two_a(@_,@_); - -## -## -## - -testing \&a_sub, '&'; - -sub a_sub (&) { - print "# \@_ = (",join(",",@_),")\n"; - &{$_[0]}; -} - -sub tmp_sub_1 { printf "ok %d\n",$i++ } - -a_sub { printf "ok %d\n",$i++ }; -a_sub \&tmp_sub_1; - -@array = ( \&tmp_sub_1 ); -eval 'a_sub @array'; -print "not " unless $@; -printf "ok %d\n",$i++; - -## -## -## - -testing \&a_subx, '\&'; - -sub a_subx (\&) { - print "# \@_ = (",join(",",@_),")\n"; - &{$_[0]}; -} - -sub tmp_sub_2 { printf "ok %d\n",$i++ } -a_subx &tmp_sub_2; - -@array = ( \&tmp_sub_2 ); -eval 'a_subx @array'; -print "not " unless $@; -printf "ok %d\n",$i++; - -## -## -## - -testing \&sub_aref, '&\@'; - -sub sub_aref (&\@) { - print "# \@_ = (",join(",",@_),")\n"; - my($sub,$array) = @_; - print "not " unless @_ == 2 && @{$array} == 4; - print map { &{$sub}($_) } @{$array} -} - -@array = (qw(O K)," ", $i++); -sub_aref { lc shift } @array; -print "\n"; - -## -## -## - -testing \&sub_array, '&@'; - -sub sub_array (&@) { - print "# \@_ = (",join(",",@_),")\n"; - print "not " unless @_ == 5; - my $sub = shift; - print map { &{$sub}($_) } @_ -} - -@array = (qw(O K)," ", $i++); -sub_array { lc shift } @array; -if ($] >= 5.008) { - eval q(sub_array { lc shift } ('O', 'K', ' ', $i++);); -} else { - print "ok ",$i++," # SKIP 5.6 & proto"; -} -print "\n"; - -## -## -## - -testing \&a_hash, '%'; - -sub a_hash (%) { - print "# \@_ = (",join(",",@_),")\n"; - scalar(@_); -} - -print "not " unless 1 == a_hash 'a'; -printf "ok %d\n",$i++; - -print "not " unless 2 == a_hash 'a','b'; -printf "ok %d\n",$i++; - -## -## -## - -testing \&a_hash_ref, '\%'; - -sub a_hash_ref (\%) { - print "# \@_ = (",join(",",@_),")\n"; - print "not " unless ref($_[0]) && $_[0]->{'a'}; - printf "ok %d\n",$i++; - $_[0]->{'b'} = 2; -} - -%hash = ( a => 1); -a_hash_ref %hash; -print "not " unless $hash{'b'} == 2; -printf "ok %d\n",$i++; - -## -## -## - -testing \&array_ref_plus, '\@@'; - -sub array_ref_plus (\@@) { - print "# \@_ = (",join(",",@_),")\n"; - print "not " unless @_ == 2 && ref($_[0]) && 1 == @{$_[0]} && $_[1] eq 'x'; - printf "ok %d\n",$i++; - @{$_[0]} = (qw(ok)," ",$i++,"\n"); -} - -@array = ('a'); -{ my @more = ('x'); - array_ref_plus @array, @more; } -print "not " unless @array == 4; -print @array; - -my $p; -print "not " if defined prototype('CORE::print'); -print "ok ", $i++, "\n"; - -print "not " if defined prototype('CORE::system'); -print "ok ", $i++, "\n"; - -print "# CORE::open => ($p)\nnot " if ($p = prototype('CORE::open')) ne '*;$@'; -print "ok ", $i++, "\n"; - -print "# CORE:Foo => ($p), \$@ => `$@'\nnot " - if defined ($p = eval { prototype('CORE::Foo') or 1 }) or $@ !~ /^Can't find an opnumber/; -print "ok ", $i++, "\n"; - -# correctly note too-short parameter lists that don't end with '$', -# a possible regression. - - -sub foo1 ($\@); -eval q{ foo1 "s" }; -print "not " unless $@ =~ /^Not enough/; -print "ok ", $i++, " # Fixed perlcc #246 with B::C 1.43_06\n"; - -sub foo2 ($\%); -eval q{ foo2 "s" }; -print "not " unless $@ =~ /^Not enough/; -print "ok ", $i++, " # Fixed perlcc #246 with B::C 1.43_06\n"; - -sub X::foo3; -*X::foo3 = sub {'ok'}; -print "# $@not " unless eval {X->foo3} eq 'ok'; -print "ok ", $i++, "\n"; - -sub X::foo4 ($); -*X::foo4 = sub ($) {'ok'}; -print "not " unless X->foo4 eq 'ok'; -print "ok ", $i++, "\n"; - -# test if the (*) prototype allows barewords, constants, scalar expressions, -# globs and globrefs (just as CORE::open() does), all under stricture -sub star (*&) { &{$_[1]} } -sub star2 (**&) { &{$_[2]} } -sub BAR { "quux" } -sub Bar::BAZ { "quuz" } -my $star = 'FOO'; -star FOO, sub { - print "not " unless $_[0] eq 'FOO'; - print "ok $i - star FOO\n"; -}; $i++; -star(FOO, sub { - print "not " unless $_[0] eq 'FOO'; - print "ok $i - star(FOO)\n"; - }); $i++; -star "FOO", sub { - print "not " unless $_[0] eq 'FOO'; - print qq/ok $i - star "FOO"\n/; -}; $i++; -star("FOO", sub { - print "not " unless $_[0] eq 'FOO'; - print qq/ok $i - star("FOO")\n/; - }); $i++; -star $star, sub { - print "not " unless $_[0] eq 'FOO'; - print "ok $i - star \$star\n"; -}; $i++; -star($star, sub { - print "not " unless $_[0] eq 'FOO'; - print "ok $i - star(\$star)\n"; - }); $i++; -star *FOO, sub { - print "not " unless $_[0] eq \*FOO; - print "ok $i - star *FOO\n"; -}; $i++; -star(*FOO, sub { - print "not " unless $_[0] eq \*FOO; - print "ok $i - star(*FOO)\n"; - }); $i++; -star \*FOO, sub { - print "not " unless $_[0] eq \*FOO; - print "ok $i - star \\*FOO\n"; -}; $i++; -star(\*FOO, sub { - print "not " unless $_[0] eq \*FOO; - print "ok $i - star(\\*FOO)\n"; - }); $i++; -star2 FOO, BAR, sub { - my $p1 = $] < 5.022 ? 'BAR' : 'quux'; - print "not " unless $_[0] eq 'FOO' and $_[1] eq $p1; - print "ok $i - star2 FOO, BAR\n"; -}; $i++; # 5.22 core change -star2(Bar::BAZ, FOO, sub { - my $p0 = $] < 5.022 ? 'Bar::BAZ' : 'quuz'; - print "not " unless $_[0] eq $p0 and $_[1] eq 'FOO'; - print "ok $i - star2(Bar::BAZ, FOO)\n" -}); $i++; # 5.22 core change -star2 BAR(), FOO, sub { - print "not " unless $_[0] eq 'quux' and $_[1] eq 'FOO'; - print "ok $i - star2 BAR(), FOO\n" -}; $i++; -star2(FOO, BAR(), sub { - print "not " unless $_[0] eq 'FOO' and $_[1] eq 'quux'; - print "ok $i - star2(FOO, BAR())\n"; - }); $i++; -star2 "FOO", "BAR", sub { - print "not " unless $_[0] eq 'FOO' and $_[1] eq 'BAR'; - print qq/ok $i - star2 "FOO", "BAR"\n/; -}; $i++; -star2("FOO", "BAR", sub { - print "not " unless $_[0] eq 'FOO' and $_[1] eq 'BAR'; - print qq/ok $i - star2("FOO", "BAR")\n/; - }); $i++; -star2 $star, $star, sub { - print "not " unless $_[0] eq 'FOO' and $_[1] eq 'FOO'; - print "ok $i - star2 \$star, \$star\n"; -}; $i++; -star2($star, $star, sub { - print "not " unless $_[0] eq 'FOO' and $_[1] eq 'FOO'; - print "ok $i - star2(\$star, \$star)\n"; - }); $i++; -star2 *FOO, *BAR, sub { - print "not " unless $_[0] eq \*FOO and $_[1] eq \*BAR; - print "ok $i - star2 *FOO, *BAR\n"; -}; $i++; -star2(*FOO, *BAR, sub { - print "not " unless $_[0] eq \*FOO and $_[1] eq \*BAR; - print "ok $i - star2(*FOO, *BAR)\n"; - }); $i++; -star2 \*FOO, \*BAR, sub { - no strict 'refs'; - print "not " unless $_[0] eq \*{'FOO'} and $_[1] eq \*{'BAR'}; - print "ok $i - star2 \*FOO, \*BAR\n"; -}; $i++; -star2(\*FOO, \*BAR, sub { - no strict 'refs'; - print "not " unless $_[0] eq \*{'FOO'} and $_[1] eq \*{'BAR'}; - print "ok $i - star2(\*FOO, \*BAR)\n"; - }); $i++; - -# test scalarref prototype -sub sreftest (\$$) { - print "not " unless ref $_[0]; - print "ok $_[1] - sreftest\n"; -} -{ - no strict 'vars'; - sreftest my $sref, $i++; - sreftest($helem{$i}, $i++); - sreftest $aelem[0], $i++; -} - -# test single term -BEGIN { - my $plusproto = <<'EOF'; -sub lazy (+$$) { - print "not " unless @_ == 3 && ref $_[0] eq $_[1]; - print "ok $_[2] - non container test\n"; -} -sub quietlazy (+) { return shift(@_) } -EOF - $plusproto =~ s/ \(\+/ \(\$/gm if $] < 5.014; - eval $plusproto; -} -sub give_aref { [] } -sub list_or_scalar { wantarray ? (1..10) : [] } -{ - my @multiarray = ("a".."z"); - my %bighash = @multiarray; - lazy(\@multiarray, 'ARRAY', $i++); - lazy(\%bighash, 'HASH', $i++); - lazy({}, 'HASH', $i++); - lazy(give_aref, 'ARRAY', $i++); - lazy(3, '', $i++); # allowed by prototype, even if runtime error - lazy(list_or_scalar, 'ARRAY', $i++); # propagate scalar context -} - -# test prototypes when they are evaled and there is a syntax error -# Byacc generates the string "syntax error". Bison gives the -# string "parse error". -# -for my $p ( "", qw{ () ($) ($@) ($%) ($;$) (&) (&\@) (&@) (%) (\%) (\@) } ) { - my $warn = ""; - local $SIG{__WARN__} = sub { - my $thiswarn = join("",@_); - return if $thiswarn =~ /^Prototype mismatch: sub main::evaled_subroutine/; - $warn .= $thiswarn; - }; - my $eval = "sub evaled_subroutine $p { &void *; }"; - eval $eval; - print "# eval[$eval]\nnot " unless $@ && $@ =~ /(parse|syntax) error/i; - print "ok ", $i++, "\n"; - if ($warn eq '') { - print "ok ", $i++, "\n"; - } else { - print "not ok ", $i++, "# $warn \n"; - } -} - -# Not $$;$;$ -print "not " unless prototype "CORE::substr" eq '$$;$$'; -print "ok ", $i++, "\n"; - -# recv takes a scalar reference for its second argument -print "not " unless prototype "CORE::recv" eq '*\\$$$'; -print "ok ", $i++, "\n"; - -{ - my $myvar; - my @myarray; - my %myhash; - sub mysub { print "not calling mysub I hope\n" } - local *myglob; - - BEGIN { - if ($] >= 5.008) { - eval q(sub myref (\[$@%&*]) { print "# $_[0]\n"; return "$_[0]" }); - } else { - eval q(sub myref ($@%&*) { print "# $_[0]\n"; return "$_[0]" }); - } - } - - print "not " unless myref($myvar) =~ /^SCALAR\(/; - print "ok ", $i++, "\n"; - print "not " unless myref(@myarray) =~ /^ARRAY\(/; - print "ok ", $i++, "\n"; - print "not " unless myref(%myhash) =~ /^HASH\(/; - print "ok ", $i++, "\n"; - print "not " unless myref(&mysub) =~ /^CODE\(/; - print "ok ", $i++, "\n"; - print "not " unless myref(*myglob) =~ /^GLOB\(/; - print "ok ", $i++, "\n"; - - eval q/sub multi1 (\[%@]) { 1 } multi1 $myvar;/; - print "not " - unless $@ =~ /Type of arg 1 to main::multi1 must be one of \[%\@\] /; - print "ok ", $i++, "\n"; - eval q/sub multi2 (\[$*&]) { 1 } multi2 @myarray;/; - print "not " - unless $@ =~ /Type of arg 1 to main::multi2 must be one of \[\$\*&\] /; - print "ok ", $i++, "\n"; - eval q/sub multi3 (\[$@]) { 1 } multi3 %myhash;/; - print "not " - unless $@ =~ /Type of arg 1 to main::multi3 must be one of \[\$\@\] /; - print "ok ", $i++, "\n"; - eval q/sub multi4 ($\[%]) { 1 } multi4 1, &mysub;/; - print "not " - unless $@ =~ /Type of arg 2 to main::multi4 must be one of \[%\] /; - print "ok ", $i++, "\n"; - eval q/sub multi5 (\[$@]$) { 1 } multi5 *myglob;/; - print "not " - unless $@ =~ /Type of arg 1 to main::multi5 must be one of \[\$\@\] / - && $@ =~ /Not enough arguments/; - print "ok ", $i++, "\n"; -} - -# check that obviously bad prototypes are getting warnings -{ - local $^W = 1; - my $warn = ""; - local $SIG{__WARN__} = sub { $warn .= join("",@_) }; - - eval 'sub badproto (@bar) { 1; }'; - print "not " unless $warn =~ /Illegal character in prototype for main::badproto : \@bar/; - print "ok ", $i++, " checking badproto - (\@bar)\n"; - - $warn = ''; - eval 'sub badproto2 (bar) { 1; }'; - print "not " unless $warn =~ /Illegal character in prototype for main::badproto2 : bar/; - print "ok ", $i++, " checking badproto2 - (bar)\n"; - - $warn = ''; - eval 'sub badproto3 (&$bar$@) { 1; }'; - print "not " unless $warn =~ /Illegal character in prototype for main::badproto3 : &\$bar\$\@/; - print "ok ", $i++, " checking badproto3 - (&\$bar\$\@)\n"; - - $warn = ''; - eval 'sub badproto4 (@ $b ar) { 1; }'; - # This one emits two warnings - # The formatting of the error changed in 5.20 - my $berr = $] < 5.020 ? '\@\$bar' : '\@ \$b ar'; - print "not " unless $warn =~ /Illegal character in prototype for main::badproto4 : $berr/; - print "ok ", $i++, " checking badproto4 - ($berr) - illegal character\n"; - if ($] >= 5.012) { - print "not " unless $warn =~ /Prototype after '\@' for main::badproto4 : $berr/; - print "ok ", $i++, " checking badproto4 - ($berr) - prototype after '\@'\n"; - } else { - print "ok ", $i++, " SKIP only one warning <5.12\n"; - } - #print '# '.$warn if $warn; - - $warn = ''; - eval 'sub badproto5 ($_$) { 1; }'; - print "not " unless $warn =~ /Illegal character after '_' in prototype for main::badproto5 : \$_\$/; - print "ok ", $i++, " checking badproto5 - (\$_\$) - illegal character after '_'\n"; - print "not " if $warn =~ /Illegal character in prototype for main::badproto5 : \$_\$/; - print "ok ", $i++, " checking badproto5 - (\$_\$) - but not just illegal character\n"; - - $warn = ''; - eval 'sub badproto6 (bar_) { 1; }'; - my $newwarn = qr/Illegal character in prototype for main::badproto6 : bar_/; - my $oldwarn = qr/Illegal character after '_' in prototype for main::badproto6 : bar_/; - if ($] >= 5.020) { - print "not " unless $warn =~ $newwarn; - print "ok ", $i++, " checking badproto6 - (bar_) - new warning\n"; - print "not " if $warn =~ $oldwarn; - print "ok ", $i++, " checking badproto6 - (bar_) - not old warning\n"; - } else { - print "not " if $warn =~ $newwarn; - print "ok ", $i++, " checking badproto6 - (bar_) - not new warning\n"; - print "not " unless $warn =~ $oldwarn; - print "ok ", $i++, " checking badproto6 - (bar_) - old warning\n"; - } - #print '# '.$warn if $warn; - - $warn = ''; - eval 'sub badproto7 (_;bar) { 1; }'; - $newwarn = qr/Illegal character in prototype for main::badproto7 : _;bar/; - $oldwarn = qr/Illegal character after '_' in prototype for main::badproto7 : _;bar/; - if ($] >= 5.020) { - print "not " unless $warn =~ $newwarn; - print "ok ", $i++, " checking badproto7 - (_;bar) - new warning\n"; - print "not " if $warn =~ $oldwarn; - print "ok ", $i++, " checking badproto7 - (_;bar) - not old warning\n"; - } else { - print "not " if $warn =~ $newwarn; - print "ok ", $i++, " checking badproto7 - (_;bar) - not new warning\n"; - print "not " unless $warn =~ $oldwarn; - print "ok ", $i++, " checking badproto7 - (_;bar) - old warning\n"; - } - #print '# '.$warn if $warn; - - $warn = ''; - eval 'sub badproto8 (_b) { 1; }'; - $newwarn = qr/Illegal character in prototype for main::badproto8 : _b/; - $oldwarn = qr/Illegal character after '_' in prototype for main::badproto8 : _b/; - if ($] >= 5.020) { - # This one emits both warnings, new and old - print "not " unless $warn =~ $newwarn; - print "ok ", $i++, " checking badproto8 - (_b) - new warning\n"; - print "not " unless $warn =~ $oldwarn; - print "ok ", $i++, " checking badproto8 - (_b) - not old warning\n"; - } else { - print "not " if $warn =~ $newwarn; - print "ok ", $i++, " checking badproto8 - (_b) - not new warning\n"; - print "not " unless $warn =~ $oldwarn; - print "ok ", $i++, " checking badproto8 - (_b) - old warning\n"; - } - #print '# '.$warn if $warn; - - $warn = ''; - eval 'sub badproto9 ([) { 1; }'; - if ($] < 5.020) { - print "not " if $warn; - print "ok ", $i++, " # SKIP matching bracket warning since 5.20\n"; - } else { - print "not " unless $warn =~ /Missing '\]' in prototype for main::badproto9 : \[/; - print "ok ", $i++, " checking for matching bracket\n"; - } - - # fails <5.12 - $warn = ''; - eval 'sub badproto10 ([_]) { 1; }'; - print "not " if $warn =~ /Missing '\]' in prototype for main::badproto10 : \[/; - print "ok ", $i++, " checking badproto10 - ([_]) - shouldn't trigger matching bracket\n"; - print "not " unless $warn =~ /Illegal character after '_' in prototype for main::badproto10 : \[_\]/; - print "ok ", $i++, " checking badproto10 - ([_]) - should trigger after '_' warnings\n"; -} - -# make sure whitespace in prototypes works -eval "sub good (\$\t\$\n\$) { 1; }"; -print "not " if $@; -print "ok ", $i++, " # (\$\t\$\n\$)\n"; - -# Ought to fail, doesn't in 5.8.1. -eval 'sub bug (\[%@]) { } my $array = [0 .. 1]; bug %$array;'; -print "not " unless $@ =~ /Not a HASH reference/; -print "ok ", $i++, ' # (\[%@]) fails <5.10',"\n"; - -# [perl #75904] -# Test that the following prototypes make subs parse as unary functions: -# * \sigil \[...] ;$ ;* ;\sigil ;\[...] -sub eval_ok { - my ( $code ) = @_; - - print "not " - unless eval ''.$code or warn $@; - print "ok ", $i++, " # ".$code."\n"; -} - -my @tests = ( - 'sub uniproto1 (*) {} uniproto1 $_, 1', - 'sub uniproto2 (\$) {} uniproto2 $_, 1', - 'sub uniproto3 (\[$%]) {} uniproto3 %_, 1', - 'sub uniproto4 (;$) {} uniproto4 $_, 1', - 'sub uniproto5 (;*) {} uniproto5 $_, 1', - 'sub uniproto6 (;\@) {} uniproto6 @_, 1', - 'sub uniproto7 (;\[$%@]) {} uniproto7 @_, 1', - 'sub uniproto8 (+) {} uniproto8 $_, 1', - 'sub uniproto9 (;+) {} uniproto9 $_, 1', -); - -foreach my $t ( @tests ) { - eval_ok($t); -} - -{ - # Lack of prototype on a subroutine definition should override any prototype - # on the declaration. - sub z_zwap (&); - - my $thiswarn; - local $SIG{__WARN__} = sub { - $thiswarn = join "", @_; - }; - - # https://code.google.com/p/perl-compiler/issues/detail?id=279 - eval q{sub z_zwap {return @_}}; - - # fix a bad plan when the warning is not raised - if ($thiswarn =~ /^Prototype mismatch: sub main::z_zwap/) { - print 'ok ', $i++, " # Prototype mismatch\n"; - } else { - print 'not ok ', $i++, " # $thiswarn\n"; - } - - if ($@) { - print "not ok ", $i++, "# $@"; - } else { - print "ok ", $i++, " # sub z_zwap \n"; - } - - - my @a = (6,4,2); - my @got = eval q{z_zwap(@a)}; - - if ($@) { - print "not ok ", $i++, " # $@"; - } else { - print "ok ", $i++, " # z_zwap\n"; - } - - if ("@got" eq "@a") { - print "ok ", $i++, " # >@got\n"; - } else { - print "not ok ", $i++, " # >@got<\n"; - } -} diff --git a/t/CORE/comp/redef.t b/t/CORE/comp/redef.t deleted file mode 100644 index 63be16c2f..000000000 --- a/t/CORE/comp/redef.t +++ /dev/null @@ -1,86 +0,0 @@ -#!./perl -w -# -# Contributed by Graham Barr - -BEGIN { - $warn = ""; - $SIG{__WARN__} = sub { $warn .= join("",@_) } -} - -sub ok ($$) { - print $_[1] ? "ok " : "not ok ", $_[0], "\n"; -} - -print "1..20\n"; - -my $NEWPROTO = 'Prototype mismatch:'; - -sub sub0 { 1 } -sub sub0 { 2 } - -ok 1, $warn =~ s/Subroutine sub0 redefined[^\n]+\n//s; - -sub sub1 { 1 } -sub sub1 () { 2 } - -ok 2, $warn =~ s/$NEWPROTO \Qsub main::sub1: none vs ()\E[^\n]+\n//s; -ok 3, $warn =~ s/Subroutine sub1 redefined[^\n]+\n//s; - -sub sub2 { 1 } -sub sub2 ($) { 2 } - -ok 4, $warn =~ s/$NEWPROTO \Qsub main::sub2: none vs ($)\E[^\n]+\n//s; -ok 5, $warn =~ s/Subroutine sub2 redefined[^\n]+\n//s; - -sub sub3 () { 1 } -sub sub3 { 2 } - -ok 6, $warn =~ s/$NEWPROTO \Qsub main::sub3 () vs none\E[^\n]+\n//s; -ok 7, $warn =~ s/Constant subroutine sub3 redefined[^\n]+\n//s; - -sub sub4 () { 1 } -sub sub4 () { 2 } - -ok 8, $warn =~ s/Constant subroutine sub4 redefined[^\n]+\n//s; - -sub sub5 () { 1 } -sub sub5 ($) { 2 } - -ok 9, $warn =~ s/$NEWPROTO \Qsub main::sub5 () vs ($)\E[^\n]+\n//s; -ok 10, $warn =~ s/Constant subroutine sub5 redefined[^\n]+\n//s; - -sub sub6 ($) { 1 } -sub sub6 { 2 } - -ok 11, $warn =~ s/$NEWPROTO \Qsub main::sub6 ($) vs none\E[^\n]+\n//s; -ok 12, $warn =~ s/Subroutine sub6 redefined[^\n]+\n//s; - -sub sub7 ($) { 1 } -sub sub7 () { 2 } - -ok 13, $warn =~ s/$NEWPROTO \Qsub main::sub7 ($) vs ()\E[^\n]+\n//s; -ok 14, $warn =~ s/Subroutine sub7 redefined[^\n]+\n//s; - -sub sub8 ($) { 1 } -sub sub8 ($) { 2 } - -ok 15, $warn =~ s/Subroutine sub8 redefined[^\n]+\n//s; - -sub sub9 ($@) { 1 } -sub sub9 ($) { 2 } - -ok 16, $warn =~ s/$NEWPROTO sub main::sub9 \(\$\Q@) vs ($)\E[^\n]+\n//s; -ok 17, $warn =~ s/Subroutine sub9 redefined[^\n]+\n//s; - -BEGIN { - local $^W = 0; - eval qq(sub sub10 () {1} sub sub10 {1}); -} - -ok 18, $warn =~ s/$NEWPROTO \Qsub main::sub10 () vs none\E[^\n]+\n//s; -ok 19, $warn =~ s/Constant subroutine sub10 redefined[^\n]+\n//s; - -ok 20, $warn eq ''; - -# If we got any errors that we were not expecting, then print them -print $warn if length $warn; diff --git a/t/CORE/comp/require.t b/t/CORE/comp/require.t deleted file mode 100644 index 6eb823c9e..000000000 --- a/t/CORE/comp/require.t +++ /dev/null @@ -1,312 +0,0 @@ -#!./perl - -BEGIN { - unshift @INC, ''; - push @INC, '../lib'; -} - -sub do_require { - %INC = (); - write_file('bleah.pm',@_); - eval { require "bleah.pm" }; - my @a; # magic guard for scope violations (must be first lexical in file) -} - -# don't make this lexical -$i = 1; - -my @fjles_to_delete = qw (bleah.pm bleah.do bleah.flg urkkk.pm urkkk.pmc -krunch.pm krunch.pmc whap.pm whap.pmc); - - -my $Is_EBCDIC = (ord('A') == 193) ? 1 : 0; -my $Is_UTF8 = (${^OPEN} || "") =~ /:utf8/; -my $total_tests = 51; -if ($Is_EBCDIC || $Is_UTF8) { $total_tests -= 3; } -print "1..$total_tests\n"; - -sub write_file { - my $f = shift; - open(REQ,">$f") or die "Can't write '$f': $!"; - binmode REQ; - print REQ @_; - close REQ or die "Could not close $f: $!"; -} - -eval {require 5.005}; -print "# $@\nnot " if $@; -print "ok ",$i++,"\n"; - -eval { require 5.005 }; -print "# $@\nnot " if $@; -print "ok ",$i++,"\n"; - -eval { require 5.005; }; -print "# $@\nnot " if $@; -print "ok ",$i++,"\n"; - -eval { - require 5.005 -}; -print "# $@\nnot " if $@; -print "ok ",$i++,"\n"; - -# new style version numbers - -eval { require v5.5.630; }; -print "# $@\nnot " if $@; -print "ok ",$i++,"\n"; - -eval { require 10.0.2; }; -print "# $@\nnot " unless $@ =~ /^Perl v10\.0\.2 required/; -print "ok ",$i++,"\n"; - -my $ver = 5.005_63; -eval { require $ver; }; -print "# $@\nnot " if $@; -print "ok ",$i++,"\n"; - -# check inaccurate fp -$ver = 10.2; -eval { require $ver; }; -print "# $@\nnot " unless $@ =~ /^Perl v10\.200.0 required/; -print "ok ",$i++,"\n"; - -$ver = 10.000_02; -eval { require $ver; }; -print "# $@\nnot " unless $@ =~ /^Perl v10\.0\.20 required/; -print "ok ",$i++,"\n"; - -print "not " unless 5.5.1 gt v5.5; -print "ok ",$i++,"\n"; - -{ - print "not " unless v5.5.640 eq "\x{5}\x{5}\x{280}"; - print "ok ",$i++,"\n"; - - print "not " unless v7.15 eq "\x{7}\x{f}"; - print "ok ",$i++,"\n"; - - print "not " - unless v1.20.300.4000.50000.600000 eq "\x{1}\x{14}\x{12c}\x{fa0}\x{c350}\x{927c0}"; - print "ok ",$i++,"\n"; -} - -# "use 5.11.0" (and higher) loads strictures. -# check that this doesn't happen with require -eval 'require 5.11.0; ${"foo"} = "bar";'; -print "# $@\nnot " if $@; -print "ok ",$i++,"\n"; -eval 'BEGIN {require 5.11.0} ${"foo"} = "bar";'; -print "# $@\nnot " if $@; -print "ok ",$i++,"\n"; - -# interaction with pod (see the eof) -write_file('bleah.pm', "print 'ok $i\n'; 1;\n"); -require "bleah.pm"; -$i++; - -# run-time failure in require -do_require "0;\n"; -print "# $@\nnot " unless $@ =~ /did not return a true/; -print "ok ",$i++,"\n"; - -print "not " if exists $INC{'bleah.pm'}; -print "ok ",$i++,"\n"; - -my $flag_file = 'bleah.flg'; -# run-time error in require -for my $expected_compile (1,0) { - write_file($flag_file, 1); - print "not " unless -e $flag_file; - print "ok ",$i++,"\n"; - write_file('bleah.pm', "unlink '$flag_file' or die; \$a=0; \$b=1/\$a; 1;\n"); - print "# $@\nnot " if eval { require 'bleah.pm' }; - print "ok ",$i++,"\n"; - print "not " unless -e $flag_file xor $expected_compile; - print "ok ",$i++,"\n"; - print "not " unless exists $INC{'bleah.pm'}; - print "ok ",$i++,"\n"; -} - -# compile-time failure in require -do_require "1)\n"; -# bison says 'parse error' instead of 'syntax error', -# various yaccs may or may not capitalize 'syntax'. -print "# $@\nnot " unless $@ =~ /(syntax|parse) error/mi; -print "ok ",$i++,"\n"; - -# previous failure cached in %INC -print "not " unless exists $INC{'bleah.pm'}; -print "ok ",$i++,"\n"; -write_file($flag_file, 1); -write_file('bleah.pm', "unlink '$flag_file'; 1"); -print "# $@\nnot " if eval { require 'bleah.pm' }; -print "ok ",$i++,"\n"; -print "# $@\nnot " unless $@ =~ /Compilation failed/i; -print "ok ",$i++,"\n"; -print "not " unless -e $flag_file; -print "ok ",$i++,"\n"; -print "not " unless exists $INC{'bleah.pm'}; -print "ok ",$i++,"\n"; - -# successful require -do_require "1"; -print "# $@\nnot " if $@; -print "ok ",$i++,"\n"; - -# do FILE shouldn't see any outside lexicals -my $x = "ok $i\n"; -write_file("bleah.do", < 'C0U', - 'UTF-16BE' => 'n', - 'UTF-16LE' => 'v', - ); - -sub bytes_to_utf { - my ($enc, $content, $do_bom) = @_; - my $template = $templates{$enc}; - die "Unsupported encoding $enc" unless $template; - return pack "$template*", ($do_bom ? 0xFEFF : ()), unpack "C*", $content; -} - -foreach (sort keys %templates) { - $i++; do_require(bytes_to_utf($_, qq(print "ok $i # $_\\n"; 1;\n), 1)); - if ($@ =~ /^(Unsupported script encoding \Q$_\E)/) { - print "ok $i # skip $1\n"; - } -} - -END { - foreach my $file (@fjles_to_delete) { - 1 while unlink $file; - } -} - -# ***interaction with pod (don't put any thing after here)*** - -=pod diff --git a/t/CORE/comp/retainedlines.t b/t/CORE/comp/retainedlines.t deleted file mode 100644 index f09cc881b..000000000 --- a/t/CORE/comp/retainedlines.t +++ /dev/null @@ -1,161 +0,0 @@ -#!./perl -w - -# Check that lines from eval are correctly retained by the debugger - -# Uncomment this for testing, but don't leave it in for "production", as -# we've not yet verified that use works. -# use strict; - -print "1..73\n"; -my $test = 0; - -sub failed { - my ($got, $expected, $name) = @_; - - print "not ok $test - $name\n"; - my @caller = caller(1); - print "# Failed test at $caller[1] line $caller[2]\n"; - if (defined $got) { - print "# Got '$got'\n"; - } else { - print "# Got undef\n"; - } - print "# Expected $expected\n"; - return; -} - -sub is ($$$) { - my ($got, $expect, $name) = @_; - $test = $test + 1; - if (defined $expect) { - if (defined $got && $got eq $expect) { - print "ok $test - $name\n"; - return 1; - } - failed($got, "'$expect'", $name); - } else { - if (!defined $got) { - print "ok $test - $name\n"; - return 1; - } - failed($got, 'undef', $name); - } -} - -$^P = 0xA; - -# perlcc issue 209 - https://code.google.com/p/perl-compiler/issues/detail?id=209 -my @before = grep { /eval/ } keys %::; - -is ((scalar @before), 0, "No evals"); - -my %seen; - -sub check_retained_lines { - my ($prog, $name) = @_; - # Is there a more efficient way to write this? - my @expect_lines = (undef, map ({"$_\n"} split "\n", $prog), "\n", ';'); - - my @keys = grep {!$seen{$_}} grep { /eval/ } keys %::; - - is ((scalar @keys), 1, "1 new eval"); - - my @got_lines = @{$::{$keys[0]}}; - - is ((scalar @got_lines), - (scalar @expect_lines), "Right number of lines for $name"); - - for (0..$#expect_lines) { - is ($got_lines[$_], $expect_lines[$_], "Line $_ is correct"); - } - $seen{$keys[0]}++; -} - -my $name = 'foo'; - -for my $sep (' ', "\0") { - - my $prog = "sub $name { - 'Perl${sep}Rules' -}; -1; -"; - - eval $prog or die; - check_retained_lines($prog, ord $sep); - $name++; -} - -{ - # This contains a syntax error - my $prog = "sub $name { - 'This is $name' - } -1 + -"; - - eval $prog and die; - - is (eval "$name()", "This is $name", "Subroutine was compiled, despite error") - or print STDERR "# $@\n"; - - check_retained_lines($prog, - 'eval that defines subroutine but has syntax error'); - $name++; -} - -foreach my $flags (0x0, 0x800, 0x1000, 0x1800) { - local $^P = $^P | $flags; - # This is easier if we accept that the guts eval will add a trailing \n - # for us - my $prog = "1 + 1 + 1\n"; - my $fail = "1 + \n"; - - is (eval $prog, 3, 'String eval works'); - if ($flags & 0x800) { - check_retained_lines($prog, sprintf "%#X", $^P); - } else { - my @after = grep { /eval/ } keys %::; - - is (scalar @after, 0 + keys %seen, - "evals that don't define subroutines are correctly cleaned up"); - } - - is (eval $fail, undef, 'Failed string eval fails'); - - if ($flags & 0x1000) { - check_retained_lines($fail, sprintf "%#X", $^P); - } else { - my @after = grep { /eval/ } keys %::; - - is (scalar @after, 0 + keys %seen, - "evals that fail are correctly cleaned up"); - } -} - -# BEGIN blocks that die -for (0xA, 0) { - local $^P = $_; - - eval (my $prog = "BEGIN{die}\n"); - - if ($_) { - check_retained_lines($prog, 'eval that defines BEGIN that dies'); - } - else { - my @after = grep { /eval/ } keys %::; - - is (scalar @after, 0 + keys %seen, - "evals with BEGIN{die} are correctly cleaned up"); - } -} - -# [perl #79442] A #line "foo" directive in a string eval was not updating -# *{"_0) {print "ok 2\n";} else {print "not ok 2\n";} - -if (length('\\\\') == 2) {print "ok 3\n";} else {print "not ok 3\n";} - -$one = 'a'; - -if (length("\\n") == 2) {print "ok 4\n";} else {print "not ok 4\n";} -if (length("\\\n") == 2) {print "ok 5\n";} else {print "not ok 5\n";} -if (length("$one\\n") == 3) {print "ok 6\n";} else {print "not ok 6\n";} -if (length("$one\\\n") == 3) {print "ok 7\n";} else {print "not ok 7\n";} -if (length("\\n$one") == 3) {print "ok 8\n";} else {print "not ok 8\n";} -if (length("\\\n$one") == 3) {print "ok 9\n";} else {print "not ok 9\n";} -if (length("\\${one}") == 2) {print "ok 10\n";} else {print "not ok 10\n";} - -if ("${one}b" eq "ab") { print "ok 11\n";} else {print "not ok 11\n";} - -@foo = (1,2,3); -if ("$foo[1]b" eq "2b") { print "ok 12\n";} else {print "not ok 12\n";} -if ("@foo[0..1]b" eq "1 2b") { print "ok 13\n";} else {print "not ok 13\n";} -$" = '::'; -if ("@foo[0..1]b" eq "1::2b") { print "ok 14\n";} else {print "not ok 14\n";} - -# test if C distinguishes between blocks and hashrefs - -$a = "{ '\\'' , 'foo' }"; -$a = eval $a; -if (ref($a) eq 'HASH') {print "ok 15\n";} else {print "not ok 15\n";} - -$a = "{ '\\\\\\'abc' => 'foo' }"; -$a = eval $a; -if (ref($a) eq 'HASH') {print "ok 16\n";} else {print "not ok 16\n";} - -$a = "{'a\\\n\\'b','foo'}"; -$a = eval $a; -if (ref($a) eq 'HASH') {print "ok 17\n";} else {print "not ok 17\n";} - -$a = "{'\\\\\\'\\\\'=>'foo'}"; -$a = eval $a; -if (ref($a) eq 'HASH') {print "ok 18\n";} else {print "not ok 18\n";} - -$a = "{q,a'b,,'foo'}"; -$a = eval $a; -if (ref($a) eq 'HASH') {print "ok 19\n";} else {print "not ok 19\n";} - -$a = "{q[[']]=>'foo'}"; -$a = eval $a; -if (ref($a) eq 'HASH') {print "ok 20\n";} else {print "not ok 20\n";} - -# needs disambiguation if first term is a variable -$a = "+{ \$a , 'foo'}"; -$a = eval $a; -if (ref($a) eq 'HASH') {print "ok 21\n";} else {print "not ok 21\n";} - -$a = "+{ \$a=>'foo'}"; -$a = eval $a; -if (ref($a) eq 'HASH') {print "ok 22\n";} else {print "not ok 22\n";} - -$a = "{ 0x01 => 'foo'}->{0x01}"; -$a = eval $a; -if ($a eq 'foo') {print "ok 23\n";} else {print "not ok 23\n";} diff --git a/t/CORE/comp/uproto.t b/t/CORE/comp/uproto.t deleted file mode 100644 index ea27198f5..000000000 --- a/t/CORE/comp/uproto.t +++ /dev/null @@ -1,134 +0,0 @@ -#!perl - -print "1..39\n"; -my $test = 0; - -sub failed { - my ($got, $expected, $name) = @_; - - print "not ok $test - $name\n"; - my @caller = caller(1); - print "# Failed test at $caller[1] line $caller[2]\n"; - if (defined $got) { - print "# Got '$got'\n"; - } else { - print "# Got undef\n"; - } - print "# Expected $expected\n"; - return; -} - -sub like { - my ($got, $pattern) = @_; - $test = $test + 1; - if (defined $got && $got =~ $pattern) { - print "ok $test\n"; - # Principle of least surprise - maintain the expected interface, even - # though we aren't using it here (yet). - return 1; - } - failed($got, $pattern, $name); -} - -sub is { - my ($got, $expect) = @_; - $test = $test + 1; - if (defined $expect) { - if (defined $got && $got eq $expect) { - print "ok $test\n"; - return 1; - } - failed($got, "'$expect'", $name); - } else { - if (!defined $got) { - print "ok $test\n"; - return 1; - } - failed($got, 'undef', $name); - } -} - -sub f($$_) { my $x = shift; is("@_", $x) } - -$foo = "FOO"; -my $bar = "BAR"; -$_ = 42; - -f("FOO xy", $foo, "xy"); -f("BAR zt", $bar, "zt"); -f("FOO 42", $foo); -f("BAR 42", $bar); -f("y 42", substr("xy",1,1)); -f("1 42", ("abcdef" =~ /abc/)); -f("not undef 42", $undef || "not undef"); -f(" 42", -f "no_such_file"); -f("FOOBAR 42", ($foo . $bar)); -f("FOOBAR 42", ($foo .= $bar)); -f("FOOBAR 42", $foo); - -eval q{ f("foo") }; -like( $@, qr/Not enough arguments for main::f at/ ); -eval q{ f(1,2,3,4) }; -like( $@, qr/Too many arguments for main::f at/ ); - -{ - my $_ = "quarante-deux"; - $foo = "FOO"; - $bar = "BAR"; - f("FOO quarante-deux", $foo); - f("BAR quarante-deux", $bar); - f("y quarante-deux", substr("xy",1,1)); - f("1 quarante-deux", ("abcdef" =~ /abc/)); - f("not undef quarante-deux", $undef || "not undef"); - f(" quarante-deux", -f "no_such_file"); - f("FOOBAR quarante-deux", ($foo . $bar)); - f("FOOBAR quarante-deux", ($foo .= $bar)); - f("FOOBAR quarante-deux", $foo); -} - -&f(""); # no error - -sub g(_) { is(shift, $expected) } - -$expected = "foo"; -g("foo"); -g($expected); -$_ = $expected; -g(); -g; -# perlcc issue 214 - https://code.google.com/p/perl-compiler/issues/detail?id=214 -undef $expected; &g; # $_ not passed -{ $expected = my $_ = "bar"; g() } - -eval q{ sub wrong1 (_$); wrong1(1,2) }; -like( $@, qr/Malformed prototype for main::wrong1/, 'wrong1' ); - -eval q{ sub wrong2 ($__); wrong2(1,2) }; -like( $@, qr/Malformed prototype for main::wrong2/, 'wrong2' ); - -sub opt ($;_) { - is($_[0], "seen"); - is($_[1], undef, "; has precedence over _"); -} - -opt("seen"); - -sub unop (_) { is($_[0], 11, "unary op") } -unop 11, 22; # takes only the first parameter into account - -sub mymkdir (_;$) { is("@_", $expected, "mymkdir") } -$expected = $_ = "mydir"; mymkdir(); -mymkdir($expected = "foo"); -$expected = "foo 493"; mymkdir foo => 0755; - -# $_ says modifiable, it's not passed by copy - -sub double(_) { $_[0] *= 2 } -$_ = 21; -double(); -is( $_, 42, '$_ is modifiable' ); -{ - my $_ = 22; - double(); - is( $_, 44, 'my $_ is modifiable' ); -} diff --git a/t/CORE/comp/use.t b/t/CORE/comp/use.t deleted file mode 100644 index 2c4c63293..000000000 --- a/t/CORE/comp/use.t +++ /dev/null @@ -1,265 +0,0 @@ -#!./perl - -BEGIN { - unshift @INC, qw(t/CORE/lib lib); - $INC{"feature.pm"} = 1; # so we don't attempt to load feature.pm -} - -print "1..73\n"; - -# Can't require test.pl, as we're testing the use/require mechanism here. - -my $test = 1; - -sub _ok { - my ($type, $got, $expected, $name) = @_; - - my $result; - if ($type eq 'is') { - $result = $got eq $expected; - } elsif ($type eq 'isnt') { - $result = $got ne $expected; - } elsif ($type eq 'like') { - $result = $got =~ $expected; - } else { - die "Unexpected type '$type'$name"; - } - if ($result) { - if ($name) { - print "ok $test - $name\n"; - } else { - print "ok $test\n"; - } - } else { - if ($name) { - print "not ok $test - $name\n"; - } else { - print "not ok $test\n"; - } - my @caller = caller(1); - print "# Failed test at $caller[1] line $caller[2]\n"; - print "# Got '$got'\n"; - if ($type eq 'is') { - print "# Expected '$expected'\n"; - } elsif ($type eq 'isnt') { - print "# Expected not '$expected'\n"; - } elsif ($type eq 'like') { - print "# Expected $expected\n"; - } - } - $test = $test + 1; - $result; -} - -sub like ($$;$) { - _ok ('like', @_); -} -sub is ($$;$) { - _ok ('is', @_); -} -sub isnt ($$;$) { - _ok ('isnt', @_); -} - -eval "use 5"; # implicit semicolon -is ($@, ''); - -eval "use 5;"; -is ($@, ''); - -eval "{use 5}"; # [perl #70884] -is ($@, ''); - -eval "{use 5 }"; # [perl #70884] -is ($@, ''); - -# new style version numbers - -eval q{ use v5.5.630; }; -is ($@, ''); - -eval q{ use 10.0.2; }; -like ($@, qr/^Perl v10\.0\.2 required/); - -eval "use 5.000"; # implicit semicolon -is ($@, ''); - -eval "use 5.000;"; -is ($@, ''); - -eval "use 6.000;"; -like ($@, qr/Perl v6\.0\.0 required--this is only \Q$^V\E, stopped/); - -eval "no 6.000;"; -is ($@, ''); - -eval "no 5.000;"; -like ($@, qr/Perls since v5\.0\.0 too modern--this is \Q$^V\E, stopped/); - -eval "use 5.6;"; -like ($@, qr/Perl v5\.600\.0 required \(did you mean v5\.6\.0\?\)--this is only \Q$^V\E, stopped/); - -eval "use 5.8;"; -like ($@, qr/Perl v5\.800\.0 required \(did you mean v5\.8\.0\?\)--this is only \Q$^V\E, stopped/); - -eval "use 5.9;"; -like ($@, qr/Perl v5\.900\.0 required \(did you mean v5\.9\.0\?\)--this is only \Q$^V\E, stopped/); - -eval "use 5.10;"; -like ($@, qr/Perl v5\.100\.0 required \(did you mean v5\.10\.0\?\)--this is only \Q$^V\E, stopped/); - -eval "use 5.11;"; -like ($@, qr/Perl v5\.110\.0 required \(did you mean v5\.11\.0\?\)--this is only \Q$^V\E, stopped/); - -eval sprintf "use %.6f;", $]; -is ($@, ''); - - -eval sprintf "use %.6f;", $] - 0.000001; -is ($@, ''); - -eval sprintf("use %.6f;", $] + 1); -like ($@, qr/Perl v6.\d+.\d+ required--this is only \Q$^V\E, stopped/); - -eval sprintf "use %.6f;", $] + 0.00001; -like ($@, qr/Perl v5.\d+.\d+ required--this is only \Q$^V\E, stopped/); - -# check that "use 5.11.0" (and higher) loads strictures -eval 'use 5.11.0; ${"foo"} = "bar";'; -like ($@, qr/Can't use string \("foo"\) as a SCALAR ref while "strict refs" in use/); -# but that they can be disabled -eval 'use 5.11.0; no strict "refs"; ${"foo"} = "bar";'; -is ($@, ""); -# and they are properly scoped -eval '{use 5.11.0;} ${"foo"} = "bar";'; -is ($@, ""); - -{ use test_use } # check that subparse saves pending tokens - -local $test_use::VERSION = 1.0; - -eval "use test_use 0.9"; -is ($@, ''); - -eval "use test_use 1.0"; -is ($@, ''); - -eval "use test_use 1.01"; -isnt ($@, ''); - -eval "use test_use 0.9 qw(fred)"; -is ($@, ''); - -is("@test_use::got", "fred"); - -eval "use test_use 1.0 qw(joe)"; -is ($@, ''); - -is("@test_use::got", "joe"); - -eval "use test_use 1.01 qw(freda)"; -isnt($@, ''); - -is("@test_use::got", "joe"); - -{ - local $test_use::VERSION = 35.36; - eval "use test_use v33.55"; - is ($@, ''); - - eval "use test_use v100.105"; - like ($@, qr/test_use version v100.105.0 required--this is only version v35\.360\.0/); - - eval "use test_use 33.55"; - is ($@, ''); - - eval "use test_use 100.105"; - like ($@, qr/test_use version 100.105 required--this is only version 35.36/); - - local $test_use::VERSION = '35.36'; - eval "use test_use v33.55"; - like ($@, ''); - - eval "use test_use v100.105"; - like ($@, qr/test_use version v100.105.0 required--this is only version v35\.360\.0/); - - eval "use test_use 33.55"; - is ($@, ''); - - eval "use test_use 100.105"; - like ($@, qr/test_use version 100.105 required--this is only version 35.36/); - - local $test_use::VERSION = v35.36; - eval "use test_use v33.55"; - is ($@, ''); - - eval "use test_use v100.105"; - like ($@, qr/test_use version v100.105.0 required--this is only version v35\.36\.0/); - - eval "use test_use 33.55"; - is ($@, ''); - - eval "use test_use 100.105"; - like ($@, qr/test_use version 100.105 required--this is only version v35.36/); -} - - -{ - # Regression test for patch 14937: - # Check that a .pm file with no package or VERSION doesn't core. - # (git commit 2658f4d9934aba5f8b23afcc078dc12b3a40223) - eval "use test_use_14937 3"; - like ($@, qr/^test_use_14937 defines neither package nor VERSION--version check failed at/); -} - -my @ver = split /\./, sprintf "%vd", $^V; - -foreach my $index (-3..+3) { - foreach my $v (0, 1) { - my @parts = @ver; - if ($index) { - if ($index < 0) { - # Jiggle one of the parts down - --$parts[-$index - 1]; - if ($parts[-$index - 1] < 0) { - # perl's version number ends with '.0' - $parts[-$index - 1] = 0; - $parts[-$index - 2] -= 2; - } - } else { - # Jiggle one of the parts up - ++$parts[$index - 1]; - } - } - my $v_version = sprintf "v%d.%d.%d", @parts; - my $version; - if ($v) { - $version = $v_version; - } else { - $version = $parts[0] + $parts[1] / 1000 + $parts[2] / 1000000; - } - - eval "use $version"; - if ($index > 0) { - # The future - like ($@, - qr/Perl $v_version required--this is only \Q$^V\E, stopped/, - "use $version"); - } else { - # The present or past - is ($@, '', "use $version"); - } - - eval "no $version"; - if ($index <= 0) { - # The present or past - like ($@, - qr/Perls since $v_version too modern--this is \Q$^V\E, stopped/, - "no $version"); - } else { - # future - is ($@, '', "no $version"); - } - } -} - diff --git a/t/CORE/comp/utf.t b/t/CORE/comp/utf.t deleted file mode 100644 index f5190f9ee..000000000 --- a/t/CORE/comp/utf.t +++ /dev/null @@ -1,102 +0,0 @@ -#!./perl -w - -print "1..4016\n"; -my $test = 0; - -my %templates = ( - 'UTF-8' => 'C0U', - 'UTF-16BE' => 'n', - 'UTF-16LE' => 'v', - ); - -sub bytes_to_utf { - my ($enc, $content, $do_bom) = @_; - my $template = $templates{$enc}; - die "Unsupported encoding $enc" unless $template; - my @chars = unpack "U*", $content; - if ($enc ne 'UTF-8') { - # Make surrogate pairs - my @remember_that_utf_16_is_variable_length; - foreach my $ord (@chars) { - if ($ord < 0x10000) { - push @remember_that_utf_16_is_variable_length, - $ord; - } else { - $ord -= 0x10000; - push @remember_that_utf_16_is_variable_length, - (0xD800 | ($ord >> 10)), (0xDC00 | ($ord & 0x3FF)); - } - } - @chars = @remember_that_utf_16_is_variable_length; - } - return pack "$template*", ($do_bom ? 0xFEFF : ()), @chars; -} - -sub test { - my ($enc, $write, $expect, $bom, $nl, $name) = @_; - open my $fh, ">", "utf$$.pl" or die "utf.pl: $!"; - binmode $fh; - print $fh bytes_to_utf($enc, $write . ($nl ? "\n" : ''), $bom); - close $fh or die $!; - my $got = do "./utf$$.pl"; - $test = $test + 1; - if (!defined $got) { - if ($@ =~ /^(Unsupported script encoding \Q$enc\E)/) { - print "ok $test # skip $1\n"; - } else { - print "not ok $test # $enc $bom $nl $name; got undef\n"; - } - } elsif ($got ne $expect) { - print "not ok $test # $enc $bom $nl $name; got '$got'\n"; - } else { - print "ok $test # $enc $bom $nl $name\n"; - } -} - -for my $bom (0, 1) { - for my $enc (qw(UTF-16LE UTF-16BE UTF-8)) { - for my $nl (1, 0) { - for my $value (123, 1234, 12345) { - test($enc, $value, $value, $bom, $nl, $value); - # This has the unfortunate side effect of causing an infinite - # loop without the bug fix it corresponds to: - test($enc, "($value)", $value, $bom, $nl, "($value)"); - } - next if $enc eq 'UTF-8'; - # Arguably a bug that currently string literals from UTF-8 file - # handles are not implicitly "use utf8", but don't FIXME that - # right now, as here we're testing the input filter itself. - - for my $expect ("N", "\xFF", "\x{100}", "\x{010a}", "\x{0a23}", - "\x{10000}", "\x{64321}", "\x{10FFFD}", - "\x{1000a}", # 0xD800 0xDC0A - "\x{12800}", # 0xD80A 0xDC00 - ) { - # A space so that the UTF-16 heuristic triggers - " '" gives two - # characters of ASCII. - my $write = " '$expect'"; - my $name = 'chrs ' . join ', ', map {ord $_} split '', $expect; - test($enc, $write, $expect, $bom, $nl, $name); - } - - # This is designed to try to trip over the end of the buffer, - # with similar results to U-1000A and U-12800 above. - for my $pad (2 .. 162) { - for my $chr ("\x{10000}", "\x{1000a}", "\x{12800}") { - my $padding = ' ' x $pad; - # Need 4 octets that were from 2 ASCII characters to trigger - # the heuristic that detects UTF-16 without a BOM. For - # UTF-16BE, one space and the newline will do, as the - # newline's high octet comes first. But for UTF-16LE, a - # newline is "\n\0", so it doesn't trigger it. - test($enc, " \n$padding'$chr'", $chr, $bom, $nl, - sprintf "'\\x{%x}' with $pad spaces before it", ord $chr); - } - } - } - } -} - -END { - 1 while unlink "utf$$.pl"; -} diff --git a/t/CORE/io/argv.t b/t/CORE/io/argv.t deleted file mode 100644 index 2d28903fe..000000000 --- a/t/CORE/io/argv.t +++ /dev/null @@ -1,140 +0,0 @@ -#!./perl - -require 't/CORE/test.pl'; - -plan(tests => 23); - -my ($devnull, $no_devnull); - -require File::Spec; -$devnull = File::Spec->devnull; - -open($TRY, '>Io_argv1.tmp') || (die "Can't open temp file: $!"); -print $TRY "a line\n"; -close $TRY or die "Could not close: $!"; - -$x = runperl( - prog => 'while (<>) { print $., $_; }', - args => [ 'Io_argv1.tmp', 'Io_argv1.tmp' ], -); -is($x, "1a line\n2a line\n", '<> from two files'); - -{ - $x = runperl( - prog => 'while (<>) { print $_; }', - stdin => "foo\n", - args => [ 'Io_argv1.tmp', '-' ], - ); - is($x, "a line\nfoo\n", ' from a file and STDIN'); - - $x = runperl( - prog => 'while (<>) { print $_; }', - stdin => "foo\n", - ); - is($x, "foo\n", ' from just STDIN'); -} - -{ - # 5.10 stopped autovivifying scalars in globs leading to a - # segfault when $ARGV is written to. - runperl( prog => 'eof()', stdin => "nothing\n" ); - is( 0+$?, 0, q(eof() doesn't segfault) ); -} - -@ARGV = ('Io_argv1.tmp', 'Io_argv1.tmp', $devnull, 'Io_argv1.tmp'); -while (<>) { - $y .= $. . $_; - if (eof()) { - is($., 3, '$. counts <>'); - } -} - -is($y, "1a line\n2a line\n3a line\n", '<> from @ARGV'); - - -open(TRY, '>Io_argv1.tmp') or die "Can't open temp file: $!"; -close TRY or die "Could not close: $!"; -open(TRY, '>Io_argv2.tmp') or die "Can't open temp file: $!"; -close TRY or die "Could not close: $!"; -@ARGV = ('Io_argv1.tmp', 'Io_argv2.tmp'); -$^I = '_bak'; # not .bak which confuses VMS -$/ = undef; -my $i = 7; -while (<>) { - s/^/ok $i\n/; - ++$i; - print; - next_test(); -} -open(TRY, '; -open(TRY, '; -close TRY or die "Could not close: $!"; -undef $^I; - -ok( eof TRY ); - -{ - no warnings 'once'; - ok( eof NEVEROPENED, 'eof() true on unopened filehandle' ); -} - -open STDIN, 'Io_argv1.tmp' or die $!; -@ARGV = (); -ok( !eof(), 'STDIN has something' ); - -is( <>, "ok 7\n" ); - -open STDIN, $devnull or die $!; -@ARGV = (); -ok( eof(), 'eof() true with empty @ARGV' ); - -@ARGV = ('Io_argv1.tmp'); -ok( !eof() ); - -@ARGV = ($devnull, $devnull); -ok( !eof() ); - -close ARGV or die $!; -ok( eof(), 'eof() true after closing ARGV' ); - -{ - local $/; - open my $fh, 'Io_argv1.tmp' or die "Could not open Io_argv1.tmp: $!"; - <$fh>; # set $. = 1 - is( <$fh>, undef ); - - open $fh, $devnull or die; - ok( defined(<$fh>) ); - - is( <$fh>, undef ); - is( <$fh>, undef ); - - open $fh, $devnull or die; # restart cycle again - ok( defined(<$fh>) ); - is( <$fh>, undef ); - close $fh or die "Could not close: $!"; -} - -# perlcc issue 227 - https://code.google.com/p/perl-compiler/issues/detail?id=227 -# This used to dump core. Fixed Nov 14, 2013 -fresh_perl_is( <<'**PROG**', "foobar", {}, "ARGV aliasing and eof()" ); -open OUT, ">Io_argv3.tmp" or die "Can't open temp file: $!"; -print OUT "foo"; -close OUT; -open IN, "Io_argv3.tmp" or die "Can't open temp file: $!"; -*ARGV = *IN; -while (<>) { - print; - print "bar" if eof(); -} -close IN; -unlink "Io_argv3.tmp"; -**PROG** - -__END__ -END { - unlink_all 'Io_argv1.tmp', 'Io_argv1.tmp_bak', - 'Io_argv2.tmp', 'Io_argv2.tmp_bak', 'Io_argv3.tmp'; -} diff --git a/t/CORE/io/binmode.t b/t/CORE/io/binmode.t deleted file mode 100644 index b08608fbe..000000000 --- a/t/CORE/io/binmode.t +++ /dev/null @@ -1,35 +0,0 @@ -#!./perl - -use Errno; -INIT { - unshift @INC, "./lib"; - require 't/CORE/test.pl'; -} - -plan(tests => 9); - -ok( binmode(STDERR), 'STDERR made binary' ); -ok( binmode(STDERR, ":unix"), ' with unix discipline' ); -ok( binmode(STDERR, ":raw"), ' raw' ); -ok( binmode(STDERR, ":crlf"), ' and crlf' ); - -# If this one fails, we're in trouble. So we just bail out. -ok( binmode(STDOUT), 'STDOUT made binary' ) || exit(1); -SKIP: { - #skip('skip unix discipline without PerlIO layers', 1) - # perlcc bug #152 - #unless find PerlIO::Layer 'perlio'; - ok( binmode(STDOUT, ":unix"), ' with unix discipline' ); -} -ok( binmode(STDOUT, ":raw"), ' raw' ); -ok( binmode(STDOUT, ":crlf"), ' and crlf' ); - -SKIP: { - skip("no EBADF", 1) unless exists &Errno::EBADF; - - no warnings 'io', 'once'; - $! = 0; - binmode(B); - # perlcc bug #150 - cmp_ok($!, '==', Errno::EBADF()); -} diff --git a/t/CORE/io/bom.t b/t/CORE/io/bom.t deleted file mode 100644 index 42f0c9103..000000000 --- a/t/CORE/io/bom.t +++ /dev/null @@ -1,13 +0,0 @@ -#!./perl - -BEGIN { - unshift @INC, 't/CORE/lib'; -} - -BEGIN { require 't/CORE/test.pl'; } - -plan(tests => 1); - -# It is important that the script contains at least one newline character -# that can be expanded to \r\n on DOSish systems. -fresh_perl_is("\xEF\xBB\xBFprint 1;\nprint 2", "12", {}, "script starts with a BOM" ); diff --git a/t/CORE/io/crlf.t b/t/CORE/io/crlf.t deleted file mode 100644 index 69fc64a39..000000000 --- a/t/CORE/io/crlf.t +++ /dev/null @@ -1,74 +0,0 @@ -#!./perl -w - -require 't/CORE/test.pl'; - -use Config; - - -my $file = tempfile(); - -{ - plan(tests => 16); - ok(open(FOO,">:crlf",$file)); - ok(print FOO 'a'.((('a' x 14).qq{\n}) x 2000) || close(FOO)); - ok(open(FOO,"<:crlf",$file)); - - my $text; - { local $/; $text = } - is(count_chars($text, "\015\012"), 0); - is(count_chars($text, "\n"), 2000); - - binmode(FOO); - seek(FOO,0,0); - { local $/; $text = } - is(count_chars($text, "\015\012"), 2000); - - SKIP: - { - skip("no PerlIO::scalar") unless $Config{extensions} =~ m!\bPerlIO/scalar\b!; - require PerlIO::scalar; - my $fcontents = join "", map {"$_\015\012"} "a".."zzz"; - open my $fh, "<:crlf", \$fcontents; - local $/ = "xxx"; - local $_ = <$fh>; - my $pos = tell $fh; # pos must be behind "xxx", before "\nxxy\n" - seek $fh, $pos, 0; - $/ = "\n"; - $s = <$fh>.<$fh>; - is($s, "\nxxy\n"); - } - - ok(close(FOO)); - - # binmode :crlf should not cumulate. - # Try it first once and then twice so that even UNIXy boxes - # get to exercise this, for DOSish boxes even once is enough. - # Try also pushing :utf8 first so that there are other layers - # in between (this should not matter: CRLF layers still should - # not accumulate). - for my $utf8 ('', ':utf8') { - for my $binmode (1..2) { - open(FOO, ">$file"); - # require PerlIO; print PerlIO::get_layers(FOO), "\n"; - binmode(FOO, "$utf8:crlf") for 1..$binmode; - # require PerlIO; print PerlIO::get_layers(FOO), "\n"; - print FOO "Hello\n"; - close FOO; - open(FOO, "<$file"); - binmode(FOO); - my $foo = scalar ; - close FOO; - print join(" ", "#", map { sprintf("%02x", $_) } unpack("C*", $foo)), - "\n"; - like($foo, qr/\x0d\x0a$/); - unlike($foo, qr/\x0d\x0d/); - } - } -} - -sub count_chars { - my($text, $chars) = @_; - my $seen = 0; - $seen++ while $text =~ /$chars/g; - return $seen; -} diff --git a/t/CORE/io/crlf_through.t b/t/CORE/io/crlf_through.t deleted file mode 100644 index 5310b7e71..000000000 --- a/t/CORE/io/crlf_through.t +++ /dev/null @@ -1,13 +0,0 @@ -#!./perl - -BEGIN { - require 't/CORE/test.pl'; -} - -no warnings 'once'; -$main::use_crlf = 1; - -my $script = './t/CORE/io/through.t'; - -die "No script: $script" unless -f $script; -do './t/CORE/io/through.t' or die "no kid script"; diff --git a/t/CORE/io/data.t b/t/CORE/io/data.t deleted file mode 100644 index b2c60e836..000000000 --- a/t/CORE/io/data.t +++ /dev/null @@ -1,80 +0,0 @@ -#!./perl - -# tests for DATA filehandle operations - -BEGIN { - unshift @INC, 't/CORE/lib'; - require 't/CORE/test.pl'; -} - -$|=1; - -# It is important that all these tests are run via fresh_perl because -# that way they get written to disk in text mode and will have CR-LF -# line endings on Windows. Otherwise the failures related to Perl -# code being read in binary mode will not be observed. - -run_multiple_progs('', \*DATA); - -done_testing(); - -__END__ -# http://rt.perl.org/rt3/Ticket/Display.html?id=28106#txn-82657 -while () { - chomp; - print "$.: '$_'\n"; - system(); -} -__DATA__ -1 -2 -3 -EXPECT -1: '1' -2: '2' -3: '3' -######## -# http://rt.perl.org/rt3/Ticket/Display.html?id=28106#txn-83113 -my $line1 = ; -`echo foo`; -my $line2 = ; -if ($line1 eq "one\n") { print "ok 1\n" } else { print "not ok 1\n" } -if ($line2 eq "two\n") { print "ok 2\n" } else { print "not ok 2\n" } -__DATA__ -one -two -EXPECT -ok 1 -ok 2 -######## -# http://rt.perl.org/rt3/Ticket/Attachment/828796/403048/perlbug.rep.txt -my @data_positions = tell(DATA); -while (){ - if (/^__DATA__$/) { - push @data_positions, tell(DATA); - } -} - -my @fh_positions; -open(my $fh, '<', $0) or die; -while (<$fh>){ - if (/^__DATA__$/) { - push @fh_positions, tell($fh); - } -} - -print "not " unless "@data_positions" eq "@fh_positions"; -print "ok"; - -__DATA__ -ab -__DATA__ -ab - -__DATA__ -ab -__DATA__ -lotsa junk -nothing -EXPECT -ok diff --git a/t/CORE/io/defout.t b/t/CORE/io/defout.t deleted file mode 100644 index 07ba9e73b..000000000 --- a/t/CORE/io/defout.t +++ /dev/null @@ -1,52 +0,0 @@ -#!./perl -# -# tests for default output handle - -# DAPM 30/4/10 this area seems to have been undertested. For now, the only -# tests are ensuring things don't crash when PL_defoutgv isn't a GV; -# it probably needs expanding at some point to cover other stuff. - -BEGIN { - unshift @INC, 't/CORE/lib'; - require 't/CORE/test.pl'; -} - -plan tests => 16; - - -my $stdout = *STDOUT; -select($stdout); -$stdout = 1; # whoops, PL_defoutgv no longer a GV! -# XXX It is a GV as of 5.13.7. Is this test file needed any more? - -# note that in the tests below, the return values aren't as important -# as the fact that they don't crash - -ok print(""), 'print'; -ok select(), 'select'; - -$a = 'fooo'; -format STDOUT = -@ @<< -"#", $a -. -ok((write())[0], 'write'); - -ok($^, '$^'); -ok($~, '$~'); -ok($=, '$='); -ok($-, '$-'); -is($%, 0, '$%'); -is($|, 0, '$|'); -$^ = 1; pass '$^ = 1'; -$~ = 1; pass '$~ = 1'; -$= = 1; pass '$= = 1'; -$- = 1; pass '$- = 1'; -$% = 1; pass '$% = 1'; -$| = 1; pass '$| = 1'; - -# Switch to STDERR for this test, so we do not lose our test output -my $stderr = *STDERR; -select($stderr); -$stderr = 1; -ok close(), 'close'; diff --git a/t/CORE/io/dup.t b/t/CORE/io/dup.t deleted file mode 100644 index c8bafe98d..000000000 --- a/t/CORE/io/dup.t +++ /dev/null @@ -1,143 +0,0 @@ -#!./perl - -BEGIN { - unshift @INC, "./lib"; - require 't/CORE/test.pl'; -} - -use Config; -no warnings 'once'; - -my $test = 1; -my $tests_needing_perlio = 17; -plan(12 + $tests_needing_perlio); -print "ok 1\n"; - -open(DUPOUT,">&STDOUT"); -open(DUPERR,">&STDERR"); - -my $tempfile = tempfile(); - -open(STDOUT,">$tempfile") || die "Can't open stdout"; -open(STDERR,">&STDOUT") || die "Can't open stderr"; - -select(STDERR); $| = 1; -select(STDOUT); $| = 1; - -print STDOUT "ok 2\n"; -print STDERR "ok 3\n"; - -# Since some systems don't have echo, we use Perl. -$echo = qq{$^X -le "print q(ok %d)"}; - -$cmd = sprintf $echo, 4; -print `$cmd`; - -$cmd = sprintf "$echo 1>&2", 5; -print `$cmd`; - -system sprintf $echo, 6; -system sprintf "$echo 1>&2", 7; - -close(STDOUT) or die "Could not close: $!"; -close(STDERR) or die "Could not close: $!"; - -open(STDOUT,">&DUPOUT") or die "Could not open: $!"; -open(STDERR,">&DUPERR") or die "Could not open: $!"; - -if (($^O eq 'MSWin32') || ($^O eq 'NetWare')) { print `type $tempfile` } -elsif ($^O eq 'VMS') { system "type $tempfile.;" } # TYPE defaults to .LIS when there is no extension -else { system "cat $tempfile" } - -print STDOUT "ok 8\n"; - -open(F,">&",1) or die "Cannot dup to numeric 1: $!"; -print F "ok 9\n"; -close(F); - -open(F,">&",'1') or die "Cannot dup to string '1': $!"; -print F "ok 10\n"; -close(F); - -open(F,">&=",1) or die "Cannot dup to numeric 1: $!"; -print F "ok 11\n"; -close(F); - -if ($Config{useperlio}) { - open(F,">&=",'1') or die "Cannot dup to string '1': $!"; - print F "ok 12\n"; - close(F); -} else { - open(F, ">&DUPOUT") or die "Cannot dup stdout back: $!"; - print F "ok 12\n"; - close(F); -} - -# To get STDOUT back. -open(F, ">&DUPOUT") or die "Cannot dup stdout back: $!"; - -curr_test(13); - -SKIP: { - skip("need perlio", $tests_needing_perlio) unless $Config{useperlio}; - - ok(open(F, ">&", STDOUT)); - isnt(fileno(F), fileno(STDOUT)); - close F; - - ok(open(F, "<&=STDIN")) or _diag $!; - is(fileno(F), fileno(STDIN)); - close F; - - ok(open(F, ">&=STDOUT")); - is(fileno(F), fileno(STDOUT)); - close F; - - ok(open(F, ">&=STDERR")); - is(fileno(F), fileno(STDERR)); - close F; - - open(G, ">$tempfile") or die; - my $g = fileno(G); - - ok(open(F, ">&=$g")); - is(fileno(F), $g); - close F; - - ok(open(F, ">&=G")); - is(fileno(F), $g); - - print G "ggg\n"; - print F "fff\n"; - - close G; # flush first - close F; # flush second - - open(G, "<$tempfile") or die; - { - my $line; - $line = ; chomp $line; is($line, "ggg"); - $line = ; chomp $line; is($line, "fff"); - } - close G; - - open UTFOUT, '>:utf8', $tempfile or die $!; - open UTFDUP, '>&UTFOUT' or die $!; - # some old greek saying. - my $message = "\x{03A0}\x{0391}\x{039D}\x{03A4}\x{0391} \x{03A1}\x{0395}\x{0399}\n"; - print UTFOUT $message; - print UTFDUP $message; - binmode UTFDUP, ':utf8'; - print UTFDUP $message; - close UTFOUT; - close UTFDUP; - open(UTFIN, "<:utf8", $tempfile) or die $!; - { - my $line; - $line = ; is($line, $message); - $line = ; is($line, $message); - $line = ; is($line, $message); - } - close UTFIN; - -} diff --git a/t/CORE/io/eintr.t b/t/CORE/io/eintr.t deleted file mode 100644 index df926f4f8..000000000 --- a/t/CORE/io/eintr.t +++ /dev/null @@ -1,142 +0,0 @@ -#!./perl - -# If a read or write is interrupted by a signal, Perl will call the -# signal handler and then attempt to restart the call. If the handler does -# something nasty like close the handle or pop layers, make sure that the -# read/write handles this gracefully (for some definition of 'graceful': -# principally, don't segfault). - -INIT { - unshift @INC, 't/CORE/lib'; -} - -use warnings; -use strict; -use Config; - -require 't/CORE/test.pl'; - -my $piped; -eval { - pipe my $in, my $out; - $piped = 1; -}; -if (!$piped) { - skip_all('pipe not implemented'); - exit 0; -} -unless (exists $Config{'d_alarm'}) { - skip_all('alarm not implemented'); - exit 0; -} - -# XXX for some reason the stdio layer doesn't seem to interrupt -# write system call when the alarm triggers. This makes the tests -# hang. - -if (exists $ENV{PERLIO} && $ENV{PERLIO} =~ /stdio/ ) { - skip_all('stdio not supported for this script'); - exit 0; -} - -# on Win32, alarm() won't interrupt the read/write call. -# Similar issues with VMS. -# On FreeBSD, writes to pipes of 8192 bytes or more use a mechanism -# that is not interruptible (see perl #85842 and #84688). -# "close during print" also hangs on Solaris 8 (but not 10 or 11). -# -# Also skip on release builds, to avoid other possibly problematic -# platforms - -if ($^O eq 'VMS' || $^O eq 'MSWin32' || $^O eq 'cygwin' || $^O eq 'freebsd' || - ($^O eq 'solaris' && $Config{osvers} eq '2.8') - || ((int($]*1000) & 1) == 0) -) { - skip_all('various portability issues'); - exit 0; -} - -my ($in, $out, $st, $sigst, $buf); - -plan(tests => 10); - - -# make two handles that will always block - -sub fresh_io { - undef $in; undef $out; # use fresh handles each time - pipe $in, $out; - $sigst = ""; -} - -$SIG{PIPE} = 'IGNORE'; - -# close during read - -fresh_io; -$SIG{ALRM} = sub { $sigst = close($in) ? "ok" : "nok" }; -alarm(1); -$st = read($in, $buf, 1); -alarm(0); -is($sigst, 'ok', 'read/close: sig handler close status'); -ok(!$st, 'read/close: read status'); -ok(!close($in), 'read/close: close status'); - -# die during read - -fresh_io; -$SIG{ALRM} = sub { die }; -alarm(1); -$st = eval { read($in, $buf, 1) }; -alarm(0); -ok(!$st, 'read/die: read status'); -ok(close($in), 'read/die: close status'); - -# close during print - -fresh_io; -$SIG{ALRM} = sub { $sigst = close($out) ? "ok" : "nok" }; -$buf = "a" x 1_000_000 . "\n"; # bigger than any pipe buffer hopefully -select $out; $| = 1; select STDOUT; -alarm(1); -$st = print $out $buf; -alarm(0); -is($sigst, 'nok', 'print/close: sig handler close status'); -ok(!$st, 'print/close: print status'); -ok(!close($out), 'print/close: close status'); - -# die during print - -fresh_io; -$SIG{ALRM} = sub { die }; -$buf = "a" x 1_000_000 . "\n"; # bigger than any pipe buffer hopefully -select $out; $| = 1; select STDOUT; -alarm(1); -$st = eval { print $out $buf }; -alarm(0); -ok(!$st, 'print/die: print status'); -# the close will hang since there's data to flush, so use alarm -alarm(1); -ok(!eval {close($out)}, 'print/die: close status'); -alarm(0); - -# close during close - -# Apparently there's nothing in standard Linux that can cause an -# EINTR in close(2); but run the code below just in case it does on some -# platform, just to see if it segfaults. -fresh_io; -$SIG{ALRM} = sub { $sigst = close($in) ? "ok" : "nok" }; -alarm(1); -close $in; -alarm(0); - -# die during close - -fresh_io; -$SIG{ALRM} = sub { die }; -alarm(1); -eval { close $in }; -alarm(0); - -# vim: ts=4 sts=4 sw=4: diff --git a/t/CORE/io/errno.t b/t/CORE/io/errno.t deleted file mode 100644 index 4e68acb1d..000000000 --- a/t/CORE/io/errno.t +++ /dev/null @@ -1,46 +0,0 @@ -#!./perl -# vim: ts=4 sts=4 sw=4: - -# $! may not be set if EOF was reached without any error. -# http://rt.perl.org/rt3/Ticket/Display.html?id=39060 - -use strict; -use Config; - -require 't/CORE/test.pl'; - -plan( tests => 16 ); - -my $test_prog = 'undef $!;while(<>){print}; print $!'; -my $saved_perlio; - -BEGIN { - $saved_perlio = $ENV{PERLIO}; -} -END { - delete $ENV{PERLIO}; - $ENV{PERLIO} = $saved_perlio if defined $saved_perlio; -} - -for my $perlio ('perlio', 'stdio') { - $ENV{PERLIO} = $perlio; -SKIP: - for my $test_in ("test\n", "test") { - skip("Guaranteed newline at EOF on VMS", 4) if $^O eq 'VMS' && $test_in eq 'test'; - skip("[perl #71504] OpenBSD test failures in errno.t with ithreads and perlio", 8) - if $^O eq 'openbsd' && $Config{useithreads} && $perlio eq 'stdio'; - my $test_in_esc = $test_in; - $test_in_esc =~ s/\n/\\n/g; - for my $rs_code ('', '$/=undef', '$/=\2', '$/=\1024') { - TODO: - { - local $::TODO = "We get RMS\$_IOP at EOF on VMS when \$/ is undef" - if $^O eq 'VMS' && $rs_code eq '$/=undef'; - is( runperl( prog => "$rs_code; $test_prog", - stdin => $test_in, stderr => 1), - $test_in, - "Wrong errno, PERLIO=$ENV{PERLIO} stdin='$test_in_esc', $rs_code"); - } - } - } -} diff --git a/t/CORE/io/errnosig.t b/t/CORE/io/errnosig.t deleted file mode 100644 index ac37b7d0f..000000000 --- a/t/CORE/io/errnosig.t +++ /dev/null @@ -1,29 +0,0 @@ -#!./perl - -INIT { - unshift @INC, "./lib"; - require 't/CORE/test.pl'; -} - -require Config; import Config; -plan(tests => 1); - -SKIP: { - skip("Alarm not supported", 1) unless exists $Config{'d_alarm'}; - - $SIG{ALRM} = sub { - # We could call anything that modifies $! here, but - # this way we can be sure that it isn't the same - # errno as interrupted sleep() would return, and are - # able to check it thereafter. - $! = -1; - }; - - alarm 1; - sleep 2; - - # Interrupted sleeps sets errno to EAGAIN, but signal - # that # hits after it (if safe signal handling is enabled) - # causes a routing that modifies $! to be run afterwards - isnt($! + 0, -1, 'Signal does not modify $!'); -} diff --git a/t/CORE/io/fflush.t b/t/CORE/io/fflush.t deleted file mode 100644 index 6cc8b6f06..000000000 --- a/t/CORE/io/fflush.t +++ /dev/null @@ -1,131 +0,0 @@ -#!./perl - -BEGIN { - unshift @INC, 't/CORE/lib'; - require 't/CORE/test.pl'; -} - -# Script to test auto flush on fork/exec/system/qx. The idea is to -# print "Pe" to a file from a parent process and "rl" to the same file -# from a child process. If buffers are flushed appropriately, the -# file should contain "Perl". We'll see... -use Config; -use warnings; -use strict; - -# This attempts to mirror the #ifdef forest found in perl.h so that we -# know when to run these tests. If that forest ever changes, change -# it here too or expect test gratuitous test failures. -my $useperlio = defined $Config{useperlio} ? $Config{useperlio} eq 'define' ? 1 : 0 : 0; -my $fflushNULL = defined $Config{fflushNULL} ? $Config{fflushNULL} eq 'define' ? 1 : 0 : 0; -my $d_sfio = defined $Config{d_sfio} ? $Config{d_sfio} eq 'define' ? 1 : 0 : 0; -my $fflushall = defined $Config{fflushall} ? $Config{fflushall} eq 'define' ? 1 : 0 : 0; -my $d_fork = defined $Config{d_fork} ? $Config{d_fork} eq 'define' ? 1 : 0 : 0; - -skip_all('fflush(NULL) or equivalent not available') - unless $useperlio || $fflushNULL || $d_sfio || $fflushall; - -plan(tests => 7); - -my $runperl = $^X =~ m/\s/ ? qq{"$^X"} : $^X; -$runperl .= qq{ "-I../lib"}; - -sub file_eq { - my $f = shift; - my $val = shift; - - open IN, $f or die "open $f: $!"; - chomp(my $line = ); - close IN; - - print "# got $line\n"; - print "# expected $val\n"; - return $line eq $val; -} - -# This script will be used as the command to execute from -# child processes -my $ffprog = tempfile(); -open PROG, "> $ffprog" or die "open $ffprog: $!"; -print PROG <<'EOF'; -my $f = shift; -my $str = shift; -open OUT, ">> $f" or die "open $f: $!"; -print OUT $str; -close OUT; -EOF - ; -close PROG or die "close $ffprog: $!";; - -$| = 0; # we want buffered output - -# Test flush on fork/exec -if (!$d_fork) { - print "ok 1 # skipped: no fork\n"; -} else { - my $f = tempfile(); - open OUT, "> $f" or die "open $f: $!"; - print OUT "Pe"; - my $pid = fork; - if ($pid) { - # Parent - wait; - close OUT or die "close $f: $!"; - } elsif (defined $pid) { - # Kid - print OUT "r"; - my $command = qq{$runperl "$ffprog" "$f" "l"}; - print "# $command\n"; - exec $command or die $!; - exit; - } else { - # Bang - die "fork: $!"; - } - - print file_eq($f, "Perl") ? "ok 1\n" : "not ok 1\n"; -} - -# Test flush on system/qx/pipe open -my %subs = ( - "system" => sub { - my $c = shift; - system $c; - }, - "qx" => sub { - my $c = shift; - qx{$c}; - }, - "popen" => sub { - my $c = shift; - open PIPE, "$c|" or die "$c: $!"; - close PIPE; - }, - ); -my $t = 2; -for (qw(system qx popen)) { - my $code = $subs{$_}; - my $f = tempfile(); - my $command = qq{$runperl $ffprog "$f" "rl"}; - open OUT, "> $f" or die "open $f: $!"; - print OUT "Pe"; - close OUT or die "close $f: $!";; - print "# $command\n"; - $code->($command); - print file_eq($f, "Perl") ? "ok $t\n" : "not ok $t\n"; - ++$t; -} - -my $cmd = _create_runperl( - switches => ['-l'], - prog => - sprintf('print qq[ok $_] for (%d..%d)', $t, $t+2)); -print "# cmd = '$cmd'\n"; -open my $CMD, "$cmd |" or die "Can't open pipe to '$cmd': $!"; -while (<$CMD>) { - system("$runperl -e 0"); - print; -} -close $CMD; -$t += 3; -curr_test($t); diff --git a/t/CORE/io/fs.t b/t/CORE/io/fs.t deleted file mode 100644 index eb2f0c238..000000000 --- a/t/CORE/io/fs.t +++ /dev/null @@ -1,454 +0,0 @@ -#!./perl - -INIT { - unshift @INC, 't/CORE/lib'; - require 't/CORE/test.pl'; -} - -use Config; - -my $Is_VMSish = ($^O eq 'VMS'); - -if (($^O eq 'MSWin32') || ($^O eq 'NetWare')) { - $wd = `cd`; -} -elsif ($^O eq 'VMS') { - $wd = `show default`; -} -else { - $wd = `pwd`; -} -chomp($wd); - -my $has_link = $Config{d_link}; -my $accurate_timestamps = - !($^O eq 'MSWin32' || $^O eq 'NetWare' || - $^O eq 'dos' || $^O eq 'os2' || - $^O eq 'cygwin' || $^O eq 'amigaos' || - $wd =~ m#$Config{afsroot}/# - ); - -if (defined &Win32::IsWinNT && Win32::IsWinNT()) { - if (Win32::FsType() eq 'NTFS') { - $has_link = 1; - $accurate_timestamps = 1; - } -} - -my $needs_fh_reopen = - $^O eq 'dos' - # Not needed on HPFS, but needed on HPFS386 ?! - || $^O eq 'os2'; - -$needs_fh_reopen = 1 if (defined &Win32::IsWin95 && Win32::IsWin95()); - -my $skip_mode_checks = - $^O eq 'cygwin' && $ENV{CYGWIN} !~ /ntsec/; - -plan(51); - -my $tmpdir = tempfile(); -my $tmpdir1 = tempfile(); - -if (($^O eq 'MSWin32') || ($^O eq 'NetWare')) { - `rmdir /s /q $tmpdir 2>nul`; - `mkdir $tmpdir`; -} -elsif ($^O eq 'VMS') { - `if f\$search("[.$tmpdir]*.*") .nes. "" then delete/nolog/noconfirm [.$tmpdir]*.*.*`; - `if f\$search("$tmpdir.dir") .nes. "" then set file/prot=o:rwed $tmpdir.dir;`; - `if f\$search("$tmpdir.dir") .nes. "" then delete/nolog/noconfirm $tmpdir.dir;`; - `create/directory [.$tmpdir]`; -} -else { - `rm -f $tmpdir 2>/dev/null; mkdir $tmpdir 2>/dev/null`; -} - -chdir $tmpdir; - -`/bin/rm -rf a b c x` if -x '/bin/rm'; - -umask(022); - -SKIP: { - skip("bogus umask", 1) if ($^O eq 'MSWin32') || ($^O eq 'NetWare') || ($^O eq 'epoc'); - - is((umask(0)&0777), 022, 'umask'), -} - -open(FH,'>x') || die "Can't create x"; -close(FH); -open(FH,'>a') || die "Can't create a"; -close(FH); - -my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, - $blksize,$blocks,$a_mode); - -SKIP: { - skip("no link", 4) unless $has_link; - - ok(link('a','b'), "link a b"); - ok(link('b','c'), "link b c"); - - $a_mode = (stat('a'))[2]; - - ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, - $blksize,$blocks) = stat('c'); - - SKIP: { - skip("no nlink", 1) if $Config{dont_use_nlink}; - - is($nlink, 3, "link count of triply-linked file"); - } - - SKIP: { - skip("hard links not that hard in $^O", 1) if $^O eq 'amigaos'; - skip("no mode checks", 1) if $skip_mode_checks; - -# if ($^O eq 'cygwin') { # new files on cygwin get rwx instead of rw- -# is($mode & 0777, 0777, "mode of triply-linked file"); -# } else { - is(sprintf("0%o", $mode & 0777), - sprintf("0%o", $a_mode & 0777), - "mode of triply-linked file"); -# } - } -} - -$newmode = (($^O eq 'MSWin32') || ($^O eq 'NetWare')) ? 0444 : 0777; - -is(chmod($newmode,'a'), 1, "chmod succeeding"); - -SKIP: { - skip("no link", 7) unless $has_link; - - ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, - $blksize,$blocks) = stat('c'); - - SKIP: { - skip("no mode checks", 1) if $skip_mode_checks; - - is($mode & 0777, $newmode, "chmod going through"); - } - - $newmode = 0700; - chmod 0444, 'x'; - $newmode = 0666; - - is(chmod($newmode,'c','x'), 2, "chmod two files"); - - ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, - $blksize,$blocks) = stat('c'); - - SKIP: { - skip("no mode checks", 1) if $skip_mode_checks; - - is($mode & 0777, $newmode, "chmod going through to c"); - } - - ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, - $blksize,$blocks) = stat('x'); - - SKIP: { - skip("no mode checks", 1) if $skip_mode_checks; - - is($mode & 0777, $newmode, "chmod going through to x"); - } - - is(unlink('b','x'), 2, "unlink two files"); - - ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, - $blksize,$blocks) = stat('b'); - - is($ino, undef, "ino of removed file b should be undef"); - - ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, - $blksize,$blocks) = stat('x'); - - is($ino, undef, "ino of removed file x should be undef"); -} - -SKIP: { - skip("no fchmod", 5) unless ($Config{d_fchmod} || "") eq "define"; - ok(open(my $fh, "<", "a"), "open a"); - is(chmod(0, $fh), 1, "fchmod"); - $mode = (stat "a")[2]; - SKIP: { - skip("no mode checks", 1) if $skip_mode_checks; - is($mode & 0777, 0, "perm reset"); - } - is(chmod($newmode, "a"), 1, "fchmod"); - $mode = (stat $fh)[2]; - SKIP: { - skip("no mode checks", 1) if $skip_mode_checks; - is($mode & 0777, $newmode, "perm restored"); - } -} - -SKIP: { - skip("no fchown", 1) unless ($Config{d_fchown} || "") eq "define"; - open(my $fh, "<", "a"); - is(chown(-1, -1, $fh), 1, "fchown"); -} - -SKIP: { - skip("has fchmod", 1) if ($Config{d_fchmod} || "") eq "define"; - open(my $fh, "<", "a"); - eval { chmod(0777, $fh); }; - like($@, qr/^The fchmod function is unimplemented at/, "fchmod is unimplemented"); -} - -SKIP: { - skip("has fchown", 1) if ($Config{d_fchown} || "") eq "define"; - open(my $fh, "<", "a"); - eval { chown(0, 0, $fh); }; - like($@, qr/^The f?chown function is unimplemented at/, "fchown is unimplemented"); -} - -is(rename('a','b'), 1, "rename a b"); - -($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, - $blksize,$blocks) = stat('a'); - -is($ino, undef, "ino of renamed file a should be undef"); - -$delta = $accurate_timestamps ? 1 : 2; # Granularity of time on the filesystem -chmod 0777, 'b'; - -$foo = (utime 500000000,500000000 + $delta,'b'); -is($foo, 1, "utime"); -check_utime_result(); - -utime undef, undef, 'b'; -($atime,$mtime) = (stat 'b')[8,9]; -print "# utime undef, undef --> $atime, $mtime\n"; -isnt($atime, 500000000, 'atime'); -isnt($mtime, 500000000 + $delta, 'mtime'); - -SKIP: { - skip("no futimes", 4) unless ($Config{d_futimes} || "") eq "define"; - open(my $fh, "<", 'b'); - $foo = (utime 500000000,500000000 + $delta, $fh); - is($foo, 1, "futime"); - check_utime_result(); -} - - -sub check_utime_result { - ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, - $blksize,$blocks) = stat('b'); - - SKIP: { - skip("bogus inode num", 1) if ($^O eq 'MSWin32') || ($^O eq 'NetWare'); - - ok($ino, 'non-zero inode num'); - } - - SKIP: { - skip("filesystem atime/mtime granularity too low", 2) - unless $accurate_timestamps; - - print "# atime - $atime mtime - $mtime delta - $delta\n"; - if($atime == 500000000 && $mtime == 500000000 + $delta) { - pass('atime'); - pass('mtime'); - } - else { - if ($^O =~ /\blinux\b/i) { - print "# Maybe stat() cannot get the correct atime, ". - "as happens via NFS on linux?\n"; - $foo = (utime 400000000,500000000 + 2*$delta,'b'); - my ($new_atime, $new_mtime) = (stat('b'))[8,9]; - print "# newatime - $new_atime nemtime - $new_mtime\n"; - if ($new_atime == $atime && $new_mtime - $mtime == $delta) { - pass("atime - accounted for possible NFS/glibc2.2 bug on linux"); - pass("mtime - accounted for possible NFS/glibc2.2 bug on linux"); - } - else { - fail("atime - $atime/$new_atime $mtime/$new_mtime"); - fail("mtime - $atime/$new_atime $mtime/$new_mtime"); - } - } - elsif ($^O eq 'VMS') { - # why is this 1 second off? - is( $atime, 500000001, 'atime' ); - is( $mtime, 500000000 + $delta, 'mtime' ); - } - elsif ($^O eq 'beos' || $^O eq 'haiku') { - SKIP: { - skip("atime not updated", 1); - } - is($mtime, 500000001, 'mtime'); - } - else { - fail("atime"); - fail("mtime"); - } - } - } -} - -SKIP: { - skip("has futimes", 1) if ($Config{d_futimes} || "") eq "define"; - open(my $fh, "<", "b") || die; - eval { utime(undef, undef, $fh); }; - like($@, qr/^The futimes function is unimplemented at/, "futimes is unimplemented"); -} - -is(unlink('b'), 1, "unlink b"); - -($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, - $blksize,$blocks) = stat('b'); -is($ino, undef, "ino of unlinked file b should be undef"); -unlink 'c'; - -chdir $wd || die "Can't cd back to $wd"; - -# Yet another way to look for links (perhaps those that cannot be -# created by perl?). Hopefully there is an ls utility in your -# %PATH%. N.B. that $^O is 'cygwin' on Cygwin. - -SKIP: { - skip("Win32/Netware specific test", 2) - unless ($^O eq 'MSWin32') || ($^O eq 'NetWare'); - skip("No symbolic links found to test with", 2) - unless `ls -l perl 2>nul` =~ /^l.*->/; - - system("cp TEST TEST$$"); - # we have to copy because e.g. GNU grep gets huffy if we have - # a symlink forest to another disk (it complains about too many - # levels of symbolic links, even if we have only two) - is(symlink("TEST$$","c"), 1, "symlink"); - $foo = `grep perl c 2>&1`; - ok($foo, "found perl in c"); - unlink 'c'; - unlink("TEST$$"); -} - -my $tmpfile = tempfile(); -open IOFSCOM, ">$tmpfile" or die "Could not write IOfs.tmp: $!"; -print IOFSCOM 'helloworld'; -close(IOFSCOM); - -# TODO: pp_truncate needs to be taught about F_CHSIZE and F_FREESP, -# as per UNIX FAQ. - -SKIP: { -# Check truncating a closed file. - eval { truncate $tmpfile, 5; }; - - skip("no truncate - $@", 8) if $@; - - is(-s $tmpfile, 5, "truncation to five bytes"); - - truncate $tmpfile, 0; - - ok(-z $tmpfile, "truncation to zero bytes"); - -#these steps are necessary to check if file is really truncated -#On Win95, FH is updated, but file properties aren't - open(FH, ">$tmpfile") or die "Can't create $tmpfile"; - print FH "x\n" x 200; - close FH; - -# Check truncating an open file. - open(FH, ">>$tmpfile") or die "Can't open $tmpfile for appending"; - - binmode FH; - select FH; - $| = 1; - select STDOUT; - - { - use strict; - print FH "x\n" x 200; - ok(truncate(FH, 200), "fh resize to 200"); - } - - if ($needs_fh_reopen) { - close (FH); open (FH, ">>$tmpfile") or die "Can't reopen $tmpfile"; - } - - SKIP: { - if ($^O eq 'vos') { - skip ("# TODO - hit VOS bug posix-973 - cannot resize an open file below the current file pos.", 5); - } - - is(-s $tmpfile, 200, "fh resize to 200 working (filename check)"); - - ok(truncate(FH, 0), "fh resize to zero"); - - if ($needs_fh_reopen) { - close (FH); open (FH, ">>$tmpfile") or die "Can't reopen $tmpfile"; - } - - ok(-z $tmpfile, "fh resize to zero working (filename check)"); - - close FH; - - open(FH, ">>$tmpfile") or die "Can't open $tmpfile for appending"; - - binmode FH; - select FH; - $| = 1; - select STDOUT; - - { - use strict; - print FH "x\n" x 200; - ok(truncate(*FH{IO}, 100), "fh resize by IO slot"); - } - - if ($needs_fh_reopen) { - close (FH); open (FH, ">>$tmpfile") or die "Can't reopen $tmpfile"; - } - - is(-s $tmpfile, 100, "fh resize by IO slot working"); - - close FH; - } -} - -# check if rename() can be used to just change case of filename -SKIP: { - skip("Works in Cygwin only if check_case is set to relaxed", 1) - if ($ENV{'CYGWIN'} && ($ENV{'CYGWIN'} =~ /check_case:(?:adjust|strict)/)); - - chdir "./$tmpdir"; - open(FH,'>x') || die "Can't create x"; - close(FH); - rename('x', 'X'); - - # this works on win32 only, because fs isn't casesensitive - ok(-e 'X', "rename working"); - - unlink_all('X'); - chdir $wd || die "Can't cd back to $wd"; -} - -# check if rename() works on directories -if ($^O eq 'VMS') { - # must have delete access to rename a directory - `set file $tmpdir.dir/protection=o:d`; - ok(rename("$tmpdir.dir", "$tmpdir1.dir"), "rename on directories") || - print "# errno: $!\n"; -} -else { - ok(rename($tmpdir, $tmpdir1), "rename on directories"); -} - -ok(-d $tmpdir1, "rename on directories working"); - -{ - # Change 26011: Re: A surprising segfault - # to make sure only that these obfuscated sentences will not crash. - - map chmod(+()), ('')x68; - ok(1, "extend sp in pp_chmod"); - - map chown(+()), ('')x68; - ok(1, "extend sp in pp_chown"); -} - -# need to remove $tmpdir if rename() in test 28 failed! -END { rmdir $tmpdir1; rmdir $tmpdir; } diff --git a/t/CORE/io/inplace.t b/t/CORE/io/inplace.t deleted file mode 100644 index ea11c2aab..000000000 --- a/t/CORE/io/inplace.t +++ /dev/null @@ -1,92 +0,0 @@ -#!./perl -use strict; -require 't/CORE/test.pl'; - -$^I = $^O eq 'VMS' ? '_bak' : '.bak'; - -plan( tests => 6 ); - -my @tfiles = (tempfile(), tempfile(), tempfile()); -my @tfiles_bak = map "$_$^I", @tfiles; - -END { unlink_all(@tfiles_bak); } - -for my $file (@tfiles) { - runperl( prog => 'print qq(foo\n);', - args => ['>', $file] ); -} - -@ARGV = @tfiles; - -while (<>) { - s/foo/bar/; -} -continue { - print; -} - -is ( runperl( prog => 'print<>;', args => \@tfiles ), - "bar\nbar\nbar\n", - "file contents properly replaced" ); - -is ( runperl( prog => 'print<>;', args => \@tfiles_bak ), - "foo\nfoo\nfoo\n", - "backup file contents stay the same" ); - -SKIP: -{ - # based on code, dosish and epoc systems can't do no-backup inplace - # edits - $^O =~ /^(MSWin32|cygwin|uwin|dos|epoc|os2)$/ - and skip("Can't inplace edit without backups on $^O", 4); - - our @ifiles = ( tempfile(), tempfile(), tempfile() ); - - { - for my $file (@ifiles) { - runperl( prog => 'print qq(bar\n);', - args => [ '>', $file ] ); - } - - local $^I = ''; - local @ARGV = @ifiles; - - while (<>) { - print "foo$_"; - } - - is(scalar(@ARGV), 0, "consumed ARGV"); - -# runperl may quote its arguments, so don't expect to be able -# to reuse things you send it. - - my @my_ifiles = @ifiles; - is( runperl( prog => 'print<>;', args => \@my_ifiles ), - "foobar\nfoobar\nfoobar\n", - "normal inplace edit"); - } - - # test * equivalence RT #70802 - { - for my $file (@ifiles) { - runperl( prog => 'print qq(bar\n);', - args => [ '>', $file ] ); - } - - local $^I = '*'; - local @ARGV = @ifiles; - - while (<>) { - print "foo$_"; - } - - is(scalar(@ARGV), 0, "consumed ARGV"); - - my @my_ifiles = @ifiles; - is( runperl( prog => 'print<>;', args => \@my_ifiles ), - "foobar\nfoobar\nfoobar\n", - "normal inplace edit"); - } - - END { unlink_all(@ifiles); } -} diff --git a/t/CORE/io/iofile.t b/t/CORE/io/iofile.t deleted file mode 100644 index 92286061b..000000000 --- a/t/CORE/io/iofile.t +++ /dev/null @@ -1,24 +0,0 @@ -#!./perl - -BEGIN { - unshift @INC, 't/CORE/lib'; - require 't/CORE/test.pl'; -} - -$| = 1; -use warnings; -use Config; - -plan tests => 3; - -# this is essentially the same as a test on a lexical filehandle in -# t/io/open.t, but done in a separate test process against a standard -# filehandle - -# check that we can call methods on filehandles auto-magically -# and have IO::File loaded for us -{ - is( $INC{'IO/File.pm'}, undef, "IO::File not loaded" ); - ok( eval { STDOUT->autoflush(1); 1 }, 'STDOUT->autoflush(1) lives' ); - ok( $INC{'IO/File.pm'}, "IO::File now loaded" ); -} diff --git a/t/CORE/io/iprefix.t b/t/CORE/io/iprefix.t deleted file mode 100644 index bcf280f46..000000000 --- a/t/CORE/io/iprefix.t +++ /dev/null @@ -1,37 +0,0 @@ -#!./perl -use strict; -require 't/CORE/test.pl'; - -$^I = 'bak.*'; - -# Modified from the original inplace.t to test adding prefixes - -plan( tests => 2 ); - -my @tfiles = (tempfile(), tempfile(), tempfile()); -my @tfiles_bak = map "bak.$_", @tfiles; - -END { unlink_all(@tfiles_bak); } - -for my $file (@tfiles) { - runperl( prog => 'print qq(foo\n);', - args => ['>', $file] ); -} - -@ARGV = @tfiles; - -while (<>) { - s/foo/bar/; -} -continue { - print; -} - -is ( runperl( prog => 'print<>;', args => \@tfiles ), - "bar\nbar\nbar\n", - "file contents properly replaced" ); - -is ( runperl( prog => 'print<>;', args => \@tfiles_bak ), - "foo\nfoo\nfoo\n", - "backup file contents stay the same" ); - diff --git a/t/CORE/io/layers.t b/t/CORE/io/layers.t deleted file mode 100644 index 2ad94d445..000000000 --- a/t/CORE/io/layers.t +++ /dev/null @@ -1,258 +0,0 @@ -#!./perl - -my $PERLIO; - -BEGIN { - unshift @INC, 't/CORE/lib'; - require 't/CORE/test.pl'; - - # Makes testing easier. - $ENV{PERLIO} = 'stdio' if exists $ENV{PERLIO} && $ENV{PERLIO} eq ''; - skip_all("PERLIO='$ENV{PERLIO}' unknown") - if exists $ENV{PERLIO} && $ENV{PERLIO} !~ /^(stdio|perlio|mmap)$/; - $PERLIO = exists $ENV{PERLIO} ? $ENV{PERLIO} : "(undef)"; -} - -use Config; - -my $DOSISH = $^O =~ /^(?:MSWin32|os2|dos|NetWare)$/ ? 1 : 0; - $DOSISH = 1 if !$DOSISH and $^O =~ /^uwin/; -my $NONSTDIO = exists $ENV{PERLIO} && $ENV{PERLIO} ne 'stdio' ? 1 : 0; -my $FASTSTDIO = $Config{d_faststdio} && $Config{usefaststdio} ? 1 : 0; -my $UTF8_STDIN; -if (${^UNICODE} & 1) { - if (${^UNICODE} & 64) { - # Conditional on the locale - $UTF8_STDIN = ${^UTF8LOCALE}; - } else { - # Unconditional - $UTF8_STDIN = 1; - } -} else { - $UTF8_STDIN = 0; -} -my $NTEST = 62 - (($DOSISH || !$FASTSTDIO) ? 7 : 0) - ($DOSISH ? 7 : 0) - + $UTF8_STDIN; - -sub PerlIO::F_UTF8 () { 0x00008000 } # from perliol.h - -plan tests => $NTEST; - -print <<__EOH__; -# PERLIO = $PERLIO -# DOSISH = $DOSISH -# NONSTDIO = $NONSTDIO -# FASTSTDIO = $FASTSTDIO -# UNICODE = ${^UNICODE} -# UTF8LOCALE = ${^UTF8LOCALE} -# UTF8_STDIN = $UTF8_STDIN -__EOH__ - -{ - sub check { - my ($result, $expected, $id) = @_; - # An interesting dance follows where we try to make the following - # IO layer stack setups to compare equal: - # - # PERLIO UNIX-like DOS-like - # - # unset / "" unix perlio / stdio [1] unix crlf - # stdio unix perlio / stdio [1] stdio - # perlio unix perlio unix perlio - # mmap unix mmap unix mmap - # - # [1] "stdio" if Configure found out how to do "fast stdio" (depends - # on the stdio implementation) and in Perl 5.8, otherwise "unix perlio" - # - if ($NONSTDIO) { - # Get rid of "unix". - shift @$result if $result->[0] eq "unix"; - # Change expectations. - if ($FASTSTDIO) { - $expected->[0] = $ENV{PERLIO}; - } else { - $expected->[0] = $ENV{PERLIO} if $expected->[0] eq "stdio"; - } - } elsif (!$FASTSTDIO && !$DOSISH) { - splice(@$result, 0, 2, "stdio") - if @$result >= 2 && - $result->[0] eq "unix" && - $result->[1] eq "perlio"; - } elsif ($DOSISH) { - splice(@$result, 0, 2, "stdio") - if @$result >= 2 && - $result->[0] eq "unix" && - $result->[1] eq "crlf"; - } - if ($DOSISH && grep { $_ eq 'crlf' } @$expected) { - # 5 tests potentially skipped because - # DOSISH systems already have a CRLF layer - # which will make new ones not stick. - splice @$expected, 1, 1 if $expected->[1] eq 'crlf'; - } - my $n = scalar @$expected; - is(scalar @$result, $n, "$id - layers == $n"); - for (my $i = 0; $i < $n; $i++) { - my $j = $expected->[$i]; - if (ref $j eq 'CODE') { - ok($j->($result->[$i]), "$id - $i is ok"); - } else { - is($result->[$i], $j, - sprintf("$id - $i is %s", - defined $j ? $j : "undef")); - } - } - } - - check([ PerlIO::get_layers(STDIN) ], - $UTF8_STDIN ? [ "stdio", "utf8" ] : [ "stdio" ], - "STDIN"); - - my $afile = tempfile(); - open(F, ">:crlf", $afile); - - check([ PerlIO::get_layers(F) ], - [ qw(stdio crlf) ], - "open :crlf"); - - binmode(F, ":crlf"); - - check([ PerlIO::get_layers(F) ], - [ qw(stdio crlf) ], - "binmode :crlf"); - - binmode(F, ":encoding(cp1047)"); - - check([ PerlIO::get_layers(F) ], - [ qw[stdio crlf encoding(cp1047) utf8] ], - ":encoding(cp1047)"); - - binmode(F, ":crlf"); - - check([ PerlIO::get_layers(F) ], - [ qw[stdio crlf encoding(cp1047) utf8 crlf utf8] ], - ":encoding(cp1047):crlf"); - - binmode(F, ":pop:pop"); - - check([ PerlIO::get_layers(F) ], - [ qw(stdio crlf) ], - ":pop"); - - binmode(F, ":raw"); - - check([ PerlIO::get_layers(F) ], - [ "stdio" ], - ":raw"); - - binmode(F, ":utf8"); - - check([ PerlIO::get_layers(F) ], - [ qw(stdio utf8) ], - ":utf8"); - - binmode(F, ":bytes"); - - check([ PerlIO::get_layers(F) ], - [ "stdio" ], - ":bytes"); - - binmode(F, ":encoding(utf8)"); - - check([ PerlIO::get_layers(F) ], - [ qw[stdio encoding(utf8) utf8] ], - ":encoding(utf8)"); - - binmode(F, ":raw :crlf"); - - check([ PerlIO::get_layers(F) ], - [ qw(stdio crlf) ], - ":raw:crlf"); - - binmode(F, ":raw :encoding(latin1)"); # "latin1" will be canonized - - # 7 tests potentially skipped. - unless ($DOSISH || !$FASTSTDIO) { - my @results = PerlIO::get_layers(F, details => 1); - - # Get rid of the args and the flags. - splice(@results, 1, 2) if $NONSTDIO; - - check([ @results ], - [ "stdio", undef, sub { $_[0] > 0 }, - "encoding", "iso-8859-1", sub { $_[0] & PerlIO::F_UTF8() } ], - ":raw:encoding(latin1)"); - } - - binmode(F); - - check([ PerlIO::get_layers(F) ], - [ "stdio" ], - "binmode"); - - # RT78844 - { - local $@ = "foo"; - binmode(F, ":encoding(utf8)"); - is( $@, "foo", '$@ not clobbered by binmode and :encoding'); - } - - close F; - - { - use open(IN => ":crlf", OUT => ":encoding(cp1252)"); - - open F, '<', $afile; - open G, '>', $afile; - - diag ("perlcc issue 203"); # https://code.google.com/p/perl-compiler/issues/detail?id=203 - check([ PerlIO::get_layers(F, input => 1) ], - [ qw(stdio crlf) ], - "use open IN"); - - check([ PerlIO::get_layers(G, output => 1) ], - [ qw[stdio encoding(cp1252) utf8] ], - "use open OUT"); - - close F; - close G; - } - - # Check that PL_sigwarn's reference count is correct, and that - # &PerlIO::Layer::NoWarnings isn't prematurely freed. - fresh_perl_like (<<"EOT", qr/^CODE/); -open(UTF, "<:raw:encoding(utf8)", '$afile') or die \$!; -print ref *PerlIO::Layer::NoWarnings{CODE}; -EOT - - # TODO: not with 5.14 - # [perl #97956] Not calling FETCH all the time on tied variables - my $f; - sub TIESCALAR { bless [] } - sub FETCH { ++$f; $_[0][0] = $_[1] } - sub STORE { $_[0][0] } - tie my $t, ""; - SKIP: { - skip("requires 5.16", 3) if $] < 5.016; - - $t = *f; - $f = 0; PerlIO::get_layers $t; - is $f, 1, '1 fetch on tied glob'; - $t = \*f; - $f = 0; PerlIO::get_layers $t; - is $f, 1, '1 fetch on tied globref'; - $t = *f; - $f = 0; PerlIO::get_layers \$t; - is $f, 1, '1 fetch on referenced tied glob'; - } - $t = ''; - $f = 0; PerlIO::get_layers $t; - is $f, 1, '1 fetch on tied string'; - - SKIP: { - skip("requires 5.16", 3) if $] < 5.016; - # No distinction between nums and strings - open "12", "<:crlf", "t/test.pl" or die "$0 cannot open t/test.pl: $!"; - ok PerlIO::get_layers(12), 'str/num arguments are treated identically'; - } -} diff --git a/t/CORE/io/nargv.t b/t/CORE/io/nargv.t deleted file mode 100644 index 704b1026e..000000000 --- a/t/CORE/io/nargv.t +++ /dev/null @@ -1,73 +0,0 @@ -#!./perl - -BEGIN { - unshift @INC, 't/CORE/lib'; - require 't/CORE/test.pl'; -} - -print "1..5\n"; - -my $j = 1; -for $i ( 1,2,5,4,3 ) { - $file = mkfiles($i); - open(FH, "> $file") || die "can't create $file: $!"; - print FH "not ok " . $j++ . "\n"; - close(FH) || die "Can't close $file: $!"; -} - - -{ - local *ARGV; - local $^I = '.bak'; - local $_; - @ARGV = mkfiles(1..3); - $n = 0; - while (<>) { - print STDOUT "# initial \@ARGV: [@ARGV]\n"; - if ($n++ == 2) { - other(); - } - show(); - } -} - -$^I = undef; -@ARGV = mkfiles(1..3); -$n = 0; -while (<>) { - print STDOUT "#final \@ARGV: [@ARGV]\n"; - if ($n++ == 2) { - other(); - } - show(); -} - -sub show { - #warn "$ARGV: $_"; - s/^not //; - print; -} - -sub other { - no warnings 'once'; - print STDOUT "# Calling other\n"; - local *ARGV; - local *ARGVOUT; - local $_; - @ARGV = mkfiles(5, 4); - while (<>) { - print STDOUT "# inner \@ARGV: [@ARGV]\n"; - show(); - } -} - -my @files; -sub mkfiles { - foreach (@_) { - $files[$_] ||= tempfile(); - } - my @results = @files[@_]; - return wantarray ? @results : @results[-1]; -} - -END { unlink_all map { ($_, "$_.bak") } mkfiles(1..5) } diff --git a/t/CORE/io/open.t b/t/CORE/io/open.t deleted file mode 100644 index cb47e6cce..000000000 --- a/t/CORE/io/open.t +++ /dev/null @@ -1,357 +0,0 @@ -#!./perl - -BEGIN { - unshift @INC, 't/CORE/lib'; - require 't/CORE/test.pl'; -} - -$| = 1; -use warnings; -use Config; - -plan(114); - -my $Perl = which_perl(); - -my $afile = tempfile(); -{ - unlink($afile) if -f $afile; - - $! = 0; # the -f above will set $! if $afile doesn't exist. - ok( open(my $f,"+>$afile"), 'open(my $f, "+>...")' ); - - binmode $f; - ok( -f $afile, ' its a file'); - ok( (print $f "SomeData\n"), ' we can print to it'); - is( tell($f), 9, ' tell()' ); - ok( seek($f,0,0), ' seek set' ); - - $b = <$f>; - is( $b, "SomeData\n", ' readline' ); - ok( -f $f, ' still a file' ); - - eval { die "Message" }; - like( $@, qr/<\$f> line 1/, ' die message correct' ); - - ok( close($f), ' close()' ); - ok( unlink($afile), ' unlink()' ); -} - -{ - ok( open(my $f,'>', $afile), "open(my \$f, '>', $afile)" ); - ok( (print $f "a row\n"), ' print'); - ok( close($f), ' close' ); - ok( -s $afile < 10, ' -s' ); -} - -{ - ok( open(my $f,'>>', $afile), "open(my \$f, '>>', $afile)" ); - ok( (print $f "a row\n"), ' print' ); - ok( close($f), ' close' ); - ok( -s $afile > 10, ' -s' ); -} - -{ - ok( open(my $f, '<', $afile), "open(my \$f, '<', $afile)" ); - my @rows = <$f>; - is( scalar @rows, 2, ' readline, list context' ); - is( $rows[0], "a row\n", ' first line read' ); - is( $rows[1], "a row\n", ' second line' ); - ok( close($f), ' close' ); -} - -{ - ok( -s $afile < 20, '-s' ); - - ok( open(my $f, '+<', $afile), 'open +<' ); - my @rows = <$f>; - is( scalar @rows, 2, ' readline, list context' ); - ok( seek($f, 0, 1), ' seek cur' ); - ok( (print $f "yet another row\n"), ' print' ); - ok( close($f), ' close' ); - ok( -s $afile > 20, ' -s' ); - - unlink($afile); -} -{ - ok( open(my $f, '-|', <; - is( scalar @rows, 2, ' readline, list context' ); - ok( close($f), ' close' ); -} -{ - ok( open(my $f, '|-', <; - my $test = curr_test; - print $f "not ok $test - piped in\n"; - next_test(); - - $test = curr_test; - print $f "not ok $test - piped in\n"; - next_test(); - ok( close($f), ' close' ); - sleep 1; - pass('flushing'); -} - - -ok( !eval { open my $f, '<&', $afile; 1; }, '<& on a non-filehandle' ); -like( $@, qr/Bad filehandle:\s+$afile/, ' right error' ); - - -# local $file tests -{ - unlink($afile) if -f $afile; - - ok( open(local $f,"+>$afile"), 'open local $f, "+>", ...' ); - binmode $f; - - ok( -f $afile, ' -f' ); - ok( (print $f "SomeData\n"), ' print' ); - is( tell($f), 9, ' tell' ); - ok( seek($f,0,0), ' seek set' ); - - $b = <$f>; - is( $b, "SomeData\n", ' readline' ); - ok( -f $f, ' still a file' ); - - eval { die "Message" }; - like( $@, qr/<\$f> line 1/, ' proper die message' ); - ok( close($f), ' close' ); - - unlink($afile); -} - -{ - ok( open(local $f,'>', $afile), 'open local $f, ">", ...' ); - ok( (print $f "a row\n"), ' print'); - ok( close($f), ' close'); - ok( -s $afile < 10, ' -s' ); -} - -{ - ok( open(local $f,'>>', $afile), 'open local $f, ">>", ...' ); - ok( (print $f "a row\n"), ' print'); - ok( close($f), ' close'); - ok( -s $afile > 10, ' -s' ); -} - -{ - ok( open(local $f, '<', $afile), 'open local $f, "<", ...' ); - my @rows = <$f>; - is( scalar @rows, 2, ' readline list context' ); - ok( close($f), ' close' ); -} - -ok( -s $afile < 20, ' -s' ); - -{ - ok( open(local $f, '+<', $afile), 'open local $f, "+<", ...' ); - my @rows = <$f>; - is( scalar @rows, 2, ' readline list context' ); - ok( seek($f, 0, 1), ' seek cur' ); - ok( (print $f "yet another row\n"), ' print' ); - ok( close($f), ' close' ); - ok( -s $afile > 20, ' -s' ); - - unlink($afile); -} - -{ - ok( open(local $f, '-|', <; - - is( scalar @rows, 2, ' readline list context' ); - ok( close($f), ' close' ); -} - -{ - ok( open(local $f, '|-', <; - my $test = curr_test; - print $f "not ok $test - piping\n"; - next_test(); - - $test = curr_test; - print $f "not ok $test - piping\n"; - next_test(); - ok( close($f), ' close' ); - sleep 1; - pass("Flush"); -} - - -ok( !eval { open local $f, '<&', $afile; 1 }, 'local <& on non-filehandle'); -like( $@, qr/Bad filehandle:\s+$afile/, ' right error' ); - -{ - local *F; - for (1..2) { - ok( open(F, qq{$Perl -le "print 'ok'"|}), 'open to pipe' ); - is(scalar , "ok\n", ' readline'); - ok( close F, ' close' ); - } - - for (1..2) { - ok( open(F, "-|", qq{$Perl -le "print 'ok'"}), 'open -|'); - is( scalar , "ok\n", ' readline'); - ok( close F, ' close' ); - } -} - - -# other dupping techniques -{ - ok( open(my $stdout, ">&", \*STDOUT), 'dup \*STDOUT into lexical fh'); - ok( open(STDOUT, ">&", $stdout), 'restore dupped STDOUT from lexical fh'); - - { - use strict; # the below should not warn - ok( open(my $stdout, ">&", STDOUT), 'dup STDOUT into lexical fh'); - } - - # used to try to open a file [perl #17830] - ok( open(my $stdin, "<&", fileno STDIN), 'dup fileno(STDIN) into lexical fh') or _diag $!; -} - -SKIP: { - skip("This perl uses perlio", 1) if $Config{useperlio}; - # Force the reference to %! to be run time by writing ! as {"!"} - skip("This system doesn't understand EINVAL", 1) - unless exists ${"!"}{EINVAL}; - - no warnings 'io'; - ok(!open(F,'>',\my $s) && ${"!"}{EINVAL}, 'open(reference) raises EINVAL'); -} - -{ - ok( !eval { open F, "BAR", "QUUX" }, 'Unknown open() mode' ); - like( $@, qr/\QUnknown open() mode 'BAR'/, ' right error' ); -} - -TODO: { - local $TODO = q{Cannot expect to pass these tests once compiled, as they failed}; - - local $SIG{__WARN__} = sub { $@ = shift }; - - sub gimme { - my $tmphandle = shift; - my $line = scalar <$tmphandle>; - warn "gimme"; - return $line; - } - - open($fh0[0], "TEST"); - gimme($fh0[0]); - like($@, qr/<\$fh0\[...\]> line 1\./, "autoviv fh package aelem") or note($@); - - open($fh1{k}, "TEST"); - gimme($fh1{k}); - like($@, qr/<\$fh1{...}> line 1\./, "autoviv fh package helem") or note($@); - - my @fh2; - open($fh2[0], "TEST"); - gimme($fh2[0]); - like($@, qr/<\$fh2\[...\]> line 1\./, "autoviv fh lexical aelem") or note($@); - - my %fh3; - open($fh3{k}, "TEST"); - gimme($fh3{k}); - like($@, qr/<\$fh3{...}> line 1\./, "autoviv fh lexical helem") or note($@); -} - -SKIP: { - skip("These tests use perlio", 5) unless $Config{useperlio}; - my $w; - use warnings 'layer'; - local $SIG{__WARN__} = sub { $w = shift }; - - eval { open(F, ">>>", $afile) }; - like($w, qr/Invalid separator character '>' in PerlIO layer spec/, - "bad open (>>>) warning"); - like($@, qr/Unknown open\(\) mode '>>>'/, - "bad open (>>>) failure"); - - eval { open(F, ">:u", $afile ) }; - like($w, qr/Unknown PerlIO layer "u"/, - 'bad layer ">:u" warning'); - eval { open(F, "<:u", $afile ) }; - like($w, qr/Unknown PerlIO layer "u"/, - 'bad layer "<:u" warning'); - eval { open(F, ":c", $afile ) }; - like($@, qr/Unknown open\(\) mode ':c'/, - 'bad layer ":c" failure'); -} - -# [perl #28986] "open m" crashes Perl - -fresh_perl_like('open m', qr/Search pattern not terminated at/, - { stderr => 1, perlcc_only => 1 }, 'open m test'); - -fresh_perl_is( - 'sub f { open(my $fh, "xxx"); $fh = "f"; } f; f;print "ok"', - 'ok', { stderr => 1 }, - '#29102: Crash on assignment to lexical filehandle'); - -# [perl #31767] Using $1 as a filehandle via open $1, "file" doesn't raise -# an exception - -eval { open $99, "foo" }; -like($@, qr/Modification of a read-only value attempted/, "readonly fh"); - -# [perl#73626] mg_get wasn't run on the pipe arg - -{ - package p73626; - sub TIESCALAR { bless {} } - sub FETCH { "$Perl -e 1"} - - tie my $p, 'p73626'; - - package main; - - ok( open(my $f, '-|', $p), 'open -| magic'); -} - -# [perl #77492] Crash when stringifying a glob, a reference to which has -# been opened and written to. -fresh_perl_is( - ' - open my $fh, ">", \*STDOUT; - print $fh "hello"; - "".*STDOUT; - print "ok"; - close $fh; - unlink \*STDOUT; - ', - 'ok', { stderr => 1 }, - '[perl #77492]: open $fh, ">", \*glob causes SEGV'); - -# [perl #77684] Opening a reference to a glob copy. -{ - my $var = *STDOUT; - open my $fh, ">", \$var; - print $fh "hello"; - is($var, "hello", '[perl #77684]: open $fh, ">", \$glob_copy') - # when this fails, it leaves an extra file: - or unlink \*STDOUT; -} - -# check that we can call methods on filehandles auto-magically -# and have IO::File loaded for us -is( $INC{'IO/File.pm'}, undef, "IO::File not loaded" ); -my $var = ""; -open my $fh, ">", \$var; -ok( eval { $fh->autoflush(1); 1 }, '$fh->autoflush(1) lives' ); -ok( $INC{'IO/File.pm'}, "IO::File now loaded" ); diff --git a/t/CORE/io/openpid.t b/t/CORE/io/openpid.t deleted file mode 100644 index 82529aca3..000000000 --- a/t/CORE/io/openpid.t +++ /dev/null @@ -1,83 +0,0 @@ -#!./perl - -##################################################################### -# -# Test for process id return value from open -# Ronald Schmidt (The Software Path) RonaldWS@software-path.com -# -##################################################################### - -BEGIN { - unshift @INC, 't/CORE/lib'; - require 't/CORE/test.pl'; -} - -if ($^O eq 'dos') { - skip_all("no multitasking"); -} - -plan tests => 10; -watchdog(15, $^O eq 'MSWin32' ? "alarm" : ''); - -use Config; -$| = 1; -$SIG{PIPE} = 'IGNORE'; -$SIG{HUP} = 'IGNORE' if $^O eq 'interix'; - -my $perl = which_perl(); -$perl .= qq[ "-I../lib"]; - -# -# commands run 4 perl programs. Two of these programs write a -# short message to STDOUT and exit. Two of these programs -# read from STDIN. One reader never exits and must be killed. -# the other reader reads one line, waits a few seconds and then -# exits to test the waitpid function. -# -$cmd1 = qq/$perl -e "\$|=1; print qq[first process\\n]; sleep 30;"/; -$cmd2 = qq/$perl -e "\$|=1; print qq[second process\\n]; sleep 30;"/; -$cmd3 = qq/$perl -e "print <>;"/; # hangs waiting for end of STDIN -$cmd4 = qq/$perl -e "print scalar <>;"/; - -#warn "#$cmd1\n#$cmd2\n#$cmd3\n#$cmd4\n"; - -# start the processes -ok( $pid1 = open(FH1, "$cmd1 |"), 'first process started'); -ok( $pid2 = open(FH2, "$cmd2 |"), ' second' ); -{ - no warnings 'once'; - ok( $pid3 = open(FH3, "| $cmd3"), ' third' ); -} -ok( $pid4 = open(FH4, "| $cmd4"), ' fourth' ); - -print "# pids were $pid1, $pid2, $pid3, $pid4\n"; - -my $killsig = 'HUP'; -$killsig = 1 unless $Config{sig_name} =~ /\bHUP\b/; - -# get message from first process and kill it -chomp($from_pid1 = scalar()); -is( $from_pid1, 'first process', 'message from first process' ); - -$kill_cnt = kill $killsig, $pid1; -is( $kill_cnt, 1, 'first process killed' ) || - print "# errno == $!\n"; - -# get message from second process and kill second process and reader process -chomp($from_pid2 = scalar()); -is( $from_pid2, 'second process', 'message from second process' ); - -$kill_cnt = kill $killsig, $pid2, $pid3; -is( $kill_cnt, 2, 'killing procs 2 & 3' ) || - print "# errno == $!\n"; - - -# send one expected line of text to child process and then wait for it -select(FH4); $| = 1; select(STDOUT); - -printf FH4 "ok %d - text sent to fourth process\n", curr_test(); -next_test(); -print "# waiting for process $pid4 to exit\n"; -$reap_pid = waitpid $pid4, 0; -is( $reap_pid, $pid4, 'fourth process reaped' ); - diff --git a/t/CORE/io/perlio.t b/t/CORE/io/perlio.t deleted file mode 100644 index a66c689eb..000000000 --- a/t/CORE/io/perlio.t +++ /dev/null @@ -1,207 +0,0 @@ -BEGIN { - unshift @INC, 't/CORE/lib'; - require Config; import Config; - require 't/CORE/test.pl'; -} - -plan tests => 44; - -use_ok('PerlIO'); - -my $txt = "txt$$"; -my $bin = "bin$$"; -my $utf = "utf$$"; -my $nonexistent = "nex$$"; - -my $txtfh; -my $binfh; -my $utffh; - -ok(open($txtfh, ">:crlf", $txt)); - -ok(open($binfh, ">:raw", $bin)); - -ok(open($utffh, ">:utf8", $utf)); - -print $txtfh "foo\n"; -print $txtfh "bar\n"; - -ok(close($txtfh)); - -print $binfh "foo\n"; -print $binfh "bar\n"; - -ok(close($binfh)); - -print $utffh "foo\x{ff}\n"; -print $utffh "bar\x{abcd}\n"; - -ok(close($utffh)); - -ok(open($txtfh, "<:crlf", $txt)); - -ok(open($binfh, "<:raw", $bin)); - - -ok(open($utffh, "<:utf8", $utf)); - -is(scalar <$txtfh>, "foo\n"); -is(scalar <$txtfh>, "bar\n"); - -is(scalar <$binfh>, "foo\n"); -is(scalar <$binfh>, "bar\n"); - -is(scalar <$utffh>, "foo\x{ff}\n"); -is(scalar <$utffh>, "bar\x{abcd}\n"); - -ok(eof($txtfh));; - -ok(eof($binfh)); - -ok(eof($utffh)); - -ok(close($txtfh)); - -ok(close($binfh)); - -ok(close($utffh)); - -# magic temporary file via 3 arg open with undef -{ - ok( open(my $x,"+<",undef), 'magic temp file via 3 arg open with undef'); - ok( defined fileno($x), ' fileno' ); - - select $x; - ok( (print "ok\n"), ' print' ); - - select STDOUT; - ok( seek($x,0,0), ' seek' ); - is( scalar <$x>, "ok\n", ' readline' ); - ok( tell($x) >= 3, ' tell' ); - - # test magic temp file over STDOUT - open OLDOUT, ">&STDOUT" or die "cannot dup STDOUT: $!"; - my $status = open(STDOUT,"+<",undef); - open STDOUT, ">&OLDOUT" or die "cannot dup OLDOUT: $!"; - # report after STDOUT is restored - ok($status, ' re-open STDOUT'); - close OLDOUT; - - SKIP: { - skip("TMPDIR not honored on this platform", 4) - if !$Config{d_mkstemp} - || $^O eq 'VMS' || $^O eq 'MSwin32' || $^O eq 'os2'; - local $ENV{TMPDIR} = $nonexistent; - - # hardcoded default temp path - my $perlio_tmp_file_glob = '/tmp/PerlIO_??????'; - - ok( open(my $x,"+<",undef), 'TMPDIR honored by magic temp file via 3 arg open with undef - works if TMPDIR points to a non-existent dir'); - - my $filename = find_filename($x, $perlio_tmp_file_glob); - is($filename, undef, "No tmp files leaked"); - unlink_all $filename if defined $filename; - - mkdir $ENV{TMPDIR}; - ok(open(my $x,"+<",undef), 'TMPDIR honored by magic temp file via 3 arg open with undef - works if TMPDIR points to an existent dir'); - - $filename = find_filename($x, $perlio_tmp_file_glob); - is($filename, undef, "No tmp files leaked"); - unlink_all $filename if defined $filename; - } -} - -sub find_filename { - my ($fh, @globs) = @_; - my ($dev, $inode) = stat $fh; - die "Can't stat $fh: $!" unless defined $dev; - - foreach (@globs) { - foreach my $file (glob $_) { - my ($this_dev, $this_inode) = stat $file; - next unless defined $this_dev; - return $file if $this_dev == $dev && $this_inode == $inode; - } - } - return; -} - -# in-memory open -SKIP: { - eval { require PerlIO::scalar }; - unless (find PerlIO::Layer 'scalar') { - skip("PerlIO::scalar not found", 9); - } - my $var; - ok( open(my $x,"+<",\$var), 'magic in-memory file via 3 arg open with \\$var'); - ok( defined fileno($x), ' fileno' ); - - select $x; - ok( (print "ok\n"), ' print' ); - - select STDOUT; - ok( seek($x,0,0), ' seek' ); - is( scalar <$x>, "ok\n", ' readline' ); - ok( tell($x) >= 3, ' tell' ); - - TODO: { - local $TODO = "broken"; - - # test in-memory open over STDOUT - open OLDOUT, ">&STDOUT" or die "cannot dup STDOUT: $!"; - #close STDOUT; - my $status = open(STDOUT,">",\$var); - my $error = "$!" unless $status; # remember the error - close STDOUT unless $status; - open STDOUT, ">&OLDOUT" or die "cannot dup OLDOUT: $!"; - print "# $error\n" unless $status; - # report after STDOUT is restored - ok($status, ' open STDOUT into in-memory var'); - - # test in-memory open over STDERR - open OLDERR, ">&STDERR" or die "cannot dup STDERR: $!"; - #close STDERR; - ok( open(STDERR,">",\$var), ' open STDERR into in-memory var'); - open STDERR, ">&OLDERR" or die "cannot dup OLDERR: $!"; - } - - -{ local $TODO = 'fails well back into 5.8.x'; - - -sub read_fh_and_return_final_rv { - my ($fh) = @_; - my $buf = ''; - my $rv; - for (1..3) { - $rv = read($fh, $buf, 1, length($buf)); - next if $rv; - } - return $rv -} - -open(my $no_perlio, '<', \'ab') or die; -open(my $perlio, '<:crlf', \'ab') or die; - -is(read_fh_and_return_final_rv($perlio), read_fh_and_return_final_rv($no_perlio), "RT#69332 - perlio should return the same value as nonperlio after EOF"); - -close ($perlio); -close ($no_perlio); -} - -{ # [perl #92258] - open my $fh, "<", \(my $f = *f); - is join("", <$fh>), '*main::f', 'reading from a glob copy'; - is ref \$f, 'GLOB', 'the glob copy is unaffected'; -} - -} - - -END { - unlink_all $txt; - unlink_all $bin; - unlink_all $utf; - rmdir $nonexistent; -} - diff --git a/t/CORE/io/perlio_fail.t b/t/CORE/io/perlio_fail.t deleted file mode 100644 index cee315d80..000000000 --- a/t/CORE/io/perlio_fail.t +++ /dev/null @@ -1,47 +0,0 @@ -#!./perl - -BEGIN { - unshift @INC, 't/CORE/lib'; - require 't/CORE/test.pl'; -} - -plan (15); - -use warnings 'layer'; -my $warn; -my $file = "fail$$"; -$SIG{__WARN__} = sub { $warn = shift }; - -END { 1 while unlink($file) } - -ok(open(FH,">",$file),"Create works"); -close(FH); -ok(open(FH,"<",$file),"Normal open works"); - -$warn = ''; $! = 0; -ok(!binmode(FH,":-)"),"All punctuation fails binmode"); -print "# $!\n"; -isnt($!,0,"Got errno"); -like($warn,qr/in PerlIO layer/,"Got warning"); - -$warn = ''; $! = 0; -ok(!binmode(FH,":nonesuch"),"Bad package fails binmode"); -print "# $!\n"; -isnt($!,0,"Got errno"); -like($warn,qr/nonesuch/,"Got warning"); -close(FH); - -$warn = ''; $! = 0; -ok(!open(FH,"<:-)",$file),"All punctuation fails open"); -print "# $!\n"; -isnt($!,"","Got errno"); -like($warn,qr/in PerlIO layer/,"Got warning"); - -$warn = ''; $! = 0; -ok(!open(FH,"<:nonesuch",$file),"Bad package fails open"); -print "# $!\n"; -isnt($!,0,"Got errno"); -like($warn,qr/nonesuch/,"Got warning"); - -ok(open(FH,"<",$file),"Normal open (still) works"); -close(FH); diff --git a/t/CORE/io/perlio_leaks.t b/t/CORE/io/perlio_leaks.t deleted file mode 100644 index b6eacf474..000000000 --- a/t/CORE/io/perlio_leaks.t +++ /dev/null @@ -1,33 +0,0 @@ -#!perl -# ioleaks.t - -BEGIN { - require 't/CORE/test.pl'; -} - -use strict; -use warnings; -plan 'no_plan'; - -# :unix -> not ok -# :stdio -> not ok -# :perlio -> ok -# :crlf -> ok - -TODO: { - foreach my $layer(qw(:unix :stdio :perlio :crlf)){ - my $base_fd = do{ open my $in, '<', $0 or die $!; fileno $in }; - - for(1 .. 3){ - local $::TODO; - if ($_ > 1 && $layer =~ /^:(unix|stdio)$/) { - $::TODO = "[perl #56644] PerlIO resource leaks on open() and then :pop in :unix and :stdio" - } - open my $fh, "<$layer", $0 or die $!; - - is fileno($fh), $base_fd, $layer; - binmode $fh, ':pop'; - } - } -} - diff --git a/t/CORE/io/perlio_open.t b/t/CORE/io/perlio_open.t deleted file mode 100644 index 8901b223c..000000000 --- a/t/CORE/io/perlio_open.t +++ /dev/null @@ -1,33 +0,0 @@ -#!./perl - -BEGIN { - unshift @INC, 't/CORE/lib'; - require 't/CORE/test.pl'; -} - -use strict; -use warnings; - -plan tests => 6; - -use Fcntl qw(:seek); - -{ - ok((open my $fh, "+>", undef), "open my \$fh, '+>', undef"); - print $fh "the right write stuff"; - ok(seek($fh, 0, SEEK_SET), "seek to zero"); - my $data = <$fh>; - is($data, "the right write stuff", "found the right stuff"); -} - -{ - ok((open my $fh, "+<", undef), "open my \$fh, '+<', undef"); - print $fh "the right read stuff"; - ok(seek($fh, 0, SEEK_SET), "seek to zero"); - my $data = <$fh>; - is($data, "the right read stuff", "found the right stuff"); -} - - - - diff --git a/t/CORE/io/pipe.t b/t/CORE/io/pipe.t deleted file mode 100644 index 28a09f49f..000000000 --- a/t/CORE/io/pipe.t +++ /dev/null @@ -1,250 +0,0 @@ -#!./perl - -BEGIN { - unshift @INC, 't/CORE/lib'; - require 't/CORE/test.pl'; -} - -INIT { - require Config; import Config; - if (!$Config{'d_fork'}) { - skip_all("fork required to pipe"); - } - else { - plan(24); - } -} - -my $Perl = which_perl(); - - -$| = 1; - -open(my $PIPE, "|-") || exec $Perl, '-pe', 'tr/YX/ko/'; - -printf $PIPE "Xk %d - open |- || exec\n", curr_test(); -next_test(); -printf $PIPE "oY %d - again\n", curr_test(); -next_test(); -close $PIPE; - -SKIP: { - # Technically this should be TODO. Someone try it if you happen to - # have a vmesa machine. - skip("Doesn't work here yet", 6) if $^O eq 'vmesa'; - - if (open($PIPE, "-|")) { - while(<$PIPE>) { - s/^not //; - print; - } - close $PIPE; # avoid zombies - } - else { - printf STDOUT "not ok %d - open -|\n", curr_test(); - next_test(); - my $tnum = curr_test; - next_test(); - exec $Perl, '-le', "print q{not ok $tnum - again}"; - } - - print("# checkpoint 1\n"); - - # This has to be *outside* the fork - next_test() for 1..2; - - print("# checkpoint 2\n"); - - my $raw = "abc\nrst\rxyz\r\nfoo\n"; - if (open($PIPE, "-|")) { - $_ = join '', <$PIPE>; - (my $raw1 = $_) =~ s/not ok \d+ - //; - my @r = map ord, split //, $raw; - my @r1 = map ord, split //, $raw1; - if ($raw1 eq $raw) { - s/^not (ok \d+ -) .*/$1 '@r1' passes through '-|'\n/s; - } else { - s/^(not ok \d+ -) .*/$1 expect '@r', got '@r1'\n/s; - } - print; - close $PIPE; # avoid zombies - } - else { - printf STDOUT "not ok %d - $raw", curr_test(); - exec $Perl, '-e0'; # Do not run END()... - } - - print "# checkpoint 3\n"; - - # This has to be *outside* the fork - next_test(); - - if (open($PIPE, "|-")) { - printf $PIPE "not ok %d - $raw", curr_test(); - close $PIPE; # avoid zombies - } - else { - $_ = join '', ; - (my $raw1 = $_) =~ s/not ok \d+ - //; - my @r = map ord, split //, $raw; - my @r1 = map ord, split //, $raw1; - if ($raw1 eq $raw) { - s/^not (ok \d+ -) .*/$1 '@r1' passes through '|-'\n/s; - } else { - s/^(not ok \d+ -) .*/$1 expect '@r', got '@r1'\n/s; - } - print; - exec $Perl, '-e0'; # Do not run END()... - } - - # This has to be *outside* the fork - next_test(); - - SKIP: { - skip("fork required", 2) unless $Config{d_fork}; - - pipe(READER,WRITER) || die "Can't open pipe"; - - if ($pid = fork) { - close WRITER; - while() { - s/^not //; - y/A-Z/a-z/; - print; - } - close READER; # avoid zombies - } - else { - die "Couldn't fork" unless defined $pid; - close READER; - printf WRITER "not ok %d - pipe & fork\n", curr_test; - next_test(); - - open(STDOUT,">&WRITER") || die "Can't dup WRITER to STDOUT"; - close WRITER; - - my $tnum = curr_test; - next_test(); - exec $Perl, '-le', "print q{not ok $tnum - with fh dup }"; - } - - # This has to be done *outside* the fork. - next_test() for 1..2; - } -} -wait; # Collect from $pid - -pipe(READER,WRITER) || die "Can't open pipe"; -close READER; - -$SIG{'PIPE'} = 'broken_pipe'; - -sub broken_pipe { - $SIG{'PIPE'} = 'IGNORE'; # loop preventer - printf "ok %d - SIGPIPE\n", curr_test; -} - -printf WRITER "not ok %d - SIGPIPE\n", curr_test; -close WRITER; -sleep 1; -next_test(); -pass(); - -# VMS doesn't like spawning subprocesses that are still connected to -# STDOUT. Someone should modify these tests to work with VMS. - -SKIP: { - skip("doesn't like spawning subprocesses that are still connected", 10) - if $^O eq 'VMS'; - - SKIP: { - # Sfio doesn't report failure when closing a broken pipe - # that has pending output. Go figure. - # BeOS will not write to broken pipes, either. - # Nor does POSIX-BC. - skip("Won't report failure on broken pipe", 1) - if $Config{d_sfio} || $^O eq 'beos' || - $^O eq 'posix-bc'; - - local $SIG{PIPE} = 'IGNORE'; - open NIL, qq{|$Perl -e "exit 0"} or die "open failed: $!"; - sleep 5; - if (print NIL 'foo') { - # If print was allowed we had better get an error on close - ok( !close NIL, 'close error on broken pipe' ); - } - else { - ok(close NIL, 'print failed on broken pipe'); - } - } - - SKIP: { - skip("Don't work yet", 9) if $^O eq 'vmesa'; - - # check that errno gets forced to 0 if the piped program exited - # non-zero - open NIL, qq{|$Perl -e "exit 23";} or die "fork failed: $!"; - $! = 1; - ok(!close NIL, 'close failure on non-zero piped exit'); - is($!, '', ' errno'); - isnt($?, 0, ' status'); - - SKIP: { - skip("Don't work yet", 6) if $^O eq 'mpeix'; - - # check that status for the correct process is collected - my $zombie; - unless( $zombie = fork ) { - $NO_ENDING=1; - exit 37; - } - my $pipe = open *FH, "sleep 2;exit 13|" or die "Open: $!\n"; - $SIG{ALRM} = sub { return }; - alarm(1); - is( close FH, '', 'close failure for... umm, something' ); - print "# checkpoint 4\n"; - is( $?, 13*256, ' status' ); - is( $!, '', ' errno'); - print "# checkpoint 5\n"; - my $wait = wait; - is( $?, 37*256, 'status correct after wait' ); - is( $wait, $zombie, ' wait pid' ); - is( $!, '', ' errno'); - } - } -} - -# Test new semantics for missing command in piped open -# 19990114 M-J. Dominus mjd@plover.com -{ local *P; - no warnings 'pipe'; - ok( !open(P, "| "), 'missing command in piped open input' ); - ok( !open(P, " |"), ' output'); -} - -# check that status is unaffected by implicit close -{ - local(*NIL); - open NIL, qq{|$Perl -e "exit 23"} or die "fork failed: $!"; - $? = 42; - # NIL implicitly closed here -} -is($?, 42, 'status unaffected by implicit close'); -$? = 0; - -# check that child is reaped if the piped program can't be executed -SKIP: { - skip("/no_such_process exists", 1) if -e "/no_such_process"; - open NIL, '/no_such_process |'; - close NIL; - - my $child = 0; - eval { - local $SIG{ALRM} = sub { die; }; - alarm 2; - $child = wait; - alarm 0; - }; - - is($child, -1, 'child reaped if piped program cannot be executed'); -} diff --git a/t/CORE/io/print.t b/t/CORE/io/print.t deleted file mode 100644 index 18bb63fcb..000000000 --- a/t/CORE/io/print.t +++ /dev/null @@ -1,62 +0,0 @@ -#!./perl - -use Errno; -INIT { - unshift @INC, 't/CORE/lib'; - require 't/CORE/test.pl'; -} - -use strict 'vars'; - -print "1..21\n"; - -my $foo = 'STDOUT'; -print $foo "ok 1\n"; - -print "ok 2\n","ok 3\n","ok 4\n"; -print STDOUT "ok 5\n"; - -open(my $foo_fh,">-"); -print $foo_fh "ok 6\n"; - -printf "ok %d\n",7; -printf("ok %d\n",8); - -my @a = ("ok %d%c",9,ord("\n")); -printf @a; - -$a[1] = 10; -printf STDOUT @a; - -$, = ' '; -$\ = "\n"; - -print "ok","11"; - -my @x = ("ok","12\nok","13\nok"); -my @y = ("15\nok","16"); -print @x,"14\nok",@y; -{ - local $\ = "ok 17\n# null =>[\000]\nok 18\n"; - print ""; -} - -$\ = ''; - -$! = 0; -no warnings 'unopened'; -print NONEXISTENT "foo"; -print "not " if ($! != &Errno::EBADF); -print "ok 19\n"; - -{ - # Change 26009: pp_print didn't extend the stack - # before pushing its return value - # to make sure only that these obfuscated sentences will not crash. - - map print(reverse), ('')x68; - print "ok 20\n"; - - map print(+()), ('')x68; - print "ok 21\n"; -} diff --git a/t/CORE/io/pvbm.t b/t/CORE/io/pvbm.t deleted file mode 100644 index 10bed1aef..000000000 --- a/t/CORE/io/pvbm.t +++ /dev/null @@ -1,83 +0,0 @@ -#!./perl - -# Test that various IO functions don't try to treat PVBMs as -# filehandles. Most of these will segfault perl if they fail. - -INIT { - unshift @INC, "./lib"; - require 't/CORE/test.pl'; -} - -INIT { $| = 1 } - -plan(28); - -sub PVBM () { 'foo' } -#{ my $dummy = index 'foo', PVBM } - -{ - my $which; - { - package Tie; - - sub TIEHANDLE { $which = 'TIEHANDLE' } - sub TIESCALAR { $which = 'TIESCALAR' } - } - my $pvbm = PVBM(); - - tie $pvbm, 'Tie'; - is ($which, 'TIESCALAR', 'PVBM gets TIESCALAR'); -} - -{ - my $pvbm = PVBM(); - ok (scalar eval { untie $pvbm; 1 }, 'untie(PVBM) doesn\'t segfault'); - ok (scalar eval { tied $pvbm; 1 }, 'tied(PVBM) doesn\'t segfault'); -} - -{ - my $pvbm = PVBM(); - - ok (scalar eval { pipe $pvbm, PIPE; }, 'pipe(PVBM, ) succeeds'); - close foo; - close PIPE; - ok (scalar eval { pipe PIPE, $pvbm; }, 'pipe(, PVBM) succeeds'); - close foo; - close PIPE; - ok (!eval { pipe \$pvbm, PIPE; }, 'pipe(PVBM ref, ) fails'); - ok (!eval { pipe PIPE, \$pvbm; }, 'pipe(, PVBM ref) fails'); - - ok (!eval { truncate $pvbm, 0 }, 'truncate(PVBM) fails'); - ok (!eval { truncate \$pvbm, 0}, 'truncate(PVBM ref) fails'); - - ok (!eval { stat $pvbm }, 'stat(PVBM) fails'); - ok (!eval { stat \$pvbm }, 'stat(PVBM ref) fails'); - - ok (!eval { lstat $pvbm }, 'lstat(PVBM) fails'); - ok (!eval { lstat \$pvbm }, 'lstat(PVBM ref) fails'); - - ok (!eval { chdir $pvbm }, 'chdir(PVBM) fails'); - ok (!eval { chdir \$pvbm }, 'chdir(pvbm ref) fails'); - - ok (!eval { close $pvbm }, 'close(PVBM) fails'); - ok (!eval { close $pvbm }, 'close(PVBM ref) fails'); - - ok (!eval { chmod 0600, $pvbm }, 'chmod(PVBM) fails'); - ok (!eval { chmod 0600, \$pvbm }, 'chmod(PVBM ref) fails'); - - SKIP: { - skip('chown() not implemented on Win32', 2) if $^O eq 'MSWin32'; - ok (!eval { chown 0, 0, $pvbm }, 'chown(PVBM) fails'); - ok (!eval { chown 0, 0, \$pvbm }, 'chown(PVBM ref) fails'); - } - - ok (!eval { utime 0, 0, $pvbm }, 'utime(PVBM) fails'); - ok (!eval { utime 0, 0, \$pvbm }, 'utime(PVBM ref) fails'); - - ok (!eval { <$pvbm> }, ' fails'); - ok (!eval { readline $pvbm }, 'readline(PVBM) fails'); - ok (!eval { readline \$pvbm }, 'readline(PVBM ref) fails'); - - ok (!eval { open $pvbm, '<', 'none.such' }, 'open(PVBM) fails'); - ok (!eval { open \$pvbm, '<', 'none.such', }, 'open(PVBM ref) fails'); -} diff --git a/t/CORE/io/read.t b/t/CORE/io/read.t deleted file mode 100644 index 64aa92635..000000000 --- a/t/CORE/io/read.t +++ /dev/null @@ -1,31 +0,0 @@ -#!./perl - -use Errno; -BEGIN { - unshift @INC, 't/CORE/lib'; - require 't/CORE/test.pl'; -} - -use strict; - -plan tests => 2; - -my $tmpfile = tempfile(); - -open(A,"+>$tmpfile"); -print A "_"; -seek(A,0,0); - -my $b = "abcd"; -$b = ""; - -read(A,$b,1,4); - -close(A); - -is($b,"\000\000\000\000_"); # otherwise probably "\000bcd_" - -$! = 0; -no warnings 'unopened'; -read(B,$b,1); -ok($! == &Errno::EBADF); diff --git a/t/CORE/io/say.t b/t/CORE/io/say.t deleted file mode 100644 index 420146189..000000000 --- a/t/CORE/io/say.t +++ /dev/null @@ -1,49 +0,0 @@ -#!./perl - -use Errno; -BEGIN { - unshift @INC, 't/CORE/lib'; - require 't/CORE/test.pl'; -} - -# Just a few very basic tests cribbed from t/io/print.t, -# with some minor additions. say is actually compiled to -# a print opcode, so it's more or less guaranteed to behave -# the same way as print in any case. - -use strict 'vars'; -use feature "say"; - -say "1..12"; - -my $foo = 'STDOUT'; -say $foo "ok 1"; - -say "ok 2\n","ok 3\n","ok 4"; -say STDOUT "ok 5"; - -open(FOO,">-"); -say FOO "ok 6"; - -open(my $bar,">-"); -say $bar "ok 7"; - -say {"STDOUT"} "ok 8"; - -$! = 0; -no warnings 'unopened'; -say NONEXISTENT "foo"; -print "not " if ($! != &Errno::EBADF); -say "ok 9"; - -$_ = "ok 10"; -say; - -$_ = "ok 11"; -say STDOUT; - -{ - # test that $, doesn't show up before the trailing \n - local $, = "\nnot ok 13"; # how to fool Test::Harness - say "ok 12"; -} diff --git a/t/CORE/io/tell.t b/t/CORE/io/tell.t deleted file mode 100644 index 2463bbda4..000000000 --- a/t/CORE/io/tell.t +++ /dev/null @@ -1,161 +0,0 @@ -#!./perl - -INIT { - unshift @INC, 't/CORE/lib'; - require 't/CORE/test.pl'; -} - -print "1..28\n"; - -$TST = 'TST'; - -$Is_Dosish = ($^O eq 'MSWin32' or $^O eq 'NetWare' or $^O eq 'dos' or - $^O eq 'os2' or $^O eq 'cygwin' or - $^O =~ /^uwin/); - -open($TST, 't/CORE/test.pl') || (die "Can't open harness"); -binmode $TST if $Is_Dosish; -if (eof(TST)) { print "not ok 1\n"; } else { print "ok 1\n"; } - -$firstline = <$TST>; -$secondpos = tell; - -$x = 0; -while () { - if (eof) {$x++;} -} -if ($x == 1) { print "ok 2\n"; } else { print "not ok 2\n"; } - -$lastpos = tell; - -unless (eof) { print "not ok 3\n"; } else { print "ok 3\n"; } - -if (seek($TST,0,0)) { print "ok 4\n"; } else { print "not ok 4\n"; } - -if (eof) { print "not ok 5\n"; } else { print "ok 5\n"; } - -if ($firstline eq ) { print "ok 6\n"; } else { print "not ok 6\n"; } - -if ($secondpos == tell) { print "ok 7\n"; } else { print "not ok 7\n"; } - -if (seek(TST,0,1)) { print "ok 8\n"; } else { print "not ok 8\n"; } - -if (eof($TST)) { print "not ok 9\n"; } else { print "ok 9\n"; } - -if ($secondpos == tell) { print "ok 10\n"; } else { print "not ok 10\n"; } - -if (seek(TST,0,2)) { print "ok 11\n"; } else { print "not ok 11\n"; } - -if ($lastpos == tell) { print "ok 12\n"; } else { print "not ok 12\n"; } - -unless (eof) { print "not ok 13\n"; } else { print "ok 13\n"; } - -if ($. == 0) { print "not ok 14\n"; } else { print "ok 14\n"; } - -$curline = $.; -open(OTHER, 't/CORE/test.pl') || (die "Can't open harness: $!"); -binmode OTHER if (($^O eq 'MSWin32') || ($^O eq 'NetWare')); - -{ - local($.); - - if ($. == 0) { print "not ok 15\n"; } else { print "ok 15\n"; } - - tell OTHER; - if ($. == 0) { print "ok 16\n"; } else { print "not ok 16\n"; } - - $. = 5; - scalar ; - if ($. == 6) { print "ok 17\n"; } else { print "not ok 17\n"; } -} - -if ($. == $curline) { print "ok 18\n"; } else { print "not ok 18\n"; } - -{ - local($.); - - scalar ; - if ($. == 7) { print "ok 19\n"; } else { print "not ok 19\n"; } -} - -if ($. == $curline) { print "ok 20\n"; } else { print "not ok 20\n"; } - -{ - local($.); - - tell OTHER; - if ($. == 7) { print "ok 21\n"; } else { print "not ok 21\n"; } -} - -close(OTHER); -{ - no warnings 'closed'; - if (tell(OTHER) == -1) { print "ok 22\n"; } else { print "not ok 22\n"; } -} -{ - no warnings 'unopened'; - if (tell(ETHER) == -1) { print "ok 23\n"; } else { print "not ok 23\n"; } -} - -# ftell(STDIN) (or any std streams) is undefined, it can return -1 or -# something else. ftell() on pipes, fifos, and sockets is defined to -# return -1. - -my $written = tempfile(); - -close($TST); -open($tst,">$written") || die "Cannot open $written:$!"; -binmode $tst if $Is_Dosish; - -if (tell($tst) == 0) { print "ok 24\n"; } else { print "not ok 24\n"; } - -print $tst "fred\n"; - -if (tell($tst) == 5) { print "ok 25\n"; } else { print "not ok 25\n"; } - -print $tst "more\n"; - -if (tell($tst) == 10) { print "ok 26\n"; } else { print "not ok 26\n"; } - -close($tst); - -open($tst,"+>>$written") || die "Cannot open $written:$!"; -binmode $tst if $Is_Dosish; - -if (0) -{ - # :stdio does not pass these so ignore them for now - -if (tell($tst) == 0) { print "ok 27\n"; } else { print "not ok 27\n"; } - -$line = <$tst>; - -if ($line eq "fred\n") { print "ok 29\n"; } else { print "not ok 29\n"; } - -if (tell($tst) == 5) { print "ok 30\n"; } else { print "not ok 30\n"; } - -} - -print $tst "xxxx\n"; - -if (tell($tst) == 15 || - tell($tst) == 5) # unset PERLIO or PERLIO=stdio (e.g. HP-UX, Solaris) -{ print "ok 27\n"; } else { print "not ok 27\n"; } - -close($tst); - -open($tst,">$written") || die "Cannot open $written:$!"; -print $tst "foobar"; -close $tst; -open($tst,">>$written") || die "Cannot open $written:$!"; - -# This test makes a questionable assumption that the file pointer will -# be at eof after opening a file but before seeking, reading, or writing. -# Only known failure is on cygwin. -my $todo = $^O eq "cygwin" && &PerlIO::get_layers($tst) eq 'stdio' - && ' # TODO: file pointer not at eof'; - -if (tell($tst) == 6) -{ print "ok 28$todo\n"; } else { print "not ok 28$todo\n"; } -close $tst; - diff --git a/t/CORE/io/through.t b/t/CORE/io/through.t deleted file mode 100644 index 745e85ccf..000000000 --- a/t/CORE/io/through.t +++ /dev/null @@ -1,147 +0,0 @@ -#!./perl - -BEGIN { - unshift @INC, 't/CORE/lib'; - require 't/CORE/test.pl'; -} - -skip_all("VMS too picky about line endings for record-oriented pipes") - if $^O eq 'VMS'; - -plan(942); - -use strict; - -my $Perl = which_perl(); - -my $data = <<'EOD'; -x - yy -z -EOD - -(my $data2 = $data) =~ s/\n/\n\n/g; - -my $t1 = { data => $data, write_c => [1,2,length $data], read_c => [1,2,3,length $data]}; -my $t2 = { data => $data2, write_c => [1,2,length $data2], read_c => [1,2,3,length $data2]}; - -$_->{write_c} = [1..length($_->{data})], - $_->{read_c} = [1..length($_->{data})+1, 0xe000] # Need <0xffff for REx - for (); # $t1, $t2; - -my $c; # len write tests, for each: one _all test, and 3 each len+2 -$c += @{$_->{write_c}} * (1 + 3*@{$_->{read_c}}) for $t1, $t2; -$c *= 3*2*2; # $how_w, file/pipe, 2 reports - -$c += 6; # Tests with sleep()... - -#print "1..$c\n"; - -my $set_out = ''; -$set_out = "binmode STDOUT, ':crlf'" - if defined $main::use_crlf && $main::use_crlf == 1; - -sub testread ($$$$$$$) { - my ($fh, $str, $read_c, $how_r, $write_c, $how_w, $why) = @_; - my $buf = ''; - if ($how_r eq 'readline_all') { - $buf .= $_ while <$fh>; - } elsif ($how_r eq 'readline') { - $/ = \$read_c; - $buf .= $_ while <$fh>; - } elsif ($how_r eq 'read') { - my($in, $c); - $buf .= $in while $c = read($fh, $in, $read_c); - } elsif ($how_r eq 'sysread') { - my($in, $c); - $buf .= $in while $c = sysread($fh, $in, $read_c); - } else { - die "Unrecognized read: '$how_r'"; - } - close $fh or die "close: $!"; - # The only contamination allowed is with sysread/prints - $buf =~ s/\r\n/\n/g if $how_r eq 'sysread' and $how_w =~ /print/; - is(length $buf, length $str, "length with wrc=$write_c, rdc=$read_c, $how_w, $how_r, $why"); - is($buf, $str, "content with wrc=$write_c, rdc=$read_c, $how_w, $how_r, $why"); -} - -sub testpipe ($$$$$$) { - my ($str, $write_c, $read_c, $how_w, $how_r, $why) = @_; - (my $quoted = $str) =~ s/\n/\\n/g;; - my $fh; - if ($how_w eq 'print') { # AUTOFLUSH??? - # Should be shell-neutral: - open $fh, '-|', qq[$Perl -we "$set_out;print for grep length, split /(.{1,$write_c})/s, qq($quoted)"] or die "open: $!"; - } elsif ($how_w eq 'print/flush') { - # shell-neutral and miniperl-enabled autoflush? qq(\x24\x7c) eq '$|' - open $fh, '-|', qq[$Perl -we "$set_out;eval qq(\\x24\\x7c = 1) or die;print for grep length, split /(.{1,$write_c})/s, qq($quoted)"] or die "open: $!"; - } elsif ($how_w eq 'syswrite') { - ### How to protect \$_ - open $fh, '-|', qq[$Perl -we "$set_out;eval qq(sub w {syswrite STDOUT, \\x24_} 1) or die; w() for grep length, split /(.{1,$write_c})/s, qq($quoted)"] or die "open: $!"; - } else { - die "Unrecognized write: '$how_w'"; - } - binmode $fh, ':crlf' - if defined $main::use_crlf && $main::use_crlf == 1; - testread($fh, $str, $read_c, $how_r, $write_c, $how_w, "pipe$why"); -} - -sub testfile ($$$$$$) { - my ($str, $write_c, $read_c, $how_w, $how_r, $why) = @_; - my @data = grep length, split /(.{1,$write_c})/s, $str; - - my $filename = tempfile(); - open my $fh, '>', $filename or die; - select $fh; - binmode $fh, ':crlf' - if defined $main::use_crlf && $main::use_crlf == 1; - if ($how_w eq 'print') { # AUTOFLUSH??? - $| = 0; - print $fh $_ for @data; - } elsif ($how_w eq 'print/flush') { - $| = 1; - print $fh $_ for @data; - } elsif ($how_w eq 'syswrite') { - syswrite $fh, $_ for @data; - } else { - die "Unrecognized write: '$how_w'"; - } - close $fh or die "close: $!"; - open $fh, '<', $filename or die; - binmode $fh, ':crlf' - if defined $main::use_crlf && $main::use_crlf == 1; - testread($fh, $str, $read_c, $how_r, $write_c, $how_w, "file$why"); -} - -# shell-neutral and miniperl-enabled autoflush? qq(\x24\x7c) eq '$|' -open my $fh, '-|', qq[$Perl -we "eval qq(\\x24\\x7c = 1) or die; binmode STDOUT; sleep 1, print for split //, qq(a\nb\n\nc\n\n\n)"] or die "open: $!"; -ok(1, 'open pipe'); -binmode $fh, q(:crlf); -ok(1, 'binmode'); -$c = undef; -my @c; -push @c, ord $c while $c = getc $fh; -ok(1, 'got chars'); -is(scalar @c, 9, 'got 9 chars'); -is("@c", '97 10 98 10 10 99 10 10 10', 'got expected chars'); -ok(close($fh), 'close'); - -for my $s (1..2) { - my $t = ($t1, $t2)[$s-1]; - my $str = $t->{data}; - my $r = $t->{read_c}; - my $w = $t->{write_c}; - for my $read_c (@$r) { - for my $write_c (@$w) { - for my $how_r (qw(readline_all readline read sysread)) { - next if $how_r eq 'readline_all' and $read_c != 1; - for my $how_w (qw(print print/flush syswrite)) { - testfile($str, $write_c, $read_c, $how_w, $how_r, $s); - testpipe($str, $write_c, $read_c, $how_w, $how_r, $s); - } - } - } - } -} - -1; diff --git a/t/CORE/io/utf8.t b/t/CORE/io/utf8.t deleted file mode 100644 index d63deacf2..000000000 --- a/t/CORE/io/utf8.t +++ /dev/null @@ -1,347 +0,0 @@ -#!./perl - -INIT { - require 't/CORE/test.pl'; -} - -no utf8; # needed for use utf8 not griping about the raw octets - - -plan(tests => 55); - -$| = 1; - -my $a_file = tempfile(); - -open(F,"+>:utf8",$a_file); -print F chr(0x100).'£'; -cmp_ok( tell(F), '==', 4, tell(F) ); -print F "\n"; -cmp_ok( tell(F), '>=', 5, tell(F) ); -seek(F,0,0); -is( getc(F), chr(0x100) ); -is( getc(F), "£" ); -is( getc(F), "\n" ); -seek(F,0,0); -binmode(F,":bytes"); -my $chr = chr(0xc4); -if (ord($a_file) == 193) { $chr = chr(0x8c); } # EBCDIC -is( getc(F), $chr ); -$chr = chr(0x80); -if (ord($a_file) == 193) { $chr = chr(0x41); } # EBCDIC -is( getc(F), $chr ); -$chr = chr(0xc2); -if (ord($a_file) == 193) { $chr = chr(0x80); } # EBCDIC -is( getc(F), $chr ); -$chr = chr(0xa3); -if (ord($a_file) == 193) { $chr = chr(0x44); } # EBCDIC -is( getc(F), $chr ); -is( getc(F), "\n" ); -seek(F,0,0); -binmode(F,":utf8"); -is( scalar(), "\x{100}£\n" ); -seek(F,0,0); -$buf = chr(0x200); -$count = read(F,$buf,2,1); -cmp_ok( $count, '==', 2 ); -is( $buf, "\x{200}\x{100}£" ); -close(F); - -{ - $a = chr(300); # This *is* UTF-encoded - $b = chr(130); # This is not. - - open F, ">:utf8", $a_file or die $!; - print F $a,"\n"; - close F; - - open F, "<:utf8", $a_file or die $!; - $x = ; - chomp($x); - is( $x, chr(300) ); - - open F, $a_file or die $!; # Not UTF - binmode(F, ":bytes"); - $x = ; - chomp($x); - $chr = chr(196).chr(172); - if (ord($a_file) == 193) { $chr = chr(141).chr(83); } # EBCDIC - is( $x, $chr ); - close F; - - open F, ">:utf8", $a_file or die $!; - binmode(F); # we write a "\n" and then tell() - avoid CRLF issues. - binmode(F,":utf8"); # turn UTF-8-ness back on - print F $a; - my $y; - { my $x = tell(F); - { use bytes; $y = length($a);} - cmp_ok( $x, '==', $y ); - } - - { # Check byte length of $b - use bytes; my $y = length($b); - cmp_ok( $y, '==', 1 ); - } - - print F $b,"\n"; # Don't upgrades $b - - { # Check byte length of $b - use bytes; my $y = length($b); - cmp_ok( $y, '==', 1 ); - } - - { - my $x = tell(F); - { use bytes; if (ord('A')==193){$y += 2;}else{$y += 3;}} # EBCDIC ASCII - cmp_ok( $x, '==', $y ); - } - - close F; - - open F, $a_file or die $!; # Not UTF - binmode(F, ":bytes"); - $x = ; - chomp($x); - $chr = v196.172.194.130; - if (ord('A') == 193) { $chr = v141.83.130; } # EBCDIC - is( $x, $chr, sprintf('(%vd)', $x) ); - - open F, "<:utf8", $a_file or die $!; - $x = ; - chomp($x); - close F; - is( $x, chr(300).chr(130), sprintf('(%vd)', $x) ); - - open F, ">", $a_file or die $!; - binmode(F, ":bytes:"); - - # Now let's make it suffer. TODO: perlcc will abort here - my $w; - { - use warnings 'utf8'; - local $SIG{__WARN__} = sub { $w = $_[0] }; - print F $a; - ok( (!$@)); - like($w, qr/Wide character in print/i ); - } -} - -# Hm. Time to get more evil. -open F, ">:utf8", $a_file or die $!; -print F $a; -binmode(F, ":bytes"); -print F chr(130)."\n"; -close F; - -open F, "<", $a_file or die $!; -binmode(F, ":bytes"); -$x = ; chomp $x; -$chr = v196.172.130; -if (ord('A') == 193) { $chr = v141.83.130; } # EBCDIC -is( $x, $chr ); - -# Right. -open F, ">:utf8", $a_file or die $!; -print F $a; -close F; -open F, ">>", $a_file or die $!; -binmode(F, ":bytes"); -print F chr(130)."\n"; -close F; - -open F, "<", $a_file or die $!; -binmode(F, ":bytes"); -$x = ; chomp $x; -SKIP: { - skip("Defaulting to UTF-8 output means that we can't generate a mangled file") - if $UTF8_OUTPUT; - is( $x, $chr ); -} - -# Now we have a deformed file. - -SKIP: { - if (ord('A') == 193) { - skip("EBCDIC doesn't complain", 2); - } else { - my @warnings; - open F, "<:utf8", $a_file or die $!; - $x = ; chomp $x; - local $SIG{__WARN__} = sub { push @warnings, $_[0]; }; - eval { sprintf "%vd\n", $x }; - is (scalar @warnings, 1); - like ($warnings[0], qr/Malformed UTF-8 character \(unexpected continuation byte 0x82, with no preceding start byte/); - } -} - -close F; -unlink($a_file); - -open F, ">:utf8", $a_file; -@a = map { chr(1 << 0 + ($_ << 2)) } 0..5; # 0x1, 0x10, .., 0x100000 # 0 + is required for some poor editors -unshift @a, chr(0); # ... and a null byte in front just for fun -print F @a; -close F; - -my $c; - -# read() should work on characters, not bytes -open F, "<:utf8", $a_file; -$a = 0; -my $failed; -for (@a) { - unless (($c = read(F, $b, 1) == 1) && - length($b) == 1 && - ord($b) == ord($_) && - tell(F) == ($a += bytes::length($b))) { - print '# ord($_) == ', ord($_), "\n"; - print '# ord($b) == ', ord($b), "\n"; - print '# length($b) == ', length($b), "\n"; - print '# bytes::length($b) == ', bytes::length($b), "\n"; - print '# tell(F) == ', tell(F), "\n"; - print '# $a == ', $a, "\n"; - print '# $c == ', $c, "\n"; - $failed++; - last; - } -} -close F; -is($failed, undef); - -{ - # Check that warnings are on on I/O, and that they can be muffled. - - local $SIG{__WARN__} = sub { $@ = shift }; - - undef $@; - open F, ">$a_file"; - binmode(F, ":bytes"); - print F chr(0x100); - close(F); - - like( $@, 'Wide character in print' ); - - undef $@; - open F, ">:utf8", $a_file; - print F chr(0x100); - close(F); - - isnt( defined $@, !0 ); - - undef $@; - open F, ">$a_file"; - binmode(F, ":utf8"); - print F chr(0x100); - close(F); - - isnt( defined $@, !0 ); - - no warnings 'utf8'; - - undef $@; - open F, ">$a_file"; - print F chr(0x100); - close(F); - - isnt( defined $@, !0 ); - - use warnings 'utf8'; - - undef $@; - open F, ">$a_file"; - binmode(F, ":bytes"); - print F chr(0x100); - close(F); - - like( $@, 'Wide character in print' ); -} - -{ - open F, ">:bytes",$a_file; print F "\xde"; close F; - - open F, "<:bytes", $a_file; - my $b = chr 0x100; - $b .= ; - is( $b, chr(0x100).chr(0xde), "21395 '.= <>' utf8 vs. bytes" ); - close F; -} - -{ - open F, ">:utf8",$a_file; print F chr 0x100; close F; - - open F, "<:utf8", $a_file; - my $b = "\xde"; - $b .= ; - is( $b, chr(0xde).chr(0x100), "21395 '.= <>' bytes vs. utf8" ); - close F; -} - -{ - my @a = ( [ 0x007F, "bytes" ], - [ 0x0080, "bytes" ], - [ 0x0080, "utf8" ], - [ 0x0100, "utf8" ] ); - my $t = 34; - for my $u (@a) { - for my $v (@a) { - # print "# @$u - @$v\n"; - open F, ">$a_file"; - binmode(F, ":" . $u->[1]); - print F chr($u->[0]); - close F; - - open F, "<$a_file"; - binmode(F, ":" . $u->[1]); - - my $s = chr($v->[0]); - utf8::upgrade($s) if $v->[1] eq "utf8"; - - $s .= ; - is( $s, chr($v->[0]) . chr($u->[0]), 'rcatline utf8' ); - close F; - $t++; - } - } - # last test here 49 -} - -{ - # [perl #23428] Somethings rotten in unicode semantics - open F, ">$a_file"; - binmode F, ":utf8"; - syswrite(F, $a = chr(0x100)); - close F; - is( ord($a), 0x100, '23428 syswrite should not downgrade scalar' ); - like( $a, qr/^\w+/, '23428 syswrite should not downgrade scalar' ); -} - -# sysread() and syswrite() tested in lib/open.t since Fcntl is used - -{ - # on a :utf8 stream should complain immediately with -w - # if it finds bad UTF-8 (:encoding(utf8) works this way) - use warnings 'utf8'; - undef $@; - local $SIG{__WARN__} = sub { $@ = shift }; - open F, ">$a_file"; - binmode F; - my ($chrE4, $chrF6) = (chr(0xE4), chr(0xF6)); - if (ord('A') == 193) # EBCDIC - { ($chrE4, $chrF6) = (chr(0x43), chr(0xEC)); } - print F "foo", $chrE4, "\n"; - print F "foo", $chrF6, "\n"; - close F; - open F, "<:utf8", $a_file; - undef $@; - my $line = ; - my ($chrE4, $chrF6) = ("E4", "F6"); - if (ord('A') == 193) { ($chrE4, $chrF6) = ("43", "EC"); } # EBCDIC - like( $@, qr/utf8 "\\x$chrE4" does not map to Unicode .+ line 1/, - "<:utf8 readline must warn about bad utf8"); - undef $@; - $line .= ; - like( $@, qr/utf8 "\\x$chrF6" does not map to Unicode .+ line 2/, - "<:utf8 rcatline must warn about bad utf8"); - close F; -} diff --git a/t/CORE/lib/test_use.pm b/t/CORE/lib/test_use.pm deleted file mode 100644 index f1ed0b11c..000000000 --- a/t/CORE/lib/test_use.pm +++ /dev/null @@ -1,11 +0,0 @@ -#!perl -w -# Don't use strict because this is for testing use - -package test_use; - -sub import { - shift; - @got = @_; -} - -1; diff --git a/t/CORE/lib/test_use_14937.pm b/t/CORE/lib/test_use_14937.pm deleted file mode 100644 index 0afc6045c..000000000 --- a/t/CORE/lib/test_use_14937.pm +++ /dev/null @@ -1 +0,0 @@ -1; diff --git a/t/CORE/mro/basic.t b/t/CORE/mro/basic.t deleted file mode 100644 index 144ff949f..000000000 --- a/t/CORE/mro/basic.t +++ /dev/null @@ -1,330 +0,0 @@ -#!./perl - -use strict; -use warnings; - -BEGIN { require q(t/CORE/test.pl); } plan(tests => 52); - -require mro; - -{ - package MRO_A; - our @ISA = qw//; - package MRO_B; - our @ISA = qw//; - package MRO_C; - our @ISA = qw//; - package MRO_D; - our @ISA = qw/MRO_A MRO_B MRO_C/; - package MRO_E; - our @ISA = qw/MRO_A MRO_B MRO_C/; - package MRO_F; - our @ISA = qw/MRO_D MRO_E/; -} - -my @MFO_F_DFS = qw/MRO_F MRO_D MRO_A MRO_B MRO_C MRO_E/; -my @MFO_F_C3 = qw/MRO_F MRO_D MRO_E MRO_A MRO_B MRO_C/; -is(mro::get_mro('MRO_F'), 'dfs'); -ok(eq_array( - mro::get_linear_isa('MRO_F'), \@MFO_F_DFS -)); - -ok(eq_array(mro::get_linear_isa('MRO_F', 'dfs'), \@MFO_F_DFS)); -ok(eq_array(mro::get_linear_isa('MRO_F', 'c3'), \@MFO_F_C3)); -eval{mro::get_linear_isa('MRO_F', 'C3')}; -like($@, qr/^Invalid mro name: 'C3'/); - -mro::set_mro('MRO_F', 'c3'); -is(mro::get_mro('MRO_F'), 'c3'); -ok(eq_array( - mro::get_linear_isa('MRO_F'), \@MFO_F_C3 -)); - -ok(eq_array(mro::get_linear_isa('MRO_F', 'dfs'), \@MFO_F_DFS)); -ok(eq_array(mro::get_linear_isa('MRO_F', 'c3'), \@MFO_F_C3)); -eval{mro::get_linear_isa('MRO_F', 'C3')}; -like($@, qr/^Invalid mro name: 'C3'/); - -my @isarev = sort { $a cmp $b } @{mro::get_isarev('MRO_B')}; -ok(eq_array( - \@isarev, - [qw/MRO_D MRO_E MRO_F/] -)); - -ok(!mro::is_universal('MRO_B')); - -@UNIVERSAL::ISA = qw/MRO_F/; -ok(mro::is_universal('MRO_B')); - -@UNIVERSAL::ISA = (); -ok(!mro::is_universal('MRO_B')); - -# is_universal, get_mro, and get_linear_isa should -# handle non-existent packages sanely -ok(!mro::is_universal('Does_Not_Exist')); -is(mro::get_mro('Also_Does_Not_Exist'), 'dfs'); -ok(eq_array( - mro::get_linear_isa('Does_Not_Exist_Three'), - [qw/Does_Not_Exist_Three/] -)); - -# Assigning @ISA via globref -{ - package MRO_TestBase; - sub testfunc { return 123 } - package MRO_TestOtherBase; - sub testfunctwo { return 321 } - package MRO_M; our @ISA = qw/MRO_TestBase/; -} -*MRO_N::ISA = *MRO_M::ISA; -is(eval { MRO_N->testfunc() }, 123); - -# XXX TODO (when there's a way to backtrack through a glob's aliases) -# push(@MRO_M::ISA, 'MRO_TestOtherBase'); -# is(eval { MRO_N->testfunctwo() }, 321); - -# Simple DESTROY Baseline -{ - my $x = 0; - my $obj; - - { - package DESTROY_MRO_Baseline; - sub new { bless {} => shift } - sub DESTROY { $x++ } - - package DESTROY_MRO_Baseline_Child; - our @ISA = qw/DESTROY_MRO_Baseline/; - } - - $obj = DESTROY_MRO_Baseline->new(); - undef $obj; - is($x, 1); - - $obj = DESTROY_MRO_Baseline_Child->new(); - undef $obj; - is($x, 2); -} - -# Dynamic DESTROY -{ - my $x = 0; - my $obj; - - { - package DESTROY_MRO_Dynamic; - sub new { bless {} => shift } - - package DESTROY_MRO_Dynamic_Child; - our @ISA = qw/DESTROY_MRO_Dynamic/; - } - - $obj = DESTROY_MRO_Dynamic->new(); - undef $obj; - is($x, 0); - - $obj = DESTROY_MRO_Dynamic_Child->new(); - undef $obj; - is($x, 0); - - no warnings 'once'; - *DESTROY_MRO_Dynamic::DESTROY = sub { $x++ }; - - $obj = DESTROY_MRO_Dynamic->new(); - undef $obj; - is($x, 1); - - $obj = DESTROY_MRO_Dynamic_Child->new(); - undef $obj; - is($x, 2); -} - -# clearing @ISA in different ways -# some are destructive to the package, hence the new -# package name each time -{ - no warnings 'uninitialized'; - { - package ISACLEAR; - our @ISA = qw/XX YY ZZ/; - } - # baseline - ok(eq_array(mro::get_linear_isa('ISACLEAR'),[qw/ISACLEAR XX YY ZZ/])); - - # this looks dumb, but it preserves existing behavior for compatibility - # (undefined @ISA elements treated as "main") - $ISACLEAR::ISA[1] = undef; - ok(eq_array(mro::get_linear_isa('ISACLEAR'),[qw/ISACLEAR XX main ZZ/])); - - # undef the array itself - undef @ISACLEAR::ISA; - ok(eq_array(mro::get_linear_isa('ISACLEAR'),[qw/ISACLEAR/])); - - # Now, clear more than one package's @ISA at once - { - package ISACLEAR1; - our @ISA = qw/WW XX/; - - package ISACLEAR2; - our @ISA = qw/YY ZZ/; - } - # baseline - ok(eq_array(mro::get_linear_isa('ISACLEAR1'),[qw/ISACLEAR1 WW XX/])); - ok(eq_array(mro::get_linear_isa('ISACLEAR2'),[qw/ISACLEAR2 YY ZZ/])); - (@ISACLEAR1::ISA, @ISACLEAR2::ISA) = (); - - ok(eq_array(mro::get_linear_isa('ISACLEAR1'),[qw/ISACLEAR1/])); - ok(eq_array(mro::get_linear_isa('ISACLEAR2'),[qw/ISACLEAR2/])); - - # [perl #49564] This is a pretty obscure way of clearing @ISA but - # it tests a regression that affects XS code calling av_clear too. - { - package ISACLEAR3; - our @ISA = qw/WW XX/; - } - ok(eq_array(mro::get_linear_isa('ISACLEAR3'),[qw/ISACLEAR3 WW XX/])); - { - package ISACLEAR3; - reset 'I'; - } - ok(eq_array(mro::get_linear_isa('ISACLEAR3'),[qw/ISACLEAR3/])); -} - -# Check that recursion bails out "cleanly" in a variety of cases -# (as opposed to say, bombing the interpreter or something) -{ - my @recurse_codes = ( - '@MRO_R1::ISA = "MRO_R2"; @MRO_R2::ISA = "MRO_R1";', - '@MRO_R3::ISA = "MRO_R4"; push(@MRO_R4::ISA, "MRO_R3");', - '@MRO_R5::ISA = "MRO_R6"; @MRO_R6::ISA = qw/XX MRO_R5 YY/;', - '@MRO_R7::ISA = "MRO_R8"; push(@MRO_R8::ISA, qw/XX MRO_R7 YY/)', - ); - foreach my $code (@recurse_codes) { - eval $code; - ok($@ =~ /Recursive inheritance detected/); - } -} - -# Check that SUPER caches get invalidated correctly -{ - { - package SUPERTEST; - sub new { bless {} => shift } - sub foo { $_[1]+1 } - - package SUPERTEST::MID; - our @ISA = 'SUPERTEST'; - - package SUPERTEST::KID; - our @ISA = 'SUPERTEST::MID'; - sub foo { my $s = shift; $s->SUPER::foo(@_) } - - package SUPERTEST::REBASE; - sub foo { $_[1]+3 } - } - - my $stk_obj = SUPERTEST::KID->new(); - is($stk_obj->foo(1), 2); - { no warnings 'redefine'; - *SUPERTEST::foo = sub { $_[1]+2 }; - } - is($stk_obj->foo(2), 4); - @SUPERTEST::MID::ISA = 'SUPERTEST::REBASE'; - is($stk_obj->foo(3), 6); -} - -{ - { - # assigning @ISA via arrayref to globref RT 60220 - package P1; - sub new { bless {}, shift } - - package P2; - } - *{P2::ISA} = [ 'P1' ]; - my $foo = P2->new; - ok(!eval { $foo->bark }, "no bark method"); - no warnings 'once'; # otherwise it'll bark about P1::bark used only once - *{P1::bark} = sub { "[bark]" }; - is(scalar eval { $foo->bark }, "[bark]", "can bark now"); -} - -{ - # assigning @ISA via arrayref then modifying it RT 72866 - { - package Q1; - sub foo { } - - package Q2; - sub bar { } - - package Q3; - } - push @Q3::ISA, "Q1"; - can_ok("Q3", "foo"); - *Q3::ISA = []; - push @Q3::ISA, "Q1"; - can_ok("Q3", "foo"); - *Q3::ISA = []; - push @Q3::ISA, "Q2"; - can_ok("Q3", "bar"); - ok(!Q3->can("foo"), "can't call foo method any longer"); -} - -{ - # test mro::method_changed_in - my $count = mro::get_pkg_gen("MRO_A"); - mro::method_changed_in("MRO_A"); - my $count_new = mro::get_pkg_gen("MRO_A"); - - is($count_new, $count + 1); -} - -{ - # test if we can call mro::invalidate_all_method_caches; - eval { - mro::invalidate_all_method_caches(); - }; - is($@, ""); -} - -{ - # @main::ISA - no warnings 'once'; - @main::ISA = 'parent'; - my $output = ''; - *parent::do = sub { $output .= 'parent' }; - *parent2::do = sub { $output .= 'parent2' }; - main->do; - @main::ISA = 'parent2'; - main->do; - is $output, 'parentparent2', '@main::ISA is magical'; -} - -{ - # Undefining *ISA, then modifying @ISA - # This broke Class::Trait. See [perl #79024]. - {package Class::Trait::Base} - no strict 'refs'; - undef *{"Extra::TSpouse::ISA"}; - 'Extra::TSpouse'->isa('Class::Trait::Base'); # cache the mro - unshift @{"Extra::TSpouse::ISA"}, 'Class::Trait::Base'; - ok 'Extra::TSpouse'->isa('Class::Trait::Base'), - 'a isa b after undef *a::ISA and @a::ISA modification'; -} - -{ - # Deleting $package::{ISA} - # Broken in 5.10.0; fixed in 5.13.7 - @Blength::ISA = 'Bladd'; - delete $Blength::{ISA}; - ok !Blength->isa("Bladd"), 'delete $package::{ISA}'; -} - -{ - # Undefining stashes - @Thrext::ISA = "Thwit"; - @Thwit::ISA = "Sile"; - undef %Thwit::; - ok !Thrext->isa('Sile'), 'undef %package:: updates subclasses'; -} diff --git a/t/CORE/mro/basic_01_c3.t b/t/CORE/mro/basic_01_c3.t deleted file mode 100644 index 9532b752b..000000000 --- a/t/CORE/mro/basic_01_c3.t +++ /dev/null @@ -1,47 +0,0 @@ -#!./perl - -use strict; -use warnings; - -require q(t/CORE/test.pl); plan(tests => 4); - -=pod - -This tests the classic diamond inheritance pattern. - - - / \ - - \ / - - -=cut - -{ - package Diamond_A; - sub hello { 'Diamond_A::hello' } -} -{ - package Diamond_B; - use base 'Diamond_A'; -} -{ - package Diamond_C; - use base 'Diamond_A'; - - sub hello { 'Diamond_C::hello' } -} -{ - package Diamond_D; - use base ('Diamond_B', 'Diamond_C'); - use mro 'c3'; -} - -ok(eq_array( - mro::get_linear_isa('Diamond_D'), - [ qw(Diamond_D Diamond_B Diamond_C Diamond_A) ] -), '... got the right MRO for Diamond_D'); - -is(Diamond_D->hello, 'Diamond_C::hello', '... method resolved itself as expected'); -is(Diamond_D->can('hello')->(), 'Diamond_C::hello', '... can(method) resolved itself as expected'); -is(UNIVERSAL::can("Diamond_D", 'hello')->(), 'Diamond_C::hello', '... can(method) resolved itself as expected'); diff --git a/t/CORE/mro/basic_01_dfs.t b/t/CORE/mro/basic_01_dfs.t deleted file mode 100644 index bdd335d15..000000000 --- a/t/CORE/mro/basic_01_dfs.t +++ /dev/null @@ -1,47 +0,0 @@ -#!./perl - -use strict; -use warnings; - -require q(t/CORE/test.pl); plan(tests => 4); - -=pod - -This tests the classic diamond inheritance pattern. - - - / \ - - \ / - - -=cut - -{ - package Diamond_A; - sub hello { 'Diamond_A::hello' } -} -{ - package Diamond_B; - use base 'Diamond_A'; -} -{ - package Diamond_C; - use base 'Diamond_A'; - - sub hello { 'Diamond_C::hello' } -} -{ - package Diamond_D; - use base ('Diamond_B', 'Diamond_C'); - use mro 'dfs'; -} - -ok(eq_array( - mro::get_linear_isa('Diamond_D'), - [ qw(Diamond_D Diamond_B Diamond_A Diamond_C) ] -), '... got the right MRO for Diamond_D'); - -is(Diamond_D->hello, 'Diamond_A::hello', '... method resolved itself as expected'); -is(Diamond_D->can('hello')->(), 'Diamond_A::hello', '... can(method) resolved itself as expected'); -is(UNIVERSAL::can("Diamond_D", 'hello')->(), 'Diamond_A::hello', '... can(method) resolved itself as expected'); diff --git a/t/CORE/mro/basic_02_c3.t b/t/CORE/mro/basic_02_c3.t deleted file mode 100644 index c15a9007c..000000000 --- a/t/CORE/mro/basic_02_c3.t +++ /dev/null @@ -1,115 +0,0 @@ -#!./perl - -use strict; -use warnings; - -require q(t/CORE/test.pl); plan(tests => 10); - -=pod - -This example is take from: http://www.python.org/2.3/mro.html - -"My first example" -class O: pass -class F(O): pass -class E(O): pass -class D(O): pass -class C(D,F): pass -class B(D,E): pass -class A(B,C): pass - - - 6 - --- -Level 3 | O | (more general) - / --- \ - / | \ | - / | \ | - / | \ | - --- --- --- | -Level 2 3 | D | 4| E | | F | 5 | - --- --- --- | - \ \ _ / | | - \ / \ _ | | - \ / \ | | - --- --- | -Level 1 1 | B | | C | 2 | - --- --- | - \ / | - \ / \ / - --- -Level 0 0 | A | (more specialized) - --- - -=cut - -{ - package Test::O; - use mro 'c3'; - - package Test::F; - use mro 'c3'; - use base 'Test::O'; - - package Test::E; - use base 'Test::O'; - use mro 'c3'; - - sub C_or_E { 'Test::E' } - - package Test::D; - use mro 'c3'; - use base 'Test::O'; - - sub C_or_D { 'Test::D' } - - package Test::C; - use base ('Test::D', 'Test::F'); - use mro 'c3'; - - sub C_or_D { 'Test::C' } - sub C_or_E { 'Test::C' } - - package Test::B; - use mro 'c3'; - use base ('Test::D', 'Test::E'); - - package Test::A; - use base ('Test::B', 'Test::C'); - use mro 'c3'; -} - -ok(eq_array( - mro::get_linear_isa('Test::F'), - [ qw(Test::F Test::O) ] -), '... got the right MRO for Test::F'); - -ok(eq_array( - mro::get_linear_isa('Test::E'), - [ qw(Test::E Test::O) ] -), '... got the right MRO for Test::E'); - -ok(eq_array( - mro::get_linear_isa('Test::D'), - [ qw(Test::D Test::O) ] -), '... got the right MRO for Test::D'); - -ok(eq_array( - mro::get_linear_isa('Test::C'), - [ qw(Test::C Test::D Test::F Test::O) ] -), '... got the right MRO for Test::C'); - -ok(eq_array( - mro::get_linear_isa('Test::B'), - [ qw(Test::B Test::D Test::E Test::O) ] -), '... got the right MRO for Test::B'); - -ok(eq_array( - mro::get_linear_isa('Test::A'), - [ qw(Test::A Test::B Test::C Test::D Test::E Test::F Test::O) ] -), '... got the right MRO for Test::A'); - -is(Test::A->C_or_D, 'Test::C', '... got the expected method output'); -is(Test::A->can('C_or_D')->(), 'Test::C', '... can got the expected method output'); -is(Test::A->C_or_E, 'Test::C', '... got the expected method output'); -is(Test::A->can('C_or_E')->(), 'Test::C', '... can got the expected method output'); diff --git a/t/CORE/mro/basic_02_dfs.t b/t/CORE/mro/basic_02_dfs.t deleted file mode 100644 index 93c7f2937..000000000 --- a/t/CORE/mro/basic_02_dfs.t +++ /dev/null @@ -1,115 +0,0 @@ -#!./perl - -use strict; -use warnings; - -require q(t/CORE/test.pl); plan(tests => 10); - -=pod - -This example is take from: http://www.python.org/2.3/mro.html - -"My first example" -class O: pass -class F(O): pass -class E(O): pass -class D(O): pass -class C(D,F): pass -class B(D,E): pass -class A(B,C): pass - - - 6 - --- -Level 3 | O | (more general) - / --- \ - / | \ | - / | \ | - / | \ | - --- --- --- | -Level 2 3 | D | 4| E | | F | 5 | - --- --- --- | - \ \ _ / | | - \ / \ _ | | - \ / \ | | - --- --- | -Level 1 1 | B | | C | 2 | - --- --- | - \ / | - \ / \ / - --- -Level 0 0 | A | (more specialized) - --- - -=cut - -{ - package Test::O; - use mro 'dfs'; - - package Test::F; - use mro 'dfs'; - use base 'Test::O'; - - package Test::E; - use base 'Test::O'; - use mro 'dfs'; - - sub C_or_E { 'Test::E' } - - package Test::D; - use mro 'dfs'; - use base 'Test::O'; - - sub C_or_D { 'Test::D' } - - package Test::C; - use base ('Test::D', 'Test::F'); - use mro 'dfs'; - - sub C_or_D { 'Test::C' } - sub C_or_E { 'Test::C' } - - package Test::B; - use mro 'dfs'; - use base ('Test::D', 'Test::E'); - - package Test::A; - use base ('Test::B', 'Test::C'); - use mro 'dfs'; -} - -ok(eq_array( - mro::get_linear_isa('Test::F'), - [ qw(Test::F Test::O) ] -), '... got the right MRO for Test::F'); - -ok(eq_array( - mro::get_linear_isa('Test::E'), - [ qw(Test::E Test::O) ] -), '... got the right MRO for Test::E'); - -ok(eq_array( - mro::get_linear_isa('Test::D'), - [ qw(Test::D Test::O) ] -), '... got the right MRO for Test::D'); - -ok(eq_array( - mro::get_linear_isa('Test::C'), - [ qw(Test::C Test::D Test::O Test::F) ] -), '... got the right MRO for Test::C'); - -ok(eq_array( - mro::get_linear_isa('Test::B'), - [ qw(Test::B Test::D Test::O Test::E) ] -), '... got the right MRO for Test::B'); - -ok(eq_array( - mro::get_linear_isa('Test::A'), - [ qw(Test::A Test::B Test::D Test::O Test::E Test::C Test::F) ] -), '... got the right MRO for Test::A'); - -is(Test::A->C_or_D, 'Test::D', '... got the expected method output'); -is(Test::A->can('C_or_D')->(), 'Test::D', '... can got the expected method output'); -is(Test::A->C_or_E, 'Test::E', '... got the expected method output'); -is(Test::A->can('C_or_E')->(), 'Test::E', '... can got the expected method output'); diff --git a/t/CORE/mro/basic_03_c3.t b/t/CORE/mro/basic_03_c3.t deleted file mode 100644 index 2e360ad41..000000000 --- a/t/CORE/mro/basic_03_c3.t +++ /dev/null @@ -1,101 +0,0 @@ -#!./perl - -use strict; -use warnings; - -require q(t/CORE/test.pl); plan(tests => 4); - -=pod - -This example is take from: http://www.python.org/2.3/mro.html - -"My second example" -class O: pass -class F(O): pass -class E(O): pass -class D(O): pass -class C(D,F): pass -class B(E,D): pass -class A(B,C): pass - - 6 - --- -Level 3 | O | - / --- \ - / | \ - / | \ - / | \ - --- --- --- -Level 2 2 | E | 4 | D | | F | 5 - --- --- --- - \ / \ / - \ / \ / - \ / \ / - --- --- -Level 1 1 | B | | C | 3 - --- --- - \ / - \ / - --- -Level 0 0 | A | - --- - ->>> A.mro() -(, , , -, , , -) - -=cut - -{ - package Test::O; - use mro 'c3'; - - sub O_or_D { 'Test::O' } - sub O_or_F { 'Test::O' } - - package Test::F; - use base 'Test::O'; - use mro 'c3'; - - sub O_or_F { 'Test::F' } - - package Test::E; - use base 'Test::O'; - use mro 'c3'; - - package Test::D; - use base 'Test::O'; - use mro 'c3'; - - sub O_or_D { 'Test::D' } - sub C_or_D { 'Test::D' } - - package Test::C; - use base ('Test::D', 'Test::F'); - use mro 'c3'; - - sub C_or_D { 'Test::C' } - - package Test::B; - use base ('Test::E', 'Test::D'); - use mro 'c3'; - - package Test::A; - use base ('Test::B', 'Test::C'); - use mro 'c3'; -} - -ok(eq_array( - mro::get_linear_isa('Test::A'), - [ qw(Test::A Test::B Test::E Test::C Test::D Test::F Test::O) ] -), '... got the right MRO for Test::A'); - -is(Test::A->O_or_D, 'Test::D', '... got the right method dispatch'); -is(Test::A->O_or_F, 'Test::F', '... got the right method dispatch'); - -# NOTE: -# this test is particularly interesting because the p5 dispatch -# would actually call Test::D before Test::C and Test::D is a -# subclass of Test::C -is(Test::A->C_or_D, 'Test::C', '... got the right method dispatch'); diff --git a/t/CORE/mro/basic_03_dfs.t b/t/CORE/mro/basic_03_dfs.t deleted file mode 100644 index c57c70443..000000000 --- a/t/CORE/mro/basic_03_dfs.t +++ /dev/null @@ -1,101 +0,0 @@ -#!./perl - -use strict; -use warnings; - -require q(t/CORE/test.pl); plan(tests => 4); - -=pod - -This example is take from: http://www.python.org/2.3/mro.html - -"My second example" -class O: pass -class F(O): pass -class E(O): pass -class D(O): pass -class C(D,F): pass -class B(E,D): pass -class A(B,C): pass - - 6 - --- -Level 3 | O | - / --- \ - / | \ - / | \ - / | \ - --- --- --- -Level 2 2 | E | 4 | D | | F | 5 - --- --- --- - \ / \ / - \ / \ / - \ / \ / - --- --- -Level 1 1 | B | | C | 3 - --- --- - \ / - \ / - --- -Level 0 0 | A | - --- - ->>> A.mro() -(, , , -, , , -) - -=cut - -{ - package Test::O; - use mro 'dfs'; - - sub O_or_D { 'Test::O' } - sub O_or_F { 'Test::O' } - - package Test::F; - use base 'Test::O'; - use mro 'dfs'; - - sub O_or_F { 'Test::F' } - - package Test::E; - use base 'Test::O'; - use mro 'dfs'; - - package Test::D; - use base 'Test::O'; - use mro 'dfs'; - - sub O_or_D { 'Test::D' } - sub C_or_D { 'Test::D' } - - package Test::C; - use base ('Test::D', 'Test::F'); - use mro 'dfs'; - - sub C_or_D { 'Test::C' } - - package Test::B; - use base ('Test::E', 'Test::D'); - use mro 'dfs'; - - package Test::A; - use base ('Test::B', 'Test::C'); - use mro 'dfs'; -} - -ok(eq_array( - mro::get_linear_isa('Test::A'), - [ qw(Test::A Test::B Test::E Test::O Test::D Test::C Test::F) ] -), '... got the right MRO for Test::A'); - -is(Test::A->O_or_D, 'Test::O', '... got the right method dispatch'); -is(Test::A->O_or_F, 'Test::O', '... got the right method dispatch'); - -# NOTE: -# this test is particularly interesting because the p5 dispatch -# would actually call Test::D before Test::C and Test::D is a -# subclass of Test::C -is(Test::A->C_or_D, 'Test::D', '... got the right method dispatch'); diff --git a/t/CORE/mro/basic_04_c3.t b/t/CORE/mro/basic_04_c3.t deleted file mode 100644 index b1e891a9e..000000000 --- a/t/CORE/mro/basic_04_c3.t +++ /dev/null @@ -1,34 +0,0 @@ -#!./perl - -use strict; -use warnings; - -require q(t/CORE/test.pl); plan(tests => 1); - -=pod - -From the parrot test t/pmc/object-meths.t - - A B A E - \ / \ / - C D - \ / - \ / - F - -=cut - -{ - package t::lib::A; use mro 'c3'; - package t::lib::B; use mro 'c3'; - package t::lib::E; use mro 'c3'; - package t::lib::C; use mro 'c3'; use base ('t::lib::A', 't::lib::B'); - package t::lib::D; use mro 'c3'; use base ('t::lib::A', 't::lib::E'); - package t::lib::F; use mro 'c3'; use base ('t::lib::C', 't::lib::D'); -} - -ok(eq_array( - mro::get_linear_isa('t::lib::F'), - [ qw(t::lib::F t::lib::C t::lib::D t::lib::A t::lib::B t::lib::E) ] -), '... got the right MRO for t::lib::F'); - diff --git a/t/CORE/mro/basic_04_dfs.t b/t/CORE/mro/basic_04_dfs.t deleted file mode 100644 index 6618d138c..000000000 --- a/t/CORE/mro/basic_04_dfs.t +++ /dev/null @@ -1,34 +0,0 @@ -#!./perl - -use strict; -use warnings; - -require q(t/CORE/test.pl); plan(tests => 1); - -=pod - -From the parrot test t/pmc/object-meths.t - - A B A E - \ / \ / - C D - \ / - \ / - F - -=cut - -{ - package t::lib::A; use mro 'dfs'; - package t::lib::B; use mro 'dfs'; - package t::lib::E; use mro 'dfs'; - package t::lib::C; use mro 'dfs'; use base ('t::lib::A', 't::lib::B'); - package t::lib::D; use mro 'dfs'; use base ('t::lib::A', 't::lib::E'); - package t::lib::F; use mro 'dfs'; use base ('t::lib::C', 't::lib::D'); -} - -ok(eq_array( - mro::get_linear_isa('t::lib::F'), - [ qw(t::lib::F t::lib::C t::lib::A t::lib::B t::lib::D t::lib::E) ] -), '... got the right MRO for t::lib::F'); - diff --git a/t/CORE/mro/basic_05_c3.t b/t/CORE/mro/basic_05_c3.t deleted file mode 100644 index 05412542e..000000000 --- a/t/CORE/mro/basic_05_c3.t +++ /dev/null @@ -1,55 +0,0 @@ -#!./perl - -use strict; -use warnings; - -require q(t/CORE/test.pl); plan(tests => 2); - -=pod - -This tests a strange bug found by Matt S. Trout -while building DBIx::Class. Thanks Matt!!!! - - - / \ - - \ / - - -=cut - -{ - package Diamond_A; - use mro 'c3'; - - sub foo { 'Diamond_A::foo' } -} -{ - package Diamond_B; - use base 'Diamond_A'; - use mro 'c3'; - - sub foo { 'Diamond_B::foo => ' . (shift)->SUPER::foo } -} -{ - package Diamond_C; - use mro 'c3'; - use base 'Diamond_A'; - -} -{ - package Diamond_D; - use base ('Diamond_C', 'Diamond_B'); - use mro 'c3'; - - sub foo { 'Diamond_D::foo => ' . (shift)->SUPER::foo } -} - -ok(eq_array( - mro::get_linear_isa('Diamond_D'), - [ qw(Diamond_D Diamond_C Diamond_B Diamond_A) ] -), '... got the right MRO for Diamond_D'); - -is(Diamond_D->foo, - 'Diamond_D::foo => Diamond_B::foo => Diamond_A::foo', - '... got the right next::method dispatch path'); diff --git a/t/CORE/mro/basic_05_dfs.t b/t/CORE/mro/basic_05_dfs.t deleted file mode 100644 index dd4ca2b83..000000000 --- a/t/CORE/mro/basic_05_dfs.t +++ /dev/null @@ -1,55 +0,0 @@ -#!./perl - -use strict; -use warnings; - -require q(t/CORE/test.pl); plan(tests => 2); - -=pod - -This tests a strange bug found by Matt S. Trout -while building DBIx::Class. Thanks Matt!!!! - - - / \ - - \ / - - -=cut - -{ - package Diamond_A; - use mro 'dfs'; - - sub foo { 'Diamond_A::foo' } -} -{ - package Diamond_B; - use base 'Diamond_A'; - use mro 'dfs'; - - sub foo { 'Diamond_B::foo => ' . (shift)->SUPER::foo } -} -{ - package Diamond_C; - use mro 'dfs'; - use base 'Diamond_A'; - -} -{ - package Diamond_D; - use base ('Diamond_C', 'Diamond_B'); - use mro 'dfs'; - - sub foo { 'Diamond_D::foo => ' . (shift)->SUPER::foo } -} - -ok(eq_array( - mro::get_linear_isa('Diamond_D'), - [ qw(Diamond_D Diamond_C Diamond_A Diamond_B) ] -), '... got the right MRO for Diamond_D'); - -is(Diamond_D->foo, - 'Diamond_D::foo => Diamond_A::foo', - '... got the right next::method dispatch path'); diff --git a/t/CORE/mro/c3_with_overload.t b/t/CORE/mro/c3_with_overload.t deleted file mode 100644 index b9b6726a0..000000000 --- a/t/CORE/mro/c3_with_overload.t +++ /dev/null @@ -1,47 +0,0 @@ -#!/usr/bin/perl - -use strict; -use warnings; - -require q(t/CORE/test.pl); plan(tests => 7); - -{ - package BaseTest; - use strict; - use warnings; - use mro 'c3'; - - package OverloadingTest; - use strict; - use warnings; - use mro 'c3'; - use base 'BaseTest'; - use overload '""' => sub { ref(shift) . " stringified" }, - fallback => 1; - - sub new { bless {} => shift } - - package InheritingFromOverloadedTest; - use strict; - use warnings; - use base 'OverloadingTest'; - use mro 'c3'; -} - -my $x = InheritingFromOverloadedTest->new(); -isa_ok($x, 'InheritingFromOverloadedTest'); - -my $y = OverloadingTest->new(); -isa_ok($y, 'OverloadingTest'); - -is("$x", 'InheritingFromOverloadedTest stringified', '... got the right value when stringifing'); -is("$y", 'OverloadingTest stringified', '... got the right value when stringifing'); - -ok(($y eq 'OverloadingTest stringified'), '... eq was handled correctly'); - -my $result; -eval { - $result = $x eq 'InheritingFromOverloadedTest stringified' -}; -ok(!$@, '... this should not throw an exception'); -ok($result, '... and we should get the true value'); diff --git a/t/CORE/mro/complex_c3.t b/t/CORE/mro/complex_c3.t deleted file mode 100644 index dfbc94bf9..000000000 --- a/t/CORE/mro/complex_c3.t +++ /dev/null @@ -1,142 +0,0 @@ -#!./perl - -use strict; -use warnings; - -require q(t/CORE/test.pl); plan(tests => 12); - -=pod - -This example is taken from: http://rt.cpan.org/Public/Bug/Display.html?id=20879 - - --- --- --- -Level 5 8 | A | 9 | B | A | C | (More General) - --- --- --- V - \ | / | - \ | / | - \ | / | - \ | / | - --- | -Level 4 7 | D | | - --- | - / \ | - / \ | - --- --- | -Level 3 4 | G | 6 | E | | - --- --- | - | | | - | | | - --- --- | -Level 2 3 | H | 5 | F | | - --- --- | - \ / | | - \ / | | - \ | | - / \ | | - / \ | | - --- --- | -Level 1 1 | J | 2 | I | | - --- --- | - \ / | - \ / | - --- v -Level 0 0 | K | (More Specialized) - --- - - -0123456789A -KJIHGFEDABC - -=cut - -{ - package Test::A; use mro 'c3'; - - package Test::B; use mro 'c3'; - - package Test::C; use mro 'c3'; - - package Test::D; use mro 'c3'; - use base qw/Test::A Test::B Test::C/; - - package Test::E; use mro 'c3'; - use base qw/Test::D/; - - package Test::F; use mro 'c3'; - use base qw/Test::E/; - sub testmeth { "wrong" } - - package Test::G; use mro 'c3'; - use base qw/Test::D/; - - package Test::H; use mro 'c3'; - use base qw/Test::G/; - - package Test::I; use mro 'c3'; - use base qw/Test::H Test::F/; - sub testmeth { "right" } - - package Test::J; use mro 'c3'; - use base qw/Test::F/; - - package Test::K; use mro 'c3'; - use base qw/Test::J Test::I/; - sub testmeth { shift->next::method } -} - -ok(eq_array( - mro::get_linear_isa('Test::A'), - [ qw(Test::A) ] -), '... got the right C3 merge order for Test::A'); - -ok(eq_array( - mro::get_linear_isa('Test::B'), - [ qw(Test::B) ] -), '... got the right C3 merge order for Test::B'); - -ok(eq_array( - mro::get_linear_isa('Test::C'), - [ qw(Test::C) ] -), '... got the right C3 merge order for Test::C'); - -ok(eq_array( - mro::get_linear_isa('Test::D'), - [ qw(Test::D Test::A Test::B Test::C) ] -), '... got the right C3 merge order for Test::D'); - -ok(eq_array( - mro::get_linear_isa('Test::E'), - [ qw(Test::E Test::D Test::A Test::B Test::C) ] -), '... got the right C3 merge order for Test::E'); - -ok(eq_array( - mro::get_linear_isa('Test::F'), - [ qw(Test::F Test::E Test::D Test::A Test::B Test::C) ] -), '... got the right C3 merge order for Test::F'); - -ok(eq_array( - mro::get_linear_isa('Test::G'), - [ qw(Test::G Test::D Test::A Test::B Test::C) ] -), '... got the right C3 merge order for Test::G'); - -ok(eq_array( - mro::get_linear_isa('Test::H'), - [ qw(Test::H Test::G Test::D Test::A Test::B Test::C) ] -), '... got the right C3 merge order for Test::H'); - -ok(eq_array( - mro::get_linear_isa('Test::I'), - [ qw(Test::I Test::H Test::G Test::F Test::E Test::D Test::A Test::B Test::C) ] -), '... got the right C3 merge order for Test::I'); - -ok(eq_array( - mro::get_linear_isa('Test::J'), - [ qw(Test::J Test::F Test::E Test::D Test::A Test::B Test::C) ] -), '... got the right C3 merge order for Test::J'); - -ok(eq_array( - mro::get_linear_isa('Test::K'), - [ qw(Test::K Test::J Test::I Test::H Test::G Test::F Test::E Test::D Test::A Test::B Test::C) ] -), '... got the right C3 merge order for Test::K'); - -is(Test::K->testmeth(), "right", 'next::method working ok'); diff --git a/t/CORE/mro/complex_dfs.t b/t/CORE/mro/complex_dfs.t deleted file mode 100644 index 0f0655ffc..000000000 --- a/t/CORE/mro/complex_dfs.t +++ /dev/null @@ -1,137 +0,0 @@ -#!./perl - -use strict; -use warnings; - -require q(t/CORE/test.pl); plan(tests => 11); - -=pod - -This example is taken from: http://rt.cpan.org/Public/Bug/Display.html?id=20879 - - --- --- --- -Level 5 8 | A | 9 | B | A | C | (More General) - --- --- --- V - \ | / | - \ | / | - \ | / | - \ | / | - --- | -Level 4 7 | D | | - --- | - / \ | - / \ | - --- --- | -Level 3 4 | G | 6 | E | | - --- --- | - | | | - | | | - --- --- | -Level 2 3 | H | 5 | F | | - --- --- | - \ / | | - \ / | | - \ | | - / \ | | - / \ | | - --- --- | -Level 1 1 | J | 2 | I | | - --- --- | - \ / | - \ / | - --- v -Level 0 0 | K | (More Specialized) - --- - - -0123456789A -KJIHGFEDABC - -=cut - -{ - package Test::A; use mro 'dfs'; - - package Test::B; use mro 'dfs'; - - package Test::C; use mro 'dfs'; - - package Test::D; use mro 'dfs'; - use base qw/Test::A Test::B Test::C/; - - package Test::E; use mro 'dfs'; - use base qw/Test::D/; - - package Test::F; use mro 'dfs'; - use base qw/Test::E/; - - package Test::G; use mro 'dfs'; - use base qw/Test::D/; - - package Test::H; use mro 'dfs'; - use base qw/Test::G/; - - package Test::I; use mro 'dfs'; - use base qw/Test::H Test::F/; - - package Test::J; use mro 'dfs'; - use base qw/Test::F/; - - package Test::K; use mro 'dfs'; - use base qw/Test::J Test::I/; -} - -ok(eq_array( - mro::get_linear_isa('Test::A'), - [ qw(Test::A) ] -), '... got the right DFS merge order for Test::A'); - -ok(eq_array( - mro::get_linear_isa('Test::B'), - [ qw(Test::B) ] -), '... got the right DFS merge order for Test::B'); - -ok(eq_array( - mro::get_linear_isa('Test::C'), - [ qw(Test::C) ] -), '... got the right DFS merge order for Test::C'); - -ok(eq_array( - mro::get_linear_isa('Test::D'), - [ qw(Test::D Test::A Test::B Test::C) ] -), '... got the right DFS merge order for Test::D'); - -ok(eq_array( - mro::get_linear_isa('Test::E'), - [ qw(Test::E Test::D Test::A Test::B Test::C) ] -), '... got the right DFS merge order for Test::E'); - -ok(eq_array( - mro::get_linear_isa('Test::F'), - [ qw(Test::F Test::E Test::D Test::A Test::B Test::C) ] -), '... got the right DFS merge order for Test::F'); - -ok(eq_array( - mro::get_linear_isa('Test::G'), - [ qw(Test::G Test::D Test::A Test::B Test::C) ] -), '... got the right DFS merge order for Test::G'); - -ok(eq_array( - mro::get_linear_isa('Test::H'), - [ qw(Test::H Test::G Test::D Test::A Test::B Test::C) ] -), '... got the right DFS merge order for Test::H'); - -ok(eq_array( - mro::get_linear_isa('Test::I'), - [ qw(Test::I Test::H Test::G Test::D Test::A Test::B Test::C Test::F Test::E) ] -), '... got the right DFS merge order for Test::I'); - -ok(eq_array( - mro::get_linear_isa('Test::J'), - [ qw(Test::J Test::F Test::E Test::D Test::A Test::B Test::C) ] -), '... got the right DFS merge order for Test::J'); - -ok(eq_array( - mro::get_linear_isa('Test::K'), - [ qw(Test::K Test::J Test::F Test::E Test::D Test::A Test::B Test::C Test::I Test::H Test::G) ] -), '... got the right DFS merge order for Test::K'); diff --git a/t/CORE/mro/dbic_c3.t b/t/CORE/mro/dbic_c3.t deleted file mode 100644 index 82d714ce1..000000000 --- a/t/CORE/mro/dbic_c3.t +++ /dev/null @@ -1,119 +0,0 @@ -#!./perl - -use strict; -use warnings; - -require q(t/CORE/test.pl); plan(tests => 1); - -=pod - -This example is taken from the inheritance graph of DBIx::Class::Core in DBIx::Class v0.07002: -(No ASCII art this time, this graph is insane) - -The xx:: prefixes are just to be sure these bogus declarations never stomp on real ones - -=cut - -{ - package xx::DBIx::Class::Core; use mro 'c3'; - our @ISA = qw/ - xx::DBIx::Class::Serialize::Storable - xx::DBIx::Class::InflateColumn - xx::DBIx::Class::Relationship - xx::DBIx::Class::PK::Auto - xx::DBIx::Class::PK - xx::DBIx::Class::Row - xx::DBIx::Class::ResultSourceProxy::Table - xx::DBIx::Class::AccessorGroup - /; - - package xx::DBIx::Class::InflateColumn; use mro 'c3'; - our @ISA = qw/ xx::DBIx::Class::Row /; - - package xx::DBIx::Class::Row; use mro 'c3'; - our @ISA = qw/ xx::DBIx::Class /; - - package xx::DBIx::Class; use mro 'c3'; - our @ISA = qw/ - xx::DBIx::Class::Componentised - xx::Class::Data::Accessor - /; - - package xx::DBIx::Class::Relationship; use mro 'c3'; - our @ISA = qw/ - xx::DBIx::Class::Relationship::Helpers - xx::DBIx::Class::Relationship::Accessor - xx::DBIx::Class::Relationship::CascadeActions - xx::DBIx::Class::Relationship::ProxyMethods - xx::DBIx::Class::Relationship::Base - xx::DBIx::Class - /; - - package xx::DBIx::Class::Relationship::Helpers; use mro 'c3'; - our @ISA = qw/ - xx::DBIx::Class::Relationship::HasMany - xx::DBIx::Class::Relationship::HasOne - xx::DBIx::Class::Relationship::BelongsTo - xx::DBIx::Class::Relationship::ManyToMany - /; - - package xx::DBIx::Class::Relationship::ProxyMethods; use mro 'c3'; - our @ISA = qw/ xx::DBIx::Class /; - - package xx::DBIx::Class::Relationship::Base; use mro 'c3'; - our @ISA = qw/ xx::DBIx::Class /; - - package xx::DBIx::Class::PK::Auto; use mro 'c3'; - our @ISA = qw/ xx::DBIx::Class /; - - package xx::DBIx::Class::PK; use mro 'c3'; - our @ISA = qw/ xx::DBIx::Class::Row /; - - package xx::DBIx::Class::ResultSourceProxy::Table; use mro 'c3'; - our @ISA = qw/ - xx::DBIx::Class::AccessorGroup - xx::DBIx::Class::ResultSourceProxy - /; - - package xx::DBIx::Class::ResultSourceProxy; use mro 'c3'; - our @ISA = qw/ xx::DBIx::Class /; - - package xx::Class::Data::Accessor; our @ISA = (); use mro 'c3'; - package xx::DBIx::Class::Relationship::HasMany; our @ISA = (); use mro 'c3'; - package xx::DBIx::Class::Relationship::HasOne; our @ISA = (); use mro 'c3'; - package xx::DBIx::Class::Relationship::BelongsTo; our @ISA = (); use mro 'c3'; - package xx::DBIx::Class::Relationship::ManyToMany; our @ISA = (); use mro 'c3'; - package xx::DBIx::Class::Componentised; our @ISA = (); use mro 'c3'; - package xx::DBIx::Class::AccessorGroup; our @ISA = (); use mro 'c3'; - package xx::DBIx::Class::Serialize::Storable; our @ISA = (); use mro 'c3'; - package xx::DBIx::Class::Relationship::Accessor; our @ISA = (); use mro 'c3'; - package xx::DBIx::Class::Relationship::CascadeActions; our @ISA = (); use mro 'c3'; -} - -ok(eq_array( - mro::get_linear_isa('xx::DBIx::Class::Core'), - [qw/ - xx::DBIx::Class::Core - xx::DBIx::Class::Serialize::Storable - xx::DBIx::Class::InflateColumn - xx::DBIx::Class::Relationship - xx::DBIx::Class::Relationship::Helpers - xx::DBIx::Class::Relationship::HasMany - xx::DBIx::Class::Relationship::HasOne - xx::DBIx::Class::Relationship::BelongsTo - xx::DBIx::Class::Relationship::ManyToMany - xx::DBIx::Class::Relationship::Accessor - xx::DBIx::Class::Relationship::CascadeActions - xx::DBIx::Class::Relationship::ProxyMethods - xx::DBIx::Class::Relationship::Base - xx::DBIx::Class::PK::Auto - xx::DBIx::Class::PK - xx::DBIx::Class::Row - xx::DBIx::Class::ResultSourceProxy::Table - xx::DBIx::Class::AccessorGroup - xx::DBIx::Class::ResultSourceProxy - xx::DBIx::Class - xx::DBIx::Class::Componentised - xx::Class::Data::Accessor - /] -), '... got the right C3 merge order for xx::DBIx::Class::Core'); diff --git a/t/CORE/mro/dbic_dfs.t b/t/CORE/mro/dbic_dfs.t deleted file mode 100644 index 7d6a1e0f4..000000000 --- a/t/CORE/mro/dbic_dfs.t +++ /dev/null @@ -1,119 +0,0 @@ -#!./perl - -use strict; -use warnings; - -require q(t/CORE/test.pl); plan(tests => 1); - -=pod - -This example is taken from the inheritance graph of DBIx::Class::Core in DBIx::Class v0.07002: -(No ASCII art this time, this graph is insane) - -The xx:: prefixes are just to be sure these bogus declarations never stomp on real ones - -=cut - -{ - package xx::DBIx::Class::Core; use mro 'dfs'; - our @ISA = qw/ - xx::DBIx::Class::Serialize::Storable - xx::DBIx::Class::InflateColumn - xx::DBIx::Class::Relationship - xx::DBIx::Class::PK::Auto - xx::DBIx::Class::PK - xx::DBIx::Class::Row - xx::DBIx::Class::ResultSourceProxy::Table - xx::DBIx::Class::AccessorGroup - /; - - package xx::DBIx::Class::InflateColumn; use mro 'dfs'; - our @ISA = qw/ xx::DBIx::Class::Row /; - - package xx::DBIx::Class::Row; use mro 'dfs'; - our @ISA = qw/ xx::DBIx::Class /; - - package xx::DBIx::Class; use mro 'dfs'; - our @ISA = qw/ - xx::DBIx::Class::Componentised - xx::Class::Data::Accessor - /; - - package xx::DBIx::Class::Relationship; use mro 'dfs'; - our @ISA = qw/ - xx::DBIx::Class::Relationship::Helpers - xx::DBIx::Class::Relationship::Accessor - xx::DBIx::Class::Relationship::CascadeActions - xx::DBIx::Class::Relationship::ProxyMethods - xx::DBIx::Class::Relationship::Base - xx::DBIx::Class - /; - - package xx::DBIx::Class::Relationship::Helpers; use mro 'dfs'; - our @ISA = qw/ - xx::DBIx::Class::Relationship::HasMany - xx::DBIx::Class::Relationship::HasOne - xx::DBIx::Class::Relationship::BelongsTo - xx::DBIx::Class::Relationship::ManyToMany - /; - - package xx::DBIx::Class::Relationship::ProxyMethods; use mro 'dfs'; - our @ISA = qw/ xx::DBIx::Class /; - - package xx::DBIx::Class::Relationship::Base; use mro 'dfs'; - our @ISA = qw/ xx::DBIx::Class /; - - package xx::DBIx::Class::PK::Auto; use mro 'dfs'; - our @ISA = qw/ xx::DBIx::Class /; - - package xx::DBIx::Class::PK; use mro 'dfs'; - our @ISA = qw/ xx::DBIx::Class::Row /; - - package xx::DBIx::Class::ResultSourceProxy::Table; use mro 'dfs'; - our @ISA = qw/ - xx::DBIx::Class::AccessorGroup - xx::DBIx::Class::ResultSourceProxy - /; - - package xx::DBIx::Class::ResultSourceProxy; use mro 'dfs'; - our @ISA = qw/ xx::DBIx::Class /; - - package xx::Class::Data::Accessor; our @ISA = (); use mro 'dfs'; - package xx::DBIx::Class::Relationship::HasMany; our @ISA = (); use mro 'dfs'; - package xx::DBIx::Class::Relationship::HasOne; our @ISA = (); use mro 'dfs'; - package xx::DBIx::Class::Relationship::BelongsTo; our @ISA = (); use mro 'dfs'; - package xx::DBIx::Class::Relationship::ManyToMany; our @ISA = (); use mro 'dfs'; - package xx::DBIx::Class::Componentised; our @ISA = (); use mro 'dfs'; - package xx::DBIx::Class::AccessorGroup; our @ISA = (); use mro 'dfs'; - package xx::DBIx::Class::Serialize::Storable; our @ISA = (); use mro 'dfs'; - package xx::DBIx::Class::Relationship::Accessor; our @ISA = (); use mro 'dfs'; - package xx::DBIx::Class::Relationship::CascadeActions; our @ISA = (); use mro 'dfs'; -} - -ok(eq_array( - mro::get_linear_isa('xx::DBIx::Class::Core'), - [qw/ - xx::DBIx::Class::Core - xx::DBIx::Class::Serialize::Storable - xx::DBIx::Class::InflateColumn - xx::DBIx::Class::Row - xx::DBIx::Class - xx::DBIx::Class::Componentised - xx::Class::Data::Accessor - xx::DBIx::Class::Relationship - xx::DBIx::Class::Relationship::Helpers - xx::DBIx::Class::Relationship::HasMany - xx::DBIx::Class::Relationship::HasOne - xx::DBIx::Class::Relationship::BelongsTo - xx::DBIx::Class::Relationship::ManyToMany - xx::DBIx::Class::Relationship::Accessor - xx::DBIx::Class::Relationship::CascadeActions - xx::DBIx::Class::Relationship::ProxyMethods - xx::DBIx::Class::Relationship::Base - xx::DBIx::Class::PK::Auto - xx::DBIx::Class::PK - xx::DBIx::Class::ResultSourceProxy::Table - xx::DBIx::Class::AccessorGroup - xx::DBIx::Class::ResultSourceProxy - /] -), '... got the right DFS merge order for xx::DBIx::Class::Core'); diff --git a/t/CORE/mro/inconsistent_c3.t b/t/CORE/mro/inconsistent_c3.t deleted file mode 100644 index 6f14ebe03..000000000 --- a/t/CORE/mro/inconsistent_c3.t +++ /dev/null @@ -1,46 +0,0 @@ -#!./perl - -use strict; -use warnings; - -BEGIN { - require q(t/CORE/test.pl); -} -plan(tests => 1); - -require mro; - -=pod - -This example is take from: http://www.python.org/2.3/mro.html - -"Serious order disagreement" # From Guido -class O: pass -class X(O): pass -class Y(O): pass -class A(X,Y): pass -class B(Y,X): pass -try: - class Z(A,B): pass #creates Z(A,B) in Python 2.2 -except TypeError: - pass # Z(A,B) cannot be created in Python 2.3 - -=cut - -{ - package X; - - package Y; - - package XY; - our @ISA = ('X', 'Y'); - - package YX; - our @ISA = ('Y', 'X'); - - package Z; - our @ISA = ('XY', 'YX'); -} - -eval { mro::get_linear_isa('Z', 'c3') }; -like($@, qr/^Inconsistent /, '... got the right error with an inconsistent hierarchy'); diff --git a/t/CORE/mro/isa_aliases.t b/t/CORE/mro/isa_aliases.t deleted file mode 100644 index 05b60f3d2..000000000 --- a/t/CORE/mro/isa_aliases.t +++ /dev/null @@ -1,43 +0,0 @@ -#!./perl - -BEGIN { require 't/CORE/test.pl' } - -plan 12; - -@Foogh::ISA = "Bar"; -*Phoogh::ISA = *Foogh::ISA; -@Foogh::ISA = "Baz"; - -ok 'Foogh'->isa("Baz"), - 'isa after another stash has claimed the @ISA via glob assignment'; -ok 'Phoogh'->isa("Baz"), - 'isa on the stash that claimed the @ISA via glob assignment'; -ok !Foogh->isa("Bar"), - '!isa when another stash has claimed the @ISA via glob assignment'; -ok !Phoogh->isa("Bar"), - '!isa on the stash that claimed the @ISA via glob assignment'; - -@Foogh::ISA = "Bar"; -*Foogh::ISA = ["Baz"]; - -ok 'Foogh'->isa("Baz"), - 'isa after glob-to-ref assignment when *ISA is shared'; -ok 'Phoogh'->isa("Baz"), - 'isa after glob-to-ref assignment on another stash when *ISA is shared'; -ok !Foogh->isa("Bar"), - '!isa after glob-to-ref assignment when *ISA is shared'; -ok !Phoogh->isa("Bar"), - '!isa after glob-to-ref assignment on another stash when *ISA is shared'; - -@Foo::ISA = "Bar"; -*Phoo::ISA = \@Foo::ISA; -@Foo::ISA = "Baz"; - -ok 'Foo'->isa("Baz"), - 'isa after another stash has claimed the @ISA via ref-to-glob assignment'; -ok 'Phoo'->isa("Baz"), - 'isa on the stash that claimed the @ISA via ref-to-glob assignment'; -ok !Foo->isa("Bar"), - '!isa when another stash has claimed the @ISA via ref-to-glob assignment'; -ok !Phoo->isa("Bar"), - '!isa on the stash that claimed the @ISA via ref-to-glob assignment'; diff --git a/t/CORE/mro/isa_c3.t b/t/CORE/mro/isa_c3.t deleted file mode 100644 index dc9d87f53..000000000 --- a/t/CORE/mro/isa_c3.t +++ /dev/null @@ -1,68 +0,0 @@ -#!perl -w - -BEGIN { - unshift @INC, 't/CORE/lib'; - require "t/CORE/test.pl"; -} - -use strict; - -plan 'no_plan'; - -# package klonk doesn't have a stash. - -package kapow; -use mro 'c3'; - -# No parents - -package urkkk; -use mro 'c3'; - -# 1 parent -@urkkk::ISA = 'klonk'; - -package kayo; -use mro 'c3'; - -# 2 parents -@urkkk::ISA = ('klonk', 'kapow'); - -package thwacke; -use mro 'c3'; - -# No parents, has @ISA -@thwacke::ISA = (); - -package zzzzzwap; -use mro 'c3'; - -@zzzzzwap::ISA = ('thwacke', 'kapow'); - -package whamm; -use mro 'c3'; - -@whamm::ISA = ('kapow', 'thwacke'); - -package main; - -my %expect = - ( - klonk => [qw(klonk)], - urkkk => [qw(urkkk klonk kapow)], - kapow => [qw(kapow)], - kayo => [qw(kayo)], - thwacke => [qw(thwacke)], - zzzzzwap => [qw(zzzzzwap thwacke kapow)], - whamm => [qw(whamm kapow thwacke)], - ); - -foreach my $package (qw(klonk urkkk kapow kayo thwacke zzzzzwap whamm)) { - my $ref = bless [], $package; - my $isa = $expect{$package}; - is("@{mro::get_linear_isa($package)}", "@$isa", "\@ISA for $package"); - - foreach my $class ($package, @$isa, 'UNIVERSAL') { - isa_ok($ref, $class, $package); - } -} diff --git a/t/CORE/mro/isa_dfs.t b/t/CORE/mro/isa_dfs.t deleted file mode 100644 index 0373dcc7e..000000000 --- a/t/CORE/mro/isa_dfs.t +++ /dev/null @@ -1,64 +0,0 @@ -#!perl -w - -BEGIN { - unshift @INC, 't/CORE/lib'; - require "t/CORE/test.pl"; -} - -use strict; - -plan 'no_plan'; - -# package klonk doesn't have a stash. - -package kapow; - -# No parents - -package urkkk; - -# 1 parent -@urkkk::ISA = 'klonk'; - -package kayo; - -# 2 parents -@urkkk::ISA = ('klonk', 'kapow'); - -package thwacke; - -# No parents, has @ISA -@thwacke::ISA = (); - -package zzzzzwap; - -@zzzzzwap::ISA = ('thwacke', 'kapow'); - -package whamm; - -@whamm::ISA = ('kapow', 'thwacke'); - -package main; - -require mro; - -my %expect = - ( - klonk => [qw(klonk)], - urkkk => [qw(urkkk klonk kapow)], - kapow => [qw(kapow)], - kayo => [qw(kayo)], - thwacke => [qw(thwacke)], - zzzzzwap => [qw(zzzzzwap thwacke kapow)], - whamm => [qw(whamm kapow thwacke)], - ); - -foreach my $package (qw(klonk urkkk kapow kayo thwacke zzzzzwap whamm)) { - my $ref = bless [], $package; - my $isa = $expect{$package}; - is("@{mro::get_linear_isa($package)}", "@$isa", "\@ISA for $package"); - - foreach my $class ($package, @$isa, 'UNIVERSAL') { - isa_ok($ref, $class, $package); - } -} diff --git a/t/CORE/mro/isarev.t b/t/CORE/mro/isarev.t deleted file mode 100644 index f1718796e..000000000 --- a/t/CORE/mro/isarev.t +++ /dev/null @@ -1,149 +0,0 @@ -#!./perl - -BEGIN { - require q(t/CORE/test.pl); -} - -use strict; -use warnings; -plan(tests => 24); - -use mro; - -sub i { - my @args = @_; - @_ - = ( - join(" ", sort @{mro::get_isarev $args[0]}), - join(" ", sort @args[1..$#args-1]), - pop @args - ); - goto &is; -} - -# Basic isarev updating, when @ISA changes -@Pastern::ISA = "BodyPart::Ungulate"; -@Scur::ISA = "BodyPart::Ungulate"; -@BodyPart::Ungulate::ISA = "BodyPart"; -i BodyPart => qw [ BodyPart::Ungulate Pastern Scur ], - 'subclasses and subsubclasses are added to isarev'; -@Pastern::ISA = (); -i BodyPart => qw [ BodyPart::Ungulate Scur ], - 'single deletion from isarev'; -@BodyPart::Ungulate::ISA = (); -i BodyPart => qw [ ], 'recursive deletion from isarev'; - # except underneath it is not actually recursive - - -# More complicated tests that move packages around - -@Huskey::ISA = "Dog"; -@Dog::ISA = "Canid"; -@Wolf::ISA = "Canid"; -@Some::Brand::Name::ISA = "Dog::Bone"; -@Dog::Bone::ISA = "Treat"; -@Free::Time::ISA = "Treat"; -@MyCollar::ISA = "Dog::Collar::Leather"; -@Dog::Collar::Leather::ISA = "Collar"; -@Another::Collar::ISA = "Collar"; -*Tike:: = *Dog::; -delete $::{"Dog::"}; -i Canid=>qw[ Wolf Tike ], - "deleting a stash elem updates isarev entries"; -i Treat=>qw[ Free::Time Tike::Bone ], - "deleting a nested stash elem updates isarev entries"; -i Collar=>qw[ Another::Collar Tike::Collar::Leather ], - "deleting a doubly nested stash elem updates isarev entries"; - -@Goat::ISA = "Ungulate"; -@Goat::Dairy::ISA = "Goat"; -@Goat::Dairy::Toggenburg::ISA = "Goat::Dairy"; -@Weird::Thing::ISA = "g"; -# Warning: glob_assign_glob is generally unsafe to do with perlcc. (#282) -# just assigning the stashes and @ISA is safer. -%g:: = %Goat::; @g::ISA = @Goat::ISA; -#*g:: = *Goat::; -i Goat => qw[ Goat::Dairy Goat::Dairy::Toggenburg Weird::Thing ], - "isarev includes subclasses of aliases"; -delete $::{"g::"}; -i Ungulate => qw[ Goat Goat::Dairy Goat::Dairy::Toggenburg ], - "deleting an alias to a package updates isarev entries"; -i"Goat" => qw[ Goat::Dairy Goat::Dairy::Toggenburg ], - "deleting an alias to a package updates isarev entries of nested stashes"; -i"Goat::Dairy" => qw[ Goat::Dairy::Toggenburg ], - "deleting an stash alias updates isarev entries of doubly nested stashes"; -i g => qw [ Weird::Thing ], - "subclasses of the deleted alias become part of its isarev"; - -@Caprine::ISA = "Hoofed::Mammal"; -@Caprine::Dairy::ISA = "Caprine"; -@Caprine::Dairy::Oberhasli::ISA = "Caprine::Dairy"; -@Whatever::ISA = "Caprine"; -#*Caprid:: = *Caprine::; -%Caprid:: = %Caprine::; @Caprid::ISA = @Caprine::ISA; -#*Caprine:: = *Chevre::; -%Caprine:: = %Chevre::; @Caprine::ISA = @Chevre::ISA; -i"Hoofed::Mammal" => qw[ Caprid ], - "replacing a stash updates isarev entries"; -i Chevre => qw[ Caprid::Dairy Whatever ], - "replacing nested stashes updates isarev entries"; - -@Disease::Eye::ISA = "Disease"; -@Disease::Eye::Infectious::ISA = "Disease::Eye"; -@Keratoconjunctivitis::ISA = "Disease::Ophthalmic::Infectious"; -*Disease::Ophthalmic:: = *Disease::Eye::; -{package some_random_new_symbol::Infectious} # autovivify -*Disease::Ophthalmic:: = *some_random_new_symbol::; -i Disease => qw[ Disease::Eye Disease::Eye::Infectious ], - "replacing an alias of a stash updates isarev entries"; -i"Disease::Eye" => qw[ Disease::Eye::Infectious ], - "replacing an alias of a stash containing another updates isarev entries"; -i"some_random_new_symbol::Infectious" => qw[ Keratoconjunctivitis ], - "replacing an alias updates isarev of stashes nested in the replacement"; - -# Globs ending with :: have autovivified stashes in them by default. We -# want one without a stash. -undef *Empty::; -@Null::ISA = "Empty"; -@Null::Null::ISA = "Empty::Empty"; -{package Zilch::Empty} # autovivify it -*Empty:: = *Zilch::; -i Zilch => qw[ Null ], "assigning to an empty spot updates isarev"; -i"Zilch::Empty" => qw[ Null::Null ], - "assigning to an empty spot updates isarev of nested packages"; - -# Classes inheriting from multiple classes that get moved in a single -# assignment. -@foo::ISA = ("xB", "xB::B"); -{package A::B} -my $A = \%A::; # keep a ref -*A:: = 'whatever'; # clobber it -*xB:: = $A; # assign to two superclasses of foo at the same time -# There should be no A::B isarev entry. -i"A::B" => qw [], 'assigning to two superclasses at the same time'; -ok !foo->isa("A::B"), - "A class must not inherit from its superclass’s former name"; - -# undeffing globs -@alpha::ISA = 'beta'; -$_ = \*alpha::ISA; # hang on to the glob -undef *alpha::ISA; -i beta => qw [], "undeffing an ISA glob deletes isarev entries"; -@az::ISA = 'buki'; -$_ = \*az::ISA; -undef *az::; -i buki => qw [], "undeffing a package glob deletes isarev entries"; - -# Package aliasing/clobbering when the clobbered package has grandchildren -# by inheritance. -@bar::ISA = 'phoo'; -@subclassA::ISA = "subclassB"; -@subclassB::ISA = "bar"; -#*bar:: = *baz::; -%bar:: = %baz::; @bar::ISA = @baz::ISA; -i phoo => qw [], - 'clobbering a class w/multiple layers of subclasses updates its parent'; - -@Thrat::ISA = 'Smin'; -%Thrat:: = (); -i Smin => qw [], '%Package:: list assignment'; diff --git a/t/CORE/mro/method_caching.t b/t/CORE/mro/method_caching.t deleted file mode 100644 index dd3f5dc5e..000000000 --- a/t/CORE/mro/method_caching.t +++ /dev/null @@ -1,59 +0,0 @@ -#!./perl - -use strict; -use warnings; -no warnings 'redefine'; # we do a lot of this -no warnings 'prototype'; # we do a lot of this - -BEGIN { - require 't/CORE/test.pl'; -} - -{ - package MCTest::Base; - sub foo { return $_[1]+1 }; - - package MCTest::Derived; - our @ISA = qw/MCTest::Base/; - - package Foo; our @FOO = qw//; -} - -# These are various ways of re-defining MCTest::Base::foo and checking whether the method is cached when it shouldn't be -my @testsubs = ( - sub { is(MCTest::Derived->foo(0), 1); }, - sub { eval 'sub MCTest::Base::foo { return $_[1]+2 }'; is(MCTest::Derived->foo(0), 2); }, - sub { eval 'sub MCTest::Base::foo($) { return $_[1]+3 }'; is(MCTest::Derived->foo(0), 3); }, - sub { eval 'sub MCTest::Base::foo($) { 4 }'; is(MCTest::Derived->foo(0), 4); }, - sub { *MCTest::Base::foo = sub { $_[1]+5 }; is(MCTest::Derived->foo(0), 5); }, - sub { local *MCTest::Base::foo = sub { $_[1]+6 }; is(MCTest::Derived->foo(0), 6); }, - sub { is(MCTest::Derived->foo(0), 5); }, - sub { sub FFF { $_[1]+7 }; local *MCTest::Base::foo = *FFF; is(MCTest::Derived->foo(0), 7); }, - sub { is(MCTest::Derived->foo(0), 5); }, - sub { sub DDD { $_[1]+8 }; *MCTest::Base::foo = *DDD; is(MCTest::Derived->foo(0), 8); }, - sub { *ASDF::asdf = sub { $_[1]+9 }; *MCTest::Base::foo = \&ASDF::asdf; is(MCTest::Derived->foo(0), 9); }, - sub { undef *MCTest::Base::foo; eval { MCTest::Derived->foo(0) }; like($@, qr/locate object method/); }, - sub { eval "sub MCTest::Base::foo($);"; *MCTest::Base::foo = \&ASDF::asdf; is(MCTest::Derived->foo(0), 9); }, - sub { *XYZ = sub { $_[1]+10 }; ${MCTest::Base::}{foo} = \&XYZ; is(MCTest::Derived->foo(0), 10); }, - sub { ${MCTest::Base::}{foo} = sub { $_[1]+11 }; is(MCTest::Derived->foo(0), 11); }, - - sub { undef *MCTest::Base::foo; eval { MCTest::Derived->foo(0) }; like($@, qr/locate object method/); }, - sub { eval 'package MCTest::Base; sub foo { $_[1]+12 }'; is(MCTest::Derived->foo(0), 12); }, - sub { eval 'package ZZZ; sub foo { $_[1]+13 }'; *MCTest::Base::foo = \&ZZZ::foo; is(MCTest::Derived->foo(0), 13); }, - sub { ${MCTest::Base::}{foo} = sub { $_[1]+14 }; is(MCTest::Derived->foo(0), 14); }, - # 5.8.8 fails this one - sub { undef *{MCTest::Base::}; eval { MCTest::Derived->foo(0) }; like($@, qr/locate object method/); }, - sub { eval 'package MCTest::Base; sub foo { $_[1]+15 }'; is(MCTest::Derived->foo(0), 15); }, - sub { undef %{MCTest::Base::}; eval { MCTest::Derived->foo(0) }; like($@, qr/locate object method/); }, - sub { eval 'package MCTest::Base; sub foo { $_[1]+16 }'; is(MCTest::Derived->foo(0), 16); }, - sub { %{MCTest::Base::} = (); eval { MCTest::Derived->foo(0) }; like($@, qr/locate object method/); }, - sub { eval 'package MCTest::Base; sub foo { $_[1]+17 }'; is(MCTest::Derived->foo(0), 17); }, - # 5.8.8 fails this one too - sub { *{MCTest::Base::} = *{Foo::}; eval { MCTest::Derived->foo(0) }; like($@, qr/locate object method/); }, - sub { *MCTest::Derived::foo = \&MCTest::Base::foo; eval { MCTest::Derived::foo(0,0) }; ok(!$@); undef *MCTest::Derived::foo }, - sub { eval 'package MCTest::Base; sub foo { $_[1]+18 }'; is(MCTest::Derived->foo(0), 18); }, -); - -plan(tests => scalar(@testsubs)); - -$_->() for (@testsubs); diff --git a/t/CORE/mro/next_NEXT.t b/t/CORE/mro/next_NEXT.t deleted file mode 100644 index 5a6c4eec3..000000000 --- a/t/CORE/mro/next_NEXT.t +++ /dev/null @@ -1,48 +0,0 @@ -#!/usr/bin/perl - -use strict; -use warnings; -use NEXT; - -require 't/CORE/test.pl'; -plan(tests => 4); - -{ - package Foo; - use strict; - use warnings; - use mro 'c3'; - - sub foo { 'Foo::foo' } - - package Fuz; - use strict; - use warnings; - use mro 'c3'; - use base 'Foo'; - - sub foo { 'Fuz::foo => ' . (shift)->next::method } - - package Bar; - use strict; - use warnings; - use mro 'c3'; - use base 'Foo'; - - sub foo { 'Bar::foo => ' . (shift)->next::method } - - package Baz; - use strict; - use warnings; - - use base 'Bar', 'Fuz'; - - sub foo { 'Baz::foo => ' . (shift)->NEXT::foo } -} - -is(Foo->foo, 'Foo::foo', '... got the right value from Foo->foo'); -is(Fuz->foo, 'Fuz::foo => Foo::foo', '... got the right value from Fuz->foo'); -is(Bar->foo, 'Bar::foo => Foo::foo', '... got the right value from Bar->foo'); - -is(Baz->foo, 'Baz::foo => Bar::foo => Fuz::foo => Foo::foo', '... got the right value using NEXT in a subclass of a C3 class'); - diff --git a/t/CORE/mro/next_edgecases.t b/t/CORE/mro/next_edgecases.t deleted file mode 100644 index bfeb7ae5d..000000000 --- a/t/CORE/mro/next_edgecases.t +++ /dev/null @@ -1,96 +0,0 @@ -#!/usr/bin/perl - -use strict; -use warnings; - -BEGIN { require q(t/CORE/test.pl); } - -plan(tests => 12); - -{ - - { - package Foo; - use strict; - use warnings; - use mro 'c3'; - sub new { bless {}, $_[0] } - sub bar { 'Foo::bar' } - } - - # call the submethod in the direct instance - - my $foo = Foo->new(); - isa_ok($foo, 'Foo'); - - can_ok($foo, 'bar'); - is($foo->bar(), 'Foo::bar', '... got the right return value'); - - # fail calling it from a subclass - - { - package Bar; - use strict; - use warnings; - use mro 'c3'; - our @ISA = ('Foo'); - } - - my $bar = Bar->new(); - isa_ok($bar, 'Bar'); - isa_ok($bar, 'Foo'); - - # test it working with with Sub::Name - SKIP: { - eval 'use Sub::Name'; - skip("Sub::Name is required for this test", 3) if $@; - - my $m = sub { (shift)->next::method() }; - my $name = 'Bar::bar'; - Sub::Name::subname($name, $m); - { - no strict 'refs'; - *{$name} = $m; - } - - can_ok($bar, 'bar'); - my $value = eval { $bar->bar() }; - ok(!$@, '... calling bar() succeeded') || diag $@; - is($value, 'Foo::bar', '... got the right return value too'); - } - - # test it failing without Sub::Name - { - package Baz; - use strict; - use warnings; - use mro 'c3'; - our @ISA = ('Foo'); - } - - my $baz = Baz->new(); - isa_ok($baz, 'Baz'); - isa_ok($baz, 'Foo'); - - { - my $m = sub { (shift)->next::method() }; - { - no strict 'refs'; - *{'Baz::bar'} = $m; - } - - eval { $baz->bar() }; - ok($@, '... calling bar() with next::method failed') || diag $@; - } - - # Test with non-existing class (used to segfault) - { - package Qux; - use mro; - sub foo { No::Such::Class->next::can } - } - - eval { Qux->foo() }; - is($@, '', "->next::can on non-existing package name"); - -} diff --git a/t/CORE/mro/next_goto.t b/t/CORE/mro/next_goto.t deleted file mode 100644 index 2ea26a1cb..000000000 --- a/t/CORE/mro/next_goto.t +++ /dev/null @@ -1,35 +0,0 @@ -#!/usr/bin/perl - -use strict; -use warnings; - -require q(t/CORE/test.pl); plan(tests => 4); - -use mro; - -{ - package Proxy; - our @ISA = qw//; - sub next_proxy { goto &next::method } - sub maybe_proxy { goto &maybe::next::method } - sub can_proxy { goto &next::can } - - package TBase; - our @ISA = qw//; - sub foo { 42 } - sub bar { 24 } - # baz doesn't exist intentionally - sub quux { 242 } - - package TTop; - our @ISA = qw/TBase/; - sub foo { shift->Proxy::next_proxy() } - sub bar { shift->Proxy::maybe_proxy() } - sub baz { shift->Proxy::maybe_proxy() } - sub quux { shift->Proxy::can_proxy()->() } -} - -is(TTop->foo, 42, 'proxy next::method via goto'); -is(TTop->bar, 24, 'proxy maybe::next::method via goto'); -ok(!TTop->baz, 'proxy maybe::next::method via goto with no method'); -is(TTop->quux, 242, 'proxy next::can via goto'); diff --git a/t/CORE/mro/next_inanon.t b/t/CORE/mro/next_inanon.t deleted file mode 100644 index 5d58abc1e..000000000 --- a/t/CORE/mro/next_inanon.t +++ /dev/null @@ -1,57 +0,0 @@ -#!/usr/bin/perl - -use strict; -use warnings; - -require q(t/CORE/test.pl); plan(tests => 2); - -=pod - -This tests the successful handling of a next::method call from within an -anonymous subroutine. - -=cut - -{ - package A; - use mro 'c3'; - - sub foo { - return 'A::foo'; - } - - sub bar { - return 'A::bar'; - } -} - -{ - package B; - use base 'A'; - use mro 'c3'; - - sub foo { - my $code = sub { - return 'B::foo => ' . (shift)->next::method(); - }; - return (shift)->$code; - } - - sub bar { - my $code1 = sub { - my $code2 = sub { - return 'B::bar => ' . (shift)->next::method(); - }; - return (shift)->$code2; - }; - return (shift)->$code1; - } -} - -is(B->foo, "B::foo => A::foo", - 'method resolved inside anonymous sub'); - -is(B->bar, "B::bar => A::bar", - 'method resolved inside nested anonymous subs'); - - diff --git a/t/CORE/mro/next_ineval.t b/t/CORE/mro/next_ineval.t deleted file mode 100644 index b27f6d9c0..000000000 --- a/t/CORE/mro/next_ineval.t +++ /dev/null @@ -1,44 +0,0 @@ -#!/usr/bin/perl - -use strict; -use warnings; - -require q(t/CORE/test.pl); plan(tests => 1); - -=pod - -This tests the use of an eval{} block to wrap a next::method call. - -=cut - -{ - package A; - use mro 'c3'; - - sub foo { - die 'A::foo died'; - return 'A::foo succeeded'; - } -} - -{ - package B; - use base 'A'; - use mro 'c3'; - - sub foo { - eval { - return 'B::foo => ' . (shift)->next::method(); - }; - - if ($@) { - return $@; - } - } -} - -like(B->foo, - qr/^A::foo died/, - 'method resolved inside eval{}'); - - diff --git a/t/CORE/mro/next_method.t b/t/CORE/mro/next_method.t deleted file mode 100644 index 325d606f0..000000000 --- a/t/CORE/mro/next_method.t +++ /dev/null @@ -1,65 +0,0 @@ -#!/usr/bin/perl - -use strict; -use warnings; - -require q(t/CORE/test.pl); plan(tests => 5); - -=pod - -This tests the classic diamond inheritance pattern. - - - / \ - - \ / - - -=cut - -{ - package Diamond_A; - use mro 'c3'; - sub hello { 'Diamond_A::hello' } - sub foo { 'Diamond_A::foo' } -} -{ - package Diamond_B; - use base 'Diamond_A'; - use mro 'c3'; - sub foo { 'Diamond_B::foo => ' . (shift)->next::method() } -} -{ - package Diamond_C; - use mro 'c3'; - use base 'Diamond_A'; - - sub hello { 'Diamond_C::hello => ' . (shift)->next::method() } - sub foo { 'Diamond_C::foo => ' . (shift)->next::method() } -} -{ - package Diamond_D; - use base ('Diamond_B', 'Diamond_C'); - use mro 'c3'; - - sub foo { 'Diamond_D::foo => ' . (shift)->next::method() } -} - -ok(eq_array( - mro::get_linear_isa('Diamond_D'), - [ qw(Diamond_D Diamond_B Diamond_C Diamond_A) ] -), '... got the right MRO for Diamond_D'); - -is(Diamond_D->hello, 'Diamond_C::hello => Diamond_A::hello', '... method resolved itself as expected'); - -is(Diamond_D->can('hello')->('Diamond_D'), - 'Diamond_C::hello => Diamond_A::hello', - '... can(method) resolved itself as expected'); - -is(UNIVERSAL::can("Diamond_D", 'hello')->('Diamond_D'), - 'Diamond_C::hello => Diamond_A::hello', - '... can(method) resolved itself as expected'); - -is(Diamond_D->foo, - 'Diamond_D::foo => Diamond_B::foo => Diamond_C::foo => Diamond_A::foo', - '... method foo resolved itself as expected'); diff --git a/t/CORE/mro/next_skip.t b/t/CORE/mro/next_skip.t deleted file mode 100644 index 86e3cf063..000000000 --- a/t/CORE/mro/next_skip.t +++ /dev/null @@ -1,75 +0,0 @@ -#!/usr/bin/perl - -use strict; -use warnings; - -require q(t/CORE/test.pl); plan(tests => 10); - -=pod - -This tests the classic diamond inheritance pattern. - - - / \ - - \ / - - -=cut - -{ - package Diamond_A; - use mro 'c3'; - sub bar { 'Diamond_A::bar' } - sub baz { 'Diamond_A::baz' } -} -{ - package Diamond_B; - use base 'Diamond_A'; - use mro 'c3'; - sub baz { 'Diamond_B::baz => ' . (shift)->next::method() } -} -{ - package Diamond_C; - use mro 'c3'; - use base 'Diamond_A'; - sub foo { 'Diamond_C::foo' } - sub buz { 'Diamond_C::buz' } - - sub woz { 'Diamond_C::woz' } - sub maybe { 'Diamond_C::maybe' } -} -{ - package Diamond_D; - use base ('Diamond_B', 'Diamond_C'); - use mro 'c3'; - sub foo { 'Diamond_D::foo => ' . (shift)->next::method() } - sub bar { 'Diamond_D::bar => ' . (shift)->next::method() } - sub buz { 'Diamond_D::buz => ' . (shift)->baz() } - sub fuz { 'Diamond_D::fuz => ' . (shift)->next::method() } - - sub woz { 'Diamond_D::woz can => ' . ((shift)->next::can() ? 1 : 0) } - sub noz { 'Diamond_D::noz can => ' . ((shift)->next::can() ? 1 : 0) } - - sub maybe { 'Diamond_D::maybe => ' . ((shift)->maybe::next::method() || 0) } - sub moybe { 'Diamond_D::moybe => ' . ((shift)->maybe::next::method() || 0) } - -} - -ok(eq_array( - mro::get_linear_isa('Diamond_D'), - [ qw(Diamond_D Diamond_B Diamond_C Diamond_A) ] -), '... got the right MRO for Diamond_D'); - -is(Diamond_D->foo, 'Diamond_D::foo => Diamond_C::foo', '... skipped B and went to C correctly'); -is(Diamond_D->bar, 'Diamond_D::bar => Diamond_A::bar', '... skipped B & C and went to A correctly'); -is(Diamond_D->baz, 'Diamond_B::baz => Diamond_A::baz', '... called B method, skipped C and went to A correctly'); -is(Diamond_D->buz, 'Diamond_D::buz => Diamond_B::baz => Diamond_A::baz', '... called D method dispatched to , different method correctly'); -eval { Diamond_D->fuz }; -like($@, qr/^No next::method 'fuz' found for Diamond_D/, '... cannot re-dispatch to a method which is not there'); - -is(Diamond_D->woz, 'Diamond_D::woz can => 1', '... can re-dispatch figured out correctly'); -is(Diamond_D->noz, 'Diamond_D::noz can => 0', '... cannot re-dispatch figured out correctly'); - -is(Diamond_D->maybe, 'Diamond_D::maybe => Diamond_C::maybe', '... redispatched D to C when it exists'); -is(Diamond_D->moybe, 'Diamond_D::moybe => 0', '... quietly failed redispatch from D'); diff --git a/t/CORE/mro/overload_c3.t b/t/CORE/mro/overload_c3.t deleted file mode 100644 index c91b3be15..000000000 --- a/t/CORE/mro/overload_c3.t +++ /dev/null @@ -1,51 +0,0 @@ -#!./perl - -use strict; -use warnings; - -BEGIN { - require q(t/CORE/test.pl); -} -plan(tests => 7); - -{ - package BaseTest; - use strict; - use warnings; - use mro 'c3'; - - package OverloadingTest; - use strict; - use warnings; - use mro 'c3'; - use base 'BaseTest'; - use overload '""' => sub { ref(shift) . " stringified" }, - fallback => 1; - - sub new { bless {} => shift } - - package InheritingFromOverloadedTest; - use strict; - use warnings; - use base 'OverloadingTest'; - use mro 'c3'; -} - -my $x = InheritingFromOverloadedTest->new(); -isa_ok($x, 'InheritingFromOverloadedTest'); - -my $y = OverloadingTest->new(); -isa_ok($y, 'OverloadingTest'); - -is("$x", 'InheritingFromOverloadedTest stringified', '... got the right value when stringifing'); -is("$y", 'OverloadingTest stringified', '... got the right value when stringifing'); - -ok(($y eq 'OverloadingTest stringified'), '... eq was handled correctly'); - -my $result; -eval { - $result = $x eq 'InheritingFromOverloadedTest stringified' -}; -ok(!$@, '... this should not throw an exception'); -ok($result, '... and we should get the true value'); - diff --git a/t/CORE/mro/overload_dfs.t b/t/CORE/mro/overload_dfs.t deleted file mode 100644 index 897dd0c40..000000000 --- a/t/CORE/mro/overload_dfs.t +++ /dev/null @@ -1,51 +0,0 @@ -#!./perl - -use strict; -use warnings; - -BEGIN { - require q(t/CORE/test.pl); -} -plan(tests => 7); - -{ - package BaseTest; - use strict; - use warnings; - use mro 'dfs'; - - package OverloadingTest; - use strict; - use warnings; - use mro 'dfs'; - use base 'BaseTest'; - use overload '""' => sub { ref(shift) . " stringified" }, - fallback => 1; - - sub new { bless {} => shift } - - package InheritingFromOverloadedTest; - use strict; - use warnings; - use base 'OverloadingTest'; - use mro 'dfs'; -} - -my $x = InheritingFromOverloadedTest->new(); -isa_ok($x, 'InheritingFromOverloadedTest'); - -my $y = OverloadingTest->new(); -isa_ok($y, 'OverloadingTest'); - -is("$x", 'InheritingFromOverloadedTest stringified', '... got the right value when stringifing'); -is("$y", 'OverloadingTest stringified', '... got the right value when stringifing'); - -ok(($y eq 'OverloadingTest stringified'), '... eq was handled correctly'); - -my $result; -eval { - $result = $x eq 'InheritingFromOverloadedTest stringified' -}; -ok(!$@, '... this should not throw an exception'); -ok($result, '... and we should get the true value'); - diff --git a/t/CORE/mro/package_aliases.t b/t/CORE/mro/package_aliases.t deleted file mode 100644 index 01eb7b9f6..000000000 --- a/t/CORE/mro/package_aliases.t +++ /dev/null @@ -1,398 +0,0 @@ -#!./perl - -BEGIN { - require q(t/CORE/test.pl); -} - -use strict; -use warnings; -plan(tests => 52); - -{ - package New; - use strict; - use warnings; - - package Old; - use strict; - use warnings; - - { - no strict 'refs'; - *{'Old::'} = *{'New::'}; - } -} - -ok (Old->isa (New::), 'Old inherits from New'); -ok (New->isa (Old::), 'New inherits from Old'); - -isa_ok (bless ({}, Old::), New::, 'Old object'); -isa_ok (bless ({}, New::), Old::, 'New object'); - - -# Test that replacing a package by assigning to an existing glob -# invalidates the isa caches -for( - { - name => 'assigning a glob to a glob', - code => '$life_raft = $::{"Left::"}; *Left:: = $::{"Right::"}', - }, - { - name => 'assigning a string to a glob', - code => '$life_raft = $::{"Left::"}; *Left:: = "Right::"', - }, - { - name => 'assigning a stashref to a glob', - code => '$life_raft = \%Left::; *Left:: = \%Right::', - }, -) { - fresh_perl_is - q~ - @Subclass::ISA = "Left"; - @Left::ISA = "TopLeft"; - - sub TopLeft::speak { "Woof!" } - sub TopRight::speak { "Bow-wow!" } - - my $thing = bless [], "Subclass"; - - # mro_package_moved needs to know to skip non-globs - $Right::{"gleck::"} = 3; - - @Right::ISA = 'TopRight'; - my $life_raft; - __code__; - - print $thing->speak, "\n"; - - undef $life_raft; - print $thing->speak, "\n"; - ~ =~ s\__code__\$$_{code}\r, - "Bow-wow!\nBow-wow!\n", - {}, - "replacing packages by $$_{name} updates isa caches"; -} - -# Similar test, but with nested packages -# -# TopLeft (Woof) TopRight (Bow-wow) -# | | -# Left::Side <- Right::Side -# | -# Subclass -# -# This test assigns Right:: to Left::, indirectly making Left::Side an -# alias to Right::Side (following the arrow in the diagram). -for( - { - name => 'assigning a glob to a glob', - code => '$life_raft = $::{"Left::"}; *Left:: = $::{"Right::"}', - }, - { - name => 'assigning a string to a glob', - code => '$life_raft = $::{"Left::"}; *Left:: = "Right::"', - }, - { - name => 'assigning a stashref to a glob', - code => '$life_raft = \%Left::; *Left:: = \%Right::', - }, -) { - fresh_perl_is - q~ - @Subclass::ISA = "Left::Side"; - @Left::Side::ISA = "TopLeft"; - - sub TopLeft::speak { "Woof!" } - sub TopRight::speak { "Bow-wow!" } - - my $thing = bless [], "Subclass"; - - @Right::Side::ISA = 'TopRight'; - my $life_raft; - __code__; - - print $thing->speak, "\n"; - - undef $life_raft; - print $thing->speak, "\n"; - ~ =~ s\__code__\$$_{code}\r, - "Bow-wow!\nBow-wow!\n", - {}, - "replacing nested packages by $$_{name} updates isa caches"; -} - -# Another nested package test, in which the isa cache needs to be reset on -# the subclass of a package that does not exist. -# -# Parenthesized packages do not exist. -# -# outer::inner ( clone::inner ) -# | | -# left right -# -# outer -> clone -# -# This test assigns outer:: to clone::, making clone::inner an alias to -# outer::inner. -# -# Then we also run the test again, but without outer::inner -for( - { - name => 'assigning a glob to a glob', - code => '*clone:: = *outer::', - }, - { - name => 'assigning a string to a glob', - code => '*clone:: = "outer::"', - }, - { - name => 'assigning a stashref to a glob', - code => '*clone:: = \%outer::', - }, -) { - for my $tail ('inner', 'inner::', 'inner:::', 'inner::::') { - fresh_perl_is - q~ - my $tail = shift; - @left::ISA = "outer::$tail"; - @right::ISA = "clone::$tail"; - bless [], "outer::$tail"; # autovivify the stash - - __code__; - - print "ok 1", "\n" if left->isa("clone::$tail"); - print "ok 2", "\n" if right->isa("outer::$tail"); - print "ok 3", "\n" if right->isa("clone::$tail"); - print "ok 4", "\n" if left->isa("outer::$tail"); - ~ =~ s\__code__\$$_{code}\r, - "ok 1\nok 2\nok 3\nok 4\n", - { args => [$tail] }, - "replacing nonexistent nested packages by $$_{name} updates isa caches" - ." ($tail)"; - - # Same test but with the subpackage autovivified after the assignment - fresh_perl_is - q~ - my $tail = shift; - @left::ISA = "outer::$tail"; - @right::ISA = "clone::$tail"; - - __code__; - - bless [], "outer::$tail"; - - print "ok 1", "\n" if left->isa("clone::$tail"); - print "ok 2", "\n" if right->isa("outer::$tail"); - print "ok 3", "\n" if right->isa("clone::$tail"); - print "ok 4", "\n" if left->isa("outer::$tail"); - ~ =~ s\__code__\$$_{code}\r, - "ok 1\nok 2\nok 3\nok 4\n", - { args => [$tail] }, - "Giving nonexistent packages multiple effective names by $$_{name}" - . " ($tail)"; - } -} - -no warnings; # temporary; there seems to be a scoping bug, as this does not - # work when placed in the blocks below - -# Test that deleting stash elements containing -# subpackages also invalidates the isa cache. -# Maybe this does not belong in package_aliases.t, but it is closely -# related to the tests immediately preceding. -{ - @Pet::ISA = ("Cur", "Hound"); - @Cur::ISA = "Hylactete"; - - sub Hylactete::speak { "Arff!" } - sub Hound::speak { "Woof!" } - - my $pet = bless [], "Pet"; - - my $life_raft = delete $::{'Cur::'}; - - is $pet->speak, 'Woof!', - 'deleting a stash from its parent stash invalidates the isa caches'; - - undef $life_raft; - is $pet->speak, 'Woof!', - 'the deleted stash is gone completely when freed'; -} -# Same thing, but with nested packages -{ - @Pett::ISA = ("Curr::Curr::Curr", "Hownd"); - @Curr::Curr::Curr::ISA = "Latrator"; - - sub Latrator::speak { "Arff!" } - sub Hownd::speak { "Woof!" } - - my $pet = bless [], "Pett"; - - my $life_raft = delete $::{'Curr::'}; - - is $pet->speak, 'Woof!', - 'deleting a stash from its parent stash resets caches of substashes'; - - undef $life_raft; - is $pet->speak, 'Woof!', - 'the deleted substash is gone completely when freed'; -} - -# [perl #77358] -fresh_perl_is - q~#!perl -w - @Pet::ISA = "Tike"; - @Tike::ISA = "Barker"; - - sub Barker::speak { print "Woof!\n" } - sub Latrator::speak { print "Bow-wow!\n" } - - my $pet = bless [], "Pet"; - - $pet->speak; - - sub Dog::speak { print "Hello.\n" } # strange dog! - @Dog::ISA = 'Latrator'; - *Tike:: = delete $::{'Dog::'}; - - $pet->speak; - ~, - "Woof!\nHello.\n", - { stderr => 1 }, - "Assigning a nameless package over one w/subclasses updates isa caches"; - -# mro_package_moved needs to make a distinction between replaced and -# assigned stashes when keeping track of what it has seen so far. -no warnings; { - no strict 'refs'; - - sub bar::blonk::blonk::phoo { "bbb" } - sub veclum::phoo { "lasrevinu" } - @feedlebomp::ISA = qw 'phoo::blonk::blonk veclum'; - *phoo::baz:: = *bar::blonk::; # now bar::blonk:: is on both sides - *phoo:: = *bar::; # here bar::blonk:: is both deleted and added - *bar:: = *boo::; # now it is only known as phoo::blonk:: - - # At this point, before the bug was fixed, %phoo::blonk::blonk:: ended - # up with no effective name, allowing it to be deleted without updating - # its subclasses’ caches. - - my $accum = ''; - - $accum .= 'feedlebomp'->phoo; # bbb - delete ${"phoo::blonk::"}{"blonk::"}; - $accum .= 'feedlebomp'->phoo; # bbb (Oops!) - @feedlebomp::ISA = @feedlebomp::ISA; - $accum .= 'feedlebomp'->phoo; # lasrevinu - - is $accum, 'bbblasrevinulasrevinu', - 'nested classes deleted & added simultaneously'; -} -use warnings; - -# mro_package_moved needs to check for self-referential packages. -# This broke Text::Template [perl #78362]. -watchdog 3; -*foo:: = \%::; -*Acme::META::Acme:: = \*Acme::; # indirect self-reference -pass("mro_package_moved and self-referential packages"); - -# Deleting a glob whose name does not indicate its location in the symbol -# table but which nonetheless *is* in the symbol table. -{ - no strict refs=>; - no warnings; - @one::more::ISA = "four"; - sub four::womp { "aoeaa" } - *two:: = *one::; - delete $::{"one::"}; - @Childclass::ISA = 'two::more'; - my $accum = 'Childclass'->womp . '-'; - my $life_raft = delete ${"two::"}{"more::"}; - $accum .= eval { 'Childclass'->womp } // ''; - is $accum, 'aoeaa-', - 'Deleting globs whose loc in the symtab differs from gv_fullname' -} - -# Pathological test for undeffing a stash that has an alias. -*Ghelp:: = *Neen::; -@Subclass::ISA = 'Ghelp'; -undef %Ghelp::; -sub Frelp::womp { "clumpren" } -eval ' - $Neen::whatever++; - @Neen::ISA = "Frelp"; -'; -is eval { 'Subclass'->womp }, 'clumpren', - 'Changes to @ISA after undef via original name'; -undef %Ghelp::; -eval ' - $Ghelp::whatever++; - @Ghelp::ISA = "Frelp"; -'; -is eval { 'Subclass'->womp }, 'clumpren', - 'Changes to @ISA after undef via alias'; - - -# Packages whose containing stashes have aliases must lose all names cor- -# responding to that container when detached. -{ - {package smare::baz} # autovivify - *phring:: = *smare::; # smare::baz now also named phring::baz - *bonk:: = delete $smare::{"baz::"}; - # In 5.13.7, it has now lost its smare::baz name (reverting to phring::baz - # as the effective name), and gained bonk as an alias. - # In 5.13.8, both smare::baz *and* phring::baz names are deleted. - - # Make some methods - no strict 'refs'; - *{"phring::baz::frump"} = sub { "hello" }; - sub frumper::frump { "good bye" }; - - @brumkin::ISA = qw "bonk frumper"; # now wrongly inherits from phring::baz - - is frump brumkin, "good bye", - 'detached stashes lose all names corresponding to the containing stash'; -} - -# Crazy edge cases involving packages ending with a single : -@Colon::ISA = 'Organ:'; # pun intended! -bless [], "Organ:"; # autovivify the stash -ok "Colon"->isa("Organ:"), 'class isa "class:"'; -{ no strict 'refs'; *{"Organ:::"} = *Organ:: } -ok "Colon"->isa("Organ"), - 'isa(foo) when inheriting from "class:" which is an alias for foo'; -{ - no warnings; - # The next line of code is *not* normative. If the structure changes, - # this line needs to change, too. - my $foo = delete $Organ::{":"}; - ok !Colon->isa("Organ"), - 'class that isa "class:" no longer isa foo if "class:" has been deleted'; -} -@Colon::ISA = ':'; -bless [], ":"; -ok "Colon"->isa(":"), 'class isa ":"'; -{ no strict 'refs'; *{":::"} = *Punctuation:: } -ok "Colon"->isa("Punctuation"), - 'isa(foo) when inheriting from ":" which is an alias for foo'; -@Colon::ISA = 'Organ:'; -bless [], "Organ:"; -{ - no strict 'refs'; - my $life_raft = \%{"Organ:::"}; - *{"Organ:::"} = \%Organ::; - ok "Colon"->isa("Organ"), - 'isa(foo) when inheriting from "class:" after hash-to-glob assignment'; -} -@Colon::ISA = 'O:'; -bless [], "O:"; -{ - no strict 'refs'; - my $life_raft = \%{"O:::"}; - *{"O:::"} = "Organ::"; - ok "Colon"->isa("Organ"), - 'isa(foo) when inheriting from "class:" after string-to-glob assignment'; -} - - diff --git a/t/CORE/mro/pkg_gen.t b/t/CORE/mro/pkg_gen.t deleted file mode 100644 index 678c4231e..000000000 --- a/t/CORE/mro/pkg_gen.t +++ /dev/null @@ -1,41 +0,0 @@ -#!./perl - -use strict; -use warnings; - -require q(t/CORE/test.pl); plan(tests => 7); - -require mro; - -{ - package Foo; - our @ISA = qw//; -} - -ok(!mro::get_pkg_gen('ReallyDoesNotExist'), - "pkg_gen 0 for non-existent pkg"); - -my $f_gen = mro::get_pkg_gen('Foo'); -ok($f_gen > 0, 'Foo pkg_gen > 0'); - -{ - no warnings 'once'; - *Foo::foo_func = sub { 123 }; -} -my $new_f_gen = mro::get_pkg_gen('Foo'); -ok($new_f_gen > $f_gen, 'Foo pkg_gen incs for methods'); -$f_gen = $new_f_gen; - -@Foo::ISA = qw/Bar/; -$new_f_gen = mro::get_pkg_gen('Foo'); -ok($new_f_gen > $f_gen, 'Foo pkg_gen incs for @ISA'); - -undef %Foo::; -is(mro::get_pkg_gen('Foo'), 1, "pkg_gen 1 for undef %Pkg::"); - -delete $::{"Foo::"}; -is(mro::get_pkg_gen('Foo'), 0, 'pkg_gen 0 for delete $::{Pkg::}'); - -delete $::{"Quux::"}; -push @Quux::ISA, "Woot"; # should not segfault -ok(1, "No segfault on modification of ISA in a deleted stash"); diff --git a/t/CORE/mro/recursion_c3.t b/t/CORE/mro/recursion_c3.t deleted file mode 100644 index 8f55438ab..000000000 --- a/t/CORE/mro/recursion_c3.t +++ /dev/null @@ -1,95 +0,0 @@ -#!./perl - -use strict; -use warnings; -BEGIN { - require 't/CORE/test.pl'; -} - -plan(skip_all => "Your system has no SIGALRM") if !exists $SIG{ALRM}; -plan(tests => 8); - -require mro; - -=pod - -These are like the 010_complex_merge_classless test, -but an infinite loop has been made in the heirarchy, -to test that we can fail cleanly instead of going -into an infinite loop - -=cut - -# initial setup, everything sane -{ - package K; - use mro 'c3'; - our @ISA = qw/J I/; - package J; - use mro 'c3'; - our @ISA = qw/F/; - package I; - use mro 'c3'; - our @ISA = qw/H F/; - package H; - use mro 'c3'; - our @ISA = qw/G/; - package G; - use mro 'c3'; - our @ISA = qw/D/; - package F; - use mro 'c3'; - our @ISA = qw/E/; - package E; - use mro 'c3'; - our @ISA = qw/D/; - package D; - use mro 'c3'; - our @ISA = qw/A B C/; - package C; - use mro 'c3'; - our @ISA = qw//; - package B; - use mro 'c3'; - our @ISA = qw//; - package A; - use mro 'c3'; - our @ISA = qw//; -} - -# A series of 8 aberations that would cause infinite loops, -# each one undoing the work of the previous -my @loopies = ( - sub { @E::ISA = qw/F/ }, - sub { @E::ISA = qw/D/; @C::ISA = qw/F/ }, - sub { @C::ISA = qw//; @A::ISA = qw/K/ }, - sub { @A::ISA = qw//; @J::ISA = qw/F K/ }, - sub { @J::ISA = qw/F/; @H::ISA = qw/K G/ }, - sub { @H::ISA = qw/G/; @B::ISA = qw/B/ }, - sub { @B::ISA = qw//; @K::ISA = qw/K J I/ }, - sub { @K::ISA = qw/J I/; @D::ISA = qw/A H B C/ }, -); - -foreach my $loopy (@loopies) { - eval { - local $SIG{ALRM} = sub { die "ALRMTimeout" }; - alarm(3); - $loopy->(); - mro::get_linear_isa('K', 'c3'); - }; - - if(my $err = $@) { - if($err =~ /ALRMTimeout/) { - ok(0, "Loop terminated by SIGALRM"); - } - elsif($err =~ /Recursive inheritance detected/) { - ok(1, "Graceful exception thrown"); - } - else { - ok(0, "Unrecognized exception: $err"); - } - } - else { - ok(0, "Infinite loop apparently succeeded???"); - } -} diff --git a/t/CORE/mro/recursion_dfs.t b/t/CORE/mro/recursion_dfs.t deleted file mode 100644 index c805c807b..000000000 --- a/t/CORE/mro/recursion_dfs.t +++ /dev/null @@ -1,82 +0,0 @@ -#!./perl - -use strict; -use warnings; -BEGIN { - require 't/CORE/test.pl'; -} - -plan(skip_all => "Your system has no SIGALRM") if !exists $SIG{ALRM}; -plan(tests => 8); - -=pod - -These are like the 010_complex_merge_classless test, -but an infinite loop has been made in the heirarchy, -to test that we can fail cleanly instead of going -into an infinite loop - -=cut - -# initial setup, everything sane -{ - package K; - our @ISA = qw/J I/; - package J; - our @ISA = qw/F/; - package I; - our @ISA = qw/H F/; - package H; - our @ISA = qw/G/; - package G; - our @ISA = qw/D/; - package F; - our @ISA = qw/E/; - package E; - our @ISA = qw/D/; - package D; - our @ISA = qw/A B C/; - package C; - our @ISA = qw//; - package B; - our @ISA = qw//; - package A; - our @ISA = qw//; -} - -# A series of 8 aberations that would cause infinite loops, -# each one undoing the work of the previous -my @loopies = ( - sub { @E::ISA = qw/F/ }, - sub { @E::ISA = qw/D/; @C::ISA = qw/F/ }, - sub { @C::ISA = qw//; @A::ISA = qw/K/ }, - sub { @A::ISA = qw//; @J::ISA = qw/F K/ }, - sub { @J::ISA = qw/F/; @H::ISA = qw/K G/ }, - sub { @H::ISA = qw/G/; @B::ISA = qw/B/ }, - sub { @B::ISA = qw//; @K::ISA = qw/K J I/ }, - sub { @K::ISA = qw/J I/; @D::ISA = qw/A H B C/ }, -); - -foreach my $loopy (@loopies) { - eval { - local $SIG{ALRM} = sub { die "ALRMTimeout" }; - alarm(3); - $loopy->(); - mro::get_linear_isa('K', 'dfs'); - }; - - if(my $err = $@) { - if($err =~ /ALRMTimeout/) { - ok(0, "Loop terminated by SIGALRM"); - } - elsif($err =~ /Recursive inheritance detected/) { - ok(1, "Graceful exception thrown"); - } - else { - ok(0, "Unrecognized exception: $err"); - } - } - else { - ok(0, "Infinite loop apparently succeeded???"); - } -} diff --git a/t/CORE/mro/vulcan_c3.t b/t/CORE/mro/vulcan_c3.t deleted file mode 100644 index 33bb79c00..000000000 --- a/t/CORE/mro/vulcan_c3.t +++ /dev/null @@ -1,66 +0,0 @@ -#!./perl - -use strict; -use warnings; - -require q(t/CORE/test.pl); plan(tests => 1); - -=pod - -example taken from: L - - Object - ^ - | - LifeForm - ^ ^ - / \ - Sentient BiPedal - ^ ^ - | | - Intelligent Humanoid - ^ ^ - \ / - Vulcan - - define class () end class; - define class () end class; - define class () end class; - define class () end class; - define class (, ) end class; - -=cut - -{ - package Object; - use mro 'c3'; - - package LifeForm; - use mro 'c3'; - use base 'Object'; - - package Sentient; - use mro 'c3'; - use base 'LifeForm'; - - package BiPedal; - use mro 'c3'; - use base 'LifeForm'; - - package Intelligent; - use mro 'c3'; - use base 'Sentient'; - - package Humanoid; - use mro 'c3'; - use base 'BiPedal'; - - package Vulcan; - use mro 'c3'; - use base ('Intelligent', 'Humanoid'); -} - -ok(eq_array( - mro::get_linear_isa('Vulcan'), - [ qw(Vulcan Intelligent Sentient Humanoid BiPedal LifeForm Object) ] -), '... got the right MRO for the Vulcan Dylan Example'); diff --git a/t/CORE/mro/vulcan_dfs.t b/t/CORE/mro/vulcan_dfs.t deleted file mode 100644 index 99e2618bc..000000000 --- a/t/CORE/mro/vulcan_dfs.t +++ /dev/null @@ -1,66 +0,0 @@ -#!./perl - -use strict; -use warnings; - -require q(t/CORE/test.pl); plan(tests => 1); - -=pod - -example taken from: L - - Object - ^ - | - LifeForm - ^ ^ - / \ - Sentient BiPedal - ^ ^ - | | - Intelligent Humanoid - ^ ^ - \ / - Vulcan - - define class () end class; - define class () end class; - define class () end class; - define class () end class; - define class (, ) end class; - -=cut - -{ - package Object; - use mro 'dfs'; - - package LifeForm; - use mro 'dfs'; - use base 'Object'; - - package Sentient; - use mro 'dfs'; - use base 'LifeForm'; - - package BiPedal; - use mro 'dfs'; - use base 'LifeForm'; - - package Intelligent; - use mro 'dfs'; - use base 'Sentient'; - - package Humanoid; - use mro 'dfs'; - use base 'BiPedal'; - - package Vulcan; - use mro 'dfs'; - use base ('Intelligent', 'Humanoid'); -} - -ok(eq_array( - mro::get_linear_isa('Vulcan'), - [ qw(Vulcan Intelligent Sentient LifeForm Object Humanoid BiPedal) ] -), '... got the right MRO for the Vulcan Dylan Example'); diff --git a/t/CORE/op/64bitint.t b/t/CORE/op/64bitint.t deleted file mode 100644 index d36eccfec..000000000 --- a/t/CORE/op/64bitint.t +++ /dev/null @@ -1,367 +0,0 @@ -#!./perl - -BEGIN { - unshift @INC, 't/CORE/lib'; - require 't/CORE/test.pl'; -} - -eval { my $q = pack "q", 0 }; -skip_all('no 64-bit types') if $@; - -# perlcc issues reported upstream at https://code.google.com/p/perl-compiler/issues/detail?id=157 - -# This could use many more tests. - -# so that using > 0xfffffff constants and -# 32+ bit integers don't cause noise -# perlcc bug #156 https://code.google.com/p/perl-compiler/issues/detail?id=156 - -use warnings; -no warnings qw(overflow portable); - -use Config; - -# perlcc bug #156 https://code.google.com/p/perl-compiler/issues/detail?id=156 -# XSLoader is not loaded - -# as 6 * 6 = 36, the last digit of 6**n will always be six. Hence the last -# digit of 16**n will always be six. Hence 16**n - 1 will always end in 5. -# Assumption is that UVs will always be a multiple of 4 bits long. - -my $UV_max = ~0; -die "UV_max eq '$UV_max', doesn't end in 5; your UV isn't 4n bits long :-(." - unless $UV_max =~ /5$/; -my $UV_max_less3 = $UV_max - 3; -my $maths_preserves_UVs = $UV_max_less3 =~ /^\d+2$/; # 5 - 3 is 2. -if ($maths_preserves_UVs) { - print "# This perl's maths preserves all bits of a UV.\n"; -} else { - print "# This perl's maths does not preserve all bits of a UV.\n"; -} - -my $q = 12345678901; -my $r = 23456789012; -my $f = 0xffffffff; -my $x; -my $y; - -$x = unpack "q", pack "q", $q; -cmp_ok($x, '==', $q); -cmp_ok($x, '>', $f); - - -$x = sprintf("%lld", 12345678901); -is($x, $q); -cmp_ok($x, '>', $f); - -$x = sprintf("%lld", $q); -cmp_ok($x, '==', $q); -is($x, $q); -cmp_ok($x, '>', $f); - -$x = sprintf("%Ld", $q); -cmp_ok($x, '==', $q); -is($x, $q); -cmp_ok($x, '>', $f); - -$x = sprintf("%qd", $q); -cmp_ok($x, '==', $q); -is($x, $q); -cmp_ok($x, '>', $f); - - -$x = sprintf("%llx", $q); - -cmp_ok(hex $x, '==', 0x2dfdc1c35); -cmp_ok(hex $x, '>', $f); - -$x = sprintf("%Lx", $q); -cmp_ok(hex $x, '==', 0x2dfdc1c35); -cmp_ok(hex $x, '>', $f); - -$x = sprintf("%qx", $q); -cmp_ok(hex $x, '==', 0x2dfdc1c35); -cmp_ok(hex $x, '>', $f); - -$x = sprintf("%llo", $q); -cmp_ok(oct "0$x", '==', 0133767016065); -cmp_ok(oct $x, '>', $f); - -$x = sprintf("%Lo", $q); -cmp_ok(oct "0$x", '==', 0133767016065); -cmp_ok(oct $x, '>', $f); - -$x = sprintf("%qo", $q); -cmp_ok(oct "0$x", '==', 0133767016065); -cmp_ok(oct $x, '>', $f); - -$x = sprintf("%llb", $q); -cmp_ok(oct "0b$x", '==', 0b1011011111110111000001110000110101); -cmp_ok(oct "0b$x", '>', $f); - -$x = sprintf("%Lb", $q); -cmp_ok(oct "0b$x", '==', 0b1011011111110111000001110000110101); -cmp_ok(oct "0b$x", '>', $f); - -$x = sprintf("%qb", $q); -cmp_ok(oct "0b$x", '==', 0b1011011111110111000001110000110101); -cmp_ok(oct "0b$x", '>', $f); - - -$x = sprintf("%llu", $q); -is($x, $q); -cmp_ok($x, '>', $f); - -$x = sprintf("%Lu", $q); -cmp_ok($x, '==', $q); -is($x, $q); -cmp_ok($x, '>', $f); - -$x = sprintf("%qu", $q); -cmp_ok($x, '==', $q); -is($x, $q); -cmp_ok($x, '>', $f); - - -$x = sprintf("%D", $q); -cmp_ok($x, '==', $q); -is($x, $q); -cmp_ok($x, '>', $f); - -$x = sprintf("%U", $q); -cmp_ok($x, '==', $q); -is($x, $q); -cmp_ok($x, '>', $f); - -$x = sprintf("%O", $q); -cmp_ok(oct $x, '==', $q); -cmp_ok(oct $x, '>', $f); - - -$x = $q + $r; -cmp_ok($x, '==', 35802467913); -cmp_ok($x, '>', $f); - -$x = $q - $r; -cmp_ok($x, '==', -11111110111); -cmp_ok(-$x, '>', $f); - -SKIP: { - # Unicos has imprecise doubles (14 decimal digits or so), - # especially if operating near the UV/IV limits the low-order bits - # become mangled even by simple arithmetic operations. - skip('too imprecise numbers on unicos') if $^O eq 'unicos'; - - $x = $q * 1234567; - cmp_ok($x, '==', 15241567763770867); - cmp_ok($x, '>', $f); - - $x /= 1234567; - cmp_ok($x, '==', $q); - cmp_ok($x, '>', $f); - - $x = 98765432109 % 12345678901; - cmp_ok($x, '==', 901); - - # The following 12 tests adapted from op/inc. - - $a = 9223372036854775807; - $c = $a++; - cmp_ok($a, '==', 9223372036854775808); - - $a = 9223372036854775807; - $c = ++$a; - cmp_ok($a, '==', 9223372036854775808); - cmp_ok($c, '==', $a); - - $a = 9223372036854775807; - $c = $a + 1; - cmp_ok($a, '==', 9223372036854775807); - cmp_ok($c, '==', 9223372036854775808); - - $a = -9223372036854775808; - { - no warnings 'imprecision'; - $c = $a--; - } - cmp_ok($a, '==', -9223372036854775809); - cmp_ok($c, '==', -9223372036854775808); - - $a = -9223372036854775808; - { - no warnings 'imprecision'; - $c = --$a; - } - cmp_ok($a, '==', -9223372036854775809); - cmp_ok($c, '==', $a); - - $a = -9223372036854775808; - $c = $a - 1; - cmp_ok($a, '==', -9223372036854775808); - cmp_ok($c, '==', -9223372036854775809); - - $a = 9223372036854775808; - $a = -$a; - { - no warnings 'imprecision'; - $c = $a--; - } - cmp_ok($a, '==', -9223372036854775809); - cmp_ok($c, '==', -9223372036854775808); - - $a = 9223372036854775808; - $a = -$a; - { - no warnings 'imprecision'; - $c = --$a; - } - cmp_ok($a, '==', -9223372036854775809); - cmp_ok($c, '==', $a); - - $a = 9223372036854775808; - $a = -$a; - $c = $a - 1; - cmp_ok($a, '==', -9223372036854775808); - cmp_ok($c, '==', -9223372036854775809); - - $a = 9223372036854775808; - $b = -$a; - { - no warnings 'imprecision'; - $c = $b--; - } - cmp_ok($b, '==', -$a-1); - cmp_ok($c, '==', -$a); - - $a = 9223372036854775808; - $b = -$a; - { - no warnings 'imprecision'; - $c = --$b; - } - cmp_ok($b, '==', -$a-1); - cmp_ok($c, '==', $b); - - $a = 9223372036854775808; - $b = -$a; - $b = $b - 1; - cmp_ok($b, '==', -(++$a)); -} - - -$x = ''; -cmp_ok((vec($x, 1, 64) = $q), '==', $q); - -cmp_ok(vec($x, 1, 64), '==', $q); -cmp_ok(vec($x, 1, 64), '>', $f); - -cmp_ok(vec($x, 0, 64), '==', 0); -cmp_ok(vec($x, 2, 64), '==', 0); - -cmp_ok(~0, '==', 0xffffffffffffffff); - -cmp_ok((0xffffffff<<32), '==', 0xffffffff00000000); - -cmp_ok(((0xffffffff)<<32)>>32, '==', 0xffffffff); - -cmp_ok(1<<63, '==', 0x8000000000000000); - -is((sprintf "%#Vx", 1<<63), '0x8000000000000000'); - -cmp_ok((0x8000000000000000 | 1), '==', 0x8000000000000001); - -cmp_ok((0xf000000000000000 & 0x8000000000000000), '==', 0x8000000000000000); -cmp_ok((0xf000000000000000 ^ 0xfffffffffffffff0), '==', 0x0ffffffffffffff0); - - -is((sprintf "%b", ~0), - '1111111111111111111111111111111111111111111111111111111111111111'); - - -is((sprintf "%64b", ~0), - '1111111111111111111111111111111111111111111111111111111111111111'); - -is((sprintf "%d", ~0>>1),'9223372036854775807'); -is((sprintf "%u", ~0),'18446744073709551615'); - -# If the 53..55 fail you have problems in the parser's string->int conversion, -# see toke.c:scan_num(). - -$q = -9223372036854775808; -is("$q","-9223372036854775808"); - -$q = 9223372036854775807; -is("$q","9223372036854775807"); - -$q = 18446744073709551615; -is("$q","18446744073709551615"); - -# Test that sv_2nv then sv_2iv is the same as sv_2iv direct -# fails if whatever Atol is defined as can't actually cope with >32 bits. -my $num = 4294967297; -my $string = "4294967297"; -{ - use integer; - $num += 0; - $string += 0; -} -is($num, $string); - -# Test that sv_2nv then sv_2uv is the same as sv_2uv direct -$num = 4294967297; -$string = "4294967297"; -$num &= 0; -$string &= 0; -is($num, $string); - -$q = "18446744073709551616e0"; -$q += 0; -isnt($q, "18446744073709551615"); - -# 0xFFFFFFFFFFFFFFFF == 1 * 3 * 5 * 17 * 257 * 641 * 65537 * 6700417' -$q = 0xFFFFFFFFFFFFFFFF / 3; -cmp_ok($q, '==', 0x5555555555555555); -SKIP: { - skip("Maths does not preserve UVs", 2) unless $maths_preserves_UVs; - cmp_ok($q, '!=', 0x5555555555555556); - skip("All UV division is precise as NVs, so is done as NVs", 1) - if $Config{d_nv_preserves_uv}; - unlike($q, qr/[e.]/); -} - -$q = 0xFFFFFFFFFFFFFFFF % 0x5555555555555555; -cmp_ok($q, '==', 0); - -$q = 0xFFFFFFFFFFFFFFFF % 0xFFFFFFFFFFFFFFF0; -cmp_ok($q, '==', 0xF); - -$q = 0x8000000000000000 % 9223372036854775807; -cmp_ok($q, '==', 1); - -$q = 0x8000000000000000 % -9223372036854775807; -cmp_ok($q, '==', -9223372036854775806); - -{ - use integer; - $q = hex "0x123456789abcdef0"; - cmp_ok($q, '==', 0x123456789abcdef0); - cmp_ok($q, '!=', 0x123456789abcdef1); - unlike($q, qr/[e.]/, 'Should not be floating point'); - - $q = oct "0x123456789abcdef0"; - cmp_ok($q, '==', 0x123456789abcdef0); - cmp_ok($q, '!=', 0x123456789abcdef1); - unlike($q, qr/[e.]/, 'Should not be floating point'); - - $q = oct "765432176543217654321"; - cmp_ok($q, '==', 0765432176543217654321); - cmp_ok($q, '!=', 0765432176543217654322); - unlike($q, qr/[e.]/, 'Should not be floating point'); - - $q = oct "0b0101010101010101010101010101010101010101010101010101010101010101"; - cmp_ok($q, '==', 0x5555555555555555); - cmp_ok($q, '!=', 0x5555555555555556); - unlike($q, qr/[e.]/, 'Should not be floating point'); -} - -done_testing(); diff --git a/t/CORE/op/alarm.t b/t/CORE/op/alarm.t deleted file mode 100644 index 6df6ddca3..000000000 --- a/t/CORE/op/alarm.t +++ /dev/null @@ -1,61 +0,0 @@ -#!./perl - -BEGIN { - unshift @INC, 't/CORE/lib'; - require 't/CORE/test.pl'; -} - -BEGIN { - use Config; - if( !$Config{d_alarm} ) { - skip_all("alarm() not implemented on this platform"); - } -} - -# alarm is triggered twice -# perlcc issue 168 https://code.google.com/p/perl-compiler/issues/detail?id=168 - -plan tests => 5; -my $Perl = which_perl(); - -my $start_time = time; -eval { - local $SIG{ALRM} = sub { die "ALARM!\n" }; - alarm 3; - - # perlfunc recommends against using sleep in combination with alarm. - 1 while (time - $start_time < 6); -}; -alarm 0; -my $diff = time - $start_time; - -# alarm time might be one second less than you said. -is( $@, "ALARM!\n", 'alarm w/$SIG{ALRM} vs inf loop' ); -ok( abs($diff - 3) <= 1, " right time" ); - - -my $start_time = time; -eval { - local $SIG{ALRM} = sub { die "ALARM!\n" }; - alarm 3; - system(qq{$Perl -e "sleep 6"}); -}; -alarm 0; -$diff = time - $start_time; - -# alarm time might be one second less than you said. -is( $@, "ALARM!\n", 'alarm w/$SIG{ALRM} vs system()' ); - -{ - local $TODO = "Why does system() block alarm() on $^O?" - if $^O eq 'VMS' || $^O eq 'dos'; - ok( abs($diff - 3) <= 1, " right time (waited $diff secs for 3-sec alarm)" ); -} - - -{ - local $SIG{"ALRM"} = sub { die }; - eval { alarm(1); my $x = qx($Perl -e "sleep 3") }; - chomp (my $foo = "foo\n"); - ok($foo eq "foo", '[perl #33928] chomp() fails after alarm(), `sleep`'); -} diff --git a/t/CORE/op/anonsub.t b/t/CORE/op/anonsub.t deleted file mode 100644 index 022644c75..000000000 --- a/t/CORE/op/anonsub.t +++ /dev/null @@ -1,85 +0,0 @@ -#!./perl -w - -unshift @INC, 't/CORE/lib'; -require 't/CORE/test.pl'; -use strict; - -$|=1; - -run_multiple_progs('', \*DATA); - -foreach my $code ('sub;', 'sub ($) ;', '{ $x = sub }', 'sub ($) && 1') { - eval $code; - like($@, qr/^Illegal declaration of anonymous subroutine at/, - "'$code' is illegal"); -} - -{ - local $::TODO; - $::TODO = 'RT #17589 not completely resolved'; - # Here's a patch. It makes "sub;" and similar report an error immediately - # from the lexer. However the solution is not complete, it doesn't - # handle the case "sub ($) : lvalue;" (marked as a TODO test), because - # it's handled by the lexer in separate tokens, hence more difficult to - # work out. - my $code = 'sub ($) : lvalue;'; - eval $code; - like($@, qr/^Illegal declaration of anonymous subroutine at/, - "'$code' is illegal"); -} - -eval "sub #foo\n{print 1}"; -is($@, ''); - -done_testing(); - -__END__ -sub X { - my $n = "ok 1\n"; - sub { print $n }; -} -my $x = X(); -undef &X; -$x->(); -EXPECT -ok 1 -######## -sub X { - my $n = "ok 1\n"; - sub { - my $dummy = $n; # eval can't close on $n without internal reference - eval 'print $n'; - die $@ if $@; - }; -} -my $x = X(); -undef &X; -$x->(); -EXPECT -ok 1 -######## -sub X { - my $n = "ok 1\n"; - eval 'sub { print $n }'; -} -my $x = X(); -die $@ if $@; -undef &X; -$x->(); -EXPECT -ok 1 -######## -sub X; -sub X { - my $n = "ok 1\n"; - eval 'sub Y { my $p = shift; $p->() }'; - die $@ if $@; - Y(sub { print $n }); -} -X(); -EXPECT -ok 1 -######## -print sub { return "ok 1\n" } -> (); -EXPECT -ok 1 diff --git a/t/CORE/op/append.t b/t/CORE/op/append.t deleted file mode 100644 index 21af62c38..000000000 --- a/t/CORE/op/append.t +++ /dev/null @@ -1,72 +0,0 @@ -#!./perl - -print "1..13\n"; - -$a = 'ab' . 'c'; # compile time -$b = 'def'; - -$c = $a . $b; -print "#1\t:$c: eq :abcdef:\n"; -if ($c eq 'abcdef') {print "ok 1\n";} else {print "not ok 1\n";} - -$c .= 'xyz'; -print "#2\t:$c: eq :abcdefxyz:\n"; -if ($c eq 'abcdefxyz') {print "ok 2\n";} else {print "not ok 2\n";} - -$_ = $a; -$_ .= $b; -print "#3\t:$_: eq :abcdef:\n"; -if ($_ eq 'abcdef') {print "ok 3\n";} else {print "not ok 3\n";} - -# test that when right argument of concat is UTF8, and is the same -# variable as the target, and the left argument is not UTF8, it no -# longer frees the wrong string. -{ - sub r2 { - my $string = ''; - $string .= pack("U0a*", 'mnopqrstuvwx'); - $string = "abcdefghijkl$string"; - } - - r2() and print "ok $_\n" for qw/ 4 5 /; -} - -# test that nul bytes get copied -{ - my ($a, $ab) = ("a", "a\0b"); - my ($ua, $uab) = map pack("U0a*", $_), $a, $ab; - - my $ub = pack("U0a*", 'b'); - - my $t1 = $a; $t1 .= $ab; - - print $t1 =~ /b/ ? "ok 6\n" : "not ok 6\t# $t1\n"; - - my $t2 = $a; $t2 .= $uab; - - print eval '$t2 =~ /$ub/' ? "ok 7\n" : "not ok 7\t# $t2\n"; - - my $t3 = $ua; $t3 .= $ab; - - print $t3 =~ /$ub/ ? "ok 8\n" : "not ok 8\t# $t3\n"; - - my $t4 = $ua; $t4 .= $uab; - - print eval '$t4 =~ /$ub/' ? "ok 9\n" : "not ok 9\t# $t4\n"; - - my $t5 = $a; $t5 = $ab . $t5; - - print $t5 =~ /$ub/ ? "ok 10\n" : "not ok 10\t# $t5\n"; - - my $t6 = $a; $t6 = $uab . $t6; - - print eval '$t6 =~ /$ub/' ? "ok 11\n" : "not ok 11\t# $t6\n"; - - my $t7 = $ua; $t7 = $ab . $t7; - - print $t7 =~ /$ub/ ? "ok 12\n" : "not ok 12\t# $t7\n"; - - my $t8 = $ua; $t8 = $uab . $t8; - - print eval '$t8 =~ /$ub/' ? "ok 13\n" : "not ok 13\t# $t8\n"; -} diff --git a/t/CORE/op/args.t b/t/CORE/op/args.t deleted file mode 100644 index e08b8d3b5..000000000 --- a/t/CORE/op/args.t +++ /dev/null @@ -1,106 +0,0 @@ -#!./perl - -INIT { - unshift @INC, 't/CORE/lib'; - require 't/CORE/test.pl'; -} - -plan( tests => 23 ); - -# test various operations on @_ - -sub new1 { bless \@_ } -{ - my $x = new1("x"); - my $y = new1("y"); - is("@$y","y"); - is("@$x","x"); -} - -sub new2 { splice @_, 0, 0, "a", "b", "c"; return \@_ } -{ - my $x = new2("x"); - my $y = new2("y"); - is("@$x","a b c x"); - is("@$y","a b c y"); -} - -sub new3 { goto &new1 } -{ - my $x = new3("x"); - my $y = new3("y"); - is("@$y","y"); - is("@$x","x"); -} - -sub new4 { goto &new2 } -{ - my $x = new4("x"); - my $y = new4("y"); - is("@$x","a b c x"); - is("@$y","a b c y"); -} - -# see if POPSUB gets to see the right pad across a dounwind() with -# a reified @_ - -sub methimpl { - my $refarg = \@_; - die( "got: @_\n" ); -} - -sub method { - &methimpl; -} - -sub try { - eval { method('foo', 'bar'); }; - print "# $@" if $@; -} - -for (1..5) { try() } -pass(); - -# bug #21542 local $_[0] causes reify problems and coredumps - -sub local1 { local $_[0] } -my $foo = 'foo'; local1($foo); local1($foo); -print "got [$foo], expected [foo]\nnot " if $foo ne 'foo'; -pass(); - -sub local2 { local $_[0]; last L } -L: { local2 } -pass(); - -# the following test for local(@_) used to be in t/op/nothr5005.t (because it -# failed with 5005threads) - -$|=1; - -sub foo { local(@_) = ('p', 'q', 'r'); } -sub bar { unshift @_, 'D'; @_ } -sub baz { push @_, 'E'; return @_ } -for (1..3) { - is(join('',foo('a', 'b', 'c')),'pqr'); - is(join('',bar('d')),'Dd'); - is(join('',baz('e')),'eE'); -} - -# [perl #28032] delete $_[0] was freeing things too early - -{ - my $flag = 0; - sub X::DESTROY { $flag = 1 } - sub f { - delete $_[0]; - ok(!$flag, 'delete $_[0] : in f'); - } - { - my $x = bless [], 'X'; - f($x); - ok(!$flag, 'delete $_[0] : after f'); - } - ok($flag, 'delete $_[0] : outside block'); -} - - diff --git a/t/CORE/op/arith.t b/t/CORE/op/arith.t deleted file mode 100644 index cf66eb1fb..000000000 --- a/t/CORE/op/arith.t +++ /dev/null @@ -1,325 +0,0 @@ -#!./perl -w - -BEGIN { - unshift @INC, 't/CORE/lib'; -} - -print "1..145\n"; - -sub try ($$) { - print +($_[1] ? "ok" : "not ok"), " $_[0]\n"; -} -sub tryeq ($$$) { - if ($_[1] == $_[2]) { - print "ok $_[0]\n"; - } else { - print "not ok $_[0] # $_[1] != $_[2]\n"; - } -} -sub tryeq_sloppy ($$$) { - if ($_[1] == $_[2]) { - print "ok $_[0]\n"; - } else { - my $error = abs ($_[1] - $_[2]) / $_[1]; - if ($error < 1e-9) { - print "ok $_[0] # $_[1] is close to $_[2], \$^O eq $^O\n"; - } else { - print "not ok $_[0] # $_[1] != $_[2]\n"; - } - } -} - -my $T = 1; -tryeq $T++, 13 % 4, 1; -tryeq $T++, -13 % 4, 3; -tryeq $T++, 13 % -4, -3; -tryeq $T++, -13 % -4, -1; - -# Give abs() a good work-out before using it in anger -tryeq $T++, abs(0), 0; -tryeq $T++, abs(1), 1; -tryeq $T++, abs(-1), 1; -tryeq $T++, abs(2147483647), 2147483647; -tryeq $T++, abs(-2147483647), 2147483647; -tryeq $T++, abs(4294967295), 4294967295; -tryeq $T++, abs(-4294967295), 4294967295; -tryeq $T++, abs(9223372036854775807), 9223372036854775807; -tryeq $T++, abs(-9223372036854775807), 9223372036854775807; -tryeq $T++, abs(1e50), 1e50; # Assume no change whatever; no slop needed -tryeq $T++, abs(-1e50), 1e50; # Assume only sign bit flipped - -my $limit = 1e6; - -# Division (and modulo) of floating point numbers -# seem to be rather sloppy in Cray. -$limit = 1e8 if $^O eq 'unicos'; - -try $T++, abs( 13e21 % 4e21 - 1e21) < $limit; -try $T++, abs(-13e21 % 4e21 - 3e21) < $limit; -try $T++, abs( 13e21 % -4e21 - -3e21) < $limit; -try $T++, abs(-13e21 % -4e21 - -1e21) < $limit; - -# UVs should behave properly - -tryeq $T++, 4063328477 % 65535, 27407; -tryeq $T++, 4063328477 % 4063328476, 1; -tryeq $T++, 4063328477 % 2031664238, 1; -tryeq $T++, 2031664238 % 4063328477, 2031664238; - -# These should trigger wrapping on 32 bit IVs and UVs - -tryeq $T++, 2147483647 + 0, 2147483647; - -# IV + IV promote to UV -tryeq $T++, 2147483647 + 1, 2147483648; -tryeq $T++, 2147483640 + 10, 2147483650; -tryeq $T++, 2147483647 + 2147483647, 4294967294; -# IV + UV promote to NV -tryeq $T++, 2147483647 + 2147483649, 4294967296; -# UV + IV promote to NV -tryeq $T++, 4294967294 + 2, 4294967296; -# UV + UV promote to NV -tryeq $T++, 4294967295 + 4294967295, 8589934590; - -# UV + IV to IV -tryeq $T++, 2147483648 + -1, 2147483647; -tryeq $T++, 2147483650 + -10, 2147483640; -# IV + UV to IV -tryeq $T++, -1 + 2147483648, 2147483647; -tryeq $T++, -10 + 4294967294, 4294967284; -# IV + IV to NV -tryeq $T++, -2147483648 + -2147483648, -4294967296; -tryeq $T++, -2147483640 + -10, -2147483650; - -# Hmm. Don't forget the simple stuff -tryeq $T++, 1 + 1, 2; -tryeq $T++, 4 + -2, 2; -tryeq $T++, -10 + 100, 90; -tryeq $T++, -7 + -9, -16; -tryeq $T++, -63 + +2, -61; -tryeq $T++, 4 + -1, 3; -tryeq $T++, -1 + 1, 0; -tryeq $T++, +29 + -29, 0; -tryeq $T++, -1 + 4, 3; -tryeq $T++, +4 + -17, -13; - -# subtraction -tryeq $T++, 3 - 1, 2; -tryeq $T++, 3 - 15, -12; -tryeq $T++, 3 - -7, 10; -tryeq $T++, -156 - 5, -161; -tryeq $T++, -156 - -5, -151; -tryeq $T++, -5 - -12, 7; -tryeq $T++, -3 - -3, 0; -tryeq $T++, 15 - 15, 0; - -tryeq $T++, 2147483647 - 0, 2147483647; -tryeq $T++, 2147483648 - 0, 2147483648; -tryeq $T++, -2147483648 - 0, -2147483648; - -tryeq $T++, 0 - -2147483647, 2147483647; -tryeq $T++, -1 - -2147483648, 2147483647; -tryeq $T++, 2 - -2147483648, 2147483650; - -tryeq $T++, 4294967294 - 3, 4294967291; -tryeq $T++, -2147483648 - -1, -2147483647; - -# IV - IV promote to UV -tryeq $T++, 2147483647 - -1, 2147483648; -tryeq $T++, 2147483647 - -2147483648, 4294967295; -# UV - IV promote to NV -tryeq $T++, 4294967294 - -3, 4294967297; -# IV - IV promote to NV -tryeq $T++, -2147483648 - +1, -2147483649; -# UV - UV promote to IV -tryeq $T++, 2147483648 - 2147483650, -2; -# IV - UV promote to IV -tryeq $T++, 2000000000 - 4000000000, -2000000000; - -# No warnings should appear; -my $a; -$a += 1; -tryeq $T++, $a, 1; -undef $a; -$a += -1; -tryeq $T++, $a, -1; -undef $a; -$a += 4294967290; -tryeq $T++, $a, 4294967290; -undef $a; -$a += -4294967290; -tryeq $T++, $a, -4294967290; -undef $a; -$a += 4294967297; -tryeq $T++, $a, 4294967297; -undef $a; -$a += -4294967297; -tryeq $T++, $a, -4294967297; - -my $s; -$s -= 1; -tryeq $T++, $s, -1; -undef $s; -$s -= -1; -tryeq $T++, $s, +1; -undef $s; -$s -= -4294967290; -tryeq $T++, $s, +4294967290; -undef $s; -$s -= 4294967290; -tryeq $T++, $s, -4294967290; -undef $s; -$s -= 4294967297; -tryeq $T++, $s, -4294967297; -undef $s; -$s -= -4294967297; -tryeq $T++, $s, +4294967297; - -# Multiplication - -tryeq $T++, 1 * 3, 3; -tryeq $T++, -2 * 3, -6; -tryeq $T++, 3 * -3, -9; -tryeq $T++, -4 * -3, 12; - -# check with 0xFFFF and 0xFFFF -tryeq $T++, 65535 * 65535, 4294836225; -tryeq $T++, 65535 * -65535, -4294836225; -tryeq $T++, -65535 * 65535, -4294836225; -tryeq $T++, -65535 * -65535, 4294836225; - -# check with 0xFFFF and 0x10001 -tryeq $T++, 65535 * 65537, 4294967295; -tryeq $T++, 65535 * -65537, -4294967295; -tryeq $T++, -65535 * 65537, -4294967295; -tryeq $T++, -65535 * -65537, 4294967295; - -# check with 0x10001 and 0xFFFF -tryeq $T++, 65537 * 65535, 4294967295; -tryeq $T++, 65537 * -65535, -4294967295; -tryeq $T++, -65537 * 65535, -4294967295; -tryeq $T++, -65537 * -65535, 4294967295; - -# These should all be dones as NVs -tryeq $T++, 65537 * 65537, 4295098369; -tryeq $T++, 65537 * -65537, -4295098369; -tryeq $T++, -65537 * 65537, -4295098369; -tryeq $T++, -65537 * -65537, 4295098369; - -# will overflow an IV (in 32-bit) -tryeq $T++, 46340 * 46342, 0x80001218; -tryeq $T++, 46340 * -46342, -0x80001218; -tryeq $T++, -46340 * 46342, -0x80001218; -tryeq $T++, -46340 * -46342, 0x80001218; - -tryeq $T++, 46342 * 46340, 0x80001218; -tryeq $T++, 46342 * -46340, -0x80001218; -tryeq $T++, -46342 * 46340, -0x80001218; -tryeq $T++, -46342 * -46340, 0x80001218; - -# will overflow a positive IV (in 32-bit) -tryeq $T++, 65536 * 32768, 0x80000000; -tryeq $T++, 65536 * -32768, -0x80000000; -tryeq $T++, -65536 * 32768, -0x80000000; -tryeq $T++, -65536 * -32768, 0x80000000; - -tryeq $T++, 32768 * 65536, 0x80000000; -tryeq $T++, 32768 * -65536, -0x80000000; -tryeq $T++, -32768 * 65536, -0x80000000; -tryeq $T++, -32768 * -65536, 0x80000000; - -# 2147483647 is prime. bah. - -tryeq $T++, 46339 * 46341, 0x7ffea80f; -tryeq $T++, 46339 * -46341, -0x7ffea80f; -tryeq $T++, -46339 * 46341, -0x7ffea80f; -tryeq $T++, -46339 * -46341, 0x7ffea80f; - -# leading space should be ignored - -tryeq $T++, 1 + " 1", 2; -tryeq $T++, 3 + " -1", 2; -tryeq $T++, 1.2, " 1.2"; -tryeq $T++, -1.2, " -1.2"; - -# divide - -tryeq $T++, 28/14, 2; -tryeq $T++, 28/-7, -4; -tryeq $T++, -28/4, -7; -tryeq $T++, -28/-2, 14; - -tryeq $T++, 0x80000000/1, 0x80000000; -tryeq $T++, 0x80000000/-1, -0x80000000; -tryeq $T++, -0x80000000/1, -0x80000000; -tryeq $T++, -0x80000000/-1, 0x80000000; - -# The example for sloppy divide, rigged to avoid the peephole optimiser. -tryeq_sloppy $T++, "20." / "5.", 4; - -tryeq $T++, 2.5 / 2, 1.25; -tryeq $T++, 3.5 / -2, -1.75; -tryeq $T++, -4.5 / 2, -2.25; -tryeq $T++, -5.5 / -2, 2.75; - -# Bluuurg if your floating point can't accurately cope with powers of 2 -# [I suspect this is parsing string->float problems, not actual arith] -tryeq_sloppy $T++, 18446744073709551616/1, 18446744073709551616; # Bluuurg -tryeq_sloppy $T++, 18446744073709551616/2, 9223372036854775808; -tryeq_sloppy $T++, 18446744073709551616/4294967296, 4294967296; -tryeq_sloppy $T++, 18446744073709551616/9223372036854775808, 2; - -{ - # The peephole optimiser is wrong to think that it can substitute intops - # in place of regular ops, because i_multiply can overflow. - # Bug reported by "Sisyphus" - my $n = 1127; - - my $float = ($n % 1000) * 167772160.0; - tryeq_sloppy $T++, $float, 21307064320; - - # On a 32 bit machine, if the i_multiply op is used, you will probably get - # -167772160. It's actually undefined behaviour, so anything may happen. - my $int = ($n % 1000) * 167772160; - tryeq $T++, $int, 21307064320; - - my $t = time; - my $t1000 = time() * 1000; - try $T++, abs($t1000 -1000 * $t) <= 2000; -} - -my $vms_no_ieee; -if ($^O eq 'VMS') { - use vars '%Config'; - eval {require Config; import Config}; - $vms_no_ieee = 1 unless defined($Config{useieee}); -} - -if ($^O eq 'vos') { - print "not ok ", $T++, " # TODO VOS raises SIGFPE instead of producing infinity.\n"; -} -elsif ($vms_no_ieee) { - print $T++, " # SKIP -- the IEEE infinity model is unavailable in this configuration.\n" -} -elsif ($^O eq 'ultrix') { - print "not ok ", $T++, " # TODO Ultrix enters deep nirvana instead of producing infinity.\n"; -} -else { - # The computation of $v should overflow and produce "infinity" - # on any system whose max exponent is less than 10**1506. - # The exact string used to represent infinity varies by OS, - # so we don't test for it; all we care is that we don't die. - # - # Perl considers it to be an error if SIGFPE is raised. - # Chances are the interpreter will die, since it doesn't set - # up a handler for SIGFPE. That's why this test is last; to - # minimize the number of test failures. --PG - - my $n = 5000; - my $v = 2; - while (--$n) - { - $v *= 2; - } - print "ok ", $T++, "\n"; -} diff --git a/t/CORE/op/array.t b/t/CORE/op/array.t deleted file mode 100644 index 5b801417e..000000000 --- a/t/CORE/op/array.t +++ /dev/null @@ -1,455 +0,0 @@ -#!./perl - -BEGIN { require 't/CORE/test.pl' } - -plan (123); - -# -# @foo, @bar, and @ary are also used from tie-stdarray after tie-ing them -# - -@ary = (1,2,3,4,5); -is(join('',@ary), '12345'); - -$tmp = $ary[$#ary]; --$#ary; -is($tmp, 5); -is($#ary, 3); -is(join('',@ary), '1234'); - -{ -@foo = (); -$r = join(',', $#foo, @foo); -is($r, "-1"); -$foo[0] = '0'; -$r = join(',', $#foo, @foo); -is($r, "0,0"); -$foo[2] = '2'; -$r = join(',', $#foo, @foo); -is($r, "2,0,,2"); -@bar = (); -$bar[0] = '0'; -$bar[1] = '1'; -$r = join(',', $#bar, @bar); -is($r, "1,0,1"); -@bar = (); -$r = join(',', $#bar, @bar); -is($r, "-1"); -$bar[0] = '0'; -$r = join(',', $#bar, @bar); -is($r, "0,0"); -$bar[2] = '2'; -$r = join(',', $#bar, @bar); -is($r, "2,0,,2"); -reset 'b' if $^O ne 'VMS'; -@bar = (); -$bar[0] = '0'; -$r = join(',', $#bar, @bar); -is($r, "0,0"); -$bar[2] = '2'; -$r = join(',', $#bar, @bar); -is($r, "2,0,,2"); - -} - -$foo = 'now is the time'; -ok(scalar (($F1,$F2,$Etc) = ($foo =~ /^(\S+)\s+(\S+)\s*(.*)/))); -is($F1, 'now'); -is($F2, 'is'); -is($Etc, 'the time'); - -$foo = 'lskjdf'; -ok(!($cnt = (($F1,$F2,$Etc) = ($foo =~ /^(\S+)\s+(\S+)\s*(.*)/)))) - or diag("$cnt $F1:$F2:$Etc"); - -%foo = ('blurfl','dyick','foo','bar','etc.','etc.'); -%bar = %foo; -is($bar{'foo'}, 'bar'); -%bar = (); -is($bar{'foo'}, undef); -(%bar,$a,$b) = (%foo,'how','now'); -is($bar{'foo'}, 'bar'); -is($bar{'how'}, 'now'); -@bar{keys %foo} = values %foo; -is($bar{'foo'}, 'bar'); -is($bar{'how'}, 'now'); - -@foo = grep(/e/,split(' ','now is the time for all good men to come to')); -is(join(' ',@foo), 'the time men come'); - -@foo = grep(!/e/,split(' ','now is the time for all good men to come to')); -is(join(' ',@foo), 'now is for all good to to'); - -$foo = join('',('a','b','c','d','e','f')[0..5]); -is($foo, 'abcdef'); - -$foo = join('',('a','b','c','d','e','f')[0..1]); -is($foo, 'ab'); - -$foo = join('',('a','b','c','d','e','f')[6]); -is($foo, ''); - -@foo = ('a','b','c','d','e','f')[0,2,4]; -@bar = ('a','b','c','d','e','f')[1,3,5]; -$foo = join('',(@foo,@bar)[0..5]); -is($foo, 'acebdf'); - -$foo = ('a','b','c','d','e','f')[0,2,4]; -is($foo, 'e'); - -$foo = ('a','b','c','d','e','f')[1]; -is($foo, 'b'); - -@foo = ( 'foo', 'bar', 'burbl'); -{ - # eval workaround fails with perlcc - # syntax fails since 5.21 - push(@foo, 'blah'); - - #if ($] < 5.021) { - # no warnings 'deprecated'; - # push(foo, 'blah'); - # eval "push(foo, 'blah');"; # fails with perlcc - #} else { - # push(@foo, 'blah'); - #} -} -is($#foo, 3); - -# various AASSIGN_COMMON checks (see newASSIGNOP() in op.c) - -#curr_test(38); - -@foo = @foo; -is("@foo", "foo bar burbl blah"); # 38 - -(undef,@foo) = @foo; -is("@foo", "bar burbl blah"); # 39 - -@foo = ('XXX',@foo, 'YYY'); -is("@foo", "XXX bar burbl blah YYY"); # 40 - -@foo = @foo = qw(foo b\a\r bu\\rbl blah); -is("@foo", 'foo b\a\r bu\\rbl blah'); # 41 - -@bar = @foo = qw(foo bar); # 42 -is("@foo", "foo bar"); -is("@bar", "foo bar"); # 43 - -# try the same with local -# XXX tie-stdarray fails the tests involving local, so we use -# different variable names to escape the 'tie' - -@bee = ( 'foo', 'bar', 'burbl', 'blah'); -{ - - local @bee = @bee; - is("@bee", "foo bar burbl blah"); # 44 - { - local (undef,@bee) = @bee; - is("@bee", "bar burbl blah"); # 45 - { - local @bee = ('XXX',@bee,'YYY'); - is("@bee", "XXX bar burbl blah YYY"); # 46 - { - local @bee = local(@bee) = qw(foo bar burbl blah); - is("@bee", "foo bar burbl blah"); # 47 - { - local (@bim) = local(@bee) = qw(foo bar); - is("@bee", "foo bar"); # 48 - is("@bim", "foo bar"); # 49 - } - is("@bee", "foo bar burbl blah"); # 50 - } - is("@bee", "XXX bar burbl blah YYY"); # 51 - } - is("@bee", "bar burbl blah"); # 52 - } - is("@bee", "foo bar burbl blah"); # 53 -} - -# try the same with my -{ - my @bee = @bee; - is("@bee", "foo bar burbl blah"); # 54 - { - my (undef,@bee) = @bee; - is("@bee", "bar burbl blah"); # 55 - { - my @bee = ('XXX',@bee,'YYY'); - is("@bee", "XXX bar burbl blah YYY"); # 56 - { - my @bee = my @bee = qw(foo bar burbl blah); - is("@bee", "foo bar burbl blah"); # 57 - { - my (@bim) = my(@bee) = qw(foo bar); - is("@bee", "foo bar"); # 58 - is("@bim", "foo bar"); # 59 - } - is("@bee", "foo bar burbl blah"); # 60 - } - is("@bee", "XXX bar burbl blah YYY"); # 61 - } - is("@bee", "bar burbl blah"); # 62 - } - is("@bee", "foo bar burbl blah"); # 63 -} - -# try the same with our (except that previous values aren't restored) -{ - our @bee = @bee; - is("@bee", "foo bar burbl blah"); - { - our (undef,@bee) = @bee; - is("@bee", "bar burbl blah"); - { - our @bee = ('XXX',@bee,'YYY'); - is("@bee", "XXX bar burbl blah YYY"); - { - our @bee = our @bee = qw(foo bar burbl blah); - is("@bee", "foo bar burbl blah"); - { - our (@bim) = our(@bee) = qw(foo bar); - is("@bee", "foo bar"); - is("@bim", "foo bar"); - } - } - } - } -} - -# make sure reification behaves -my $t = curr_test(); -sub reify { $_[1] = $t++; print "@_\n"; } -reify('ok'); -reify('ok'); - -curr_test($t); - -# qw() is no longer a runtime split, it's compiletime. -is (qw(foo bar snorfle)[2], 'snorfle'); - -@ary = (12,23,34,45,56); - -is(shift(@ary), 12); -is(pop(@ary), 56); -is(push(@ary,56), 4); -is(unshift(@ary,12), 5); - -sub foo { "a" } -@foo=(foo())[0,0]; -is ($foo[1], "a"); - -# $[ should have the same effect regardless of whether the aelem -# op is optimized to aelemfast. - - - -sub tary { - no warnings 'deprecated'; - local $[ = 10; - my $five = 5; - is ($tary[5], $tary[$five]); -} - -@tary = (0..50); -tary(); - - -# bugid #15439 - clearing an array calls destructors which may try -# to modify the array - caused 'Attempt to free unreferenced scalar' - -my $got = runperl ( - prog => q{ - sub X::DESTROY { @a = () } - @a = (bless {}, q{X}); - @a = (); - }, - stderr => 1 - ); - -$got =~ s/\n/ /g; -is ($got, ''); - -# Test negative and funky indices. - - -{ - my @a = 0..4; - is($a[-1], 4); - is($a[-2], 3); - is($a[-5], 0); - ok(!defined $a[-6]); - - is($a[2.1] , 2); - is($a[2.9] , 2); - is($a[undef], 0); - is($a["3rd"], 3); -} - - -{ - my @a; - eval '$a[-1] = 0'; - like($@, qr/Modification of non-creatable array value attempted, subscript -1/, "\$a[-1] = 0"); -} - -sub test_arylen { - my $ref = shift; - local $^W = 1; - is ($$ref, undef, "\$# on freed array is undef"); - my @warn; - local $SIG{__WARN__} = sub {push @warn, "@_"}; - $$ref = 1000; - is (scalar @warn, 1); - like ($warn[0], qr/^Attempt to set length of freed array/); -} - -{ - my $a = \$#{[]}; - # Need a new statement to make it go out of scope - test_arylen ($a); - test_arylen (do {my @a; \$#a}); -} - -{ - use vars '@array'; - - my $outer = \$#array; - is ($$outer, -1); - is (scalar @array, 0); - - $$outer = 3; - is ($$outer, 3); - is (scalar @array, 4); - - my $ref = \@array; - - my $inner; - { - local @array; - $inner = \$#array; - - is ($$inner, -1); - is (scalar @array, 0); - $$outer = 6; - - is (scalar @$ref, 7); - - is ($$inner, -1); - is (scalar @array, 0); - - $$inner = 42; - } - - is (scalar @array, 7); - is ($$outer, 6); - - is ($$inner, undef, "orphaned $#foo is always undef"); - - is (scalar @array, 7); - is ($$outer, 6); - - $$inner = 1; - - is (scalar @array, 7); - is ($$outer, 6); - - $$inner = 503; # Bang! - - is (scalar @array, 7); - is ($$outer, 6); -} - -{ - # Bug #36211 - use vars '@array'; - for (1,2) { - { - local @a; - is ($#a, -1); - @a=(1..4) - } - } -} - -{ - # Bug #37350 - my @array = (1..4); - $#{@array} = 7; - is ($#{4}, 7); - - my $x; - $#{$x} = 3; - is(scalar @$x, 4); - - push @{@array}, 23; - is ($4[8], 23); -} -{ - # Bug #37350 -- once more with a global - use vars '@array'; - @array = (1..4); - $#{@array} = 7; - is ($#{4}, 7); - - my $x; - $#{$x} = 3; - is(scalar @$x, 4); - - push @{@array}, 23; - is ($4[8], 23); -} - -# more tests for AASSIGN_COMMON - -{ - our($x,$y,$z) = (1..3); - our($y,$z) = ($x,$y); - is("$x $y $z", "1 1 2"); -} -{ - our($x,$y,$z) = (1..3); - (our $y, our $z) = ($x,$y); - is("$x $y $z", "1 1 2"); -} - -# [perl #70171] -{ - my $x = get_x(); my %x = %$x; sub get_x { %x=(1..4); return \%x }; - is( - join(" ", map +($_,$x{$_}), sort keys %x), "1 2 3 4", - 'bug 70171 (self-assignment via my %x = %$x)' - ); - my $y = get_y(); my @y = @$y; sub get_y { @y=(1..4); return \@y }; - is( - "@y", "1 2 3 4", - 'bug 70171 (self-assignment via my @x = @$x)' - ); -} - -# [perl #70171], [perl #82110] -{ - my ($i, $ra, $rh); - again: - my @a = @$ra; # common assignment on 2nd attempt - my %h = %$rh; # common assignment on 2nd attempt - @a = qw(1 2 3 4); - %h = qw(a 1 b 2 c 3 d 4); - $ra = \@a; - $rh = \%h; - goto again unless $i++; - - is("@a", "1 2 3 4", - 'bug 70171 (self-assignment via my @x = @$x) - goto variant' - ); - is( - join(" ", map +($_,$h{$_}), sort keys %h), "a 1 b 2 c 3 d 4", - 'bug 70171 (self-assignment via my %x = %$x) - goto variant' - ); -} - - -*trit = *scile; $trit[0]; -ok(1, 'aelem_fast on a nonexistent array does not crash'); - -"We're included by lib/Tie/Array/std.t so we need to return something true"; diff --git a/t/CORE/op/array_base.aux b/t/CORE/op/array_base.aux deleted file mode 100644 index 79b6deed8..000000000 --- a/t/CORE/op/array_base.aux +++ /dev/null @@ -1,5 +0,0 @@ -our($ra1, $ri1, $rf1, $rfe1); -$ra1 = $[; -BEGIN { $ri1 = $^H; $rf1 = $^H{foo}; $rfe1 = exists($^H{foo}); } - -1; diff --git a/t/CORE/op/array_base.t b/t/CORE/op/array_base.t deleted file mode 100644 index 21fe37a81..000000000 --- a/t/CORE/op/array_base.t +++ /dev/null @@ -1,82 +0,0 @@ -#!perl -w -use strict; - -require 't/CORE/test.pl'; - -plan (tests => 24); -no warnings 'deprecated'; - -# Bug #27024 -{ - # this used to segfault (because $[=1 is optimized away to a null block) - my $x; - $[ = 1 while $x; - pass('#27204'); - $[ = 0; # restore the original value for less side-effects -} - -# [perl #36313] perl -e "1for$[=0" crash -{ - my $x; - $x = 1 for ($[) = 0; - pass('optimized assignment to $[ used to segfault in list context'); - if ($[ = 0) { $x = 1 } - pass('optimized assignment to $[ used to segfault in scalar context'); - $x = ($[=2.4); - is($x, 2, 'scalar assignment to $[ behaves like other variables'); - $x = (($[) = 0); - is($x, 1, 'list assignment to $[ behaves like other variables'); - $x = eval q{ ($[, $x) = (0) }; - like($@, qr/That use of \$\[ is unsupported/, - 'cannot assign to $[ in a list'); - eval q{ ($[) = (0, 1) }; - like($@, qr/That use of \$\[ is unsupported/, - 'cannot assign list of >1 elements to $['); - eval q{ ($[) = () }; - like($@, qr/That use of \$\[ is unsupported/, - 'cannot assign list of <1 elements to $['); -} - - -{ - $[ = 11; - cmp_ok($[ + 0, '==', 11, 'setting $[ affects $['); - our $t11; BEGIN { $t11 = $^H{'$['} } - cmp_ok($t11, '==', 11, 'setting $[ affects $^H{\'$[\'}'); - - BEGIN { $^H{'$['} = 22 } - cmp_ok($[ + 0, '==', 22, 'setting $^H{\'$\'} affects $['); - our $t22; BEGIN { $t22 = $^H{'$['} } - cmp_ok($t22, '==', 22, 'setting $^H{\'$[\'} affects $^H{\'$[\'}'); - - BEGIN { %^H = () } - my $val = do { - no warnings 'uninitialized'; - $[; - }; - cmp_ok($val, '==', 0, 'clearing %^H affects $['); - our $t0; BEGIN { $t0 = $^H{'$['} } - cmp_ok($t0, '==', 0, 'clearing %^H affects $^H{\'$[\'}'); -} - -{ - $[ = 13; - BEGIN { $^H |= 0x04000000; $^H{foo} = "z"; } - - our($ri0, $rf0); BEGIN { $ri0 = $^H; $rf0 = $^H{foo}; } - cmp_ok($[ + 0, '==', 13, '$[ correct before require'); - ok($ri0 & 0x04000000, '$^H correct before require'); - is($rf0, "z", '$^H{foo} correct before require'); - - our($ra1, $ri1, $rf1, $rfe1); - BEGIN { require "t/CORE/op/array_base.aux"; } - cmp_ok($ra1, '==', 0, '$[ cleared for require'); - ok(!($ri1 & 0x04000000), '$^H cleared for require'); - is($rf1, undef, '$^H{foo} cleared for require'); - ok(!$rfe1, '$^H{foo} cleared for require'); - - our($ri2, $rf2); BEGIN { $ri2 = $^H; $rf2 = $^H{foo}; } - cmp_ok($[ + 0, '==', 13, '$[ correct after require'); - ok($ri2 & 0x04000000, '$^H correct after require'); - is($rf2, "z", '$^H{foo} correct after require'); -} diff --git a/t/CORE/op/assignwarn.t b/t/CORE/op/assignwarn.t deleted file mode 100644 index 76c9d964c..000000000 --- a/t/CORE/op/assignwarn.t +++ /dev/null @@ -1,68 +0,0 @@ -#!./perl -w - -# -# Verify which OP= operators warn if their targets are undefined. -# Based on redef.t, contributed by Graham Barr -# -- Robin Barker -# -# Now almost completely rewritten. - -BEGIN { - unshift @INC, 't/CORE/lib'; - require 't/CORE/test.pl'; -} - -use strict; - -my (%should_warn, %should_not); -++$should_warn{$_} foreach qw(* / x & ** << >>); -++$should_not{$_} foreach qw(+ - . | ^ && ||); - -my %todo_as_tie = reverse (add => '+', subtract => '-', - bit_or => '|', bit_xor => '^'); - -my %integer = reverse (i_add => '+', i_subtract => '-'); -$integer{$_} = 0 foreach qw(* / %); - -sub TIESCALAR { my $x; bless \$x } -sub FETCH { ${$_[0]} } -sub STORE { ${$_[0]} = $_[1] } - -sub test_op { - my ($tie, $int, $op_seq, $warn, $todo) = @_; - my $code = "sub {\n"; - $code .= "use integer;" if $int; - $code .= "my \$x;\n"; - $code .= "tie \$x, 'main';\n" if $tie; - $code .= "$op_seq;\n}\n"; - - my $sub = eval $code; - is($@, '', "Can eval code for $op_seq"); - local $::TODO; - $::TODO = "[perl #17809] pp_$todo" if $todo; - if ($warn) { - warning_like($sub, qr/^Use of uninitialized value/, - "$op_seq$tie$int warns"); - } else { - warning_is($sub, undef, "$op_seq$tie$int does not warn"); - } -} - -# go through all tests once normally and once with tied $x -for my $tie ("", ", tied") { - foreach my $integer ('', ', int') { - test_op($tie, $integer, $_, 0) foreach qw($x++ $x-- ++$x --$x); - } - - foreach (keys %should_warn, keys %should_not) { - test_op($tie, '', "\$x $_= 1", $should_warn{$_}, $tie && $todo_as_tie{$_}); - next unless exists $integer{$_}; - test_op($tie, ', int', "\$x $_= 1", $should_warn{$_}, $tie && $integer{$_}); - } - - foreach (qw(| ^ &)) { - test_op($tie, '', "\$x $_= 'x'", $should_warn{$_}, $tie && $todo_as_tie{$_}); - } -} - -done_testing(); diff --git a/t/CORE/op/attrhand.t b/t/CORE/op/attrhand.t deleted file mode 100644 index c0ad753c0..000000000 --- a/t/CORE/op/attrhand.t +++ /dev/null @@ -1,63 +0,0 @@ -#!/usr/bin/perl -w - -BEGIN { - require 't/CORE/test.pl'; -} - -# Attribute::Handlers are currently not supported -# perlcc issue 169 https://code.google.com/p/perl-compiler/issues/detail?id=169 - -plan tests => 4; - -# test for bug #38475: parsing errors with multiline attributes - -package Antler; - -use Attribute::Handlers; - -sub TypeCheck :ATTR(CODE,RAWDATA) { - ::ok(1); -} - -sub WrongAttr :ATTR(CODE,RAWDATA) { - ::ok(0); -} - -sub CheckData :ATTR(RAWDATA) { - # check that the $data element contains the given attribute parameters. - - if ($_[4] eq "12, 14") { - ::ok(1) - } - else { - ::ok(0) - } -} - -sub CheckEmptyValue :ATTR() { - if (not defined $_[4]) { - ::ok(1) - } - else { - ::ok(0) - } -} - -package Deer; -use base 'Antler'; - -sub something : TypeCheck( - QNET::Util::Object, - QNET::Util::Object, - QNET::Util::Object -) { # WrongAttr (perl tokenizer bug) - # keep this ^ lined up ! - return 42; -} - -something(); - -sub c :CheckData(12, 14) {}; - -sub d1 :CheckEmptyValue() {}; -sub d2 :CheckEmptyValue {}; diff --git a/t/CORE/op/attrs.t b/t/CORE/op/attrs.t deleted file mode 100644 index 1054ea8bf..000000000 --- a/t/CORE/op/attrs.t +++ /dev/null @@ -1,329 +0,0 @@ -#!./perl - -# Regression tests for attributes.pm and the C< : attrs> syntax. - -BEGIN { - unshift @INC, 't/CORE/lib'; - require 't/CORE/test.pl'; -} - -use warnings; -# force perlcc to compile the script with attributes -# this is not really a perlcc issue -use attributes; - -$SIG{__WARN__} = sub { die @_ }; - -sub eval_ok ($;$) { - eval shift; - is( $@, '', @_); -} - -our $anon1; eval_ok '$anon1 = sub : method { $_[0]++ }'; - -# perlcc issue 170 - https://code.google.com/p/perl-compiler/issues/detail?id=170 -eval 'sub e1 ($) : plugh ;'; -like $@, qr/^Invalid CODE attributes?: ["']?plugh["']? at/; - -eval 'sub e2 ($) : plugh(0,0) xyzzy ;'; -like $@, qr/^Invalid CODE attributes: ["']?plugh\(0,0\)["']? /; - -eval 'sub e3 ($) : plugh(0,0 xyzzy ;'; -like $@, qr/Unterminated attribute parameter in attribute list at/; - -eval 'sub e4 ($) : plugh + XYZZY ;'; -like $@, qr/Invalid separator character '[+]' in attribute list at/; - -eval_ok 'my main $x : = 0;'; -eval_ok 'my $x : = 0;'; -eval_ok 'my $x ;'; -eval_ok 'my ($x) : = 0;'; -eval_ok 'my ($x) ;'; -eval_ok 'my ($x) : ;'; -eval_ok 'my ($x,$y) : = 0;'; -eval_ok 'my ($x,$y) ;'; -eval_ok 'my ($x,$y) : ;'; - -eval 'my ($x,$y) : plugh;'; -like $@, qr/^Invalid SCALAR attribute: ["']?plugh["']? at/; - -# bug #16080 -eval '{my $x : plugh}'; -like $@, qr/^Invalid SCALAR attribute: ["']?plugh["']? at/; -eval '{my ($x,$y) : plugh(})}'; -like $@, qr/^Invalid SCALAR attribute: ["']?plugh\(}\)["']? at/; - -# More syntax tests from the attributes manpage -eval 'my $x : switch(10,foo(7,3)) : expensive;'; -like $@, qr/^Invalid SCALAR attributes: ["']?switch\(10,foo\(7,3\)\) : expensive["']? at/; -eval q/my $x : Ugly('\(") :Bad;/; -like $@, qr/^Invalid SCALAR attributes: ["']?Ugly\('\\\("\) : Bad["']? at/; -eval 'my $x : _5x5;'; -like $@, qr/^Invalid SCALAR attribute: ["']?_5x5["']? at/; -eval 'my $x : locked method;'; -like $@, qr/^Invalid SCALAR attributes: ["']?locked : method["']? at/; -eval 'my $x : switch(10,foo();'; -like $@, qr/^Unterminated attribute parameter in attribute list at/; -eval q/my $x : Ugly('(');/; -like $@, qr/^Unterminated attribute parameter in attribute list at/; -eval 'my $x : 5x5;'; -like $@, qr/error/; -eval 'my $x : Y2::north;'; -like $@, qr/Invalid separator character ':' in attribute list at/; - -sub A::MODIFY_SCALAR_ATTRIBUTES { return } -eval 'my A $x : plugh;'; -like $@, qr/^SCALAR package attribute may clash with future reserved word: ["']?plugh["']? at/; - -eval 'my A $x : plugh plover;'; -like $@, qr/^SCALAR package attributes may clash with future reserved words: ["']?plugh["']? /; - -no warnings 'reserved'; -eval 'my A $x : plugh;'; -is $@, ''; - -eval 'package Cat; my Cat @socks;'; -like $@, ''; - -eval 'my Cat %nap;'; -like $@, ''; - -sub X::MODIFY_CODE_ATTRIBUTES { die "$_[0]" } -sub X::foo { 1 } -*Y::bar = \&X::foo; -*Y::bar = \&X::foo; # second time for -w -eval 'package Z; sub Y::bar : foo'; -like $@, qr/^X at /; - -@attrs = attributes::get $anon1; -#@attrs = eval 'attributes::get $anon1'; # perlcc issue ... anon sub :method within eval -#use Devel::Peek; Dump($anon1); -is "@attrs", "method", "perlcc eval our anon sub :method access"; - -sub Z::DESTROY { } -sub Z::FETCH_CODE_ATTRIBUTES { return 'Z' } -my $thunk = eval 'bless +sub : method { 1 }, "Z"'; -is ref($thunk), "Z"; - -@attrs = eval 'attributes::get $thunk'; -is "@attrs", "method Z"; - -# Test attributes on predeclared subroutines: -eval 'package A; sub PS : lvalue'; -@attrs = eval 'attributes::get \&A::PS'; -is "@attrs", "lvalue"; - -# Test attributes on predeclared subroutines, after definition -eval 'package A; sub PS : lvalue; sub PS { }'; -@attrs = eval 'attributes::get \&A::PS'; -is "@attrs", "lvalue"; - -# Test ability to modify existing sub's (or XSUB's) attributes. -eval 'package A; sub X { $_[0] } sub X : method'; -@attrs = eval 'attributes::get \&A::X'; -is "@attrs", "method"; - -# Above not with just 'pure' built-in attributes. -sub Z::MODIFY_CODE_ATTRIBUTES { (); } -eval 'package Z; sub L { $_[0] } sub L : Z method'; -@attrs = eval 'attributes::get \&Z::L'; -is "@attrs", "method Z"; - -# Begin testing attributes that tie - -{ - package Ttie; - sub DESTROY {} - sub TIESCALAR { my $x = $_[1]; bless \$x, $_[0]; } - sub FETCH { ${$_[0]} } - sub STORE { - ::pass; - ${$_[0]} = $_[1]*2; - } - package Tloop; - sub MODIFY_SCALAR_ATTRIBUTES { tie ${$_[1]}, 'Ttie', -1; (); } -} - -eval_ok ' - package Tloop; - for my $i (0..2) { - my $x : TieLoop = $i; - $x != $i*2 and ::is $x, $i*2; - } -'; - -# bug #15898 -eval 'our ${""} : foo = 1'; -like $@, qr/Can't declare scalar dereference in "our"/; -eval 'my $$foo : bar = 1'; -like $@, qr/Can't declare scalar dereference in "my"/; - - -my @code = qw(lvalue method); -my @other = qw(shared); -my @deprecated = qw(locked unique); -my %valid; -$valid{CODE} = {map {$_ => 1} @code}; -$valid{SCALAR} = {map {$_ => 1} @other}; -$valid{ARRAY} = $valid{HASH} = $valid{SCALAR}; -my %deprecated; -$deprecated{CODE} = { locked => 1 }; -$deprecated{ARRAY} = $deprecated{HASH} = $deprecated{SCALAR} = { unique => 1 }; - -our ($scalar, @array, %hash); -foreach my $value (\&foo, \$scalar, \@array, \%hash) { - my $type = ref $value; - foreach my $negate ('', '-') { - foreach my $attr (@code, @other, @deprecated) { - my $attribute = $negate . $attr; - eval "use attributes __PACKAGE__, \$value, '$attribute'"; - if ($deprecated{$type}{$attr}) { - like $@, qr/^Attribute "$attr" is deprecated at \(eval \d+\)/, - "$type attribute $attribute deprecated"; - } elsif ($valid{$type}{$attr}) { - if ($attribute eq '-shared') { - like $@, qr/^A variable may not be unshared/; - } else { - is( $@, '', "$type attribute $attribute"); - } - } else { - like $@, qr/^Invalid $type attribute: $attribute/, - "Bogus $type attribute $attribute should fail"; - } - } - } -} - -# this will segfault if it fails -sub PVBM () { 'foo' } -{ my $dummy = index 'foo', PVBM } - -ok !defined(attributes::get(\PVBM)), - 'PVBMs don\'t segfault attributes::get'; - -{ - # [perl #49472] Attributes + Unknown Error - eval ' - use strict; - sub MODIFY_CODE_ATTRIBUTE{} - sub f:Blah {$nosuchvar}; - '; - - my $err = $@; - like ($err, qr/Global symbol "\$nosuchvar" requires /, 'perl #49472'); -} - -# Test that code attributes always get applied to the same CV that -# we're left with at the end (bug#66970). -{ - package bug66970; - our $c; - sub MODIFY_CODE_ATTRIBUTES { $c = $_[1]; () } - $c=undef; eval 'sub t0 :Foo'; - main::ok $c == \&{"t0"}; - $c=undef; eval 'sub t1 :Foo { }'; - main::ok $c == \&{"t1"}; - $c=undef; eval 'sub t2'; - our $t2a = \&{"t2"}; - $c=undef; eval 'sub t2 :Foo'; - main::ok $c == \&{"t2"} && $c == $t2a; - $c=undef; eval 'sub t3'; - our $t3a = \&{"t3"}; - $c=undef; eval 'sub t3 :Foo { }'; - main::ok $c == \&{"t3"} && $c == $t3a; - $c=undef; eval 'sub t4 :Foo'; - our $t4a = \&{"t4"}; - our $t4b = $c; - $c=undef; eval 'sub t4 :Foo'; - main::ok $c == \&{"t4"} && $c == $t4b && $c == $t4a; - $c=undef; eval 'sub t5 :Foo'; - our $t5a = \&{"t5"}; - our $t5b = $c; - $c=undef; eval 'sub t5 :Foo { }'; - main::ok $c == \&{"t5"} && $c == $t5b && $c == $t5a; -} - -my @tests = grep {/^[^#]/} split /\n/, <<'EOT'; -# This one is fine as an empty attribute list -my $holy_Einstein : = ''; -# This one is deprecated -my $krunch := 4; -our $FWISK_FWISK_FWIZZACH_FWACH_ZACHITTY_ZICH_SHAZZATZ_FWISK := ''; -state $thump := 'Trumpets'; -# Lather rinse repeat in my usual obsessive style -my @holy_perfect_pitch : = (); -my @zok := (); -our @GUKGUK := (); -# state @widget_mark := (); -my %holy_seditives : = (); -my %bang := (); -our %GIGAZING := (); -# state %hex := (); -my $holy_giveaways : = ''; -my $eee_yow := []; -our $TWOYYOYYOING_THUK_UGH := 1 == 1; -state $octothorn := 'Tinky Winky'; -my @holy_Taj_Mahal : = (); -my @touche := (); -our @PLAK_DAK_THUK_FRIT := (); -# state @hash_mark := (); -my %holy_priceless_collection_of_Etruscan_snoods : = (); -my %wham_eth := (); -our %THWUK := (); -# state %octalthorpe := (); -my $holy_sewer_pipe : = ''; -my $thunk := undef; -our $BLIT := time; -state $crunch := 'Laa Laa'; -my @glurpp := (); -my @holy_harem : = (); -our @FABADAP := (); -# state @square := (); -my %holy_pin_cushions : = (); -my %swoosh := (); -our %RRRRR := (); -# state %scratchmark := (); -EOT - -foreach my $test (@tests) { - use feature 'state'; - eval $test; - if ($test =~ /:=/) { - like $@, qr/Use of := for an empty attribute list is not allowed/, - "Parse error for q{$test}"; - } else { - is $@, '', "No error for q{$test}"; - } -} - -# [perl #68560] Calling closure prototypes (only accessible via :attr) -{ - package brength; - my $proto; - sub MODIFY_CODE_ATTRIBUTES { $proto = $_[1]; _: } - eval q{ - my $x; - () = sub :a0 { $x }; - }; - package main; - eval { $proto->() }; # used to crash in pp_entersub - like $@, qr/^Closure prototype called/, - "Calling closure proto with (no) args"; - eval { () = &$proto }; # used to crash in pp_leavesub - like $@, qr/^Closure prototype called/, - 'Calling closure proto with no @_ that returns a lexical'; -} - -# [perl #68658] Attributes on stately variables -{ - package thwext; - sub MODIFY_SCALAR_ATTRIBUTES { () } - my $i = 0; - my $x_values = ''; - eval 'sub foo { use 5.01; state $x :A0 = $i++; $x_values .= $x }'; - foo(); foo(); - package main; - is $x_values, '00', 'state with attributes'; -} - -done_testing(); diff --git a/t/CORE/op/auto.t b/t/CORE/op/auto.t deleted file mode 100644 index 8fa32ca03..000000000 --- a/t/CORE/op/auto.t +++ /dev/null @@ -1,56 +0,0 @@ -#!./perl - -INIT { - unshift @INC, "./lib"; - require 't/CORE/test.pl'; -} - -plan( tests => 39 ); - -$x = 10000; -cmp_ok(0 + ++$x - 1,'==',10000,'scalar ++x - 1'); -cmp_ok(0 + $x-- - 1,'==',10000,'scalar x-- - 1'); -cmp_ok(1 * $x, '==',10000,'scalar 1 * x'); -cmp_ok(0 + $x-- - 0,'==',10000,'scalar x-- - 0'); -cmp_ok(1 + $x, '==',10000,'scalar 1 + x'); -cmp_ok(1 + $x++, '==',10000,'scalar 1 + x++'); -cmp_ok(0 + $x, '==',10000,'scalar x'); -cmp_ok(0 + --$x + 1,'==',10000,'scalar --x + 1'); -cmp_ok(0 + ++$x + 0,'==',10000,'scalar ++x + 0'); -cmp_ok($x, '==',10000,'scalar x final'); - -$x[0] = 10000; -cmp_ok(0 + ++$x[0] - 1,'==',10000,'aelem ++x - 1'); -cmp_ok(0 + $x[0]-- - 1,'==',10000,'aelem x-- - 1'); -cmp_ok(1 * $x[0], '==',10000,'aelem 1 * x'); -cmp_ok(0 + $x[0]-- - 0,'==',10000,'aelem x-- - 0'); -cmp_ok(1 + $x[0], '==',10000,'aelem 1 + x'); -cmp_ok(1 + $x[0]++, '==',10000,'aelem 1 + x++'); -cmp_ok(0 + $x[0], '==',10000,'aelem x'); -cmp_ok(0 + --$x[0] + 1,'==',10000,'aelem --x + 1'); -cmp_ok(0 + ++$x[0] + 0,'==',10000,'aelem ++x + 0'); -cmp_ok($x[0], '==',10000,'aelem x final'); - -$x{0} = 10000; -cmp_ok(0 + ++$x{0} - 1,'==',10000,'helem ++x - 1'); -cmp_ok(0 + $x{0}-- - 1,'==',10000,'helem x-- - 1'); -cmp_ok(1 * $x{0}, '==',10000,'helem 1 * x'); -cmp_ok(0 + $x{0}-- - 0,'==',10000,'helem x-- - 0'); -cmp_ok(1 + $x{0}, '==',10000,'helem 1 + x'); -cmp_ok(1 + $x{0}++, '==',10000,'helem 1 + x++'); -cmp_ok(0 + $x{0}, '==',10000,'helem x'); -cmp_ok(0 + --$x{0} + 1,'==',10000,'helem --x + 1'); -cmp_ok(0 + ++$x{0} + 0,'==',10000,'helem ++x + 0'); -cmp_ok($x{0}, '==',10000,'helem x final'); - -# test magical autoincrement - -cmp_ok(++($foo = '99'), 'eq','100','99 incr 100'); -cmp_ok(++($foo = "99a"), 'eq','100','99a incr 100'); -cmp_ok(++($foo = "99\0a"), 'eq','100','99\0a incr 100'); -cmp_ok(++($foo = 'a0'), 'eq','a1','a0 incr a1'); -cmp_ok(++($foo = 'Az'), 'eq','Ba','Az incr Ba'); -cmp_ok(++($foo = 'zz'), 'eq','aaa','zzz incr aaa'); -cmp_ok(++($foo = 'A99'),'eq','B00','A99 incr B00'); -cmp_ok(++($foo = 'zi'), 'eq','zj','zi incr zj (EBCDIC i,j non-contiguous check)'); -cmp_ok(++($foo = 'zr'), 'eq','zs','zr incr zs (EBCDIC r,s non-contiguous check)'); diff --git a/t/CORE/op/avhv.t b/t/CORE/op/avhv.t deleted file mode 100644 index 764f89121..000000000 --- a/t/CORE/op/avhv.t +++ /dev/null @@ -1,283 +0,0 @@ -#!./perl - -# This test was originally for pseudo-hashes. It now exists to ensure -# they were properly removed in 5.9. - -INIT { - unshift @INC, 't/CORE/lib'; - require 't/CORE/test.pl'; -} - -require Tie::Array; - -package Tie::BasicArray; -@ISA = 'Tie::Array'; -sub TIEARRAY { bless [], $_[0] } -sub STORE { $_[0]->[$_[1]] = $_[2] } -sub FETCH { $_[0]->[$_[1]] } -sub FETCHSIZE { scalar(@{$_[0]})} -sub STORESIZE { $#{$_[0]} = $_[1]+1 } - -package main; - -plan(tests => 40); - -# Helper function to check the typical error message. -sub not_hash { - my($err) = shift; - like( $err, qr/^Not a HASH reference / ) || - printf STDERR "# at %s line %d.\n", (caller)[1,2]; -} - -# Something to place inside if blocks and while loops that won't get -# compiled out. -my $foo = 42; -sub no_op { $foo++ } - - -$sch = { - 'abc' => 1, - 'def' => 2, - 'jkl' => 3, -}; - -# basic normal array -$a = []; -$a->[0] = $sch; - -eval { - $a->{'abc'} = 'ABC'; -}; -not_hash($@); - -eval { - $a->{'def'} = 'DEF'; -}; -not_hash($@); - -eval { - $a->{'jkl'} = 'JKL'; -}; -not_hash($@); - -eval { - @keys = keys %$a; -}; -not_hash($@); - -eval { - @values = values %$a; -}; -not_hash($@); - -eval { - while( my($k,$v) = each %$a ) { - no_op; - } -}; -not_hash($@); - - -# quick check with tied array -tie @fake, 'Tie::StdArray'; -$a = \@fake; -$a->[0] = $sch; - -eval { - $a->{'abc'} = 'ABC'; -}; -not_hash($@); - -eval { - if ($a->{'abc'} eq 'ABC') { no_op(23) } else { no_op(42) } -}; -not_hash($@); - -# quick check with tied array -tie @fake, 'Tie::BasicArray'; -$a = \@fake; -$a->[0] = $sch; - -eval { - $a->{'abc'} = 'ABC'; -}; -not_hash($@); - -eval { - if ($a->{'abc'} eq 'ABC') { no_op(23) } else { no_op(42) } -}; -not_hash($@); - -# quick check with tied array & tied hash -require Tie::Hash; -tie %fake, Tie::StdHash; -%fake = %$sch; -$a->[0] = \%fake; - -eval { - $a->{'abc'} = 'ABC'; -}; -not_hash($@); - -eval { - if ($a->{'abc'} eq 'ABC') { no_op(23) } else { no_op(42) } -}; -not_hash($@); - - -# hash slice -eval { - my $slice = join('', 'x',@$a{'abc','def'},'x'); -}; -not_hash($@); - - -# evaluation in scalar context -my $avhv = [{}]; - -eval { - () = %$avhv; -}; -not_hash($@); - -push @$avhv, "a"; -eval { - () = %$avhv; -}; -not_hash($@); - -$avhv = []; -eval { $a = %$avhv }; -not_hash($@); - -$avhv = [{foo=>1, bar=>2}]; -eval { - %$avhv =~ m,^\d+/\d+,; -}; -not_hash($@); - -# check if defelem magic works -sub f { - print "not " unless $_[0] eq 'a'; - $_[0] = 'b'; - print "ok 11\n"; -} -$a = [{key => 1}, 'a']; -eval { - f($a->{key}); -}; -not_hash($@); - -# check if exists() is behaving properly -$avhv = [{foo=>1,bar=>2,pants=>3}]; -eval { - no_op if exists $avhv->{bar}; -}; -not_hash($@); - -eval { - $avhv->{pants} = undef; -}; -not_hash($@); - -eval { - no_op if exists $avhv->{pants}; -}; -not_hash($@); - -eval { - no_op if exists $avhv->{bar}; -}; -not_hash($@); - -eval { - $avhv->{bar} = 10; -}; -not_hash($@); - -eval { - no_op unless exists $avhv->{bar} and $avhv->{bar} == 10; -}; -not_hash($@); - -eval { - $v = delete $avhv->{bar}; -}; -not_hash($@); - -eval { - no_op if exists $avhv->{bar}; -}; -not_hash($@); - -eval { - $avhv->{foo} = 'xxx'; -}; -not_hash($@); -eval { - $avhv->{bar} = 'yyy'; -}; -not_hash($@); -eval { - $avhv->{pants} = 'zzz'; -}; -not_hash($@); -eval { - @x = delete @{$avhv}{'foo','pants'}; -}; -not_hash($@); -eval { - no_op unless "$avhv->{bar}" eq "yyy"; -}; -not_hash($@); - -# hash assignment -eval { - %$avhv = (); -}; -not_hash($@); - -eval { - %hv = %$avhv; -}; -not_hash($@); - -eval { - %$avhv = (foo => 29, pants => 2, bar => 0); -}; -not_hash($@); - -my $extra; -my @extra; -eval { - ($extra, %$avhv) = ("moo", foo => 42, pants => 53, bar => "HIKE!"); -}; -not_hash($@); - -eval { - %$avhv = (); - (%$avhv, $extra) = (foo => 42, pants => 53, bar => "HIKE!"); -}; -not_hash($@); - -eval { - @extra = qw(whatever and stuff); - %$avhv = (); -}; -not_hash($@); -eval { - (%$avhv, @extra) = (foo => 42, pants => 53, bar => "HIKE!"); -}; -not_hash($@); - -eval { - (@extra, %$avhv) = (foo => 42, pants => 53, bar => "HIKE!"); -}; -not_hash($@); - -# Check hash slices (BUG ID 20010423.002) -$avhv = [{foo=>1, bar=>2}]; -eval { - @$avhv{"foo", "bar"} = (42, 53); -}; -not_hash($@); diff --git a/t/CORE/op/bless.t b/t/CORE/op/bless.t deleted file mode 100644 index 726efe620..000000000 --- a/t/CORE/op/bless.t +++ /dev/null @@ -1,143 +0,0 @@ -#!./perl - -INIT { - require 't/CORE/test.pl'; -} - -plan (109); - -sub expected { - my($object, $package, $type) = @_; - print "# $object $package $type\n"; - is(ref($object), $package); - my $r = qr/^\Q$package\E=(\w+)\(0x([0-9a-f]+)\)$/; - like("$object", $r); - if ("$object" =~ $r) { - is($1, $type); - # in 64-bit platforms hex warns for 32+ -bit values - cmp_ok(do {no warnings 'portable'; hex($2)}, '==', $object); - } - else { - fail(); fail(); - } -} - -# test blessing simple types - -$a1 = bless {}, "A"; -expected($a1, "A", "HASH"); -$b1 = bless [], "B"; -expected($b1, "B", "ARRAY"); -$c1 = bless \(map "$_", "test"), "C"; -expected($c1, "C", "SCALAR"); -our $test = "foo"; $d1 = bless \*test, "D"; -expected($d1, "D", "GLOB"); -$e1 = bless sub { 1 }, "E"; -expected($e1, "E", "CODE"); -$f1 = bless \[], "F"; -expected($f1, "F", "REF"); -$g1 = bless \substr("test", 1, 2), "G"; -expected($g1, "G", "LVALUE"); - -# blessing ref to object doesn't modify object - -expected(bless(\$a1, "F"), "F", "REF"); -expected($a1, "A", "HASH"); - -# reblessing does modify object - -bless $a1, "A2"; -expected($a1, "A2", "HASH"); - -# local and my -{ - local $a1 = bless $a1, "A3"; # should rebless outer $a1 - local $b1 = bless [], "B3"; - my $c1 = bless $c1, "C3"; # should rebless outer $c1 - our $test2 = ""; my $d1 = bless \*test2, "D3"; - expected($a1, "A3", "HASH"); - expected($b1, "B3", "ARRAY"); - expected($c1, "C3", "SCALAR"); - expected($d1, "D3", "GLOB"); -} -expected($a1, "A3", "HASH"); -expected($b1, "B", "ARRAY"); -expected($c1, "C3", "SCALAR"); -expected($d1, "D", "GLOB"); - -# class is magic -"E" =~ /(.)/; -expected(bless({}, $1), "E", "HASH"); -{ - local $! = 1; - my $string = "$!"; - $! = 2; # attempt to avoid cached string - $! = 1; - expected(bless({}, $!), $string, "HASH"); - -# ref is ref to magic - { - { - package F; - sub test { main::is(${$_[0]}, $string) } - } - $! = 2; - $f1 = bless \$!, "F"; - $! = 1; - $f1->test; - } -} - -# ref is magic -### example of magic variable that is a reference?? - -# no class, or empty string (with a warning), or undef (with two) -expected(bless([]), 'main', "ARRAY"); -{ - local $SIG{__WARN__} = sub { push @w, join '', @_ }; - use warnings; - - $m = bless []; - expected($m, 'main', "ARRAY"); - is (scalar @w, 0, "array 0"); - - @w = (); - $m = bless [], ''; - expected($m, 'main', "ARRAY"); - is (scalar @w, 1, "array 1"); - - @w = (); - $m = bless [], undef; - expected($m, 'main', "ARRAY"); - is (scalar @w, 2, "array 2"); -} - -# class is a ref -$a1 = bless {}, "A4"; -$b1 = eval { bless {}, $a1 }; -isnt ($@, '', "class is a ref"); - -# class is an overloaded ref -{ - package H4; - # perlcc issue 172 - https://code.google.com/p/perl-compiler/issues/detail?id=172 - use overload '""' => sub { "C4" }; -} -$h1 = bless {}, "H4"; -$c4 = eval { bless \$test, $h1 }; -is ($@, '', "class is an overloaded ref"); -expected($c4, 'C4', "SCALAR"); - -{ - my %h = 1..2; - my($k) = keys %h; - my $x=\$k; - bless $x, 'pam'; - is(ref $x, 'pam'); - - my $a = bless \(keys %h), 'zap'; - is(ref $a, 'zap'); -} - -bless [], "main::"; -ok(1, 'blessing into main:: does not crash'); # [perl #87388] diff --git a/t/CORE/op/bop.t b/t/CORE/op/bop.t deleted file mode 100644 index 7dd61edf4..000000000 --- a/t/CORE/op/bop.t +++ /dev/null @@ -1,558 +0,0 @@ -#!./perl - -# -# test the bit operators '&', '|', '^', '~', '<<', and '>>' -# - -BEGIN { - unshift @INC, 't/CORE/lib'; - require 't/CORE/test.pl'; - require Config; -} - -# Tests don't have names yet. -# If you find tests are failing, please try adding names to tests to track -# down where the failure is, and supply your new names as a patch. -# (Just-in-time test naming) -plan tests => 171 + (10*13*2) + 4; - -# numerics -ok ((0xdead & 0xbeef) == 0x9ead); -ok ((0xdead | 0xbeef) == 0xfeef); -ok ((0xdead ^ 0xbeef) == 0x6042); -ok ((~0xdead & 0xbeef) == 0x2042); - -# shifts -ok ((257 << 7) == 32896); -ok ((33023 >> 7) == 257); - -# signed vs. unsigned -ok ((~0 > 0 && do { use integer; ~0 } == -1)); - -my $bits = 0; -for (my $i = ~0; $i; $i >>= 1) { ++$bits; } -my $cusp = eval qq{1 << ($bits - 1)}; # poor editor fix - - -ok (($cusp & -1) > 0 && do { use integer; $cusp & -1 } < 0); -ok (($cusp | 1) > 0 && do { use integer; $cusp | 1 } < 0); -ok (($cusp ^ 1) > 0 && do { use integer; $cusp ^ 1 } < 0); -ok ((eval qq{1 << ($bits - 1)}) == $cusp && - do { use integer; eval qq{1 << ($bits - 1)} } == -$cusp); -ok (($cusp >> 1) == ($cusp / 2) && - do { use integer; abs($cusp >> 1) } == ($cusp / 2)); - -$Aaz = chr(ord("A") & ord("z")); -$Aoz = chr(ord("A") | ord("z")); -$Axz = chr(ord("A") ^ ord("z")); - -# short strings -is (("AAAAA" & "zzzzz"), ($Aaz x 5)); -is (("AAAAA" | "zzzzz"), ($Aoz x 5)); -is (("AAAAA" ^ "zzzzz"), ($Axz x 5)); - -# long strings -$foo = "A" x 150; -$bar = "z" x 75; -$zap = "A" x 75; -# & truncates -is (($foo & $bar), ($Aaz x 75 )); -# | does not truncate -is (($foo | $bar), ($Aoz x 75 . $zap)); -# ^ does not truncate -is (($foo ^ $bar), ($Axz x 75 . $zap)); - -# string constants -sub _and($) { $_[0] & "+0" } -sub _oar($) { $_[0] | "+0" } -sub _xor($) { $_[0] ^ "+0" } -is _and "waf", '# ', 'str var & const str'; # These three -is _and 0, '0', 'num var & const str'; # are from -is _and "waf", '# ', 'str var & const str again'; # [perl #20661] -is _oar "yit", '{yt', 'str var | const str'; -is _oar 0, '0', 'num var | const str'; -is _oar "yit", '{yt', 'str var | const str again'; -is _xor "yit", 'RYt', 'str var ^ const str'; -is _xor 0, '0', 'num var ^ const str'; -is _xor "yit", 'RYt', 'str var ^ const str again'; - -# -is ("ok \xFF\xFF\n" & "ok 19\n", "ok 19\n"); -is ("ok 20\n" | "ok \0\0\n", "ok 20\n"); -is ("o\000 \0001\000" ^ "\000k\0002\000\n", "ok 21\n"); - -# -is ("ok \x{FF}\x{FF}\n" & "ok 22\n", "ok 22\n"); -is ("ok 23\n" | "ok \x{0}\x{0}\n", "ok 23\n"); -is ("o\x{0} \x{0}4\x{0}" ^ "\x{0}k\x{0}2\x{0}\n", "ok 24\n"); - -# -is (sprintf("%vd", v4095 & v801), 801); -is (sprintf("%vd", v4095 | v801), 4095); -is (sprintf("%vd", v4095 ^ v801), 3294); - -# -is (sprintf("%vd", v4095.801.4095 & v801.4095), '801.801'); -is (sprintf("%vd", v4095.801.4095 | v801.4095), '4095.4095.4095'); -is (sprintf("%vd", v801.4095 ^ v4095.801.4095), '3294.3294.4095'); -# -is (sprintf("%vd", v120.300 & v200.400), '72.256'); -is (sprintf("%vd", v120.300 | v200.400), '248.444'); -is (sprintf("%vd", v120.300 ^ v200.400), '176.188'); -# -my $a = v120.300; -my $b = v200.400; -$a ^= $b; -is (sprintf("%vd", $a), '176.188'); -my $a = v120.300; -my $b = v200.400; -$a |= $b; -is (sprintf("%vd", $a), '248.444'); - -# -# UTF8 ~ behaviour -# - -my $Is_EBCDIC = (ord('A') == 193) ? 1 : 0; - -my @not36; - -for (0x100...0xFFF) { - $a = ~(chr $_); - if ($Is_EBCDIC) { - push @not36, sprintf("%#03X", $_) - if $a ne chr(~$_) or length($a) != 1; - } - else { - push @not36, sprintf("%#03X", $_) - if $a ne chr(~$_) or length($a) != 1 or ~$a ne chr($_); - } -} -is (join (', ', @not36), ''); - -my @not37; - -for my $i (0xEEE...0xF00) { - for my $j (0x0..0x120) { - $a = ~(chr ($i) . chr $j); - if ($Is_EBCDIC) { - push @not37, sprintf("%#03X %#03X", $i, $j) - if $a ne chr(~$i).chr(~$j) or - length($a) != 2; - } - else { - push @not37, sprintf("%#03X %#03X", $i, $j) - if $a ne chr(~$i).chr(~$j) or - length($a) != 2 or - ~$a ne chr($i).chr($j); - } - } -} -is (join (', ', @not37), ''); - -SKIP: { - skip "EBCDIC" if $Is_EBCDIC; - is (~chr(~0), "\0"); -} - - -my @not39; - -for my $i (0x100..0x120) { - for my $j (0x100...0x120) { - push @not39, sprintf("%#03X %#03X", $i, $j) - if ~(chr($i)|chr($j)) ne (~chr($i)&~chr($j)); - } -} -is (join (', ', @not39), ''); - -my @not40; - -for my $i (0x100..0x120) { - for my $j (0x100...0x120) { - push @not40, sprintf("%#03X %#03X", $i, $j) - if ~(chr($i)&chr($j)) ne (~chr($i)|~chr($j)); - } -} -is (join (', ', @not40), ''); - - -# More variations on 19 and 22. -is ("ok \xFF\x{FF}\n" & "ok 41\n", "ok 41\n"); -is ("ok \x{FF}\xFF\n" & "ok 42\n", "ok 42\n"); - -# Tests to see if you really can do casts negative floats to unsigned properly -$neg1 = -1.0; -ok (~ $neg1 == 0); -$neg7 = -7.0; -ok (~ $neg7 == 6); - - -# double magic tests - -sub TIESCALAR { bless { value => $_[1], orig => $_[1] } } -sub STORE { $_[0]{store}++; $_[0]{value} = $_[1] } -sub FETCH { $_[0]{fetch}++; $_[0]{value} } -sub stores { tied($_[0])->{value} = tied($_[0])->{orig}; - delete(tied($_[0])->{store}) || 0 } -sub fetches { delete(tied($_[0])->{fetch}) || 0 } - -# numeric double magic tests - -tie $x, "main", 1; -tie $y, "main", 3; - -is(($x | $y), 3); -is(fetches($x), 1); -is(fetches($y), 1); -is(stores($x), 0); -is(stores($y), 0); - -is(($x & $y), 1); -is(fetches($x), 1); -is(fetches($y), 1); -is(stores($x), 0); -is(stores($y), 0); - -is(($x ^ $y), 2); -is(fetches($x), 1); -is(fetches($y), 1); -is(stores($x), 0); -is(stores($y), 0); - -is(($x |= $y), 3); -is(fetches($x), 2); -is(fetches($y), 1); -is(stores($x), 1); -is(stores($y), 0); - -is(($x &= $y), 1); -is(fetches($x), 2); -is(fetches($y), 1); -is(stores($x), 1); -is(stores($y), 0); - -is(($x ^= $y), 2); -is(fetches($x), 2); -is(fetches($y), 1); -is(stores($x), 1); -is(stores($y), 0); - -is(~~$y, 3); -is(fetches($y), 1); -is(stores($y), 0); - -{ use integer; - -is(($x | $y), 3); -is(fetches($x), 1); -is(fetches($y), 1); -is(stores($x), 0); -is(stores($y), 0); - -is(($x & $y), 1); -is(fetches($x), 1); -is(fetches($y), 1); -is(stores($x), 0); -is(stores($y), 0); - -is(($x ^ $y), 2); -is(fetches($x), 1); -is(fetches($y), 1); -is(stores($x), 0); -is(stores($y), 0); - -is(($x |= $y), 3); -is(fetches($x), 2); -is(fetches($y), 1); -is(stores($x), 1); -is(stores($y), 0); - -is(($x &= $y), 1); -is(fetches($x), 2); -is(fetches($y), 1); -is(stores($x), 1); -is(stores($y), 0); - -is(($x ^= $y), 2); -is(fetches($x), 2); -is(fetches($y), 1); -is(stores($x), 1); -is(stores($y), 0); - -is(~$y, -4); -is(fetches($y), 1); -is(stores($y), 0); - -} # end of use integer; - -# stringwise double magic tests - -tie $x, "main", "a"; -tie $y, "main", "c"; - -is(($x | $y), ("a" | "c")); -is(fetches($x), 1); -is(fetches($y), 1); -is(stores($x), 0); -is(stores($y), 0); - -is(($x & $y), ("a" & "c")); -is(fetches($x), 1); -is(fetches($y), 1); -is(stores($x), 0); -is(stores($y), 0); - -is(($x ^ $y), ("a" ^ "c")); -is(fetches($x), 1); -is(fetches($y), 1); -is(stores($x), 0); -is(stores($y), 0); - -is(($x |= $y), ("a" | "c")); -is(fetches($x), 2); -is(fetches($y), 1); -is(stores($x), 1); -is(stores($y), 0); - -is(($x &= $y), ("a" & "c")); -is(fetches($x), 2); -is(fetches($y), 1); -is(stores($x), 1); -is(stores($y), 0); - -is(($x ^= $y), ("a" ^ "c")); -is(fetches($x), 2); -is(fetches($y), 1); -is(stores($x), 1); -is(stores($y), 0); - -is(~~$y, "c"); -is(fetches($y), 1); -is(stores($y), 0); - -$a = "\0\x{100}"; chop($a); -ok(utf8::is_utf8($a)); # make sure UTF8 flag is still there -$a = ~$a; -is($a, "\xFF", "~ works with utf-8"); - -# [rt.perl.org 33003] -# This would cause a segfault without malloc wrap -SKIP: { - skip "No malloc wrap checks" unless $Config::Config{usemallocwrap}; - like( runperl(prog => 'eval q($#a>>=1); print 1'), "^1\n?" ); -} - -# [perl #37616] Bug in &= (string) and/or m// -{ - $a = "aa"; - $a &= "a"; - ok($a =~ /a+$/, 'ASCII "a" is NUL-terminated'); - - $b = "bb\x{100}"; - $b &= "b"; - ok($b =~ /b+$/, 'Unicode "b" is NUL-terminated'); -} - -{ - $a = chr(0x101) x 0x101; - $b = chr(0x0FF) x 0x0FF; - - $c = $a | $b; - is($c, chr(0x1FF) x 0xFF . chr(0x101) x 2); - - $c = $b | $a; - is($c, chr(0x1FF) x 0xFF . chr(0x101) x 2); - - $c = $a & $b; - is($c, chr(0x001) x 0x0FF); - - $c = $b & $a; - is($c, chr(0x001) x 0x0FF); - - $c = $a ^ $b; - is($c, chr(0x1FE) x 0x0FF . chr(0x101) x 2); - - $c = $b ^ $a; - is($c, chr(0x1FE) x 0x0FF . chr(0x101) x 2); -} - -{ - $a = chr(0x101) x 0x101; - $b = chr(0x0FF) x 0x0FF; - - $a |= $b; - is($a, chr(0x1FF) x 0xFF . chr(0x101) x 2); -} - -{ - $a = chr(0x101) x 0x101; - $b = chr(0x0FF) x 0x0FF; - - $b |= $a; - is($b, chr(0x1FF) x 0xFF . chr(0x101) x 2); -} - -{ - $a = chr(0x101) x 0x101; - $b = chr(0x0FF) x 0x0FF; - - $a &= $b; - is($a, chr(0x001) x 0x0FF); -} - -{ - $a = chr(0x101) x 0x101; - $b = chr(0x0FF) x 0x0FF; - - $b &= $a; - is($b, chr(0x001) x 0x0FF); -} - -{ - $a = chr(0x101) x 0x101; - $b = chr(0x0FF) x 0x0FF; - - $a ^= $b; - is($a, chr(0x1FE) x 0x0FF . chr(0x101) x 2); -} - -{ - $a = chr(0x101) x 0x101; - $b = chr(0x0FF) x 0x0FF; - - $b ^= $a; - is($b, chr(0x1FE) x 0x0FF . chr(0x101) x 2); -} - -# update to pp_complement() via Coverity -SKIP: { - # UTF-EBCDIC is limited to 0x7fffffff and can't encode ~0. - skip "EBCDIC" if $Is_EBCDIC; - - my $str = "\x{10000}\x{800}"; - # U+10000 is four bytes in UTF-8/UTF-EBCDIC. - # U+0800 is three bytes in UTF-8/UTF-EBCDIC. - - no warnings "utf8"; - { use bytes; $str =~ s/\C\C\z//; } - -# perlcc issue 174 - https://code.google.com/p/perl-compiler/issues/detail?id=174 - - # it's really bogus that (~~malformed) is \0. - my $ref = "\x{10000}\0"; - is(~~$str, $ref); - - # same test, but this time with a longer replacement string that - # exercises a different branch in pp_subsr() - - $str = "\x{10000}\x{800}"; - { use bytes; $str =~ s/\C\C\z/\0\0\0/; } - - # it's also bogus that (~~malformed) is \0\0\0\0. - my $ref = "\x{10000}\0\0\0\0"; - is(~~$str, $ref, "use bytes with long replacement"); -} - -# ref tests - -my %res; - -for my $str ("x", "\x{100}") { - for my $chr (qw/S A H G X ( * F/) { - for my $op (qw/| & ^/) { - my $co = ord $chr; - my $so = ord $str; - $res{"$chr$op$str"} = eval qq/chr($co $op $so)/; - } - } - $res{"undef|$str"} = $str; - $res{"undef&$str"} = ""; - $res{"undef^$str"} = $str; -} - -sub PVBM () { "X" } -index "foo", PVBM; - -my $warn = 0; -local $^W = 1; -local $SIG{__WARN__} = sub { $warn++ }; - -sub is_first { - my ($got, $orig, $op, $str, $name) = @_; - is(substr($got, 0, 1), $res{"$orig$op$str"}, $name); -} - -for ( - # [object to test, first char of stringification, name] - [undef, "undef", "undef" ], - [\1, "S", "scalar ref" ], - [[], "A", "array ref" ], - [{}, "H", "hash ref" ], - [qr/x/, "(", "qr//" ], - [*foo, "*", "glob" ], - [\*foo, "G", "glob ref" ], - [PVBM, "X", "PVBM" ], - [\PVBM, "S", "PVBM ref" ], - [bless([], "Foo"), "F", "object" ], -) { - my ($val, $orig, $type) = @$_; - - for (["x", "string"], ["\x{100}", "utf8"]) { - my ($str, $desc) = @$_; - - $warn = 0; - - is_first($val | $str, $orig, "|", $str, "$type | $desc"); - is_first($val & $str, $orig, "&", $str, "$type & $desc"); - is_first($val ^ $str, $orig, "^", $str, "$type ^ $desc"); - - is_first($str | $val, $orig, "|", $str, "$desc | $type"); - is_first($str & $val, $orig, "&", $str, "$desc & $type"); - is_first($str ^ $val, $orig, "^", $str, "$desc ^ $type"); - - my $new; - ($new = $val) |= $str; - is_first($new, $orig, "|", $str, "$type |= $desc"); - ($new = $val) &= $str; - is_first($new, $orig, "&", $str, "$type &= $desc"); - ($new = $val) ^= $str; - is_first($new, $orig, "^", $str, "$type ^= $desc"); - - ($new = $str) |= $val; - is_first($new, $orig, "|", $str, "$desc |= $type"); - ($new = $str) &= $val; - is_first($new, $orig, "&", $str, "$desc &= $type"); - ($new = $str) ^= $val; - is_first($new, $orig, "^", $str, "$desc ^= $type"); - - if ($orig eq "undef") { - # undef |= and undef ^= don't warn - is($warn, 10, "no duplicate warnings"); - } - else { - is($warn, 0, "no warnings"); - } - } -} - -my $strval; - -{ - package Bar; - # perlcc issue 172 - https://code.google.com/p/perl-compiler/issues/detail?id=172 - use overload q/""/ => sub { $strval }; - - package Baz; - use overload q/|/ => sub { "y" }; -} - -ok(!eval { bless([], "Bar") | "x"; 1 }, "string overload can't use |"); -like($@, qr/no method found/, "correct error"); -is(eval { bless([], "Baz") | "x" }, "y", "| overload works"); - -my $obj = bless [], "Bar"; -$strval = "x"; -eval { $obj |= "Q" }; -$strval = "z"; -is("$obj", "z", "|= doesn't break string overload"); diff --git a/t/CORE/op/caller.pl b/t/CORE/op/caller.pl deleted file mode 100644 index bf2afe974..000000000 --- a/t/CORE/op/caller.pl +++ /dev/null @@ -1,175 +0,0 @@ -# tests shared between t/op/caller.t and ext/XS-APItest/t/op.t - -use strict; -use warnings; - -sub dooot { - is(hint_fetch('dooot'), undef); - is(hint_fetch('thikoosh'), undef); - ok(!hint_exists('dooot')); - ok(!hint_exists('thikoosh')); - if ($::testing_caller) { - is(hint_fetch('dooot', 1), 54); - } - BEGIN { - $^H{dooot} = 42; - } - is(hint_fetch('dooot'), 6 * 7); - if ($::testing_caller) { - is(hint_fetch('dooot', 1), 54); - } - - BEGIN { - $^H{dooot} = undef; - } - is(hint_fetch('dooot'), undef); - ok(hint_exists('dooot')); - - BEGIN { - delete $^H{dooot}; - } - is(hint_fetch('dooot'), undef); - ok(!hint_exists('dooot')); - if ($::testing_caller) { - is(hint_fetch('dooot', 1), 54); - } -} -{ - is(hint_fetch('dooot'), undef); - is(hint_fetch('thikoosh'), undef); - BEGIN { - $^H{dooot} = 1; - $^H{thikoosh} = "SKREECH"; - } - if ($::testing_caller) { - is(hint_fetch('dooot'), 1); - } - is(hint_fetch('thikoosh'), "SKREECH"); - - BEGIN { - $^H{dooot} = 42; - } - { - { - BEGIN { - $^H{dooot} = 6 * 9; - } - is(hint_fetch('dooot'), 54); - is(hint_fetch('thikoosh'), "SKREECH"); - { - BEGIN { - delete $^H{dooot}; - } - is(hint_fetch('dooot'), undef); - ok(!hint_exists('dooot')); - is(hint_fetch('thikoosh'), "SKREECH"); - } - dooot(); - } - is(hint_fetch('dooot'), 6 * 7); - is(hint_fetch('thikoosh'), "SKREECH"); - } - is(hint_fetch('dooot'), 6 * 7); - is(hint_fetch('thikoosh'), "SKREECH"); -} - -print "# which now works inside evals\n"; - -{ - BEGIN { - $^H{dooot} = 42; - } - is(hint_fetch('dooot'), 6 * 7); - - eval "is(hint_fetch('dooot'), 6 * 7); 1" or die $@; - - eval <<'EOE' or die $@; - is(hint_fetch('dooot'), 6 * 7); - eval "is(hint_fetch('dooot'), 6 * 7); 1" or die $@; - BEGIN { - $^H{dooot} = 54; - } - is(hint_fetch('dooot'), 54); - eval "is(hint_fetch('dooot'), 54); 1" or die $@; - eval 'BEGIN { $^H{dooot} = -1; }; 1' or die $@; - is(hint_fetch('dooot'), 54); - eval "is(hint_fetch('dooot'), 54); 1" or die $@; -EOE -} - -{ - BEGIN { - $^H{dooot} = "FIP\0FOP\0FIDDIT\0FAP"; - } - is(hint_fetch('dooot'), "FIP\0FOP\0FIDDIT\0FAP", "Can do embedded 0 bytes"); - - BEGIN { - $^H{dooot} = chr 256; - } - is(hint_fetch('dooot'), chr 256, "Can do Unicode"); - - BEGIN { - $^H{dooot} = -42; - } - is(hint_fetch('dooot'), -42, "Can do IVs"); - - BEGIN { - $^H{dooot} = ~0; - } - cmp_ok(hint_fetch('dooot'), '>', 42, "Can do UVs"); -} - -{ - my ($k1, $k2, $k3, $k4); - BEGIN { - $k1 = chr 163; - $k2 = $k1; - $k3 = chr 256; - $k4 = $k3; - utf8::upgrade $k2; - utf8::encode $k4; - - $^H{$k1} = 1; - $^H{$k2} = 2; - $^H{$k3} = 3; - $^H{$k4} = 4; - } - - - is(hint_fetch($k1), 2, "UTF-8 or not, it's the same"); - if ($::testing_caller) { - # Perl_refcounted_he_fetch() insists that you have the key correctly - # normalised for the way hashes store them. As this one isn't - # normalised down to bytes, it won't t work with - # Perl_refcounted_he_fetch() - is(hint_fetch($k2), 2, "UTF-8 or not, it's the same"); - } - is(hint_fetch($k3), 3, "Octect sequences and UTF-8 are distinct"); - is(hint_fetch($k4), 4, "Octect sequences and UTF-8 are distinct"); -} - -{ - my ($k1, $k2, $k3); - BEGIN { - ($k1, $k2, $k3) = ("\0", "\0\0", "\0\0\0"); - $^H{$k1} = 1; - $^H{$k2} = 2; - $^H{$k3} = 3; - } - - is(hint_fetch($k1), 1, "Keys with the same hash value don't clash"); - is(hint_fetch($k2), 2, "Keys with the same hash value don't clash"); - is(hint_fetch($k3), 3, "Keys with the same hash value don't clash"); - - BEGIN { - $^H{$k1} = "a"; - $^H{$k2} = "b"; - $^H{$k3} = "c"; - } - - is(hint_fetch($k1), "a", "Keys with the same hash value don't clash"); - is(hint_fetch($k2), "b", "Keys with the same hash value don't clash"); - is(hint_fetch($k3), "c", "Keys with the same hash value don't clash"); -} - -1; diff --git a/t/CORE/op/caller.t b/t/CORE/op/caller.t deleted file mode 100644 index cdb41e7d7..000000000 --- a/t/CORE/op/caller.t +++ /dev/null @@ -1,240 +0,0 @@ -#!./perl -# Tests for caller() - -BEGIN { require 't/CORE/test.pl'; } - -plan( tests => 74 ); - -my @c; - -print "# Tests with caller(0)\n"; - -@c = caller(0); -ok( (!@c), "caller(0) in main program" ); - -eval { @c = caller(0) }; -is( $c[3], "(eval)", "subroutine name in an eval {}" ); -ok( !$c[4], "hasargs false in an eval {}" ); - -eval q{ @c = (Caller(0))[3] }; -is( $c[3], "(eval)", "subroutine name in an eval ''" ); -ok( !$c[4], "hasargs false in an eval ''" ); - -sub { @c = caller(0) } -> (); -is( $c[3], "main::__ANON__", "anonymous subroutine name" ); -ok( $c[4], "hasargs true with anon sub" ); - -# Bug 20020517.003, used to dump core -sub foo { @c = caller(0) } -my $fooref = delete $::{foo}; -$fooref -> (); -TODO: { - local $TODO = 'https://code.google.com/p/perl-compiler/issues/detail?id=182'; - is( $c[3], "main::__ANON__", "deleted subroutine name" ); -} -ok( $c[4], "hasargs true with deleted sub" ); - -#test can't be run in perlcc -#BEGIN { -# require strict; -# is +(caller 0)[1], __FILE__, -# "[perl #68712] filenames after require in a BEGIN block" -#} - -print "# Tests with caller(1)\n"; - -sub f { @c = caller(1) } - -sub callf { f(); } -callf(); -is( $c[3], "main::callf", "subroutine name" ); -ok( $c[4], "hasargs true with callf()" ); -&callf; -ok( !$c[4], "hasargs false with &callf" ); - -eval { f() }; -is( $c[3], "(eval)", "subroutine name in an eval {}" ); -ok( !$c[4], "hasargs false in an eval {}" ); - -eval q{ f() }; -is( $c[3], "(eval)", "subroutine name in an eval ''" ); -ok( !$c[4], "hasargs false in an eval ''" ); - -sub { f() } -> (); -is( $c[3], "main::__ANON__", "anonymous subroutine name" ); -ok( $c[4], "hasargs true with anon sub" ); - -sub foo2 { f() } -my $fooref2 = delete $::{foo2}; -$fooref2 -> (); -TODO: { - local $TODO = 'https://code.google.com/p/perl-compiler/issues/detail?id=182'; - is( $c[3], "main::__ANON__", "deleted subroutine name" ); -} -ok( $c[4], "hasargs true with deleted sub" ); - -# See if caller() returns the correct warning mask - -sub show_bits -{ - my $in = shift; - my $out = ''; - foreach (unpack('W*', $in)) { - $out .= sprintf('\x%02x', $_); - } - return $out; -} - -sub check_bits -{ - local $Level = $Level + 2; - my ($got, $exp, $desc) = @_; - if (! ok($got eq $exp, $desc)) { - diag(' got: ' . show_bits($got)); - diag('expected: ' . show_bits($exp)); - } -} - -sub testwarn { - my $w = shift; - my $id = shift; - check_bits( (caller(0))[9], $w, "warnings match caller ($id)"); -} - -# warning bits in BEGIN blocks not easily tested in perlcc -#{ -# no warnings; -# # Build the warnings mask dynamically -# my ($default, $registered); -# BEGIN { -# for my $i (0..$warnings::LAST_BIT/2 - 1) { -# vec($default, $i, 2) = 1; -# } -# $registered = $default; -# vec($registered, $warnings::LAST_BIT/2, 2) = 1; -# } -# -# # The repetition number must be set to the value of $BYTES in -# # lib/warnings.pm -# BEGIN { check_bits( ${^WARNING_BITS}, "\0" x 13, 'all bits off via "no warnings"' ) } -# testwarn("\0" x 13, 'no bits'); -# -# use warnings; -# BEGIN { check_bits( ${^WARNING_BITS}, $default, -# 'default bits on via "use warnings"' ); } -# BEGIN { testwarn($default, 'all'); } -# # run-time : -# # the warning mask has been extended by warnings::register -# testwarn($registered, 'ahead of w::r'); -# -# use warnings::register; -# BEGIN { check_bits( ${^WARNING_BITS}, $registered, -# 'warning bits on via "use warnings::register"' ) } -# testwarn($registered, 'following w::r'); -#} - - -# The next two cases test for a bug where caller ignored evals if -# the DB::sub glob existed but &DB::sub did not (for example, if -# $^P had been set but no debugger has been loaded). The tests -# thus assume that there is no &DB::sub: if there is one, they -# should both pass no matter whether or not this bug has been -# fixed. - -my $debugger_test = q< - my @stackinfo = caller(0); - return scalar @stackinfo; ->; - -sub pb { return (caller(0))[3] } - -my $i = eval $debugger_test; -is( $i, 11, "do not skip over eval (and caller returns 10 elements)" ); - -is( eval 'pb()', 'main::pb', "actually return the right function name" ); - -my $saved_perldb = $^P; -$^P = 16; -$^P = $saved_perldb; - -$i = eval $debugger_test; -is( $i, 11, 'do not skip over eval even if $^P had been on at some point' ); -is( eval 'pb()', 'main::pb', 'actually return the right function name even if $^P had been on at some point' ); - -print "# caller can now return the compile time state of %^H\n"; - -sub hint_exists { - my $key = shift; - my $level = shift; - my @results = caller($level||0); - exists $results[10]->{$key}; -} - -sub hint_fetch { - my $key = shift; - my $level = shift; - my @results = caller($level||0); - $results[10]->{$key}; -} - -{ - my $tmpfile = tempfile(); - - open my $fh, '>', $tmpfile or die "open $tmpfile: $!"; - print $fh <<'EOP'; -#!perl -wl -use strict; - -{ - package KAZASH ; - - sub DESTROY { - print "DESTROY"; - } -} - -@DB::args = bless [], 'KAZASH'; - -print $^P; -print scalar @DB::args; - -{ - local $^P = shift; -} - -@DB::args = (); # At this point, the object should be freed. - -print $^P; -print scalar @DB::args; - -# It shouldn't leak. -EOP - close $fh; - - foreach (0, 1) { - my $got = runperl(progfile => $tmpfile, args => [$_]); - $got =~ s/\s+/ /gs; - like($got, qr/\s*0 1 DESTROY 0 0\s*/, - "\@DB::args doesn't leak with \$^P = $_"); - } -} - -# This also used to leak [perl #97010]: -{ - my $gone; - sub fwib::DESTROY { ++$gone } - package DB; - sub { () = caller(0) }->(); # initialise PL_dbargs - @args = bless[],'fwib'; - sub { () = caller(0) }->(); # clobber @args without initialisation - ::is $gone, 1, 'caller does not leak @DB::args elems when AvREAL'; -} - -$::testing_caller = 1; - -my $caller_file = './op/caller.pl'; -if ( !-e $caller_file ) { - $caller_file = './t/CORE/'.$caller_file; -} - -do "$caller_file" or die $@; diff --git a/t/CORE/op/chars.t b/t/CORE/op/chars.t deleted file mode 100644 index efdea027b..000000000 --- a/t/CORE/op/chars.t +++ /dev/null @@ -1,74 +0,0 @@ -#!./perl - -print "1..33\n"; - -# because of ebcdic.c these should be the same on asciiish -# and ebcdic machines. -# Peter Prymmer . - -my $c = "\c@"; -print +((ord($c) == 0) ? "" : "not "),"ok 1\n"; -$c = "\cA"; -print +((ord($c) == 1) ? "" : "not "),"ok 2\n"; -$c = "\cB"; -print +((ord($c) == 2) ? "" : "not "),"ok 3\n"; -$c = "\cC"; -print +((ord($c) == 3) ? "" : "not "),"ok 4\n"; -$c = "\cD"; -print +((ord($c) == 4) ? "" : "not "),"ok 5\n"; -$c = "\cE"; -print +((ord($c) == 5) ? "" : "not "),"ok 6\n"; -$c = "\cF"; -print +((ord($c) == 6) ? "" : "not "),"ok 7\n"; -$c = "\cG"; -print +((ord($c) == 7) ? "" : "not "),"ok 8\n"; -$c = "\cH"; -print +((ord($c) == 8) ? "" : "not "),"ok 9\n"; -$c = "\cI"; -print +((ord($c) == 9) ? "" : "not "),"ok 10\n"; -$c = "\cJ"; -print +((ord($c) == 10) ? "" : "not "),"ok 11\n"; -$c = "\cK"; -print +((ord($c) == 11) ? "" : "not "),"ok 12\n"; -$c = "\cL"; -print +((ord($c) == 12) ? "" : "not "),"ok 13\n"; -$c = "\cM"; -print +((ord($c) == 13) ? "" : "not "),"ok 14\n"; -$c = "\cN"; -print +((ord($c) == 14) ? "" : "not "),"ok 15\n"; -$c = "\cO"; -print +((ord($c) == 15) ? "" : "not "),"ok 16\n"; -$c = "\cP"; -print +((ord($c) == 16) ? "" : "not "),"ok 17\n"; -$c = "\cQ"; -print +((ord($c) == 17) ? "" : "not "),"ok 18\n"; -$c = "\cR"; -print +((ord($c) == 18) ? "" : "not "),"ok 19\n"; -$c = "\cS"; -print +((ord($c) == 19) ? "" : "not "),"ok 20\n"; -$c = "\cT"; -print +((ord($c) == 20) ? "" : "not "),"ok 21\n"; -$c = "\cU"; -print +((ord($c) == 21) ? "" : "not "),"ok 22\n"; -$c = "\cV"; -print +((ord($c) == 22) ? "" : "not "),"ok 23\n"; -$c = "\cW"; -print +((ord($c) == 23) ? "" : "not "),"ok 24\n"; -$c = "\cX"; -print +((ord($c) == 24) ? "" : "not "),"ok 25\n"; -$c = "\cY"; -print +((ord($c) == 25) ? "" : "not "),"ok 26\n"; -$c = "\cZ"; -print +((ord($c) == 26) ? "" : "not "),"ok 27\n"; -$c = "\c["; -print +((ord($c) == 27) ? "" : "not "),"ok 28\n"; -$c = "\c\\"; -print +((ord($c) == 28) ? "" : "not "),"ok 29\n"; -$c = "\c]"; -print +((ord($c) == 29) ? "" : "not "),"ok 30\n"; -$c = "\c^"; -print +((ord($c) == 30) ? "" : "not "),"ok 31\n"; -$c = "\c_"; -print +((ord($c) == 31) ? "" : "not "),"ok 32\n"; -$c = "\c?"; -print +((ord($c) == 127) ? "" : "not "),"ok 33\n"; diff --git a/t/CORE/op/chdir.t b/t/CORE/op/chdir.t deleted file mode 100644 index 9fab5c89d..000000000 --- a/t/CORE/op/chdir.t +++ /dev/null @@ -1,232 +0,0 @@ -#!./perl -w - -BEGIN { - # We're not going to chdir() into 't' because we don't know if - # chdir() works! Instead, we'll hedge our bets and put both - # possibilities into @INC. - require 't/CORE/test.pl'; - # Really want to know if chdir is working, as the build process will all go - # wrong if it is not. -} - -plan(tests => 48); - -use Config; - -my $IsVMS = $^O eq 'VMS'; - -my $vms_unix_rpt = 0; -my $vms_efs = 0; -if ($IsVMS) { - if (eval 'require VMS::Feature') { - $vms_unix_rpt = VMS::Feature::current("filename_unix_report"); - $vms_efs = VMS::Feature::current("efs_charset"); - } else { - my $unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || ''; - my $efs_charset = $ENV{'DECC$EFS_CHARSET'} || ''; - $vms_unix_rpt = $unix_rpt =~ /^[ET1]/i; - $vms_efs = $efs_charset =~ /^[ET1]/i; - } -} - -# For an op regression test, I don't want to rely on "use constant" working. -my $has_fchdir = ($Config{d_fchdir} || "") eq "define"; - -# Might be a little early in the testing process to start using these, -# but I can't think of a way to write this test without them. -use File::Spec::Functions qw(:DEFAULT splitdir rel2abs splitpath); - -# Can't use Cwd::abs_path() because it has different ideas about -# path separators than File::Spec. -sub abs_path { - my $d = rel2abs(curdir); - $d = lc($d) if $^O =~ /^uwin/; - $d; -} - -my $Cwd = abs_path; - -# Let's get to a known position -SKIP: { - my ($vol,$dir) = splitpath(abs_path,1); - my $test_dir = -d 't/CORE' ? 't/CORE' : '.'; - my $compare_dir = (splitdir($dir))[-1]; - - # VMS is case insensitive but will preserve case in EFS mode. - # So we must normalize the case for the compare. - - $compare_dir = lc($compare_dir) if $IsVMS; - skip("Already in t/", 2) if $compare_dir eq $test_dir; - - ok( chdir($test_dir), 'chdir($test_dir)'); - is( abs_path, catdir($Cwd, $test_dir), ' abs_path() agrees' ); -} - -$Cwd = abs_path; - -SKIP: { - skip("no fchdir", 16) unless $has_fchdir; - my $has_dirfd = ($Config{d_dirfd} || $Config{d_dir_dd_fd} || "") eq "define"; - ok(opendir(my $dh, "."), "opendir ."); - ok(open(my $fh, "<", "op"), "open op"); - ok(chdir($fh), "fchdir op"); - ok(-f "chdir.t", "verify that we are in op"); - if ($has_dirfd) { - ok(chdir($dh), "fchdir back"); - } - else { - eval { chdir($dh); }; - like($@, qr/^The dirfd function is unimplemented at/, "dirfd is unimplemented"); - chdir ".." or die $!; - } - - # same with bareword file handles - no warnings 'once'; - *DH = $dh; - *FH = $fh; - ok(chdir FH, "fchdir op bareword"); - ok(-f "chdir.t", "verify that we are in op"); - if ($has_dirfd) { - ok(chdir DH, "fchdir back bareword"); - } - else { - eval { chdir(DH); }; - like($@, qr/^The dirfd function is unimplemented at/, "dirfd is unimplemented"); - chdir ".." or die $!; - } - ok(-d "op", "verify that we are back"); - - # And now the ambiguous case - { - no warnings qw; - ok(opendir(H, "op"), "opendir op") or diag $!; - # perlcc issue 207 - https://code.google.com/p/perl-compiler/issues/detail?id=207 - ok(open(H, "<", "base"), "open base") or diag $!; - } - if ($has_dirfd) { - ok(chdir(H), "fchdir to op"); - ok(-f "chdir.t", "verify that we are in 'op'"); - chdir ".." or die $!; - } - else { - eval { chdir(H); }; - like($@, qr/^The dirfd function is unimplemented at/, - "dirfd is unimplemented"); - SKIP: { - skip("dirfd is unimplemented"); - } - } - ok(closedir(H), "closedir"); - ok(chdir(H), "fchdir to base"); - ok(-f "cond.t", "verify that we are in 'base'"); - chdir ".." or die $!; -} - -SKIP: { - skip("has fchdir", 1) if $has_fchdir; - opendir(my $dh, "op"); - eval { chdir($dh); }; - like($@, qr/^The fchdir function is unimplemented at/, "fchdir is unimplemented"); -} - -# The environment variables chdir() pays attention to. -my @magic_envs = qw(HOME LOGDIR SYS$LOGIN); - -sub check_env { - my($key) = @_; - - # Make sure $ENV{'SYS$LOGIN'} is only honored on VMS. - if( $key eq 'SYS$LOGIN' && !$IsVMS ) { - ok( !chdir(), "chdir() on $^O ignores only \$ENV{$key} set" ); - is( abs_path, $Cwd, ' abs_path() did not change' ); - pass( " no need to test SYS\$LOGIN on $^O" ) for 1..7; - } - else { - ok( chdir(), "chdir() w/ only \$ENV{$key} set" ); - is( abs_path, $ENV{$key}, ' abs_path() agrees' ); - chdir($Cwd); - is( abs_path, $Cwd, ' and back again' ); - - my $warning = ''; - local $SIG{__WARN__} = sub { $warning .= join '', @_ }; - - - # Check the deprecated chdir(undef) feature. -#line 64 - ok( chdir(undef), "chdir(undef) w/ only \$ENV{$key} set" ); - is( abs_path, $ENV{$key}, ' abs_path() agrees' ); - - my $program_name = $0; - $program_name =~ s/\.bin$/.t/; - $program_name =~ s{^\./}{}; - - is( $warning, < 143; - -$_ = 'abc'; -$c = foo(); -is ($c . $_, 'cab', 'optimized'); - -$_ = 'abc'; -$c = chop($_); -is ($c . $_ , 'cab', 'unoptimized'); - -sub foo { - chop; -} - -@foo = ("hi \n","there\n","!\n"); -@bar = @foo; -chop(@bar); -is (join('',@bar), 'hi there!'); - -$foo = "\n"; -chop($foo,@foo); -is (join('',$foo,@foo), 'hi there!'); - -$_ = "foo\n\n"; -$got = chomp(); -ok ($got == 1) or print "# got $got\n"; -is ($_, "foo\n"); - -$_ = "foo\n"; -$got = chomp(); -ok ($got == 1) or print "# got $got\n"; -is ($_, "foo"); - -$_ = "foo"; -$got = chomp(); -ok ($got == 0) or print "# got $got\n"; -is ($_, "foo"); - -$_ = "foo"; -$/ = "oo"; -$got = chomp(); -ok ($got == 2) or print "# got $got\n"; -is ($_, "f"); - -$_ = "bar"; -$/ = "oo"; -$got = chomp(); -ok ($got == 0) or print "# got $got\n"; -is ($_, "bar"); - -$_ = "f\n\n\n\n\n"; -$/ = ""; -$got = chomp(); -ok ($got == 5) or print "# got $got\n"; -is ($_, "f"); - -$_ = "f\n\n"; -$/ = ""; -$got = chomp(); -ok ($got == 2) or print "# got $got\n"; -is ($_, "f"); - -$_ = "f\n"; -$/ = ""; -$got = chomp(); -ok ($got == 1) or print "# got $got\n"; -is ($_, "f"); - -$_ = "f"; -$/ = ""; -$got = chomp(); -ok ($got == 0) or print "# got $got\n"; -is ($_, "f"); - -$_ = "xx"; -$/ = "xx"; -$got = chomp(); -ok ($got == 2) or print "# got $got\n"; -is ($_, ""); - -$_ = "axx"; -$/ = "xx"; -$got = chomp(); -ok ($got == 2) or print "# got $got\n"; -is ($_, "a"); - -$_ = "axx"; -$/ = "yy"; -$got = chomp(); -ok ($got == 0) or print "# got $got\n"; -is ($_, "axx"); - -# This case once mistakenly behaved like paragraph mode. -$_ = "ab\n"; -$/ = \3; -$got = chomp(); -ok ($got == 0) or print "# got $got\n"; -is ($_, "ab\n"); - -# Go Unicode. - -$_ = "abc\x{1234}"; -chop; -is ($_, "abc", "Go Unicode"); - -$_ = "abc\x{1234}d"; -chop; -is ($_, "abc\x{1234}"); - -$_ = "\x{1234}\x{2345}"; -chop; -is ($_, "\x{1234}"); - -my @stuff = qw(this that); -is (chop(@stuff[0,1]), 't'); - -# bug id 20010305.012 -@stuff = qw(ab cd ef); -is (chop(@stuff = @stuff), 'f'); - -@stuff = qw(ab cd ef); -is (chop(@stuff[0, 2]), 'f'); - -my %stuff = (1..4); -is (chop(@stuff{1, 3}), '4'); - -# chomp should not stringify references unless it decides to modify them -$_ = []; -$/ = "\n"; -$got = chomp(); -ok ($got == 0) or print "# got $got\n"; -is (ref($_), "ARRAY", "chomp ref (modify)"); - -$/ = ")"; # the last char of something like "ARRAY(0x80ff6e4)" -$got = chomp(); -ok ($got == 1) or print "# got $got\n"; -ok (!ref($_), "chomp ref (no modify)"); - -$/ = "\n"; - -%chomp = ("One" => "One", "Two\n" => "Two", "" => ""); -%chop = ("One" => "On", "Two\n" => "Two", "" => ""); - -foreach (keys %chomp) { - my $key = $_; - eval {chomp $_}; - if ($@) { - my $err = $@; - $err =~ s/\n$//s; - fail ("\$\@ = \"$err\""); - } else { - is ($_, $chomp{$key}, "chomp hash key"); - } -} - -foreach (keys %chop) { - my $key = $_; - eval {chop $_}; - if ($@) { - my $err = $@; - $err =~ s/\n$//s; - fail ("\$\@ = \"$err\""); - } else { - is ($_, $chop{$key}, "chop hash key"); - } -} - -# chop and chomp can't be lvalues -eval 'chop($x) = 1;'; -ok($@ =~ /Can\'t modify.*chop.*in.*assignment/); -eval 'chomp($x) = 1;'; -ok($@ =~ /Can\'t modify.*chom?p.*in.*assignment/); -eval 'chop($x, $y) = (1, 2);'; -ok($@ =~ /Can\'t modify.*chop.*in.*assignment/); -eval 'chomp($x, $y) = (1, 2);'; -ok($@ =~ /Can\'t modify.*chom?p.*in.*assignment/); - -my @chars = ("N", latin1_to_native("\xd3"), substr ("\xd4\x{100}", 0, 1), chr 1296); -foreach my $start (@chars) { - foreach my $end (@chars) { - local $/ = $end; - my $message = "start=" . ord ($start) . " end=" . ord $end; - my $string = $start . $end; - is (chomp ($string), 1, "$message [returns 1]"); - is ($string, $start, $message); - - my $end_utf8 = $end; - utf8::encode ($end_utf8); - next if $end_utf8 eq $end; - - # $end ne $end_utf8, so these should not chomp. - $string = $start . $end_utf8; - my $chomped = $string; - is (chomp ($chomped), 0, "$message (end as bytes) [returns 0]"); - is ($chomped, $string, "$message (end as bytes)"); - - $/ = $end_utf8; - $string = $start . $end; - $chomped = $string; - is (chomp ($chomped), 0, "$message (\$/ as bytes) [returns 0]"); - is ($chomped, $string, "$message (\$/ as bytes)"); - } -} - -{ - # returns length in characters, but not in bytes. - $/ = "\x{100}"; - $a = "A$/"; - $b = chomp $a; - is ($b, 1); - - $/ = "\x{100}\x{101}"; - $a = "A$/"; - $b = chomp $a; - is ($b, 2); -} - -{ - # [perl #36569] chop fails on decoded string with trailing nul - my $asc = "perl\0"; - my $utf = "perl".pack('U',0); # marked as utf8 - is(chop($asc), "\0", "chopping ascii NUL"); - is(chop($utf), "\0", "chopping utf8 NUL"); - is($asc, "perl", "chopped ascii NUL"); - is($utf, "perl", "chopped utf8 NUL"); -} - -{ - # Change 26011: Re: A surprising segfault - # to make sure only that these obfuscated sentences will not crash. - - map chop(+()), ('')x68; - ok(1, "extend sp in pp_chop"); - - map chomp(+()), ('')x68; - ok(1, "extend sp in pp_chomp"); -} - -{ - # [perl #73246] chop doesn't support utf8 - # the problem was UTF8_IS_START() didn't handle perl's extended UTF8 - my $utf = "\x{80000001}\x{80000000}"; - my $result = chop($utf); - is($utf, "\x{80000001}", "chopping high 'unicode'- remnant"); - is($result, "\x{80000000}", "chopping high 'unicode' - result"); - - SKIP: { - no warnings 'overflow'; # avoid compile-time warnings below on 32-bit architectures - use Config; - $Config{ivsize} >= 8 - or skip("this build can't handle very large characters", 2); - my $utf = "\x{ffffffffffffffff}\x{fffffffffffffffe}"; - my $result = chop $utf; - is($utf, "\x{ffffffffffffffff}", "chop even higher 'unicode' - remnant"); - is($result, "\x{fffffffffffffffe}", "chop even higher 'unicode' - result"); - } -} diff --git a/t/CORE/op/chr.t b/t/CORE/op/chr.t deleted file mode 100644 index 97829f3f1..000000000 --- a/t/CORE/op/chr.t +++ /dev/null @@ -1,64 +0,0 @@ -#!./perl - -BEGIN { - unshift @INC, "./lib"; - require 't/CORE/test.pl'; -} - -plan tests => 34; - -# Note that t/op/ord.t already tests for chr() <-> ord() rountripping. - -# Don't assume ASCII. - -is(chr(ord("A")), "A"); - -is(chr( 0), "\x00"); -is(chr(127), "\x7F"); -is(chr(128), "\x80"); -is(chr(255), "\xFF"); - -is(chr(-0.1), "\x{FFFD}"); # The U+FFFD Unicode replacement character. -is(chr(-1 ), "\x{FFFD}"); -is(chr(-2 ), "\x{FFFD}"); -is(chr(-3.0), "\x{FFFD}"); -{ - use bytes; # Backward compatibility. - is(chr(-0.1), "\x00"); - is(chr(-1 ), "\xFF"); - is(chr(-2 ), "\xFE"); - is(chr(-3.0), "\xFD"); -} - -# Check UTF-8 (not UTF-EBCDIC). -SKIP: { - skip "no UTF-8 on EBCDIC", 21 if chr(193) eq 'A'; - -sub hexes { - no warnings 'utf8'; # avoid surrogate and beyond Unicode warnings - join(" ",unpack "U0 (H2)*", chr $_[0]); -} - -# The following code points are some interesting steps in UTF-8. - is(hexes( 0x100), "c4 80"); - is(hexes( 0x7FF), "df bf"); - is(hexes( 0x800), "e0 a0 80"); - is(hexes( 0xFFF), "e0 bf bf"); - is(hexes( 0x1000), "e1 80 80"); - is(hexes( 0xCFFF), "ec bf bf"); - is(hexes( 0xD000), "ed 80 80"); - is(hexes( 0xD7FF), "ed 9f bf"); - is(hexes( 0xD800), "ed a0 80"); # not strict utf-8 (surrogate area begin) - is(hexes( 0xDFFF), "ed bf bf"); # not strict utf-8 (surrogate area end) - is(hexes( 0xE000), "ee 80 80"); - is(hexes( 0xFFFF), "ef bf bf"); - is(hexes( 0x10000), "f0 90 80 80"); - is(hexes( 0x3FFFF), "f0 bf bf bf"); - is(hexes( 0x40000), "f1 80 80 80"); - is(hexes( 0xFFFFF), "f3 bf bf bf"); - is(hexes(0x100000), "f4 80 80 80"); - is(hexes(0x10FFFF), "f4 8f bf bf"); # Unicode (4.1) last code point - is(hexes(0x110000), "f4 90 80 80"); - is(hexes(0x1FFFFF), "f7 bf bf bf"); # last four byte encoding - is(hexes(0x200000), "f8 88 80 80 80"); -} diff --git a/t/CORE/op/closure.t b/t/CORE/op/closure.t deleted file mode 100644 index 36ee2f15c..000000000 --- a/t/CORE/op/closure.t +++ /dev/null @@ -1,691 +0,0 @@ -#!./perl -# -*- Mode: Perl -*- -# closure.t: -# Original written by Ulrich Pfeifer on 2 Jan 1997. -# Greatly extended by Tom Phoenix on 28 Jan 1997. -# -# Run with -debug for debugging output. - -BEGIN { - require 't/CORE/test.pl'; -} - -use Config; - -my $i = 1; -sub foo { $i = shift if @_; $i } - -# no closure -is(foo, 1); -foo(2); -is(foo, 2); - -# closure: lexical outside sub -my $foo = sub {$i = shift if @_; $i }; -my $bar = sub {$i = shift if @_; $i }; -is(&$foo(), 2); -&$foo(3); -is(&$foo(), 3); -# did the lexical change? -is(foo, 3, 'lexical changed'); -is($i, 3, 'lexical changed'); -# did the second closure notice? -is(&$bar(), 3, 'second closure noticed'); - -# closure: lexical inside sub -sub bar { - my $i = shift; - sub { $i = shift if @_; $i } -} - -$foo = bar(4); -$bar = bar(5); -is(&$foo(), 4); -&$foo(6); -is(&$foo(), 6); -is(&$bar(), 5); - -# nested closures -sub bizz { - my $i = 7; - if (@_) { - my $i = shift; - sub {$i = shift if @_; $i }; - } else { - my $i = $i; - sub {$i = shift if @_; $i }; - } -} -$foo = bizz(); -$bar = bizz(); -is(&$foo(), 7); -&$foo(8); -is(&$foo(), 8); -is(&$bar(), 7); - -$foo = bizz(9); -$bar = bizz(10); -is(&$foo(11)-1, &$bar()); - -my @foo; -for (qw(0 1 2 3 4)) { - my $i = $_; - $foo[$_] = sub {$i = shift if @_; $i }; -} - -is(&{$foo[0]}(), 0); -is(&{$foo[1]}(), 1); -is(&{$foo[2]}(), 2); -is(&{$foo[3]}(), 3); -is(&{$foo[4]}(), 4); - -for (0 .. 4) { - &{$foo[$_]}(4-$_); -} - -is(&{$foo[0]}(), 4); -is(&{$foo[1]}(), 3); -is(&{$foo[2]}(), 2); -is(&{$foo[3]}(), 1); -is(&{$foo[4]}(), 0); - -sub barf { - my @foo; - for (qw(0 1 2 3 4)) { - my $i = $_; - $foo[$_] = sub {$i = shift if @_; $i }; - } - @foo; -} - -@foo = barf(); -is(&{$foo[0]}(), 0); -is(&{$foo[1]}(), 1); -is(&{$foo[2]}(), 2); -is(&{$foo[3]}(), 3); -is(&{$foo[4]}(), 4); - -for (0 .. 4) { - &{$foo[$_]}(4-$_); -} - -is(&{$foo[0]}(), 4); -is(&{$foo[1]}(), 3); -is(&{$foo[2]}(), 2); -is(&{$foo[3]}(), 1); -is(&{$foo[4]}(), 0); - -# test if closures get created in optimized for loops - -my %foo; -for my $n ('A'..'E') { - $foo{$n} = sub { $n eq $_[0] }; -} - -ok(&{$foo{A}}('A')); -ok(&{$foo{B}}('B')); -ok(&{$foo{C}}('C')); -ok(&{$foo{D}}('D')); -ok(&{$foo{E}}('E')); - -for my $n (0..4) { - $foo[$n] = sub { $n == $_[0] }; -} - -ok(&{$foo[0]}(0)); -ok(&{$foo[1]}(1)); -ok(&{$foo[2]}(2)); -ok(&{$foo[3]}(3)); -ok(&{$foo[4]}(4)); - -for my $n (0..4) { - $foo[$n] = sub { - # no intervening reference to $n here - sub { $n == $_[0] } - }; -} - -ok($foo[0]->()->(0)); -ok($foo[1]->()->(1)); -ok($foo[2]->()->(2)); -ok($foo[3]->()->(3)); -ok($foo[4]->()->(4)); - -{ - my $w; - $w = sub { - my ($i) = @_; - is($i, 10); - sub { $w }; - }; - $w->(10); -} - -# Additional tests by Tom Phoenix . - -{ - use strict; - - use vars qw!$test!; - my($debugging, %expected, $inner_type, $where_declared, $within); - my($nc_attempt, $call_outer, $call_inner, $undef_outer); - my($code, $inner_sub_test, $expected, $line, $errors, $output); - my(@inners, $sub_test, $pid); - $debugging = 1 if defined($ARGV[0]) and $ARGV[0] eq '-debug'; - - # The expected values for these tests - %expected = ( - 'global_scalar' => 1001, - 'global_array' => 2101, - 'global_hash' => 3004, - 'fs_scalar' => 4001, - 'fs_array' => 5101, - 'fs_hash' => 6004, - 'sub_scalar' => 7001, - 'sub_array' => 8101, - 'sub_hash' => 9004, - 'foreach' => 10011, - ); - - # Our innermost sub is either named or anonymous - for $inner_type (qw!named anon!) { - # And it may be declared at filescope, within a named - # sub, or within an anon sub - for $where_declared (qw!filescope in_named in_anon!) { - # And that, in turn, may be within a foreach loop, - # a naked block, or another named sub - for $within (qw!foreach naked other_sub!) { - - my $test = curr_test(); - # Here are a number of variables which show what's - # going on, in a way. - $nc_attempt = 0+ # Named closure attempted - ( ($inner_type eq 'named') || - ($within eq 'other_sub') ) ; - $call_inner = 0+ # Need to call &inner - ( ($inner_type eq 'anon') && - ($within eq 'other_sub') ) ; - $call_outer = 0+ # Need to call &outer or &$outer - ( ($inner_type eq 'anon') && - ($within ne 'other_sub') ) ; - $undef_outer = 0+ # $outer is created but unused - ( ($where_declared eq 'in_anon') && - (not $call_outer) ) ; - - $code = "# This is a test script built by t/op/closure.t\n\n"; - - print <<"DEBUG_INFO" if $debugging; -# inner_type: $inner_type -# where_declared: $where_declared -# within: $within -# nc_attempt: $nc_attempt -# call_inner: $call_inner -# call_outer: $call_outer -# undef_outer: $undef_outer -DEBUG_INFO - - $code .= <<"END_MARK_ONE"; - -BEGIN { \$SIG{__WARN__} = sub { - my \$msg = \$_[0]; -END_MARK_ONE - - $code .= <<"END_MARK_TWO" if $nc_attempt; - return if index(\$msg, 'will not stay shared') != -1; - return if index(\$msg, 'is not available') != -1; -END_MARK_TWO - - $code .= <<"END_MARK_THREE"; # Backwhack a lot! - print "not ok: got unexpected warning \$msg\\n"; -} } - -require 't/CORE/test.pl'; -curr_test($test); - -# some of the variables which the closure will access -\$global_scalar = 1000; -\@global_array = (2000, 2100, 2200, 2300); -%global_hash = 3000..3009; - -my \$fs_scalar = 4000; -my \@fs_array = (5000, 5100, 5200, 5300); -my %fs_hash = 6000..6009; - -END_MARK_THREE - - if ($where_declared eq 'filescope') { - # Nothing here - } elsif ($where_declared eq 'in_named') { - $code .= <<'END'; -sub outer { - my $sub_scalar = 7000; - my @sub_array = (8000, 8100, 8200, 8300); - my %sub_hash = 9000..9009; -END - # } - } elsif ($where_declared eq 'in_anon') { - $code .= <<'END'; -$outer = sub { - my $sub_scalar = 7000; - my @sub_array = (8000, 8100, 8200, 8300); - my %sub_hash = 9000..9009; -END - # } - } else { - die "What was $where_declared?" - } - - if ($within eq 'foreach') { - $code .= " - my \$foreach = 12000; - my \@list = (10000, 10010); - foreach \$foreach (\@list) { - " # } - } elsif ($within eq 'naked') { - $code .= " { # naked block\n" # } - } elsif ($within eq 'other_sub') { - $code .= " sub inner_sub {\n" # } - } else { - die "What was $within?" - } - - $sub_test = $test; - @inners = ( qw!global_scalar global_array global_hash! , - qw!fs_scalar fs_array fs_hash! ); - push @inners, 'foreach' if $within eq 'foreach'; - if ($where_declared ne 'filescope') { - push @inners, qw!sub_scalar sub_array sub_hash!; - } - for $inner_sub_test (@inners) { - - if ($inner_type eq 'named') { - $code .= " sub named_$sub_test " - } elsif ($inner_type eq 'anon') { - $code .= " \$anon_$sub_test = sub " - } else { - die "What was $inner_type?" - } - - # Now to write the body of the test sub - if ($inner_sub_test eq 'global_scalar') { - $code .= '{ ++$global_scalar }' - } elsif ($inner_sub_test eq 'fs_scalar') { - $code .= '{ ++$fs_scalar }' - } elsif ($inner_sub_test eq 'sub_scalar') { - $code .= '{ ++$sub_scalar }' - } elsif ($inner_sub_test eq 'global_array') { - $code .= '{ ++$global_array[1] }' - } elsif ($inner_sub_test eq 'fs_array') { - $code .= '{ ++$fs_array[1] }' - } elsif ($inner_sub_test eq 'sub_array') { - $code .= '{ ++$sub_array[1] }' - } elsif ($inner_sub_test eq 'global_hash') { - $code .= '{ ++$global_hash{3002} }' - } elsif ($inner_sub_test eq 'fs_hash') { - $code .= '{ ++$fs_hash{6002} }' - } elsif ($inner_sub_test eq 'sub_hash') { - $code .= '{ ++$sub_hash{9002} }' - } elsif ($inner_sub_test eq 'foreach') { - $code .= '{ ++$foreach }' - } else { - die "What was $inner_sub_test?" - } - - # Close up - if ($inner_type eq 'anon') { - $code .= ';' - } - $code .= "\n"; - $sub_test++; # sub name sequence number - - } # End of foreach $inner_sub_test - - # Close up $within block # { - $code .= " }\n\n"; - - # Close up $where_declared block - if ($where_declared eq 'in_named') { # { - $code .= "}\n\n"; - } elsif ($where_declared eq 'in_anon') { # { - $code .= "};\n\n"; - } - - # We may need to do something with the sub we just made... - $code .= "undef \$outer;\n" if $undef_outer; - $code .= "&inner_sub;\n" if $call_inner; - if ($call_outer) { - if ($where_declared eq 'in_named') { - $code .= "&outer;\n\n"; - } elsif ($where_declared eq 'in_anon') { - $code .= "&\$outer;\n\n" - } - } - - # Now, we can actually prep to run the tests. - for $inner_sub_test (@inners) { - $expected = $expected{$inner_sub_test} or - die "expected $inner_sub_test missing"; - - # Named closures won't access the expected vars - if ( $nc_attempt and - substr($inner_sub_test, 0, 4) eq "sub_" ) { - $expected = 1; - } - - # If you make a sub within a foreach loop, - # what happens if it tries to access the - # foreach index variable? If it's a named - # sub, it gets the var from "outside" the loop, - # but if it's anon, it gets the value to which - # the index variable is aliased. - # - # Of course, if the value was set only - # within another sub which was never called, - # the value has not been set yet. - # - if ($inner_sub_test eq 'foreach') { - if ($inner_type eq 'named') { - if ($call_outer || ($where_declared eq 'filescope')) { - $expected = 12001 - } else { - $expected = 1 - } - } - } - - # Here's the test: - my $desc = "$inner_type $where_declared $within $inner_sub_test"; - if ($inner_type eq 'anon') { - $code .= "is(&\$anon_$test, $expected, '$desc');\n" - } else { - $code .= "is(&named_$test, $expected, '$desc');\n" - } - $test++; - } - - if ($Config{d_fork} and $^O ne 'VMS' and $^O ne 'MSWin32' and $^O ne 'NetWare') { - # Fork off a new perl to run the tests. - # (This is so we can catch spurious warnings.) - $| = 1; print ""; $| = 0; # flush output before forking - pipe READ, WRITE or die "Can't make pipe: $!"; - pipe READ2, WRITE2 or die "Can't make second pipe: $!"; - die "Can't fork: $!" unless defined($pid = open PERL, "|-"); - unless ($pid) { - # Child process here. We're going to send errors back - # through the extra pipe. - close READ; - close READ2; - open STDOUT, ">&WRITE" or die "Can't redirect STDOUT: $!"; - open STDERR, ">&WRITE2" or die "Can't redirect STDERR: $!"; - exec which_perl(), '-w', '-' - or die "Can't exec perl: $!"; - } else { - # Parent process here. - close WRITE; - close WRITE2; - print PERL $code; - close PERL; - { local $/; - $output = join '', ; - $errors = join '', ; } - close READ; - close READ2; - } - } else { - # No fork(). Do it the hard way. - my $cmdfile = tempfile(); - my $errfile = tempfile(); - open CMD, ">$cmdfile"; print CMD $code; close CMD; - my $cmd = which_perl(); - $cmd .= " -w $cmdfile 2>$errfile"; - if ($^O eq 'VMS' or $^O eq 'MSWin32' or $^O eq 'NetWare') { - # Use pipe instead of system so we don't inherit STD* from - # this process, and then foul our pipe back to parent by - # redirecting output in the child. - open PERL,"$cmd |" or die "Can't open pipe: $!\n"; - { local $/; $output = join '', } - close PERL; - } else { - my $outfile = tempfile(); - system "$cmd >$outfile"; - { local $/; open IN, $outfile; $output = ; close IN } - } - if ($?) { - printf "not ok: exited with error code %04X\n", $?; - exit; - } - { local $/; open IN, $errfile; $errors = ; close IN } - } - print $output; - curr_test($test); - print STDERR $errors; - # This has the side effect of alerting *our* test.pl to the state of - # what has just been passed to STDOUT, so that if anything there has - # failed, our test.pl will print a diagnostic and exit uncleanly. - unlike($output, qr/not ok/, 'All good'); - is($errors, '', 'STDERR is silent'); - if ($debugging && ($errors || $? || ($output =~ /not ok/))) { - my $lnum = 0; - for $line (split '\n', $code) { - printf "%3d: %s\n", ++$lnum, $line; - } - } - is($?, 0, 'exited cleanly') or diag(sprintf "Error code $? = 0x%X", $?); - print '#', "-" x 30, "\n" if $debugging; - - } # End of foreach $within - } # End of foreach $where_declared - } # End of foreach $inner_type - -} - -# The following dumps core with perl <= 5.8.0 (bugid 9535) ... -BEGIN { $vanishing_pad = sub { eval $_[0] } } -$some_var = 123; -is($vanishing_pad->('$some_var'), 123, 'RT #9535'); - -# ... and here's another coredump variant - this time we explicitly -# delete the sub rather than using a BEGIN ... - -sub deleteme { $a = sub { eval '$newvar' } } -deleteme(); -*deleteme = sub {}; # delete the sub -$newvar = 123; # realloc the SV of the freed CV -is($a->(), 123, 'RT #9535'); - -# ... and a further coredump variant - the fixup of the anon sub's -# CvOUTSIDE pointer when the middle eval is freed, wasn't good enough to -# survive the outer eval also being freed. - -$x = 123; -$a = eval q( - eval q[ - sub { eval '$x' } - ] -); -@a = ('\1\1\1\1\1\1\1') x 100; # realloc recently-freed CVs -is($a->(), 123, 'RT #9535'); - -# this coredumped on <= 5.8.0 because evaling the closure caused -# an SvFAKE to be added to the outer anon's pad, which was then grown. -my $outer; -sub { - my $x; - $x = eval 'sub { $outer }'; - $x->(); - $a = [ 99 ]; - $x->(); -}->(); -pass(); - -# [perl #17605] found that an empty block called in scalar context -# can lead to stack corruption -{ - my $x = "foooobar"; - $x =~ s/o//eg; - is($x, 'fbar', 'RT #17605'); -} - -# DAPM 24-Nov-02 -# SvFAKE lexicals should be visible thoughout a function. -# On <= 5.8.0, the third test failed, eg bugid #18286 - -{ - my $x = 1; - sub fake { - is(sub {eval'$x'}->(), 1, 'RT #18286'); - { $x; is(sub {eval'$x'}->(), 1, 'RT #18286'); } - is(sub {eval'$x'}->(), 1, 'RT #18286'); - } -} -fake(); - -{ - $x = 1; - my $x = 2; - sub tmp { sub { eval '$x' } } - my $a = tmp(); - undef &tmp; - is($a->(), 2, - "undefining a sub shouldn't alter visibility of outer lexicals"); -} - -# handy class: $x = Watch->new(\$foo,'bar') -# causes 'bar' to be appended to $foo when $x is destroyed -sub Watch::new { bless [ $_[1], $_[2] ], $_[0] } -sub Watch::DESTROY { ${$_[0][0]} .= $_[0][1] } - -# bugid 1028: -# nested anon subs (and associated lexicals) not freed early enough - -sub linger { - my $x = Watch->new($_[0], '2'); - sub { - $x; - my $y; - sub { $y; }; - }; -} -{ - my $watch = '1'; - linger(\$watch); - is($watch, '12', 'RT #1028'); -} - -# bugid 10085 -# obj not freed early enough - -sub linger2 { - my $obj = Watch->new($_[0], '2'); - sub { sub { $obj } }; -} -{ - my $watch = '1'; - linger2(\$watch); - is($watch, 12, 'RT #10085'); -} - -# bugid 16302 - named subs didn't capture lexicals on behalf of inner subs - -{ - my $x = 1; - sub f16302 { - sub { - is($x, 1, 'RT #16302'); - }->(); - } -} -f16302(); - -# The presence of an eval should turn cloneless anon subs into clonable -# subs - otherwise the CvOUTSIDE of that sub may be wrong - -{ - my %a; - for my $x (7,11) { - $a{$x} = sub { $x=$x; sub { eval '$x' } }; - } - is($a{7}->()->() + $a{11}->()->(), 18); -} - -{ - # bugid #23265 - this used to coredump during destruction of PL_maincv - # and its children - - fresh_perl_is(<< '__EOF__', "yxx\n", {stderr => 1}, 'RT #23265'); - print - sub {$_[0]->(@_)} -> ( - sub { - $_[1] - ? $_[0]->($_[0], $_[1] - 1) . sub {"x"}->() - : "y" - }, - 2 - ) - , "\n" - ; -__EOF__ -} - -{ - # bugid #24914 = used to coredump restoring PL_comppad in the - # savestack, due to the early freeing of the anon closure - - fresh_perl_is('sub d {die} my $f; $f = sub {my $x=1; $f = 0; d}; eval{$f->()}; print qq(ok\n)', - "ok\n", {stderr => 1}, 'RT #24914'); -} - - -# After newsub is redefined outside the BEGIN, its CvOUTSIDE should point -# to main rather than BEGIN, and BEGIN should be freed. - -# perl bug #163 https://code.google.com/p/perl-compiler/issues/detail?id=163 -# wontfix for perlcc as the DESTROY will not be called for compile-time -# declarations in the same phase -{ - my $flag = 0; - sub X::DESTROY { $flag = 1 } - { - my $x; - BEGIN {$x = \&newsub } - sub newsub {}; - $x = bless {}, 'X'; - } - if (is_perlcc_compiled()) { - is($flag, 0, "compile-time redefined sub does not call DESTROY with perlcc"); - } else { - is($flag, 1, "redefined sub calls DESTROY"); - } -} - -sub f { - my $x if $_[0]; - sub { \$x } -} - -{ - f(1); - my $c1= f(0); - my $c2= f(0); - - my $r1 = $c1->(); - my $r2 = $c2->(); - isnt($r1, $r2, - "don't copy a stale lexical; crate a fresh undef one instead"); -} - -# [perl #63540] Don’t treat sub { if(){.....}; "constant" } as a constant - -BEGIN { - my $x = 7; - *baz = sub() { if($x){ () = "tralala"; blonk() }; 0 } -} -{ - my $blonk_was_called; - *blonk = sub { ++$blonk_was_called }; - my $ret = baz(); - is($ret, 0, 'RT #63540'); - is($blonk_was_called, 1, 'RT #63540'); -} - -done_testing(); diff --git a/t/CORE/op/cmp.t b/t/CORE/op/cmp.t deleted file mode 100644 index 39875b79a..000000000 --- a/t/CORE/op/cmp.t +++ /dev/null @@ -1,317 +0,0 @@ -#!./perl - -BEGIN { - unshift @INC, 't/CORE/lib'; -} - -# 2s complement assumption. Won't break test, just makes the internals of -# the SVs less interesting if were not on 2s complement system. -my $uv_max = ~0; -my $uv_maxm1 = ~0 ^ 1; -my $uv_big = $uv_max; -$uv_big = ($uv_big - 20000) | 1; -my ($iv0, $iv1, $ivm1, $iv_min, $iv_max, $iv_big, $iv_small); -$iv_max = $uv_max; # Do copy, *then* divide -$iv_max /= 2; -$iv_min = $iv_max; -{ - use integer; - $iv0 = 2 - 2; - $iv1 = 3 - 2; - $ivm1 = 2 - 3; - $iv_max -= 1; - $iv_min += 0; - $iv_big = $iv_max - 3; - $iv_small = $iv_min + 2; -} -my $uv_bigi = $iv_big; -$uv_bigi |= 0x0; - -my @array = qw(perl rules); - -my @raw, @upgraded, @utf8; -foreach ("\x{1F4A9}", chr(163), 'N') { - push @raw, $_; - my $temp = $_ . chr 256; - chop $temp; - push @upgraded, $temp; - my $utf8 = $_; - next if utf8::upgrade($utf8) == length $_; - utf8::encode($utf8); - push @utf8, $utf8; -} - -# Seems one needs to perform the maths on 'Inf' to get the NV correctly primed. -@FOO = ('s', 'N/A', 'a', 'NaN', -1, undef, 0, 1, 3.14, 1e37, 0.632120558, -.5, - 'Inf'+1, '-Inf'-1, 0x0, 0x1, 0x5, 0xFFFFFFFF, $uv_max, $uv_maxm1, - $uv_big, $uv_bigi, $iv0, $iv1, $ivm1, $iv_min, $iv_max, $iv_big, - $iv_small, \$array[0], \$array[0], \$array[1], \$^X, @raw, @upgraded, - @utf8); - -$expect = 7 * ($#FOO+2) * ($#FOO+1) + 6 * @raw + 6 * @utf8; -print "1..$expect\n"; - -my $bad_NaN = 0; - -{ - # gcc's -ffast-math option may stop NaNs working correctly - use Config; - my $ccflags = $Config{ccflags} // ''; - $bad_NaN = 1 if $ccflags =~ /-ffast-math\b/; -} - -sub nok ($$$$$$$$) { - my ($test, $left, $threeway, $right, $result, $i, $j, $boolean) = @_; - $result = defined $result ? "'$result'" : 'undef'; - if ($bad_NaN && ($left eq 'NaN' || $right eq 'NaN')) { - print "ok $test # skipping failed NaN test under -ffast-math\n"; - } - else { - print "not ok $test # ($left $threeway $right) gives: $result \$i=$i \$j=$j, $boolean disagrees\n"; - } -} - -my $ok = 0; -for my $i (0..$#FOO) { - for my $j ($i..$#FOO) { - $ok++; - # Comparison routines may convert these internally, which would change - # what is used to determine the comparison on later runs. Hence copy - my ($i1, $i2, $i3, $i4, $i5, $i6, $i7, $i8, $i9, $i10, - $i11, $i12, $i13, $i14, $i15, $i16, $i17) = - ($FOO[$i], $FOO[$i], $FOO[$i], $FOO[$i], $FOO[$i], $FOO[$i], - $FOO[$i], $FOO[$i], $FOO[$i], $FOO[$i], $FOO[$i], $FOO[$i], - $FOO[$i], $FOO[$i], $FOO[$i], $FOO[$i], $FOO[$i]); - my ($j1, $j2, $j3, $j4, $j5, $j6, $j7, $j8, $j9, $j10, - $j11, $j12, $j13, $j14, $j15, $j16, $j17) = - ($FOO[$j], $FOO[$j], $FOO[$j], $FOO[$j], $FOO[$j], $FOO[$j], - $FOO[$j], $FOO[$j], $FOO[$j], $FOO[$j], $FOO[$j], $FOO[$j], - $FOO[$j], $FOO[$j], $FOO[$j], $FOO[$j], $FOO[$j]); - my $cmp = $i1 <=> $j1; - if (!defined($cmp) ? !($i2 < $j2) - : ($cmp == -1 && $i2 < $j2 || - $cmp == 0 && !($i2 < $j2) || - $cmp == 1 && !($i2 < $j2))) - { - print "ok $ok\n"; - } - else { - nok ($ok, $i3, '<=>', $j3, $cmp, $i, $j, '<'); - } - $ok++; - if (!defined($cmp) ? !($i4 == $j4) - : ($cmp == -1 && !($i4 == $j4) || - $cmp == 0 && $i4 == $j4 || - $cmp == 1 && !($i4 == $j4))) - { - print "ok $ok\n"; - } - else { - nok ($ok, $i3, '<=>', $j3, $cmp, $i, $j, '=='); - } - $ok++; - if (!defined($cmp) ? !($i5 > $j5) - : ($cmp == -1 && !($i5 > $j5) || - $cmp == 0 && !($i5 > $j5) || - $cmp == 1 && ($i5 > $j5))) - { - print "ok $ok\n"; - } - else { - nok ($ok, $i3, '<=>', $j3, $cmp, $i, $j, '>'); - } - $ok++; - if (!defined($cmp) ? !($i6 >= $j6) - : ($cmp == -1 && !($i6 >= $j6) || - $cmp == 0 && $i6 >= $j6 || - $cmp == 1 && $i6 >= $j6)) - { - print "ok $ok\n"; - } - else { - nok ($ok, $i3, '<=>', $j3, $cmp, $i, $j, '>='); - } - $ok++; - # OK, so the docs are wrong it seems. NaN != NaN - if (!defined($cmp) ? ($i7 != $j7) - : ($cmp == -1 && $i7 != $j7 || - $cmp == 0 && !($i7 != $j7) || - $cmp == 1 && $i7 != $j7)) - { - print "ok $ok\n"; - } - else { - nok ($ok, $i3, '<=>', $j3, $cmp, $i, $j, '!='); - } - $ok++; - if (!defined($cmp) ? !($i8 <= $j8) - : ($cmp == -1 && $i8 <= $j8 || - $cmp == 0 && $i8 <= $j8 || - $cmp == 1 && !($i8 <= $j8))) - { - print "ok $ok\n"; - } - else { - nok ($ok, $i3, '<=>', $j3, $cmp, $i, $j, '<='); - } - $ok++; - my $pmc = $j16 <=> $i16; # cmp it in reverse - # Should give -ve of other answer, or undef for NaNs - # a + -a should be zero. not zero is truth. which avoids using == - if (defined($cmp) ? !($cmp + $pmc) : !defined $pmc) - { - print "ok $ok\n"; - } - else { - nok ($ok, $i3, '<=>', $j3, $cmp, $i, $j, '<=> transposed'); - } - - - # String comparisons - $ok++; - $cmp = $i9 cmp $j9; - if ($cmp == -1 && $i10 lt $j10 || - $cmp == 0 && !($i10 lt $j10) || - $cmp == 1 && !($i10 lt $j10)) - { - print "ok $ok\n"; - } - else { - nok ($ok, $i3, 'cmp', $j3, $cmp, $i, $j, 'lt'); - } - $ok++; - if ($cmp == -1 && !($i11 eq $j11) || - $cmp == 0 && ($i11 eq $j11) || - $cmp == 1 && !($i11 eq $j11)) - { - print "ok $ok\n"; - } - else { - nok ($ok, $i3, 'cmp', $j3, $cmp, $i, $j, 'eq'); - } - $ok++; - if ($cmp == -1 && !($i12 gt $j12) || - $cmp == 0 && !($i12 gt $j12) || - $cmp == 1 && ($i12 gt $j12)) - { - print "ok $ok\n"; - } - else { - nok ($ok, $i3, 'cmp', $j3, $cmp, $i, $j, 'gt'); - } - $ok++; - if ($cmp == -1 && $i13 le $j13 || - $cmp == 0 && ($i13 le $j13) || - $cmp == 1 && !($i13 le $j13)) - { - print "ok $ok\n"; - } - else { - nok ($ok, $i3, 'cmp', $j3, $cmp, $i, $j, 'le'); - } - $ok++; - if ($cmp == -1 && ($i14 ne $j14) || - $cmp == 0 && !($i14 ne $j14) || - $cmp == 1 && ($i14 ne $j14)) - { - print "ok $ok\n"; - } - else { - nok ($ok, $i3, 'cmp', $j3, $cmp, $i, $j, 'ne'); - } - $ok++; - if ($cmp == -1 && !($i15 ge $j15) || - $cmp == 0 && ($i15 ge $j15) || - $cmp == 1 && ($i15 ge $j15)) - { - print "ok $ok\n"; - } - else { - nok ($ok, $i3, 'cmp', $j3, $cmp, $i, $j, 'ge'); - } - $ok++; - $pmc = $j17 cmp $i17; # cmp it in reverse - # Should give -ve of other answer - # a + -a should be zero. not zero is truth. which avoids using == - if (!($cmp + $pmc)) - { - print "ok $ok\n"; - } - else { - nok ($ok, $i3, 'cmp', $j3, $cmp, $i, $j, 'cmp transposed'); - } - } -} - -# We know the answers for these. We can rely on the consistency checks above -# to test the other string comparisons. - -while (my ($i, $v) = each @raw) { - # Copy, to avoid any inadvertent conversion - my ($raw, $cooked, $not); - $raw = $v; - $cooked = $upgraded[$i]; - $not = $raw eq $cooked ? '' : 'not '; - printf "%sok %d # eq, chr %d\n", $not, ++$ok, ord $raw; - - $raw = $v; - $cooked = $upgraded[$i]; - $not = $raw ne $cooked ? 'not ' : ''; - printf "%sok %d # ne, chr %d\n", $not, ++$ok, ord $raw; - - $raw = $v; - $cooked = $upgraded[$i]; - $not = (($raw cmp $cooked) == 0) ? '' : 'not '; - printf "%sok %d # cmp, chr %d\n", $not, ++$ok, ord $raw; - - # And now, transposed. - $raw = $v; - $cooked = $upgraded[$i]; - $not = $cooked eq $raw ? '' : 'not '; - printf "%sok %d # eq, chr %d\n", $not, ++$ok, ord $raw; - - $raw = $v; - $cooked = $upgraded[$i]; - $not = $cooked ne $raw ? 'not ' : ''; - printf "%sok %d # ne, chr %d\n", $not, ++$ok, ord $raw; - - $raw = $v; - $cooked = $upgraded[$i]; - $not = (($cooked cmp $raw) == 0) ? '' : 'not '; - printf "%sok %d # cmp, chr %d\n", $not, ++$ok, ord $raw; -} - -while (my ($i, $v) = each @utf8) { - # Copy, to avoid any inadvertent conversion - my ($raw, $cooked, $not); - $raw = $raw[$i]; - $cooked = $v; - $not = $raw eq $cooked ? 'not ' : ''; - printf "%sok %d # eq vs octets, chr %d\n", $not, ++$ok, ord $raw; - - $raw = $raw[$i]; - $cooked = $v; - $not = $raw ne $cooked ? '' : 'not '; - printf "%sok %d # ne vs octets, chr %d\n", $not, ++$ok, ord $raw; - - $raw = $raw[$i]; - $cooked = $v; - $not = (($raw cmp $cooked) == 0) ? 'not ' : ''; - printf "%sok %d # cmp vs octects, chr %d\n", $not, ++$ok, ord $raw; - - # And now, transposed. - $raw = $raw[$i]; - $cooked = $v; - $not = $cooked eq $raw ? 'not ' : ''; - printf "%sok %d # eq vs octets, chr %d\n", $not, ++$ok, ord $raw; - - $raw = $raw[$i]; - $cooked = $v; - $not = $cooked ne $raw? '' : 'not '; - printf "%sok %d # ne vs octets, chr %d\n", $not, ++$ok, ord $raw; - - $raw = $raw[$i]; - $cooked = $v; - $not = (($cooked cmp $raw) == 0) ? 'not ' : ''; - printf "%sok %d # cmp vs octects, chr %d\n", $not, ++$ok, ord $raw; -} diff --git a/t/CORE/op/concat.t b/t/CORE/op/concat.t deleted file mode 100644 index 0707a08fa..000000000 --- a/t/CORE/op/concat.t +++ /dev/null @@ -1,162 +0,0 @@ -#!./perl - -BEGIN { - unshift @INC, 't/CORE/lib'; -} - -# This ok() function is specially written to avoid any concatenation. -my $test = 1; -sub ok { - my($ok, $name) = @_; - - printf "%sok %d - %s\n", ($ok ? "" : "not "), $test, $name; - - printf "# Failed test at line %d\n", (caller)[2] unless $ok; - - $test++; - return $ok; -} - -print "1..30\n"; - -($a, $b, $c) = qw(foo bar); - -ok("$a" eq "foo", "verifying assign"); -ok("$a$b" eq "foobar", "basic concatenation"); -ok("$c$a$c" eq "foo", "concatenate undef, fore and aft"); - -# Okay, so that wasn't very challenging. Let's go Unicode. - -{ - # bug id 20000819.004 - - $_ = $dx = "\x{10f2}"; - s/($dx)/$dx$1/; - { - ok($_ eq "$dx$dx","bug id 20000819.004, back"); - } - - # perlcc issue 225 - https://code.google.com/p/perl-compiler/issues/detail?id=225 - $_ = $dx = "\x{10f2}"; - s/($dx)/$1$dx/; - { - ok($_ eq "$dx$dx","bug id 20000819.004, front"); - } - - $dx = "\x{10f2}"; - $_ = "\x{10f2}\x{10f2}"; - s/($dx)($dx)/$1$2/; - { - ok($_ eq "$dx$dx","bug id 20000819.004, front and back"); - } -} - -{ - # bug id 20000901.092 - # test that undef left and right of utf8 results in a valid string - - my $a; - $a .= "\x{1ff}"; - ok($a eq "\x{1ff}", "bug id 20000901.092, undef left"); - $a .= undef; - ok($a eq "\x{1ff}", "bug id 20000901.092, undef right"); -} - -{ - # ID 20001020.006 - - "x" =~ /(.)/; # unset $2 - - # Without the fix this 5.7.0 would croak: - # Modification of a read-only value attempted at ... - eval {"$2\x{1234}"}; - ok(!$@, "bug id 20001020.006, left"); - - # For symmetry with the above. - eval {"\x{1234}$2"}; - ok(!$@, "bug id 20001020.006, right"); - - *pi = \undef; - # This bug existed earlier than the $2 bug, but is fixed with the same - # patch. Without the fix this 5.7.0 would also croak: - # Modification of a read-only value attempted at ... - eval{"$pi\x{1234}"}; - ok(!$@, "bug id 20001020.006, constant left"); - - # For symmetry with the above. - eval{"\x{1234}$pi"}; - ok(!$@, "bug id 20001020.006, constant right"); -} - -sub beq { use bytes; $_[0] eq $_[1]; } - -{ - # concat should not upgrade its arguments. - my($l, $r, $c); - - ($l, $r, $c) = ("\x{101}", "\x{fe}", "\x{101}\x{fe}"); - ok(beq($l.$r, $c), "concat utf8 and byte"); - ok(beq($l, "\x{101}"), "right not changed after concat u+b"); - ok(beq($r, "\x{fe}"), "left not changed after concat u+b"); - - ($l, $r, $c) = ("\x{fe}", "\x{101}", "\x{fe}\x{101}"); - ok(beq($l.$r, $c), "concat byte and utf8"); - ok(beq($l, "\x{fe}"), "right not changed after concat b+u"); - ok(beq($r, "\x{101}"), "left not changed after concat b+u"); -} - -{ - my $a; ($a .= 5) . 6; - ok($a == 5, '($a .= 5) . 6 - present since 5.000'); -} - -{ - # [perl #24508] optree construction bug - sub strfoo { "x" } - my ($x, $y); - $y = ($x = '' . strfoo()) . "y"; - ok( "$x,$y" eq "x,xy", 'figures out correct target' ); -} - -{ - # [perl #26905] "use bytes" doesn't apply byte semantics to concatenation - - my $p = "\xB6"; # PILCROW SIGN (ASCII/EBCDIC), 2bytes in UTF-X - my $u = "\x{100}"; - my $b = pack 'a*', "\x{100}"; - my $pu = "\xB6\x{100}"; - my $up = "\x{100}\xB6"; - my $x1 = $p; - my $y1 = $u; - - use bytes; - ok(beq($p.$u, $p.$b), "perl #26905, left eq bytes"); - ok(beq($u.$p, $b.$p), "perl #26905, right eq bytes"); - # perlcc issue 224 - https://code.google.com/p/perl-compiler/issues/detail?id=224 - ok(!beq($p.$u, $pu), "perl #26905, left ne unicode"); - ok(!beq($u.$p, $up), "perl #26905, right ne unicode"); - - $x1 .= $u; - $x2 = $p . $u; - $y1 .= $p; - $y2 = $u . $p; - - no bytes; - ok(beq($x1, $x2), "perl #26905, left, .= vs = . in bytes"); - ok(beq($y1, $y2), "perl #26905, right, .= vs = . in bytes"); - ok(($x1 eq $x2), "perl #26905, left, .= vs = . in chars"); - ok(($y1 eq $y2), "perl #26905, right, .= vs = . in chars"); -} - -{ - # Concatenation needs to preserve UTF8ness of left oper. - my $x = eval"qr/\x{fff}/"; - ok( ord chop($x .= "\303\277") == 191, "UTF8ness preserved" ); -} - -{ - my $x; - $x = "a" . "b"; - $x .= "-append-"; - ok($x eq "ab-append-", "Appending to something initialized using constant folding"); -} diff --git a/t/CORE/op/concat2.t b/t/CORE/op/concat2.t deleted file mode 100644 index 42c802ef4..000000000 --- a/t/CORE/op/concat2.t +++ /dev/null @@ -1,20 +0,0 @@ -#!./perl - -# This file is for concatenation tests that require test.pl. -# -# concat.t cannot use test.pl as it needs to avoid using concatenation in -# its ok() function. - -BEGIN { - unshift @INC, 't/CORE/lib'; - require 't/CORE/test.pl'; -} - -plan 1; - -fresh_perl_is <<'end', "ok\n", {}, - use encoding 'utf8'; - map { "a" . $a } ((1)x5000); - print "ok\n"; -end - "concat does not lose its stack pointer after utf8 upgrade [perl #78674]"; diff --git a/t/CORE/op/cond.t b/t/CORE/op/cond.t deleted file mode 100644 index 0a0d1e173..000000000 --- a/t/CORE/op/cond.t +++ /dev/null @@ -1,10 +0,0 @@ -#!./perl - -print "1..4\n"; - -print 1 ? "ok 1\n" : "not ok 1\n"; # compile time -print 0 ? "not ok 2\n" : "ok 2\n"; - -$x = 1; -print $x ? "ok 3\n" : "not ok 3\n"; # run time -print !$x ? "not ok 4\n" : "ok 4\n"; diff --git a/t/CORE/op/context.t b/t/CORE/op/context.t deleted file mode 100644 index 17b14bd05..000000000 --- a/t/CORE/op/context.t +++ /dev/null @@ -1,26 +0,0 @@ -#!./perl - -INIT { - unshift @INC, "./lib"; - require 't/CORE/test.pl'; -} - -plan( tests => 7 ); - -sub foo { - $a='abcd'; - $a=~/(.)/g; - cmp_ok($1,'eq','a','context ' . curr_test()); -} - -$a=foo; -@a=foo; -foo; -foo(foo); - -my $before = curr_test(); -$h{foo} = foo; -my $after = curr_test(); - -cmp_ok($after-$before,'==',1,'foo called once') - or diag("nr tests: before=$before, after=$after"); diff --git a/t/CORE/op/cproto.t b/t/CORE/op/cproto.t deleted file mode 100644 index 51cb663bd..000000000 --- a/t/CORE/op/cproto.t +++ /dev/null @@ -1,265 +0,0 @@ -#!./perl -# Tests to ensure that we don't unexpectedly change prototypes of builtins - -BEGIN { - unshift @INC, 't/CORE/lib'; -} - -BEGIN { require 't/CORE/test.pl'; } -plan tests => 237; - -while () { - chomp; - (my $keyword, my $proto, local $TODO) = split " ", $_, 3; - if ($proto eq 'undef') { - ok( !defined prototype "CORE::".$keyword, $keyword ); - } - elsif ($proto eq 'unknown') { - eval { prototype "CORE::".$keyword }; - like( $@, qr/Can't find an opnumber for/, $keyword ); - } - else { - is( "(".prototype("CORE::".$keyword).")", $proto, $keyword ); - } -} - -# the keyword list : - -__DATA__ -abs (_) -accept (**) -alarm (_) -and () -atan2 ($$) -bind (*$) -binmode (*;$) -bless ($;$) -caller (;$) -chdir (;$) -chmod (@) -chomp undef -chop undef -chown (@) -chr (_) -chroot (_) -close (;*) -closedir (*) -cmp unknown -connect (*$) -continue () -cos (_) -crypt ($$) -dbmclose (\%) -dbmopen (\%$$) -defined undef -delete undef -die (@) -do undef -dump () -each (+) -else undef -elsif undef -endgrent () -endhostent () -endnetent () -endprotoent () -endpwent () -endservent () -eof (;*) -eq ($$) -eval undef -exec undef -exists undef -exit (;$) -exp (_) -fcntl (*$$) -fileno (*) -flock (*$) -for undef -foreach undef -fork () -format undef -formline ($@) -ge ($$) -getc (;*) -getgrent () -getgrgid ($) -getgrnam ($) -gethostbyaddr ($$) -gethostbyname ($) -gethostent () -getlogin () -getnetbyaddr ($$) -getnetbyname ($) -getnetent () -getpeername (*) -getpgrp (;$) -getppid () -getpriority ($$) -getprotobyname ($) -getprotobynumber ($) -getprotoent () -getpwent () -getpwnam ($) -getpwuid ($) -getservbyname ($$) -getservbyport ($$) -getservent () -getsockname (*) -getsockopt (*$$) -given undef -glob undef -gmtime (;$) -goto undef -grep undef -gt ($$) -hex (_) -if undef -index ($$;$) -int (_) -ioctl (*$$) -join ($@) -keys (+) -kill (@) -last undef -lc (_) -lcfirst (_) -le ($$) -length (_) -link ($$) -listen (*$) -local undef -localtime (;$) -lock (\$) -log (_) -lstat (*) -lt ($$) -m undef -map undef -mkdir (_;$) -msgctl ($$$) -msgget ($$) -msgrcv ($$$$$) -msgsnd ($$$) -my undef -ne ($$) -next undef -no undef -not ($) -oct (_) -open (*;$@) -opendir (*$) -or () -ord (_) -our undef -pack ($@) -package undef -pipe (**) -pop (;+) -pos undef -print undef -printf undef -prototype undef -push (+@) -q undef -qq undef -qr undef -quotemeta (_) -qw undef -qx undef -rand (;$) -read (*\$$;$) -readdir (*) -readline (;*) -readlink (_) -readpipe (_) -recv (*\$$$) -redo undef -ref (_) -rename ($$) -require undef -reset (;$) -return undef -reverse (@) -rewinddir (*) -rindex ($$;$) -rmdir (_) -s undef -say undef -scalar undef -seek (*$$) -seekdir (*$) -select (;*) -semctl ($$$$) -semget ($$$) -semop ($$) -send (*$$;$) -setgrent () -sethostent ($) -setnetent ($) -setpgrp (;$$) -setpriority ($$$) -setprotoent ($) -setpwent () -setservent ($) -setsockopt (*$$$) -shift (;+) -shmctl ($$$) -shmget ($$$) -shmread ($$$$) -shmwrite ($$$$) -shutdown (*$) -sin (_) -sleep (;$) -socket (*$$$) -socketpair (**$$$) -sort undef -splice (+;$$@) -split undef -sprintf ($@) -sqrt (_) -srand (;$) -stat (*) -state undef -study undef -sub undef -substr ($$;$$) -symlink ($$) -syscall ($@) -sysopen (*$$;$) -sysread (*\$$;$) -sysseek (*$$) -system undef -syswrite (*$;$$) -tell (;*) -telldir (*) -tie (\[$@%*]$@) -tied (\[$@%*]) -time () -times () -tr undef -truncate ($$) -uc (_) -ucfirst (_) -umask (;$) -undef undef -unless undef -unlink (@) -unpack ($;$) -unshift (+@) -untie (\[$@%*]) -until undef -use undef -utime (@) -values (+) -vec ($$$) -wait () -waitpid ($$) -wantarray () -warn (@) -when undef -while undef -write (;*) -x unknown -xor ($$) -y undef diff --git a/t/CORE/op/crypt.t b/t/CORE/op/crypt.t deleted file mode 100644 index 902657098..000000000 --- a/t/CORE/op/crypt.t +++ /dev/null @@ -1,33 +0,0 @@ -#!./perl -w - -use Config; -BEGIN { require 't/CORE/test.pl' } - -plan(tests => 4); - -# Can't assume too much about the string returned by crypt(), -# and about how many bytes of the encrypted (really, hashed) -# string matter. -# -# HISTORICALLY the results started with the first two bytes of the salt, -# followed by 11 bytes from the set [./0-9A-Za-z], and only the first -# eight characters mattered, but those are probably no more safe -# bets, given alternative encryption/hashing schemes like MD5, -# C2 (or higher) security schemes, and non-UNIX platforms. - -SKIP: { - skip ("VOS crypt ignores salt.", 1) if ($^O eq 'vos'); - ok(substr(crypt("ab", "cd"), 2) ne substr(crypt("ab", "ce"), 2), "salt makes a difference"); -} - -$a = "a\xFF\x{100}"; - -eval {$b = crypt($a, "cd")}; -like($@, qr/Wide character in crypt/, "wide characters ungood"); - -chop $a; # throw away the wide character - -eval {$b = crypt($a, "cd")}; -is($@, '', "downgrade to eight bit characters"); -is($b, crypt("a\xFF", "cd"), "downgrade results agree"); - diff --git a/t/CORE/op/dbm.t b/t/CORE/op/dbm.t deleted file mode 100644 index 8b5ec143a..000000000 --- a/t/CORE/op/dbm.t +++ /dev/null @@ -1,73 +0,0 @@ -#!./perl - -BEGIN { - unshift @INC, 't/CORE/lib'; - require 't/CORE/test.pl'; -} - -eval q{ require AnyDBM_File }; # not all places have dbm* functions -skip_all("No dbm functions") if $@; - -plan tests => 4; - -# This is [20020104.007] "coredump on dbmclose" - -my $filename = tempfile(); - -my $prog = <<'EOC'; -package Foo; -$filename = '@@@@'; -sub new { - my $proto = shift; - my $class = ref($proto) || $proto; - my $self = {}; - bless($self,$class); - my %LT; - dbmopen(%LT, $filename, 0666) || - die "Can't open $filename because of $!\n"; - $self->{'LT'} = \%LT; - return $self; -} -sub DESTROY { - my $self = shift; - dbmclose(%{$self->{'LT'}}); - 1 while unlink $filename; - 1 while unlink glob "$filename.*"; - print "ok\n"; -} -package main; -$test = Foo->new(); # must be package var -# $test = undef; # this force the DESTROY method on compiled binary -EOC - -$prog =~ s/\@\@\@\@/$filename/; - -fresh_perl_is("require AnyDBM_File;\n$prog", 'ok', {}, 'explicit require'); -# perlcc issue 208 - https://code.google.com/p/perl-compiler/issues/detail?id=208 -fresh_perl_is($prog, 'ok', {}, 'implicit require'); - -$prog = <<'EOC'; -$filename = '@@@@'; -@INC = (); -dbmopen(%LT, $filename, 0666); -1 while unlink $filename; -1 while unlink glob "$filename.*"; -die "Failed to fail!"; -EOC - -$prog =~ s/\@\@\@\@/$filename/; - -# perlcc wontfix issue 226 - https://code.google.com/p/perl-compiler/issues/detail?id=226 -# dbmopen is resolved at compile-time (require "AnyDBM_File.pm"), not run-time -# So this dbmopen error - can("TIEHASH") - does not trigger. -SKIP: { - if (is_perlcc_compiled()) { # test if runnning compiled - skip "wontfix issue 226 in perlcc"; - } else { - fresh_perl_like($prog, qr/No dbm on this machine/, {}, - 'implicit require fails'); - } -} -fresh_perl_like('delete $::{"AnyDBM_File::"}; ' . $prog, - qr/No dbm on this machine/, {}, - 'implicit require and no stash fails'); diff --git a/t/CORE/op/defins.t b/t/CORE/op/defins.t deleted file mode 100644 index e413a9ab8..000000000 --- a/t/CORE/op/defins.t +++ /dev/null @@ -1,160 +0,0 @@ -#!./perl -w - -# -# test auto defined() test insertion -# - -INIT { - unshift @INC, "./lib"; - $SIG{__WARN__} = sub { $warns++; warn $_[0] }; -} -require 't/CORE/test.pl'; -plan( tests => 19 ); - -my $unix_mode = 1; - -if ($^O eq 'VMS') { - # We have to know if VMS is in UNIX mode. In UNIX mode, trailing dots - # should not be present. There are actually two settings that control this. - - $unix_mode = 0; - my $unix_rpt = 0; - my $drop_dot = 0; - if (eval 'require VMS::Feature') { - $unix_rpt = VMS::Feature::current('filename_unix_report'); - $drop_dot = VMS::Feature::current('readdir_dropdotnotype'); - } else { - my $unix_report = $ENV{'DECC$FILENAME_UNIX_REPORT'} || ''; - $unix_rpt = $unix_report =~ /^[ET1]/i; - my $drop_dot_notype = $ENV{'DECC$READ$DIR_DROPDOTNOTYPE'} || ''; - $drop_dot = $drop_dot_notype =~ /^[ET1]/i; - } - $unix_mode = 1 if $drop_dot && unix_rpt; -} - -$wanted_filename = $unix_mode ? '0' : '0.'; -$saved_filename = './0'; - -cmp_ok($warns,'==',0,'no warns at start'); - -open(my $FILE,">$saved_filename"); -ok(defined($FILE),'created work file'); -print $FILE "1\n"; -print $FILE "0"; -close($FILE); - -open(FILE,"<$saved_filename"); -ok(defined(FILE),'opened work file'); -my $seen = 0; -my $dummy; -while (my $name = ) - { - $seen++ if $name eq '0'; - } -cmp_ok($seen,'==',1,'seen in while()'); - -seek(FILE,0,0); -$seen = 0; -my $line = ''; -do - { - $seen++ if $line eq '0'; - } while ($line = ); -cmp_ok($seen,'==',1,'seen in do/while'); - -seek(FILE,0,0); -$seen = 0; -while (($seen ? $dummy : $name) = ) - { - $seen++ if $name eq '0'; - } -cmp_ok($seen,'==',1,'seen in while() ternary'); - -seek(FILE,0,0); -$seen = 0; -my %where; -while ($where{$seen} = ) - { - $seen++ if $where{$seen} eq '0'; - } -cmp_ok($seen,'==',1,'seen in hash while()'); -close FILE; - -# perlcc issue #154 https://code.google.com/p/perl-compiler/issues/detail?id=154 -# replace DIR by $DIR solves the problem -opendir($DIR,'.'); -ok(defined($DIR),'opened current directory'); -$seen = 0; -while (my $name = readdir($DIR)) - { - $seen++ if $name eq $wanted_filename; - } -cmp_ok($seen,'==',1,'saw work file once'); - -rewinddir($DIR); -$seen = 0; -$dummy = ''; -while (($seen ? $dummy : $name) = readdir($DIR)) - { - $seen++ if $name eq $wanted_filename; - } -cmp_ok($seen,'>',0,'saw file in while() ternary'); - -rewinddir($DIR); -$seen = 0; -while ($where{$seen} = readdir($DIR)) - { - $seen++ if $where{$seen} eq $wanted_filename; - } -cmp_ok($seen,'==',1,'saw file in hash while()'); - -$seen = 0; -while (my $name = glob('*')) - { - $seen++ if $name eq $wanted_filename; - } -cmp_ok($seen,'==',1,'saw file in glob while()'); - -$seen = 0; -$dummy = ''; -while (($seen ? $dummy : $name) = glob('*')) - { - $seen++ if $name eq $wanted_filename; - } -cmp_ok($seen,'>',0,'saw file in glob hash while() ternary'); - -$seen = 0; -while ($where{$seen} = glob('*')) - { - $seen++ if $where{$seen} eq $wanted_filename; - } -cmp_ok($seen,'==',1,'seen in glob hash while()'); - -unlink($saved_filename); -ok(!(-f $saved_filename),'work file unlinked'); - -my %hash = (0 => 1, 1 => 2); - -$seen = 0; -while (my $name = each %hash) - { - $seen++ if $name eq '0'; - } -cmp_ok($seen,'==',1,'seen in each'); - -$seen = 0; -$dummy = ''; -while (($seen ? $dummy : $name) = each %hash) - { - $seen++ if $name eq '0'; - } -cmp_ok($seen,'==',1,'seen in each ternary'); - -$seen = 0; -while ($where{$seen} = each %hash) - { - $seen++ if $where{$seen} eq '0'; - } -cmp_ok($seen,'==',1,'seen in each hash'); - -cmp_ok($warns,'==',0,'no warns at finish'); diff --git a/t/CORE/op/delete.t b/t/CORE/op/delete.t deleted file mode 100644 index f99014cce..000000000 --- a/t/CORE/op/delete.t +++ /dev/null @@ -1,142 +0,0 @@ -#!./perl - -INIT { - unshift @INC, "./lib"; - require 't/CORE/test.pl'; -} - -plan( tests => 38 ); - -# delete() on hash elements - -$foo{1} = 'a'; -$foo{2} = 'b'; -$foo{3} = 'c'; -$foo{4} = 'd'; -$foo{5} = 'e'; - -$foo = delete $foo{2}; - -cmp_ok($foo,'eq','b','delete 2'); -ok(!(exists $foo{2}),'b absent'); -cmp_ok($foo{1},'eq','a','a exists'); -cmp_ok($foo{3},'eq','c','c exists'); -cmp_ok($foo{4},'eq','d','d exists'); -cmp_ok($foo{5},'eq','e','e exists'); - -@foo = delete @foo{4, 5}; - -cmp_ok(scalar(@foo),'==',2,'deleted slice'); -cmp_ok($foo[0],'eq','d','slice 1'); -cmp_ok($foo[1],'eq','e','slice 2'); -ok(!(exists $foo{4}),'d absent'); -ok(!(exists $foo{5}),'e absent'); -cmp_ok($foo{1},'eq','a','a still exists'); -cmp_ok($foo{3},'eq','c','c still exists'); - -$foo = join('',values(%foo)); -ok($foo eq 'ac' || $foo eq 'ca','remaining keys'); - -foreach $key (keys %foo) { - delete $foo{$key}; -} - -$foo{'foo'} = 'x'; -$foo{'bar'} = 'y'; - -$foo = join('',values(%foo)); -ok($foo eq 'xy' || $foo eq 'yx','fresh keys'); - -$refhash{"top"}->{"foo"} = "FOO"; -$refhash{"top"}->{"bar"} = "BAR"; - -delete $refhash{"top"}->{"bar"}; -@list = keys %{$refhash{"top"}}; - -cmp_ok("@list",'eq',"foo", 'autoviv and delete hashref'); - -{ - my %a = ('bar', 33); - my($a) = \(values %a); - my $b = \$a{bar}; - my $c = \delete $a{bar}; - - ok($a == $b && $b == $c,'a b c equivalent'); -} - -# delete() on array elements - -@foo = (); -$foo[1] = 'a'; -$foo[2] = 'b'; -$foo[3] = 'c'; -$foo[4] = 'd'; -$foo[5] = 'e'; - -$foo = delete $foo[2]; - -cmp_ok($foo,'eq','b','ary delete 2'); -ok(!(exists $foo[2]),'ary b absent'); -cmp_ok($foo[1],'eq','a','ary a exists'); -cmp_ok($foo[3],'eq','c','ary c exists'); -cmp_ok($foo[4],'eq','d','ary d exists'); -cmp_ok($foo[5],'eq','e','ary e exists'); - -@bar = delete @foo[4,5]; - -cmp_ok(scalar(@bar),'==',2,'ary deleted slice'); -cmp_ok($bar[0],'eq','d','ary slice 1'); -cmp_ok($bar[1],'eq','e','ary slice 2'); -ok(!(exists $foo[4]),'ary d absent'); -ok(!(exists $foo[5]),'ary e absent'); -cmp_ok($foo[1],'eq','a','ary a still exists'); -cmp_ok($foo[3],'eq','c','ary c still exists'); - -$foo = join('',@foo); -cmp_ok($foo,'eq','ac','ary elems'); -cmp_ok(scalar(@foo),'==',4,'four is the number thou shalt count'); - -foreach $key (0 .. $#foo) { - delete $foo[$key]; -} - -cmp_ok(scalar(@foo),'==',0,'and then there were none'); - -$foo[0] = 'x'; -$foo[1] = 'y'; - -$foo = "@foo"; -cmp_ok($foo,'eq','x y','two fresh'); - -$refary[0]->[0] = "FOO"; -$refary[0]->[3] = "BAR"; - -delete $refary[0]->[3]; - -cmp_ok( scalar(@{$refary[0]}),'==',1,'one down'); - -{ - my @a = 33; - my($a) = \(@a); - my $b = \$a[0]; - my $c = \delete $a[bar]; - - ok($a == $b && $b == $c,'a b c also equivalent'); -} - -{ - my %h; - my ($x,$y) = (1, scalar delete @h{()}); - ok(!defined($y),q([perl #29127] scalar delete of empty slice returned garbage)); -} - -{ - my $x = 0; - sub X::DESTROY { $x++ } - { - my @a; - $a[0] = bless [], 'X'; - my $y = delete $a[0]; - } - cmp_ok($x,'==',1,q([perl #30733] array delete didn't free returned element)); -} diff --git a/t/CORE/op/die.t b/t/CORE/op/die.t deleted file mode 100644 index a51333f9e..000000000 --- a/t/CORE/op/die.t +++ /dev/null @@ -1,74 +0,0 @@ -#!./perl - -print "1..15\n"; - -$SIG{__DIE__} = sub { print ref($_[0]) ? ("ok ",$_[0]->[0]++,"\n") : @_ } ; - -$err = "#[\000]\nok 1\n"; -eval { - die $err; -}; - -print "not " unless $@ eq $err; -print "ok 2\n"; - -$x = [3]; -eval { die $x; }; - -print "not " unless $x->[0] == 4; -print "ok 4\n"; - -eval { - eval { - die [ 5 ]; - }; - die if $@; -}; - -eval { - eval { - die bless [ 7 ], "Error"; - }; - die if $@; -}; - -print "not " unless ref($@) eq "Out"; -print "ok 10\n"; - -{ - package Error; - - sub PROPAGATE { - print "ok ",$_[0]->[0]++,"\n"; - bless [$_[0]->[0]], "Out"; - } -} - -{ - # die/warn and utf8 - use utf8; - local $SIG{__DIE__}; - my $msg = "ce ºtii tu, bã ?\n"; - eval { die $msg }; print "not " unless $@ eq $msg; - print "ok 11\n"; - our $err; - local $SIG{__WARN__} = $SIG{__DIE__} = sub { $err = shift }; - eval { die $msg }; print "not " unless $err eq $msg; - print "ok 12\n"; - eval { warn $msg }; print "not " unless $err eq $msg; - print "ok 13\n"; - eval qq/ use strict; \$\x{3b1} /; - print "not " unless $@ =~ /Global symbol "\$\x{3b1}"/; - print "ok 14\n"; -} - -# [perl #36470] got uninit warning if $@ was undef - -{ - my $ok = 1; - local $SIG{__DIE__}; - local $SIG{__WARN__} = sub { $ok = 0 }; - eval { undef $@; die }; - print "not " unless $ok; - print "ok 15\n"; -} diff --git a/t/CORE/op/die_except.t b/t/CORE/op/die_except.t deleted file mode 100644 index 3e2efb6f3..000000000 --- a/t/CORE/op/die_except.t +++ /dev/null @@ -1,81 +0,0 @@ -#!./perl -w - -require 't/CORE/test.pl'; -use strict; - -{ - package End; - sub DESTROY { $_[0]->() } - sub main::end(&) { - my($cleanup) = @_; - return bless(sub { $cleanup->() }, "End"); - } -} - -my($val, $err); - -$@ = "t0\n"; -$val = eval { - $@ = "t1\n"; - 1; -}; $err = $@; -is($val, 1); -is($err, ""); - -$@ = "t0\n"; -$val = eval { - $@ = "t1\n"; - do { - die "t3\n"; - }; - 1; -}; $err = $@; -is($val, undef); -# perlcc issue 215 - https://code.google.com/p/perl-compiler/issues/detail?id=215 -is($err, "t3\n"); - -$@ = "t0\n"; -$val = eval { - $@ = "t1\n"; - local $@ = "t2\n"; - 1; -}; $err = $@; -is($val, 1); -is($err, ""); - -$@ = "t0\n"; -$val = eval { - $@ = "t1\n"; - local $@ = "t2\n"; - do { - die "t3\n"; - }; - 1; -}; $err = $@; -is($val, undef); -# perlcc issue 215 - https://code.google.com/p/perl-compiler/issues/detail?id=215 -is($err, "t3\n"); - -$@ = "t0\n"; -$val = eval { - $@ = "t1\n"; - my $c = end { $@ = "t2\n"; }; - 1; -}; $err = $@; -is($val, 1); -is($err, ""); - -$@ = "t0\n"; -$val = eval { - $@ = "t1\n"; - my $c = end { $@ = "t2\n"; }; - do { - die "t3\n"; - }; - 1; -}; $err = $@; -is($val, undef); -# perlcc issue 215 - https://code.google.com/p/perl-compiler/issues/detail?id=215 -is($err, "t3\n"); - -done_testing(); diff --git a/t/CORE/op/die_exit.t b/t/CORE/op/die_exit.t deleted file mode 100644 index 6f24b166c..000000000 --- a/t/CORE/op/die_exit.t +++ /dev/null @@ -1,83 +0,0 @@ -#!./perl -w - -# -# Verify that C return the return code -# -- Robin Barker -# - -BEGIN { - unshift @INC, 't/CORE/lib'; - require 't/CORE/test.pl'; -} - -use strict; - -skip_all('broken on MPE/iX') if $^O eq 'mpeix'; - -$| = 1; - -my @tests = ( - [ 0, 0], - [ 0, 1], - [ 0, 127], - [ 0, 128], - [ 0, 255], - [ 0, 256], - [ 0, 512], - [ 1, 0], - [ 1, 1], - [ 1, 256], - [ 128, 0], - [ 128, 1], - [ 128, 256], - [ 255, 0], - [ 255, 1], - [ 255, 256], - # see if implicit close preserves $? - [ 0, 512, '{ local *F; open F, q[TEST]; close F; $!=0 } die;'], -); - -plan(tests => scalar @tests); - -my $vms_exit_mode = 0; - -if ($^O eq 'VMS') { - if (eval 'require VMS::Feature') { - $vms_exit_mode = !(VMS::Feature::current("posix_exit")); - } else { - my $env_unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || ''; - my $env_posix_ex = $ENV{'PERL_VMS_POSIX_EXIT'} || ''; - my $unix_rpt = $env_unix_rpt =~ /^[ET1]/i; - my $posix_ex = $env_posix_ex =~ /^[ET1]/i; - if (($unix_rpt || $posix_ex) ) { - $vms_exit_mode = 0; - } else { - $vms_exit_mode = 1; - } - } -} - -# Dump any error messages from the dying processes off to a temp file. -my $tempfile = tempfile(); -open STDERR, '>', $tempfile or die "Can't open temp error file $tempfile: $!"; - -foreach my $test (@tests) { - my($bang, $query, $code) = @$test; - $code ||= 'die;'; - if ($^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'VMS') { - system(qq{$^X -e "\$! = $bang; \$? = $query; $code"}); - } - else { - system(qq{$^X -e '\$! = $bang; \$? = $query; $code'}); - } - my $exit = $?; - - # The legacy VMS exit code 44 (SS$_ABORT) is returned if a program dies. - # We only get the severity bits, which boils down to 4. See L. - $bang = 4 if $vms_exit_mode; - - is($exit, (($bang || ($query >> 8) || 255) << 8), - sprintf "exit = 0x%04x bang = 0x%04x query = 0x%04x", $exit, $bang, $query); -} - -close STDERR; diff --git a/t/CORE/op/die_keeperr.t b/t/CORE/op/die_keeperr.t deleted file mode 100644 index 10269b21f..000000000 --- a/t/CORE/op/die_keeperr.t +++ /dev/null @@ -1,43 +0,0 @@ -#!perl -w - -BEGIN { require 't/CORE/test.pl' } - -plan(20); - -sub End::DESTROY { $_[0]->() } - -sub end(&) { - my($c) = @_; - return bless(sub { $c->() }, "End"); -} - -foreach my $inx ("", "aabbcc\n", [qw(aa bb cc)]) { - foreach my $outx ("", "xxyyzz\n", [qw(xx yy zz)]) { - my $warn = ""; - local $SIG{__WARN__} = sub { $warn .= $_[0] }; - { - $@ = $outx; - my $e = end { die $inx if $inx }; - } - ok ref($@) eq ref($outx) && $@ eq $outx; - $warn =~ s/ at [^\n]*\n\z//; - is $warn, $inx ? "\t(in cleanup) $inx" : ""; - } -} - -{ - no warnings "misc"; - my $warn = ""; - local $SIG{__WARN__} = sub { $warn .= $_[0] }; - { my $e = end { die "aa\n"; }; } - is $warn, ""; -} - -{ - my $warn = ""; - local $SIG{__WARN__} = sub { $warn .= $_[0] }; - { my $e = end { no warnings "misc"; die "aa\n"; }; } - is $warn, "\t(in cleanup) aa\n"; -} - -1; diff --git a/t/CORE/op/die_unwind.t b/t/CORE/op/die_unwind.t deleted file mode 100644 index 46d010a41..000000000 --- a/t/CORE/op/die_unwind.t +++ /dev/null @@ -1,73 +0,0 @@ -#!./perl -w - -require 't/CORE/test.pl'; -use strict; - -# -# This test checks for $@ being set early during an exceptional -# unwinding, and that this early setting doesn't affect the late -# setting used to emit the exception from eval{}. The early setting is -# a backward-compatibility hack to satisfy modules that were relying on -# the historical early setting in order to detect exceptional unwinding. -# This hack should be removed when a proper way to detect exceptional -# unwinding has been developed. -# - -{ - package End; - sub DESTROY { $_[0]->() } - sub main::end(&) { - my($cleanup) = @_; - return bless(sub { $cleanup->() }, "End"); - } -} - -my($uerr, $val, $err); - -$@ = ""; -$val = eval { - my $c = end { $uerr = $@; $@ = "t2\n"; }; - 1; -}; $err = $@; -is($uerr, ""); -is($val, 1); -is($err, ""); - -$@ = "t0\n"; -$val = eval { - $@ = "t1\n"; - my $c = end { $uerr = $@; $@ = "t2\n"; }; - 1; -}; $err = $@; -is($uerr, "t1\n"); -is($val, 1); -is($err, ""); - -$@ = ""; -$val = eval { - my $c = end { $uerr = $@; $@ = "t2\n"; }; - do { - die "t3\n"; - }; - 1; -}; $err = $@; -is($uerr, "t3\n"); -is($val, undef); -is($err, "t3\n"); - -$@ = "t0\n"; -$val = eval { - $@ = "t1\n"; - my $c = end { $uerr = $@; $@ = "t2\n"; }; - do { - die "t3\n"; - }; - 1; -}; $err = $@; -# perlcc issue 215 - https://code.google.com/p/perl-compiler/issues/detail?id=215 -is($uerr, "t3\n"); -is($val, undef); -# perlcc issue 215 - https://code.google.com/p/perl-compiler/issues/detail?id=215 -is($err, "t3\n"); - -done_testing(); diff --git a/t/CORE/op/do.t b/t/CORE/op/do.t deleted file mode 100644 index 97a9bff78..000000000 --- a/t/CORE/op/do.t +++ /dev/null @@ -1,201 +0,0 @@ -#!./perl -w - -require 't/CORE/test.pl'; -use strict; -no warnings 'void'; - -sub foo1 -{ - ok($_[0], 'in foo1'); - 'value'; -} - -sub foo2 -{ - shift; - ok($_[0], 'in foo2'); - my $x = 'value'; - $x; -} - -my $result; -$_[0] = 0; -{ - no warnings 'deprecated'; - $result = do foo1(1); -} - -is($result, 'value', 'do &sub and proper @_ handling'); -cmp_ok($_[0], '==', 0, 'do &sub and proper @_ handling'); - -$_[0] = 0; -{ - no warnings 'deprecated'; - $result = do foo2(0,1,0); -} -is($result, 'value', 'do &sub and proper @_ handling'); -cmp_ok($_[0], '==', 0, 'do &sub and proper @_ handling'); - -my $called; -$result = do{ ++$called; 'value';}; -is($called, 1, 'do block called'); -is($result, 'value', 'do block returns correct value'); - -my @blathered; -sub blather { - push @blathered, $_ foreach @_; -} - -{ - no warnings 'deprecated'; - do blather("ayep","sho nuff"); - is("@blathered", "ayep sho nuff", 'blathered called with list'); -} -@blathered = (); - -my @x = ("jeepers", "okydoke"); -my @y = ("uhhuh", "yeppers"); -{ - no warnings 'deprecated'; - do blather(@x,"noofie",@y); - is("@blathered", "@x noofie @y", 'blathered called with arrays too'); -} - -unshift @INC, '.'; - -my $file16 = tempfile(); -if (open my $do, '>', $file16) { - print $do "isnt(wantarray, undef, 'do in scalar context');\n"; - print $do "cmp_ok(wantarray, '==', 0, 'do in scalar context');\n"; - close $do or die "Could not close: $!"; -} - -my $a = do $file16; die $@ if $@; - -my $file17 = tempfile(); -if (open my $do, '>', $file17) { - print $do "isnt(wantarray, undef, 'do in list context');\n"; - print $do "cmp_ok(wantarray, '!=', 0, 'do in list context');\n"; - close $do or die "Could not close: $!"; -} - -my @a = do $file17; die $@ if $@; - -my $file18 = tempfile(); -if (open my $do, '>', $file18) { - print $do "is(wantarray, undef, 'do in void context');\n"; - close $do or die "Could not close: $!"; -} - -do $file18; die $@ if $@; - -# bug ID 20010920.007 -eval qq{ do qq(a file that does not exist); }; -is($@, '', "do on a non-existing file, first try"); - -eval qq{ do uc qq(a file that does not exist); }; -is($@, '', "do on a non-existing file, second try"); - -# 6 must be interpreted as a file name here -$! = 0; -my $do6 = do 6; -my $errno = $1; -is($do6, undef, 'do 6 must be interpreted as a filename'); -isnt($!, 0, 'and should set $!'); - -# [perl #19545] -my ($u, @t); -{ - # perlcc issue 192 - https://code.google.com/p/perl-compiler/issues/detail?id=192 - no warnings 'uninitialized'; - push @t, ($u = (do {} . "This should be pushed.")); -} -is($#t, 0, "empty do result value" ); - -my $zok = ''; -my $owww = do { 1 if $zok }; -is($owww, '', 'last is unless'); -$owww = do { 2 unless not $zok }; -is($owww, 1, 'last is if not'); - -$zok = 'swish'; -$owww = do { 3 unless $zok }; -is($owww, 'swish', 'last is unless'); -$owww = do { 4 if not $zok }; -is($owww, '', 'last is if not'); - -# [perl #38809] -@a = (7); -my $x = sub { do { return do { @a } }; 2 }->(); -is($x, 1, 'return do { } receives caller scalar context'); -@x = sub { do { return do { @a } }; 2 }->(); -is("@x", "7", 'return do { } receives caller list context'); - -@a = (7, 8); -$x = sub { do { return do { 1; @a } }; 3 }->(); -is($x, 2, 'return do { ; } receives caller scalar context'); -@x = sub { do { return do { 1; @a } }; 3 }->(); -is("@x", "7 8", 'return do { ; } receives caller list context'); - -my @b = (11 .. 15); -$x = sub { do { return do { 1; @a, @b } }; 3 }->(); -is($x, 5, 'return do { ; , } receives caller scalar context'); -@x = sub { do { return do { 1; @a, @b } }; 3 }->(); -is("@x", "7 8 11 12 13 14 15", 'return do { ; , } receives caller list context'); - -$x = sub { do { return do { 1; @a }, do { 2; @b } }; 3 }->(); -is($x, 5, 'return do { ; }, do { ; } receives caller scalar context'); -@x = sub { do { return do { 1; @a }, do { 2; @b } }; 3 }->(); -is("@x", "7 8 11 12 13 14 15", 'return do { ; }, do { ; } receives caller list context'); - -@a = (7, 8, 9); -$x = sub { do { do { 1; return @a } }; 4 }->(); -is($x, 3, 'do { return } receives caller scalar context'); -@x = sub { do { do { 1; return @a } }; 4 }->(); -is("@x", "7 8 9", 'do { return } receives caller list context'); - -@a = (7, 8, 9, 10); -$x = sub { do { return do { 1; do { 2; @a } } }; 5 }->(); -is($x, 4, 'return do { do { ; } } receives caller scalar context'); -@x = sub { do { return do { 1; do { 2; @a } } }; 5 }->(); -is("@x", "7 8 9 10", 'return do { do { ; } } receives caller list context'); - -# Do blocks created by constant folding -# [perl #68108] -$x = sub { if (1) { 20 } }->(); -is($x, 20, 'if (1) { $x } receives caller scalar context'); - -@a = (21 .. 23); -$x = sub { if (1) { @a } }->(); -is($x, 3, 'if (1) { @a } receives caller scalar context'); -@x = sub { if (1) { @a } }->(); -is("@x", "21 22 23", 'if (1) { @a } receives caller list context'); - -$x = sub { if (1) { 0; 20 } }->(); -is($x, 20, 'if (1) { ...; $x } receives caller scalar context'); - -@a = (24 .. 27); -$x = sub { if (1) { 0; @a } }->(); -is($x, 4, 'if (1) { ...; @a } receives caller scalar context'); -@x = sub { if (1) { 0; @a } }->(); -is("@x", "24 25 26 27", 'if (1) { ...; @a } receives caller list context'); - -$x = sub { if (1) { 0; 20 } else{} }->(); -is($x, 20, 'if (1) { ...; $x } else{} receives caller scalar context'); - -@a = (24 .. 27); -$x = sub { if (1) { 0; @a } else{} }->(); -is($x, 4, 'if (1) { ...; @a } else{} receives caller scalar context'); -@x = sub { if (1) { 0; @a } else{} }->(); -is("@x", "24 25 26 27", 'if (1) { ...; @a } else{} receives caller list context'); - -$x = sub { if (0){} else { 0; 20 } }->(); -is($x, 20, 'if (0){} else { ...; $x } receives caller scalar context'); - -@a = (24 .. 27); -$x = sub { if (0){} else { 0; @a } }->(); -is($x, 4, 'if (0){} else { ...; @a } receives caller scalar context'); -@x = sub { if (0){} else { 0; @a } }->(); -is("@x", "24 25 26 27", 'if (0){} else { ...; @a } receives caller list context'); - -done_testing(); diff --git a/t/CORE/op/dor.t b/t/CORE/op/dor.t deleted file mode 100644 index 0b13d15b7..000000000 --- a/t/CORE/op/dor.t +++ /dev/null @@ -1,72 +0,0 @@ -#!./perl - -# Test // and friends. - -INIT { - unshift @INC, 't/CORE/lib'; - require 't/CORE/test.pl'; -} - -package main; - -plan( tests => 31 ); - -my($x); - -$x=1; -is($x // 0, 1, ' // : left-hand operand defined'); - -$x = undef; -is($x // 1, 1, ' // : left-hand operand undef'); - -$x=''; -is($x // 0, '', ' // : left-hand operand defined but empty'); - -like([] // 0, qr/^ARRAY/, ' // : left-hand operand a referece'); - -$x=undef; -$x //= 1; -is($x, 1, ' //=: left-hand operand undefined'); - -$x //= 0; -is($x, 1, '//=: left-hand operand defined'); - -$x = ''; -$x //= 0; -is($x, '', '//=: left-hand operand defined but empty'); - -@ARGV = (undef, 0, 3); -is(shift // 7, 7, 'shift // ... works'); -is(shift() // 7, 0, 'shift() // ... works'); -is(shift @ARGV // 7, 3, 'shift @array // ... works'); - -@ARGV = (3, 0, undef); -is(pop // 7, 7, 'pop // ... works'); -is(pop() // 7, 0, 'pop() // ... works'); -is(pop @ARGV // 7, 3, 'pop @array // ... works'); - -# Test that various syntaxes are allowed - -for (qw(getc pos readline readlink undef umask <> <$foo> -f)) { - eval "sub { $_ // 0 }"; - is($@, '', "$_ // ... compiles"); -} - -# Test for some ambiguous syntaxes - -eval q# sub f ($) { } f $x / 2; #; -is( $@, '' ); -eval q# sub f ($):lvalue { $y } f $x /= 2; #; -is( $@, '' ); -eval q# sub f ($) { } f $x /2; #; -like( $@, qr/^Search pattern not terminated/ ); -eval q# sub { print $fh / 2 } #; -is( $@, '' ); -eval q# sub { print $fh /2 } #; -like( $@, qr/^Search pattern not terminated/ ); - -# [perl #28123] Perl optimizes // away incorrectly - -is(0 // 2, 0, ' // : left-hand operand not optimized away'); -is('' // 2, '', ' // : left-hand operand not optimized away'); -is(undef // 2, 2, ' // : left-hand operand optimized away'); diff --git a/t/CORE/op/each.t b/t/CORE/op/each.t deleted file mode 100644 index c33b3aff1..000000000 --- a/t/CORE/op/each.t +++ /dev/null @@ -1,239 +0,0 @@ -#!./perl - -BEGIN { - unshift @INC, 't/CORE/lib'; - require 't/CORE/test.pl'; -} - -plan tests => 54; - -$h{'abc'} = 'ABC'; -$h{'def'} = 'DEF'; -$h{'jkl','mno'} = "JKL\034MNO"; -$h{'a',2,3,4,5} = join("\034",'A',2,3,4,5); -$h{'a'} = 'A'; -$h{'b'} = 'B'; -$h{'c'} = 'C'; -$h{'d'} = 'D'; -$h{'e'} = 'E'; -$h{'f'} = 'F'; -$h{'g'} = 'G'; -$h{'h'} = 'H'; -$h{'i'} = 'I'; -$h{'j'} = 'J'; -$h{'k'} = 'K'; -$h{'l'} = 'L'; -$h{'m'} = 'M'; -$h{'n'} = 'N'; -$h{'o'} = 'O'; -$h{'p'} = 'P'; -$h{'q'} = 'Q'; -$h{'r'} = 'R'; -$h{'s'} = 'S'; -$h{'t'} = 'T'; -$h{'u'} = 'U'; -$h{'v'} = 'V'; -$h{'w'} = 'W'; -$h{'x'} = 'X'; -$h{'y'} = 'Y'; -$h{'z'} = 'Z'; - -@keys = keys %h; -@values = values %h; - -is ($#keys, 29, "keys"); -is ($#values, 29, "values"); - -$i = 0; # stop -w complaints - -while (($key,$value) = each(%h)) { - if ($key eq $keys[$i] && $value eq $values[$i] - && (('a' lt 'A' && $key lt $value) || $key gt $value)) { - $key =~ y/a-z/A-Z/; - $i++ if $key eq $value; - } -} - -is ($i, 30, "each count"); - -@keys = ('blurfl', keys(%h), 'dyick'); -is ($#keys, 31, "added a key"); - -$size = ((split('/',scalar %h))[1]); -keys %h = $size * 5; -$newsize = ((split('/',scalar %h))[1]); -is ($newsize, $size * 8, "resize"); -keys %h = 1; -$size = ((split('/',scalar %h))[1]); -is ($size, $newsize, "same size"); -%h = (1,1); -$size = ((split('/',scalar %h))[1]); -is ($size, $newsize, "still same size"); -undef %h; -%h = (1,1); -$size = ((split('/',scalar %h))[1]); -is ($size, 8, "size 8"); - -# test scalar each -%hash = 1..20; -$total = 0; -$total += $key while $key = each %hash; -is ($total, 100, "test scalar each"); - -for (1..3) { @foo = each %hash } -keys %hash; -$total = 0; -$total += $key while $key = each %hash; -is ($total, 100, "test scalar keys resets iterator"); - -for (1..3) { @foo = each %hash } -$total = 0; -$total += $key while $key = each %hash; -isnt ($total, 100, "test iterator of each is being maintained"); - -for (1..3) { @foo = each %hash } -values %hash; -$total = 0; -$total += $key while $key = each %hash; -is ($total, 100, "test values keys resets iterator"); - -$size = (split('/', scalar %hash))[1]; -keys(%hash) = $size / 2; -is ($size, (split('/', scalar %hash))[1]); -keys(%hash) = $size + 100; -isnt ($size, (split('/', scalar %hash))[1]); - -is (keys(%hash), 10, "keys (%hash)"); - -{ - no warnings 'deprecated'; - is (keys(hash), 10, "keys (hash)"); -} - -$i = 0; -%h = (a => A, b => B, c=> C, d => D, abc => ABC); -{ - no warnings 'deprecated'; - @keys = keys(h); - @values = values(h); - while (($key, $value) = each(h)) { - if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) { - $i++; - } - } -} -is ($i, 5); - -@tests = (&next_test, &next_test, &next_test); -{ - package Obj; - sub DESTROY { print "ok $::tests[1] # DESTROY called\n"; } - { - my $h = { A => bless [], __PACKAGE__ }; - while (my($k,$v) = each %$h) { - print "ok $::tests[0]\n" if $k eq 'A' and ref($v) eq 'Obj'; - } - } - print "ok $::tests[2]\n"; -} - -# Check for Unicode hash keys. -%u = ("\x{12}", "f", "\x{123}", "fo", "\x{1234}", "foo"); -$u{"\x{12345}"} = "bar"; -@u{"\x{10FFFD}"} = "zap"; - -my %u2; -foreach (keys %u) { - is (length(), 1, "Check length of " . _qq $_); - $u2{$_} = $u{$_}; -} -ok (eq_hash(\%u, \%u2), "copied unicode hash keys correctly?"); - -$a = "\xe3\x81\x82"; $A = "\x{3042}"; -%b = ( $a => "non-utf8"); -%u = ( $A => "utf8"); - -is (exists $b{$A}, '', "utf8 key in bytes hash"); -is (exists $u{$a}, '', "bytes key in utf8 hash"); -print "# $b{$_}\n" for keys %b; # Used to core dump before change #8056. -pass ("if we got here change 8056 worked"); -print "# $u{$_}\n" for keys %u; # Used to core dump before change #8056. -pass ("change 8056 is thanks to Inaba Hiroto"); - -# on EBCDIC chars are mapped differently so pick something that needs encoding -# there too. -$d = pack("U*", 0xe3, 0x81, 0xAF); -{ use bytes; $ol = bytes::length($d) } -cmp_ok ($ol, '>', 3, "check encoding on EBCDIC"); -%u = ($d => "downgrade"); -for (keys %u) { - is (length, 3, "check length"); - is ($_, pack("U*", 0xe3, 0x81, 0xAF), "check value"); -} -{ - { use bytes; is (bytes::length($d), $ol) } -} - -{ - my %u; - my $u0 = pack("U0U", 0x00FF); - my $b0 = "\xC3\xBF"; # 0xCB 0xBF is U+00FF in UTF-8 - my $u1 = pack("U0U", 0x0100); - my $b1 = "\xC4\x80"; # 0xC4 0x80 is U+0100 in UTF-8 - - $u{$u0} = 1; - $u{$b0} = 2; - $u{$u1} = 3; - $u{$b1} = 4; - - is(scalar keys %u, 4, "four different Unicode keys"); - is($u{$u0}, 1, "U+00FF -> 1"); - is($u{$b0}, 2, "U+00C3 U+00BF -> 2"); - is($u{$u1}, 3, "U+0100 -> 3 "); - is($u{$b1}, 4, "U+00C4 U+0080 -> 4"); -} - -# test for syntax errors -for my $k (qw(each keys values)) { - eval $k; - like($@, qr/^Not enough arguments for $k/, "$k demands argument"); -} - -{ - my %foo=(1..10); - my ($k,$v); - my $count=keys %foo; - my ($k1,$v1)=each(%foo); - my $yes = 0; - if (%foo) { $yes++ } - my ($k2,$v2)=each(%foo); - my $rest=0; - while (each(%foo)) {$rest++}; - is($yes,1,"if(%foo) was true"); - isnt($k1,$k2,"if(%foo) didnt mess with each (key)"); - isnt($v1,$v2,"if(%foo) didnt mess with each (value)"); - is($rest,3,"Got the expect number of keys"); - my $hsv=1 && %foo; - like($hsv,'/',"Got bucket stats from %foo in scalar assignment context"); - my @arr=%foo&&%foo; - is(@arr,10,"Got expected number of elements in list context"); -} -{ - our %foo=(1..10); - my ($k,$v); - my $count=keys %foo; - my ($k1,$v1)=each(%foo); - my $yes = 0; - if (%foo) { $yes++ } - my ($k2,$v2)=each(%foo); - my $rest=0; - while (each(%foo)) {$rest++}; - is($yes,1,"if(%foo) was true"); - isnt($k1,$k2,"if(%foo) didnt mess with each (key)"); - isnt($v1,$v2,"if(%foo) didnt mess with each (value)"); - is($rest,3,"Got the expect number of keys"); - my $hsv=1 && %foo; - like($hsv,'/',"Got bucket stats from %foo in scalar assignment context"); - my @arr=%foo&&%foo; - is(@arr,10,"Got expected number of elements in list context"); -} diff --git a/t/CORE/op/each_array.t b/t/CORE/op/each_array.t deleted file mode 100644 index bc19b89b5..000000000 --- a/t/CORE/op/each_array.t +++ /dev/null @@ -1,101 +0,0 @@ -#!./perl - -BEGIN { require 't/CORE/test.pl' } - -use strict; -use warnings; - -my (@array, @r, $k, $v); - -plan tests => 41; - -@array = qw(crunch zam bloop); - -(@r) = each @array; -is (scalar @r, 2); -is ($r[0], 0); -is ($r[1], 'crunch'); -($k, $v) = each @array; -is ($k, 1); -is ($v, 'zam'); -($k, $v) = each @array; -is ($k, 2); -is ($v, 'bloop'); -(@r) = each @array; -is (scalar @r, 0); - -(@r) = each @array; -is (scalar @r, 2); -is ($r[0], 0); -is ($r[1], 'crunch'); -($k) = each @array; -is ($k, 1); - -my @lex_array = qw(PLOP SKLIZZORCH RATTLE PBLRBLPSFT); - -(@r) = each @lex_array; -is (scalar @r, 2); -is ($r[0], 0); -is ($r[1], 'PLOP'); -($k, $v) = each @lex_array; -is ($k, 1); -is ($v, 'SKLIZZORCH'); -($k) = each @lex_array; -is ($k, 2); - -($k, $v) = each @lex_array; -is ($k, 3); -is ($v, 'PBLRBLPSFT'); - -(@r) = each @lex_array; -is (scalar @r, 0); - -my $ar = ['bacon']; - -(@r) = each @$ar; -is (scalar @r, 2); -is ($r[0], 0); -is ($r[1], 'bacon'); - -(@r) = each @$ar; -is (scalar @r, 0); - -is (each @$ar, 0); -is (scalar each @$ar, undef); -my @keys; -@keys = keys @array; -is ("@keys", "0 1 2"); - -@keys = keys @lex_array; -is ("@keys", "0 1 2 3"); - -($k, $v) = each @array; -is ($k, 0); -is ($v, 'crunch'); - -@keys = keys @array; -is ("@keys", "0 1 2"); - -($k, $v) = each @array; -is ($k, 0); -is ($v, 'crunch'); - - - -my @values; -@values = values @array; -is ("@values", "@array"); - -@values = values @lex_array; -is ("@values", "@lex_array"); - -($k, $v) = each @array; -is ($k, 0); -is ($v, 'crunch'); - -@values = values @array; -is ("@values", "@array"); - -($k, $v) = each @array; -is ($k, 0); -is ($v, 'crunch'); diff --git a/t/CORE/op/eval.t b/t/CORE/op/eval.t deleted file mode 100644 index 7d5528a42..000000000 --- a/t/CORE/op/eval.t +++ /dev/null @@ -1,564 +0,0 @@ -#!./perl - -BEGIN { - unshift @INC, 't/CORE/lib'; - require 't/CORE/test.pl'; -} - -plan(tests => 118); - -eval 'pass();'; - -is($@, ''); - -eval "\$foo\n = # this is a comment\n'ok 3';"; -is($foo, 'ok 3'); - -eval "\$foo\n = # this is a comment\n'ok 4\n';"; -is($foo, "ok 4\n"); - -print eval ' -$foo =;'; # this tests for a call through yyerror() -like($@, qr/line 2/); - -print eval '$foo = /'; # this tests for a call through fatal() -like($@, qr/Search/); - -is(eval '"ok 7\n";', "ok 7\n"); - -$foo = 5; -$fact = 'if ($foo <= 1) {1;} else {push(@x,$foo--); (eval $fact) * pop(@x);}'; -$ans = eval $fact; -is($ans, 120, 'calculate a factorial with recursive evals'); - -$foo = 5; -$fact = 'local($foo)=$foo; $foo <= 1 ? 1 : $foo-- * (eval $fact);'; -$ans = eval $fact; -is($ans, 120, 'calculate a factorial with recursive evals'); - -my $curr_test = curr_test(); -my $tempfile = tempfile(); -open(try,'>',$tempfile); -print try 'print "ok $curr_test\n";',"\n"; -close try; - -do "./$tempfile"; print $@; - -# Test the singlequoted eval optimizer - -$i = $curr_test + 1; -for (1..3) { - eval 'print "ok ", $i++, "\n"'; -} - -$curr_test += 4; - -eval { - print "ok $curr_test\n"; - die sprintf "ok %d\n", $curr_test + 2; - 1; -} || printf "ok %d\n$@", $curr_test + 1; - -curr_test($curr_test + 3); - -# check whether eval EXPR determines value of EXPR correctly - -{ - my @a = qw(a b c d); - my @b = eval @a; - is("@b", '4'); - is($@, ''); - - my $a = q[defined(wantarray) ? (wantarray ? ($b='A') : ($b='S')) : ($b='V')]; - my $b; - @a = eval $a; - is("@a", 'A'); - is( $b, 'A'); - $_ = eval $a; - is( $b, 'S'); - eval $a; - is( $b, 'V'); - - $b = 'wrong'; - $x = sub { - my $b = "right"; - is(eval('"$b"'), $b); - }; - &$x(); -} - -{ - my $b = 'wrong'; - my $X = sub { - my $b = "right"; - is(eval('"$b"'), $b); - }; - &$X(); -} - -# check navigation of multiple eval boundaries to find lexicals - -my $x = 'aa'; -eval <<'EOT'; die if $@; - print "# $x\n"; # clone into eval's pad - sub do_eval1 { - eval $_[0]; die if $@; - } -EOT -do_eval1('is($x, "aa")'); -$x++; -do_eval1('eval q[is($x, "ab")]'); -$x++; -do_eval1('sub { print "# $x\n"; eval q[is($x, "ac")] }->()'); -$x++; - -# calls from within eval'' should clone outer lexicals - -eval <<'EOT'; die if $@; - sub do_eval2 { - eval $_[0]; die if $@; - } -do_eval2('is($x, "ad")'); -$x++; -do_eval2('eval q[is($x, "ae")]'); -$x++; -do_eval2('sub { print "# $x\n"; eval q[is($x, "af")] }->()'); -EOT - -# calls outside eval'' should NOT clone lexicals from called context - -$main::ok = 'not ok'; -my $ok = 'ok'; -eval <<'EOT'; die if $@; - # $x unbound here - sub do_eval3 { - eval $_[0]; die if $@; - } -EOT -{ - my $ok = 'not ok'; - do_eval3('is($ok, q{ok})'); - do_eval3('eval q[is($ok, q{ok})]'); - do_eval3('sub { eval q[is($ok, q{ok})] }->()'); -} - -{ - my $x = curr_test(); - my $got; - sub recurse { - my $l = shift; - if ($l < $x) { - ++$l; - eval 'print "# level $l\n"; recurse($l);'; - die if $@; - } - else { - $got = "ok $l"; - } - } - local $SIG{__WARN__} = sub { fail() if $_[0] =~ /^Deep recurs/ }; - recurse(curr_test() - 5); - - is($got, "ok $x", - "recursive subroutine-call inside eval'' see its own lexicals"); -} - - -eval <<'EOT'; - sub create_closure { - my $self = shift; - return sub { - return $self; - }; - } -EOT -is(create_closure("good")->(), "good", - 'closures created within eval bind correctly'); - -$main::r = "good"; -sub terminal { eval '$r . q{!}' } -is(do { - my $r = "bad"; - eval 'terminal($r)'; -}, 'good!', 'lexical search terminates correctly at subroutine boundary'); - -{ - # Have we cured panic which occurred with require/eval in die handler ? - local $SIG{__DIE__} = sub { eval {1}; die shift }; - eval { die "wham_eth\n" }; - is($@, "wham_eth\n"); -} - -{ - my $c = eval "(1,2)x10"; - is($c, '2222222222', 'scalar eval"" pops stack correctly'); -} - -# return from eval {} should clear $@ correctly -{ - my $status = eval { - eval { die }; - print "# eval { return } test\n"; - return; # removing this changes behavior - }; - is($@, '', 'return from eval {} should clear $@ correctly'); -} - -# ditto for eval "" -{ - my $status = eval q{ - eval q{ die }; - print "# eval q{ return } test\n"; - return; # removing this changes behavior - }; - is($@, '', 'return from eval "" should clear $@ correctly'); -} - -# Check that eval catches bad goto calls -# (BUG ID 20010305.003) -{ - eval { - eval { goto foo; }; - like($@, qr/Can't "goto" into the middle of a foreach loop/, - 'eval catches bad goto calls'); - last; - foreach my $i (1) { - foo: fail('jumped into foreach'); - } - }; - fail("Outer eval didn't execute the last"); - diag($@); -} - -# Make sure that "my $$x" is forbidden -# 20011224 MJD -{ - foreach (qw($$x @$x %$x $$$x)) { - eval 'my ' . $_; - isnt($@, '', "my $_ is forbidden"); - } -} - -{ - $@ = 5; - eval q{}; - cmp_ok(length $@, '==', 0, '[ID 20020623.002] eval "" doesn\'t clear $@'); -} - -# DAPM Nov-2002. Perl should now capture the full lexical context during -# evals. - -$::zzz = $::zzz = 0; -my $zzz = 1; - -eval q{ - sub fred1 { - eval q{ is(eval '$zzz', 1); } - } - fred1(47); - { my $zzz = 2; fred1(48) } -}; - -eval q{ - sub fred2 { - is(eval('$zzz'), 1); - } -}; -fred2(49); -{ my $zzz = 2; fred2(50) } - -# sort() starts a new context stack. Make sure we can still find -# the lexically enclosing sub - -sub do_sort { - my $zzz = 2; - my @a = sort - { is(eval('$zzz'), 2); $a <=> $b } - 2, 1; -} -do_sort(); - -# more recursion and lexical scope leak tests - -eval q{ - my $r = -1; - my $yyy = 9; - sub fred3 { - my $l = shift; - my $r = -2; - return 1 if $l < 1; - return 0 if eval '$zzz' != 1; - return 0 if $yyy != 9; - return 0 if eval '$yyy' != 9; - return 0 if eval '$l' != $l; - return $l * fred3($l-1); - } - my $r = fred3(5); - is($r, 120); - $r = eval'fred3(5)'; - is($r, 120); - $r = 0; - eval '$r = fred3(5)'; - is($r, 120); - $r = 0; - { my $yyy = 4; my $zzz = 5; my $l = 6; $r = eval 'fred3(5)' }; - is($r, 120); -}; -my $r = fred3(5); -is($r, 120); -$r = eval'fred3(5)'; -is($r, 120); -$r = 0; -eval'$r = fred3(5)'; -is($r, 120); -$r = 0; -{ my $yyy = 4; my $zzz = 5; my $l = 6; $r = eval 'fred3(5)' }; -is($r, 120); - -# check that goto &sub within evals doesn't leak lexical scope - -my $yyy = 2; - -sub fred4 { - my $zzz = 3; - is($zzz, 3); - is(eval '$zzz', 3); - is(eval '$yyy', 2); -} - -eval q{ - fred4(); - sub fred5 { - my $zzz = 4; - is($zzz, 4); - is(eval '$zzz', 4); - is(eval '$yyy', 2); - goto &fred4; - } - fred5(); -}; -fred5(); -{ my $yyy = 88; my $zzz = 99; fred5(); } -eval q{ my $yyy = 888; my $zzz = 999; fred5(); }; - -{ - $eval = eval 'sub { eval "sub { %S }" }'; - $eval->({}); - pass('[perl #9728] used to dump core'); -} - -# evals that appear in the DB package should see the lexical scope of the -# thing outside DB that called them (usually the debugged code), rather -# than the usual surrounding scope - -our $x = 1; -{ - my $x=2; - sub db1 { $x; eval '$x' } - sub DB::db2 { $x; eval '$x' } - package DB; - sub db3 { eval '$x' } - sub DB::db4 { eval '$x' } - sub db5 { my $x=4; eval '$x' } - package main; - sub db6 { my $x=4; eval '$x' } -} -{ - my $x = 3; - is(db1(), 2); - is(DB::db2(), 2); - is(DB::db3(), 3); - is(DB::db4(), 3); - is(DB::db5(), 3); - is(db6(), 4); -} - -# [perl #19022] used to end up with shared hash warnings -# The program should generate no output, so anything we see is on stderr -my $got = runperl (prog => '$h{a}=1; foreach my $k (keys %h) {eval qq{\$k}}', - stderr => 1); -is ($got, ''); - -# And a buggy way of fixing #19022 made this fail - $k became undef after the -# eval for a build with copy on write -{ - my %h; - $h{a}=1; - foreach my $k (keys %h) { - is($k, 'a'); - - eval "\$k"; - - is($k, 'a'); - } -} - -sub Foo {} print Foo(eval {}); -pass('#20798 (used to dump core)'); - -# check for context in string eval -{ - my(@r,$r,$c); - sub context { defined(wantarray) ? (wantarray ? ($c='A') : ($c='S')) : ($c='V') } - - my $code = q{ context() }; - @r = qw( a b ); - $r = 'ab'; - @r = eval $code; - is("@r$c", 'AA', 'string eval list context'); - $r = eval $code; - is("$r$c", 'SS', 'string eval scalar context'); - eval $code; - is("$c", 'V', 'string eval void context'); -} - -# [perl #34682] escaping an eval with last could coredump or dup output - -$got = runperl ( - prog => - 'sub A::TIEARRAY { L: { eval { last L } } } tie @a, A; warn qq(ok\n)', -stderr => 1); - -is($got, "ok\n", 'eval and last'); - -# eval undef should be the same as eval "" barring any warnings - -{ - local $@ = "foo"; - eval undef; - is($@, "", 'eval undef'); -} - -{ - no warnings; - eval "/ /b;"; - like($@, qr/^syntax error/, 'eval syntax error, no warnings'); -} - -# a syntax error in an eval called magically 9eg vie tie or overload) -# resulted in an assertion failure in S_docatch, since doeval had already -# poppedthe EVAL context due to the failure, but S_docatch expected the -# context to still be there. - -{ - my $ok = 0; - package Eval1; - sub STORE { eval '('; $ok = 1 } - sub TIESCALAR { bless [] } - - my $x; - tie $x, bless []; - $x = 1; - ::is($ok, 1, 'eval docatch'); -} - -# [perl #51370] eval { die "\x{a10d}" } followed by eval { 1 } did not reset -# length $@ -$@ = ""; -eval { die "\x{a10d}"; }; -$_ = length $@; -eval { 1 }; - -cmp_ok($@, 'eq', "", 'length of $@ after eval'); -cmp_ok(length $@, '==', 0, 'length of $@ after eval'); - -# Check if eval { 1 }; completely resets $@ -require Config; - -my $tempfile = tempfile(); -open $prog, ">", $tempfile or die "Can't create test file"; -print $prog <<'END_EVAL_TEST'; - use Devel::Peek; - $! = 0; - $@ = $!; - Dump($@); - print STDERR "******\n"; - eval { die "\x{a10d}"; }; - $_ = length $@; - eval { 1 }; - Dump($@); - print STDERR "******\n"; - print STDERR "Done\n"; -END_EVAL_TEST - close $prog or die "Can't close $tempfile: $!"; - my $got = runperl(progfile => $tempfile, stderr => 1); - my ($first, $second, $tombstone) = split (/\*\*\*\*\*\*\n/, $got); - - is($tombstone, "Done\n", 'Program completed successfully'); - - $first =~ s/,pNOK//; - s/ PV = 0x[0-9a-f]+/ PV = 0x/ foreach $first, $second; - s/ LEN = [0-9]+/ LEN = / foreach $first, $second; - # Dump may double newlines through pipes, though not files - # which is what this test used to use. - $second =~ s/ IV = 0\n\n/ IV = 0\n/ if $^O eq 'VMS'; - - is($second, $first, 'eval { 1 } completely resets $@'); - -# Test that "use feature" and other hint transmission in evals and s///ee -# don't leak memory -{ - use feature qw(:5.10); - my $count_expected = ($^H & 0x20000) ? 2 : 1; - my $t; - my $s = "a"; - $s =~ s/a/$t = \%^H; qq( qq() );/ee; - is(Internals::SvREFCNT(%$t), $count_expected, 'RT 63110'); -} - -{ - # test that the CV compiled for the eval is freed by checking that no additional - # reference to outside lexicals are made. - my $x; - is(Internals::SvREFCNT($x), 1, "originally only 1 referece"); - eval '$x'; - is(Internals::SvREFCNT($x), 1, "execution eval doesn't create new references"); -} - -# perlcc issue 216 - https://code.google.com/p/perl-compiler/issues/detail?id=216 -fresh_perl_is(<<'EOP', "ok\n", undef, 'RT #70862'); -$::{'@'}=''; -eval {}; -print "ok\n"; -EOP - -fresh_perl_is(<<'EOP', "ok\n", undef, 'variant of RT #70862'); -eval { - $::{'@'}=''; -}; -print "ok\n"; -EOP - -fresh_perl_is(<<'EOP', "ok\n", undef, 'related to RT #70862'); -$::{'@'}=\3; -eval {}; -print "ok\n"; -EOP - -fresh_perl_is(<<'EOP', "ok\n", undef, 'related to RT #70862'); -eval { - $::{'@'}=\3; -}; -print "ok\n"; -EOP - - fresh_perl_is(<<'EOP', "ok\n", undef, 'segfault on syntax errors in block evals'); -# localize the hits hash so the eval ends up with the pad offset of a copy of it in its targ -BEGIN { $^H |= 0x00020000 } -eval q{ eval { + } }; -print "ok\n"; -EOP - -fresh_perl_is(<<'EOP', "ok\n", undef, 'assert fail on non-string in Perl_lex_start'); -use overload '""' => sub { '1;' }; -my $ov = bless []; -eval $ov; -print "ok\n"; -EOP - -for my $k (!0) { - eval 'my $do_something_with = $k'; - eval { $k = 'mon' }; - is "a" =~ /a/, "1", - "string eval leaves readonly lexicals readonly [perl #19135]"; -} diff --git a/t/CORE/op/exec.t b/t/CORE/op/exec.t deleted file mode 100644 index 90ac76f3e..000000000 --- a/t/CORE/op/exec.t +++ /dev/null @@ -1,145 +0,0 @@ -#!./perl - -BEGIN { - push @INC, ('./lib'); - require 't/CORE/test.pl'; -} - -my $vms_exit_mode = 0; - -if ($^O eq 'VMS') { - if (eval 'require VMS::Feature') { - $vms_exit_mode = !(VMS::Feature::current("posix_exit")); - } else { - my $env_unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || ''; - my $env_posix_ex = $ENV{'PERL_VMS_POSIX_EXIT'} || ''; - my $unix_rpt = $env_unix_rpt =~ /^[ET1]/i; - my $posix_ex = $env_posix_ex =~ /^[ET1]/i; - if (($unix_rpt || $posix_ex) ) { - $vms_exit_mode = 0; - } else { - $vms_exit_mode = 1; - } - } -} - - -# suppress VMS whinging about bad execs. -use vmsish qw(hushed); - -$| = 1; # flush stdout - -$ENV{LC_ALL} = 'C'; # Forge English error messages. -$ENV{LANGUAGE} = 'C'; # Ditto in GNU. - -my $Is_VMS = $^O eq 'VMS'; -my $Is_Win32 = $^O eq 'MSWin32'; - -plan(tests => 22); - -my $Perl = which_perl(); - -my $exit; -SKIP: { - skip("bug/feature of pdksh", 2) if $^O eq 'os2'; - - my $tnum = curr_test(); - $exit = system qq{$Perl -le "print q{ok $tnum - interp system(EXPR)"}}; - next_test(); - is( $exit, 0, ' exited 0' ); -} - -my $tnum = curr_test(); -$exit = system qq{$Perl -le "print q{ok $tnum - split & direct system(EXPR)"}}; -next_test(); -is( $exit, 0, ' exited 0' ); - -# On VMS and Win32 you need the quotes around the program or it won't work. -# On Unix its the opposite. -my $quote = $Is_VMS || $Is_Win32 ? '"' : ''; -$tnum = curr_test(); -$exit = system $Perl, '-le', - "${quote}print q{ok $tnum - system(PROG, LIST)}${quote}"; -next_test(); -is( $exit, 0, ' exited 0' ); - - -# Some basic piped commands. Some OS's have trouble with "helpfully" -# putting newlines on the end of piped output. So we split this into -# newline insensitive and newline sensitive tests. -my $echo_out = `$Perl -e "print 'ok'" | $Perl -le "print "`; -$echo_out =~ s/\n\n/\n/g; -is( $echo_out, "ok\n", 'piped echo emulation'); - -{ - # here we check if extra newlines are going to be slapped on - # piped output. - local $TODO = 'VMS sticks newlines on everything' if $Is_VMS; - - is( scalar `$Perl -e "print 'ok'"`, - "ok", 'no extra newlines on ``' ); - - is( scalar `$Perl -e "print 'ok'" | $Perl -e "print "`, - "ok", 'no extra newlines on pipes'); - - is( scalar `$Perl -le "print 'ok'" | $Perl -le "print "`, - "ok\n\n", 'doubled up newlines'); - - is( scalar `$Perl -e "print 'ok'" | $Perl -le "print "`, - "ok\n", 'extra newlines on inside pipes'); - - is( scalar `$Perl -le "print 'ok'" | $Perl -e "print "`, - "ok\n", 'extra newlines on outgoing pipes'); - - { - local($/) = \2; - $out = runperl(prog => 'print q{1234}'); - is($out, "1234", 'ignore $/ when capturing output in scalar context'); - } -} - - -is( system(qq{$Perl -e "exit 0"}), 0, 'Explicit exit of 0' ); - -my $exit_one = $vms_exit_mode ? 4 << 8 : 1 << 8; -is( system(qq{$Perl "-I../lib" -e "use vmsish qw(hushed); exit 1"}), $exit_one, - 'Explicit exit of 1' ); - -$rc = system { "lskdfj" } "lskdfj"; -unless( ok($rc == 255 << 8 or $rc == -1 or $rc == 256 or $rc == 512) ) { - print "# \$rc == $rc\n"; -} - -unless ( ok( $! == 2 or $! =~ /\bno\b.*\bfile/i or - $! == 13 or $! =~ /permission denied/i or - $! == 22 or $! =~ /invalid argument/i ) ) { - printf "# \$! eq %d, '%s'\n", $!, $!; -} - - -is( `$Perl -le "print 'ok'"`, "ok\n", 'basic ``' ); -is( <<`END`, "ok\n", '<<`HEREDOC`' ); -$Perl -le "print 'ok'" -END - -{ - my $_ = qq($Perl -le "print 'ok'"); - is( readpipe, "ok\n", 'readpipe default argument' ); -} - -TODO: { - my $tnum = curr_test(); - if( $^O =~ /Win32/ ) { - print "not ok $tnum - exec failure doesn't terminate process " . - "# TODO Win32 exec failure waits for user input\n"; - next_test(); - last TODO; - } - - ok( !exec("lskdjfalksdjfdjfkls"), - "exec failure doesn't terminate process"); -} - -my $test = curr_test(); -exec $Perl, '-le', qq{${quote}print 'ok $test - exec PROG, LIST'${quote}}; -fail("This should never be reached if the exec() worked"); diff --git a/t/CORE/op/exists_sub.t b/t/CORE/op/exists_sub.t deleted file mode 100644 index 0624f313b..000000000 --- a/t/CORE/op/exists_sub.t +++ /dev/null @@ -1,45 +0,0 @@ -#!./perl - -BEGIN { - unshift @INC, 't/CORE/lib'; -} - -print "1..9\n"; - -sub t1; -sub t2 : lvalue; -sub t3 (); -sub t4 ($); -sub t5 {1;} -{ - package P1; - sub tmc {1;} - package P2; - @ISA = 'P1'; -} - -print "not " unless exists &t1 && not defined &t1; -print "ok 1\n"; -print "not " unless exists &t2 && not defined &t2; -print "ok 2\n"; -print "not " unless exists &t3 && not defined &t3; -print "ok 3\n"; -print "not " unless exists &t4 && not defined &t4; -print "ok 4\n"; -print "not " unless exists &t5 && defined &t5; -print "ok 5\n"; -P2::->tmc; -print "not " unless not exists &P2::tmc && not defined &P2::tmc; -print "ok 6\n"; -my $ref; -$ref->{A}[0] = \&t4; -print "not " unless exists &{$ref->{A}[0]} && not defined &{$ref->{A}[0]}; -print "ok 7\n"; -undef &P1::tmc; -print "not " unless exists &P1::tmc && not defined &P1::tmc; -print "ok 8\n"; -eval 'exists &t5()'; -print "not " unless $@; -print "ok 9\n"; - -exit 0; diff --git a/t/CORE/op/exp.t b/t/CORE/op/exp.t deleted file mode 100644 index 5fc70b2c7..000000000 --- a/t/CORE/op/exp.t +++ /dev/null @@ -1,58 +0,0 @@ -#!./perl - -BEGIN { - unshift @INC, 't/CORE/lib'; - require 't/CORE/test.pl'; -} - -plan tests => 16; - -# compile time evaluation - -$s = sqrt(2); -is(substr($s,0,5), '1.414'); - -$s = exp(1); -is(substr($s,0,7), '2.71828'); - -cmp_ok(exp(log(1)), '==', 1); - -# run time evaluation - -$x1 = 1; -$x2 = 2; -$s = sqrt($x2); -is(substr($s,0,5), '1.414'); - -$s = exp($x1); -is(substr($s,0,7), '2.71828'); - -cmp_ok(exp(log($x1)), '==', 1); - -# tests for transcendental functions - -my $pi = 3.1415926535897931160; -my $pi_2 = 1.5707963267948965580; - -sub round { - my $result = shift; - return sprintf("%.9f", $result); -} - -# sin() tests -cmp_ok(sin(0), '==', 0.0); -cmp_ok(round(sin($pi)), '==', 0.0); -cmp_ok(round(sin(-1 * $pi)), '==', 0.0); -cmp_ok(round(sin($pi_2)), '==', 1.0); -cmp_ok(round(sin(-1 * $pi_2)), '==', -1.0); - -# cos() tests -cmp_ok(cos(0), '==', 1.0); -cmp_ok(round(cos($pi)), '==', -1.0); -cmp_ok(round(cos(-1 * $pi)), '==', -1.0); -cmp_ok(round(cos($pi_2)), '==', 0.0); -cmp_ok(round(cos(-1 * $pi_2)), '==', 0.0); - -# atan2() tests were removed due to differing results from calls to -# atan2() on various OS's and architectures. See perlport.pod for -# more information. diff --git a/t/CORE/op/fh.t b/t/CORE/op/fh.t deleted file mode 100644 index b6df36f34..000000000 --- a/t/CORE/op/fh.t +++ /dev/null @@ -1,28 +0,0 @@ -#!./perl - -BEGIN { - unshift @INC, 't/CORE/lib'; - require 't/CORE/test.pl'; -} - -plan tests => 8; - -# symbolic filehandles should only result in glob entries with FH constructors - -$|=1; -my $a = "SYM000"; -ok(!defined(fileno($a))); -ok(!defined *{$a}); - -select select $a; -ok(defined *{$a}); - -$a++; -ok(!close $a); -ok(!defined *{$a}); - -ok(open($a, ">&STDOUT")); -ok(defined *{$a}); - -ok(close $a); - diff --git a/t/CORE/op/filehandle.t b/t/CORE/op/filehandle.t deleted file mode 100644 index 27c3e70c5..000000000 --- a/t/CORE/op/filehandle.t +++ /dev/null @@ -1,24 +0,0 @@ -#!./perl - -# There are few filetest operators that are portable enough to test. -# See pod/perlport.pod for details. - -BEGIN { - unshift @INC, 't/CORE/lib'; - require 't/CORE/test.pl'; -} - -plan 4; -use FileHandle; - -my $str = "foo"; -open my $fh, "<", \$str; -is <$fh>, "foo"; - -eval { - $fh->seek(0, 0); - is $fh->tell, 0; - is <$fh>, "foo"; -}; - -is $@, ''; diff --git a/t/CORE/op/filetest.t b/t/CORE/op/filetest.t deleted file mode 100644 index 545532ebc..000000000 --- a/t/CORE/op/filetest.t +++ /dev/null @@ -1,201 +0,0 @@ -#!./perl - -# There are few filetest operators that are portable enough to test. -# See pod/perlport.pod for details. - -BEGIN { - unshift @INC, 't/CORE/lib'; - require 't/CORE/test.pl'; -} - -use Config; -plan(tests => 28 + 27*14); - -chdir('./t/CORE'); - -ok( -d 'op' ); -ok( -f 'TEST' ); -ok( !-f 'op' ); -ok( !-d 'TEST' ); -ok( -r 'TEST' ); - -# Make a read only file -my $ro_file = tempfile(); - -{ - open my $fh, '>', $ro_file or die "open $fh: $!"; - close $fh or die "close $fh: $!"; -} - -chmod 0555, $ro_file or die "chmod 0555, '$ro_file' failed: $!"; - -$oldeuid = $>; # root can read and write anything -eval '$> = 1'; # so switch uid (may not be implemented) - -print "# oldeuid = $oldeuid, euid = $>\n"; - -SKIP: { - if (!$Config{d_seteuid}) { - skip('no seteuid'); - } - else { - ok( !-w $ro_file ); - } -} - -# Scripts are not -x everywhere so cannot test that. - -eval '$> = $oldeuid'; # switch uid back (may not be implemented) - -# this would fail for the euid 1 -# (unless we have unpacked the source code as uid 1...) -ok( -r 'op' ); - -# this would fail for the euid 1 -# (unless we have unpacked the source code as uid 1...) -SKIP: { - if ($Config{d_seteuid}) { - ok( -w 'op' ); - } else { - skip('no seteuid'); - } -} - -ok( -x 'op' ); # Hohum. Are directories -x everywhere? - -is( "@{[grep -r, qw(foo io noo op zoo)]}", "io op" ); - -# Test stackability of filetest operators - -ok( defined( -f -d 'TEST' ) && ! -f -d _ ); -ok( !defined( -e 'zoo' ) ); -ok( !defined( -e -d 'zoo' ) ); -ok( !defined( -f -e 'zoo' ) ); -ok( -f -e 'TEST' ); -ok( -e -f 'TEST' ); -ok( defined(-d -e 'TEST') ); -ok( defined(-e -d 'TEST') ); -ok( ! -f -d 'op' ); -ok( -x -d -x 'op' ); -ok( (-s -f 'TEST' > 1), "-s returns real size" ); -ok( -f -s 'TEST' == 1 ); - -# now with an empty file -my $tempfile = tempfile(); -open my $fh, ">", $tempfile; -close $fh; -ok( -f $tempfile ); -is( -s $tempfile, 0 ); -is( -f -s $tempfile, 0 ); -is( -s -f $tempfile, 0 ); -unlink_all $tempfile; - -# test that _ is a bareword after filetest operators - --f 'TEST'; -ok( -f _ ); -sub _ { "this is not a file name" } -ok( -f _ ); - -my $over; -{ - package OverFtest; - - use overload - fallback => 1, - -X => sub { - $over = [qq($_[0]), $_[1]]; - "-$_[1]"; - }; -} -{ - package OverString; - - # No fallback. -X should fall back to string overload even without - # it. - use overload q/""/ => sub { $over = 1; "TEST" }; -} -{ - package OverBoth; - - use overload - q/""/ => sub { "TEST" }, - -X => sub { "-$_[1]" }; -} -{ - package OverNeither; - - # Need fallback. Previous versions of perl required 'fallback' to do - # -X operations on an object with no "" overload. - use overload - '+' => sub { 1 }, - fallback => 1; -} - -my $ft = bless [], "OverFtest"; -my $ftstr = qq($ft); -my $str = bless [], "OverString"; -my $both = bless [], "OverBoth"; -my $neither = bless [], "OverNeither"; -my $nstr = qq($neither); - -open my $gv, "<", "TEST"; -bless $gv, "OverString"; -open my $io, "<", "TEST"; -$io = *{$io}{IO}; -bless $io, "OverString"; - -my $fcntl_not_available; -eval { require Fcntl } or $fcntl_not_available = 1; - -for my $op (split //, "rwxoRWXOezsfdlpSbctugkTMBAC") { - $over = []; - ok( my $rv = eval "-$op \$ft", "overloaded -$op succeeds" ) - or diag( $@ ); - is( $over->[0], $ftstr, "correct object for overloaded -$op" ); - is( $over->[1], $op, "correct op for overloaded -$op" ); - is( $rv, "-$op", "correct return value for overloaded -$op"); - - my ($exp, $is) = (1, "is"); - if ( - !$fcntl_not_available and ( - $op eq "u" and not eval { Fcntl::S_ISUID() } or - $op eq "g" and not eval { Fcntl::S_ISGID() } or - $op eq "k" and not eval { Fcntl::S_ISVTX() } - ) - ) { - ($exp, $is) = (0, "not"); - } - - $over = 0; - $rv = eval "-$op \$str"; - ok( !$@, "-$op succeeds with string overloading" ) - or diag( $@ ); - is( $rv, eval "-$op 'TEST'", "correct -$op on string overload" ); - is( $over, $exp, "string overload $is called for -$op" ); - - ($exp, $is) = $op eq "l" ? (1, "is") : (0, "not"); - - $over = 0; - eval "-$op \$gv"; - is( $over, $exp, "string overload $is called for -$op on GLOB" ); - - # IO refs always get string overload called. This might be a bug. - $op eq "t" || $op eq "T" || $op eq "B" - and ($exp, $is) = (1, "is"); - - $over = 0; - eval "-$op \$io"; - is( $over, $exp, "string overload $is called for -$op on IO"); - - $rv = eval "-$op \$both"; - is( $rv, "-$op", "correct -$op on string/-X overload" ); - - $rv = eval "-$op \$neither"; - ok( !$@, "-$op succeeds with random overloading" ) - or diag( $@ ); - is( $rv, eval "-$op \$nstr", "correct -$op with random overloading" ); - - is( eval "-r -$op \$ft", "-r", "stacked overloaded -$op" ); - is( eval "-$op -r \$ft", "-$op", "overloaded stacked -$op" ); -} diff --git a/t/CORE/op/filetest_stack_ok.t b/t/CORE/op/filetest_stack_ok.t deleted file mode 100644 index eb702a271..000000000 --- a/t/CORE/op/filetest_stack_ok.t +++ /dev/null @@ -1,45 +0,0 @@ -#!./perl - -# On platforms that don't support all of the filetest operators the code -# that faked the results of missing tests used to leave the test's -# argument on the stack. - -BEGIN { - unshift @INC, 't/CORE/lib'; - require 't/CORE/test.pl'; -} - -my @ops = split //, 'rwxoRWXOezsfdlpSbctugkTMBAC'; - -plan( tests => @ops * 3 ); - -for my $op (@ops) { - ok( 1 == @{ [ eval "-$op 'TEST'" ] }, "-$op returns single value" ); - - my $count = 0; - my $t; - for my $m ("a", "b") { - if ($count == 0) { - $t = eval "-$op _" ? 0 : "foo"; - } - elsif ($count == 1) { - is($m, "b", "-$op did not remove too many values from the stack"); - } - $count++; - } - - $count = 0; - for my $m ("c", "d") { - if ($count == 0) { - $t = eval "-$op -e \$^X" ? 0 : "bar"; - } - elsif ($count == 1) { - local $TODO; - if ($op eq 'T' or $op eq 't' or $op eq 'B') { - $TODO = "[perl #77388] stacked file test does not work with -$op"; - } - is($m, "d", "-$op -e \$^X did not remove too many values from the stack"); - } - $count++; - } -} diff --git a/t/CORE/op/filetest_t.t b/t/CORE/op/filetest_t.t deleted file mode 100644 index 47b7b762d..000000000 --- a/t/CORE/op/filetest_t.t +++ /dev/null @@ -1,30 +0,0 @@ -#!./perl - -BEGIN { - unshift @INC, 't/CORE/lib'; - require 't/CORE/test.pl'; -} - -use strict; - -plan 2; - -my($dev_tty, $dev_null) = qw(/dev/tty /dev/null); - ($dev_tty, $dev_null) = qw(con nul ) if $^O =~ /^(MSWin32|os2)$/; - ($dev_tty, $dev_null) = qw(TT: _NLA0: ) if $^O eq "VMS"; - -SKIP: { - open(my $tty, "<", $dev_tty) - or skip("Can't open terminal '$dev_tty': $!"); - if ($^O eq 'VMS') { - # TT might be a mailbox or other non-terminal device - my $tt_dev = VMS::Filespec::vmspath('TT'); - skip("'$tt_dev' is probably not a terminal") if $tt_dev !~ m/^_(tt|ft|rt)/i; - } - ok(-t $tty, "'$dev_tty' is a TTY"); -} -SKIP: { - open(my $null, "<", $dev_null) - or skip("Can't open null device '$dev_null': $!"); - ok(!-t $null, "'$dev_null' is not a TTY"); -} diff --git a/t/CORE/op/flip.t b/t/CORE/op/flip.t deleted file mode 100644 index 44a2ea175..000000000 --- a/t/CORE/op/flip.t +++ /dev/null @@ -1,65 +0,0 @@ -#!./perl - -BEGIN { - require 't/CORE/test.pl'; -} - -plan(11); - -@a = (1,2,3,4,5,6,7,8,9,10,11,12); -@b = (); -while ($_ = shift(@a)) { - if ($x = /4/../8/) { $z = $x; push @b, $x + 0; } - $y .= /1/../2/; -} -is(join("*", @b), "1*2*3*4*5"); - -is($z, '5E0'); - -is($y, '12E0123E0'); - -@a = ('a','b','c','d','e','f','g'); - -{ -local $.; - -open(of,'t/CORE/test.pl') or die "Can't open harness: $!"; -while () { - (3 .. 5) && ($foo .= $_); -} -$x = ($foo =~ y/\n/\n/); - -is($x, 3); - -$x = 3.14; -ok(($x...$x) eq "1"); - -{ - # coredump reported in bug 20001018.008 - readline(UNKNOWN); - $. = 1; - $x = 1..10; - ok(1); -} - -} - -ok(!defined $.); - -use warnings; -my $warn=''; -$SIG{__WARN__} = sub { $warn .= join '', @_ }; - -ok(scalar(0..2)); - -like($warn, qr/uninitialized/); -$warn = ''; - -# if we want to catch the numeric warnings, we need to delay that line, -# as it s done during compilation ( this is not a bug by itself ) -$x = eval q/"foo".."bar"/; -ok((() = ($warn =~ /isn't numeric/g)) == 2); -$warn = ''; - -$. = 15; -ok(scalar(15..0)); diff --git a/t/CORE/op/fork.t b/t/CORE/op/fork.t deleted file mode 100644 index 996300c73..000000000 --- a/t/CORE/op/fork.t +++ /dev/null @@ -1,484 +0,0 @@ -#!./perl - -# tests for both real and emulated fork() - -BEGIN { - unshift @INC, 't/CORE/lib'; - require 't/CORE/test.pl'; - require Config; - skip_all('no fork') - unless ($Config::Config{d_fork} or $Config::Config{d_pseudofork}); -} - -skip_all('fork/status problems on MPE/iX') - if $^O eq 'mpeix'; - -$|=1; - -run_multiple_progs('', \*DATA); - -done_testing(); - -__END__ -$| = 1; -if ($cid = fork) { - sleep 1; - if ($result = (kill 9, $cid)) { - print "ok 2\n"; - } - else { - print "not ok 2 $result\n"; - } - sleep 1 if $^O eq 'MSWin32'; # avoid WinNT race bug -} -else { - print "ok 1\n"; - sleep 10; -} -EXPECT -OPTION random -ok 1 -ok 2 -######## -$| = 1; -if ($cid = fork) { - sleep 1; - print "not " unless kill 'INT', $cid; - print "ok 2\n"; -} -else { - # XXX On Windows the default signal handler kills the - # XXX whole process, not just the thread (pseudo-process) - $SIG{INT} = sub { exit }; - print "ok 1\n"; - sleep 5; - die; -} -EXPECT -OPTION random -ok 1 -ok 2 -######## -$| = 1; -sub forkit { - print "iteration $i start\n"; - my $x = fork; - if (defined $x) { - if ($x) { - print "iteration $i parent\n"; - } - else { - print "iteration $i child\n"; - } - } - else { - print "pid $$ failed to fork\n"; - } -} -while ($i++ < 3) { do { forkit(); }; } -EXPECT -OPTION random -iteration 1 start -iteration 1 parent -iteration 1 child -iteration 2 start -iteration 2 parent -iteration 2 child -iteration 2 start -iteration 2 parent -iteration 2 child -iteration 3 start -iteration 3 parent -iteration 3 child -iteration 3 start -iteration 3 parent -iteration 3 child -iteration 3 start -iteration 3 parent -iteration 3 child -iteration 3 start -iteration 3 parent -iteration 3 child -######## -$| = 1; -fork() - ? (print("parent\n"),sleep(1)) - : (print("child\n"),exit) ; -EXPECT -OPTION random -parent -child -######## -$| = 1; -fork() - ? (print("parent\n"),exit) - : (print("child\n"),sleep(1)) ; -EXPECT -OPTION random -parent -child -######## -$| = 1; -@a = (1..3); -for (@a) { - if (fork) { - print "parent $_\n"; - $_ = "[$_]"; - } - else { - print "child $_\n"; - $_ = "-$_-"; - } -} -print "@a\n"; -EXPECT -OPTION random -parent 1 -child 1 -parent 2 -child 2 -parent 2 -child 2 -parent 3 -child 3 -parent 3 -child 3 -parent 3 -child 3 -parent 3 -child 3 -[1] [2] [3] --1- [2] [3] -[1] -2- [3] -[1] [2] -3- --1- -2- [3] --1- [2] -3- -[1] -2- -3- --1- -2- -3- -######## -$| = 1; -foreach my $c (1,2,3) { - if (fork) { - print "parent $c\n"; - } - else { - print "child $c\n"; - exit; - } -} -while (wait() != -1) { print "waited\n" } -EXPECT -OPTION random -child 1 -child 2 -child 3 -parent 1 -parent 2 -parent 3 -waited -waited -waited -######## -use Config; -$| = 1; -$\ = "\n"; -fork() - ? print($Config{osname} eq $^O) - : print($Config{osname} eq $^O) ; -EXPECT -OPTION random -1 -1 -######## -$| = 1; -$\ = "\n"; -fork() - ? do { require Config; print($Config::Config{osname} eq $^O); } - : do { require Config; print($Config::Config{osname} eq $^O); } -EXPECT -OPTION random -1 -1 -######## -$| = 1; -use Cwd; -my $cwd = cwd(); # Make sure we load Win32.pm while "../lib" still works. -$\ = "\n"; -my $dir; -if (fork) { - $dir = "f$$.tst"; - mkdir $dir, 0755; - chdir $dir; - print cwd() =~ /\Q$dir/i ? "ok 1 parent" : "not ok 1 parent"; - chdir ".."; - rmdir $dir; -} -else { - sleep 2; - $dir = "f$$.tst"; - mkdir $dir, 0755; - chdir $dir; - print cwd() =~ /\Q$dir/i ? "ok 1 child" : "not ok 1 child"; - chdir ".."; - rmdir $dir; -} -EXPECT -OPTION random -ok 1 parent -ok 1 child -######## -$| = 1; -$\ = "\n"; -my $getenv; -if ($^O eq 'MSWin32' || $^O eq 'NetWare') { - $getenv = qq[$^X -e "print \$ENV{TST}"]; -} -else { - $getenv = qq[$^X -e 'print \$ENV{TST}']; -} -$ENV{TST} = 'foo'; -if (fork) { - sleep 1; - print "parent before: " . `$getenv`; - $ENV{TST} = 'bar'; - print "parent after: " . `$getenv`; -} -else { - print "child before: " . `$getenv`; - $ENV{TST} = 'baz'; - print "child after: " . `$getenv`; -} -EXPECT -OPTION random -child before: foo -child after: baz -parent before: foo -parent after: bar -######## -$| = 1; -$\ = "\n"; -if ($pid = fork) { - waitpid($pid,0); - print "parent got $?" -} -else { - exit(42); -} -EXPECT -OPTION random -parent got 10752 -######## -$| = 1; -$\ = "\n"; -my $echo = 'echo'; -if ($pid = fork) { - waitpid($pid,0); - print "parent got $?" -} -else { - exec("$echo foo"); -} -EXPECT -OPTION random -foo -parent got 0 -######## -if (fork) { - die "parent died"; -} -else { - die "child died"; -} -EXPECT -OPTION random -parent died at - line 2. -child died at - line 5. -######## -if ($pid = fork) { - eval { die "parent died" }; - print $@; -} -else { - eval { die "child died" }; - print $@; -} -EXPECT -OPTION random -parent died at - line 2. -child died at - line 6. -######## -if (eval q{$pid = fork}) { - eval q{ die "parent died" }; - print $@; -} -else { - eval q{ die "child died" }; - print $@; -} -EXPECT -OPTION random -parent died at (eval 2) line 1. -child died at (eval 2) line 1. -######## -BEGIN { - $| = 1; - fork and exit; - print "inner\n"; -} -# XXX In emulated fork(), the child will not execute anything after -# the BEGIN block, due to difficulties in recreating the parse stacks -# and restarting yyparse() midstream in the child. This can potentially -# be overcome by treating what's after the BEGIN{} as a brand new parse. -#print "outer\n" -EXPECT -OPTION random -inner -######## -sub pipe_to_fork ($$) { - my $parent = shift; - my $child = shift; - pipe($child, $parent) or die; - my $pid = fork(); - die "fork() failed: $!" unless defined $pid; - close($pid ? $child : $parent); - $pid; -} - -if (pipe_to_fork('PARENT','CHILD')) { - # parent - print PARENT "pipe_to_fork\n"; - close PARENT; -} -else { - # child - while () { print; } - close CHILD; - exit; -} - -sub pipe_from_fork ($$) { - my $parent = shift; - my $child = shift; - pipe($parent, $child) or die; - my $pid = fork(); - die "fork() failed: $!" unless defined $pid; - close($pid ? $child : $parent); - $pid; -} - -if (pipe_from_fork('PARENT','CHILD')) { - # parent - while () { print; } - close PARENT; -} -else { - # child - print CHILD "pipe_from_fork\n"; - close CHILD; - exit; -} -EXPECT -OPTION random -pipe_from_fork -pipe_to_fork -######## -$|=1; -if ($pid = fork()) { - print "forked first kid\n"; - print "waitpid() returned ok\n" if waitpid($pid,0) == $pid; -} -else { - print "first child\n"; - exit(0); -} -if ($pid = fork()) { - print "forked second kid\n"; - print "wait() returned ok\n" if wait() == $pid; -} -else { - print "second child\n"; - exit(0); -} -EXPECT -OPTION random -forked first kid -first child -waitpid() returned ok -forked second kid -second child -wait() returned ok -######## -pipe(RDR,WTR) or die $!; -my $pid = fork; -die "fork: $!" if !defined $pid; -if ($pid == 0) { - close RDR; - print WTR "STRING_FROM_CHILD\n"; - close WTR; -} else { - close WTR; - chomp(my $string_from_child = ); - close RDR; - print $string_from_child eq "STRING_FROM_CHILD", "\n"; -} -EXPECT -OPTION random -1 -######## -# [perl #39145] Perl_dounwind() crashing with Win32's fork() emulation -sub { @_ = 3; fork ? die "1\n" : die "1\n" }->(2); -EXPECT -OPTION random -1 -1 -######## -# [perl #72604] @DB::args stops working across Win32 fork -$|=1; -sub f { - if ($pid = fork()) { - print "waitpid() returned ok\n" if waitpid($pid,0) == $pid; - } - else { - package DB; - my @c = caller(0); - print "child: called as [$c[3](", join(',',@DB::args), ")]\n"; - exit(0); - } -} -f("foo", "bar"); -EXPECT -OPTION random -child: called as [main::f(foo,bar)] -waitpid() returned ok -######## -# Windows 2000: https://rt.cpan.org/Ticket/Display.html?id=66016#txn-908976 -system $^X, "-e", "if (\$pid=fork){sleep 1;kill(9, \$pid)} else {sleep 5}"; -print $?>>8, "\n"; -EXPECT -0 -######## -# Windows 7: https://rt.cpan.org/Ticket/Display.html?id=66016#txn-908976 -system $^X, "-e", "if (\$pid=fork){kill(9, \$pid)} else {sleep 5}"; -print $?>>8, "\n"; -EXPECT -0 -######## -# Windows fork() emulation: can we still waitpid() after signalling SIGTERM? -$|=1; -if (my $pid = fork) { - sleep 1; - print "1\n"; - kill 'TERM', $pid; - waitpid($pid, 0); - print "4\n"; -} -else { - $SIG{TERM} = sub { print "2\n" }; - sleep 3; - print "3\n"; -} -EXPECT -1 -2 -3 -4 diff --git a/t/CORE/op/getpid.t b/t/CORE/op/getpid.t deleted file mode 100644 index 0fef19ddf..000000000 --- a/t/CORE/op/getpid.t +++ /dev/null @@ -1,26 +0,0 @@ -#!perl -w - -# Tests if $$ and getppid return consistent values across threads - -BEGIN { - unshift @INC, "./lib"; - require 't/CORE/test.pl'; -} - -use strict; -use Config; - -INIT { - plan tests => 3; - eval 'use threads; use threads::shared'; - skip_all("unable to load thread modules") if $@; -} - -my ($pid, $ppid) = ($$, getppid()); -my $pid2 : shared = 0; -my $ppid2 : shared = 0; - -new threads( sub { ($pid2, $ppid2) = ($$, getppid()); } ) -> join(); - -is($pid, $pid2, 'pids'); -is($ppid, $ppid2, 'ppids'); diff --git a/t/CORE/op/getppid.t b/t/CORE/op/getppid.t deleted file mode 100644 index 1fcf95670..000000000 --- a/t/CORE/op/getppid.t +++ /dev/null @@ -1,68 +0,0 @@ -#!./perl - -# Test that getppid() follows UNIX semantics: when the parent process -# dies, the child is reparented to the init process -# The init process is usually 1, but doesn't have to be, and there's no -# standard way to find out what it is, so the only portable way to go it so -# attempt 2 reparentings and see if the PID both orphaned grandchildren get is -# the same. (and not ours) - -BEGIN { - require 't/CORE/test.pl'; -} - -use strict; -plan(8); - -sub fork_and_retrieve { - my $which = shift; - pipe my ($r, $w) or die "pipe: $!\n"; - my $pid = fork; defined $pid or die "fork: $!\n"; - - if ($pid) { - # parent - close $w; - $_ = <$r>; - chomp; - die "Garbled output '$_'" - unless my ($first, $second) = /^(\d+),(\d+)\z/; - cmp_ok ($first, '>=', 1, "Parent of $which grandchild"); - cmp_ok ($second, '>=', 1, "New parent of orphaned $which grandchild"); - SKIP: { - skip("Orphan processes are not reparented on QNX", 1) - if $^O eq 'nto'; - isnt($first, $second, - "Orphaned $which grandchild got a new parent"); - } - return $second; - } - else { - # child - # Prevent test.pl from thinking that we failed to run any tests. - $::NO_ENDING = 1; - close $r; - - my $pid2 = fork; defined $pid2 or die "fork: $!\n"; - if ($pid2) { - close $w; - sleep 1; - } - else { - # grandchild - my $ppid1 = getppid(); - # Wait for immediate parent to exit - sleep 2; - my $ppid2 = getppid(); - print $w "$ppid1,$ppid2\n"; - } - exit 0; - } -} - -my $first = fork_and_retrieve("first"); -my $second = fork_and_retrieve("second"); -SKIP: { - skip ("Orphan processes are not reparented on QNX", 1) if $^O eq 'nto'; - is ($first, $second, "Both orphaned grandchildren get the same new parent"); -} -isnt ($first, $$, "And that new parent isn't this process"); diff --git a/t/CORE/op/gmagic.t b/t/CORE/op/gmagic.t deleted file mode 100644 index 7dfdc27b4..000000000 --- a/t/CORE/op/gmagic.t +++ /dev/null @@ -1,103 +0,0 @@ -#!./perl -w - -BEGIN { - unshift @INC, 't/CORE/lib'; - require 't/CORE/test.pl'; -} - -use strict; - -tie my $c => 'Tie::Monitor'; - -sub expected_tie_calls { - my ($obj, $rexp, $wexp) = @_; - local $::Level = $::Level + 1; - my ($rgot, $wgot) = $obj->init(); - is ($rgot, $rexp); - is ($wgot, $wexp); -} - -# Use ok() instead of is(), cmp_ok() etc, to strictly control number of accesses -my($r, $s); -ok($r = $c + 0 == 0, 'the thing itself'); -expected_tie_calls(tied $c, 1, 0); -ok($r = "$c" eq '0', 'the thing itself'); -expected_tie_calls(tied $c, 1, 0); - -ok($c . 'x' eq '0x', 'concat'); -expected_tie_calls(tied $c, 1, 0); -ok('x' . $c eq 'x0', 'concat'); -expected_tie_calls(tied $c, 1, 0); -$s = $c . $c; -ok($s eq '00', 'concat'); -expected_tie_calls(tied $c, 2, 0); -$r = 'x'; -$s = $c = $r . 'y'; -ok($s eq 'xy', 'concat'); -expected_tie_calls(tied $c, 1, 1); -$s = $c = $c . 'x'; -ok($s eq '0x', 'concat'); -expected_tie_calls(tied $c, 2, 1); -$s = $c = 'x' . $c; -ok($s eq 'x0', 'concat'); -expected_tie_calls(tied $c, 2, 1); -$s = $c = $c . $c; -ok($s eq '00', 'concat'); -expected_tie_calls(tied $c, 3, 1); - -$s = chop($c); -ok($s eq '0', 'multiple magic in core functions'); -expected_tie_calls(tied $c, 1, 1); - -# was a glob -my $tied_to = tied $c; -$c = *strat; -$s = $c; -ok($s eq *strat, - 'Assignment should not ignore magic when the last thing assigned was a glob'); -expected_tie_calls($tied_to, 1, 1); - -# A plain *foo should not call get-magic on *foo. -# This method of scalar-tying an immutable glob relies on details of the -# current implementation that are subject to change. This test may need to -# be rewritten if they do change. -my $tyre = tie $::{gelp} => 'Tie::Monitor'; -# Compilation of this eval autovivifies the *gelp glob. -eval '$tyre->init(0); () = \*gelp'; -my($rgot, $wgot) = $tyre->init(0); -ok($rgot == 0, 'a plain *foo causes no get-magic'); -ok($wgot == 0, 'a plain *foo causes no set-magic'); - -done_testing(); - -# adapted from Tie::Counter by Abigail -package Tie::Monitor; - -sub TIESCALAR { - my($class, $value) = @_; - bless { - read => 0, - write => 0, - values => [ 0 ], - }; -} - -sub FETCH { - my $self = shift; - ++$self->{read}; - $self->{values}[$#{ $self->{values} }]; -} - -sub STORE { - my($self, $value) = @_; - ++$self->{write}; - push @{ $self->{values} }, $value; -} - -sub init { - my $self = shift; - my @results = ($self->{read}, $self->{write}); - $self->{read} = $self->{write} = 0; - $self->{values} = [ 0 ]; - @results; -} diff --git a/t/CORE/op/goto.t b/t/CORE/op/goto.t deleted file mode 100644 index bdf92165d..000000000 --- a/t/CORE/op/goto.t +++ /dev/null @@ -1,597 +0,0 @@ -#!./perl - -# "This IS structured code. It's just randomly structured." - -BEGIN { - require 't/CORE/test.pl'; -} - -use warnings; -use strict; -plan(tests => 77 - 1); -our $TODO; - -my $deprecated = 0; -local $SIG{__WARN__} = sub { if ($_[0] =~ m/jump into a construct/) { $deprecated++; } else { warn $_[0] } }; - -our $foo; -while ($?) { - $foo = 1; - label1: - is($deprecated, 1); - $deprecated = 0; - $foo = 2; - goto label2; -} continue { - $foo = 0; - goto label4; - label3: - is($deprecated, 1); - $deprecated = 0; - $foo = 4; - goto label4; -} -is($deprecated, 0); -goto label1; - -$foo = 3; - -label2: -is($foo, 2, 'escape while loop'); -is($deprecated, 0); -goto label3; - -label4: -is($foo, 4, 'second escape while loop'); - -my $r = run_perl(prog => 'goto foo;', stderr => 1); -like($r, qr/label/, 'cant find label'); - -my $ok = 0; -sub foo { - goto bar; - return; -bar: - $ok = 1; -} - -&foo; -ok($ok, 'goto in sub'); - -sub bar { - my $x = 'bypass'; - eval "goto $x"; -} - -&bar; -exit; - -FINALE: -is(curr_test(), 20, 'FINALE'); - -# does goto LABEL handle block contexts correctly? -# note that this scope-hopping differs from last & next, -# which always go up-scope strictly. -my $count = 0; -my $cond = 1; -for (1) { - if ($cond == 1) { - $cond = 0; - goto OTHER; - } - elsif ($cond == 0) { - OTHER: - $cond = 2; - is($count, 0, 'OTHER'); - $count++; - goto THIRD; - } - else { - THIRD: - is($count, 1, 'THIRD'); - $count++; - } -} -is($count, 2, 'end of loop'); - -# Does goto work correctly within a for(;;) loop? -# (BUG ID 20010309.004) - -for(my $i=0;!$i++;) { - my $x=1; - goto label; - label: is($x, 1, 'goto inside a for(;;) loop body from inside the body'); -} - -# Does goto work correctly going *to* a for(;;) loop? -# (make sure it doesn't skip the initializer) - -my ($z, $y) = (0); -FORL1: for ($y=1; $z;) { - ok($y, 'goto a for(;;) loop, from outside (does initializer)'); - goto TEST19} -($y,$z) = (0, 1); -goto FORL1; - -# Even from within the loop? -TEST19: $z = 0; -FORL2: for($y=1; 1;) { - if ($z) { - ok($y, 'goto a for(;;) loop, from inside (does initializer)'); - last; - } - ($y, $z) = (0, 1); - goto FORL2; -} - -# Does goto work correctly within a try block? -# (BUG ID 20000313.004) - [perl #2359] -$ok = 0; -eval { - my $variable = 1; - goto LABEL20; - LABEL20: $ok = 1 if $variable; -}; -ok($ok, 'works correctly within a try block'); -is($@, "", '...and $@ not set'); - -# And within an eval-string? -$ok = 0; -eval q{ - my $variable = 1; - goto LABEL21; - LABEL21: $ok = 1 if $variable; -}; -ok($ok, 'works correctly within an eval string'); -is($@, "", '...and $@ still not set'); - - -# Test that goto works in nested eval-string -$ok = 0; -{eval q{ - eval q{ - goto LABEL22; - }; - $ok = 0; - last; - - LABEL22: $ok = 1; -}; -$ok = 0 if $@; -} -ok($ok, 'works correctly in a nested eval string'); - -{ - my $false = 0; - my $count; - - $ok = 0; - { goto A; A: $ok = 1 } continue { } - ok($ok, '#20357 goto inside /{ } continue { }/ loop'); - - $ok = 0; - { do { goto A; A: $ok = 1 } while $false } - ok($ok, '#20154 goto inside /do { } while ()/ loop'); - $ok = 0; - foreach(1) { goto A; A: $ok = 1 } continue { }; - ok($ok, 'goto inside /foreach () { } continue { }/ loop'); - - $ok = 0; - sub a { - A: { if ($false) { redo A; B: $ok = 1; redo A; } } - goto B unless $count++; - } - is($deprecated, 0); - a(); - ok($ok, '#19061 loop label wiped away by goto'); - is($deprecated, 1); - $deprecated = 0; - - $ok = 0; - my $p; - for ($p=1;$p && goto A;$p=0) { A: $ok = 1 } - ok($ok, 'weird case of goto and for(;;) loop'); - is($deprecated, 1); - $deprecated = 0; -} - -# bug #9990 - don't prematurely free the CV we're &going to. - -sub f1 { - my $x; - goto sub { $x=0; ok(1,"don't prematurely free CV\n") } -} -f1(); - -# bug #22181 - this used to coredump or make $x undefined, due to -# erroneous popping of the inner BLOCK context - -undef $ok; -for ($count=0; $count<2; $count++) { - my $x = 1; - goto LABEL29; - LABEL29: - $ok = $x; -} -is($ok, 1, 'goto in for(;;) with continuation'); - -# bug #22299 - goto in require doesn't find label - -open my $f, ">Op_goto01.pm" or die; -print $f <<'EOT'; -package goto01; -goto YYY; -die; -YYY: print "OK\n"; -1; -EOT -close $f; - -$r = runperl(prog => 'use Op_goto01; print qq[DONE\n]'); -is($r, "OK\nDONE\n", "goto within use-d file"); -unlink_all("Op_goto01.pm"); - -# test for [perl #24108] -$ok = 1; -$count = 0; -sub i_return_a_label { - $count++; - return "returned_label"; -} -eval { goto +i_return_a_label; }; -$ok = 0; - -returned_label: -is($count, 1, 'called i_return_a_label'); -ok($ok, 'skipped to returned_label'); - -# [perl #29708] - goto &foo could leave foo() at depth two with -# @_ == PL_sv_undef, causing a coredump - - -$r = runperl( - prog => - 'sub f { return if $d; $d=1; my $a=sub {goto &f}; &$a; f() } f(); print qq(ok\n)', - stderr => 1 - ); -is($r, "ok\n", 'avoid pad without an @_'); - -goto moretests; -fail('goto moretests'); -exit; - -bypass: - -is(curr_test(), 9, 'eval "goto $x"'); - -# Test autoloading mechanism. - -sub two { - my ($pack, $file, $line) = caller; # Should indicate original call stats. - is("@_ $pack $file $line", "1 2 3 main $::FILE $::LINE", - 'autoloading mechanism.'); -} - -sub one { - eval <<'END'; - no warnings 'redefine'; - sub one { pass('sub one'); goto &two; fail('sub one tail'); } -END - goto &one; -} - -$::FILE = __FILE__; -$::LINE = __LINE__ + 1; -&one(1,2,3); - -{ - my $wherever = 'NOWHERE'; - eval { goto $wherever }; - like($@, qr/Can't find label NOWHERE/, 'goto NOWHERE sets $@'); -} - -# see if a modified @_ propagates -{ - my $i; - package Foo; - sub DESTROY { my $s = shift; ::is($s->[0], $i, "destroy $i"); } - sub show { ::is(+@_, 5, "show $i",); } - sub start { push @_, 1, "foo", {}; goto &show; } - for (1..3) { $i = $_; start(bless([$_]), 'bar'); } -} - -sub auto { - goto &loadit; -} - -sub AUTOLOAD { $ok = 1 if "@_" eq "foo" } - -$ok = 0; -auto("foo"); -ok($ok, 'autoload'); - -{ - my $wherever = 'FINALE'; - goto $wherever; -} -fail('goto $wherever'); - -moretests: -# test goto duplicated labels. -{ - my $z = 0; - eval { - $z = 0; - for (0..1) { - L4: # not outer scope - $z += 10; - last; - } - goto L4 if $z == 10; - last; - }; - like($@, qr/Can't "goto" into the middle of a foreach loop/, - 'catch goto middle of foreach'); - - $z = 0; - # ambiguous label resolution (outer scope means endless loop!) - L1: - for my $x (0..1) { - $z += 10; - is($z, 10, 'prefer same scope (loop body) to outer scope (loop entry)'); - goto L1 unless $x; - $z += 10; - L1: - is($z, 10, 'prefer same scope: second'); - last; - } - - $z = 0; - L2: - { - $z += 10; - is($z, 10, 'prefer this scope (block body) to outer scope (block entry)'); - goto L2 if $z == 10; - $z += 10; - L2: - is($z, 10, 'prefer this scope: second'); - } - - - { - $z = 0; - while (1) { - L3: # not inner scope - $z += 10; - last; - } - is($z, 10, 'prefer this scope to inner scope'); - goto L3 if $z == 10; - $z += 10; - L3: # this scope ! - is($z, 10, 'prefer this scope to inner scope: second'); - } - - L4: # not outer scope - { - $z = 0; - while (1) { - L4: # not inner scope - $z += 1; - last; - } - is($z, 1, 'prefer this scope to inner,outer scopes'); - goto L4 if $z == 1; - $z += 10; - L4: # this scope ! - is($z, 1, 'prefer this scope to inner,outer scopes: second'); - } - - { - my $loop = 0; - for my $x (0..1) { - L2: # without this, fails 1 (middle) out of 3 iterations - $z = 0; - L2: - $z += 10; - is($z, 10, - "same label, multiple times in same scope (choose 1st) $loop"); - goto L2 if $z == 10 and not $loop++; - } - } -} - -# deep recursion with gotos eventually caused a stack reallocation -# which messed up buggy internals that didn't expect the stack to move - -sub recurse1 { - unshift @_, "x"; - no warnings 'recursion'; - goto &recurse2; -} -sub recurse2 { - my $x = shift; - $_[0] ? +1 + recurse1($_[0] - 1) : 0 -} -is(recurse1(500), 500, 'recursive goto &foo'); - -# [perl #32039] Chained goto &sub drops data too early. - -sub a32039 { @_=("foo"); goto &b32039; } -sub b32039 { goto &c32039; } -sub c32039 { is($_[0], 'foo', 'chained &goto') } -a32039(); - -# [perl #35214] next and redo re-entered the loop with the wrong cop, -# causing a subsequent goto to crash - -{ - my $r = runperl( - stderr => 1, - prog => -'for ($_=0;$_<3;$_++){A: if($_==1){next} if($_==2){$_++;goto A}}print qq(ok\n)' - ); - is($r, "ok\n", 'next and goto'); - - $r = runperl( - stderr => 1, - prog => -'for ($_=0;$_<3;$_++){A: if($_==1){$_++;redo} if($_==2){$_++;goto A}}print qq(ok\n)' - ); - is($r, "ok\n", 'redo and goto'); -} - -# goto &foo not allowed in evals - - -sub null { 1 }; -eval 'goto &null'; -like($@, qr/Can't goto subroutine from an eval-string/, 'eval string'); -eval { goto &null }; -like($@, qr/Can't goto subroutine from an eval-block/, 'eval block'); - -# [perl #36521] goto &foo in warn handler could defeat recursion avoider - -{ - my $r = runperl( - stderr => 1, - prog => 'my $d; my $w = sub { return if $d++; warn q(bar)}; local $SIG{__WARN__} = sub { goto &$w; }; warn q(foo);' - ); - like($r, qr/bar/, "goto &foo in warn"); -} - -=pod -TODO: { - local $TODO = "[perl #43403] goto() from an if to an else doesn't undo local () changes"; - our $global = "unmodified"; - if ($global) { # true but not constant-folded - local $global = "modified"; - goto ELSE; - } else { - ELSE: is($global, "unmodified"); - } -} -=cut - -is($deprecated, 0); - -#74290 -{ - my $x; - my $y; - F1:++$x and eval 'return if ++$y == 10; goto F1;'; - is($x, 10, - 'labels outside evals can be distinguished from the start of the eval'); -} - -goto wham_eth; -die "You can't get here"; - -wham_eth: 1 if 0; -ouch_eth: pass('labels persist even if their statement is optimised away'); - -$foo = "(0)"; -if($foo eq $foo) { - goto bungo; -} -$foo .= "(9)"; -bungo: -format CHOLET = -wellington -. -$foo .= "(1)"; -{ - my $cholet; - open(CHOLET, ">", \$cholet); - write CHOLET; - close CHOLET; - $foo .= "(".$cholet.")"; - is($foo, "(0)(1)(wellington\n)", "label before format decl"); -} - -$foo = "(A)"; -if($foo eq $foo) { - goto orinoco; -} -$foo .= "(X)"; -orinoco: -sub alderney { return "tobermory"; } -$foo .= "(B)"; -$foo .= "(".alderney().")"; -is($foo, "(A)(B)(tobermory)", "label before sub decl"); - -$foo = "[0:".__PACKAGE__."]"; -if($foo eq $foo) { - goto bulgaria; -} -$foo .= "[9]"; -bulgaria: -package Tomsk; -$foo .= "[1:".__PACKAGE__."]"; -$foo .= "[2:".__PACKAGE__."]"; -package main; -$foo .= "[3:".__PACKAGE__."]"; -is($foo, "[0:main][1:Tomsk][2:Tomsk][3:main]", "label before package decl"); - -$foo = "[A:".__PACKAGE__."]"; -if($foo eq $foo) { - goto adelaide; -} -$foo .= "[Z]"; -adelaide: -package Cairngorm { - $foo .= "[B:".__PACKAGE__."]"; -} -$foo .= "[C:".__PACKAGE__."]"; -is($foo, "[A:main][B:Cairngorm][C:main]", "label before package block"); - -our $obidos; -$foo = "{0}"; -if($foo eq $foo) { - goto shansi; -} -$foo .= "{9}"; -shansi: -BEGIN { $obidos = "x"; } -$foo .= "{1$obidos}"; -is($foo, "{0}{1x}", "label before BEGIN block"); - -$foo = "{A:".(1.5+1.5)."}"; -if($foo eq $foo) { - goto stepney; -} -$foo .= "{Z}"; -stepney: -use integer; -$foo .= "{B:".(1.5+1.5)."}"; -is($foo, "{A:3}{B:2}", "label before use decl"); - -$foo = "<0>"; -if($foo eq $foo) { - goto tom; -} -$foo .= "<9>"; -tom: dick: harry: -$foo .= "<1>"; -$foo .= "<2>"; -is($foo, "<0><1><2>", "first of three stacked labels"); - -$foo = ""; -if($foo eq $foo) { - goto beta; -} -$foo .= ""; -alpha: beta: gamma: -$foo .= ""; -$foo .= ""; -is($foo, "", "second of three stacked labels"); - -$foo = ",0."; -if($foo eq $foo) { - goto gimel; -} -$foo .= ",9."; -alef: bet: gimel: -$foo .= ",1."; -$foo .= ",2."; -is($foo, ",0.,1.,2.", "third of three stacked labels"); diff --git a/t/CORE/op/grent.t b/t/CORE/op/grent.t deleted file mode 100644 index 13bbcea69..000000000 --- a/t/CORE/op/grent.t +++ /dev/null @@ -1,187 +0,0 @@ -#!./perl - -INIT { - unshift @INC, 't/CORE/lib'; - require 't/CORE/test.pl'; -} - -eval {my @n = getgrgid 0}; -if ($@ =~ /(The \w+ function is unimplemented)/) { - skip_all("getgrgid unimplemented"); -} - -eval { require Config; import Config; }; -my $reason; -if ($Config{'i_grp'} ne 'define') { - $reason = '$Config{i_grp} not defined'; -} -elsif (not -f "/etc/group" ) { # Play safe. - $reason = 'no /etc/group file'; -} - -if (not defined $where) { # Try NIS. - foreach my $ypcat (qw(/usr/bin/ypcat /bin/ypcat /etc/ypcat)) { - if (-x $ypcat && - open(GR, "$ypcat group 2>/dev/null |") && - defined()) - { - print "# `ypcat group` worked\n"; - - # Check to make sure we're really using NIS. - if( open(NSSW, "/etc/nsswitch.conf" ) ) { - my($group) = grep /^\s*group:/, ; - - # If there's no group line, assume it default to compat. - if( !$group || $group !~ /(nis|compat)/ ) { - print "# Doesn't look like you're using NIS in ". - "/etc/nsswitch.conf\n"; - last; - } - } - $where = "NIS group - $ypcat"; - undef $reason; - last; - } - } -} - -if (not defined $where) { # Try NetInfo. - foreach my $nidump (qw(/usr/bin/nidump)) { - if (-x $nidump && - open(GR, "$nidump group . 2>/dev/null |") && - defined()) - { - $where = "NetInfo group - $nidump"; - undef $reason; - last; - } - } -} - -if (not defined $where) { # Try local. - my $GR = "/etc/group"; - if (-f $GR && open(GR, $GR) && defined()) { - undef $reason; - $where = "local $GR"; - } -} - -if ($reason) { - skip_all($reason); -} - - -# By now the GR filehandle should be open and full of juicy group entries. - -plan(tests => 3); - -# Go through at most this many groups. -# (note that the first entry has been read away by now) -my $max = 25; - -my $n = 0; -my $tst = 1; -my %perfect; -my %seen; - -print "# where $where\n"; - -ok( setgrent(), 'setgrent' ) || print "# $!\n"; - -while () { - chomp; - # LIMIT -1 so that groups with no users don't fall off - my @s = split /:/, $_, -1; - my ($name_s,$passwd_s,$gid_s,$members_s) = @s; - if (@s) { - push @{ $seen{$name_s} }, $.; - } else { - warn "# Your $where line $. is empty.\n"; - next; - } - if ($n == $max) { - local $/; - my $junk = ; - last; - } - # In principle we could whine if @s != 4 but do we know enough - # of group file formats everywhere? - if (@s == 4) { - $members_s =~ s/\s*,\s*/,/g; - $members_s =~ s/\s+$//; - $members_s =~ s/^\s+//; - @n = getgrgid($gid_s); - # 'nogroup' et al. - next unless @n; - my ($name,$passwd,$gid,$members) = @n; - # Protect against one-to-many and many-to-one mappings. - if ($name_s ne $name) { - @n = getgrnam($name_s); - ($name,$passwd,$gid,$members) = @n; - next if $name_s ne $name; - } - # NOTE: group names *CAN* contain whitespace. - $members =~ s/\s+/,/g; - # what about different orders of members? - $perfect{$name_s}++ - if $name eq $name_s and -# Do not compare passwords: think shadow passwords. -# Not that group passwords are used much but better not assume anything. - $gid eq $gid_s and - $members eq $members_s; - } - $n++; -} - -endgrent(); - -print "# max = $max, n = $n, perfect = ", scalar keys %perfect, "\n"; - -if (keys %perfect == 0 && $n) { - $max++; - print < 61 ); - -{ - my @lol = ([qw(a b c)], [], [qw(1 2 3)]); - my @mapped = map {scalar @$_} @lol; - cmp_ok("@mapped", 'eq', "3 0 3", 'map scalar list of list'); - - my @grepped = grep {scalar @$_} @lol; - cmp_ok("@grepped", 'eq', "$lol[0] $lol[2]", 'grep scalar list of list'); - $test++; - - @grepped = grep { $_ } @mapped; - cmp_ok( "@grepped", 'eq', "3 3", 'grep basic'); -} - -{ - my @res; - - @res = map({$_} ("geronimo")); - cmp_ok( scalar(@res), '==', 1, 'basic map nr'); - cmp_ok( $res[0], 'eq', 'geronimo', 'basic map is'); - - @res = map - ({$_} ("yoyodyne")); - cmp_ok( scalar(@res), '==', 1, 'linefeed map nr'); - cmp_ok( $res[0], 'eq', 'yoyodyne', 'linefeed map is'); - - @res = (map( - {a =>$_}, - ("chobb")))[0]->{a}; - cmp_ok( scalar(@res), '==', 1, 'deref map nr'); - cmp_ok( $res[0], 'eq', 'chobb', 'deref map is'); - - @res = map {$_} ("geronimo"); - cmp_ok( scalar(@res), '==', 1, 'no paren basic map nr'); - cmp_ok( $res[0], 'eq', 'geronimo', 'no paren basic map is'); - - @res = map - {$_} ("yoyodyne"); - cmp_ok( scalar(@res), '==', 1, 'no paren linefeed map nr'); - cmp_ok( $res[0], 'eq', 'yoyodyne', 'no paren linefeed map is'); - - @res = (map - {a =>$_}, - ("chobb"))[0]->{a}; - cmp_ok( scalar(@res), '==', 1, 'no paren deref map nr'); - cmp_ok( $res[0], 'eq', 'chobb', 'no paren deref map is'); - - my $x = "\xFF\xFF\xFF\xFF\xFF\xFF\xFF\n"; - - @res = map($_&$x,("sferics\n")); - cmp_ok( scalar(@res), '==', 1, 'binand map nr 1'); - cmp_ok( $res[0], 'eq', "sferics\n", 'binand map is 1'); - - @res = map - ($_ & $x, ("sferics\n")); - cmp_ok( scalar(@res), '==', 1, 'binand map nr 2'); - cmp_ok( $res[0], 'eq', "sferics\n", 'binand map is 2'); - - @res = map { $_ & $x } ("sferics\n"); - cmp_ok( scalar(@res), '==', 1, 'binand map nr 3'); - cmp_ok( $res[0], 'eq', "sferics\n", 'binand map is 3'); - - @res = map - { $_&$x } ("sferics\n"); - cmp_ok( scalar(@res), '==', 1, 'binand map nr 4'); - cmp_ok( $res[0], 'eq', "sferics\n", 'binand map is 4'); - - @res = grep({$_} ("geronimo")); - cmp_ok( scalar(@res), '==', 1, 'basic grep nr'); - cmp_ok( $res[0], 'eq', 'geronimo', 'basic grep is'); - - @res = grep - ({$_} ("yoyodyne")); - cmp_ok( scalar(@res), '==', 1, 'linefeed grep nr'); - cmp_ok( $res[0], 'eq', 'yoyodyne', 'linefeed grep is'); - - @res = grep - ({a=>$_}->{a}, - ("chobb")); - cmp_ok( scalar(@res), '==', 1, 'deref grep nr'); - cmp_ok( $res[0], 'eq', 'chobb', 'deref grep is'); - - @res = grep {$_} ("geronimo"); - cmp_ok( scalar(@res), '==', 1, 'no paren basic grep nr'); - cmp_ok( $res[0], 'eq', 'geronimo', 'no paren basic grep is'); - - @res = grep - {$_} ("yoyodyne"); - cmp_ok( scalar(@res), '==', 1, 'no paren linefeed grep nr'); - cmp_ok( $res[0], 'eq', 'yoyodyne', 'no paren linefeed grep is'); - - @res = grep {a=>$_}->{a}, ("chobb"); - cmp_ok( scalar(@res), '==', 1, 'no paren deref grep nr'); - cmp_ok( $res[0], 'eq', 'chobb', 'no paren deref grep is'); - - @res = grep - {a=>$_}->{a}, ("chobb"); - cmp_ok( scalar(@res), '==', 1, 'no paren deref linefeed nr'); - cmp_ok( $res[0], 'eq', 'chobb', 'no paren deref linefeed is'); - - @res = grep($_&"X", ("bodine")); - cmp_ok( scalar(@res), '==', 1, 'binand X grep nr'); - cmp_ok( $res[0], 'eq', 'bodine', 'binand X grep is'); - - @res = grep - ($_&"X", ("bodine")); - cmp_ok( scalar(@res), '==', 1, 'binand X linefeed grep nr'); - cmp_ok( $res[0], 'eq', 'bodine', 'binand X linefeed grep is'); - - @res = grep {$_&"X"} ("bodine"); - cmp_ok( scalar(@res), '==', 1, 'no paren binand X grep nr'); - cmp_ok( $res[0], 'eq', 'bodine', 'no paren binand X grep is'); - - @res = grep - {$_&"X"} ("bodine"); - cmp_ok( scalar(@res), '==', 1, 'no paren binand X linefeed grep nr'); - cmp_ok( $res[0], 'eq', 'bodine', 'no paren binand X linefeed grep is'); -} - -{ - # Tests for "for" in "map" and "grep" - # Used to dump core, bug [perl #17771] - - my @x; - my $y = ''; - @x = map { $y .= $_ for 1..2; 1 } 3..4; - cmp_ok( "@x,$y",'eq',"1 1,1212", '[perl #17771] for in map 1'); - - $y = ''; - @x = map { $y .= $_ for 1..2; $y .= $_ } 3..4; - cmp_ok( "@x,$y",'eq',"123 123124,123124", '[perl #17771] for in map 2'); - - $y = ''; - @x = map { for (1..2) { $y .= $_ } $y .= $_ } 3..4; - cmp_ok( "@x,$y",'eq',"123 123124,123124", '[perl #17771] for in map 3'); - - $y = ''; - @x = grep { $y .= $_ for 1..2; 1 } 3..4; - cmp_ok( "@x,$y",'eq',"3 4,1212", '[perl #17771] for in grep 1'); - - $y = ''; - @x = grep { for (1..2) { $y .= $_ } 1 } 3..4; - cmp_ok( "@x,$y",'eq',"3 4,1212", '[perl #17771] for in grep 2'); - - # Add also a sample test from [perl #18153]. (The same bug). - $a = 1; map {if ($a){}} (2); - pass( '[perl #18153] (not dead yet)' ); # no core dump is all we need -} - -{ - sub add_an_x(@){ - map {"${_}x"} @_; - }; - cmp_ok( join("-",add_an_x(1,2,3,4)), 'eq', "1x-2x-3x-4x", 'add-an-x'); -} - -{ - my $gimme; - - sub gimme { - my $want = wantarray(); - if (defined $want) { - $gimme = $want ? 'list' : 'scalar'; - } else { - $gimme = 'void'; - } - } - - my @list = 0..9; - - undef $gimme; gimme for @list; cmp_ok($gimme, 'eq', 'void', 'gimme a V!'); - undef $gimme; grep { gimme } @list; cmp_ok($gimme, 'eq', 'scalar', 'gimme an S!'); - undef $gimme; map { gimme } @list; cmp_ok($gimme, 'eq', 'list', 'gimme an L!'); -} - -{ - # test scalar context return - my @list = (7, 14, 21); - - my $x = map {$_ *= 2} @list; - cmp_ok("@list", 'eq', "14 28 42", 'map scalar return'); - cmp_ok($x, '==', 3, 'map scalar count'); - - @list = (9, 16, 25, 36); - $x = grep {$_ % 2} @list; - cmp_ok($x, '==', 2, 'grep scalar count'); - - my @res = grep {$_ % 2} @list; - cmp_ok("@res", 'eq', "9 25", 'grep extract'); -} - -{ - # This shouldn't loop indefinitely. - my @empty = map { while (1) {} } (); - cmp_ok("@empty", 'eq', '', 'staying alive'); -} - -{ - my $x; - eval 'grep $x (1,2,3);'; - like($@, qr/Missing comma after first argument to grep function/, - "proper error on variable as block. [perl #37314]"); -} diff --git a/t/CORE/op/groups.t b/t/CORE/op/groups.t deleted file mode 100644 index 930a5a28a..000000000 --- a/t/CORE/op/groups.t +++ /dev/null @@ -1,407 +0,0 @@ -#!./perl -INIT { - if ( $^O eq 'VMS' ) { - my $p = "/bin:/usr/bin:/usr/xpg4/bin:/usr/ucb"; - if ( $ENV{PATH} ) { - $p .= ":$ENV{PATH}"; - } - $ENV{PATH} = $p; - } - $ENV{LC_ALL} = "C"; # so that external utilities speak English - $ENV{LANGUAGE} = 'C'; # GNU locale extension - - unshift @INC, 't/CORE/lib'; - require 't/CORE/test.pl'; -} -use 5.010; -use strict; -use Config (); -use POSIX (); - -skip_all('getgrgid() not implemented') - unless eval { my($foo) = getgrgid(0); 1 }; - -skip_all("No 'id' or 'groups'") if - $^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'VMS' || $^O =~ /lynxos/i; - -Test(); -exit; - - - -sub Test { - - # Get our supplementary groups from the system by running commands - # like `id -a'. - my ( $groups_command, $groups_string ) = system_groups() - or skip_all("No 'id' or 'groups'"); - my @extracted_groups = extract_system_groups( $groups_string ) - or skip_all("Can't parse '${groups_command}'"); - - my $pwgid = $( + 0; - my ($pwgnam) = getgrgid($pwgid); - $pwgnam //= ''; - print "# pwgid=$pwgid pwgnam=$pwgnam \$(=$(\n"; - - # Get perl's supplementary groups by looking at $( - my ( $gid_count, $all_perl_groups ) = perl_groups(); - my %basegroup = basegroups( $pwgid, $pwgnam ); - my @extracted_supplementary_groups = remove_basegroup( \ %basegroup, \ @extracted_groups ); - - print "1..2\n"; - - - # Test: The supplementary groups in $( should match the - # getgroups(2) kernal API call. - # - my $ngroups_max = posix_ngroups_max(); - if ( defined $ngroups_max && $ngroups_max < @extracted_groups ) { - # Some OSes (like darwin)but conceivably others might return - # more groups from `id -a' than can be handled by the - # kernel. On darwin, NGROUPS_MAX is 16 and 12 are taken up for - # the system already. - # - # There is more fall-out from this than just Perl's unit - # tests. You may be a member of a group according to Active - # Directory (or whatever) but the OS won't respect it because - # it's the 17th (or higher) group and there's no space to - # store your membership. - print "ok 1 # SKIP Your platform's `$groups_command' is broken\n"; - } - - elsif ( darwin() ) { - # darwin uses getgrouplist(3) or an Open Directory API within - # /usr/bin/id and /usr/bin/groups which while "nice" isn't - # accurate for this test. The hard, real, list of groups we're - # running in derives from getgroups(2) and is not dynamic but - # the Libc API getgrouplist(3) is. - # - # In practical terms, this meant that while `id -a' can be - # relied on in other OSes to purely use getgroups(2) and show - # us what's real, darwin will use getgrouplist(3) to show us - # what might be real if only we'd open a new console. - # - print "ok 1 # SKIP darwin's `${groups_command}' can't be trusted\n"; - } - - else { - - # Read $( but ignore any groups in $( that we failed to parse - # successfully out of the `id -a` mess. - # - my @perl_groups = remove_unparsed_entries( \ @extracted_groups, - \ @$all_perl_groups ); - my @supplementary_groups = remove_basegroup( \ %basegroup, - \ @perl_groups ); - - my $ok1 = 0; - if ( match_groups( \ @supplementary_groups, - \ @extracted_supplementary_groups, - $pwgid ) ) { - print "ok 1\n"; - $ok1 = 1; - } - elsif ( cygwin_nt() ) { - %basegroup = unixy_cygwin_basegroups(); - @extracted_supplementary_groups = remove_basegroup( \ %basegroup, \ @extracted_groups ); - - if ( match_groups( \ @supplementary_groups, - \ @extracted_supplementary_groups, - $pwgid ) ) { - print "ok 1 # This Cygwin behaves like Unix (Win2k?)\n"; - $ok1 = 1; - } - } - - unless ( $ok1 ) { - - } - } - - # multiple 0's indicate GROUPSTYPE is currently long but should be short - $gid_count->{0} //= 0; - if ( 0 == $pwgid || $gid_count->{0} < 2 ) { - print "ok 2\n"; - } - else { - print "not ok 2 (groupstype should be type short, not long)\n"; - } - - return; -} - -# Get the system groups and the command used to fetch them. -# -sub system_groups { - my ( $cmd, $groups_string ) = _system_groups(); - - if ( $groups_string ) { - chomp $groups_string; - diag_variable( groups => $groups_string ); - } - - return ( $cmd, $groups_string ); -} - -# We have to find a command that prints all (effective -# and real) group names (not ids). The known commands are: -# groups -# id -Gn -# id -a -# Beware 1: some systems do just 'id -G' even when 'id -Gn' is used. -# Beware 2: id -Gn or id -a format might be id(name) or name(id). -# Beware 3: the groups= might be anywhere in the id output. -# Beware 4: groups can have spaces ('id -a' being the only defense against this) -# Beware 5: id -a might not contain the groups= part. -# -# That is, we might meet the following: -# -# foo bar zot # accept -# foo 22 42 bar zot # accept -# 1 22 42 2 3 # reject -# groups=(42),foo(1),bar(2),zot me(3) # parsed by $GROUP_RX1 -# groups=22,42,1(foo),2(bar),3(zot(me)) # parsed by $GROUP_RX2 -# -# and the groups= might be after, before, or between uid=... and gid=... -use constant GROUP_RX1 => qr/ - ^ - (?.+) - \( - (?\d+) - \) - $ -/x; -use constant GROUP_RX2 => qr/ - ^ - (?\d+) - \( - (?.+) - \) - $ -/x; -sub _system_groups { - my $cmd; - my $str; - - # prefer 'id' over 'groups' (is this ever wrong anywhere?) - # and 'id -a' over 'id -Gn' (the former is good about spaces in group names) - - $cmd = 'id -a 2>/dev/null || id 2>/dev/null'; - $str = `$cmd`; - if ( $str && $str =~ /groups=/ ) { - # $str is of the form: - # uid=39957(gsar) gid=22(users) groups=33536,39181,22(users),0(root),1067(dev) - # FreeBSD since 6.2 has a fake id -a: - # uid=1001(tobez) gid=20(staff) groups=20(staff), 0(wheel), 68(dialer) - # On AIX it's id - # - # Linux may also have a context= field - - return ( $cmd, $str ); - } - - $cmd = 'id -Gn 2>/dev/null'; - $str = `$cmd`; - if ( $str && $str !~ /^[\d\s]$/ ) { - # $str could be of the form: - # users 33536 39181 root dev - return ( $cmd, $str ); - } - - $cmd = 'groups 2>/dev/null'; - $str = `$cmd`; - if ( $str ) { - # may not reflect all groups in some places, so do a sanity check - if (-d '/afs') { - print < join ',', @extracted ); - } - - return @extracted; -} - -# Get the POSIX value NGROUPS_MAX. -sub posix_ngroups_max { - return eval { - POSIX::NGROUPS_MAX(); - }; -} - -# Test if this is Apple's darwin -sub darwin { - # Observed 'darwin-2level' - return $Config::Config{myuname} =~ /^darwin/; -} - -# Test if this is Cygwin -sub cygwin_nt { - return $Config::Config{myuname} =~ /^cygwin_nt/i; -} - -# Get perl's supplementary groups and the number of times each gid -# appeared. -sub perl_groups { - # Lookup perl's own groups from $( - my @gids = split ' ', $(; - my %gid_count; - my @gr_name; - for my $gid ( @gids ) { - ++ $gid_count{$gid}; - - my ($group) = getgrgid $gid; - - # Why does this test prefer to not test groups which we don't have - # a name for? One possible answer is that my primary group comes - # from from my entry in the user database but isn't mentioned in - # the group database. Are there more reasons? - next if ! defined $group; - - - push @gr_name, $group; - } - - diag_variable( gr_name => join ',', @gr_name ); - - return ( \ %gid_count, \ @gr_name ); -} - -# Remove entries from our parsing of $( that don't appear in our -# parsing of `id -a`. -sub remove_unparsed_entries { - my ( $extracted_groups, $perl_groups ) = @_; - - my %was_extracted = - map { $_ => 1 } - @$extracted_groups; - - return - grep { $was_extracted{$_} } - @$perl_groups; -} - -# Get a list of base groups. I'm not sure why cygwin by default is -# skipped here. -sub basegroups { - my ( $pwgid, $pwgnam ) = @_; - - if ( cygwin_nt() ) { - return; - } - else { - return ( - $pwgid => 1, - $pwgnam => 1, - ); - } -} - -# Cygwin might have another form of basegroup which we should actually use -sub unixy_cygwin_basegroups { - my ( $pwgid, $pwgnam ) = @_; - return ( - $pwgid => 1, - $pwgnam => 1, - ); -} - -# Filter a full list of groups and return only the supplementary -# gorups. -sub remove_basegroup { - my ( $basegroups, $groups ) = @_; - - return - grep { ! $basegroups->{$_} } - @$groups; -} - -# Test supplementary groups to see if they're a close enough match or -# if there aren't any supplementary groups then validate the current -# group against $(. -sub match_groups { - my ( $supplementary_groups, $extracted_supplementary_groups, $pwgid ) = @_; - - # Compare perl vs system groups - my %g; - $g{$_}[0] = 1 for @$supplementary_groups; - $g{$_}[1] = 1 for @$extracted_supplementary_groups; - - # Find any mismatches - my @misses = - grep { ! ( $g{$_}[0] && $g{$_}[1] ) } - sort keys %g; - - return - ! @misses - || ( ! @$supplementary_groups - && 1 == @$extracted_supplementary_groups - && $pwgid == $extracted_supplementary_groups->[0] ); -} - -# Print a nice little diagnostic. -sub diag_variable { - my ( $label, $content ) = @_; - - printf "# %-11s=%s\n", $label, $content; - return; -} - -# Removes duplicates from a list -sub uniq { - my %seen; - return - grep { ! $seen{$_}++ } - @_; -} - -# Local variables: -# indent-tabs-mode: nil -# End: -# -# ex: set ts=8 sts=4 sw=4 noet: diff --git a/t/CORE/op/gv.t b/t/CORE/op/gv.t deleted file mode 100644 index adb3c65ae..000000000 --- a/t/CORE/op/gv.t +++ /dev/null @@ -1,909 +0,0 @@ -#!./perl - -# -# various typeglob tests -# - - -BEGIN { - unshift @INC, 't/CORE/lib'; - require 't/CORE/test.pl'; -} - - -use warnings; - -plan( tests => 234 ); - -# type coersion on assignment -$foo = 'foo'; -$bar = *main::foo; -$bar = $foo; -is(ref(\$bar), 'SCALAR'); -$foo = *main::bar; - -# type coersion (not) on misc ops - -ok($foo); -is(ref(\$foo), 'GLOB'); - -unlike ($foo, qr/abcd/); -is(ref(\$foo), 'GLOB'); - -is($foo, '*main::bar'); -is(ref(\$foo), 'GLOB'); - -{ - no warnings; - ${\*$foo} = undef; - is(ref(\$foo), 'GLOB', 'no type coersion when assigning to *{} retval'); - $::{phake} = *bar; - is( - \$::{phake}, \*{"phake"}, - 'symbolic *{} returns symtab entry when FAKE' - ); - ${\*{"phake"}} = undef; - is( - ref(\$::{phake}), 'GLOB', - 'no type coersion when assigning to retval of symbolic *{}' - ); - $::{phaque} = *bar; - eval ' - is( - \$::{phaque}, \*phaque, - "compile-time *{} returns symtab entry when FAKE" - ); - ${\*phaque} = undef; - '; - is( - ref(\$::{phaque}), 'GLOB', - 'no type coersion when assigning to retval of compile-time *{}' - ); -} - -# type coersion on substitutions that match -$a = *main::foo; -$b = $a; -$a =~ s/^X//; -is(ref(\$a), 'GLOB'); -$a =~ s/^\*//; -is($a, 'main::foo'); -is(ref(\$b), 'GLOB'); - -# typeglobs as lvalues -substr($foo, 0, 1) = "XXX"; -is(ref(\$foo), 'SCALAR'); -is($foo, 'XXXmain::bar'); - -# returning glob values -sub foo { - local($bar) = *main::foo; - $foo = *main::bar; - return ($foo, $bar); -} - -($fuu, $baa) = foo(); -ok(defined $fuu); -is(ref(\$fuu), 'GLOB'); - - -ok(defined $baa); -is(ref(\$baa), 'GLOB'); - -# nested package globs -# NOTE: It's probably OK if these semantics change, because the -# fact that %X::Y:: is stored in %X:: isn't documented. -# (I hope.) - -# perlcc issue 191 - https://code.google.com/p/perl-compiler/issues/detail?id=191 -{ package Foo::Bar; no warnings 'once'; $test=1; } -ok(exists $Foo::{'Bar::'}, '$Foo::{Bar::} exists'); -is($Foo::{'Bar::'}, '*Foo::Bar::', '$Foo::{Bar::}'); - - -# test undef operator clearing out entire glob -$foo = 'stuff'; -@foo = qw(more stuff); -%foo = qw(even more random stuff); -undef *foo; -is ($foo, undef); -is (scalar @foo, 0, 'scalar @foo'); -is (scalar %foo, 0, 'scalar %foo'); - -{ - # test warnings from assignment of undef to glob - my $msg = ''; - local $SIG{__WARN__} = sub { $msg = $_[0] }; - use warnings; - *foo = 'bar'; - is($msg, ''); - *foo = undef; - like($msg, qr/Undefined value assigned to typeglob/); - - no warnings 'once'; - # test warnings for converting globs to other forms - my $copy = *PWOMPF; - foreach ($copy, *SKREEE) { - $msg = ''; - my $victim = sprintf "%d", $_; - like($msg, qr/Argument "\*main::[A-Z]{6}" isn't numeric in sprintf/, - "Warning on conversion to IV"); - is($victim, 0); - - $msg = ''; - $victim = sprintf "%u", $_; - like($msg, qr/Argument "\*main::[A-Z]{6}" isn't numeric in sprintf/, - "Warning on conversion to UV"); - is($victim, 0); - - $msg = ''; - $victim = sprintf "%e", $_; - like($msg, qr/Argument "\*main::[A-Z]{6}" isn't numeric in sprintf/, - "Warning on conversion to NV"); - like($victim, qr/^0\.0+E\+?00/i, "Expect floating point zero"); - - $msg = ''; - $victim = sprintf "%s", $_; - is($msg, '', "No warning on stringification"); - is($victim, '' . $_); - } -} - -my $test = curr_test(); -# test *glob{THING} syntax -$x = "ok $test\n"; -++$test; -@x = ("ok $test\n"); -++$test; -%x = ("ok $test" => "\n"); -++$test; -sub x { "ok $test\n" } -print ${*x{SCALAR}}, @{*x{ARRAY}}, %{*x{HASH}}, &{*x{CODE}}; -# This needs to go here, after the print, as sub x will return the current -# value of test -++$test; -format x = -XXX This text isn't used. Should it be? -. -curr_test($test); - -is (ref *x{FORMAT}, "FORMAT", "FORMAT glob assign"); -*x = *STDOUT; -is (*{*x{GLOB}}, "*main::STDOUT", "IO glob assign"); - -{ - my $test = curr_test(); - - print {*x{IO}} "ok $test\n"; - ++$test; - - my $warn; - local $SIG{__WARN__} = sub { - $warn .= $_[0]; - }; - my $val = *x{FILEHANDLE}; - print {*x{IO}} ($warn =~ /is deprecated/ - ? "ok $test\n" : "not ok $test\n"); - curr_test(++$test); -} - - -{ - # test if defined() doesn't create any new symbols - - my $a = "SYM000"; - ok(!defined *{$a}); - - ok(!defined @{$a}); - ok(!defined *{$a}); - - { - no warnings 'deprecated'; - ok(!defined %{$a}); - } - ok(!defined *{$a}); - - ok(!defined ${$a}); - ok(!defined *{$a}); - - ok(!defined &{$a}); - ok(!defined *{$a}); - - my $state = "not"; - *{$a} = sub { $state = "ok" }; - ok(defined &{$a}); - ok(defined *{$a}); - &{$a}; - is ($state, 'ok'); -} - -{ - # although it *should* if you're talking about magicals - - my $a = "]"; - ok(defined ${$a}); - ok(defined *{$a}); - - $a = "1"; - "o" =~ /(o)/; - ok(${$a}); - ok(defined *{$a}); - $a = "2"; - ok(!${$a}); - ok(defined *{$a}); - $a = "1x"; - ok(!defined ${$a}); - ok(!defined *{$a}); - $a = "11"; - "o" =~ /(((((((((((o)))))))))))/; - ok(${$a}); - ok(defined *{$a}); -} - -# [ID 20010526.001] localized glob loses value when assigned to - -$j=1; %j=(a=>1); @j=(1); local *j=*j; *j = sub{}; - -is($j, 1); -is($j{a}, 1); -is($j[0], 1); - -{ - # does pp_readline() handle glob-ness correctly? - my $g = *foo; - $g = ; - is ($g, "Perl\n"); -} - -{ - my $w = ''; - local $SIG{__WARN__} = sub { $w = $_[0] }; - sub abc1 (); - local *abc1 = sub { }; - is ($w, ''); - sub abc2 (); - local *abc2; - *abc2 = sub { }; - is ($w, ''); - sub abc3 (); - *abc3 = sub { }; - like ($w, qr/Prototype mismatch/, 'Prototype mismatch'); -} - -{ - # [17375] rcatline to formerly-defined undef was broken. Fixed in - # do_readline by checking SvOK. AMS, 20020918 - my $x = "not "; - $x = undef; - $x .= ; - is ($x, "Rules\n", 'Rules'); -} - -{ - # test the assignment of a GLOB to an LVALUE - my $e = ''; - local $SIG{__DIE__} = sub { $e = $_[0] }; - my %v; - sub f { $_[0] = 0; $_[0] = "a"; $_[0] = *DATA } - f($v{v}); - is ($v{v}, '*main::DATA', '*main::DATA'); - is (ref\$v{v}, 'GLOB', 'lvalue assignment preserves globs'); - my $x = readline $v{v}; - is ($x, "perl\n"); - is ($e, '', '__DIE__ handler never called'); -} - -{ - my $e = ''; - # GLOB assignment to tied element - local $SIG{__DIE__} = sub { $e = $_[0] }; - sub T::TIEARRAY { bless [] => "T" } - sub T::STORE { $_[0]->[ $_[1] ] = $_[2] } - sub T::FETCH { $_[0]->[ $_[1] ] } - sub T::FETCHSIZE { @{$_[0]} } - tie my @ary => "T"; - $ary[0] = *DATA; - is ($ary[0], '*main::DATA'); - is ( - ref\tied(@ary)->[0], 'GLOB', - 'tied elem assignment preserves globs' - ); - is ($e, '', '__DIE__ handler not called'); - my $x = readline $ary[0]; - is($x, "rocks\n"); - is ($e, '', '__DIE__ handler never called'); -} - -{ - # Need some sort of die or warn to get the global destruction text if the - # bug is still present - my $output = runperl(prog => <<'EOPROG'); -package M; -$| = 1; -sub DESTROY {eval {die qq{Farewell $_[0]}}; print $@} -package main; - -bless \$A::B, q{M}; -*A:: = \*B::; -EOPROG - like($output, qr/^Farewell M=SCALAR/, "DESTROY was called"); - unlike($output, qr/global destruction/, - "unreferenced symbol tables should be cleaned up immediately"); -} - -# Possibly not the correct test file for these tests. -# There are certain space optimisations implemented via promotion rules to -# GVs - -foreach (qw (oonk ga_shloip)) { - ok(!exists $::{$_}, "no symbols of any sort to start with for $_"); -} - -# A string in place of the typeglob is promoted to the function prototype -$::{oonk} = "pie"; -my $proto = eval 'prototype \&oonk'; -die if $@; -is ($proto, "pie", "String is promoted to prototype"); - - -# A reference to a value is used to generate a constant subroutine -foreach my $value (3, "Perl rules", \42, qr/whatever/, [1,2,3], {1=>2}, - \*STDIN, \&ok, \undef, *STDOUT) { - delete $::{oonk}; - $::{oonk} = \$value; - $proto = eval 'prototype \&oonk'; - die if $@; - is ($proto, '', "Prototype for a constant subroutine is empty"); - - my $got = eval 'oonk'; - die if $@; - is (ref $got, ref $value, "Correct type of value (" . ref($value) . ")"); - is ($got, $value, "Value is correctly set"); -} - -delete $::{oonk}; -$::{oonk} = \"Value"; - -*{"ga_shloip"} = \&{"oonk"}; - -is (ref $::{ga_shloip}, 'SCALAR', "Export of proxy constant as is"); -is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original"); -is (eval 'ga_shloip', "Value", "Constant has correct value"); -is (ref $::{ga_shloip}, 'SCALAR', - "Inlining of constant doesn't change representation"); - -delete $::{ga_shloip}; - -eval 'sub ga_shloip (); 1' or die $@; -is ($::{ga_shloip}, '', "Prototype is stored as an empty string"); - -# Check that a prototype expands. -*{"ga_shloip"} = \&{"oonk"}; - -is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original"); -is (eval 'ga_shloip', "Value", "Constant has correct value"); -is (ref \$::{ga_shloip}, 'GLOB', "Symbol table has full typeglob"); - - -@::zwot = ('Zwot!'); - -# Check that assignment to an existing typeglob works -{ - my $w = ''; - local $SIG{__WARN__} = sub { $w = $_[0] }; - *{"zwot"} = \&{"oonk"}; - is($w, '', "Should be no warning"); -} - -is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original"); -is (eval 'zwot', "Value", "Constant has correct value"); -is (ref \$::{zwot}, 'GLOB', "Symbol table has full typeglob"); -is (join ('!', @::zwot), 'Zwot!', "Existing array still in typeglob"); - -sub spritsits () { - "Traditional"; -} - -# Check that assignment to an existing subroutine works -{ - my $w = ''; - local $SIG{__WARN__} = sub { $w = $_[0] }; - *{"spritsits"} = \&{"oonk"}; - like($w, qr/^Constant subroutine main::spritsits redefined/, - "Redefining a constant sub should warn"); -} - -is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original"); -is (eval 'spritsits', "Value", "Constant has correct value"); -is (ref \$::{spritsits}, 'GLOB', "Symbol table has full typeglob"); - -# Check that assignment to an existing typeglob works -{ - my $w = ''; - local $SIG{__WARN__} = sub { $w = $_[0] }; - *{"plunk"} = []; - *{"plunk"} = \&{"oonk"}; - is($w, '', "Should be no warning"); -} - -is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original"); -is (eval 'plunk', "Value", "Constant has correct value"); -is (ref \$::{plunk}, 'GLOB', "Symbol table has full typeglob"); - -my $gr = eval '\*plunk' or die; - -{ - my $w = ''; - local $SIG{__WARN__} = sub { $w = $_[0] }; - *{$gr} = \&{"oonk"}; - is($w, '', "Redefining a constant sub to another constant sub with the same underlying value should not warn (It's just re-exporting, and that was always legal)"); -} - -is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original"); -is (eval 'plunk', "Value", "Constant has correct value"); -is (ref \$::{plunk}, 'GLOB', "Symbol table has full typeglob"); - -# Non-void context should defeat the optimisation, and will cause the original -# to be promoted (what change 26482 intended) -my $result; -{ - my $w = ''; - local $SIG{__WARN__} = sub { $w = $_[0] }; - $result = *{"awkkkkkk"} = \&{"oonk"}; - is($w, '', "Should be no warning"); -} - -is (ref \$result, 'GLOB', - "Non void assignment should still return a typeglob"); - -is (ref \$::{oonk}, 'GLOB', "This export does affect original"); -is (eval 'plunk', "Value", "Constant has correct value"); -is (ref \$::{plunk}, 'GLOB', "Symbol table has full typeglob"); - -delete $::{oonk}; -$::{oonk} = \"Value"; - -sub non_dangling { - my $w = ''; - local $SIG{__WARN__} = sub { $w = $_[0] }; - *{"zap"} = \&{"oonk"}; - is($w, '', "Should be no warning"); -} - -non_dangling(); -is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original"); -is (eval 'zap', "Value", "Constant has correct value"); -is (ref $::{zap}, 'SCALAR', "Exported target is also a PCS"); - -sub dangling { - local $SIG{__WARN__} = sub { die $_[0] }; - *{"biff"} = \&{"oonk"}; -} - -dangling(); -is (ref \$::{oonk}, 'GLOB', "This export does affect original"); -is (eval 'biff', "Value", "Constant has correct value"); -is (ref \$::{biff}, 'GLOB', "Symbol table has full typeglob"); - -{ - use vars qw($glook $smek $foof); - # Check reference assignment isn't affected by the SV type (bug #38439) - $glook = 3; - $smek = 4; - $foof = "halt and cool down"; - - my $rv = \*smek; - is($glook, 3); - *glook = $rv; - is($glook, 4); - - my $pv = ""; - $pv = \*smek; - is($foof, "halt and cool down"); - *foof = $pv; - is($foof, 4); -} - -format = -. - -foreach my $value ([1,2,3], {1=>2}, *STDOUT{IO}, \&ok, *STDOUT{FORMAT}) { - # *STDOUT{IO} returns a reference to a PVIO. As it's blessed, ref returns - # IO::Handle, which isn't what we want. - my $type = $value; - $type =~ s/.*=//; - $type =~ s/\(.*//; - delete $::{oonk}; - $::{oonk} = $value; - $proto = eval 'prototype \&oonk'; - like ($@, qr/^Cannot convert a reference to $type to typeglob/, - "Cannot upgrade ref-to-$type to typeglob"); -} - -{ - no warnings qw(once uninitialized); - my $g = \*clatter; - my $r = eval {no strict; ${*{$g}{SCALAR}}}; - is ($@, '', "PERL_DONT_CREATE_GVSV shouldn't affect thingy syntax"); - - $g = \*vowm; - $r = eval {use strict; ${*{$g}{SCALAR}}}; - is ($@, '', - "PERL_DONT_CREATE_GVSV shouldn't affect thingy syntax under strict"); -} - -{ - # Bug reported by broquaint on IRC - *slosh::{HASH}->{ISA}=[]; - slosh->import; - pass("gv_fetchmeth coped with the unexpected"); - - # An audit found these: - { - package slosh; - sub rip { - my $s = shift; - $s->SUPER::rip; - } - } - eval {slosh->rip;}; - like ($@, qr/^Can't locate object method "rip"/, "Even with SUPER"); - - is(slosh->isa('swoosh'), ''); - - $CORE::GLOBAL::{"lock"}=[]; - eval "no warnings; lock"; - like($@, qr/^Not enough arguments for lock/, - "Can't trip up general keyword overloading"); - - $CORE::GLOBAL::{"readline"}=[]; - eval " if 0"; - is($@, '', "Can't trip up readline overloading"); - - $CORE::GLOBAL::{"readpipe"}=[]; - eval "`` if 0"; - is($@, '', "Can't trip up readpipe overloading"); -} - -{ - die if exists $::{BONK}; - $::{BONK} = \"powie"; - *{"BONK"} = \&{"BONK"}; - eval 'is(BONK(), "powie", - "Assignment works when glob created midway (bug 45607)"); 1' - or die $@; -} - -# For now these tests are here, but they would probably be better in a file for -# tests for croaks. (And in turn, that probably deserves to be in a different -# directory. Gerard Goossen has a point about the layout being unclear - -sub coerce_integer { - no warnings 'numeric'; - $_[0] |= 0; -} -sub coerce_number { - no warnings 'numeric'; - $_[0] += 0; -} -sub coerce_string { - $_[0] .= ''; -} - -foreach my $type (qw(integer number string)) { - my $prog = "coerce_$type(*STDERR)"; - is (scalar eval "$prog; 1", undef, "$prog failed..."); - like ($@, qr/Can't coerce GLOB to $type in/, - "with the correct error message"); -} - -# RT #60954 anonymous glob should be defined, and not coredump when -# stringified. The behaviours are: -# -# defined($glob) "$glob" -# 5.8.8 false "" with uninit warning -# 5.10.0 true (coredump) -# 5.12.0 true "" - -{ - my $io_ref = *STDOUT{IO}; - my $glob = *$io_ref; - ok(defined $glob, "RT #60954 anon glob should be defined"); - - my $warn = ''; - local $SIG{__WARN__} = sub { $warn = $_[0] }; - use warnings; - my $str = "$glob"; - is($warn, '', "RT #60954 anon glob stringification shouldn't warn"); - is($str, '', "RT #60954 anon glob stringification should be empty"); -} - -# [perl #71254] - Assigning a glob to a variable that has a current -# match position. (We are testing that Perl_magic_setmglob respects globs' -# special used of SvSCREAM.) -{ - $m = 2; $m=~s/./0/gems; $m= *STDERR; - is( - "$m", "*main::STDERR", - '[perl #71254] assignment of globs to vars with pos' - ); -} - -# [perl #72740] - indirect object syntax, heuristically imputed due to -# the non-existence of a function, should not cause a stash entry to be -# created for the non-existent function. -{ - package RT72740a; - my $f = bless({}, RT72740b); - sub s1 { s2 $f; } - our $s4; - sub s3 { s4 $f; } -} -{ - package RT72740b; - sub s2 { "RT72740b::s2" } - sub s4 { "RT72740b::s4" } -} -ok(exists($RT72740a::{s1}), "RT72740a::s1 exists"); -ok(!exists($RT72740a::{s2}), "RT72740a::s2 does not exist"); -ok(exists($RT72740a::{s3}), "RT72740a::s3 exists"); -# perlcc issue 191 - https://code.google.com/p/perl-compiler/issues/detail?id=191 -ok(exists($RT72740a::{s4}), "RT72740a::s4 exists"); -is(RT72740a::s1(), "RT72740b::s2", "RT72740::s1 parsed correctly"); -is(RT72740a::s3(), "RT72740b::s4", "RT72740::s3 parsed correctly"); - -# [perl #71686] Globs that are in symbol table can be un-globbed -$sym = undef; -$::{fake} = *sym; -is (eval 'local *::fake = \"chuck"; $fake', 'chuck', - "Localized glob didn't coerce into a RV"); -is ($@, '', "Can localize FAKE glob that's present in stash"); -is (scalar $::{fake}, "*main::sym", - "Localized FAKE glob's value was correctly restored"); - -# [perl #1804] *$x assignment when $x is a copy of another glob -# And [perl #77508] (same thing with list assignment) -{ - no warnings 'once'; - my $x = *_random::glob_that_is_not_used_elsewhere; - *$x = sub{}; - is( - "$x", '*_random::glob_that_is_not_used_elsewhere', - '[perl #1804] *$x assignment when $x is FAKE', - ); - $x = *_random::glob_that_is_not_used_elsewhere; - (my $dummy, *$x) = (undef,[]); - is( - "$x", '*_random::glob_that_is_not_used_elsewhere', - '[perl #77508] *$x list assignment when $x is FAKE', - ) or require Devel::Peek, Devel::Peek::Dump($x); -} - -# [perl #76540] -# this caused panics or 'Attempt to free unreferenced scalar' -# (its a compile-time issue, so the die lets us skip the prints) -{ - my @warnings; - local $SIG{__WARN__} = sub { push @warnings, @_ }; - - eval <<'EOF'; -BEGIN { $::{FOO} = \'bar' } -die "made it"; -print FOO, "\n"; -print FOO, "\n"; -EOF - - like($@, qr/made it/, "#76540 - no panic"); - ok(!@warnings, "#76540 - no 'Attempt to free unreferenced scalar'"); -} - -# [perl #77362] various bugs related to globs as PVLVs -{ - # perlcc issue 192 - https://code.google.com/p/perl-compiler/issues/detail?id=192 - no warnings qw 'once void'; - my %h; # We pass a key of this hash to the subroutine to get a PVLV. - sub { for(shift) { - # Set up our glob-as-PVLV - $_ = *hon; - - # Bad symbol for array - ok eval{ @$_; 1 }, 'PVLV glob slots can be autovivified' or diag $@; - - # This should call TIEHANDLE, not TIESCALAR - *thext::TIEHANDLE = sub{}; - ok eval{ tie *$_, 'thext'; 1 }, 'PVLV globs can be tied as handles' - or diag $@; - - # Assigning undef to the glob should not overwrite it... - { - my $w; - local $SIG{__WARN__} = sub { $w = shift }; - *$_ = undef; - is $_, "*main::hon", 'PVLV: assigning undef to the glob does nothing'; - like $w, qr\Undefined value assigned to typeglob\, - 'PVLV: assigning undef to the glob warns'; - } - - # Neither should reference assignment. - *$_ = []; - is $_, "*main::hon", "PVLV: arrayref assignment assigns to the AV slot"; - - # Concatenation should still work. - ok eval { $_ .= 'thlew' }, 'PVLV concatenation does not die' or diag $@; - is $_, '*main::honthlew', 'PVLV concatenation works'; - - # And we should be able to overwrite it with a string, number, or refer- - # ence, too, if we omit the *. - $_ = *hon; $_ = 'tzor'; - is $_, 'tzor', 'PVLV: assigning a string over a glob'; - $_ = *hon; $_ = 23; - is $_, 23, 'PVLV: assigning an integer over a glob'; - $_ = *hon; $_ = 23.23; - is $_, 23.23, 'PVLV: assigning a float over a glob'; - $_ = *hon; $_ = \my $sthat; - is $_, \$sthat, 'PVLV: assigning a reference over a glob'; - - # This bug was found by code inspection. Could this ever happen in - # real life? :-) - # This duplicates a file handle, accessing it through a PVLV glob, the - # glob having been removed from the symbol table, so a stringified form - # of it does not work. This checks that sv_2io does not stringify a PVLV. - $_ = *quin; - open *quin, "t/test.pl"; # test.pl is as good a file as any - delete $::{quin}; - ok eval { open my $zow, "<&", $_ }, 'PVLV: sv_2io stringifieth not' - or diag $@; - - # Similar tests to make sure sv_2cv etc. do not stringify. - *$_ = sub { 1 }; - ok eval { &$_ }, "PVLV glob can be called as a sub" or diag $@; - *flelp = sub { 2 }; - $_ = 'flelp'; - is eval { &$_ }, 2, 'PVLV holding a string can be called as a sub' - or diag $@; - - # Coderef-to-glob assignment when the glob is no longer accessible - # under its name: These tests are to make sure the OPpASSIGN_CV_TO_GV - # optimisation takes PVLVs into account, which is why the RHSs have to be - # named subs. - use constant gheen => 'quare'; - $_ = *ming; - delete $::{ming}; - *$_ = \&gheen; - is eval { &$_ }, 'quare', - 'PVLV: constant assignment when the glob is detached from the symtab' - or diag $@; - $_ = *bength; - delete $::{bength}; - *gheck = sub { 'lon' }; - *$_ = \&gheck; - is eval { &$_ }, 'lon', - 'PVLV: coderef assignment when the glob is detached from the symtab' - or diag $@; - - { - # open should accept a PVLV as its first argument - $_ = *hon; - ok eval { open $_,'<', \my $thlext }, 'PVLV can be the first arg to open' - or diag $@; - } - - # -t should not stringify - $_ = *thlit; delete $::{thlit}; - *$_ = *STDOUT{IO}; - ok defined -t $_, 'PVLV: -t does not stringify'; - - # neither should -T - # but some systems don’t support this on file handles - my $pass; - ok - eval { - open my $quile, "<", 't/test.pl'; - $_ = *$quile; - $pass = -T $_; - 1 - } ? $pass : $@ =~ /not implemented on filehandles/, - "PVLV: -T does not stringify"; - - # Unopened file handle - { - my $w; - local $SIG{__WARN__} = sub { $w .= shift }; - $_ = *vor; - close $_; - like $w, qr\unopened filehandle vor\, - 'PVLV globs get their names reported in unopened error messages'; - } - - }}->($h{k}); -} - -*aieee = 4; -pass('Can assign integers to typeglobs'); -*aieee = 3.14; -pass('Can assign floats to typeglobs'); -*aieee = 'pi'; -pass('Can assign strings to typeglobs'); - -{ - package thrext; - sub TIESCALAR{bless[]} - sub STORE{ die "No!"} - sub FETCH{ no warnings 'once'; *thrit } - tie my $a, "thrext"; - () = "$a"; # do a fetch; now $a holds a glob - eval { *$a = sub{} }; - eval { $a = undef }; # workaround for untie($handle) bug - untie $a; - eval { $a = "bar" }; - ::is $a, "bar", - "[perl #77812] Globs in tied scalars can be reified if STORE dies" -} - -# These two crashed prior to 5.13.6. In 5.13.6 they were fatal errors. They -# were fixed in 5.13.7. -ok eval { - my $glob = \*heen::ISA; - delete $::{"heen::"}; - *$glob = *bar; -}, "glob-to-*ISA assignment works when *ISA has lost its stash"; -ok eval { - my $glob = \*slare::ISA; - delete $::{"slare::"}; - *$glob = []; -}, "array-to-*ISA assignment works when *ISA has lost its stash"; -# These two crashed in 5.13.6. They were likewise fixed in 5.13.7. -ok eval { - sub greck; - my $glob = do { no warnings "once"; \*phing::foo}; - delete $::{"phing::"}; - *$glob = *greck; -}, "Assigning a glob-with-sub to a glob that has lost its stash warks"; -ok eval { - sub pon::foo; - my $glob = \*pon::foo; - delete $::{"pon::"}; - *$glob = *foo; -}, "Assigning a glob to a glob-with-sub that has lost its stash warks"; - -{ - package Tie::Alias; - sub TIESCALAR{ bless \\pop } - sub FETCH { $${$_[0]} } - sub STORE { $${$_[0]} = $_[1] } - package main; - tie my $alias, 'Tie::Alias', my $var; - no warnings 'once'; - $var = *galobbe; - { - local *$alias = []; - $var = 3; - is $alias, 3, "[perl #77926] Glob reification during localisation"; - } -} - -# This code causes gp_free to call a destructor when a glob is being -# restored on scope exit. The destructor used to see SVs with a refcount of -# zero inside the glob, which could result in crashes (though not in this -# test case, which just panics). -{ - no warnings 'once'; - my $survived; - *Trit::DESTROY = sub { - $thwext = 42; # panic - $survived = 1; - }; - { - local *thwext; - $thwext = bless[],'Trit'; - (); - } - ok $survived, - 'no error when gp_free calls a destructor that assigns to the gv'; -} - -__END__ -Perl -Rules -perl -rocks diff --git a/t/CORE/op/hash.t b/t/CORE/op/hash.t deleted file mode 100644 index ef3ea32d8..000000000 --- a/t/CORE/op/hash.t +++ /dev/null @@ -1,157 +0,0 @@ -#!./perl -w - -BEGIN { require 't/CORE/test.pl' } -use strict; - -plan tests => 8; - -my %h; - -ok (!Internals::HvREHASH(%h), "hash doesn't start with rehash flag on"); - -foreach (1..10) { - $h{"\0"x$_}++; -} - -ok (!Internals::HvREHASH(%h), "10 entries doesn't trigger rehash"); - -foreach (11..20) { - $h{"\0"x$_}++; -} - -ok (Internals::HvREHASH(%h), "20 entries triggers rehash"); - - - - -# second part using an emulation of the PERL_HASH in perl, mounting an -# attack on a pre-populated hash. This is also useful if you need normal -# keys which don't contain \0 -- suitable for stashes - -use constant MASK_U32 => 2**32; -use constant HASH_SEED => 0; -use constant THRESHOLD => 14; -use constant START => "a"; - -# some initial hash data -my %h2; -my $counter= "a"; -$h2{$counter++}++ while $counter ne 'cd'; - -ok (!Internals::HvREHASH(%h2), - "starting with pre-populated non-pathological hash (rehash flag if off)"); - -my @keys = get_keys(\%h2); -my $buckets= buckets(\%h2); -$h2{$_}++ for @keys; -$h2{$counter++}++ while buckets(\%h2) == $buckets; # force a split -ok (Internals::HvREHASH(%h2), - scalar(@keys) . " colliding into the same bucket keys are triggering rehash after split"); - -# returns the number of buckets in a hash -sub buckets { - my $hr = shift; - my $keys_buckets= scalar(%$hr); - if ($keys_buckets=~m!/([0-9]+)\z!) { - return 0+$1; - } else { - return 8; - } -} - -sub get_keys { - my $hr = shift; - - # the minimum of bits required to mount the attack on a hash - my $min_bits = log(THRESHOLD)/log(2); - # if the hash has already been populated with a significant amount - # of entries the number of mask bits can be higher - my $keys = scalar keys %$hr; - my $bits = $keys ? log($keys)/log(2) : 0; - $bits = $min_bits if $min_bits > $bits; - - $bits = int($bits) < $bits ? int($bits) + 1 : int($bits); - # need to add 2 bits to cover the internal split cases - $bits += 2; - my $mask = 2**$bits-1; - print "# using mask: $mask ($bits)\n"; - - my @keys; - my $s = START; - my $c = 0; - # get 2 keys on top of the THRESHOLD - my $hash; - while (@keys < THRESHOLD+2) { - # next if exists $hash->{$s}; - $hash = hash($s); - next unless ($hash & $mask) == 0; - $c++; - printf "# %2d: %5s, %10s\n", $c, $s, $hash; - push @keys, $s; - } continue { - $s++; - } - - return @keys; -} - - -# trying to provide the fastest equivalent of C macro's PERL_HASH in -# Perl - the main complication is that it uses U32 integer, which we -# can't do it perl, without doing some tricks -sub hash { - my $s = shift; - my @c = split //, $s; - my $u = HASH_SEED; - for (@c) { - # (A % M) + (B % M) == (A + B) % M - # This works because '+' produces a NV, which is big enough to hold - # the intermediate result. We only need the % before any "^" and "&" - # to get the result in the range for an I32. - # and << doesn't work on NV, so using 1 << 10 - $u += ord; - $u += $u * (1 << 10); $u %= MASK_U32; - $u ^= $u >> 6; - } - $u += $u << 3; $u %= MASK_U32; - $u ^= $u >> 11; $u %= MASK_U32; - $u += $u << 15; $u %= MASK_U32; - $u; -} - -# This will crash perl if it fails - -use constant PVBM => 'foo'; - -my $dummy = index 'foo', PVBM; -eval { my %h = (a => PVBM); 1 }; - -ok (!$@, 'fbm scalar can be inserted into a hash'); - - -my $destroyed; -{ package Class; DESTROY { ++$destroyed; } } - -$destroyed = 0; -{ - my %h; - keys(%h) = 1; - $h{key} = bless({}, 'Class'); -} -is($destroyed, 1, 'Timely hash destruction with lvalue keys'); - - -# [perl #79178] Hash keys must not be stringified during compilation -# Run perl -MO=Concise -e '$a{\"foo"}' on a non-threaded pre-5.13.8 version -# to see why. -{ - my $key; - package bar; - sub TIEHASH { bless {}, $_[0] } - sub FETCH { $key = $_[1] } - package main; - tie my %h, "bar"; - () = $h{\'foo'}; - is ref $key, SCALAR => - 'hash keys are not stringified during compilation'; -} diff --git a/t/CORE/op/hashassign.t b/t/CORE/op/hashassign.t deleted file mode 100644 index 26fccce68..000000000 --- a/t/CORE/op/hashassign.t +++ /dev/null @@ -1,322 +0,0 @@ -#!./perl -w - -BEGIN { - unshift @INC, 't/CORE/lib'; - require 't/CORE/test.pl'; -} - -# perlcc issue #166 https://code.google.com/p/perl-compiler/issues/detail?id=166 - -# use strict; - -plan tests => 218; - -my @comma = ("key", "value"); - -# The peephole optimiser already knows that it should convert the string in -# $foo{string} into a shared hash key scalar. It might be worth making the -# tokeniser build the LHS of => as a shared hash key scalar too. -# And so there's the possiblility of it going wrong -# And going right on 8 bit but wrong on utf8 keys. -# And really we should also try utf8 literals in {} and => in utf8.t - -# Some of these tests are (effectively) duplicated in each.t -my %comma = @comma; -ok (keys %comma == 1, 'keys on comma hash'); -ok (values %comma == 1, 'values on comma hash'); -# defeat any tokeniser or optimiser cunning -my $key = 'ey'; -is ($comma{"k" . $key}, "value", 'is key present? (unoptimised)'); -# now with cunning: -is ($comma{key}, "value", 'is key present? (maybe optimised)'); -#tokeniser may treat => differently. -my @temp = (key=>undef); -is ($comma{$temp[0]}, "value", 'is key present? (using LHS of =>)'); - -@temp = %comma; -ok (eq_array (\@comma, \@temp), 'list from comma hash'); - -@temp = each %comma; -ok (eq_array (\@comma, \@temp), 'first each from comma hash'); -@temp = each %comma; -ok (eq_array ([], \@temp), 'last each from comma hash'); - -my %temp = %comma; - -ok (keys %temp == 1, 'keys on copy of comma hash'); -ok (values %temp == 1, 'values on copy of comma hash'); -is ($temp{'k' . $key}, "value", 'is key present? (unoptimised)'); -# now with cunning: -is ($temp{key}, "value", 'is key present? (maybe optimised)'); -@temp = (key=>undef); -is ($comma{$temp[0]}, "value", 'is key present? (using LHS of =>)'); - -@temp = %temp; -ok (eq_array (\@temp, \@temp), 'list from copy of comma hash'); - -@temp = each %temp; -ok (eq_array (\@temp, \@temp), 'first each from copy of comma hash'); -@temp = each %temp; -ok (eq_array ([], \@temp), 'last each from copy of comma hash'); - -my @arrow = (Key =>"Value"); - -my %arrow = @arrow; -ok (keys %arrow == 1, 'keys on arrow hash'); -ok (values %arrow == 1, 'values on arrow hash'); -# defeat any tokeniser or optimiser cunning -$key = 'ey'; -is ($arrow{"K" . $key}, "Value", 'is key present? (unoptimised)'); -# now with cunning: -is ($arrow{Key}, "Value", 'is key present? (maybe optimised)'); -#tokeniser may treat => differently. -@temp = ('Key', undef); -is ($arrow{$temp[0]}, "Value", 'is key present? (using LHS of =>)'); - -@temp = %arrow; -ok (eq_array (\@arrow, \@temp), 'list from arrow hash'); - -@temp = each %arrow; -ok (eq_array (\@arrow, \@temp), 'first each from arrow hash'); -@temp = each %arrow; -ok (eq_array ([], \@temp), 'last each from arrow hash'); - -%temp = %arrow; - -ok (keys %temp == 1, 'keys on copy of arrow hash'); -ok (values %temp == 1, 'values on copy of arrow hash'); -is ($temp{'K' . $key}, "Value", 'is key present? (unoptimised)'); -# now with cunning: -is ($temp{Key}, "Value", 'is key present? (maybe optimised)'); -@temp = ('Key', undef); -is ($arrow{$temp[0]}, "Value", 'is key present? (using LHS of =>)'); - -@temp = %temp; -ok (eq_array (\@temp, \@temp), 'list from copy of arrow hash'); - -@temp = each %temp; -ok (eq_array (\@temp, \@temp), 'first each from copy of arrow hash'); -@temp = each %temp; -ok (eq_array ([], \@temp), 'last each from copy of arrow hash'); - -my %direct = ('Camel', 2, 'Dromedary', 1); -my %slow; -$slow{Dromedary} = 1; -$slow{Camel} = 2; - -ok (eq_hash (\%slow, \%direct), "direct list assignment to hash"); -%direct = (Camel => 2, 'Dromedary' => 1); -ok (eq_hash (\%slow, \%direct), "direct list assignment to hash using =>"); - -$slow{Llama} = 0; # A llama is not a camel :-) -ok (!eq_hash (\%direct, \%slow), "different hashes should not be equal!"); - -my (%names, %names_copy); -%names = ('$' => 'Scalar', '@' => 'Array', # Grr ' - '%', 'Hash', '&', 'Code'); -%names_copy = %names; -ok (eq_hash (\%names, \%names_copy), "check we can copy our hash"); - -sub in { - my %args = @_; - return eq_hash (\%names, \%args); -} - -ok (in (%names), "pass hash into a method"); - -sub in_method { - my $self = shift; - my %args = @_; - return eq_hash (\%names, \%args); -} - -ok (main->in_method (%names), "pass hash into a method"); - -sub out { - return %names; -} -%names_copy = out (); - -ok (eq_hash (\%names, \%names_copy), "pass hash from a subroutine"); - -sub out_method { - my $self = shift; - return %names; -} -%names_copy = main->out_method (); - -ok (eq_hash (\%names, \%names_copy), "pass hash from a method"); - -sub in_out { - my %args = @_; - return %args; -} -%names_copy = in_out (%names); - -ok (eq_hash (\%names, \%names_copy), "pass hash to and from a subroutine"); - -sub in_out_method { - my $self = shift; - my %args = @_; - return %args; -} -%names_copy = main->in_out_method (%names); - -ok (eq_hash (\%names, \%names_copy), "pass hash to and from a method"); - -my %names_copy2 = %names; -ok (eq_hash (\%names, \%names_copy2), "check copy worked"); - -# This should get ignored. -%names_copy = ('%', 'Associative Array', %names); - -ok (eq_hash (\%names, \%names_copy), "duplicates at the start of a list"); - -# This should not -%names_copy = ('*', 'Typeglob', %names); - -$names_copy2{'*'} = 'Typeglob'; -ok (eq_hash (\%names_copy, \%names_copy2), "duplicates at the end of a list"); - -%names_copy = ('%', 'Associative Array', '*', 'Endangered species', %names, - '*', 'Typeglob',); - -ok (eq_hash (\%names_copy, \%names_copy2), "duplicates at both ends"); - -# And now UTF8 - -foreach my $chr (60, 200, 600, 6000, 60000) { - # This little game may set a UTF8 flag internally. Or it may not. :-) - my ($key, $value) = (chr ($chr) . "\x{ABCD}", "$chr\x{ABCD}"); - chop ($key, $value); - my @utf8c = ($key, $value); - my %utf8c = @utf8c; - - ok (keys %utf8c == 1, 'keys on utf8 comma hash'); - ok (values %utf8c == 1, 'values on utf8 comma hash'); - # defeat any tokeniser or optimiser cunning - is ($utf8c{"" . $key}, $value, 'is key present? (unoptimised)'); - my $tempval = sprintf '$utf8c{"\x{%x}"}', $chr; - is (eval $tempval, $value, "is key present? (maybe $tempval is optimised)"); - $tempval = sprintf '@temp = ("\x{%x}" => undef)', $chr; - eval $tempval or die "'$tempval' gave $@"; - is ($utf8c{$temp[0]}, $value, 'is key present? (using LHS of $tempval)'); - - @temp = %utf8c; - ok (eq_array (\@utf8c, \@temp), 'list from utf8 comma hash'); - - @temp = each %utf8c; - ok (eq_array (\@utf8c, \@temp), 'first each from utf8 comma hash'); - @temp = each %utf8c; - ok (eq_array ([], \@temp), 'last each from utf8 comma hash'); - - %temp = %utf8c; - - ok (keys %temp == 1, 'keys on copy of utf8 comma hash'); - ok (values %temp == 1, 'values on copy of utf8 comma hash'); - is ($temp{"" . $key}, $value, 'is key present? (unoptimised)'); - $tempval = sprintf '$temp{"\x{%x}"}', $chr; - is (eval $tempval, $value, "is key present? (maybe $tempval is optimised)"); - $tempval = sprintf '@temp = ("\x{%x}" => undef)', $chr; - eval $tempval or die "'$tempval' gave $@"; - is ($temp{$temp[0]}, $value, "is key present? (using LHS of $tempval)"); - - @temp = %temp; - ok (eq_array (\@temp, \@temp), 'list from copy of utf8 comma hash'); - - @temp = each %temp; - ok (eq_array (\@temp, \@temp), 'first each from copy of utf8 comma hash'); - @temp = each %temp; - ok (eq_array ([], \@temp), 'last each from copy of utf8 comma hash'); - - my $assign = sprintf '("\x{%x}" => "%d")', $chr, $chr; - print "# $assign\n"; - my (@utf8a) = eval $assign; - - my %utf8a = @utf8a; - ok (keys %utf8a == 1, 'keys on utf8 arrow hash'); - ok (values %utf8a == 1, 'values on utf8 arrow hash'); - # defeat any tokeniser or optimiser cunning - is ($utf8a{$key . ""}, $value, 'is key present? (unoptimised)'); - $tempval = sprintf '$utf8a{"\x{%x}"}', $chr; - is (eval $tempval, $value, "is key present? (maybe $tempval is optimised)"); - $tempval = sprintf '@temp = ("\x{%x}" => undef)', $chr; - eval $tempval or die "'$tempval' gave $@"; - is ($utf8a{$temp[0]}, $value, "is key present? (using LHS of $tempval)"); - - @temp = %utf8a; - ok (eq_array (\@utf8a, \@temp), 'list from utf8 arrow hash'); - - @temp = each %utf8a; - ok (eq_array (\@utf8a, \@temp), 'first each from utf8 arrow hash'); - @temp = each %utf8a; - ok (eq_array ([], \@temp), 'last each from utf8 arrow hash'); - - %temp = %utf8a; - - ok (keys %temp == 1, 'keys on copy of utf8 arrow hash'); - ok (values %temp == 1, 'values on copy of utf8 arrow hash'); - is ($temp{'' . $key}, $value, 'is key present? (unoptimised)'); - $tempval = sprintf '$temp{"\x{%x}"}', $chr; - is (eval $tempval, $value, "is key present? (maybe $tempval is optimised)"); - $tempval = sprintf '@temp = ("\x{%x}" => undef)', $chr; - eval $tempval or die "'$tempval' gave $@"; - is ($temp{$temp[0]}, $value, "is key present? (using LHS of $tempval)"); - - @temp = %temp; - ok (eq_array (\@temp, \@temp), 'list from copy of utf8 arrow hash'); - - @temp = each %temp; - ok (eq_array (\@temp, \@temp), 'first each from copy of utf8 arrow hash'); - @temp = each %temp; - ok (eq_array ([], \@temp), 'last each from copy of utf8 arrow hash'); - -} - -# now some tests for hash assignment in scalar and list context with -# duplicate keys [perl #24380], [perl #31865] -{ - my %h; my $x; my $ar; - is( (join ':', %h = (1) x 8), '1:1', - 'hash assignment in list context removes duplicates' ); - is( (join ':', %h = qw(a 1 a 2 b 3 c 4 d 5 d 6)), 'a:2:b:3:c:4:d:6', - 'hash assignment in list context removes duplicates 2' ); - is( scalar( %h = (1,2,1,3,1,4,1,5) ), 2, - 'hash assignment in scalar context' ); - is( scalar( ($x,%h) = (0,1,2,1,3,1,4,1,5) ), 3, - 'scalar + hash assignment in scalar context' ); - $ar = [ %h = (1,2,1,3,1,4,1,5) ]; - is( $#$ar, 1, 'hash assignment in list context' ); - is( "@$ar", "1 5", '...gets the last values' ); - $ar = [ ($x,%h) = (0,1,2,1,3,1,4,1,5) ]; - is( $#$ar, 2, 'scalar + hash assignment in list context' ); - is( "@$ar", "0 1 5", '...gets the last values' ); -} - -# test stringification of keys -{ - no warnings 'once'; - my @types = qw( SCALAR ARRAY HASH CODE GLOB); - my @refs = ( \ do { my $x }, [], {}, sub {}, \ *x); - my(%h, %expect); - @h{@refs} = @types; - @expect{map "$_", @refs} = @types; - ok (eq_hash(\%h, \%expect), 'unblessed ref stringification'); - - bless $_ for @refs; - %h = (); %expect = (); - @h{@refs} = @types; - @expect{map "$_", @refs} = @types; - ok (eq_hash(\%h, \%expect), 'blessed ref stringification'); -} - -# [perl #76716] Hash assignment should not zap weak refs. -{ - my %tb; - require Scalar::Util; - Scalar::Util::weaken(my $p = \%tb); - %tb = (); - is $p, \%tb, "hash assignment should not zap weak refs"; - undef %tb; - is $p, \%tb, "hash undef should not zap weak refs"; -} diff --git a/t/CORE/op/hashwarn.t b/t/CORE/op/hashwarn.t deleted file mode 100644 index 71d70023f..000000000 --- a/t/CORE/op/hashwarn.t +++ /dev/null @@ -1,69 +0,0 @@ -#!./perl - -BEGIN { require 't/CORE/test.pl' } - -plan( tests => 16 ); - -use strict; -use warnings; - -use vars qw{ @warnings }; - -BEGIN { - $SIG{'__WARN__'} = sub { push @warnings, @_ }; - $| = 1; -} - -my $fail_odd = 'Odd number of elements in hash assignment at '; -my $fail_odd_anon = 'Odd number of elements in anonymous hash at '; -my $fail_ref = 'Reference found where even-sized list expected at '; -my $fail_not_hr = 'Not a HASH reference at '; - -{ - @warnings = (); - my %hash = (1..3); - cmp_ok(scalar(@warnings),'==',1,'odd count'); - cmp_ok(substr($warnings[0],0,length($fail_odd)),'eq',$fail_odd,'odd msg'); - - @warnings = (); - %hash = 1; - cmp_ok(scalar(@warnings),'==',1,'scalar count'); - cmp_ok(substr($warnings[0],0,length($fail_odd)),'eq',$fail_odd,'scalar msg'); - - @warnings = (); - %hash = { 1..3 }; - cmp_ok(scalar(@warnings),'==',2,'odd hashref count'); - cmp_ok(substr($warnings[0],0,length($fail_odd_anon)),'eq',$fail_odd_anon,'odd hashref msg 1'); - cmp_ok(substr($warnings[1],0,length($fail_ref)),'eq',$fail_ref,'odd hashref msg 2'); - - @warnings = (); - %hash = [ 1..3 ]; - cmp_ok(scalar(@warnings),'==',1,'arrayref count'); - cmp_ok(substr($warnings[0],0,length($fail_ref)),'eq',$fail_ref,'arrayref msg'); - - @warnings = (); - %hash = sub { print "fenice" }; - cmp_ok(scalar(@warnings),'==',1,'coderef count'); - cmp_ok(substr($warnings[0],0,length($fail_odd)),'eq',$fail_odd,'coderef msg'); - - @warnings = (); - $_ = { 1..10 }; - cmp_ok(scalar(@warnings),'==',0,'hashref assign'); - - # Old pseudo-hash syntax, now removed. - - @warnings = (); - my $avhv = [{x=>1,y=>2}]; - eval { - %$avhv = (x=>13,'y'); - }; - cmp_ok(scalar(@warnings),'==',0,'pseudo-hash 1 count'); - cmp_ok(substr($@,0,length($fail_not_hr)),'eq',$fail_not_hr,'pseudo-hash 1 msg'); - - @warnings = (); - eval { - %$avhv = 'x'; - }; - cmp_ok(scalar(@warnings),'==',0,'pseudo-hash 2 count'); - cmp_ok(substr($@,0,length($fail_not_hr)),'eq',$fail_not_hr,'pseudo-hash 2 msg'); -} diff --git a/t/CORE/op/inc.t b/t/CORE/op/inc.t deleted file mode 100644 index 992742085..000000000 --- a/t/CORE/op/inc.t +++ /dev/null @@ -1,271 +0,0 @@ -#!./perl - - -require 't/CORE/test.pl'; -use warnings; -use strict; - -# Verify that addition/subtraction properly upgrade to doubles. -# These tests are only significant on machines with 32 bit longs, -# and two's complement negation, but shouldn't fail anywhere. - -my $a = 2147483647; -my $c=$a++; -cmp_ok($a, '==', 2147483648); - -$a = 2147483647; -$c=++$a; -cmp_ok($a, '==', 2147483648); - -$a = 2147483647; -$a=$a+1; -cmp_ok($a, '==', 2147483648); - -$a = -2147483648; -$c=$a--; -cmp_ok($a, '==', -2147483649); - -$a = -2147483648; -$c=--$a; -cmp_ok($a, '==', -2147483649); - -$a = -2147483648; -$a=$a-1; -cmp_ok($a, '==', -2147483649); - -$a = 2147483648; -$a = -$a; -$c=$a--; -cmp_ok($a, '==', -2147483649); - -$a = 2147483648; -$a = -$a; -$c=--$a; -cmp_ok($a, '==', -2147483649); - -$a = 2147483648; -$a = -$a; -$a=$a-1; -cmp_ok($a, '==', -2147483649); - -$a = 2147483648; -$b = -$a; -$c=$b--; -cmp_ok($b, '==', -$a-1); - -$a = 2147483648; -$b = -$a; -$c=--$b; -cmp_ok($b, '==', -$a-1); - -$a = 2147483648; -$b = -$a; -$b=$b-1; -cmp_ok($b, '==', -(++$a)); - -$a = undef; -is($a++, '0', "postinc undef returns '0'"); - -$a = undef; -is($a--, undef, "postdec undef returns undef"); - -# Verify that shared hash keys become unshared. - -sub check_same { - my ($orig, $suspect) = @_; - my $fail; - while (my ($key, $value) = each %$suspect) { - if (exists $orig->{$key}) { - if ($orig->{$key} ne $value) { - print "# key '$key' was '$orig->{$key}' now '$value'\n"; - $fail = 1; - } - } else { - print "# key '$key' is '$orig->{$key}', unexpect.\n"; - $fail = 1; - } - } - foreach (keys %$orig) { - next if (exists $suspect->{$_}); - print "# key '$_' was '$orig->{$_}' now missing\n"; - $fail = 1; - } - ok (!$fail); -} - -my (%orig) = my (%inc) = my (%dec) = my (%postinc) = my (%postdec) - = (1 => 1, ab => "ab"); -my %up = (1=>2, ab => 'ac'); -my %down = (1=>0, ab => -1); - -foreach (keys %inc) { - my $ans = $up{$_}; - my $up; - eval {$up = ++$_}; - is($up, $ans); - is($@, ''); -} - -check_same (\%orig, \%inc); - -foreach (keys %dec) { - my $ans = $down{$_}; - my $down; - eval {$down = --$_}; - is($down, $ans); - is($@, ''); -} - -check_same (\%orig, \%dec); - -foreach (keys %postinc) { - my $ans = $postinc{$_}; - my $up; - eval {$up = $_++}; - is($up, $ans); - is($@, ''); -} - -check_same (\%orig, \%postinc); - -foreach (keys %postdec) { - my $ans = $postdec{$_}; - my $down; - eval {$down = $_--}; - is($down, $ans); - is($@, ''); -} - -check_same (\%orig, \%postdec); - -{ - # perlcc issue 192 - https://code.google.com/p/perl-compiler/issues/detail?id=192 - no warnings 'uninitialized'; - my ($x, $y); - eval { - $y ="$x\n"; - ++$x; - }; - cmp_ok($x, '==', 1); - is($@, ''); - - my ($p, $q); - eval { - $q ="$p\n"; - --$p; - }; - cmp_ok($p, '==', -1); - is($@, ''); -} - -$a = 2147483648; -$c=--$a; -cmp_ok($a, '==', 2147483647); - - -$a = 2147483648; -$c=$a--; -cmp_ok($a, '==', 2147483647); - -{ - use integer; - my $x = 0; - $x++; - cmp_ok($x, '==', 1, "(void) i_postinc"); - $x--; - cmp_ok($x, '==', 0, "(void) i_postdec"); -} - -# I'm sure that there's an IBM format with a 48 bit mantissa -# IEEE doubles have a 53 bit mantissa -# 80 bit long doubles have a 64 bit mantissa -# sparcs have a 112 bit mantissa for their long doubles. Just to be awkward :-) - -my $h_uv_max = 1 + (~0 >> 1); -my $found; -for my $n (47..113) { - my $power_of_2 = 2**$n; - my $plus_1 = $power_of_2 + 1; - next if $plus_1 != $power_of_2; - my ($start_p, $start_n); - if ($h_uv_max > $power_of_2 / 2) { - my $uv_max = 1 + 2 * (~0 >> 1); - # UV_MAX is 2**$something - 1, so subtract 1 to get the start value - $start_p = $uv_max - 1; - # whereas IV_MIN is -(2**$something), so subtract 2 - $start_n = -$h_uv_max + 2; - print "# Mantissa overflows at 2**$n ($power_of_2)\n"; - print "# But max UV ($uv_max) is greater so testing that\n"; - } else { - print "# Testing 2**$n ($power_of_2) which overflows the mantissa\n"; - $start_p = int($power_of_2 - 2); - $start_n = -$start_p; - my $check = $power_of_2 - 2; - die "Something wrong with our rounding assumptions: $check vs $start_p" - unless $start_p == $check; - } - - foreach ([$start_p, '++$i', 'pre-inc', 'inc'], - [$start_p, '$i++', 'post-inc', 'inc'], - [$start_n, '--$i', 'pre-dec', 'dec'], - [$start_n, '$i--', 'post-dec', 'dec']) { - my ($start, $action, $description, $act) = @$_; - my $code = eval << "EOC" or die $@; -sub { - no warnings 'imprecision'; - my \$i = \$start; - for(0 .. 3) { - my \$a = $action; - } -} -EOC - - warning_is($code, undef, "$description under no warnings 'imprecision'"); - - $code = eval << "EOC" or die $@; -sub { - use warnings 'imprecision'; - my \$i = \$start; - for(0 .. 3) { - my \$a = $action; - } -} -EOC - - warnings_like($code, [(qr/Lost precision when ${act}rementing -?\d+/) x 2], - "$description under use warnings 'imprecision'"); - } - - $found = 1; - last; -} -die "Could not find a value which overflows the mantissa" unless $found; - -# these will segfault if they fail - -sub PVBM () { 'foo' } -{ my $dummy = index 'foo', PVBM } - -isnt(scalar eval { my $pvbm = PVBM; $pvbm++ }, undef); -isnt(scalar eval { my $pvbm = PVBM; $pvbm-- }, undef); -isnt(scalar eval { my $pvbm = PVBM; ++$pvbm }, undef); -isnt(scalar eval { my $pvbm = PVBM; --$pvbm }, undef); - -# #9466 - -# don't use pad TARG when the thing you're copying is a ref, or the referent -# won't get freed. -{ - package P9466; - my $x; - sub DESTROY { $x = 1 } - for (0..1) { - $x = 0; - my $a = bless {}; - my $b = $_ ? $a++ : $a--; - undef $a; undef $b; - ::is($x, 1, "9466 case $_"); - } -} - -done_testing(); diff --git a/t/CORE/op/inccode-tie.t b/t/CORE/op/inccode-tie.t deleted file mode 100644 index 90594a361..000000000 --- a/t/CORE/op/inccode-tie.t +++ /dev/null @@ -1,15 +0,0 @@ -#!./perl - -# Calls all tests in op/inccode.t after tying @INC first. - -use Tie::Array; -my @orig_INC = @INC; -tie @INC, 'Tie::StdArray'; -@INC = @orig_INC; -for my $file ('./t/CORE/op/inccode.t', './op/inccode.t', './t/op/inccode.t', ':op:inccode.t') { - if (-r $file) { - do $file; die $@ if $@; - exit; - } -} -die "Cannot find ./op/inccode.t or ./t/op/inccode.t\n"; diff --git a/t/CORE/op/inccode.t b/t/CORE/op/inccode.t deleted file mode 100644 index 4f73f4b6b..000000000 --- a/t/CORE/op/inccode.t +++ /dev/null @@ -1,304 +0,0 @@ -#!./perl -w - -# Tests for the coderef-in-@INC feature - -BEGIN { - unshift @INC, "./lib"; - require 't/CORE/test.pl'; -} - -use Config; - -my $can_fork = 0; -my $has_perlio = $Config{useperlio}; - -if ($Config{d_fork} && eval 'require POSIX; 1') { - $can_fork = 1; -} - -use strict; - -plan(tests => 49 + (3 + 14 * $can_fork)); - -sub get_temp_fh { - my $f = tempfile(); - open my $fh, ">$f" or die "Can't create $f: $!"; - print $fh "package ".substr($_[0],0,-3).";\n1;\n"; - print $fh $_[1] if @_ > 1; - close $fh or die "Couldn't close: $!"; - open $fh, $f or die "Can't open $f: $!"; - return $fh; -} - -sub fooinc { - my ($self, $filename) = @_; - if (substr($filename,0,3) eq 'Foo') { - return get_temp_fh($filename); - } - else { - return undef; - } -} - -push @INC, \&fooinc; - -my $evalret = eval { require Bar; 1 }; -ok( !$evalret, 'Trying non-magic package' ); - -$evalret = eval { require Foo; 1 }; -die $@ if $@; -ok( $evalret, 'require Foo; magic via code ref' ); -ok( exists $INC{'Foo.pm'}, ' %INC sees Foo.pm' ); -is( ref $INC{'Foo.pm'}, 'CODE', ' val Foo.pm is a coderef in %INC' ); -is( $INC{'Foo.pm'}, \&fooinc, ' val Foo.pm is correct in %INC' ); - -$evalret = eval "use Foo1; 1;"; -die $@ if $@; -ok( $evalret, 'use Foo1' ); -ok( exists $INC{'Foo1.pm'}, ' %INC sees Foo1.pm' ); -is( ref $INC{'Foo1.pm'}, 'CODE', ' val Foo1.pm is a coderef in %INC' ); -is( $INC{'Foo1.pm'}, \&fooinc, ' val Foo1.pm is correct in %INC' ); - -$evalret = eval { do 'Foo2.pl'; 1 }; -die $@ if $@; -ok( $evalret, 'do "Foo2.pl"' ); -ok( exists $INC{'Foo2.pl'}, ' %INC sees Foo2.pl' ); -is( ref $INC{'Foo2.pl'}, 'CODE', ' val Foo2.pl is a coderef in %INC' ); -is( $INC{'Foo2.pl'}, \&fooinc, ' val Foo2.pl is correct in %INC' ); - -pop @INC; - - -sub fooinc2 { - my ($self, $filename) = @_; - if (substr($filename, 0, length($self->[1])) eq $self->[1]) { - return get_temp_fh($filename); - } - else { - return undef; - } -} - -my $arrayref = [ \&fooinc2, 'Bar' ]; -push @INC, $arrayref; - -$evalret = eval { require Foo; 1; }; -die $@ if $@; -ok( $evalret, 'Originally loaded packages preserved' ); -$evalret = eval { require Foo3; 1; }; -ok( !$evalret, 'Original magic INC purged' ); - -$evalret = eval { require Bar; 1 }; -die $@ if $@; -ok( $evalret, 'require Bar; magic via array ref' ); -ok( exists $INC{'Bar.pm'}, ' %INC sees Bar.pm' ); -is( ref $INC{'Bar.pm'}, 'ARRAY', ' val Bar.pm is an arrayref in %INC' ); -is( $INC{'Bar.pm'}, $arrayref, ' val Bar.pm is correct in %INC' ); - -ok( eval "use Bar1; 1;", 'use Bar1' ); -ok( exists $INC{'Bar1.pm'}, ' %INC sees Bar1.pm' ); -is( ref $INC{'Bar1.pm'}, 'ARRAY', ' val Bar1.pm is an arrayref in %INC' ); -is( $INC{'Bar1.pm'}, $arrayref, ' val Bar1.pm is correct in %INC' ); - -ok( eval { do 'Bar2.pl'; 1 }, 'do "Bar2.pl"' ); -ok( exists $INC{'Bar2.pl'}, ' %INC sees Bar2.pl' ); -is( ref $INC{'Bar2.pl'}, 'ARRAY', ' val Bar2.pl is an arrayref in %INC' ); -is( $INC{'Bar2.pl'}, $arrayref, ' val Bar2.pl is correct in %INC' ); - -pop @INC; - -sub FooLoader::INC { - my ($self, $filename) = @_; - if (substr($filename,0,4) eq 'Quux') { - return get_temp_fh($filename); - } - else { - return undef; - } -} - -my $href = bless( {}, 'FooLoader' ); -push @INC, $href; - -$evalret = eval { require Quux; 1 }; -die $@ if $@; -ok( $evalret, 'require Quux; magic via hash object' ); -ok( exists $INC{'Quux.pm'}, ' %INC sees Quux.pm' ); -is( ref $INC{'Quux.pm'}, 'FooLoader', - ' val Quux.pm is an object in %INC' ); -is( $INC{'Quux.pm'}, $href, ' val Quux.pm is correct in %INC' ); - -pop @INC; - -my $aref = bless( [], 'FooLoader' ); -push @INC, $aref; - -$evalret = eval { require Quux1; 1 }; -die $@ if $@; -ok( $evalret, 'require Quux1; magic via array object' ); -ok( exists $INC{'Quux1.pm'}, ' %INC sees Quux1.pm' ); -is( ref $INC{'Quux1.pm'}, 'FooLoader', - ' val Quux1.pm is an object in %INC' ); -is( $INC{'Quux1.pm'}, $aref, ' val Quux1.pm is correct in %INC' ); - -pop @INC; - -my $sref = bless( \(my $x = 1), 'FooLoader' ); -push @INC, $sref; - -$evalret = eval { require Quux2; 1 }; -die $@ if $@; -ok( $evalret, 'require Quux2; magic via scalar object' ); -ok( exists $INC{'Quux2.pm'}, ' %INC sees Quux2.pm' ); -is( ref $INC{'Quux2.pm'}, 'FooLoader', - ' val Quux2.pm is an object in %INC' ); -is( $INC{'Quux2.pm'}, $sref, ' val Quux2.pm is correct in %INC' ); - -pop @INC; - -push @INC, sub { - my ($self, $filename) = @_; - if (substr($filename,0,4) eq 'Toto') { - $INC{$filename} = 'xyz'; - return get_temp_fh($filename); - } - else { - return undef; - } -}; - -$evalret = eval { require Toto; 1 }; -die $@ if $@; -ok( $evalret, 'require Toto; magic via anonymous code ref' ); -ok( exists $INC{'Toto.pm'}, ' %INC sees Toto.pm' ); -ok( ! ref $INC{'Toto.pm'}, q/ val Toto.pm isn't a ref in %INC/ ); -is( $INC{'Toto.pm'}, 'xyz', ' val Toto.pm is correct in %INC' ); - -pop @INC; - -push @INC, sub { - my ($self, $filename) = @_; - if ($filename eq 'abc.pl') { - return get_temp_fh($filename, qq(return "abc";\n)); - } - else { - return undef; - } -}; - -my $ret = ""; -$ret ||= do 'abc.pl'; -is( $ret, 'abc', 'do "abc.pl" sees return value' ); - -{ - my $filename = './Foo.pm'; - #local @INC; # local fails on tied @INC - my @old_INC = @INC; # because local doesn't work on tied arrays - @INC = sub { $filename = 'seen'; return undef; }; - eval { require $filename; }; - is( $filename, 'seen', 'the coderef sees fully-qualified pathnames' ); - @INC = @old_INC; -} - -# this will segfault if it fails - -sub PVBM () { 'foo' } -{ my $dummy = index 'foo', PVBM } - -# I don't know whether these requires should succeed or fail. 5.8 failed -# all of them; 5.10 with an ordinary constant in place of PVBM lets the -# latter two succeed. For now I don't care, as long as they don't -# segfault :). - -unshift @INC, sub { PVBM }; -eval 'require foo'; -ok( 1, 'returning PVBM doesn\'t segfault require' ); -eval 'use foo'; -ok( 1, 'returning PVBM doesn\'t segfault use' ); -shift @INC; -unshift @INC, sub { \PVBM }; -eval 'require foo'; -ok( 1, 'returning PVBM ref doesn\'t segfault require' ); -eval 'use foo'; -ok( 1, 'returning PVBM ref doesn\'t segfault use' ); -shift @INC; - -SKIP: { - skip( "No PerlIO available", 3 ) unless $has_perlio; - pop @INC; - - push @INC, sub { - my ($cr, $filename) = @_; - my $module = $filename; $module =~ s,/,::,g; $module =~ s/\.pm$//; - open my $fh, '<', - \"package $module; sub complain { warn q() }; \$::file = __FILE__;" - or die $!; - $INC{$filename} = "/custom/path/to/$filename"; - return $fh; - }; - - require Publius::Vergilius::Maro; - is( $INC{'Publius/Vergilius/Maro.pm'}, - '/custom/path/to/Publius/Vergilius/Maro.pm', '%INC set correctly'); - is( our $file, '/custom/path/to/Publius/Vergilius/Maro.pm', - '__FILE__ set correctly' ); - { - my $warning; - local $SIG{__WARN__} = sub { $warning = shift }; - Publius::Vergilius::Maro::complain(); - like( $warning, qr{something's wrong at /custom/path/to/Publius/Vergilius/Maro.pm}, 'warn() reports correct file source' ); - } -} -pop @INC; - -if ($can_fork) { - require PerlIO::scalar; - # This little bundle of joy generates n more recursive use statements, - # with each module chaining the next one down to 0. If it works, then we - # can safely nest subprocesses - my $use_filter_too; - push @INC, sub { - return unless $_[1] =~ /^BBBLPLAST(\d+)\.pm/; - my $pid = open my $fh, "-|"; - if ($pid) { - # Parent - return $fh unless $use_filter_too; - # Try filters and state in addition. - return ($fh, sub {s/$_[1]/pass/; return}, "die") - } - die "Can't fork self: $!" unless defined $pid; - - # Child - my $count = $1; - # Lets force some fun with odd sized reads. - $| = 1; - print 'push @main::bbblplast, '; - print "$count;\n"; - if ($count--) { - print "use BBBLPLAST$count;\n"; - } - if ($use_filter_too) { - print "die('In $_[1]');"; - } else { - print "pass('In $_[1]');"; - } - print '"Truth"'; - POSIX::_exit(0); - die "Can't get here: $!"; - }; - - @::bbblplast = (); - require BBBLPLAST5; - is ("@::bbblplast", "0 1 2 3 4 5", "All ran"); - - foreach (keys %INC) { - delete $INC{$_} if /^BBBLPLAST/; - } - - @::bbblplast = (); - $use_filter_too = 1; - - require BBBLPLAST5; - - is ("@::bbblplast", "0 1 2 3 4 5", "All ran with a filter"); -} diff --git a/t/CORE/op/incfilter.t b/t/CORE/op/incfilter.t deleted file mode 100644 index 357ec19da..000000000 --- a/t/CORE/op/incfilter.t +++ /dev/null @@ -1,244 +0,0 @@ -#!./perl -w - -# Tests for the source filters in coderef-in-@INC - -BEGIN { require 't/CORE/test.pl' } - -use strict; -use Config; -use Filter::Util::Call; - -plan(tests => 145); - -unshift @INC, sub { - no warnings 'uninitialized'; - ref $_[1] eq 'ARRAY' ? @{$_[1]} : $_[1]; -}; - -my $fh; - -open $fh, "<", \'pass("Can return file handles from \@INC");'; -do $fh or die; - -my @origlines = ("# This is a blank line\n", - "pass('Can return generators from \@INC');\n", - "pass('Which return multiple lines');\n", - "1", - ); -my @lines = @origlines; -sub generator { - $_ = shift @lines; - # Return of 0 marks EOF - return defined $_ ? 1 : 0; -}; - -do \&generator or die; - -@lines = @origlines; -# Check that the array dereferencing works ready for the more complex tests: -do [\&generator] or die; - -sub generator_with_state { - my $param = $_[1]; - is (ref $param, 'ARRAY', "Got our parameter"); - $_ = shift @$param; - return defined $_ ? 1 : 0; -} - -do [\&generator_with_state, - ["pass('Can return generators which take state');\n", - "pass('And return multiple lines');\n", - ]] or die; - - -open $fh, "<", \'fail("File handles and filters work from \@INC");'; - -do [$fh, sub {s/fail/pass/; return;}] or die; - -open $fh, "<", \'fail("File handles and filters with state work from \@INC");'; - -do [$fh, sub {s/$_[1]/pass/; return;}, 'fail'] or die; - -print "# 2 tests with pipes from subprocesses.\n"; - -my ($echo_command, $pass_arg, $fail_arg); - -if ($^O eq 'VMS') { - $echo_command = 'write sys$output'; - $pass_arg = '"pass"'; - $fail_arg = '"fail"'; -} -else { - $echo_command = 'echo'; - $pass_arg = 'pass'; - $fail_arg = 'fail'; -} - -open $fh, "$echo_command $pass_arg|" or die $!; - -do $fh or die; - -open $fh, "$echo_command $fail_arg|" or die $!; - -do [$fh, sub {s/$_[1]/pass/; return;}, 'fail'] or die; - -sub rot13_filter { - filter_add(sub { - my $status = filter_read(); - tr/A-Za-z/N-ZA-Mn-za-m/; - $status; - }) -} - -open $fh, "<", \<<'EOC'; -BEGIN {rot13_filter}; -cnff("This will rot13'ed prepend"); -EOC - -do $fh or die; - -open $fh, "<", \<<'EOC'; -ORTVA {ebg13_svygre}; -pass("This will rot13'ed twice"); -EOC - -do [$fh, sub {tr/A-Za-z/N-ZA-Mn-za-m/; return;}] or die; - -my $count = 32; -sub prepend_rot13_filter { - filter_add(sub { - my $previous = $_; - # Filters should append to any existing data in $_ - # But (logically) shouldn't filter it twice. - my $test = "fzrt!"; - $_ = $test; - my $status = filter_read(); - my $got = substr $_, 0, length $test, ''; - is $got, $test, "Upstream didn't alter existing data"; - tr/A-Za-z/N-ZA-Mn-za-m/; - $_ = $previous . $_; - die "Looping infinitely" unless $count--; - $status; - }) -} - -open $fh, "<", \<<'EOC'; -ORTVA {cercraq_ebg13_svygre}; -pass("This will rot13'ed twice"); -EOC - -do [$fh, sub {tr/A-Za-z/N-ZA-Mn-za-m/; return;}] or die; - -# This generates a heck of a lot of oks, but I think it's necessary. -my $amount = 1; -sub prepend_block_counting_filter { - filter_add(sub { - my $output = $_; - my $count = 256; - while (--$count) { - $_ = ''; - my $status = filter_read($amount); - cmp_ok (length $_, '<=', $amount, "block mode works?"); - $output .= $_; - if ($status <= 0 or /\n/s) { - $_ = $output; - return $status; - } - } - die "Looping infinitely"; - - }) -} - -open $fh, "<", \<<'EOC'; -BEGIN {prepend_block_counting_filter}; -pass("one by one"); -pass("and again"); -EOC - -do [$fh, sub {return;}] or die; - -open $fh, "<", \<<'EOC'; -BEGIN {prepend_block_counting_filter}; -pas("SSS make s fast SSS"); -EOC - -TODO: { - todo_skip "disabled under -Dmad", 50 if $Config{mad}; - do [$fh, sub {s/s/ss/gs; s/([\nS])/$1$1$1/gs; return;}] or die; -} - -sub prepend_line_counting_filter { - filter_add(sub { - my $output = $_; - $_ = ''; - my $status = filter_read(); - my $newlines = tr/\n//; - cmp_ok ($newlines, '<=', 1, "1 line at most?"); - $_ = $output . $_ if defined $output; - return $status; - }) -} - -open $fh, "<", \<<'EOC'; -BEGIN {prepend_line_counting_filter}; -pass("You should see this line thrice"); -EOC - -do [$fh, sub {$_ .= $_ . $_; return;}] or die; - -do \"pass\n(\n'Scalar references are treated as initial file contents'\n)\n" -or die; - -open $fh, "<", \"ss('The file is concatenated');"; - -do [\'pa', $fh] or die; - -open $fh, "<", \"ff('Gur svygre vf bayl eha ba gur svyr');"; - -do [\'pa', $fh, sub {tr/A-Za-z/N-ZA-Mn-za-m/; return;}] or die; - -open $fh, "<", \"SS('State also works');"; - -do [\'pa', $fh, sub {s/($_[1])/lc $1/ge; return;}, "S"] or die; - -@lines = ('ss', '(', "'you can use a generator'", ')'); - -do [\'pa', \&generator] or die; - -do [\'pa', \&generator_with_state, - ["ss('And generators which take state');\n", - "pass('And return multiple lines');\n", - ]] or die; - -# d8723a6a74b2c12e wasn't perfect, as the char * returned by SvPV*() can be -# a temporary, freed at the next FREETMPS. And there is a FREETMPS in -# pp_require - -for (0 .. 1) { - # Need both alternatives on the regexp, because currently the logic in - # pp_require for what is written to %INC is somewhat confused - open $fh, "<", - \'like(__FILE__, qr/(?:GLOB|CODE)\(0x[0-9a-f]+\)/, "__FILE__ is valid");'; - do $fh or die; -} - -# [perl #91880] $_ marked TEMP or having the wrong refcount inside a -{ # filter sub - local @INC; local $|; - unshift @INC, sub { sub { undef *_; --$| }}; - do "dah"; - pass '$_ has the right refcount inside a filter sub'; - - my $temps = 0; - @INC = sub { sub { - my $temp = \sub{$_}->(); - $temps++ if $temp == \$_; - $_ = "a" unless $|; - return --$| - }}; - local $^W; - do "dah"; - - is $temps, 0, '$_ is not marked TEMP'; -} diff --git a/t/CORE/op/index.t b/t/CORE/op/index.t deleted file mode 100644 index a91624542..000000000 --- a/t/CORE/op/index.t +++ /dev/null @@ -1,226 +0,0 @@ -#!./perl - -BEGIN { - unshift @INC, 't/CORE/lib'; - require 't/CORE/test.pl'; -} - -use strict; -plan( tests => 120 ); - -run_tests() unless caller; - -sub run_tests { - -my $foo = 'Now is the time for all good men to come to the aid of their country.'; - -my $first = substr($foo,0,index($foo,'the')); -is($first, "Now is "); - -my $last = substr($foo,rindex($foo,'the'),100); -is($last, "their country."); - -$last = substr($foo,index($foo,'Now'),2); -is($last, "No"); - -$last = substr($foo,rindex($foo,'Now'),2); -is($last, "No"); - -$last = substr($foo,index($foo,'.'),100); -is($last, "."); - -$last = substr($foo,rindex($foo,'.'),100); -is($last, "."); - -is(index("ababa","a",-1), 0); -is(index("ababa","a",0), 0); -is(index("ababa","a",1), 2); -is(index("ababa","a",2), 2); -is(index("ababa","a",3), 4); -is(index("ababa","a",4), 4); -is(index("ababa","a",5), -1); - -is(rindex("ababa","a",-1), -1); -is(rindex("ababa","a",0), 0); -is(rindex("ababa","a",1), 0); -is(rindex("ababa","a",2), 2); -is(rindex("ababa","a",3), 2); -is(rindex("ababa","a",4), 4); -is(rindex("ababa","a",5), 4); - -# tests for empty search string -is(index("abc", "", -1), 0); -is(index("abc", "", 0), 0); -is(index("abc", "", 1), 1); -is(index("abc", "", 2), 2); -is(index("abc", "", 3), 3); -is(index("abc", "", 4), 3); -is(rindex("abc", "", -1), 0); -is(rindex("abc", "", 0), 0); -is(rindex("abc", "", 1), 1); -is(rindex("abc", "", 2), 2); -is(rindex("abc", "", 3), 3); -is(rindex("abc", "", 4), 3); - -$a = "foo \x{1234}bar"; - -is(index($a, "\x{1234}"), 4); -is(index($a, "bar", ), 5); - -is(rindex($a, "\x{1234}"), 4); -is(rindex($a, "foo", ), 0); - -{ - my $needle = "\x{1230}\x{1270}"; - my @needles = split ( //, $needle ); - my $haystack = "\x{1228}\x{1228}\x{1230}\x{1270}"; - foreach ( @needles ) { - my $a = index ( "\x{1228}\x{1228}\x{1230}\x{1270}", $_ ); - my $b = index ( $haystack, $_ ); - is($a, $b, q{[perl #22375] 'split'/'index' problem for utf8}); - } - $needle = "\x{1270}\x{1230}"; # Transpose them. - @needles = split ( //, $needle ); - foreach ( @needles ) { - my $a = index ( "\x{1228}\x{1228}\x{1230}\x{1270}", $_ ); - my $b = index ( $haystack, $_ ); - is($a, $b, q{[perl #22375] 'split'/'index' problem for utf8}); - } -} - -{ - my $search; - my $text; - $search = latin1_to_native("foo \xc9 bar"); - $text = latin1_to_native("a\xa3\xa3a $search $search quux"); - - my $text_utf8 = $text; - utf8::upgrade($text_utf8); - my $search_utf8 = $search; - utf8::upgrade($search_utf8); - - is (index($text, $search), 5); - is (rindex($text, $search), 18); - is (index($text, $search_utf8), 5); - is (rindex($text, $search_utf8), 18); - is (index($text_utf8, $search), 5); - is (rindex($text_utf8, $search), 18); - is (index($text_utf8, $search_utf8), 5); - is (rindex($text_utf8, $search_utf8), 18); - - my $text_octets = $text_utf8; - utf8::encode ($text_octets); - my $search_octets = $search_utf8; - utf8::encode ($search_octets); - - is (index($text_octets, $search_octets), 7, "index octets, octets") - or _diag ($text_octets, $search_octets); - is (rindex($text_octets, $search_octets), 21, "rindex octets, octets"); - is (index($text_octets, $search_utf8), -1); - is (rindex($text_octets, $search_utf8), -1); - is (index($text_utf8, $search_octets), -1); - is (rindex($text_utf8, $search_octets), -1); - - is (index($text_octets, $search), -1); - is (rindex($text_octets, $search), -1); - is (index($text, $search_octets), -1); - is (rindex($text, $search_octets), -1); -} - -foreach my $utf8 ('', ', utf-8') { - foreach my $arraybase (0, 1, -1, -2) { - my $expect_pos = 2 + $arraybase; - - my $prog = "no warnings 'deprecated';\n"; - $prog .= "\$[ = $arraybase; \$big = \"N\\xabN\\xab\"; "; - $prog .= '$big .= chr 256; chop $big; ' if $utf8; - $prog .= 'print rindex $big, "N", 2 + $['; - - fresh_perl_is($prog, $expect_pos, {}, "\$[ = $arraybase$utf8"); - } -} - -SKIP: { - skip "UTF-EBCDIC is limited to 0x7fffffff", 3 if ord("A") == 193; - - my $a = "\x{80000000}"; - my $s = $a.'defxyz'; - is(index($s, 'def'), 1, "0x80000000 is a single character"); - - my $b = "\x{fffffffd}"; - my $t = $b.'pqrxyz'; - is(index($t, 'pqr'), 1, "0xfffffffd is a single character"); - - local ${^UTF8CACHE} = -1; - is(index($t, 'xyz'), 4, "0xfffffffd and utf8cache"); -} - - -# Tests for NUL characters. -{ - my @tests = ( - ["", -1, -1, -1], - ["foo", -1, -1, -1], - ["\0", 0, -1, -1], - ["\0\0", 0, 0, -1], - ["\0\0\0", 0, 0, 0], - ["foo\0", 3, -1, -1], - ["foo\0foo\0\0", 3, 7, -1], - ); - foreach my $l (1 .. 3) { - my $q = "\0" x $l; - my $i = 0; - foreach my $test (@tests) { - $i ++; - my $str = $$test [0]; - my $res = $$test [$l]; - - { - is (index ($str, $q), $res, "Find NUL character(s)"); - } - - # - # Bug #53746 shows a difference between variables and literals, - # so test literals as well. - # - my $test_str = qq {is (index ("$str", "$q"), $res, } . - qq {"Find NUL character(s)")}; - $test_str =~ s/\0/\\0/g; - - eval $test_str; - die $@ if $@; - } - } -} - -{ - # RT#75898 - is(eval { utf8::upgrade($_ = " "); index $_, " ", 72 }, -1, - 'UTF-8 cache handles offset beyond the end of the string'); - $_ = "\x{100}BC"; - is(index($_, "C", 4), -1, - 'UTF-8 cache handles offset beyond the end of the string'); -} - -# RT #89218 -use constant {PVBM => 'galumphing', PVBM2 => 'bang'}; - -sub index_it { - is(index('galumphing', PVBM), 0, - "index isn't confused by format compilation"); -} - -index_it(); -is($^A, '', '$^A is empty'); -formline PVBM; -is($^A, 'galumphing', "formline isn't confused by index compilation"); -index_it(); - -$^A = ''; -# must not do index here before formline. -is($^A, '', '$^A is empty'); -formline PVBM2; -is($^A, 'bang', "formline isn't confused by index compilation"); -is(index('bang', PVBM2), 0, "index isn't confused by format compilation"); - -} diff --git a/t/CORE/op/int.t b/t/CORE/op/int.t deleted file mode 100644 index 2203148fa..000000000 --- a/t/CORE/op/int.t +++ /dev/null @@ -1,68 +0,0 @@ -#!./perl - -BEGIN { - unshift @INC, 't/CORE/lib'; - require 't/CORE/test.pl'; -} - -plan 15; - -# compile time evaluation - -if (int(1.234) == 1) {pass()} else {fail()} - -if (int(-1.234) == -1) {pass()} else {fail()} - -# run time evaluation - -$x = 1.234; -cmp_ok(int($x), '==', 1); -cmp_ok(int(-$x), '==', -1); - -$x = length("abc") % -10; -cmp_ok($x, '==', -7); - -{ - my $fail; - use integer; - $x = length("abc") % -10; - $y = (3/-10)*-10; - ok($x+$y == 3) or ++$fail; - ok(abs($x) < 10) or ++$fail; - if ($fail) { - diag("\$x == $x", "\$y == $y"); - } -} - -@x = ( 6, 8, 10); -cmp_ok($x["1foo"], '==', 8, 'check bad strings still get converted'); - -$x = 4294967303.15; -$y = int ($x); -is($y, "4294967303", 'check values > 32 bits work'); - -$y = int (-$x); - -is($y, "-4294967303"); - -$x = 4294967294.2; -$y = int ($x); - -is($y, "4294967294"); - -$x = 4294967295.7; -$y = int ($x); - -is($y, "4294967295"); - -$x = 4294967296.11312; -$y = int ($x); - -is($y, "4294967296"); - -$y = int(279964589018079/59); -cmp_ok($y, '==', 4745162525730); - -$y = 279964589018079; -$y = int($y/59); -cmp_ok($y, '==', 4745162525730); diff --git a/t/CORE/op/join.t b/t/CORE/op/join.t deleted file mode 100644 index c2829df09..000000000 --- a/t/CORE/op/join.t +++ /dev/null @@ -1,113 +0,0 @@ -#!./perl - -print "1..22\n"; - -@x = (1, 2, 3); -if (join(':',@x) eq '1:2:3') {print "ok 1\n";} else {print "not ok 1\n";} - -if (join('',1,2,3) eq '123') {print "ok 2\n";} else {print "not ok 2\n";} - -if (join(':',split(/ /,"1 2 3")) eq '1:2:3') {print "ok 3\n";} else {print "not ok 3\n";} - -my $f = 'a'; -$f = join ',', 'b', $f, 'e'; -if ($f eq 'b,a,e') {print "ok 4\n";} else {print "# '$f'\nnot ok 4\n";} - -$f = 'a'; -$f = join ',', $f, 'b', 'e'; -if ($f eq 'a,b,e') {print "ok 5\n";} else {print "not ok 5\n";} - -$f = 'a'; -$f = join $f, 'b', 'e', 'k'; -if ($f eq 'baeak') {print "ok 6\n";} else {print "# '$f'\nnot ok 6\n";} - -# 7,8 check for multiple read of tied objects -{ package X; - sub TIESCALAR { my $x = 7; bless \$x }; - sub FETCH { my $y = shift; $$y += 5 }; - tie my $t, 'X'; - my $r = join ':', $t, 99, $t, 99; - print "# expected '12:99:17:99' got '$r'\nnot " if $r ne '12:99:17:99'; - print "ok 7\n"; - $r = join '', $t, 99, $t, 99; - print "# expected '22992799' got '$r'\nnot " if $r ne '22992799'; - print "ok 8\n"; -}; - -# 9,10 and for multiple read of undef -{ my $s = 5; - local ($^W, $SIG{__WARN__}) = ( 1, sub { $s+=4 } ); - my $r = join ':', 'a', undef, $s, 'b', undef, $s, 'c'; - print "# expected 'a::9:b::13:c' got '$r'\nnot " if $r ne 'a::9:b::13:c'; - print "ok 9\n"; - my $r = join '', 'a', undef, $s, 'b', undef, $s, 'c'; - print "# expected 'a17b21c' got '$r'\nnot " if $r ne 'a17b21c'; - print "ok 10\n"; -}; - -{ my $s = join("", chr(0x1234), chr(0xff)); - print "not " unless length($s) == 2 && $s eq "\x{1234}\x{ff}"; - print "ok 11\n"; -} - -{ my $s = join(chr(0xff), chr(0x1234), ""); - print "not " unless length($s) == 2 && $s eq "\x{1234}\x{ff}"; - print "ok 12\n"; -} - -{ my $s = join(chr(0x1234), chr(0xff), chr(0x2345)); - print "not " unless length($s) == 3 && $s eq "\x{ff}\x{1234}\x{2345}"; - print "ok 13\n"; -} - -{ my $s = join(chr(0xff), chr(0x1234), chr(0xfe)); - print "not " unless length($s) == 3 && $s eq "\x{1234}\x{ff}\x{fe}"; - print "ok 14\n"; -} - -{ # [perl #24846] $jb2 should be in bytes, not in utf8. - my $b = "abc\304"; - my $u = "abc\x{0100}"; - - sub join_into_my_variable { - my $r = join("", @_); - return $r; - } - - my $jb1 = join_into_my_variable("", $b); - my $ju1 = join_into_my_variable("", $u); - my $jb2 = join_into_my_variable("", $b); - my $ju2 = join_into_my_variable("", $u); - - { - use bytes; - print "not " unless $jb1 eq $b; - print "ok 15\n"; - } - print "not " unless $jb1 eq $b; - print "ok 16\n"; - - { - use bytes; - print "not " unless $ju1 eq $u; - print "ok 17\n"; - } - print "not " unless $ju1 eq $u; - print "ok 18\n"; - - { - use bytes; - print "not " unless $jb2 eq $b; - print "ok 19\n"; - } - print "not " unless $jb2 eq $b; - print "ok 20\n"; - - { - use bytes; - print "not " unless $ju2 eq $u; - print "ok 21\n"; - } - print "not " unless $ju2 eq $u; - print "ok 22\n"; -} diff --git a/t/CORE/op/kill0.t b/t/CORE/op/kill0.t deleted file mode 100644 index 0d0494cc3..000000000 --- a/t/CORE/op/kill0.t +++ /dev/null @@ -1,51 +0,0 @@ -#!./perl - -BEGIN { - unshift @INC, 't/CORE/lib'; - require 't/CORE/test.pl'; -} - -BEGIN { - if ($^O eq 'riscos') { - skip_all("kill() not implemented on this platform"); - } -} - -use strict; - -plan tests => 6; - -ok( kill(0, $$), 'kill(0, $pid) returns true if $pid exists' ); - -# It's not easy to come up with an individual PID that is known not to exist, -# so just check that at least some PIDs in a large range are reported not to -# exist. -my $count = 0; -my $total = 30_000; -for my $pid (1 .. $total) { - ++$count if kill(0, $pid); -} -# It is highly unlikely that all of the above PIDs are genuinely in use, -# so $count should be less than $total. -ok( $count < $total, 'kill(0, $pid) returns false if $pid does not exist' ); - -# Verify that trying to kill a non-numeric PID is fatal -my @bad_pids = ( - [ undef , 'undef' ], - [ '' , 'empty string' ], - [ 'abcd', 'alphabetic' ], -); - -for my $case ( @bad_pids ) { - my ($pid, $name) = @$case; - eval { kill 0, $pid }; - like( $@, qr/^Can't kill a non-numeric process ID/, "dies killing $name pid"); -} - -# Verify that killing a magic variable containing a number doesn't -# trigger the above -{ - my $x = $$ . " "; - $x =~ /(\d+)/; - ok(eval { kill 0, $1 }, "can kill a number string in a magic variable"); -} diff --git a/t/CORE/op/lc.t b/t/CORE/op/lc.t deleted file mode 100644 index 469df5327..000000000 --- a/t/CORE/op/lc.t +++ /dev/null @@ -1,207 +0,0 @@ -#!./perl - -BEGIN { - unshift @INC, 't/CORE/lib'; - require 't/CORE/test.pl'; -} - -# perlcc issue #162 https://code.google.com/p/perl-compiler/issues/detail?id=162 -# problem with utf-8 - -plan tests => 93; - -is(lc(undef), "", "lc(undef) is ''"); -is(lcfirst(undef), "", "lcfirst(undef) is ''"); -is(uc(undef), "", "uc(undef) is ''"); -is(ucfirst(undef), "", "ucfirst(undef) is ''"); - -$a = "HELLO.* world"; -$b = "hello.* WORLD"; - -is("\Q$a\E." , "HELLO\\.\\*\\ world.", '\Q\E HELLO.* world'); -is("\u$a" , "HELLO\.\* world", '\u'); -is("\l$a" , "hELLO\.\* world", '\l'); -is("\U$a" , "HELLO\.\* WORLD", '\U'); -is("\L$a" , "hello\.\* world", '\L'); - -is(quotemeta($a) , "HELLO\\.\\*\\ world", 'quotemeta'); -is(ucfirst($a) , "HELLO\.\* world", 'ucfirst'); -is(lcfirst($a) , "hELLO\.\* world", 'lcfirst'); -is(uc($a) , "HELLO\.\* WORLD", 'uc'); -is(lc($a) , "hello\.\* world", 'lc'); - -is("\Q$b\E." , "hello\\.\\*\\ WORLD.", '\Q\E hello.* WORLD'); -is("\u$b" , "Hello\.\* WORLD", '\u'); -is("\l$b" , "hello\.\* WORLD", '\l'); -is("\U$b" , "HELLO\.\* WORLD", '\U'); -is("\L$b" , "hello\.\* world", '\L'); - -is(quotemeta($b) , "hello\\.\\*\\ WORLD", 'quotemeta'); -is(ucfirst($b) , "Hello\.\* WORLD", 'ucfirst'); -is(lcfirst($b) , "hello\.\* WORLD", 'lcfirst'); -is(uc($b) , "HELLO\.\* WORLD", 'uc'); -is(lc($b) , "hello\.\* world", 'lc'); - -# \x{100} is LATIN CAPITAL LETTER A WITH MACRON; its bijective lowercase is -# \x{101}, LATIN SMALL LETTER A WITH MACRON. - -$a = "\x{100}\x{101}Aa"; -$b = "\x{101}\x{100}aA"; - -is("\Q$a\E." , "\x{100}\x{101}Aa.", '\Q\E \x{100}\x{101}Aa'); -is("\u$a" , "\x{100}\x{101}Aa", '\u'); -is("\l$a" , "\x{101}\x{101}Aa", '\l'); -is("\U$a" , "\x{100}\x{100}AA", '\U'); -is("\L$a" , "\x{101}\x{101}aa", '\L'); - -is(quotemeta($a) , "\x{100}\x{101}Aa", 'quotemeta'); -is(ucfirst($a) , "\x{100}\x{101}Aa", 'ucfirst'); -is(lcfirst($a) , "\x{101}\x{101}Aa", 'lcfirst'); -is(uc($a) , "\x{100}\x{100}AA", 'uc'); -is(lc($a) , "\x{101}\x{101}aa", 'lc'); - -is("\Q$b\E." , "\x{101}\x{100}aA.", '\Q\E \x{101}\x{100}aA'); -is("\u$b" , "\x{100}\x{100}aA", '\u'); -is("\l$b" , "\x{101}\x{100}aA", '\l'); -is("\U$b" , "\x{100}\x{100}AA", '\U'); -is("\L$b" , "\x{101}\x{101}aa", '\L'); - -is(quotemeta($b) , "\x{101}\x{100}aA", 'quotemeta'); -is(ucfirst($b) , "\x{100}\x{100}aA", 'ucfirst'); -is(lcfirst($b) , "\x{101}\x{100}aA", 'lcfirst'); -is(uc($b) , "\x{100}\x{100}AA", 'uc'); -is(lc($b) , "\x{101}\x{101}aa", 'lc'); - -# \x{DF} is LATIN SMALL LETTER SHARP S, its uppercase is SS or \x{53}\x{53}; -# \x{149} is LATIN SMALL LETTER N PRECEDED BY APOSTROPHE, its uppercase is -# \x{2BC}\x{E4} or MODIFIER LETTER APOSTROPHE and N. - -is(latin1_to_native("\U\x{DF}aB\x{149}cD"), latin1_to_native("SSAB\x{2BC}NCD"), - "multicharacter uppercase"); - -# The \x{DF} is its own lowercase, ditto for \x{149}. -# There are no single character -> multiple characters lowercase mappings. - -is(latin1_to_native("\L\x{DF}aB\x{149}cD"), latin1_to_native("\x{DF}ab\x{149}cd"), - "multicharacter lowercase"); - -# titlecase is used for \u / ucfirst. - -# \x{587} is ARMENIAN SMALL LIGATURE ECH YIWN and its titlecase is -# \x{535}\x{582} ARMENIAN CAPITAL LETTER ECH + ARMENIAN SMALL LETTER YIWN -# while its lowercase is -# \x{587} itself -# and its uppercase is -# \x{535}\x{552} ARMENIAN CAPITAL LETTER ECH + ARMENIAN CAPITAL LETTER YIWN - -$a = "\x{587}"; - -is("\L\x{587}" , "\x{587}", "ligature lowercase"); -is("\u\x{587}" , "\x{535}\x{582}", "ligature titlecase"); -is("\U\x{587}" , "\x{535}\x{552}", "ligature uppercase"); - -# mktables had problems where many-to-one case mappings didn't work right. -# The lib/uni/fold.t should give the fourth folding, "casefolding", a good -# workout (one cannot directly get that from Perl). -# \x{01C4} is LATIN CAPITAL LETTER DZ WITH CARON -# \x{01C5} is LATIN CAPITAL LETTER D WITH SMALL LETTER Z WITH CARON -# \x{01C6} is LATIN SMALL LETTER DZ WITH CARON -# \x{03A3} is GREEK CAPITAL LETTER SIGMA -# \x{03C2} is GREEK SMALL LETTER FINAL SIGMA -# \x{03C3} is GREEK SMALL LETTER SIGMA - -is(lc("\x{1C4}") , "\x{1C6}", "U+01C4 lc is U+01C6"); -is(lc("\x{1C5}") , "\x{1C6}", "U+01C5 lc is U+01C6, too"); - -is(ucfirst("\x{3C2}") , "\x{3A3}", "U+03C2 ucfirst is U+03A3"); -is(ucfirst("\x{3C3}") , "\x{3A3}", "U+03C3 ucfirst is U+03A3, too"); - -is(uc("\x{1C5}") , "\x{1C4}", "U+01C5 uc is U+01C4"); -is(uc("\x{1C6}") , "\x{1C4}", "U+01C6 uc is U+01C4, too"); - -# #18107: A host of bugs involving [ul]c{,first}. AMS 20021106 -$a = "\x{3c3}foo.bar"; # \x{3c3} == GREEK SMALL LETTER SIGMA. -$b = "\x{3a3}FOO.BAR"; # \x{3a3} == GREEK CAPITAL LETTER SIGMA. - -($c = $b) =~ s/(\w+)/lc($1)/ge; -is($c , $a, "Using s///e to change case."); - -($c = $a) =~ s/(\p{IsWord}+)/uc($1)/ge; -is($c , $b, "Using s///e to change case."); - -($c = $b) =~ s/(\p{IsWord}+)/lcfirst($1)/ge; -is($c , "\x{3c3}FOO.bAR", "Using s///e to change case."); - -($c = $a) =~ s/(\p{IsWord}+)/ucfirst($1)/ge; -is($c , "\x{3a3}foo.Bar", "Using s///e to change case."); - -# #18931: perl5.8.0 bug in \U..\E processing -# Test case from Nicholas Clark. -for my $a (0,1) { - $_ = 'abcdefgh'; - $_ .= chr 256; - chop; - /(.*)/; - is(uc($1), "ABCDEFGH", "[perl #18931]"); -} - -{ - foreach (0, 1) { - $a = v10.v257; - chop $a; - $a =~ s/^(\s*)(\w*)/$1\u$2/; - is($a, v10, "[perl #18857]"); - } -} - - -# [perl #38619] Bug in lc and uc (interaction between UTF-8, substr, and lc/uc) - -for ("a\x{100}", "xyz\x{100}") { - is(substr(uc($_), 0), uc($_), "[perl #38619] uc"); -} -for ("A\x{100}", "XYZ\x{100}") { - is(substr(lc($_), 0), lc($_), "[perl #38619] lc"); -} -for ("a\x{100}", "ßyz\x{100}") { # ß to Ss (different length) - is(substr(ucfirst($_), 0), ucfirst($_), "[perl #38619] ucfirst"); -} - -# Related to [perl #38619] -# the original report concerns PERL_MAGIC_utf8. -# these cases concern PERL_MAGIC_regex_global. - -for (map { $_ } "a\x{100}", "abc\x{100}", "\x{100}") { - chop; # get ("a", "abc", "") in utf8 - my $return = uc($_) =~ /\G(.?)/g; - my $result = $return ? $1 : "not"; - my $expect = (uc($_) =~ /(.?)/g)[0]; - is($return, 1, "[perl #38619]"); - is($result, $expect, "[perl #38619]"); -} - -for (map { $_ } "A\x{100}", "ABC\x{100}", "\x{100}") { - chop; # get ("A", "ABC", "") in utf8 - my $return = lc($_) =~ /\G(.?)/g; - my $result = $return ? $1 : "not"; - my $expect = (lc($_) =~ /(.?)/g)[0]; - is($return, 1, "[perl #38619]"); - is($result, $expect, "[perl #38619]"); -} - -for (1, 4, 9, 16, 25) { - is(uc "\x{03B0}" x $_, "\x{3a5}\x{308}\x{301}" x $_, - 'uc U+03B0 grows threefold'); - - is(lc "\x{0130}" x $_, "i\x{307}" x $_, 'lc U+0130 grows'); -} - -# bug #43207 -my $temp = "Hello"; -for ("$temp") { - lc $_; - is($_, "Hello"); -} - -# new in Unicode 5.1.0 -is(lc("\x{1E9E}"), "\x{df}", "lc(LATIN CAPITAL LETTER SHARP S)"); diff --git a/t/CORE/op/lc_user.t b/t/CORE/op/lc_user.t deleted file mode 100644 index 46198b93c..000000000 --- a/t/CORE/op/lc_user.t +++ /dev/null @@ -1,32 +0,0 @@ -BEGIN { - unshift @INC, 't/CORE/lib'; - require 't/CORE/test.pl'; -} - -plan tests => 5; - -%utf8::ToSpecUpper = ( -"s" => "SS", # Make sure can handle weird ASCII translations -); - -sub ToUpper { - return < $tests); - -use tests 2; # First make sure that %! %- %+ do not load extra modules. -map %{"foo::$_"}, qw< ! - + >; -TODO: { - local $TODO = 'with perlcc'; - ok !exists $INC{'Errno.pm'}, '$swext::! does not load Errno'; -} -ok !exists $INC{'Tie/Hash/NamedCapture.pm'}, - '$foo::+ and $foo::- do not load Tie::Hash::NamedCapture'; - -use tests 1; # ARGV -fresh_perl_is - '$count=0; ++$count while(); print $count', - '0', - { stdin => 'swext\n' }, - ' does not iterate through STDIN'; - -use tests 1; # %SIG -ok !scalar keys %foo::SIG, "%foo::SIG"; - -use tests 4; # rw ${^LETTERS} variables -for(qw< CHILD_ERROR_NATIVE ENCODING UTF8CACHE WARNING_BITS >) { - my $name = s/./"qq|\\c$&|"/ere; - local $$name = 'swit'; - - # Bring it into existence first, as defined() sometimes takes shortcuts - ${"foo::$name"}; - - ok !defined(${"foo::$name"}), "\$foo::^$_"; -} - -use tests 6; # read-only ${^LETTERS} -for(qw< MATCH PREMATCH POSTMATCH TAINT UNICODE UTF8LOCALE >) { - ok eval { ${"foo::" . s/./"qq|\\c$&|"/ere} = 'prile' }, "\$foo::^$_"; -} - -use tests 16; # $ and $ (regexp only, not $0) -for(qw< 1 2 3 4 5 6 7 8 9 324897 237 635 6780 42 14 >) { - ok eval { ${"foo::$_"} = 'prile' }, "\$foo::$_"; -} - -use tests 5; # read-only single-char scalars -for(qw< & ` ' + ] >) { - ok eval { ${"foo::$_"} = 'twor'}, "\$foo::$_"; -} - -use tests 14; # rw single-char scalars we can safely modify -{ - # $. doesn’t appear magical from Perl-space until a filehandle has been - # read, so we’ll do that right now. - open my $fh, "<", \"freen"; - <$fh>; - - for(qw< : ? ! - | ^ ~ = % . \ / ; 0 >) { - local $$_ = 'thew'; - ${"foo::$_"}; # touch it - ok !defined ${"foo::$_"}, "\$foo::$_"; - } -} - -use tests 1; # %! -ok scalar keys %{"foo::!"} == 0, '%foo::!'; - -use tests 4; # [@%][+-] -ok eval { ${"foo::+"}{strat} = 'quin' }, '%foo::+'; -ok eval { ${"foo::-"}{strat} = 'quin' }, '%foo::-'; -ok eval { ${"foo::+"}[47] = 'quin' }, '@foo::+'; -ok eval { ${"foo::-"}[63] = 'quin' }, '@foo::-'; - -use tests 1; # $# - This naughty little thing just warns. -{ - my $w = ''; - local $SIG{__WARN__} = sub { $w = shift }; - eval '${"foo::#"}'; - is $w, '', '$foo::#'; -} - -use tests 11; # rw $^X scalars -for(qw< C O I L H A D W E P T >) { - my $name = eval "qq|\\c$_|"; - local $$name = 'poof'; # we're setting, among other things, $^D, so all - # characters in here must be valid -D flags - ${"foo::$name"}; # touch - ok !defined ${"foo::$name"}, "\$foo::^$_"; -} - -use tests 1; # read-only $^X scalars -for(qw< S V >) { - my $name = eval "qq|\\c$_|"; - ok eval { ${"foo::$name"} = 'twor'}, "\$foo::^$_"; -} - -use tests 1; # $[ -# To avoid tests that are *too* weird, we’ll just check for definition. -${"foo::["}; # touch -ok !defined ${"foo::["}, '$foo::['; - -use tests 4; # user/group vars -# These are rw, but setting them is obviously going to make the test much -# more complex than necessary. So, again, we check for definition. -for(qw< < > ( ) >) { - ${"foo::$_"}; # touch - ok !defined ${"foo::$_"}, "\$foo::$_"; -} - -use tests 1; # $^N -# This is a cheeky little blighter. It’s not read-only, but setting it does -# nothing. It is undefined by default. -{ - my $thing; - "felp" =~ /(.)(?{ $thing = ${"foo::\cN"} })/; - ok !defined $thing, '$foo::^N'; -} - -# I think that’s it! diff --git a/t/CORE/op/length.t b/t/CORE/op/length.t deleted file mode 100644 index 07e523049..000000000 --- a/t/CORE/op/length.t +++ /dev/null @@ -1,236 +0,0 @@ -#!./perl - -INIT { - require 't/CORE/test.pl'; - unshift @INC, 't/CORE/lib'; -} - -plan (38); - -print "not " unless length("") == 0; -print "ok 1\n"; - -print "not " unless length("abc") == 3; -print "ok 2\n"; - -$_ = "foobar"; -print "not " unless length() == 6; -print "ok 3\n"; - -# Okay, so that wasn't very challenging. Let's go Unicode. - -{ - my $a = "\x{41}"; - - print "not " unless length($a) == 1; - print "ok 4\n"; - $test++; - - use bytes; - print "not " unless $a eq "\x41" && length($a) == 1; - print "ok 5\n"; - $test++; -} - -{ - my $a = pack("U", 0xFF); - - print "not " unless length($a) == 1; - print "ok 6\n"; - $test++; - - use bytes; - if (ord('A') == 193) - { - printf "#%vx for 0xFF\n",$a; - print "not " unless $a eq "\x8b\x73" && length($a) == 2; - } - else - { - print "not " unless $a eq "\xc3\xbf" && length($a) == 2; - } - print "ok 7\n"; - $test++; -} - -{ - my $a = "\x{100}"; - - print "not " unless length($a) == 1; - print "ok 8\n"; - $test++; - - use bytes; - if (ord('A') == 193) - { - printf "#%vx for 0x100\n",$a; - print "not " unless $a eq "\x8c\x41" && length($a) == 2; - } - else - { - print "not " unless $a eq "\xc4\x80" && length($a) == 2; - } - print "ok 9\n"; - $test++; -} - -{ - my $a = "\x{100}\x{80}"; - - print "not " unless length($a) == 2; - print "ok 10\n"; - $test++; - - use bytes; - if (ord('A') == 193) - { - printf "#%vx for 0x100 0x80\n",$a; - print "not " unless $a eq "\x8c\x41\x8a\x67" && length($a) == 4; - } - else - { - print "not " unless $a eq "\xc4\x80\xc2\x80" && length($a) == 4; - } - print "ok 11\n"; - $test++; -} - -{ - my $a = "\x{80}\x{100}"; - - print "not " unless length($a) == 2; - print "ok 12\n"; - $test++; - - use bytes; - if (ord('A') == 193) - { - printf "#%vx for 0x80 0x100\n",$a; - print "not " unless $a eq "\x8a\x67\x8c\x41" && length($a) == 4; - } - else - { - print "not " unless $a eq "\xc2\x80\xc4\x80" && length($a) == 4; - } - print "ok 13\n"; - $test++; -} - -# Now for Unicode with magical vtbls - -{ - require Tie::Scalar; - my $a; - tie $a, 'Tie::StdScalar'; # makes $a magical - $a = "\x{263A}"; - - print "not " unless length($a) == 1; - print "ok 14\n"; - $test++; - - use bytes; - print "not " unless length($a) == 3; - print "ok 15\n"; - $test++; -} - -{ - # Play around with Unicode strings, - # give a little workout to the UTF-8 length cache. - my $a = chr(256) x 100; - print length $a == 100 ? "ok 16\n" : "not ok 16\n"; - chop $a; - print length $a == 99 ? "ok 17\n" : "not ok 17\n"; - $a .= $a; - print length $a == 198 ? "ok 18\n" : "not ok 18\n"; - $a = chr(256) x 999; - print length $a == 999 ? "ok 19\n" : "not ok 19\n"; - substr($a, 0, 1) = ''; - print length $a == 998 ? "ok 20\n" : "not ok 20\n"; -} - -curr_test(21); - -require Tie::Scalar; - -$u = "ASCII"; - -tie $u, 'Tie::StdScalar', chr 256; - -is(length $u, 1, "Length of a UTF-8 scalar returned from tie"); -is(length $u, 1, "Again! Again!"); - -$^W = 1; - -my $warnings = 0; - -$SIG{__WARN__} = sub { - $warnings++; - warn @_; -}; - -is(length(undef), undef, "Length of literal undef"); - -my $u; - -is(length($u), undef, "Length of regular scalar"); - -$u = "Gotcha!"; - -tie $u, 'Tie::StdScalar'; - -is(length($u), undef, "Length of tied scalar (MAGIC)"); - -is($u, undef); - -{ - package U; - use overload '""' => sub {return undef;}; -} - -my $uo = bless [], 'U'; - -{ - my $w = ''; - local $SIG{__WARN__} = sub { $w = shift }; - my $expected = $] < 5.018 ? undef : 0; - is(length($uo), $expected, "Length of string overloaded reference"); - if ($] < 5.018) { - is($w, '', 'no warning for stringifying as undef'); - } else { - like($w, qr/uninitialized/, 'uninit warning for stringifying as undef'); - } -} - -my $ul = 3; -is(($ul = length(undef)), undef, - "Returned length of undef with result in TARG"); -is($ul, undef, "Assigned length of undef with result in TARG"); - -$ul = 3; -is(($ul = length($u)), undef, - "Returned length of tied undef with result in TARG"); -is($ul, undef, "Assigned length of tied undef with result in TARG"); - -$ul = 3; -is(($ul = length($uo)), undef, - "Returned length of overloaded undef with result in TARG"); -is($ul, undef, "Assigned length of overloaded undef with result in TARG"); - -# ok(!defined $uo); Turns you can't test this. FIXME for pp_defined? - -{ - my $y = "\x{100}BC"; - is(index($y, "B"), 1, 'adds an intermediate position to the offset cache'); - is(length $y, 3, - 'Check that sv_len_utf8() can take advantage of the offset cache'); -} - -{ - local $SIG{__WARN__} = sub { - pass("'print length undef' warned"); - }; - print length undef; -} - -is($warnings, 0, "There were no other warnings"); diff --git a/t/CORE/op/lex.t b/t/CORE/op/lex.t deleted file mode 100644 index 061c27cc8..000000000 --- a/t/CORE/op/lex.t +++ /dev/null @@ -1,47 +0,0 @@ -#!perl -use strict; -use warnings; - -require 't/CORE/test.pl'; - -plan(tests => 4); - -{ - no warnings 'deprecated'; - print <<; # Yow! -ok 1 - - # previous line intentionally left blank. - - my $yow = "ok 2"; - print <<; # Yow! -$yow - - # previous line intentionally left blank. -} - -curr_test(3); - - -{ - my %foo = (aap => "monkey"); - my $foo = ''; - is("@{[$foo{'aap'}]}", 'monkey', 'interpolation of hash lookup with space between lexical variable and subscript'); - is("@{[$foo {'aap'}]}", 'monkey', 'interpolation of hash lookup with space between lexical variable and subscript - test for [perl #70091]'); - -# Original bug report [perl #70091] -# #!perl -# use warnings; -# my %foo; -# my $foo = ''; -# (my $tmp = $foo) =~ s/^/$foo {$0}/e; -# __END__ -# -# This program causes a segfault with 5.10.0 and 5.10.1. -# -# The space between '$foo' and '{' is essential, which is why piping -# it through perl -MO=Deparse "fixes" it. -# - -} - diff --git a/t/CORE/op/lex_assign.t b/t/CORE/op/lex_assign.t deleted file mode 100644 index 098ce17cf..000000000 --- a/t/CORE/op/lex_assign.t +++ /dev/null @@ -1,353 +0,0 @@ -#!./perl - -INIT { - unshift @INC, 't/CORE/lib'; -} - -$| = 1; -umask 0; -$xref = \ ""; -$runme = $^X; -@a = (1..5); -%h = (1..6); -$aref = \@a; -$href = \%h; -open OP, qq{$runme -le "print 'aaa Ok ok' for 1..100"|}; -$chopit = 'aaaaaa'; -@chopar = (113 .. 119); -$posstr = '123456'; -$cstr = 'aBcD.eF'; -pos $posstr = 3; -$nn = $n = 2; -sub subb {"in s"} - -@INPUT = ; -@simple_input = grep /^\s*\w+\s*\$\w+\s*[#\n]/, @INPUT; -print "1..", (11 + @INPUT + @simple_input), "\n"; -$ord = 0; - -sub wrn {"@_"} - -sub note { print join ' ', '#', @_, "\n" } - -# Check correct optimization of ucfirst etc -$ord++; -my $a = "AB"; -my $b = "\u\L$a"; -print "not " unless $b eq 'Ab'; -print "ok $ord\n"; - -# Check correct destruction of objects: -my $dc = 0; -sub A::DESTROY {$dc += 1} -$a=8; -my $b; -{ my $c = 6; $b = bless \$c, "A"} - -$ord++; -print "not " unless $dc == 0; -print "ok $ord\n"; - -$b = $a+5; - -$ord++; -print "not " unless $dc == 1; -print "ok $ord\n"; - -$ord++; -my $xxx = 'b'; -$xxx = 'c' . ($xxx || 'e'); -print "not " unless $xxx eq 'cb'; -print "ok $ord\n"; - -{ # Check calling STORE - my $sc = 0; - no warnings q/redefine/; - # adjust test for B::C - local *B::TIESCALAR = sub {bless [11], 'B'}; - local *B::FETCH = sub { -(shift->[0]) }; - local *B::STORE = sub { $sc++; my $o = shift; $o->[0] = 17 + shift }; - - - my $m; - tie $m, 'B'; - $m = 100; - - $ord++; - print "not " unless $sc == 1; - print "ok $ord\n"; - - my $t = 11; - $m = $t + 89; - - $ord++; - print "not " unless $sc == 2; - print "ok $ord\n"; - - $ord++; - print "# $m\nnot " unless $m == -117; - print "ok $ord\n"; - - $m += $t; - - $ord++; - print "not " unless $sc == 3; - print "ok $ord\n"; - - $ord++; - print "# $m\nnot " unless $m == 89; - print "ok $ord\n"; -} - - -# Chains of assignments -my ($l1, $l2, $l3, $l4); -my $zzzz = 12; -$zzz1 = $l1 = $l2 = $zzz2 = $l3 = $l4 = 1 + $zzzz; - -$ord++; -print "# $zzz1 = $l1 = $l2 = $zzz2 = $l3 = $l4 = 13\nnot " - unless $zzz1 == 13 and $zzz2 == 13 and $l1 == 13 - and $l2 == 13 and $l3 == 13 and $l4 == 13; -print "ok $ord\n"; - - -for (@INPUT) { - $ord++; - ($op, undef, $comment) = /^([^\#]+)(\#\s+(.*))?/; - $comment = $op unless defined $comment; - chomp; - $op = "$op==$op" unless $op =~ /==/; - ($op, $expectop) = $op =~ /(.*)==(.*)/; - - $skip = ($op =~ /^'\?\?\?'/ or $comment =~ /skip\(.*\Q$^O\E.*\)/i) - ? "skip" : "# '$_'\nnot"; - $integer = ($comment =~ /^i_/) ? "use integer;" : '' ; - (print "#skipping $comment:\nok $ord\n"), next if $skip eq 'skip'; - - my $code = < # glob - # readline -'faked' # rcatline -(@z = (1 .. 3)) # aassign -chop $chopit # chop -(chop (@x=@chopar)) # schop -chomp $chopit # chomp -(chop (@x=@chopar)) # schomp -pos $posstr # pos -pos $chopit # pos returns undef -$nn++==2 # postinc -$nn++==3 # i_postinc -$nn--==4 # postdec -$nn--==3 # i_postdec -$n ** $n # pow -$n * $n # multiply -$n * $n # i_multiply -$n / $n # divide -$n / $n # i_divide -$n % $n # modulo -$n % $n # i_modulo -$n x $n # repeat -$n + $n # add -$n + $n # i_add -$n - $n # subtract -$n - $n # i_subtract -$n . $n # concat -$n . $a=='2fake' # concat with self -"3$a"=='3fake' # concat with self in stringify -"$n" # stringify -$n << $n # left_shift -$n >> $n # right_shift -$n <=> $n # ncmp -$n <=> $n # i_ncmp -$n cmp $n # scmp -$n & $n # bit_and -$n ^ $n # bit_xor -$n | $n # bit_or --$n # negate --$n # i_negate -~$n # complement -atan2 $n,$n # atan2 -sin $n # sin -cos $n # cos -'???' # rand -exp $n # exp -log $n # log -sqrt $n # sqrt -int $n # int -hex $n # hex -oct $n # oct -abs $n # abs -length $posstr # length -substr $posstr, 2, 2 # substr -vec("abc",2,8) # vec -index $posstr, 2 # index -rindex $posstr, 2 # rindex -sprintf "%i%i", $n, $n # sprintf -ord $n # ord -chr $n # chr -crypt $n, $n # crypt -ucfirst ($cstr . "a") # ucfirst padtmp -ucfirst $cstr # ucfirst -lcfirst $cstr # lcfirst -uc $cstr # uc -lc $cstr # lc -quotemeta $cstr # quotemeta -@$aref # rv2av -@$undefed # rv2av undef -(each %h) % 2 == 1 # each -values %h # values -keys %h # keys -%$href # rv2hv -pack "C2", $n,$n # pack -split /a/, "abad" # split -join "a"; @a # join -push @a,3==6 # push -unshift @aaa # unshift -reverse @a # reverse -reverse $cstr # reverse - scal -grep $_, 1,0,2,0,3 # grepwhile -map "x$_", 1,0,2,0,3 # mapwhile -subb() # entersub -caller # caller -warn "ignore this\n" # warn -'faked' # die -open BLAH, "2GB) work with perlio (stdio/sfio). -# sysopen(), sysseek(), syswrite(), sysread() are tested in t/lib/syslfs.t. -# If you modify/add tests here, remember to update also ext/Fcntl/t/syslfs.t. - -BEGIN { - unshift @INC, 't/CORE/lib'; - require 't/CORE/test.pl'; - require Config; - # Don't bother if there are no quad offsets. - skip_all('no 64-bit file offsets') - if $Config::Config{lseeksize} < 8; -} - -use strict; - -our @s; - -my $big0 = tempfile(); -my $big1 = tempfile(); -my $big2 = tempfile(); - -my $explained; - -sub explain { - unless ($explained++) { - print <$big1") or - die "open $big1 failed: $!"; -binmode(BIG) or - die "binmode $big1 failed: $!"; -seek(BIG, 1_000_000, SEEK_SET) or - die "seek $big1 failed: $!"; -print BIG "big" or - die "print $big1 failed: $!"; -close(BIG) or - die "close $big1 failed: $!"; - -my @s1 = stat($big1); - -print "# s1 = @s1\n"; - -open(BIG, ">$big2") or - die "open $big2 failed: $!"; -binmode(BIG) or - die "binmode $big2 failed: $!"; -seek(BIG, 2_000_000, SEEK_SET) or - die "seek $big2 failed: $!"; -print BIG "big" or - die "print $big2 failed: $!"; -close(BIG) or - die "close $big2 failed: $!"; - -my @s2 = stat($big2); - -print "# s2 = @s2\n"; - -unless ($s1[7] == 1_000_003 && $s2[7] == 2_000_003 && - $s1[11] == $s2[11] && $s1[12] == $s2[12] && - $s1[12] > 0) { - skip_all("no sparse files?"); -} - -print "# we seem to have sparse files...\n"; - -# By now we better be sure that we do have sparse files: -# if we are not, the following will hog 5 gigabytes of disk. Ooops. -# This may fail by producing some signal; run in a subprocess first for safety - -$ENV{LC_ALL} = "C"; - -my $r = system '../perl', '-e', <<"EOF"; -open my \$big, '>', q{$big0} or die qq{open $big0: $!}; -seek \$big, 5_000_000_000, 0 or die qq{seek $big0: $!}; -print \$big "big" or die qq{print $big0: $!}; -close \$big or die qq{close $big0: $!}; -exit 0; -EOF - -open(BIG, ">$big0") or die "open failed: $!"; -binmode BIG; -if ($r or not seek(BIG, 5_000_000_000, SEEK_SET)) { - my $err = $r ? 'signal '.($r & 0x7f) : $!; - explain("seeking past 2GB failed: $err"); -} - -# Either the print or (more likely, thanks to buffering) the close will -# fail if there are are filesize limitations (process or fs). -my $print = print BIG "big"; -print "# print failed: $!\n" unless $print; -my $close = close BIG; -print "# close failed: $!\n" unless $close; -unless ($print && $close) { - if ($! =~/too large/i) { - explain("writing past 2GB failed: process limits?"); - } elsif ($! =~ /quota/i) { - explain("filesystem quota limits?"); - } else { - explain("error: $!"); - } -} - -@s = stat($big0); - -print "# @s\n"; - -unless ($s[7] == 5_000_000_003) { - explain("kernel/fs not configured to use large files?"); -} - -sub offset ($$) { - local $::Level = $::Level + 1; - my ($offset_will_be, $offset_want) = @_; - my $offset_is = eval $offset_will_be; - unless ($offset_is == $offset_want) { - print "# bad offset $offset_is, want $offset_want\n"; - my ($offset_func) = ($offset_will_be =~ /^(\w+)/); - if (unpack("L", pack("L", $offset_want)) == $offset_is) { - print "# 32-bit wraparound suspected in $offset_func() since\n"; - print "# $offset_want cast into 32 bits equals $offset_is.\n"; - } elsif ($offset_want - unpack("L", pack("L", $offset_want)) - 1 - == $offset_is) { - print "# 32-bit wraparound suspected in $offset_func() since\n"; - printf "# %s - unpack('L', pack('L', %s)) - 1 equals %s.\n", - $offset_want, - $offset_want, - $offset_is; - } - fail($offset_will_be); - } else { - pass($offset_will_be); - } -} - -plan(tests => 17); - -is($s[7], 5_000_000_003, 'exercises pp_stat'); -is(-s $big0, 5_000_000_003, 'exercises pp_ftsize'); - -is(-e $big0, 1); -is(-f $big0, 1); - -open(BIG, $big0) or die "open failed: $!"; -binmode BIG; - -isnt(seek(BIG, 4_500_000_000, SEEK_SET), undef); - -offset('tell(BIG)', 4_500_000_000); - -isnt(seek(BIG, 1, SEEK_CUR), undef); - -# If you get 205_032_705 from here it means that -# your tell() is returning 32-bit values since (I32)4_500_000_001 -# is exactly 205_032_705. -offset('tell(BIG)', 4_500_000_001); - -isnt(seek(BIG, -1, SEEK_CUR), undef); - -offset('tell(BIG)', 4_500_000_000); - -isnt(seek(BIG, -3, SEEK_END), undef); - -offset('tell(BIG)', 5_000_000_000); - -my $big; - -is(read(BIG, $big, 3), 3); - -is($big, "big"); - -# 705_032_704 = (I32)5_000_000_000 -# See that we don't have "big" in the 705_... spot: -# that would mean that we have a wraparound. -isnt(seek(BIG, 705_032_704, SEEK_SET), undef); - -my $zero; - -is(read(BIG, $zero, 3), 3); - -is($zero, "\0\0\0"); - -explain() unless $::Tests_Are_Passing; - -END { - # unlink may fail if applied directly to a large file - # be paranoid about leaving 5 gig files lying around - open(BIG, ">$big0"); # truncate - close(BIG); -} - -# eof diff --git a/t/CORE/op/list.t b/t/CORE/op/list.t deleted file mode 100644 index 0ff2d193c..000000000 --- a/t/CORE/op/list.t +++ /dev/null @@ -1,176 +0,0 @@ -#!./perl - -INIT { - unshift @INC, "./lib"; - require 't/CORE/test.pl'; -} - -plan( tests => 63 ); - -@foo = (1, 2, 3, 4); -cmp_ok($foo[0], '==', 1, 'first elem'); -cmp_ok($foo[3], '==', 4, 'last elem'); - -$_ = join(':',@foo); -cmp_ok($_, 'eq', '1:2:3:4', 'join list'); - -($a,$b,$c,$d) = (1,2,3,4); -cmp_ok("$a;$b;$c;$d", 'eq', '1;2;3;4', 'list assign'); - -($c,$b,$a) = split(/ /,"111 222 333"); -cmp_ok("$a;$b;$c",'eq','333;222;111','list split on space'); - -($a,$b,$c) = ($c,$b,$a); -cmp_ok("$a;$b;$c",'eq','111;222;333','trio rotate'); - -($a, $b) = ($b, $a); -cmp_ok("$a-$b",'eq','222-111','duo swap'); - -($a, $b) = ($b, $a) = ($a, $b); -cmp_ok("$a-$b",'eq','222-111','duo swap swap'); - -($a, $b[1], $c{2}, $d) = (1, 2, 3, 4); -cmp_ok($a,'==',1,'assign scalar in list'); -cmp_ok($b[1],'==',2,'assign aelem in list'); -cmp_ok($c{2},'==',3,'assign helem in list'); -cmp_ok($d,'==',4,'assign last scalar in list'); - -@foo = (1,2,3,4,5,6,7,8); -($a, $b, $c, $d) = @foo; -cmp_ok("$a/$b/$c/$d",'eq','1/2/3/4','long list assign'); - -@foo = (1,2); -($a, $b, $c, $d) = @foo; -cmp_ok($a,'==',1,'short list 1 defined'); -cmp_ok($b,'==',2,'short list 2 defined'); -ok(!defined($c),'short list 3 undef'); -ok(!defined($d),'short list 4 undef'); - -@foo = @bar = (1); -cmp_ok(join(':',@foo,@bar),'eq','1:1','list reassign'); - -@foo = @bar = (2,3); -cmp_ok(join(':',join('+',@foo),join('-',@bar)),'eq','2+3:2-3','long list reassign'); - -@foo = (); -@foo = 1+2+3; -cmp_ok(join(':',@foo),'eq','6','scalar assign to array'); - -{ - my ($a, $b, $c); - for ($x = 0; $x < 3; $x = $x + 1) { - ($a, $b, $c) = - $x == 0 ? ('a','b','c') - : $x == 1 ? ('d','e','f') - : ('g','h','i') - ; - if ($x == 0) { - cmp_ok($a,'eq','a','ternary for a 1'); - cmp_ok($b,'eq','b','ternary for b 1'); - cmp_ok($c,'eq','c','ternary for c 1'); - } - if ($x == 1) { - cmp_ok($a,'eq','d','ternary for a 2'); - cmp_ok($b,'eq','e','ternary for b 2'); - cmp_ok($c,'eq','f','ternary for c 2'); - } - if ($x == 2) { - cmp_ok($a,'eq','g','ternary for a 3'); - cmp_ok($b,'eq','h','ternary for b 3'); - cmp_ok($c,'eq','i','ternary for c 3'); - } - } -} - -{ - my ($a, $b, $c); - for ($x = 0; $x < 3; $x = $x + 1) { - ($a, $b, $c) = do { - if ($x == 0) { - ('a','b','c'); - } - elsif ($x == 1) { - ('d','e','f'); - } - else { - ('g','h','i'); - } - }; - if ($x == 0) { - cmp_ok($a,'eq','a','block for a 1'); - cmp_ok($b,'eq','b','block for b 1'); - cmp_ok($c,'eq','c','block for c 1'); - } - if ($x == 1) { - cmp_ok($a,'eq','d','block for a 2'); - cmp_ok($b,'eq','e','block for b 2'); - cmp_ok($c,'eq','f','block for c 2'); - } - if ($x == 2) { - cmp_ok($a,'eq','g','block for a 3'); - cmp_ok($b,'eq','h','block for b 3'); - cmp_ok($c,'eq','i','block for c 3'); - } - } -} - -$x = 666; -@a = ($x == 12345 || (1,2,3)); -cmp_ok(join('*',@a),'eq','1*2*3','logical or f'); - -@a = ($x == $x || (4,5,6)); -cmp_ok(join('*',@a),'eq','1','logical or t'); - -cmp_ok(join('',1,2,(3,4,5)),'eq','12345','list ..(...)'); -cmp_ok(join('',(1,2,3,4,5)),'eq','12345','list (.....)'); -cmp_ok(join('',(1,2,3,4),5),'eq','12345','list (....).'); -cmp_ok(join('',1,(2,3,4),5),'eq','12345','list .(...).'); -cmp_ok(join('',1,2,(3,4),5),'eq','12345','list ..(..).'); -cmp_ok(join('',1,2,3,(4),5),'eq','12345','list ...(.).'); -cmp_ok(join('',(1,2),3,(4,5)),'eq','12345','list (..).(..)'); - -{ - my @a = (0, undef, undef, 3); - my @b = @a[1,2]; - my @c = (0, undef, undef, 3)[1, 2]; - cmp_ok(scalar(@b),'==',scalar(@c),'slice and slice'); - cmp_ok(scalar(@c),'==',2,'slice len'); - - @b = (29, scalar @c[()]); - cmp_ok(join(':',@b),'eq','29:','slice ary nil'); - - my %h = (a => 1); - @b = (30, scalar @h{()}); - cmp_ok(join(':',@b),'eq','30:','slice hash nil'); - - my $size = scalar(()[1..1]); - cmp_ok($size,'==','0','size nil'); -} - -{ - # perl #39882 - sub test_zero_args { - my $test_name = shift; - is(scalar(@_), 0, $test_name); - } - test_zero_args("simple list slice", (10,11)[2,3]); - test_zero_args("grepped list slice", grep(1, (10,11)[2,3])); - test_zero_args("sorted list slice", sort((10,11)[2,3])); - test_zero_args("assigned list slice", my @tmp = (10,11)[2,3]); - test_zero_args("do-returned list slice", do { (10,11)[2,3]; }); - test_zero_args("list literal slice", qw(a b)[2,3]); - test_zero_args("empty literal slice", qw()[2,3]); -} - -{ - # perl #20321 - is (join('', @{[('abc'=~/./g)[0,1,2,1,0]]}), "abcba"); -} - -{ - is(join('', qw(a b c)[2,0,1]), "cab"); - my @a = qw(a b c); - is(join(":", @a), "a:b:c"); - my @b = qw(); - is($#b, -1); -} diff --git a/t/CORE/op/local.t b/t/CORE/op/local.t deleted file mode 100644 index 5eae9998e..000000000 --- a/t/CORE/op/local.t +++ /dev/null @@ -1,801 +0,0 @@ -#!./perl - -BEGIN { - unshift @INC, "./lib"; - require 't/CORE/test.pl'; -} -plan tests => 306; - -my $list_assignment_supported = 1; - -#mg.c says list assignment not supported on VMS, EPOC, and SYMBIAN. -$list_assignment_supported = 0 if ($^O eq 'VMS'); - - -sub foo { - local($a, $b) = @_; - local($c, $d); - $c = "c 3"; - $d = "d 4"; - { local($a,$c) = ("a 9", "c 10"); ($x, $y) = ($a, $c); } - is($a, "a 1"); - is($b, "b 2"); - $c, $d; -} - -$a = "a 5"; -$b = "b 6"; -$c = "c 7"; -$d = "d 8"; - -my @res; -@res = &foo("a 1","b 2"); -is($res[0], "c 3"); -is($res[1], "d 4"); - -is($a, "a 5"); -is($b, "b 6"); -is($c, "c 7"); -is($d, "d 8"); -is($x, "a 9"); -is($y, "c 10"); - -# same thing, only with arrays and associative arrays - -sub foo2 { - local($a, @b) = @_; - local(@c, %d); - @c = "c 3"; - $d{''} = "d 4"; - { local($a,@c) = ("a 19", "c 20"); ($x, $y) = ($a, @c); } - is($a, "a 1"); - is("@b", "b 2"); - $c[0], $d{''}; -} - -$a = "a 5"; -@b = "b 6"; -@c = "c 7"; -$d{''} = "d 8"; - -@res = &foo2("a 1","b 2"); -is($res[0], "c 3"); -is($res[1], "d 4"); - -is($a, "a 5"); -is("@b", "b 6"); -is($c[0], "c 7"); -is($d{''}, "d 8"); -is($x, "a 19"); -is($y, "c 20"); - - -eval 'local($$e)'; -like($@, qr/Can't localize through a reference/); - -eval '$e = []; local(@$e)'; -like($@, qr/Can't localize through a reference/); - -eval '$e = {}; local(%$e)'; -like($@, qr/Can't localize through a reference/); - -# Array and hash elements - -@a = ('a', 'b', 'c'); -{ - local($a[1]) = 'foo'; - local($a[2]) = $a[2]; - is($a[1], 'foo'); - is($a[2], 'c'); - undef @a; -} -is($a[1], 'b'); -is($a[2], 'c'); -ok(!defined $a[0]); - -@a = ('a', 'b', 'c'); -{ - local($a[4]) = 'x'; - ok(!defined $a[3]); - is($a[4], 'x'); -} -is(scalar(@a), 3); -ok(!exists $a[3]); -ok(!exists $a[4]); - -@a = ('a', 'b', 'c'); -{ - local($a[5]) = 'z'; - $a[4] = 'y'; - ok(!defined $a[3]); - is($a[4], 'y'); - is($a[5], 'z'); -} -is(scalar(@a), 5); -ok(!defined $a[3]); -is($a[4], 'y'); -ok(!exists $a[5]); - -@a = ('a', 'b', 'c'); -{ - local(@a[4,6]) = ('x', 'z'); - ok(!defined $a[3]); - is($a[4], 'x'); - ok(!defined $a[5]); - is($a[6], 'z'); -} -is(scalar(@a), 3); -ok(!exists $a[3]); -ok(!exists $a[4]); -ok(!exists $a[5]); -ok(!exists $a[6]); - -@a = ('a', 'b', 'c'); -{ - local(@a[4,6]) = ('x', 'z'); - $a[5] = 'y'; - ok(!defined $a[3]); - is($a[4], 'x'); - is($a[5], 'y'); - is($a[6], 'z'); -} -is(scalar(@a), 6); -ok(!defined $a[3]); -ok(!defined $a[4]); -is($a[5], 'y'); -ok(!exists $a[6]); - -@a = ('a', 'b', 'c'); -{ - local($a[1]) = "X"; - shift @a; -} -is($a[0].$a[1], "Xb"); -{ - my $d = "@a"; - local @a = @a; - is("@a", $d); -} - -@a = ('a', 'b', 'c'); -$a[4] = 'd'; -{ - delete local $a[1]; - is(scalar(@a), 5); - is($a[0], 'a'); - ok(!exists($a[1])); - is($a[2], 'c'); - ok(!exists($a[3])); - is($a[4], 'd'); - - ok(!exists($a[888])); - delete local $a[888]; - is(scalar(@a), 5); - ok(!exists($a[888])); - - ok(!exists($a[999])); - my ($d, $zzz) = delete local @a[4, 999]; - is(scalar(@a), 3); - ok(!exists($a[4])); - ok(!exists($a[999])); - is($d, 'd'); - is($zzz, undef); - - my $c = delete local $a[2]; - is(scalar(@a), 1); - ok(!exists($a[2])); - is($c, 'c'); - - $a[888] = 'yyy'; - $a[999] = 'zzz'; -} -is(scalar(@a), 5); -is($a[0], 'a'); -is($a[1], 'b'); -is($a[2], 'c'); -ok(!defined($a[3])); -is($a[4], 'd'); -ok(!exists($a[5])); -ok(!exists($a[888])); -ok(!exists($a[999])); - -%h = (a => 1, b => 2, c => 3, d => 4); -{ - delete local $h{b}; - is(scalar(keys(%h)), 3); - is($h{a}, 1); - ok(!exists($h{b})); - is($h{c}, 3); - is($h{d}, 4); - - ok(!exists($h{yyy})); - delete local $h{yyy}; - is(scalar(keys(%h)), 3); - ok(!exists($h{yyy})); - - ok(!exists($h{zzz})); - my ($d, $zzz) = delete local @h{qw/d zzz/}; - is(scalar(keys(%h)), 2); - ok(!exists($h{d})); - ok(!exists($h{zzz})); - is($d, 4); - is($zzz, undef); - - my $c = delete local $h{c}; - is(scalar(keys(%h)), 1); - ok(!exists($h{c})); - is($c, 3); - - $h{yyy} = 888; - $h{zzz} = 999; -} -is(scalar(keys(%h)), 4); -is($h{a}, 1); -is($h{b}, 2); -is($h{c}, 3); -ok($h{d}, 4); -ok(!exists($h{yyy})); -ok(!exists($h{zzz})); - -%h = ('a' => { 'b' => 1 }, 'c' => 2); -{ - my $a = delete local $h{a}; - is(scalar(keys(%h)), 1); - ok(!exists($h{a})); - is($h{c}, 2); - is(scalar(keys(%$a)), 1); - - my $b = delete local $a->{b}; - is(scalar(keys(%$a)), 0); - is($b, 1); - - $a->{d} = 3; -} -is(scalar(keys(%h)), 2); -{ - my $a = $h{a}; - is(scalar(keys(%$a)), 2); - is($a->{b}, 1); - is($a->{d}, 3); -} -is($h{c}, 2); - -%h = ('a' => 1, 'b' => 2, 'c' => 3); -{ - local($h{'a'}) = 'foo'; - local($h{'b'}) = $h{'b'}; - is($h{'a'}, 'foo'); - is($h{'b'}, 2); - local($h{'c'}); - delete $h{'c'}; -} -is($h{'a'}, 1); -is($h{'b'}, 2); -{ - my $d = join("\n", map { "$_=>$h{$_}" } sort keys %h); - local %h = %h; - is(join("\n", map { "$_=>$h{$_}" } sort keys %h), $d); -} -is($h{'c'}, 3); - -# check for scope leakage -$a = 'outer'; -if (1) { local $a = 'inner' } -is($a, 'outer'); - -# see if localization works when scope unwinds -local $m = 5; -eval { - for $m (6) { - local $m = 7; - die "bye"; - } -}; -is($m, 5); - -# see if localization works on tied arrays -{ - package TA; - sub TIEARRAY { bless [], $_[0] } - sub STORE { print "# STORE [@_]\n"; $_[0]->[$_[1]] = $_[2] } - sub FETCH { my $v = $_[0]->[$_[1]]; print "# FETCH [@_=$v]\n"; $v } - sub EXISTS { print "# EXISTS [@_]\n"; exists $_[0]->[$_[1]]; } - sub DELETE { print "# DELETE [@_]\n"; delete $_[0]->[$_[1]]; } - sub CLEAR { print "# CLEAR [@_]\n"; @{$_[0]} = (); } - sub FETCHSIZE { scalar(@{$_[0]}) } - sub SHIFT { shift (@{$_[0]}) } - sub EXTEND {} -} - -tie @a, 'TA'; -@a = ('a', 'b', 'c'); -{ - local($a[1]) = 'foo'; - local($a[2]) = $a[2]; - is($a[1], 'foo'); - is($a[2], 'c'); - @a = (); -} -is($a[1], 'b'); -is($a[2], 'c'); -ok(!defined $a[0]); -{ - my $d = "@a"; - local @a = @a; - is("@a", $d); -} -# RT #7938: localising an array should make it temporarily untied -{ - @a = qw(a b c); - local @a = (6,7,8); - is("@a", "6 7 8", 'local @a assigned 6,7,8'); - { - my $c = 0; - local *TA::STORE = sub { $c++ }; - $a[0] = 9; - is($c, 0, 'STORE not called after array localised'); - } - is("@a", "9 7 8", 'local @a should now be 9 7 8'); -} -is("@a", "a b c", '@a should now contain original value'); - - -# local() should preserve the existenceness of tied array elements -@a = ('a', 'b', 'c'); -{ - local($a[4]) = 'x'; - ok(!defined $a[3]); - is($a[4], 'x'); -} -is(scalar(@a), 3); -ok(!exists $a[3]); -ok(!exists $a[4]); - -@a = ('a', 'b', 'c'); -{ - local($a[5]) = 'z'; - $a[4] = 'y'; - ok(!defined $a[3]); - is($a[4], 'y'); - is($a[5], 'z'); -} -is(scalar(@a), 5); -ok(!defined $a[3]); -is($a[4], 'y'); -ok(!exists $a[5]); - -@a = ('a', 'b', 'c'); -{ - local(@a[4,6]) = ('x', 'z'); - ok(!defined $a[3]); - is($a[4], 'x'); - ok(!defined $a[5]); - is($a[6], 'z'); -} -is(scalar(@a), 3); -ok(!exists $a[3]); -ok(!exists $a[4]); -ok(!exists $a[5]); -ok(!exists $a[6]); - -@a = ('a', 'b', 'c'); -{ - local(@a[4,6]) = ('x', 'z'); - $a[5] = 'y'; - ok(!defined $a[3]); - is($a[4], 'x'); - is($a[5], 'y'); - is($a[6], 'z'); -} -is(scalar(@a), 6); -ok(!defined $a[3]); -ok(!defined $a[4]); -is($a[5], 'y'); -ok(!exists $a[6]); - -@a = ('a', 'b', 'c'); -$a[4] = 'd'; -{ - delete local $a[1]; - is(scalar(@a), 5); - is($a[0], 'a'); - ok(!exists($a[1])); - is($a[2], 'c'); - ok(!exists($a[3])); - is($a[4], 'd'); - - ok(!exists($a[888])); - delete local $a[888]; - is(scalar(@a), 5); - ok(!exists($a[888])); - - ok(!exists($a[999])); - my ($d, $zzz) = delete local @a[4, 999]; - is(scalar(@a), 3); - ok(!exists($a[4])); - ok(!exists($a[999])); - is($d, 'd'); - is($zzz, undef); - - my $c = delete local $a[2]; - is(scalar(@a), 1); - ok(!exists($a[2])); - is($c, 'c'); - - $a[888] = 'yyy'; - $a[999] = 'zzz'; -} -is(scalar(@a), 5); -is($a[0], 'a'); -is($a[1], 'b'); -is($a[2], 'c'); -ok(!defined($a[3])); -is($a[4], 'd'); -ok(!exists($a[5])); -ok(!exists($a[888])); -ok(!exists($a[999])); - -# see if localization works on tied hashes -{ - package TH; - sub TIEHASH { bless {}, $_[0] } - sub STORE { print "# STORE [@_]\n"; $_[0]->{$_[1]} = $_[2] } - sub FETCH { my $v = $_[0]->{$_[1]}; print "# FETCH [@_=$v]\n"; $v } - sub EXISTS { print "# EXISTS [@_]\n"; exists $_[0]->{$_[1]}; } - sub DELETE { print "# DELETE [@_]\n"; delete $_[0]->{$_[1]}; } - sub CLEAR { print "# CLEAR [@_]\n"; %{$_[0]} = (); } - sub FIRSTKEY { print "# FIRSTKEY [@_]\n"; keys %{$_[0]}; each %{$_[0]} } - sub NEXTKEY { print "# NEXTKEY [@_]\n"; each %{$_[0]} } -} - -tie %h, 'TH'; -%h = ('a' => 1, 'b' => 2, 'c' => 3); - -{ - local($h{'a'}) = 'foo'; - local($h{'b'}) = $h{'b'}; - local($h{'y'}); - local($h{'z'}) = 33; - is($h{'a'}, 'foo'); - is($h{'b'}, 2); - local($h{'c'}); - delete $h{'c'}; -} -is($h{'a'}, 1); -is($h{'b'}, 2); -is($h{'c'}, 3); - -# local() should preserve the existenceness of tied hash elements -ok(! exists $h{'y'}); -ok(! exists $h{'z'}); -TODO: { - todo_skip("Localize entire tied hash"); - my $d = join("\n", map { "$_=>$h{$_}" } sort keys %h); - local %h = %h; - is(join("\n", map { "$_=>$h{$_}" } sort keys %h), $d); -} - -# RT #7939: localising a hash should make it temporarily untied -{ - %h = qw(a 1 b 2 c 3); - local %h = qw(x 6 y 7 z 8); - is(join('', sort keys %h), "xyz", 'local %h has new keys'); - is(join('', sort values %h), "678", 'local %h has new values'); - { - my $c = 0; - local *TH::STORE = sub { $c++ }; - $h{x} = 9; - is($c, 0, 'STORE not called after hash localised'); - } - is($h{x}, 9, '$h{x} should now be 9'); -} -is(join('', sort keys %h), "abc", 'restored %h has original keys'); -is(join('', sort values %h), "123", 'restored %h has original values'); - - -%h = (a => 1, b => 2, c => 3, d => 4); -{ - delete local $h{b}; - is(scalar(keys(%h)), 3); - is($h{a}, 1); - ok(!exists($h{b})); - is($h{c}, 3); - is($h{d}, 4); - - ok(!exists($h{yyy})); - delete local $h{yyy}; - is(scalar(keys(%h)), 3); - ok(!exists($h{yyy})); - - ok(!exists($h{zzz})); - my ($d, $zzz) = delete local @h{qw/d zzz/}; - is(scalar(keys(%h)), 2); - ok(!exists($h{d})); - ok(!exists($h{zzz})); - is($d, 4); - is($zzz, undef); - - my $c = delete local $h{c}; - is(scalar(keys(%h)), 1); - ok(!exists($h{c})); - is($c, 3); - - $h{yyy} = 888; - $h{zzz} = 999; -} -is(scalar(keys(%h)), 4); -is($h{a}, 1); -is($h{b}, 2); -is($h{c}, 3); -ok($h{d}, 4); -ok(!exists($h{yyy})); -ok(!exists($h{zzz})); - -@a = ('a', 'b', 'c'); -{ - local($a[1]) = "X"; - shift @a; -} -is($a[0].$a[1], "Xb"); - -# now try the same for %SIG - -$SIG{TERM} = 'foo'; -$SIG{INT} = \&foo; -$SIG{__WARN__} = $SIG{INT}; -{ - local($SIG{TERM}) = $SIG{TERM}; - local($SIG{INT}) = $SIG{INT}; - local($SIG{__WARN__}) = $SIG{__WARN__}; - is($SIG{TERM}, 'main::foo'); - is($SIG{INT}, \&foo); - is($SIG{__WARN__}, \&foo); - local($SIG{INT}); - delete $SIG{__WARN__}; -} -is($SIG{TERM}, 'main::foo'); -is($SIG{INT}, \&foo); -is($SIG{__WARN__}, \&foo); -{ - my $d = join("\n", map { "$_=>$SIG{$_}" } sort keys %SIG); - local %SIG = %SIG; - is(join("\n", map { "$_=>$SIG{$_}" } sort keys %SIG), $d); -} - -# and for %ENV - -$ENV{_X_} = 'a'; -$ENV{_Y_} = 'b'; -$ENV{_Z_} = 'c'; -{ - local($ENV{_A_}); - local($ENV{_B_}) = 'foo'; - local($ENV{_X_}) = 'foo'; - local($ENV{_Y_}) = $ENV{_Y_}; - is($ENV{_X_}, 'foo'); - is($ENV{_Y_}, 'b'); - local($ENV{_Z_}); - delete $ENV{_Z_}; -} -is($ENV{_X_}, 'a'); -is($ENV{_Y_}, 'b'); -is($ENV{_Z_}, 'c'); -# local() should preserve the existenceness of %ENV elements -ok(! exists $ENV{_A_}); -ok(! exists $ENV{_B_}); - -SKIP: { - skip("Can't make list assignment to \%ENV on this system") - unless $list_assignment_supported; - my $d = join("\n", map { "$_=>$ENV{$_}" } sort keys %ENV); - local %ENV = %ENV; - is(join("\n", map { "$_=>$ENV{$_}" } sort keys %ENV), $d); -} - -# does implicit localization in foreach skip magic? - -$_ = "o 0,o 1,"; -my $iter = 0; -while (/(o.+?),/gc) { - is($1, "o $iter"); - foreach (1..1) { $iter++ } - if ($iter > 2) { fail("endless loop"); last; } -} - -{ - package UnderScore; - sub TIESCALAR { bless \my $self, shift } - sub FETCH { die "read \$_ forbidden" } - sub STORE { die "write \$_ forbidden" } - tie $_, __PACKAGE__; - my @tests = ( - "Nesting" => sub { print '#'; for (1..3) { print } - print "\n" }, 1, - "Reading" => sub { print }, 0, - "Matching" => sub { $x = /badness/ }, 0, - "Concat" => sub { $_ .= "a" }, 0, - "Chop" => sub { chop }, 0, - "Filetest" => sub { -x }, 0, - "Assignment" => sub { $_ = "Bad" }, 0, - # XXX whether next one should fail is debatable - "Local \$_" => sub { local $_ = 'ok?'; print }, 0, - "for local" => sub { for("#ok?\n"){ print } }, 1, - ); - while ( ($name, $code, $ok) = splice(@tests, 0, 3) ) { - eval { &$code }; - main::ok(($ok xor $@), "Underscore '$name'"); - } - untie $_; -} - -{ - # BUG 20001205.22 - my %x; - $x{a} = 1; - { local $x{b} = 1; } - ok(! exists $x{b}); - { local @x{c,d,e}; } - ok(! exists $x{c}); -} - -# local() and readonly magic variables - -eval { local $1 = 1 }; -like($@, qr/Modification of a read-only value attempted/); - -# local($_) always strips all magic -eval { for ($1) { local $_ = 1 } }; -is($@, ""); - -{ - my $STORE = 0; - package TieHash; - sub TIEHASH { bless $_[1], $_[0] } - sub FETCH { 42 } - sub STORE { ++$STORE } - - package main; - tie my %hash, "TieHash", {}; - - eval { for ($hash{key}) {local $_ = 2} }; - is($STORE, 0); -} - -# The s/// adds 'g' magic to $_, but it should remain non-readonly -eval { for("a") { for $x (1,2) { local $_="b"; s/(.*)/+$1/ } } }; -is($@, ""); - -# RT #4342 Special local() behavior for $[ -{ - no warnings 'deprecated'; - local $[ = 1; - ok(1 == $[, 'lexcical scope of local $['); - f(); -} - -sub f { ok(0 == $[); } - -# sub localisation -{ - package Other; - - sub f1 { "f1" } - sub f2 { "f2" } - - no warnings "redefine"; - { - local *f1 = sub { "g1" }; - ::ok(f1() eq "g1", "localised sub via glob"); - } - ::ok(f1() eq "f1", "localised sub restored"); - { - local $Other::{"f1"} = sub { "h1" }; - ::ok(f1() eq "h1", "localised sub via stash"); - } - ::ok(f1() eq "f1", "localised sub restored"); - { - local @Other::{qw/ f1 f2 /} = (sub { "j1" }, sub { "j2" }); - ::ok(f1() eq "j1", "localised sub via stash slice"); - ::ok(f2() eq "j2", "localised sub via stash slice"); - } - ::ok(f1() eq "f1", "localised sub restored"); - ::ok(f2() eq "f2", "localised sub restored"); -} - -# Localising unicode keys (bug #38815) -{ - my %h; - $h{"\243"} = "pound"; - $h{"\302\240"} = "octects"; - is(scalar keys %h, 2); - { - my $unicode = chr 256; - my $ambigous = "\240" . $unicode; - chop $ambigous; - local $h{$unicode} = 256; - local $h{$ambigous} = 160; - - is(scalar keys %h, 4); - is($h{"\243"}, "pound"); - is($h{$unicode}, 256); - is($h{$ambigous}, 160); - is($h{"\302\240"}, "octects"); - } - is(scalar keys %h, 2); - is($h{"\243"}, "pound"); - is($h{"\302\240"}, "octects"); -} - -# And with slices -{ - my %h; - $h{"\243"} = "pound"; - $h{"\302\240"} = "octects"; - is(scalar keys %h, 2); - { - my $unicode = chr 256; - my $ambigous = "\240" . $unicode; - chop $ambigous; - local @h{$unicode, $ambigous} = (256, 160); - - is(scalar keys %h, 4); - is($h{"\243"}, "pound"); - is($h{$unicode}, 256); - is($h{$ambigous}, 160); - is($h{"\302\240"}, "octects"); - } - is(scalar keys %h, 2); - is($h{"\243"}, "pound"); - is($h{"\302\240"}, "octects"); -} - -# [perl #39012] localizing @_ element then shifting frees element too # soon - -{ - my $x; - my $y = bless [], 'X39012'; - sub X39012::DESTROY { $x++ } - sub { local $_[0]; shift }->($y); - ok(!$x, '[perl #39012]'); - -} - -# when localising a hash element, the key should be copied, not referenced - -{ - my %h=('k1' => 111); - my $k='k1'; - { - local $h{$k}=222; - - is($h{'k1'},222); - $k='k2'; - } - ok(! exists($h{'k2'})); - is($h{'k1'},111); -} -{ - my %h=('k1' => 111); - our $k = 'k1'; # try dynamic too - { - local $h{$k}=222; - is($h{'k1'},222); - $k='k2'; - } - ok(! exists($h{'k2'})); - is($h{'k1'},111); -} - -like( runperl(stderr => 1, - prog => 'use constant foo => q(a);' . - 'index(q(a), foo);' . - 'local *g=${::}{foo};print q(ok);'), "ok", "[perl #52740]"); - -# Keep this test last, as it can SEGV -{ - local *@; - pass("Localised *@"); - eval {1}; - pass("Can eval with *@ localised"); -} - diff --git a/t/CORE/op/localref.t b/t/CORE/op/localref.t deleted file mode 100644 index 0bdc2b1ee..000000000 --- a/t/CORE/op/localref.t +++ /dev/null @@ -1,98 +0,0 @@ -#!./perl - -unshift @INC, "./lib"; -require 't/CORE/test.pl'; -plan( tests => 64 ); - -$aa = 1; -{ local $aa; $aa = 2; is($aa,2); } -is($aa,1); -{ local ${aa}; $aa = 3; is($aa,3); } -is($aa,1); -{ local ${"aa"}; $aa = 4; is($aa,4); } -is($aa,1); -$x = "aa"; -{ local ${$x}; $aa = 5; is($aa,5); undef $x; is($aa,5); } -is($aa,1); -$x = "a"; -{ local ${$x x2};$aa = 6; is($aa,6); undef $x; is($aa,6); } -is($aa,1); -$x = "aa"; -{ local $$x; $aa = 7; is($aa,7); undef $x; is($aa,7); } -is($aa,1); - -@aa = qw/a b/; -{ local @aa; @aa = qw/c d/; is("@aa","c d"); } -is("@aa","a b"); -{ local @{aa}; @aa = qw/e f/; is("@aa","e f"); } -is("@aa","a b"); -{ local @{"aa"}; @aa = qw/g h/; is("@aa","g h"); } -is("@aa","a b"); -$x = "aa"; -{ local @{$x}; @aa = qw/i j/; is("@aa","i j"); undef $x; is("@aa","i j"); } -is("@aa","a b"); -$x = "a"; -{ local @{$x x2};@aa = qw/k l/; is("@aa","k l"); undef $x; is("@aa","k l"); } -is("@aa","a b"); -$x = "aa"; -{ local @$x; @aa = qw/m n/; is("@aa","m n"); undef $x; is("@aa","m n"); } -is("@aa","a b"); - -%aa = qw/a b/; -{ local %aa; %aa = qw/c d/; is($aa{c},"d"); } -is($aa{a},"b"); -{ local %{aa}; %aa = qw/e f/; is($aa{e},"f"); } -is($aa{a},"b"); -{ local %{"aa"}; %aa = qw/g h/; is($aa{g},"h"); } -is($aa{a},"b"); -$x = "aa"; -{ local %{$x}; %aa = qw/i j/; is($aa{i},"j"); undef $x; is($aa{i},"j"); } -is($aa{a},"b"); -$x = "a"; -{ local %{$x x2};%aa = qw/k l/; is($aa{k},"l"); undef $x; is($aa{k},"l"); } -is($aa{a},"b"); -$x = "aa"; -{ local %$x; %aa = qw/m n/; is($aa{m},"n"); undef $x; is($aa{m},"n"); } -is($aa{a},"b"); - -sub test_err_localref () { - like($@,qr/Can't localize through a reference/,'error'); -} -$x = \$aa; -my $y = \$aa; -eval { local $$x; }; test_err_localref; -eval { local ${$x}; }; test_err_localref; -eval { local $$y; }; test_err_localref; -eval { local ${$y}; }; test_err_localref; -eval { local ${\$aa}; }; test_err_localref; -eval { local ${\'aa'}; }; test_err_localref; -$x = \@aa; -$y = \@aa; -eval { local @$x; }; test_err_localref; -eval { local @{$x}; }; test_err_localref; -eval { local @$y; }; test_err_localref; -eval { local @{$y}; }; test_err_localref; -eval { local @{\@aa}; }; test_err_localref; -eval { local @{[]}; }; test_err_localref; -$x = \%aa; -$y = \%aa; -eval { local %$x; }; test_err_localref; -eval { local %{$x}; }; test_err_localref; -eval { local %$y; }; test_err_localref; -eval { local %{$y}; }; test_err_localref; -eval { local %{\%aa}; }; test_err_localref; -eval { local %{{a=>1}}; };test_err_localref; - - -{ - # [perl #27638] when restoring a localized variable, the thing being - # freed shouldn't be visible - my $ok; - $x = 0; - sub X::DESTROY { $ok = !ref($x); } - { - local $x = \ bless {}, 'X'; - 1; - } -ok($ok,'old value not visible during restore'); -} diff --git a/t/CORE/op/loopctl.t b/t/CORE/op/loopctl.t deleted file mode 100644 index 1e3c1805d..000000000 --- a/t/CORE/op/loopctl.t +++ /dev/null @@ -1,995 +0,0 @@ -#!./perl - -# We have the following types of loop: -# -# 1a) while(A) {B} -# 1b) B while A; -# -# 2a) until(A) {B} -# 2b) B until A; -# -# 3a) for(@A) {B} -# 3b) B for A; -# -# 4a) for (A;B;C) {D} -# -# 5a) { A } # a bare block is a loop which runs once -# -# Loops of type (b) don't allow for next/last/redo style -# control, so we ignore them here. Type (a) loops can -# all be labelled, so there are ten possibilities (each -# of 5 types, labelled/unlabelled). We therefore need -# thirty tests to try the three control statements against -# the ten types of loop. For the first four types it's useful -# to distinguish the case where next re-iterates from the case -# where it leaves the loop. That makes 38. -# All these tests rely on "last LABEL" -# so if they've *all* failed, maybe you broke that... -# -# These tests are followed by an extra test of nested loops. -# Feel free to add more here. -# -# -- .robin. 2001-03-13 -INIT { - unshift @INC, "./lib"; - require 't/CORE/test.pl'; -} - -plan( tests => 54 ); - -my $ok; - -TEST1: { - - $ok = 0; - - my $x = 1; - my $first_time = 1; - while($x--) { - if (!$first_time) { - $ok = 1; - last TEST1; - } - $ok = 0; - $first_time = 0; - redo; - last TEST1; - } - continue { - $ok = 0; - last TEST1; - } - $ok = 0; -} -cmp_ok($ok,'==',1,'no label on while()'); - -TEST2: { - - $ok = 0; - - my $x = 2; - my $first_time = 1; - my $been_in_continue = 0; - while($x--) { - if (!$first_time) { - $ok = $been_in_continue; - last TEST2; - } - $ok = 0; - $first_time = 0; - next; - last TEST2; - } - continue { - $been_in_continue = 1; - } - $ok = 0; -} -cmp_ok($ok,'==',1,'no label on while() successful next'); - -TEST3: { - - $ok = 0; - - my $x = 1; - my $first_time = 1; - my $been_in_loop = 0; - my $been_in_continue = 0; - while($x--) { - $been_in_loop = 1; - if (!$first_time) { - $ok = 0; - last TEST3; - } - $ok = 0; - $first_time = 0; - next; - last TEST3; - } - continue { - $been_in_continue = 1; - } - $ok = $been_in_loop && $been_in_continue; -} -cmp_ok($ok,'==',1,'no label on while() unsuccessful next'); - -TEST4: { - - $ok = 0; - - my $x = 1; - my $first_time = 1; - while($x++) { - if (!$first_time) { - $ok = 0; - last TEST4; - } - $ok = 0; - $first_time = 0; - last; - last TEST4; - } - continue { - $ok = 0; - last TEST4; - } - $ok = 1; -} -cmp_ok($ok,'==',1,'no label on while() last'); - -TEST5: { - - $ok = 0; - - my $x = 0; - my $first_time = 1; - until($x++) { - if (!$first_time) { - $ok = 1; - last TEST5; - } - $ok = 0; - $first_time = 0; - redo; - last TEST5; - } - continue { - $ok = 0; - last TEST5; - } - $ok = 0; -} -cmp_ok($ok,'==',1,'no label on until()'); - -TEST6: { - - $ok = 0; - - my $x = 0; - my $first_time = 1; - my $been_in_continue = 0; - until($x++ >= 2) { - if (!$first_time) { - $ok = $been_in_continue; - last TEST6; - } - $ok = 0; - $first_time = 0; - next; - last TEST6; - } - continue { - $been_in_continue = 1; - } - $ok = 0; -} -cmp_ok($ok,'==',1,'no label on until() successful next'); - -TEST7: { - - $ok = 0; - - my $x = 0; - my $first_time = 1; - my $been_in_loop = 0; - my $been_in_continue = 0; - until($x++) { - $been_in_loop = 1; - if (!$first_time) { - $ok = 0; - last TEST7; - } - $ok = 0; - $first_time = 0; - next; - last TEST7; - } - continue { - $been_in_continue = 1; - } - $ok = $been_in_loop && $been_in_continue; -} -cmp_ok($ok,'==',1,'no label on until() unsuccessful next'); - -TEST8: { - - $ok = 0; - - my $x = 0; - my $first_time = 1; - until($x++ == 10) { - if (!$first_time) { - $ok = 0; - last TEST8; - } - $ok = 0; - $first_time = 0; - last; - last TEST8; - } - continue { - $ok = 0; - last TEST8; - } - $ok = 1; -} -cmp_ok($ok,'==',1,'no label on until() last'); - -TEST9: { - - $ok = 0; - - my $first_time = 1; - for(1) { - if (!$first_time) { - $ok = 1; - last TEST9; - } - $ok = 0; - $first_time = 0; - redo; - last TEST9; - } - continue { - $ok = 0; - last TEST9; - } - $ok = 0; -} -cmp_ok($ok,'==',1,'no label on for(@array)'); - -TEST10: { - - $ok = 0; - - my $first_time = 1; - my $been_in_continue = 0; - for(1,2) { - if (!$first_time) { - $ok = $been_in_continue; - last TEST10; - } - $ok = 0; - $first_time = 0; - next; - last TEST10; - } - continue { - $been_in_continue = 1; - } - $ok = 0; -} -cmp_ok($ok,'==',1,'no label on for(@array) successful next'); - -TEST11: { - - $ok = 0; - - my $first_time = 1; - my $been_in_loop = 0; - my $been_in_continue = 0; - for(1) { - $been_in_loop = 1; - if (!$first_time) { - $ok = 0; - last TEST11; - } - $ok = 0; - $first_time = 0; - next; - last TEST11; - } - continue { - $been_in_continue = 1; - } - $ok = $been_in_loop && $been_in_continue; -} -cmp_ok($ok,'==',1,'no label on for(@array) unsuccessful next'); - -TEST12: { - - $ok = 0; - - my $first_time = 1; - for(1..10) { - if (!$first_time) { - $ok = 0; - last TEST12; - } - $ok = 0; - $first_time = 0; - last; - last TEST12; - } - continue { - $ok=0; - last TEST12; - } - $ok = 1; -} -cmp_ok($ok,'==',1,'no label on for(@array) last'); - -TEST13: { - - $ok = 0; - - for(my $first_time = 1; 1;) { - if (!$first_time) { - $ok = 1; - last TEST13; - } - $ok = 0; - $first_time=0; - - redo; - last TEST13; - } - $ok = 0; -} -cmp_ok($ok,'==',1,'no label on for(;;)'); - -TEST14: { - - $ok = 0; - - for(my $first_time = 1; 1; $first_time=0) { - if (!$first_time) { - $ok = 1; - last TEST14; - } - $ok = 0; - next; - last TEST14; - } - $ok = 0; -} -cmp_ok($ok,'==',1,'no label on for(;;) successful next'); - -TEST15: { - - $ok = 0; - - my $x=1; - my $been_in_loop = 0; - for(my $first_time = 1; $x--;) { - $been_in_loop = 1; - if (!$first_time) { - $ok = 0; - last TEST15; - } - $ok = 0; - $first_time = 0; - next; - last TEST15; - } - $ok = $been_in_loop; -} -cmp_ok($ok,'==',1,'no label on for(;;) unsuccessful next'); - -TEST16: { - - $ok = 0; - - for(my $first_time = 1; 1; last TEST16) { - if (!$first_time) { - $ok = 0; - last TEST16; - } - $ok = 0; - $first_time = 0; - last; - last TEST16; - } - $ok = 1; -} -cmp_ok($ok,'==',1,'no label on for(;;) last'); - -TEST17: { - - $ok = 0; - my $first_time = 1; - - { - if (!$first_time) { - $ok = 1; - last TEST17; - } - $ok = 0; - $first_time=0; - - redo; - last TEST17; - } - continue { - $ok = 0; - last TEST17; - } - $ok = 0; -} -cmp_ok($ok,'==',1,'no label on bare block'); - -TEST18: { - - $ok = 0; - { - next; - last TEST18; - } - continue { - $ok = 1; - last TEST18; - } - $ok = 0; -} -cmp_ok($ok,'==',1,'no label on bare block next'); - -TEST19: { - - $ok = 0; - { - last; - last TEST19; - } - continue { - $ok = 0; - last TEST19; - } - $ok = 1; -} -cmp_ok($ok,'==',1,'no label on bare block last'); - -### Now do it all again with labels - -TEST20: { - - $ok = 0; - - my $x = 1; - my $first_time = 1; - LABEL20: while($x--) { - if (!$first_time) { - $ok = 1; - last TEST20; - } - $ok = 0; - $first_time = 0; - redo LABEL20; - last TEST20; - } - continue { - $ok = 0; - last TEST20; - } - $ok = 0; -} -cmp_ok($ok,'==',1,'label on while()'); - -TEST21: { - - $ok = 0; - - my $x = 2; - my $first_time = 1; - my $been_in_continue = 0; - LABEL21: while($x--) { - if (!$first_time) { - $ok = $been_in_continue; - last TEST21; - } - $ok = 0; - $first_time = 0; - next LABEL21; - last TEST21; - } - continue { - $been_in_continue = 1; - } - $ok = 0; -} -cmp_ok($ok,'==',1,'label on while() successful next'); - -TEST22: { - - $ok = 0; - - my $x = 1; - my $first_time = 1; - my $been_in_loop = 0; - my $been_in_continue = 0; - LABEL22: while($x--) { - $been_in_loop = 1; - if (!$first_time) { - $ok = 0; - last TEST22; - } - $ok = 0; - $first_time = 0; - next LABEL22; - last TEST22; - } - continue { - $been_in_continue = 1; - } - $ok = $been_in_loop && $been_in_continue; -} -cmp_ok($ok,'==',1,'label on while() unsuccessful next'); - -TEST23: { - - $ok = 0; - - my $x = 1; - my $first_time = 1; - LABEL23: while($x++) { - if (!$first_time) { - $ok = 0; - last TEST23; - } - $ok = 0; - $first_time = 0; - last LABEL23; - last TEST23; - } - continue { - $ok = 0; - last TEST23; - } - $ok = 1; -} -cmp_ok($ok,'==',1,'label on while() last'); - -TEST24: { - - $ok = 0; - - my $x = 0; - my $first_time = 1; - LABEL24: until($x++) { - if (!$first_time) { - $ok = 1; - last TEST24; - } - $ok = 0; - $first_time = 0; - redo LABEL24; - last TEST24; - } - continue { - $ok = 0; - last TEST24; - } - $ok = 0; -} -cmp_ok($ok,'==',1,'label on until()'); - -TEST25: { - - $ok = 0; - - my $x = 0; - my $first_time = 1; - my $been_in_continue = 0; - LABEL25: until($x++ >= 2) { - if (!$first_time) { - $ok = $been_in_continue; - last TEST25; - } - $ok = 0; - $first_time = 0; - next LABEL25; - last TEST25; - } - continue { - $been_in_continue = 1; - } - $ok = 0; -} -cmp_ok($ok,'==',1,'label on until() successful next'); - -TEST26: { - - $ok = 0; - - my $x = 0; - my $first_time = 1; - my $been_in_loop = 0; - my $been_in_continue = 0; - LABEL26: until($x++) { - $been_in_loop = 1; - if (!$first_time) { - $ok = 0; - last TEST26; - } - $ok = 0; - $first_time = 0; - next LABEL26; - last TEST26; - } - continue { - $been_in_continue = 1; - } - $ok = $been_in_loop && $been_in_continue; -} -cmp_ok($ok,'==',1,'label on until() unsuccessful next'); - -TEST27: { - - $ok = 0; - - my $x = 0; - my $first_time = 1; - LABEL27: until($x++ == 10) { - if (!$first_time) { - $ok = 0; - last TEST27; - } - $ok = 0; - $first_time = 0; - last LABEL27; - last TEST27; - } - continue { - $ok = 0; - last TEST8; - } - $ok = 1; -} -cmp_ok($ok,'==',1,'label on until() last'); - -TEST28: { - - $ok = 0; - - my $first_time = 1; - LABEL28: for(1) { - if (!$first_time) { - $ok = 1; - last TEST28; - } - $ok = 0; - $first_time = 0; - redo LABEL28; - last TEST28; - } - continue { - $ok = 0; - last TEST28; - } - $ok = 0; -} -cmp_ok($ok,'==',1,'label on for(@array)'); - -TEST29: { - - $ok = 0; - - my $first_time = 1; - my $been_in_continue = 0; - LABEL29: for(1,2) { - if (!$first_time) { - $ok = $been_in_continue; - last TEST29; - } - $ok = 0; - $first_time = 0; - next LABEL29; - last TEST29; - } - continue { - $been_in_continue = 1; - } - $ok = 0; -} -cmp_ok($ok,'==',1,'label on for(@array) successful next'); - -TEST30: { - - $ok = 0; - - my $first_time = 1; - my $been_in_loop = 0; - my $been_in_continue = 0; - LABEL30: for(1) { - $been_in_loop = 1; - if (!$first_time) { - $ok = 0; - last TEST30; - } - $ok = 0; - $first_time = 0; - next LABEL30; - last TEST30; - } - continue { - $been_in_continue = 1; - } - $ok = $been_in_loop && $been_in_continue; -} -cmp_ok($ok,'==',1,'label on for(@array) unsuccessful next'); - -TEST31: { - - $ok = 0; - - my $first_time = 1; - LABEL31: for(1..10) { - if (!$first_time) { - $ok = 0; - last TEST31; - } - $ok = 0; - $first_time = 0; - last LABEL31; - last TEST31; - } - continue { - $ok=0; - last TEST31; - } - $ok = 1; -} -cmp_ok($ok,'==',1,'label on for(@array) last'); - -TEST32: { - - $ok = 0; - - LABEL32: for(my $first_time = 1; 1;) { - if (!$first_time) { - $ok = 1; - last TEST32; - } - $ok = 0; - $first_time=0; - - redo LABEL32; - last TEST32; - } - $ok = 0; -} -cmp_ok($ok,'==',1,'label on for(;;)'); - -TEST33: { - - $ok = 0; - - LABEL33: for(my $first_time = 1; 1; $first_time=0) { - if (!$first_time) { - $ok = 1; - last TEST33; - } - $ok = 0; - next LABEL33; - last TEST33; - } - $ok = 0; -} -cmp_ok($ok,'==',1,'label on for(;;) successful next'); - -TEST34: { - - $ok = 0; - - my $x=1; - my $been_in_loop = 0; - LABEL34: for(my $first_time = 1; $x--;) { - $been_in_loop = 1; - if (!$first_time) { - $ok = 0; - last TEST34; - } - $ok = 0; - $first_time = 0; - next LABEL34; - last TEST34; - } - $ok = $been_in_loop; -} -cmp_ok($ok,'==',1,'label on for(;;) unsuccessful next'); - -TEST35: { - - $ok = 0; - - LABEL35: for(my $first_time = 1; 1; last TEST16) { - if (!$first_time) { - $ok = 0; - last TEST35; - } - $ok = 0; - $first_time = 0; - last LABEL35; - last TEST35; - } - $ok = 1; -} -cmp_ok($ok,'==',1,'label on for(;;) last'); - -TEST36: { - - $ok = 0; - my $first_time = 1; - - LABEL36: { - if (!$first_time) { - $ok = 1; - last TEST36; - } - $ok = 0; - $first_time=0; - - redo LABEL36; - last TEST36; - } - continue { - $ok = 0; - last TEST36; - } - $ok = 0; -} -cmp_ok($ok,'==',1,'label on bare block'); - -TEST37: { - - $ok = 0; - LABEL37: { - next LABEL37; - last TEST37; - } - continue { - $ok = 1; - last TEST37; - } - $ok = 0; -} -cmp_ok($ok,'==',1,'label on bare block next'); - -TEST38: { - - $ok = 0; - LABEL38: { - last LABEL38; - last TEST38; - } - continue { - $ok = 0; - last TEST38; - } - $ok = 1; -} -cmp_ok($ok,'==',1,'label on bare block last'); - -TEST39: { - $ok = 0; - my ($x, $y, $z) = (1,1,1); - one39: while ($x--) { - $ok = 0; - two39: while ($y--) { - $ok = 0; - three39: while ($z--) { - next two39; - } - continue { - $ok = 0; - last TEST39; - } - } - continue { - $ok = 1; - last TEST39; - } - $ok = 0; - } -} -cmp_ok($ok,'==',1,'nested constructs'); - -sub test_last_label { last TEST40 } - -TEST40: { - $ok = 1; - test_last_label(); - $ok = 0; -} -cmp_ok($ok,'==',1,'dynamically scoped label'); - -sub test_last { last } - -TEST41: { - $ok = 1; - test_last(); - $ok = 0; -} -cmp_ok($ok,'==',1,'dynamically scoped'); - - -# [perl #27206] Memory leak in continue loop -# Ensure that the temporary object is freed each time round the loop, -# rather then all 10 of them all being freed right at the end - -{ - my $n=10; my $late_free = 0; - sub X::DESTROY { $late_free++ if $n < 0 }; - { - ($n-- && bless {}, 'X') && redo; - } - cmp_ok($late_free,'==',0,"bug 27206: redo memory leak"); - - $n = 10; $late_free = 0; - { - ($n-- && bless {}, 'X') && redo; - } - continue { } - cmp_ok($late_free,'==',0,"bug 27206: redo with continue memory leak"); -} - -# ensure that redo doesn't clear a lexical declared in the condition - -{ - my $i = 1; - while (my $x = $i) { - $i++; - redo if $i == 2; - cmp_ok($x,'==',1,"while/redo lexical life"); - last; - } - $i = 1; - until (! (my $x = $i)) { - $i++; - redo if $i == 2; - cmp_ok($x,'==',1,"until/redo lexical life"); - last; - } - for ($i = 1; my $x = $i; ) { - $i++; - redo if $i == 2; - cmp_ok($x,'==',1,"for/redo lexical life"); - last; - } - -} - -{ - $a37725[3] = 1; # use package var - $i = 2; - for my $x (reverse @a37725) { - $x = $i++; - } - cmp_ok("@a37725",'eq',"5 4 3 2",'bug 27725: reverse with empty slots bug'); -} - -# [perl #21469] bad things happened with for $x (...) { *x = *y } - -{ - my $i = 1; - $x_21469 = 'X'; - $y1_21469 = 'Y1'; - $y2_21469 = 'Y2'; - $y3_21469 = 'Y3'; - for $x_21469 (1,2,3) { - is($x_21469, $i, "bug 21469: correct at start of loop $i"); - *x_21469 = (*y1_21469, *y2_21469, *y3_21469)[$i-1]; - is($x_21469, "Y$i", "bug 21469: correct at tail of loop $i"); - $i++; - } - is($x_21469, 'X', "bug 21469: X okay at end of loop"); -} diff --git a/t/CORE/op/lop.t b/t/CORE/op/lop.t deleted file mode 100644 index 5aef47141..000000000 --- a/t/CORE/op/lop.t +++ /dev/null @@ -1,64 +0,0 @@ -#!./perl - -# -# test the logical operators '&&', '||', '!', 'and', 'or', 'not' -# - -BEGIN { - unshift @INC, 't/CORE/lib'; -} - -print "1..11\n"; - -my $test = 0; -for my $i (undef, 0 .. 2, "", "0 but true") { - my $true = 1; - my $false = 0; - for my $j (undef, 0 .. 2, "", "0 but true") { - $true &&= !( - ((!$i || !$j) != !($i && $j)) - or (!($i || $j) != (!$i && !$j)) - or (!!($i || $j) != !(!$i && !$j)) - or (!(!$i || !$j) != !!($i && $j)) - ); - $false ||= ( - ((!$i || !$j) == !!($i && $j)) - and (!!($i || $j) == (!$i && !$j)) - and ((!$i || $j) == ($i && !$j)) - and (($i || !$j) != (!$i && $j)) - ); - } - if (not $true) { - print "not "; - } elsif ($false) { - print "not "; - } - print "ok ", ++$test, "\n"; -} - -# $test == 6 -my $i = 0; -(($i ||= 1) &&= 3) += 4; -print "not " unless $i == 7; -print "ok ", ++$test, "\n"; - -my ($x, $y) = (1, 8); -$i = !$x || $y; -print "not " unless $i == 8; -print "ok ", ++$test, "\n"; - -++$y; -$i = !$x || !$x || !$x || $y; -print "not " unless $i == 9; -print "ok ", ++$test, "\n"; - -$x = 0; -++$y; -$i = !$x && $y; -print "not " unless $i == 10; -print "ok ", ++$test, "\n"; - -++$y; -$i = !$x && !$x && !$x && $y; -print "not " unless $i == 11; -print "ok ", ++$test, "\n"; diff --git a/t/CORE/op/magic-27839.t b/t/CORE/op/magic-27839.t deleted file mode 100644 index f8801cc0d..000000000 --- a/t/CORE/op/magic-27839.t +++ /dev/null @@ -1,40 +0,0 @@ -#!./perl -w - -BEGIN { - require 't/CORE/test.pl'; - unless (is_perlcc_compiled()) { - $SIG{__WARN__} = sub { die "Dying on warning: ", @_ }; - } -} -INIT { - if (is_perlcc_compiled()) { - $SIG{__WARN__} = sub { die "Dying on warning: ", @_ }; - } -} - -plan(tests => 2); - -use strict; - -# Test for bug [perl #27839] -{ - my $x; - sub f { - "abc" =~ /(.)./; - $x = "@+"; - return @+; - }; - "pqrstuvwxyz" =~ /..(....)../; # prime @+ etc in this scope - my @y = f(); - is $x, "@y", "return a magic array ($x) vs (@y)"; - - sub f2 { - "abc" =~ /(?.)./; - my @h = %+; - $x = "@h"; - return %+; - }; - @y = f(); - is $x, "@y", "return a magic hash ($x) vs (@y)"; -} - diff --git a/t/CORE/op/magic.t b/t/CORE/op/magic.t deleted file mode 100644 index 7be48d79b..000000000 --- a/t/CORE/op/magic.t +++ /dev/null @@ -1,569 +0,0 @@ -#!./perl - -BEGIN { - $| = 1; - unshift @INC, 't/CORE/lib'; - $ENV{PATH} = '/bin' if ${^TAINT}; - require 't/CORE/test.pl'; - unless (is_perlcc_compiled()) { - $SIG{__WARN__} = sub { die "Dying on warning: ", @_ }; - } -} -INIT { - if (is_perlcc_compiled()) { - $SIG{__WARN__} = sub { die "Dying on warning: ", @_ }; - } -} - -use warnings; -use Config; - -plan (tests => 87); - -$Is_MSWin32 = $^O eq 'MSWin32'; -$Is_NetWare = $^O eq 'NetWare'; -$Is_VMS = $^O eq 'VMS'; -$Is_Dos = $^O eq 'dos'; -$Is_os2 = $^O eq 'os2'; -$Is_Cygwin = $^O eq 'cygwin'; -$Is_MPE = $^O eq 'mpeix'; -$Is_BeOS = $^O eq 'beos'; - -$PERL = $^X; - -END { - # On VMS, environment variable changes are peristent after perl exits - delete $ENV{'FOO'} if $Is_VMS; -} - -eval '$ENV{"FOO"} = "hi there";'; # check that ENV is inited inside eval -# cmd.exe will echo 'variable=value' but 4nt will echo just the value -# -- Nikola Knezevic -if ($Is_MSWin32) { like `set FOO`, qr/^(?:FOO=)?hi there$/; } -elsif ($Is_VMS) { is `write sys\$output f\$trnlnm("FOO")`, "hi there\n"; } -else { is `echo \$FOO`, "hi there\n"; } - -# perlcc issue 193 - https://code.google.com/p/perl-compiler/issues/detail?id=193 -unlink_all 'ajslkdfpqjsjfk'; -$! = 0; -open(FOO,'ajslkdfpqjsjfk'); -isnt($!, 0, '$! should not be 0'); -close FOO; # just mention it, squelch used-only-once - -SKIP: { - skip('SIGINT not safe on this platform', 5) - if $Is_MSWin32 || $Is_NetWare || $Is_Dos || $Is_MPE; - # the next tests are done in a subprocess because sh spits out a - # newline onto stderr when a child process kills itself with SIGINT. - # We use a pipe rather than system() because the VMS command buffer - # would overflow with a command that long. - - open( CMDPIPE, "| $PERL"); - - print CMDPIPE <<'END'; - - $| = 1; # command buffering - - $SIG{"INT"} = "ok3"; kill "INT",$$; sleep 1; - $SIG{"INT"} = "IGNORE"; kill "INT",$$; sleep 1; print "ok 4\n"; - $SIG{"INT"} = "DEFAULT"; kill "INT",$$; sleep 1; print "not ok 4\n"; - - sub ok3 { - if (($x = pop(@_)) eq "INT") { - print "ok 3\n"; - } - else { - print "not ok 3 ($x @_)\n"; - } - } - -END - - close CMDPIPE; - - open( CMDPIPE, "| $PERL"); - print CMDPIPE <<'END'; - - { package X; - sub DESTROY { - kill "INT",$$; - } - } - sub x { - my $x=bless [], 'X'; - return sub { $x }; - } - $| = 1; # command buffering - $SIG{"INT"} = "ok5"; - { - local $SIG{"INT"}=x(); - print ""; # Needed to expose failure in 5.8.0 (why?) - } - sleep 1; - delete $SIG{"INT"}; - kill "INT",$$; sleep 1; - sub ok5 { - print "ok 5\n"; - } -END - close CMDPIPE; - $? >>= 8 if $^O eq 'VMS'; # POSIX status hiding in 2nd byte - my $todo = ($^O eq 'os2' ? ' # TODO: EMX v0.9d_fix4 bug: wrong nibble? ' : ''); - print $? & 0xFF ? "ok 6$todo\n" : "not ok 6$todo\n"; - - open(CMDPIPE, "| $PERL"); - print CMDPIPE <<'END'; - - sub PVBM () { 'foo' } - index 'foo', PVBM; - my $pvbm = PVBM; - - sub foo { exit 0 } - - $SIG{"INT"} = $pvbm; - kill "INT", $$; sleep 1; -END - close CMDPIPE; - $? >>= 8 if $^O eq 'VMS'; - print $? ? "not ok 7\n" : "ok 7\n"; - - curr_test(curr_test() + 5); -} - -# can we slice ENV? -@val1 = @ENV{keys(%ENV)}; -@val2 = values(%ENV); -is join(':',@val1), join(':',@val2); -cmp_ok @val1, '>', 1; - -# regex vars -'foobarbaz' =~ /b(a)r/; -is $`, 'foo'; -is $&, 'bar'; -is $', 'baz'; -is $+, 'a'; - -# $" -@a = qw(foo bar baz); -is "@a", "foo bar baz"; -{ - local $" = ','; - is "@a", "foo,bar,baz"; -} - -# $; -%h = (); -$h{'foo', 'bar'} = 1; -is((keys %h)[0], "foo\034bar"); -{ - local $; = 'x'; - %h = (); - $h{'foo', 'bar'} = 1; - is((keys %h)[0], 'fooxbar'); -} - -# $?, $@, $$ -system qq[$PERL "-I../lib" -e "use vmsish qw(hushed); exit(0)"]; -is $?, 0; -system qq[$PERL "-I../lib" -e "use vmsish qw(hushed); exit(1)"]; -isnt $?, 0; - -eval { die "foo\n" }; -is $@, "foo\n"; - -cmp_ok($$, '>', 0); -eval { $$++ }; -like ($@, qr/^Modification of a read-only value attempted/); - -# $^X and $0 -{ - if ($^O eq 'qnx') { - chomp($wd = `/usr/bin/fullpath -t`); - } - elsif($Is_Cygwin || $Config{'d_procselfexe'}) { - # Cygwin turns the symlink into the real file - chomp($wd = `pwd`); - $wd =~ s#/t$##; - $wd =~ /(.*)/; $wd = $1; # untaint - if ($Is_Cygwin) { - $wd = Cygwin::win_to_posix_path(Cygwin::posix_to_win_path($wd, 1)); - } - } - elsif($Is_os2) { - $wd = Cwd::sys_cwd(); - } - else { - $wd = '.'; - } - my $perl = $Is_VMS || $Config{d_procselfexe} ? $^X : "$wd/perl"; - my $headmaybe = ''; - my $middlemaybe = ''; - my $tailmaybe = ''; - $script = "$wd/show-shebang"; - if ($Is_MSWin32) { - chomp($wd = `cd`); - $wd =~ s|\\|/|g; - $perl = "$wd/perl.exe"; - $script = "$wd/show-shebang.bat"; - $headmaybe = <$script") or diag "Can't write to $script: $!"; - ok print(SCRIPT $headmaybe . <=', 5.00319; -ok $^O; -cmp_ok $^T, '>', 850000000; - -# Test change 25062 is working -my $orig_osname = $^O; -{ -local $^I = '.bak'; -is $^O, $orig_osname, 'Assigning $^I does not clobber $^O'; -} -$^O = $orig_osname; - -{ - #RT #72422 - foreach my $p (0, 1) { - fresh_perl_is(<<"EOP", '2 4 8', undef, "test \$^P = $p"); -\$DB::single = 2; -\$DB::trace = 4; -\$DB::signal = 8; -\$^P = $p; -print "\$DB::single \$DB::trace \$DB::signal"; -EOP - } -} - -# Check that assigning to $0 on Linux sets the process name with both -# argv[0] assignment and by calling prctl() -{ - SKIP: { - skip "We don't have prctl() here", 2 unless $Config{d_prctl_set_name}; - - # We don't really need these tests. prctl() is tested in the - # Kernel, but test it anyway for our sanity. If something doesn't - # work (like if the system doesn't have a ps(1) for whatever - # reason) just bail out gracefully. - my $maybe_ps = sub { - my ($cmd) = @_; - local ($?, $!); - - no warnings; - my $res = `$cmd`; - skip "Couldn't shell out to `$cmd', returned code $?", 2 if $?; - return $res; - }; - - my $name = "Good Morning, Dave"; - $0 = $name; - - chomp(my $argv0 = $maybe_ps->("ps h $$")); - chomp(my $prctl = $maybe_ps->("ps hc $$")); - - # perlcc issue 194 - https://code.google.com/p/perl-compiler/issues/detail?id=194 - like($argv0, $name, "Set process name through argv[0] ($argv0)"); - like($prctl, substr($name, 0, 15), "Set process name through prctl() ($prctl)"); - } -} - -{ - my $ok = 1; - my $warn = ''; - local $SIG{'__WARN__'} = sub { $ok = 0; $warn = join '', @_; $warn =~ s/\n$//; }; - $! = undef; - local $TODO = $Is_VMS ? "'\$!=undef' does throw a warning" : ''; - ok($ok, $warn); -} - -{ - no warnings 'void'; - -# Make sure Errno hasn't been prematurely autoloaded - { - local $TODO = "perlcc has to load Errno, p5p refused to fix this" if is_perlcc_compiled; - ok !keys %Errno::, '!keys %Errno::'; - } - -# Test auto-loading of Errno when %! is used - - ok scalar eval q{ - %!; - scalar %Errno::; - }, $@; -} - -{ - # Make sure that Errno loading doesn't clobber $! - # similar to perlcc issue 193 - https://code.google.com/p/perl-compiler/issues/detail?id=193 - undef %Errno::; - delete $INC{"Errno.pm"}; - - open(FOO, "nonesuch"); # Generate ENOENT - my %errs = %{"!"}; # Cause Errno.pm to be loaded at run-time - ok ${"!"}{ENOENT}, '${"!"}{ENOENT}'; -} - -# Check that we don't auto-load packages -SKIP: TODO: { - skip "staticly linked; may be preloaded", 4 unless $Config{usedl}; - local $TODO = "perlcc preloads those magic modules when it sees a tied symbol" if is_perlcc_compiled; - foreach (['powie::!', 'Errno'], - ['powie::+', 'Tie::Hash::NamedCapture']) { - my ($symbol, $package) = @$_; - foreach my $scalar_first ('', '$$symbol;') { - my $desc = qq{Referencing %{"$symbol"}}; - $desc .= qq{ after mentioning \${"$symbol"}} if $scalar_first; - $desc .= " doesn't load $package"; - - fresh_perl_is(<<"EOP", 0, {}, $desc); -use strict qw(vars subs); -my \$symbol = '$symbol'; -$scalar_first; -1 if %{\$symbol}; -print scalar %${package}::; -EOP - } - } -} - -is $^S, 0; -eval { is $^S,1 }; -eval " BEGIN { ok ! defined \$^S } "; -is $^S, 0; - -my $taint = ${^TAINT}; -is ${^TAINT}, $taint; -eval { ${^TAINT} = 1 }; -is ${^TAINT}, $taint; - -# 5.6.1 had a bug: @+ and @- were not properly interpolated -# into double-quoted strings -# 20020414 mjd-perl-patch+@plover.com -"I like pie" =~ /(I) (like) (pie)/; -is "@-", "0 0 2 7"; -is "@+", "10 1 6 10"; - -# Tests for the magic get of $\ -{ - my $ok = 0; - # [perl #19330] - { - local $\ = undef; - $\++; $\++; - $ok = $\ eq 2; - } - ok $ok; - $ok = 0; - { - local $\ = "a\0b"; - $ok = "a$\b" eq "aa\0bb"; - } - ok $ok; -} - -# Test for bug [perl #36434] -# Can not do this test on VMS, EPOC, and SYMBIAN according to comments -# in mg.c/Perl_magic_clear_all_env() -SKIP: { - skip('Can\'t make assignment to \%ENV on this system', 3) if $Is_VMS; - - local @ISA; - local %ENV; - # This used to be __PACKAGE__, but that causes recursive - # inheritance, which is detected earlier now and broke - # this test - eval { push @ISA, __FILE__ }; - is $@, '', 'Push a constant on a magic array'; - $@ and print "# $@"; - eval { %ENV = (PATH => __PACKAGE__) }; - is $@, '', 'Assign a constant to a magic hash'; - $@ and print "# $@"; - eval { my %h = qw(A B); %ENV = (PATH => (keys %h)[0]) }; - is $@, '', 'Assign a shared key to a magic hash'; - $@ and print "# $@"; -} - -# Tests for Perl_magic_clearsig -foreach my $sig (qw(__WARN__ INT)) { - $SIG{$sig} = lc $sig; - is $SIG{$sig}, 'main::' . lc $sig, "Can assign to $sig"; - is delete $SIG{$sig}, 'main::' . lc $sig, "Can delete from $sig"; - is $SIG{$sig}, undef, "$sig is now gone"; - is delete $SIG{$sig}, undef, "$sig remains gone"; -} - -# And now one which doesn't exist; -{ - no warnings 'signal'; - $SIG{HUNGRY} = 'mmm, pie'; -} -is $SIG{HUNGRY}, 'mmm, pie', 'Can assign to HUNGRY'; -is delete $SIG{HUNGRY}, 'mmm, pie', 'Can delete from HUNGRY'; -is $SIG{HUNGRY}, undef, "HUNGRY is now gone"; -is delete $SIG{HUNGRY}, undef, "HUNGRY remains gone"; - -# Test deleting signals that we never set -foreach my $sig (qw(__DIE__ _BOGUS_HOOK KILL THIRSTY)) { - TODO:{ - local $TODO = "under the debugger" if $^P; - is $SIG{$sig}, undef, "$sig is not present"; - is delete $SIG{$sig}, undef, "delete of $sig returns undef"; - } -} - -{ - $! = 9999; - is int $!, 9999, q{[perl #72850] Core dump in bleadperl from perl -e '$! = 9999; $a = $!;'}; - -} - -# ^^^^^^^^^ New tests go here ^^^^^^^^^ - -SKIP: { - skip("%ENV manipulations fail or aren't safe on $^O", 4) - if $Is_VMS || $Is_Dos; - - SKIP: { - skip("clearing \%ENV is not safe when running under valgrind") - if $ENV{PERL_VALGRIND}; - - $PATH = $ENV{PATH}; - $PDL = $ENV{PERL_DESTRUCT_LEVEL} || 0; - $ENV{foo} = "bar"; - %ENV = (); - $ENV{PATH} = $PATH; - $ENV{PERL_DESTRUCT_LEVEL} = $PDL || 0; - if ($Is_MSWin32) { - is `set foo 2>NUL`, ""; - } else { - is `echo \$foo`, "\n"; - } - } - - $ENV{__NoNeSuCh} = "foo"; - $0 = "bar"; -# cmd.exe will echo 'variable=value' but 4nt will echo just the value -# -- Nikola Knezevic - if ($Is_MSWin32) { - like `set __NoNeSuCh`, qr/^(?:__NoNeSuCh=)?foo$/; - } else { - is `echo \$__NoNeSuCh`, "foo\n"; - } - SKIP: { - skip("\$0 check only on Linux and FreeBSD", 2) - unless $^O =~ /^(linux|freebsd)$/ - && open CMDLINE, "/proc/$$/cmdline"; - - chomp(my $line = scalar ); - my $me = (split /\0/, $line)[0]; - is $me, $0, 'altering $0 is effective (testing with /proc/)'; - close CMDLINE; - # perlbug #22811 - my $mydollarzero = sub { - my($arg) = shift; - $0 = $arg if defined $arg; - # In FreeBSD the ps -o command= will cause - # an empty header line, grab only the last line. - my $ps = (`ps -o command= -p $$`)[-1]; - return if $?; - chomp $ps; - printf "# 0[%s]ps[%s]\n", $0, $ps; - $ps; - }; - my $ps = $mydollarzero->("x"); - ok(!$ps # we allow that something goes wrong with the ps command - # In Linux 2.4 we would get an exact match ($ps eq 'x') but - # in Linux 2.2 there seems to be something funny going on: - # it seems as if the original length of the argv[] would - # be stored in the proc struct and then used by ps(1), - # no matter what characters we use to pad the argv[]. - # (And if we use \0:s, they are shown as spaces.) Sigh. - || $ps =~ /^x\s*$/ - # FreeBSD cannot get rid of both the leading "perl :" - # and the trailing " (perl)": some FreeBSD versions - # can get rid of the first one. - || ($^O eq 'freebsd' && $ps =~ m/^(?:perl: )?x(?: \(perl\))?$/), - 'altering $0 is effective (testing with `ps`)'); - } -} - -# test case-insignificance of %ENV (these tests must be enabled only -# when perl is compiled with -DENV_IS_CASELESS) -SKIP: { - skip('no caseless %ENV support', 4) unless $Is_MSWin32 || $Is_NetWare; - - %ENV = (); - $ENV{'Foo'} = 'bar'; - $ENV{'fOo'} = 'baz'; - is scalar(keys(%ENV)), 1; - ok exists $ENV{'FOo'}; - is delete $ENV{'foO'}, 'baz'; - is scalar(keys(%ENV)), 0; -} - -__END__ - -# Put new tests before the various ENV tests, as they blow %ENV away. diff --git a/t/CORE/op/magic_phase.t b/t/CORE/op/magic_phase.t deleted file mode 100644 index 67fc0670c..000000000 --- a/t/CORE/op/magic_phase.t +++ /dev/null @@ -1,61 +0,0 @@ -#!./perl - -use strict; -use warnings; - -use vars '%compile_time'; - -# Test ${^GLOBAL_PHASE} -# -# Test::More, test.pl, etc assert plans in END, which happens before global -# destruction, so we don't want to use those here. - -print "1..8\n"; - -sub ok ($$) { - print "not " if !$_[0]; - print "ok"; - print " - $_[1]" if defined $_[1]; - print "\n"; -} - -BEGIN { - $compile_time{BEGIN} = ${^GLOBAL_PHASE}; -} - -UNITCHECK { - $compile_time{UNITCHECK} = ${^GLOBAL_PHASE}; -} - -CHECK { - $compile_time{CHECK} = ${^GLOBAL_PHASE}; -} - -INIT { - $compile_time{INIT} = ${^GLOBAL_PHASE}; -} - -for my $phase ( 'BEGIN', 'UNITCHECK', 'CHECK', 'INIT' ) { - my $should_be = $phase =~ m/^(:?BEGIN|UNITCHECK)/ ? 'START' : $phase; - ok( $compile_time{$phase} eq $should_be, $phase ); - - # print STDERR "# got: '$compile_time{$phase}'\n# expected: '$should_be'\n"; -} - -ok ${^GLOBAL_PHASE} eq 'RUN', 'RUN'; - -sub Moo::DESTROY { - ok ${^GLOBAL_PHASE} eq 'RUN', 'DESTROY is run-time too, usually'; -} - -my $tiger = bless {}, Moo::; - -sub Kooh::DESTROY { - ok ${^GLOBAL_PHASE} eq 'DESTRUCT', 'DESTRUCT'; -} - -our $affe = bless {}, Kooh::; - -END { - ok ${^GLOBAL_PHASE} eq 'END', 'END'; -} diff --git a/t/CORE/op/method.t b/t/CORE/op/method.t deleted file mode 100644 index 0f244153d..000000000 --- a/t/CORE/op/method.t +++ /dev/null @@ -1,327 +0,0 @@ -#!./perl -w - -# -# test method calls and autoloading. -# - -INIT { - unshift @INC, "./lib"; - require 't/CORE/test.pl'; -} - -use strict; -no warnings 'once'; - -plan(tests => 79); - -@A::ISA = 'Z'; -@Z::ISA = 'C'; - -sub C::d {"C::d"} -sub D::d {"D::d"} - -# First, some basic checks of method-calling syntax: -my $obj = bless [], "Pack"; -sub Pack::method { shift; join(",", "method", @_) } -my $mname = "method"; - -is(Pack->method("a","b","c"), "method,a,b,c"); -is(Pack->$mname("a","b","c"), "method,a,b,c"); -is(method Pack ("a","b","c"), "method,a,b,c"); -is((method Pack "a","b","c"), "method,a,b,c"); - -is(Pack->method(), "method"); -is(Pack->$mname(), "method"); -is(method Pack (), "method"); -is(Pack->method, "method"); -is(Pack->$mname, "method"); -is(method Pack, "method"); - -is($obj->method("a","b","c"), "method,a,b,c"); -is($obj->$mname("a","b","c"), "method,a,b,c"); -is((method $obj ("a","b","c")), "method,a,b,c"); -is((method $obj "a","b","c"), "method,a,b,c"); - -is($obj->method(0), "method,0"); -is($obj->method(1), "method,1"); - -is($obj->method(), "method"); -is($obj->$mname(), "method"); -is((method $obj ()), "method"); -is($obj->method, "method"); -is($obj->$mname, "method"); -is(method $obj, "method"); - -is( A->d, "C::d"); # Update hash table; - -*Z::d = \&D::d; # Import now. -is(A->d, "D::d"); # Update hash table; - -{ - local @A::ISA = qw(C); # Update hash table with split() assignment - is(A->d, "C::d"); - $#A::ISA = -1; - is(eval { A->d } || "fail", "fail"); -} -is(A->d, "D::d"); - -{ - local *Z::d; - eval 'sub Z::d {"Z::d1"}'; # Import now. - is(A->d, "Z::d1"); # Update hash table; - undef &Z::d; - is((eval { A->d }, ($@ =~ /Undefined subroutine/)), 1); -} - -is(A->d, "D::d"); # Back to previous state - -eval 'no warnings "redefine"; sub Z::d {"Z::d2"}'; # Import now. -is(A->d, "Z::d2"); # Update hash table; - -# What follows is hardly guarantied to work, since the names in scripts -# are already linked to "pruned" globs. Say, `undef &Z::d' if it were -# after `delete $Z::{d}; sub Z::d {}' would reach an old subroutine. - -# issue #159 https://code.google.com/p/perl-compiler/issues/detail?id=159 -undef &Z::d; -delete $Z::{d}; -is(A->d, "C::d"); # Update hash table; - -eval 'sub Z::d {"Z::d3"}'; # Import now. -is(A->d, "Z::d3"); # Update hash table; - -delete $Z::{d}; -*dummy::dummy = sub {}; # Mark as updated -is(A->d, "C::d"); - -eval 'sub Z::d {"Z::d4"}'; # Import now. -is(A->d, "Z::d4"); # Update hash table; - -delete $Z::{d}; # Should work without any help too -is(A->d, "C::d"); - -{ - local *C::d; - is(eval { A->d } || "nope", "nope"); -} -is(A->d, "C::d"); - -*A::x = *A::d; -A->d; -is(eval { A->x } || "nope", "nope", 'cache should not follow synonyms'); - -my $counter; - -eval <<'EOF'; -sub C::e; -BEGIN { *Z::e = \&C::e } # Shouldn't prevent AUTOLOAD in original pkg -sub Y::f; -$counter = 0; - -@X::ISA = 'Y'; -@Y::ISA = 'Z'; - -sub Z::AUTOLOAD { - my $c = ++$counter; - my $method = $Z::AUTOLOAD; - my $msg = "Z: In $method, $c"; - eval "sub $method { \$msg }"; - goto &$method; -} -sub C::AUTOLOAD { - my $c = ++$counter; - my $method = $C::AUTOLOAD; - my $msg = "C: In $method, $c"; - eval "sub $method { \$msg }"; - goto &$method; -} -EOF - -is(A->e(), "C: In C::e, 1"); # We get a correct autoload -is(A->e(), "C: In C::e, 1"); # Which sticks - -is(A->ee(), "Z: In A::ee, 2"); # We get a generic autoload, method in top -is(A->ee(), "Z: In A::ee, 2"); # Which sticks - -is(Y->f(), "Z: In Y::f, 3"); # We vivify a correct method -is(Y->f(), "Z: In Y::f, 3"); # Which sticks - -# This test is not intended to be reasonable. It is here just to let you -# know that you broke some old construction. Feel free to rewrite the test -# if your patch breaks it. - -{ -no warnings 'redefine'; -*Z::AUTOLOAD = sub { - use warnings; - my $c = ++$counter; - my $method = $::AUTOLOAD; - no strict 'refs'; - *$::AUTOLOAD = sub { "new Z: In $method, $c" }; - goto &$::AUTOLOAD; -}; -} - -is(A->eee(), "new Z: In A::eee, 4"); # We get a correct $autoload -is(A->eee(), "new Z: In A::eee, 4"); # Which sticks - -{ - no strict 'refs'; - # this test added due to bug discovery (in 5.004_04, fb73857aa0bfa8ed) - is(defined(@{"unknown_package::ISA"}) ? "defined" : "undefined", "undefined"); -} - -# test that failed subroutine calls don't affect method calls -{ - package A1; - sub foo { "foo" } - package A2; - @A2::ISA = 'A1'; - package main; - is(A2->foo(), "foo", "A2->foo 1"); - is(do { eval 'A2::foo()'; $@ ? 1 : 0}, 1); - is(A2->foo(), "foo", "A2->foo 2"); -} - -## This test was totally misguided. It passed before only because the -## code to determine if a package was loaded used to look for the hash -## %Foo::Bar instead of the package Foo::Bar:: -- and Config.pm just -## happens to export %Config. -# { -# is(do { use Config; eval 'Config->foo()'; -# $@ =~ /^\QCan't locate object method "foo" via package "Config" at/ ? 1 : $@}, 1); -# is(do { use Config; eval '$d = bless {}, "Config"; $d->foo()'; -# $@ =~ /^\QCan't locate object method "foo" via package "Config" at/ ? 1 : $@}, 1); -# } - -# test error messages if method loading fails -my $e; - -eval '$e = bless {}, "E::A"; E::A->foo()'; -like ($@, qr/^\QCan't locate object method "foo" via package "E::A" at/); -eval '$e = bless {}, "E::B"; $e->foo()'; -like ($@, qr/^\QCan't locate object method "foo" via package "E::B" at/); -# next 3: perlcc issue -eval 'E::C->foo()'; -like ($@, qr/^\QCan't locate object method "foo" via package "E::C" (perhaps /); - -eval 'UNIVERSAL->E::D::foo()'; -like ($@, qr/^\QCan't locate object method "foo" via package "E::D" (perhaps /); -eval 'my $e = bless {}, "UNIVERSAL"; $e->E::E::foo()'; -like ($@, qr/^\QCan't locate object method "foo" via package "E::E" (perhaps /); - -$e = bless {}, "E::F"; # force package to exist -eval 'UNIVERSAL->E::F::foo()'; -like ($@, qr/^\QCan't locate object method "foo" via package "E::F" at/); -eval '$e = bless {}, "UNIVERSAL"; $e->E::F::foo()'; -like ($@, qr/^\QCan't locate object method "foo" via package "E::F" at/); - -# TODO: we need some tests for the SUPER:: pseudoclass - -# failed method call or UNIVERSAL::can() should not autovivify packages -is( $::{"Foo::"} || "none", "none"); # sanity check 1 -is( $::{"Foo::"} || "none", "none"); # sanity check 2 - -is( UNIVERSAL::can("Foo", "boogie") ? "yes":"no", "no" ); -is( $::{"Foo::"} || "none", "none"); # still missing? - -is( Foo->UNIVERSAL::can("boogie") ? "yes":"no", "no" ); -is( $::{"Foo::"} || "none", "none"); # still missing? - -is( Foo->can("boogie") ? "yes":"no", "no" ); -is( $::{"Foo::"} || "none", "none"); # still missing? - -is( eval 'Foo->boogie(); 1' ? "yes":"no", "no" ); -is( $::{"Foo::"} || "none", "none"); # still missing? - -is(do { eval 'Foo->boogie()'; - $@ =~ /^\QCan't locate object method "boogie" via package "Foo" (perhaps / ? 1 : $@}, 1); - -eval 'sub Foo::boogie { "yes, sir!" }'; -is( $::{"Foo::"} ? "ok" : "none", "ok"); # should exist now -is( Foo->boogie(), "yes, sir!"); - -# TODO: universal.t should test NoSuchPackage->isa()/can() - -# This is actually testing parsing of indirect objects and undefined subs -# print foo("bar") where foo does not exist is not an indirect object. -# print foo "bar" where foo does not exist is an indirect object. -eval 'sub AUTOLOAD { "ok ", shift, "\n"; }'; -ok(1, "AUTOLOAD parsing of indirect objects and undefined subs"); - -# Bug ID 20010902.002 -is( - eval q[ - my $x = 'x'; # Lexical or package variable, 5.6.1 panics. - sub Foo::x : lvalue { $x } - Foo->$x = 'ok'; - ] || $@, 'ok' -); - -# An autoloaded, inherited DESTROY may be invoked differently than normal -# methods, and has been known to give rise to spurious warnings -# eg <200203121600.QAA11064@gizmo.fdgroup.co.uk> - -{ - use warnings; - my $w = ''; - local $SIG{__WARN__} = sub { $w = $_[0] }; - - sub AutoDest::Base::AUTOLOAD {} - @AutoDest::ISA = qw(AutoDest::Base); - { my $x = bless {}, 'AutoDest'; } - $w =~ s/\n//g; - is($w, ''); -} - -# [ID 20020305.025] PACKAGE::SUPER doesn't work anymore - -package main; -our @X; -package Amajor; -sub test { - push @main::X, 'Amajor', @_; -} -package Bminor; -use base qw(Amajor); -package main; -sub Bminor::test { - $_[0]->Bminor::SUPER::test('x', 'y'); - push @main::X, 'Bminor', @_; -} -Bminor->test('y', 'z'); -is("@X", "Amajor Bminor x y Bminor Bminor y z"); - -package main; -for my $meth (['Bar', 'Foo::Bar'], - ['SUPER::Bar', 'main::SUPER::Bar'], - ['Xyz::SUPER::Bar', 'Xyz::SUPER::Bar']) -{ -# perlcc wontfix 276 - This cannot work with B::C - https://code.google.com/p/perl-compiler/issues/detail?id=276 - if ( $0 =~ m/\.bin$/ ) { - ok(1, "skip perlcc wontfix 276 UNIVERSAL::AUTOLOAD"); - } else { - fresh_perl_is(<$meth->[0](); -EOT - "Foo $meth->[1]", - { switches => [ '-w' ] }, - "check if UNIVERSAL::AUTOLOAD works with [ ".join(', ', @$meth).' ]', - ); - } -} - -# Test for #71952: crash when looking for a nonexistent destructor -# Regression introduced by fbb3ee5af3d4 -{ - fresh_perl_is(<<'EOT', -sub M::DESTROY; bless {}, "M" ; print "survived\n"; -EOT - "survived", - {}, - "no crash with a declared but missing DESTROY method" - ); -} - diff --git a/t/CORE/op/mkdir.t b/t/CORE/op/mkdir.t deleted file mode 100644 index 3d8f24d18..000000000 --- a/t/CORE/op/mkdir.t +++ /dev/null @@ -1,56 +0,0 @@ -#!./perl -w - -BEGIN { - unshift @INC, 't/CORE/lib'; - require 't/CORE/test.pl'; -} - -plan tests => 22; - -unless (eval { - require File::Path; - File::Path::rmtree('blurfl'); - 1 -}) { - diag("$0 may fail if its temporary directory remains from a previous run"); - diag("Attempted to load File::Path to delete directory t/blurfl - error was\n$@"); - diag("\nIf you have problems, please manually delete t/blurfl"); -} - -# tests 3 and 7 rather naughtily expect English error messages -$ENV{'LC_ALL'} = 'C'; -$ENV{LANGUAGE} = 'C'; # GNU locale extension - -ok(mkdir('blurfl',0777), 'mkdir blurfl'); -ok(!mkdir('blurfl',0777), 'mkdir blurfl a second time'); -ok($!{EEXIST} || $! =~ /cannot move|exist|denied|unknown/i, '$!{EEXIST} or $!'); -ok(-d 'blurfl'); -ok(rmdir('blurfl')); -ok(!rmdir('blurfl')); -ok($!{ENOENT} || $! =~ /cannot find|such|exist|not found|not a directory|unknown/i); -ok(mkdir('blurfl')); -ok(rmdir('blurfl')); - -# trailing slashes will be removed before the system call to mkdir -ok(mkdir('blurfl///'), 'mkdir blurfl///'); -ok(-d 'blurfl', '-d blurfl'); -ok(rmdir('blurfl///'), 'rmdir blurfl///'); -ok(!-d 'blurfl', '!-d blurfl'); - -# test default argument - -$_ = 'blurfl'; -ok(mkdir); -ok(-d); -ok(rmdir); -ok(!-d); -$_ = 'lfrulb'; - -{ - my $_ = 'blurfl'; - ok(mkdir); - ok(-d); - ok(-d 'blurfl'); - ok(!-d 'lfrulb'); - ok(rmdir); -} diff --git a/t/CORE/op/my.t b/t/CORE/op/my.t deleted file mode 100644 index 6a477db2b..000000000 --- a/t/CORE/op/my.t +++ /dev/null @@ -1,132 +0,0 @@ -#!./perl - -print "1..36\n"; - -sub foo { - my($a, $b) = @_; - my $c; - my $d; - $c = "ok 3\n"; - $d = "ok 4\n"; - { my($a, undef, $c) = ("ok 9\n", "not ok 10\n", "ok 10\n"); - ($x, $y) = ($a, $c); } - print $a, $b; - $c . $d; -} - -$a = "ok 5\n"; -$b = "ok 6\n"; -$c = "ok 7\n"; -$d = "ok 8\n"; - -print &foo("ok 1\n","ok 2\n"); - -print $a,$b,$c,$d,$x,$y; - -# same thing, only with arrays and associative arrays - -sub foo2 { - my($a, @b) = @_; - my(@c, %d); - @c = "ok 13\n"; - $d{''} = "ok 14\n"; - { my($a,@c) = ("ok 19\n", "ok 20\n"); ($x, $y) = ($a, @c); } - print $a, @b; - $c[0] . $d{''}; -} - -$a = "ok 15\n"; -@b = "ok 16\n"; -@c = "ok 17\n"; -$d{''} = "ok 18\n"; - -print &foo2("ok 11\n","ok 12\n"); - -print $a,@b,@c,%d,$x,$y; - -my $i = "outer"; - -if (my $i = "inner") { - print "not " if $i ne "inner"; -} -print "ok 21\n"; - -if ((my $i = 1) == 0) { - print "not "; -} -else { - print "not" if $i != 1; -} -print "ok 22\n"; - -my $j = 5; -while (my $i = --$j) { - print("not "), last unless $i > 0; -} -continue { - print("not "), last unless $i > 0; -} -print "ok 23\n"; - -$j = 5; -for (my $i = 0; (my $k = $i) < $j; ++$i) { - print("not "), last unless $i >= 0 && $i < $j && $i == $k; -} -print "ok 24\n"; -print "not " if defined $k; -print "ok 25\n"; - -foreach my $i (26, 27) { - print "ok $i\n"; -} - -print "not " if $i ne "outer"; -print "ok 28\n"; - -# Ensure that C (without parens) doesn't force scalar context. -my @x; -{ @x = my @y } -print +(@x ? "not " : ""), "ok 29\n"; -{ @x = my %y } -print +(@x ? "not " : ""), "ok 30\n"; - -# Found in HTML::FormatPS -my %fonts = qw(nok 31); -for my $full (keys %fonts) { - $full =~ s/^n//; - # Supposed to be copy-on-write via force_normal after a THINKFIRST check. - print "$full $fonts{nok}\n"; -} - -# [perl #29340] optimising away the = () left the padav returning the -# array rather than the contents, leading to 'Bizarre copy of array' error - -sub opta { my @a=() } -sub opth { my %h=() } -eval { my $x = opta }; -print "not " if $@; -print "ok 32\n"; -eval { my $x = opth }; -print "not " if $@; -print "ok 33\n"; - - -sub foo3 { - ++my $x->{foo}; - print "not " if defined $x->{bar}; - ++$x->{bar}; -} -eval { foo3(); foo3(); }; -print "not " if $@; -print "ok 34\n"; - -# my $foo = undef should always assign [perl #37776] -{ - my $count = 35; - loop: - my $test = undef; - print "not " if defined $test; - print "ok $count\n"; - $test = 42; - goto loop if ++$count < 37; -} diff --git a/t/CORE/op/my_stash.t b/t/CORE/op/my_stash.t deleted file mode 100644 index e486421af..000000000 --- a/t/CORE/op/my_stash.t +++ /dev/null @@ -1,31 +0,0 @@ -#!./perl - -package Foo; - -BEGIN { - unshift @INC, 't/CORE/lib'; - require 't/CORE/test.pl'; -} - -plan 7; - -use constant MyClass => 'Foo::Bar::Biz::Baz'; - -{ - package Foo::Bar::Biz::Baz; - 1; -} - -for (qw(Foo Foo:: MyClass __PACKAGE__)) { - eval "sub { my $_ \$obj = shift; }"; - ok ! $@; -# print $@ if $@; -} - -use constant NoClass => 'Nope::Foo::Bar::Biz::Baz'; - -for (qw(Nope Nope:: NoClass)) { - eval "sub { my $_ \$obj = shift; }"; - ok $@; -# print $@ if $@; -} diff --git a/t/CORE/op/mydef.t b/t/CORE/op/mydef.t deleted file mode 100644 index 74b2398af..000000000 --- a/t/CORE/op/mydef.t +++ /dev/null @@ -1,217 +0,0 @@ -#!./perl -w - -BEGIN { - unshift @INC, 't/CORE/lib'; - require 't/CORE/test.pl'; -} - -use strict; -no warnings 'misc'; - -$_ = 'global'; -is($_, 'global', '$_ initial value'); -s/oba/abo/; -is($_, 'glabol', 's/// on global $_'); - -{ - my $_ = 'local'; - is($_, 'local', 'my $_ initial value'); - s/oca/aco/; - is($_, 'lacol', 's/// on my $_'); - /(..)/; - is($1, 'la', '// on my $_'); - cmp_ok(tr/c/d/, '==', 1, 'tr/// on my $_ counts correctly' ); - is($_, 'ladol', 'tr/// on my $_'); - { - my $_ = 'nested'; - is($_, 'nested', 'my $_ nested'); - chop; - is($_, 'neste', 'chop on my $_'); - } - { - our $_; - is($_, 'glabol', 'gains access to our global $_'); - } - is($_, 'ladol', 'my $_ restored'); -} -is($_, 'glabol', 'global $_ restored'); -s/abo/oba/; -is($_, 'global', 's/// on global $_ again'); -{ - my $_ = 11; - our $_ = 22; - is($_, 22, 'our $_ is seen explicitly'); - chop; - is($_, 2, '...default chop chops our $_'); - /(.)/; - is($1, 2, '...default match sees our $_'); -} - -$_ = "global"; -{ - my $_ = 'local'; - for my $_ ("foo") { - is($_, "foo", 'for my $_'); - /(.)/; - is($1, "f", '...m// in for my $_'); - is(our $_, 'global', '...our $_ inside for my $_'); - } - is($_, 'local', '...my $_ restored outside for my $_'); - is(our $_, 'global', '...our $_ restored outside for my $_'); -} -{ - my $_ = 'local'; - for ("implicit foo") { # implicit "my $_" - is($_, "implicit foo", 'for implicit my $_'); - /(.)/; - is($1, "i", '...m// in for implicit my $_'); - is(our $_, 'global', '...our $_ inside for implicit my $_'); - } - is($_, 'local', '...my $_ restored outside for implicit my $_'); - is(our $_, 'global', '...our $_ restored outside for implicit my $_'); -} -{ - my $_ = 'local'; - is($_, "postfix foo", 'postfix for' ) for 'postfix foo'; - is($_, 'local', '...my $_ restored outside postfix for'); - is(our $_, 'global', '...our $_ restored outside postfix for'); -} -{ - for our $_ ("bar") { - is($_, "bar", 'for our $_'); - /(.)/; - is($1, "b", '...m// in for our $_'); - } - is($_, 'global', '...our $_ restored outside for our $_'); -} - -{ - my $buf = ''; - sub tmap1 { /(.)/; $buf .= $1 } # uses our $_ - my $_ = 'x'; - sub tmap2 { /(.)/; $buf .= $1 } # uses my $_ - map { - tmap1(); - tmap2(); - ok( /^[67]\z/, 'local lexical $_ is seen in map' ); - { is(our $_, 'global', 'our $_ still visible'); } - ok( $_ == 6 || $_ == 7, 'local lexical $_ is still seen in map' ); - { my $_ ; is($_, undef, 'nested my $_ is undefined'); } - } 6, 7; - is($buf, 'gxgx', q/...map doesn't modify outer lexical $_/); - is($_, 'x', '...my $_ restored outside map'); - is(our $_, 'global', '...our $_ restored outside map'); - map { my $_; is($_, undef, 'redeclaring $_ in map block undefs it'); } 1; -} -{ map { my $_; is($_, undef, 'declaring $_ in map block undefs it'); } 1; } -{ - sub tmap3 () { return $_ }; - my $_ = 'local'; - sub tmap4 () { return $_ }; - my $x = join '-', map $_.tmap3.tmap4, 1 .. 2; - is($x, '1globallocal-2globallocal', 'map without {}'); -} -{ - for my $_ (1) { - my $x = map $_, qw(a b); - is($x, 2, 'map in scalar context'); - } -} -{ - my $buf = ''; - sub tgrep1 { /(.)/; $buf .= $1 } - my $_ = 'y'; - sub tgrep2 { /(.)/; $buf .= $1 } - grep { - tgrep1(); - tgrep2(); - ok( /^[89]\z/, 'local lexical $_ is seen in grep' ); - { is(our $_, 'global', 'our $_ still visible'); } - ok( $_ == 8 || $_ == 9, 'local lexical $_ is still seen in grep' ); - } 8, 9; - is($buf, 'gygy', q/...grep doesn't modify outer lexical $_/); - is($_, 'y', '...my $_ restored outside grep'); - is(our $_, 'global', '...our $_ restored outside grep'); -} -{ - sub tgrep3 () { return $_ }; - my $_ = 'local'; - sub tgrep4 () { return $_ }; - my $x = join '-', grep $_=$_.tgrep3.tgrep4, 1 .. 2; - is($x, '1globallocal-2globallocal', 'grep without {} with side-effect'); - is($_, 'local', '...but without extraneous side-effects'); -} -{ - for my $_ (1) { - my $x = grep $_, qw(a b); - is($x, 2, 'grep in scalar context'); - } -} -{ - my $s = "toto"; - my $_ = "titi"; - my $r; - { - local $::TODO = 'Marked as todo since test was added in 59f00321bbc2d046' unless $0 =~ m{.bin$}; # fixed in perlcc - $r = $s =~ /to(?{ is($_, 'toto', 'my $_ in code-match' ) })to/; - } - ok($r, "\$s=$s should match!"); - is(our $_, 'global', '...our $_ restored outside code-match'); -} - -{ - my $_ = "abc"; - my $x = reverse; - is($x, "cba", 'reverse without arguments picks up $_'); -} - -{ - package notmain; - our $_ = 'notmain'; - ::is($::_, 'notmain', 'our $_ forced into main::'); - /(.*)/; - ::is($1, 'notmain', '...m// defaults to our $_ in main::'); -} - -my $file = tempfile(); -{ - open my $_, '>', $file or die "Can't open $file: $!"; - print $_ "hello\n"; - close $_; - cmp_ok(-s $file, '>', 5, 'writing to filehandle $_ works'); -} -{ - open my $_, $file or die "Can't open $file: $!"; - my $x = <$_>; - is($x, "hello\n", 'reading from <$_> works'); - close $_; -} - -{ - $fqdb::_ = 'fqdb'; - is($fqdb::_, 'fqdb', 'fully qualified $_ is not in main' ); - is(eval q/$fqdb::_/, 'fqdb', 'fully qualified, evaled $_ is not in main' ); - package fqdb; - ::isnt($_, 'fqdb', 'unqualified $_ is in main' ); - ::isnt(eval q/$_/, 'fqdb', 'unqualified, evaled $_ is in main'); -} - -{ - $clank_est::qunckkk = 3; - our $qunckkk; - $qunckkk = 4; - package clank_est; - our $qunckkk; - ::is($qunckkk, 3, 'regular variables are not forced to main'); -} - -{ - $whack::_ = 3; - our $_; - $_ = 4; - package whack; - our $_; - ::is($_, 4, '$_ is "special", and always forced to main'); -} - -done_testing(); diff --git a/t/CORE/op/negate.t b/t/CORE/op/negate.t deleted file mode 100644 index fa9a50fd7..000000000 --- a/t/CORE/op/negate.t +++ /dev/null @@ -1,30 +0,0 @@ -#!./perl -w - -BEGIN { - unshift @INC, 't/CORE/lib'; - require 't/CORE/test.pl'; -} - -plan tests => 16; - -# Some of these will cause warnings if left on. Here we're checking the -# functionality, not the warnings. -no warnings "numeric"; - -# test cases based on [perl #36675] -'-10' eq '+10' -is(- 10, -10, "Simple numeric negation to negative"); -is(- -10, 10, "Simple numeric negation to positive"); -is(-"10", -10, "Negation of a positive string to negative"); -is(-"10.0", -10, "Negation of a positive decimal sting to negative"); -is(-"10foo", -10, "Negation of a numeric-lead string returns negation of numeric"); -is(-"-10", 10, 'Negation of string starting with "-" returns a positive number - integer'); -is(-"-10.0", 10.0, 'Negation of string starting with "-" returns a positive number - decimal'); -is(-"-10foo", "+10foo", 'Negation of string starting with "-" returns a string starting with "+" - non-numeric'); -is(-"xyz", "-xyz", 'Negation of a negative string adds "-" to the front'); -is(-"-xyz", "+xyz", "Negation of a negative string to positive"); -is(-"+xyz", "-xyz", "Negation of a positive string to negative"); -is(-bareword, "-bareword", "Negation of bareword treated like a string"); -is(- -bareword, "+bareword", "Negation of -bareword returns string +bareword"); -is(-" -10", 10, "Negation of a whitespace-lead numeric string"); -is(-" -10.0", 10, "Negation of a whitespace-lead decimal string"); -is(-" -10foo", 10, "Negation of a whitespace-lead sting starting with a numeric") diff --git a/t/CORE/op/not.t b/t/CORE/op/not.t deleted file mode 100644 index 4aab9bf27..000000000 --- a/t/CORE/op/not.t +++ /dev/null @@ -1,48 +0,0 @@ -#!./perl -w - -BEGIN { - unshift @INC, 't/CORE/lib'; - require 't/CORE/test.pl'; -} - -plan tests => 16; - -# not() tests -pass() if not(); -is(not(), 1); -is(not(), not(0)); - -# test not(..) and ! -is(! 1, not 1); -is(! 0, not 0); -is(! (0, 0), not(0, 0)); - -# test the return of ! -{ - my $not0 = ! 0; - my $not1 = ! 1; - - no warnings; - ok($not1 == undef); - ok($not1 == ()); - - use warnings; - ok($not1 eq ''); - ok($not1 == 0); - ok($not0 == 1); -} - -# test the return of not -{ - my $not0 = not 0; - my $not1 = not 1; - - no warnings; - ok($not1 == undef); - ok($not1 == ()); - - use warnings; - ok($not1 eq ''); - ok($not1 == 0); - ok($not0 == 1); -} diff --git a/t/CORE/op/numconvert.t b/t/CORE/op/numconvert.t deleted file mode 100644 index 979867f16..000000000 --- a/t/CORE/op/numconvert.t +++ /dev/null @@ -1,262 +0,0 @@ -#!./perl - -# -# test the conversion operators -# -# Notations: -# -# "N p i N vs N N": Apply op-N, then op-p, then op-i, then reporter-N -# Compare with application of op-N, then reporter-N -# Right below are descriptions of different ops and reporters. - -# We do not use these subroutines any more, sub overhead makes a "switch" -# solution better: - -# obviously, 0, 1 and 2, 3 are destructive. (XXXX 64-bit? 4 destructive too) - -# *0 = sub {--$_[0]}; # - -# *1 = sub {++$_[0]}; # + - -# # Converters -# *2 = sub { $_[0] = $max_uv & $_[0]}; # U -# *3 = sub { use integer; $_[0] += $zero}; # I -# *4 = sub { $_[0] += $zero}; # N -# *5 = sub { $_[0] = "$_[0]" }; # P - -# # Side effects -# *6 = sub { $max_uv & $_[0]}; # u -# *7 = sub { use integer; $_[0] + $zero}; # i -# *8 = sub { $_[0] + $zero}; # n -# *9 = sub { $_[0] . "" }; # p - -# # Reporters -# sub a2 { sprintf "%u", $_[0] } # U -# sub a3 { sprintf "%d", $_[0] } # I -# sub a4 { sprintf "%g", $_[0] } # N -# sub a5 { "$_[0]" } # P - -BEGIN { - unshift @INC, 't/CORE/lib'; - require 't/CORE/test.pl'; -} - -use strict; - -my $max_chain = $ENV{PERL_TEST_NUMCONVERTS} || 2; - -# Bulk out if unsigned type is hopelessly wrong: -my $max_uv1 = ~0; -my $max_uv2 = sprintf "%u", $max_uv1 ** 6; # 6 is an arbitrary number here -my $big_iv = do {use integer; $max_uv1 * 16}; # 16 is an arbitrary number here -my $max_uv_less3 = $max_uv1 - 3; - -print "# max_uv1 = $max_uv1, max_uv2 = $max_uv2, big_iv = $big_iv\n"; -print "# max_uv_less3 = $max_uv_less3\n"; -if ($max_uv1 ne $max_uv2 or $big_iv > $max_uv1 or $max_uv1 == $max_uv_less3) { - eval { require Config; }; - my $message = 'unsigned perl arithmetic is not sane'; - $message .= " (common in 64-bit platforms)" if $Config::Config{d_quad}; - skip_all($message); -} -if ($max_uv_less3 =~ tr/0-9//c) { - skip_all('this perl stringifies large unsigned integers using E notation'); -} - -my $st_t = 4*4; # We try 4 initializers and 4 reporters - -my $num = 0; -$num += 10**$_ - 4**$_ for 1.. $max_chain; -$num *= $st_t; -$num += $::additional_tests; -plan(tests => $num); # In fact 15 times more subsubtests... - -my $max_uv = ~0; -my $max_iv = int($max_uv/2); -my $zero = 0; - -my $l_uv = length $max_uv; -my $l_iv = length $max_iv; - -# Hope: the first digits are good -my $larger_than_uv = substr 97 x 100, 0, $l_uv; -my $smaller_than_iv = substr 12 x 100, 0, $l_iv; -my $yet_smaller_than_iv = substr 97 x 100, 0, ($l_iv - 1); - -my @list = (1, $yet_smaller_than_iv, $smaller_than_iv, $max_iv, $max_iv + 1, - $max_uv, $max_uv + 1); -unshift @list, (reverse map -$_, @list), 0; # 15 elts -@list = map "$_", @list; # Normalize - -note("@list"); - -# need to special case ++ for max_uv, as ++ "magic" on a string gives -# another string, whereas ++ magic on a string used as a number gives -# a number. Not a problem when NV preserves UV, but if it doesn't then -# stringification of the latter gives something in e notation. - -my $max_uv_pp = "$max_uv"; $max_uv_pp++; -my $max_uv_p1 = "$max_uv"; $max_uv_p1+=0; $max_uv_p1++; - -# Also need to cope with %g notation for max_uv_p1 that actually gives an -# integer less than max_uv because of correct rounding for the limited -# precision. This bites for 12 byte long doubles and 8 byte UVs - -my $temp = $max_uv_p1; -my $max_uv_p1_as_iv; -{use integer; $max_uv_p1_as_iv = 0 + sprintf "%s", $temp} -my $max_uv_p1_as_uv = 0 | sprintf "%s", $temp; - -my @opnames = split //, "-+UINPuinp"; - -# @list = map { 2->($_), 3->($_), 4->($_), 5->($_), } @list; # Prepare input - -my $test = 1; -my $nok; -for my $num_chain (1..$max_chain) { - my @ops = map [split //], grep /[4-9]/, - map { sprintf "%0${num_chain}d", $_ } 0 .. 10**$num_chain - 1; - - #@ops = ([]) unless $num_chain; - #@ops = ([6, 4]); - - for my $op (@ops) { - for my $first (2..5) { - for my $last (2..5) { - $nok = 0; - my @otherops = grep $_ <= 3, @$op; - my @curops = ($op,\@otherops); - - for my $num (@list) { - my $inpt; - my @ans; - - for my $short (0, 1) { - # undef $inpt; # Forget all we had - some bugs were masked - - $inpt = $num; # Try to not contaminate $num... - $inpt = "$inpt"; - if ($first == 2) { - $inpt = $max_uv & $inpt; # U 2 - } elsif ($first == 3) { - use integer; $inpt += $zero; # I 3 - } elsif ($first == 4) { - $inpt += $zero; # N 4 - } else { - $inpt = "$inpt"; # P 5 - } - - # Saves 20% of time - not with this logic: - #my $tmp = $inpt; - #my $tmp1 = $num; - #next if $num_chain > 1 - # and "$tmp" ne "$tmp1"; # Already the coercion gives problems... - - for my $curop (@{$curops[$short]}) { - if ($curop < 5) { - if ($curop < 3) { - if ($curop == 0) { - --$inpt; # - 0 - } elsif ($curop == 1) { - ++$inpt; # + 1 - } else { - $inpt = $max_uv & $inpt; # U 2 - } - } elsif ($curop == 3) { - use integer; $inpt += $zero; - } else { - $inpt += $zero; # N 4 - } - } elsif ($curop < 8) { - if ($curop == 5) { - $inpt = "$inpt"; # P 5 - } elsif ($curop == 6) { - my $dummy = $max_uv & $inpt; # u 6 - } else { - use integer; my $dummy = $inpt + $zero; - } - } elsif ($curop == 8) { - my $dummy = $inpt + $zero; # n 8 - } else { - my $dummy = $inpt . ""; # p 9 - } - } - - if ($last == 2) { - $inpt = sprintf "%u", $inpt; # U 2 - } elsif ($last == 3) { - $inpt = sprintf "%d", $inpt; # I 3 - } elsif ($last == 4) { - $inpt = sprintf "%g", $inpt; # N 4 - } else { - $inpt = "$inpt"; # P 5 - } - push @ans, $inpt; - } - if ($ans[0] ne $ans[1]) { - my $diag = "'$ans[0]' ne '$ans[1]',\t$num\t=> @opnames[$first,@{$curops[0]},$last] vs @opnames[$first,@{$curops[1]},$last]"; - my $excuse; - # XXX ought to check that "+" was in the list of opnames - if ((($ans[0] eq $max_uv_pp) and ($ans[1] eq $max_uv_p1)) - or (($ans[1] eq $max_uv_pp) and ($ans[0] eq $max_uv_p1))) { - # string ++ versus numeric ++. Tolerate this little - # bit of insanity - $excuse = "ok, as string ++ of max_uv is \"$max_uv_pp\", numeric is $max_uv_p1"; - } elsif ($opnames[$last] eq 'I' and $ans[1] eq "-1" - and $ans[0] eq $max_uv_p1_as_iv) { - # Max UV plus 1 is NV. This NV may stringify in E notation. - # And the number of decimal digits shown in E notation will depend - # on the binary digits in the mantissa. And it may be that - # (say) 18446744073709551616 in E notation is truncated to - # (say) 1.8446744073709551e+19 (say) which gets converted back - # as 1.8446744073709551000e+19 - # ie 18446744073709551000 - # which isn't the integer we first had. - # But each step of conversion is correct. So it's not an error. - # (Only shows up for 64 bit UVs and NVs with 64 bit mantissas, - # and on Crays (64 bit integers, 48 bit mantissas) IIRC) - $excuse = "ok, \"$max_uv_p1\" correctly converts to IV \"$max_uv_p1_as_iv\""; - } elsif ($opnames[$last] eq 'U' and $ans[1] eq ~0 - and $ans[0] eq $max_uv_p1_as_uv) { - # as aboce - $excuse = "ok, \"$max_uv_p1\" correctly converts to UV \"$max_uv_p1_as_uv\""; - } elsif (grep {defined $_ && /^N$/} @opnames[@{$curops[0]}] - and $ans[0] == $ans[1] and $ans[0] <= ~0 - # First must be in E notation (ie not just digits) and - # second must still be an integer. - # eg 1.84467440737095516e+19 - # 1.84467440737095516e+19 for 64 bit mantissa is in the - # integer range, so 1.84467440737095516e+19 + 0 is treated - # as integer addition. [should it be?] - # and 18446744073709551600 + 0 is 18446744073709551600 - # Which isn't the string you first thought of. - # I can't remember why there isn't symmetry in this - # exception, ie why only the first ops are tested for 'N' - and $ans[0] != /^-?\d+$/ and $ans[1] !~ /^-?\d+$/) { - $excuse = "ok, numerically equal - notation changed due to adding zero"; - } else { - $nok++, - diag($diag); - } - if ($excuse) { - note($diag); - note($excuse); - } - } - } - ok($nok == 0); - } - } - } -} - -# Tests that use test.pl start here. -BEGIN { $::additional_tests = 4 } - -ok(-0.0 eq "0", 'negative zero stringifies as 0'); -ok(!-0.0, "neg zero is boolean false"); -my $nz = -0.0; -{ my $dummy = "$nz"; } -ok(!$nz, 'previously stringified -0.0 is boolean false'); -$nz = -0.0; -is sprintf("%+.f", - -$nz), sprintf("%+.f", - -$nz), - "negation does not coerce negative zeroes"; diff --git a/t/CORE/op/oct.t b/t/CORE/op/oct.t deleted file mode 100644 index 905ec43f4..000000000 --- a/t/CORE/op/oct.t +++ /dev/null @@ -1,137 +0,0 @@ -#!./perl - -# tests 51 onwards aren't all warnings clean. (intentionally) - -require 't/CORE/test.pl'; -use strict; - -plan(tests => 77); - -foreach(['0b1_0101', 0b101_01], - ['0b10_101', 0_2_5], - ['0b101_01', 2_1], - ['0b1010_1', 0x1_5], - ['b1_0101', 0b10101], - ['b10_101', 025], - ['b101_01', 21], - ['b1010_1', 0x15], - ['01_234', 0b10_1001_1100], - ['012_34', 01234], - ['0123_4', 668], - ['01234', 0x29c], - ['0x1_234', 0b10010_00110100], - ['0x12_34', 01_1064], - ['0x123_4', 4660], - ['0x1234', 0x12_34], - ['x1_234', 0b100100011010_0], - ['x12_34', 0_11064], - ['x123_4', 4660], - ['x1234', 0x_1234], - ['0b1111_1111_1111_1111_1111_1111_1111_1111', 4294967295], - ['037_777_777_777', 4294967295], - ['0xffff_ffff', 4294967295], - ['0b'.( '0'x10).'1_0101', 0b101_01], - ['0b'.( '0'x100).'1_0101', 0b101_01], - ['0b'.('0'x1000).'1_0101', 0b101_01], - # Things that perl 5.6.1 and 5.7.2 did wrong (plus some they got right) - ["b00b0101", 0], - ["bb0101", 0], - ["0bb0101", 0], - ["0x0x3A", 0], - ["0xx3A", 0], - ["x0x3A", 0], - ["xx3A", 0], - ["0x3A", 0x3A], - ["x3A", 0x3A], - ["0x0x4", 0], - ["0xx4", 0], - ["x0x4", 0], - ["xx4", 0], - ["0x4", 4], - ["x4", 4], - # Allow uppercase base markers (#76296) - ["0XCAFE", 0xCAFE], - ["XCAFE", 0xCAFE], - ["0B101001", 0b101001], - ["B101001", 0b101001], - ) { - my ($string, $value) = @$_; - my $result = oct $string; - - my $desc = ($^O ne 'VMS' || length $string <= 256) && "oct \"$string\""; - - unless (cmp_ok($value, '==', $result, $desc)) { - my $format = ($string =~ /([bx])/i) ? "0\L$1%\U$1": '0%o'; - diag(sprintf "oct '%s' gives '%s' ($format), not %s ($format)", - $string, $result, $result, $value, $value); - } -} - -foreach(['01_234', 0b_1001000110100], - ['012_34', 011064], - ['0123_4', 4660], - ['01234_', 0x1234], - ['0x_1234', 0b1001000110100], - ['0x1_234', 011064], - ['0x12_34', 4660], - ['0x1234_', 0x1234], - ['x_1234', 0b1001000110100], - ['x12_34', 011064], - ['x123_4', 4660], - ['x1234_', 0x1234], - ['0xff_ff_ff_ff', 4294967295], - [( '0'x10).'01234', 0x1234], - [( '0'x100).'01234', 0x1234], - [('0'x1000).'01234', 0x1234], - # Things that perl 5.6.1 and 5.7.2 did wrong (plus some they got right) - ["0x3A", 0x3A], - ["x3A", 0x3A], - ["0x4",4], - ["x4", 4], - # Allow uppercase base markers (#76296) - ["0XCAFE", 0xCAFE], - ["XCAFE", 0xCAFE], - ) { - my ($string, $value) = @$_; - my $result = hex $string; - - my $desc = ($^O ne 'VMS' || length $string <= 256) && "hex \"$string\""; - - unless (cmp_ok($value, '==', $result, $desc)) { - diag(sprintf "hex '%s' gives '%s' (0x%X), not %s (0x%X)", - $string, $result, $result, $value, $value); - } -} - - -$_ = "\0_7_7"; -is(length, 5); -is($_, "\0"."_"."7"."_"."7"); -chop, chop, chop, chop; -is($_, "\0"); -if (ord("\t") != 9) { - # question mark is 111 in 1047, 037, && POSIX-BC - is("\157_", "?_"); -} -else { - is("\077_", "?_"); -} - -$_ = "\x_7_7"; -is(length, 5); -is($_, "\0"."_"."7"."_"."7"); -chop, chop, chop, chop; -is($_, "\0"); -if (ord("\t") != 9) { - # / is 97 in 1047, 037, && POSIX-BC - is("\x61_", "/_"); -} -else { - is("\x2F_", "/_"); -} - -eval '$a = oct "10\x{100}"'; -like($@, qr/Wide character/); - -eval '$a = hex "ab\x{100}"'; -like($@, qr/Wide character/); diff --git a/t/CORE/op/or.t b/t/CORE/op/or.t deleted file mode 100644 index 6f7438ccf..000000000 --- a/t/CORE/op/or.t +++ /dev/null @@ -1,67 +0,0 @@ -#!./perl - -# Test || in weird situations. - -INIT { - unshift @INC, 't/CORE/lib'; - require 't/CORE/test.pl'; -} - - -package Countdown; - -sub TIESCALAR { - my $class = shift; - my $instance = shift || undef; - return bless \$instance => $class; -} - -sub FETCH { - print "# FETCH! ${$_[0]}\n"; - return ${$_[0]}--; -} - - -package main; - -plan( tests => 8 ); - - -my ($a, $b, $c); - -$! = 1; -$a = $!; -my $a_str = sprintf "%s", $a; -my $a_num = sprintf "%d", $a; - -$c = $a || $b; - -is($c, $a_str); -is($c+0, $a_num); # force numeric context. - -$a =~ /./g or die "Match failed for some reason"; # Make $a magic - -$c = $a || $b; - -is($c, $a_str); -is($c+0, $a_num); # force numeric context. - -my $val = 3; - -$c = $val || $b; -is($c, 3); - -tie $a, 'Countdown', $val; - -$c = $a; -is($c, 3, 'Single FETCH on tied scalar'); - -$c = $a; -is($c, 2, ' $tied = $var'); - -$c = $a || $b; - -{ - local $TODO = 'Double FETCH'; - is($c, 1, ' $tied || $var'); -} diff --git a/t/CORE/op/ord.t b/t/CORE/op/ord.t deleted file mode 100644 index 9891bcab7..000000000 --- a/t/CORE/op/ord.t +++ /dev/null @@ -1,68 +0,0 @@ -#!./perl - -INIT { - unshift @INC, "./lib"; - require 't/CORE/test.pl'; -} - -plan(tests => 35); - -# compile time evaluation - -# 'A' 65 ASCII -# 'A' 193 EBCDIC - -ok(ord('A') == 65 || ord('A') == 193, "ord('A') is ".ord('A')); - -is(ord(chr(500)), 500, "compile time chr 500"); - -# run time evaluation - -$x = 'ABC'; - -ok(ord($x) == 65 || ord($x) == 193, "ord('$x') is ".ord($x)); - -ok(chr 65 eq 'A' || chr 193 eq 'A', "chr can produce 'A'"); - -$x = 500; -is(ord(chr($x)), $x, "runtime chr $x"); - -is(ord("\x{1234}"), 0x1234, 'compile time ord \x{....}'); - -# perlcc issue #162 https://code.google.com/p/perl-compiler/issues/detail?id=162 -$x = "\x{1234}"; -is(ord($x), 0x1234, 'runtime ord \x{....}'); - -{ - no warnings 'utf8'; # avoid Unicode warnings - -# The following code points are some interesting steps. - is(ord(chr( 0x100)), 0x100, '0x0100'); - is(ord(chr( 0x3FF)), 0x3FF, 'last two-byte char in UTF-EBCDIC'); - is(ord(chr( 0x400)), 0x400, 'first three-byte char in UTF-EBCDIC'); - is(ord(chr( 0x7FF)), 0x7FF, 'last two-byte char in UTF-8'); - is(ord(chr( 0x800)), 0x800, 'first three-byte char in UTF-8'); - is(ord(chr( 0xFFF)), 0xFFF, '0x0FFF'); - is(ord(chr( 0x1000)), 0x1000, '0x1000'); - is(ord(chr( 0x3FFF)), 0x3FFF, 'last three-byte char in UTF-EBCDIC'); - is(ord(chr( 0x4000)), 0x4000, 'first four-byte char in UTF-EBCDIC'); - is(ord(chr( 0xCFFF)), 0xCFFF, '0xCFFF'); - is(ord(chr( 0xD000)), 0xD000, '0xD000'); - is(ord(chr( 0xD7FF)), 0xD7FF, '0xD7FF'); - is(ord(chr( 0xD800)), 0xD800, 'surrogate begin (not strict utf-8)'); - is(ord(chr( 0xDFFF)), 0xDFFF, 'surrogate end (not strict utf-8)'); - is(ord(chr( 0xE000)), 0xE000, '0xE000'); - is(ord(chr( 0xFDD0)), 0xFDD0, 'first additional noncharacter in BMP'); - is(ord(chr( 0xFDEF)), 0xFDEF, 'last additional noncharacter in BMP'); - is(ord(chr( 0xFFFE)), 0xFFFE, '0xFFFE'); - is(ord(chr( 0xFFFF)), 0xFFFF, 'last three-byte char in UTF-8'); - is(ord(chr( 0x10000)), 0x10000, 'first four-byte char in UTF-8'); - is(ord(chr( 0x3FFFF)), 0x3FFFF, 'last four-byte char in UTF-EBCDIC'); - is(ord(chr( 0x40000)), 0x40000, 'first five-byte char in UTF-EBCDIC'); - is(ord(chr( 0xFFFFF)), 0xFFFFF, '0xFFFFF'); - is(ord(chr(0x100000)), 0x100000, '0x100000'); - is(ord(chr(0x10FFFF)), 0x10FFFF, 'Unicode last code point'); - is(ord(chr(0x110000)), 0x110000, '0x110000'); - is(ord(chr(0x1FFFFF)), 0x1FFFFF, 'last four-byte char in UTF-8'); - is(ord(chr(0x200000)), 0x200000, 'first five-byte char in UTF-8'); -} diff --git a/t/CORE/op/overload_integer.t b/t/CORE/op/overload_integer.t deleted file mode 100644 index 073ac2a55..000000000 --- a/t/CORE/op/overload_integer.t +++ /dev/null @@ -1,55 +0,0 @@ -#!./perl - -use strict; -use warnings; - -print "1..2\n"; - -package Foo; - -use overload; - -sub import -{ - overload::constant 'integer' => sub { return shift; }; -} - -package main; - -BEGIN { $INC{'Foo.pm'} = "/lib/Foo.pm" } - -use Foo; - -my $result = eval "5+6"; - -my $error = $@; - -my $label = "No exception was thrown with an overload::constant 'integer' inside an eval."; -# TEST -if ($error eq "") -{ - print "ok 1 - $label\n" -} -else -{ - print "not ok 1 - $label\n"; - print "# Error is $error\n"; -} - -$label = "Correct solution"; - -if (!defined($result)) -{ - $result = ""; -} -# TEST -if ($result eq 11) -{ - print "ok 2 - $label\n"; -} -else -{ - print "not ok 2 - $label\n"; - print "# Result is $result\n"; -} - diff --git a/t/CORE/op/override.t b/t/CORE/op/override.t deleted file mode 100644 index 2c74da2a4..000000000 --- a/t/CORE/op/override.t +++ /dev/null @@ -1,135 +0,0 @@ -#!./perl - -BEGIN { - unshift @INC, 't/CORE/lib'; - require 't/CORE/test.pl'; - # help B - use Tie::Hash::NamedCapture; -} - -plan tests => 26; - -# -# This file tries to test builtin override using CORE::GLOBAL -# -my $dirsep = "/"; - -INIT { package Foo; *main::getlogin = sub { "kilroy"; } } - -eval q/is( getlogin, "kilroy" )/; - -my $t = 42; -INIT { *CORE::GLOBAL::time = sub () { $t; } } - -eval q/is( 45, time + 3 )/; - -# -# require has special behaviour -# -my $r; -INIT { *CORE::GLOBAL::require = sub { $r = shift; 1; } } - -eval q/require Foo/; -is( $r, "Foo.pm", 'Foo.pm' ); - - -eval q/require Foo::Bar/; -is( $r, join($dirsep, "Foo", "Bar.pm") ); - -eval q/require 'Foo'/; -is( $r, "Foo", 'Foo' ); - -eval q/require 5.006/; -is( $r, "5.006", q/5.006/ ); - -eval q/require v5.6/; -ok( abs($r - 5.006) < 0.001 && $r eq "\x05\x06" ); - -eval "use Foo"; -is( $r, "Foo.pm" ); - -eval "use Foo::Bar"; -is( $r, join($dirsep, "Foo", "Bar.pm") ); - -eval "use 5.006"; -is( $r, "5.006", q/5.006/ ); - -# localizing *CORE::GLOBAL::foo should revert to finding CORE::foo -{ - local(*CORE::GLOBAL::require); - $r = ''; - eval "require NoNeXiSt;"; - ok( ! ( $r or $@ !~ /^Can't locate NoNeXiSt/i ) ); -} - -# -# readline() has special behaviour too -# - -$r = 11; -INIT { *CORE::GLOBAL::readline = sub (;*) { ++$r }; } -eval q/ -is( , 12, 12 ); -is( <$fh> , 13, 13 ); -my $pad_fh; -is( <$pad_fh> , 14, 14 ); -/; - -# Non-global readline() override -INIT { *Rgs::readline = sub (;*) { --$r }; } -eval q/{ - package Rgs; - ::is( , 13, 13 ); - ::is( <$fh> , 12, 12 ); - ::is( <$pad_fh> , 11, 11 ); -}/; - -# Global readpipe() override -INIT { *CORE::GLOBAL::readpipe = sub ($) { "$_[0] " . --$r }; } -eval q| -is( `rm`, "rm 10", '``' ); -is( qx/cp/, "cp 9", 'qx' ); -|; - -# Non-global readpipe() override -INIT { *Rgs::readpipe = sub ($) { ++$r . " $_[0]" }; } -eval q|{ - package Rgs; - ::is( `rm`, "10 rm", '``' ); - ::is( qx/cp/, "11 cp", 'qx' ); -}|; - -# Verify that the parsing of overridden keywords isn't messed up -# by the indirect object notation -{ - local $SIG{__WARN__} = sub { - ::like( $_[0], qr/^ok overriden at/, "like" ); - }; - INIT { *OverridenWarn::warn = sub { CORE::warn "@_ overriden"; }; } - package OverridenWarn; - sub foo { "ok" } - eval q| - warn( OverridenWarn->foo() ); - warn OverridenWarn->foo(); - |; -} -INIT { *OverridenPop::pop = sub { ::is( $_[0][0], "ok" ) }; } -{ - package OverridenPop; - sub foo { [ "ok" ] } - eval q| - pop( OverridenPop->foo() ); - pop OverridenPop->foo(); - |; -} - -{ - eval { - local *CORE::GLOBAL::require = sub { - CORE::require($_[0]); - }; - require 5; - require Text::ParseWords; - }; - is $@, '', '$@ empty'; -} diff --git a/t/CORE/op/pack.t b/t/CORE/op/pack.t deleted file mode 100644 index db7e84903..000000000 --- a/t/CORE/op/pack.t +++ /dev/null @@ -1,2000 +0,0 @@ -#!./perl -w - -BEGIN { - unshift @INC, 't/CORE/lib'; - require 't/CORE/test.pl'; -} - -# This is truth in an if statement, and could be a skip message -my $no_endianness = $] > 5.009 ? '' : - "Endianness pack modifiers not available on this perl"; -my $no_signedness = $] > 5.009 ? '' : - "Signed/unsigned pack modifiers not available on this perl"; - -plan tests => 14700; - -use strict; -use warnings qw(FATAL all); -use Config; - -my $Is_EBCDIC = (defined $Config{ebcdic} && $Config{ebcdic} eq 'define'); -my $Perl = which_perl(); -my @valid_errors = (qr/^Invalid type '\w'/); - -my $ByteOrder = 'unknown'; -my $maybe_not_avail = '(?:hto[bl]e|[bl]etoh)'; -if ($no_endianness) { - push @valid_errors, qr/^Invalid type '[<>]'/; -} elsif ($Config{byteorder} =~ /^1234(?:5678)?$/) { - $ByteOrder = 'little'; - $maybe_not_avail = '(?:htobe|betoh)'; -} -elsif ($Config{byteorder} =~ /^(?:8765)?4321$/) { - $ByteOrder = 'big'; - $maybe_not_avail = '(?:htole|letoh)'; -} -else { - push @valid_errors, qr/^Can't (?:un)?pack (?:big|little)-endian .*? on this platform/; -} - -if ($no_signedness) { - push @valid_errors, qr/^'!' allowed only after types sSiIlLxX in (?:un)?pack/; -} - -for my $size ( 16, 32, 64 ) { - if (defined $Config{"u${size}size"} and ($Config{"u${size}size"}||0) != ($size >> 3)) { - push @valid_errors, qr/^Perl_my_$maybe_not_avail$size\(\) not available/; - } -} - -my $IsTwosComplement = pack('i', -1) eq "\xFF" x $Config{intsize}; -print "# \$IsTwosComplement = $IsTwosComplement\n"; - -sub is_valid_error -{ - my $err = shift; - - for my $e (@valid_errors) { - $err =~ $e and return 1; - } - - return 0; -} - -sub encode_list { - my @result = map {_qq($_)} @_; - if (@result == 1) { - return @result; - } - return '(' . join (', ', @result) . ')'; -} - - -sub list_eq ($$) { - my ($l, $r) = @_; - return 0 unless @$l == @$r; - for my $i (0..$#$l) { - if (defined $l->[$i]) { - return 0 unless defined ($r->[$i]) && $l->[$i] eq $r->[$i]; - } else { - return 0 if defined $r->[$i] - } - } - return 1; -} - -############################################################################## -# -# Here starteth the tests -# - -{ - my $format = "c2 x5 C C x s d i l a6"; - # Need the expression in here to force ary[5] to be numeric. This avoids - # test2 failing because ary2 goes str->numeric->str and ary doesn't. - my @ary = (1,-100,127,128,32767,987.654321098 / 100.0,12345,123456, - "abcdef"); - my $foo = pack($format,@ary); - my @ary2 = unpack($format,$foo); - - is($#ary, $#ary2); - - my $out1=join(':',@ary); - my $out2=join(':',@ary2); - # Using long double NVs may introduce greater accuracy than wanted. - $out1 =~ s/:9\.87654321097999\d*:/:9.87654321098:/; - $out2 =~ s/:9\.87654321097999\d*:/:9.87654321098:/; - is($out1, $out2); - - like($foo, qr/def/); -} -# How about counting bits? - -{ - my $x; - is( ($x = unpack("%32B*", "\001\002\004\010\020\040\100\200\377")), 16 ); - - is( ($x = unpack("%32b69", "\001\002\004\010\020\040\100\200\017")), 12 ); - - is( ($x = unpack("%32B69", "\001\002\004\010\020\040\100\200\017")), 9 ); -} - -{ - my $sum = 129; # ASCII - $sum = 103 if $Is_EBCDIC; - - my $x; - is( ($x = unpack("%32B*", "Now is the time for all good blurfl")), $sum ); - - my $foo; - open(BIN, $Perl) || die "Can't open $Perl: $!\n"; - binmode BIN; - sysread BIN, $foo, 8192; - close BIN; - - $sum = unpack("%32b*", $foo); - my $longway = unpack("b*", $foo); - is( $sum, $longway =~ tr/1/1/ ); -} - -{ - my $x; - is( ($x = unpack("I",pack("I", 0xFFFFFFFF))), 0xFFFFFFFF ); -} - -{ - # check 'w' - my @x = (5,130,256,560,32000,3097152,268435455,1073741844, 2**33, - '4503599627365785','23728385234614992549757750638446'); - my $x = pack('w*', @x); - my $y = pack 'H*', '0581028200843081fa0081bd8440ffffff7f8480808014A0808'. - '0800087ffffffffffdb19caefe8e1eeeea0c2e1e3e8ede1ee6e'; - - is($x, $y); - - my @y = unpack('w*', $y); - my $a; - while ($a = pop @x) { - my $b = pop @y; - is($a, $b); - } - - @y = unpack('w2', $x); - - is(scalar(@y), 2); - is($y[1], 130); - $x = pack('w*', 5000000000); $y = ''; - # Math::BigInt::Calc skipped - perlcc issue 176 - # https://code.google.com/p/perl-compiler/issues/detail?id=176 - eval { - use Math::BigInt; - $y = pack('w*', Math::BigInt::->new(5000000000)); - }; - is($x, $y, "5000000000 x: $x ; y: $y"); - - $x = pack 'w', ~0; - $y = pack 'w', (~0).''; - is($x, $y, '~0 int scalar'); - is(unpack ('w',$x), ~0); - is(unpack ('w',$y), ~0); - - $x = pack 'w', ~0 - 1; - $y = pack 'w', (~0) - 2; - - if (~0 - 1 == (~0) - 2) { - is($x, $y, "NV arithmetic"); - } else { - isnt($x, $y, "IV/NV arithmetic"); - } - cmp_ok(unpack ('w',$x), '==', ~0 - 1); - cmp_ok(unpack ('w',$y), '==', ~0 - 2); - - # These should spot that pack 'w' is using NV, not double, on platforms - # where IVs are smaller than doubles, and harmlessly pass elsewhere. - # (tests for change 16861) - my $x0 = 2**54+3; - my $y0 = 2**54-2; - - $x = pack 'w', $x0; - $y = pack 'w', $y0; - - if ($x0 == $y0) { - is($x, $y, "NV arithmetic"); - } else { - isnt($x, $y, "IV/NV arithmetic"); - } - cmp_ok(unpack ('w',$x), '==', $x0); - cmp_ok(unpack ('w',$y), '==', $y0); -} - - -{ - print "# test exceptions\n"; - my $x; - eval { $x = unpack 'w', pack 'C*', 0xff, 0xff}; - like($@, qr/^Unterminated compressed integer/); - - eval { $x = unpack 'w', pack 'C*', 0xff, 0xff, 0xff, 0xff}; - like($@, qr/^Unterminated compressed integer/); - - eval { $x = unpack 'w', pack 'C*', 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff}; - like($@, qr/^Unterminated compressed integer/); - - eval { $x = pack 'w', -1 }; - like ($@, qr/^Cannot compress negative numbers/); - - eval { $x = pack 'w', '1'x(1 + length ~0) . 'e0' }; - like ($@, qr/^Can only compress unsigned integers/); - - # Check that the warning behaviour on the modifiers !, < and > is as we - # expect it for this perl. - my $can_endian = $no_endianness ? '' : 'sSiIlLqQjJfFdDpP'; - my $can_shriek = 'sSiIlL'; - $can_shriek .= 'nNvV' unless $no_signedness; - # h and H can't do either, so act as sanity checks in blead - foreach my $base (split '', 'hHsSiIlLqQjJfFdDpPnNvV') { - foreach my $mod ('', '<', '>', '!', '!', '!<', '!>') { - SKIP: { - # Avoid void context warnings. - my $a = eval {pack "$base$mod"}; - skip "pack can't $base", 1 if $@ =~ /^Invalid type '\w'/; - # Which error you get when 2 would be possible seems to be emergent - # behaviour of pack's format parser. - - my $fails_shriek = $mod =~ /!/ && index ($can_shriek, $base) == -1; - my $fails_endian = $mod =~ /[<>]/ && index ($can_endian, $base) == -1; - my $shriek_first = $mod =~ /^!/; - - if ($no_endianness and ($mod eq '!')) { - # The ! isn't seem as part of $base. Instead it's seen as a modifier - # on > or < - $fails_shriek = 1; - undef $fails_endian; - } elsif ($fails_shriek and $fails_endian) { - if ($shriek_first) { - undef $fails_endian; - } - } - - if ($fails_endian) { - if ($no_endianness) { - # < and > are seen as pattern letters, not modifiers - like ($@, qr/^Invalid type '[<>]'/, "pack can't $base$mod"); - } else { - like ($@, qr/^'[<>]' allowed only after types/, - "pack can't $base$mod"); - } - } elsif ($fails_shriek) { - like ($@, qr/^'!' allowed only after types/, - "pack can't $base$mod"); - } else { - is ($@, '', "pack can $base$mod"); - } - } - } - } - - SKIP: { - skip $no_endianness, 2*3 + 2*8 if $no_endianness; - for my $mod (qw( ! < > )) { - eval { $x = pack "a$mod", 42 }; - like ($@, qr/^'$mod' allowed only after types \S+ in pack/); - - eval { $x = unpack "a$mod", 'x'x8 }; - like ($@, qr/^'$mod' allowed only after types \S+ in unpack/); - } - - for my $mod (qw( <> >< !<> !>< >!< <>! >' after type 'I' in pack/); - - eval { $x = unpack "sI${mod}s", 'x'x16 }; - like ($@, qr/^Can't use both '<' and '>' after type 'I' in unpack/); - } - } - - SKIP: { - # Is this a stupid thing to do on VMS, VOS and other unusual platforms? - - skip("-- the IEEE infinity model is unavailable in this configuration.", 1) - if (($^O eq 'VMS') && !defined($Config{useieee})); - - skip("-- $^O has serious fp indigestion on w-packed infinities", 1) - if ( - ($^O eq 'mpeix') - || - ($^O eq 'ultrix') - || - ($^O =~ /^svr4/ && -f "/etc/issue" && -f "/etc/.relid") # NCR MP-RAS - ); - - my $inf = eval '2**1000000'; - - skip("Couldn't generate infinity - got error '$@'", 1) - unless defined $inf and $inf == $inf / 2 and $inf + 1 == $inf; - - local our $TODO; - $TODO = "VOS needs a fix for posix-1022 to pass this test." - if ($^O eq 'vos'); - - eval { $x = pack 'w', $inf }; - like ($@, qr/^Cannot compress integer/, "Cannot compress integer"); - } - - SKIP: { - - skip("-- the full range of an IEEE double may not be available in this configuration.", 3) - if (($^O eq 'VMS') && !defined($Config{useieee})); - - skip("-- $^O does not like 2**1023", 3) - if (($^O eq 'ultrix')); - - # This should be about the biggest thing possible on an IEEE double - my $big = eval '2**1023'; - - skip("Couldn't generate 2**1023 - got error '$@'", 3) - unless defined $big and $big != $big / 2; - - eval { $x = pack 'w', $big }; - is ($@, '', "Should be able to pack 'w', $big # 2**1023"); - - my $y = eval {unpack 'w', $x}; - is ($@, '', - "Should be able to unpack 'w' the result of pack 'w', $big # 2**1023"); - - # I'm getting about 1e-16 on FreeBSD - my $quotient = int (100 * ($y - $big) / $big); - ok($quotient < 2 && $quotient > -2, - "Round trip pack, unpack 'w' of $big is within 1% ($quotient%)"); - } - -} - -print "# test the 'p' template\n"; - -# literals -is(unpack("p",pack("p","foo")), "foo"); -SKIP: { - skip $no_endianness, 2 if $no_endianness; - is(unpack("p<",pack("p<","foo")), "foo"); - is(unpack("p>",pack("p>","foo")), "foo"); -} -# scalars -is(unpack("p",pack("p",239)), 239); -SKIP: { - skip $no_endianness, 2 if $no_endianness; - is(unpack("p<",pack("p<",239)), 239); - is(unpack("p>",pack("p>",239)), 239); -} - -# temps -sub foo { my $a = "a"; return $a . $a++ . $a++ } -{ - use warnings qw(NONFATAL all); - my $warning; - local $SIG{__WARN__} = sub { - $warning = $_[0]; - }; - my $junk = pack("p", &foo); - - like($warning, qr/temporary val/); -} - -# undef should give null pointer -like(pack("p", undef), qr/^\0+$/); -SKIP: { - skip $no_endianness, 2 if $no_endianness; - like(pack("p<", undef), qr/^\0+$/); - like(pack("p>", undef), qr/^\0+$/); -} - -# Check for optimizer bug (e.g. Digital Unix GEM cc with -O4 on DU V4.0B gives -# 4294967295 instead of -1) -# see #ifdef __osf__ in pp.c pp_unpack -is((unpack("i",pack("i",-1))), -1); - -print "# test the pack lengths of s S i I l L n N v V + modifiers\n"; - -my @lengths = ( - qw(s 2 S 2 i -4 I -4 l 4 L 4 n 2 N 4 v 2 V 4 n! 2 N! 4 v! 2 V! 4), - 's!' => $Config{shortsize}, 'S!' => $Config{shortsize}, - 'i!' => $Config{intsize}, 'I!' => $Config{intsize}, - 'l!' => $Config{longsize}, 'L!' => $Config{longsize}, -); - -while (my ($base, $expect) = splice @lengths, 0, 2) { - my @formats = ($base); - $base =~ /^[nv]/i or push @formats, "$base>", "$base<"; - for my $format (@formats) { - SKIP: { - skip $no_endianness, 1 if $no_endianness && $format =~ m/[<>]/; - skip $no_signedness, 1 if $no_signedness && $format =~ /[nNvV]!/; - my $len = length(pack($format, 0)); - if ($expect > 0) { - is($expect, $len, "format '$format'"); - } else { - $expect = -$expect; - ok ($len >= $expect, "format '$format'") || - print "# format '$format' has length $len, expected >= $expect\n"; - } - } - } -} - - -print "# test unpack-pack lengths\n"; - -my @templates = qw(c C W i I s S l L n N v V f d q Q); - -foreach my $base (@templates) { - my @tmpl = ($base); - $base =~ /^[cwnv]/i or push @tmpl, "$base>", "$base<"; - foreach my $t (@tmpl) { - SKIP: { - my @t = eval { unpack("$t*", pack("$t*", 12, 34)) }; - - skip "cannot pack '$t' on this perl", 4 - if is_valid_error($@); - - is( $@, '', "Template $t works"); - is(scalar @t, 2); - - is($t[0], 12); - is($t[1], 34); - } - } -} - -{ - # uuencode/decode - - # Note that first uuencoding known 'text' data and then checking the - # binary values of the uuencoded version would not be portable between - # character sets. Uuencoding is meant for encoding binary data, not - # text data. - - my $in = pack 'C*', 0 .. 255; - - # just to be anal, we do some random tr/`/ / - my $uu = <<'EOUU'; -M` $"`P0%!@<("0H+# T.#Q`1$A,4%187&!D:&QP='A\@(2(C)"4F)R@I*BLL -M+2XO,#$R,S0U-C'EZ>WQ]?G^`@8*#A(6& -MAXB)BHN,C8Z/D)&2DY25EI>8F9J;G)V>GZ"AHJ.DI::GJ*FJJZRMKJ^PL;*S -MM+6VM[BYNKN\O;Z_P,'"P\3%QL?(R+CY.7FY^CIZNOL[>[O\/'R\_3U]O?X^?K[_/W^_P ` -EOUU - - $_ = $uu; - tr/ /`/; - - is(pack('u', $in), $_); - - is(unpack('u', $uu), $in); - - $in = "\x1f\x8b\x08\x08\x58\xdc\xc4\x35\x02\x03\x4a\x41\x50\x55\x00\xf3\x2a\x2d\x2e\x51\x48\xcc\xcb\x2f\xc9\x48\x2d\x52\x08\x48\x2d\xca\x51\x28\x2d\x4d\xce\x4f\x49\x2d\xe2\x02\x00\x64\x66\x60\x5c\x1a\x00\x00\x00"; - $uu = <<'EOUU'; -M'XL("%C("`&1F -&8%P:```` -EOUU - - is(unpack('u', $uu), $in); - -# This is identical to the above except that backquotes have been -# changed to spaces - - $uu = <<'EOUU'; -M'XL("%C(" &1F -&8%P: -EOUU - - # ' # Grr - is(unpack('u', $uu), $in); - -} - -# test the ascii template types (A, a, Z) - -foreach ( -['p', 'A*', "foo\0bar\0 ", "foo\0bar\0 "], -['p', 'A11', "foo\0bar\0 ", "foo\0bar\0 "], -['u', 'A*', "foo\0bar \0", "foo\0bar"], -['u', 'A8', "foo\0bar \0", "foo\0bar"], -['p', 'a*', "foo\0bar\0 ", "foo\0bar\0 "], -['p', 'a11', "foo\0bar\0 ", "foo\0bar\0 \0\0"], -['u', 'a*', "foo\0bar \0", "foo\0bar \0"], -['u', 'a8', "foo\0bar \0", "foo\0bar "], -['p', 'Z*', "foo\0bar\0 ", "foo\0bar\0 \0"], -['p', 'Z11', "foo\0bar\0 ", "foo\0bar\0 \0\0"], -['p', 'Z3', "foo", "fo\0"], -['u', 'Z*', "foo\0bar \0", "foo"], -['u', 'Z8', "foo\0bar \0", "foo"], -) -{ - my ($what, $template, $in, $out) = @$_; - my $got = $what eq 'u' ? (unpack $template, $in) : (pack $template, $in); - unless (is($got, $out)) { - my $un = $what eq 'u' ? 'un' : ''; - print "# ${un}pack ('$template', "._qq($in).') gave '._qq($out). - ' not '._qq($got)."\n"; - } -} - -print "# packing native shorts/ints/longs\n"; - -is(length(pack("s!", 0)), $Config{shortsize}); -is(length(pack("i!", 0)), $Config{intsize}); -is(length(pack("l!", 0)), $Config{longsize}); -ok(length(pack("s!", 0)) <= length(pack("i!", 0))); -ok(length(pack("i!", 0)) <= length(pack("l!", 0))); -is(length(pack("i!", 0)), length(pack("i", 0))); - -sub numbers { - my $base = shift; - my @formats = ($base); - $base =~ /^[silqjfdp]/i and push @formats, "$base>", "$base<"; - for my $format (@formats) { - numbers_with_total ($format, undef, @_); - } -} - -sub numbers_with_total { - my $format = shift; - my $total = shift; - if (!defined $total) { - foreach (@_) { - $total += $_; - } - } - print "# numbers test for $format\n"; - foreach (@_) { - SKIP: { - my $out = eval {unpack($format, pack($format, $_))}; - skip "cannot pack '$format' on this perl", 2 - if is_valid_error($@); - - is($@, '', "no error"); - is($out, $_, "unpack pack $format $_"); - } - } - - my $skip_if_longer_than = ~0; # "Infinity" - if (~0 - 1 == ~0) { - # If we're running with -DNO_PERLPRESERVE_IVUV and NVs don't preserve all - # UVs (in which case ~0 is NV, ~0-1 will be the same NV) then we can't - # correctly in perl calculate UV totals for long checksums, as pp_unpack - # is using UV maths, and we've only got NVs. - $skip_if_longer_than = $Config{nv_preserves_uv_bits}; - } - - foreach ('', 1, 2, 3, 15, 16, 17, 31, 32, 33, 53, 54, 63, 64, 65) { - SKIP: { - my $sum = eval {unpack "%$_$format*", pack "$format*", @_}; - skip "cannot pack '$format' on this perl", 3 - if is_valid_error($@); - - is($@, '', "no error"); - ok(defined $sum, "sum bits $_, format $format defined"); - - my $len = $_; # Copy, so that we can reassign '' - $len = 16 unless length $len; - - SKIP: { - skip "cannot test checksums over $skip_if_longer_than bits", 1 - if $len > $skip_if_longer_than; - - # Our problem with testing this portably is that the checksum code in - # pp_unpack is able to cast signed to unsigned, and do modulo 2**n - # arithmetic in unsigned ints, which perl has no operators to do. - # (use integer; does signed ints, which won't wrap on UTS, which is just - # fine with ANSI, but not with most people's assumptions. - # This is why we need to supply the totals for 'Q' as there's no way in - # perl to calculate them, short of unpack '%0Q' (is that documented?) - # ** returns NVs; make sure it's IV. - my $max = 1 + 2 * (int (2 ** ($len-1))-1); # The max possible checksum - my $max_p1 = $max + 1; - my ($max_is_integer, $max_p1_is_integer); - $max_p1_is_integer = 1 unless $max_p1 + 1 == $max_p1; - $max_is_integer = 1 if $max - 1 < ~0; - - my $calc_sum; - if (ref $total) { - $calc_sum = &$total($len); - } else { - $calc_sum = $total; - # Shift into range by some multiple of the total - my $mult = $max_p1 ? int ($total / $max_p1) : undef; - # Need this to make sure that -1 + (~0+1) is ~0 (ie still integer) - $calc_sum = $total - $mult; - $calc_sum -= $mult * $max; - if ($calc_sum < 0) { - $calc_sum += 1; - $calc_sum += $max; - } - } - if ($calc_sum == $calc_sum - 1 && $calc_sum == $max_p1) { - # we're into floating point (either by getting out of the range of - # UV arithmetic, or because we're doing a floating point checksum) - # and our calculation of the checksum has become rounded up to - # max_checksum + 1 - $calc_sum = 0; - } - - if ($calc_sum == $sum) { # HAS to be ==, not eq (so no is()). - pass ("unpack '%$_$format' gave $sum"); - } else { - my $delta = 1.000001; - if ($format =~ tr /dDfF// - && ($calc_sum <= $sum * $delta && $calc_sum >= $sum / $delta)) { - pass ("unpack '%$_$format' gave $sum, expected $calc_sum"); - } else { - my $text = ref $total ? &$total($len) : $total; - fail; - print "# For list (" . join (", ", @_) . ") (total $text)" - . " packed with $format unpack '%$_$format' gave $sum," - . " expected $calc_sum\n"; - } - } - } - } - } -} - -numbers ('c', -128, -1, 0, 1, 127); -numbers ('C', 0, 1, 127, 128, 255); -numbers ('W', 0, 1, 127, 128, 255, 256, 0x7ff, 0x800, 0xfffd); -numbers ('s', -32768, -1, 0, 1, 32767); -numbers ('S', 0, 1, 32767, 32768, 65535); -numbers ('i', -2147483648, -1, 0, 1, 2147483647); -numbers ('I', 0, 1, 2147483647, 2147483648, 4294967295); -numbers ('l', -2147483648, -1, 0, 1, 2147483647); -numbers ('L', 0, 1, 2147483647, 2147483648, 4294967295); -numbers ('s!', -32768, -1, 0, 1, 32767); -numbers ('S!', 0, 1, 32767, 32768, 65535); -numbers ('i!', -2147483648, -1, 0, 1, 2147483647); -numbers ('I!', 0, 1, 2147483647, 2147483648, 4294967295); -numbers ('l!', -2147483648, -1, 0, 1, 2147483647); -numbers ('L!', 0, 1, 2147483647, 2147483648, 4294967295); -numbers ('n', 0, 1, 32767, 32768, 65535); -numbers ('v', 0, 1, 32767, 32768, 65535); -numbers ('N', 0, 1, 2147483647, 2147483648, 4294967295); -numbers ('V', 0, 1, 2147483647, 2147483648, 4294967295); -numbers ('n!', -32768, -1, 0, 1, 32767); -numbers ('v!', -32768, -1, 0, 1, 32767); -numbers ('N!', -2147483648, -1, 0, 1, 2147483647); -numbers ('V!', -2147483648, -1, 0, 1, 2147483647); -# All these should have exact binary representations: -numbers ('f', -1, 0, 0.5, 42, 2**34); -numbers ('d', -(2**34), -1, 0, 1, 2**34); -## These don't, but 'd' is NV. XXX wrong, it's double -#numbers ('d', -1, 0, 1, 1-exp(-1), -exp(1)); - -numbers_with_total ('q', -1, - -9223372036854775808, -1, 0, 1,9223372036854775807); -# This total is icky, but the true total is 2**65-1, and need a way to generate -# the expected checksum on any system including those where NVs can preserve -# 65 bits. (long double is 128 bits on sparc, so they certainly can) -# or where rounding is down not up on binary conversion (crays) -numbers_with_total ('Q', sub { - my $len = shift; - $len = 65 if $len > 65; # unmasked total is 2**65-1 here - my $total = 1 + 2 * (int (2**($len - 1)) - 1); - return 0 if $total == $total - 1; # Overflowed integers - return $total; # NVs still accurate to nearest integer - }, - 0, 1,9223372036854775807, 9223372036854775808, - 18446744073709551615); - -print "# pack nvNV byteorders\n"; - -is(pack("n", 0xdead), "\xde\xad"); -is(pack("v", 0xdead), "\xad\xde"); -is(pack("N", 0xdeadbeef), "\xde\xad\xbe\xef"); -is(pack("V", 0xdeadbeef), "\xef\xbe\xad\xde"); - -SKIP: { - skip $no_signedness, 4 if $no_signedness; - is(pack("n!", 0xdead), "\xde\xad"); - is(pack("v!", 0xdead), "\xad\xde"); - is(pack("N!", 0xdeadbeef), "\xde\xad\xbe\xef"); - is(pack("V!", 0xdeadbeef), "\xef\xbe\xad\xde"); -} - -print "# test big-/little-endian conversion\n"; - -sub byteorder -{ - my $format = shift; - print "# byteorder test for $format\n"; - for my $value (@_) { - SKIP: { - my($nat,$be,$le) = eval { map { pack $format.$_, $value } '', '>', '<' }; - skip "cannot pack '$format' on this perl", 5 - if is_valid_error($@); - - { - use warnings qw(NONFATAL utf8); - print "# [$value][$nat][$be][$le][$@]\n"; - } - - SKIP: { - skip "cannot compare native byteorder with big-/little-endian", 1 - if $ByteOrder eq 'unknown'; - - is($nat, $ByteOrder eq 'big' ? $be : $le); - } - is($be, reverse($le)); - my @x = eval { unpack "$format$format>$format<", $nat.$be.$le }; - - print "# [$value][", join('][', @x), "][$@]\n"; - - is($@, ''); - is($x[0], $x[1]); - is($x[0], $x[2]); - } - } -} - -byteorder('s', -32768, -1, 0, 1, 32767); -byteorder('S', 0, 1, 32767, 32768, 65535); -byteorder('i', -2147483648, -1, 0, 1, 2147483647); -byteorder('I', 0, 1, 2147483647, 2147483648, 4294967295); -byteorder('l', -2147483648, -1, 0, 1, 2147483647); -byteorder('L', 0, 1, 2147483647, 2147483648, 4294967295); -byteorder('j', -2147483648, -1, 0, 1, 2147483647); -byteorder('J', 0, 1, 2147483647, 2147483648, 4294967295); -byteorder('s!', -32768, -1, 0, 1, 32767); -byteorder('S!', 0, 1, 32767, 32768, 65535); -byteorder('i!', -2147483648, -1, 0, 1, 2147483647); -byteorder('I!', 0, 1, 2147483647, 2147483648, 4294967295); -byteorder('l!', -2147483648, -1, 0, 1, 2147483647); -byteorder('L!', 0, 1, 2147483647, 2147483648, 4294967295); -byteorder('q', -9223372036854775808, -1, 0, 1, 9223372036854775807); -byteorder('Q', 0, 1, 9223372036854775807, 9223372036854775808, 18446744073709551615); -byteorder('f', -1, 0, 0.5, 42, 2**34); -byteorder('F', -1, 0, 0.5, 42, 2**34); -byteorder('d', -(2**34), -1, 0, 1, 2**34); -byteorder('D', -(2**34), -1, 0, 1, 2**34); - -print "# test negative numbers\n"; - -SKIP: { - skip "platform is not using two's complement for negative integers", 120 - unless $IsTwosComplement; - - for my $format (qw(s i l j s! i! l! q)) { - SKIP: { - my($nat,$be,$le) = eval { map { pack $format.$_, -1 } '', '>', '<' }; - skip "cannot pack '$format' on this perl", 15 - if is_valid_error($@); - - my $len = length $nat; - is($_, "\xFF"x$len) for $nat, $be, $le; - - my(@val,@ref); - if ($len >= 8) { - @val = (-2, -81985529216486896, -9223372036854775808); - @ref = ("\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFE", - "\xFE\xDC\xBA\x98\x76\x54\x32\x10", - "\x80\x00\x00\x00\x00\x00\x00\x00"); - } - elsif ($len >= 4) { - @val = (-2, -19088744, -2147483648); - @ref = ("\xFF\xFF\xFF\xFE", - "\xFE\xDC\xBA\x98", - "\x80\x00\x00\x00"); - } - else { - @val = (-2, -292, -32768); - @ref = ("\xFF\xFE", - "\xFE\xDC", - "\x80\x00"); - } - for my $x (@ref) { - if ($len > length $x) { - $x = $x . "\xFF" x ($len - length $x); - } - } - - for my $i (0 .. $#val) { - my($nat,$be,$le) = eval { map { pack $format.$_, $val[$i] } '', '>', '<' }; - is($@, ''); - - SKIP: { - skip "cannot compare native byteorder with big-/little-endian", 1 - if $ByteOrder eq 'unknown'; - - is($nat, $ByteOrder eq 'big' ? $be : $le); - } - - is($be, $ref[$i]); - is($be, reverse($le)); - } - } - } -} - -{ - # / - - my ($x, $y, $z); - eval { ($x) = unpack '/a*','hello' }; - like($@, qr!'/' must follow a numeric type!); - undef $x; - eval { $x = unpack '/a*','hello' }; - like($@, qr!'/' must follow a numeric type!); - - undef $x; - eval { ($z,$x,$y) = unpack 'a3/A C/a* C/Z', "003ok \003yes\004z\000abc" }; - is($@, ''); - is($z, 'ok'); - is($x, 'yes'); - is($y, 'z'); - undef $z; - eval { $z = unpack 'a3/A C/a* C/Z', "003ok \003yes\004z\000abc" }; - is($@, ''); - is($z, 'ok'); - - - undef $x; - eval { ($x) = pack '/a*','hello' }; - like($@, qr!Invalid type '/'!); - undef $x; - eval { $x = pack '/a*','hello' }; - like($@, qr!Invalid type '/'!); - - $z = pack 'n/a* N/Z* w/A*','string','hi there ','etc'; - my $expect = "\000\006string\0\0\0\012hi there \000\003etc"; - is($z, $expect); - - undef $x; - $expect = 'hello world'; - eval { ($x) = unpack ("w/a", chr (11) . "hello world!")}; - is($x, $expect); - is($@, ''); - - undef $x; - # Doing this in scalar context used to fail. - eval { $x = unpack ("w/a", chr (11) . "hello world!")}; - is($@, ''); - is($x, $expect); - - foreach ( - ['a/a*/a*', '212ab345678901234567','ab3456789012'], - ['a/a*/a*', '3012ab345678901234567', 'ab3456789012'], - ['a/a*/b*', '212ab', $Is_EBCDIC ? '100000010100' : '100001100100'], - ) - { - my ($pat, $in, $expect) = @$_; - undef $x; - eval { ($x) = unpack $pat, $in }; - is($@, ''); - is($x, $expect) || - printf "# list unpack ('$pat', '$in') gave %s, expected '$expect'\n", - encode_list ($x); - - undef $x; - eval { $x = unpack $pat, $in }; - is($@, ''); - is($x, $expect) || - printf "# scalar unpack ('$pat', '$in') gave %s, expected '$expect'\n", - encode_list ($x); - } - - # / with # - - my $pattern = <<'EOU'; - a3/A # Count in ASCII - C/a* # Count in a C char - C/Z # Count in a C char but skip after \0 -EOU - - $x = $y = $z =undef; - eval { ($z,$x,$y) = unpack $pattern, "003ok \003yes\004z\000abc" }; - is($@, ''); - is($z, 'ok'); - is($x, 'yes'); - is($y, 'z'); - undef $x; - eval { $z = unpack $pattern, "003ok \003yes\004z\000abc" }; - is($@, ''); - is($z, 'ok'); - - $pattern = <<'EOP'; - n/a* # Count as network short - w/A* # Count a BER integer -EOP - $expect = "\000\006string\003etc"; - $z = pack $pattern,'string','etc'; - is($z, $expect); -} - - -SKIP: { - skip("(EBCDIC and) version strings are bad idea", 2) if $Is_EBCDIC; - - is("1.20.300.4000", sprintf "%vd", pack("U*",1,20,300,4000)); - is("1.20.300.4000", sprintf "%vd", pack(" U*",1,20,300,4000)); -} -isnt(v1.20.300.4000, sprintf "%vd", pack("C0U*",1,20,300,4000)); - -my $rslt = $Is_EBCDIC ? "156 67" : "199 162"; -is(join(" ", unpack("U0 C*", chr(0x1e2))), $rslt); - -# does pack U create Unicode? -is(ord(pack('U', 300)), 300); - -# does unpack U deref Unicode? -is((unpack('U', chr(300)))[0], 300); - -# is unpack U the reverse of pack U for Unicode string? -is("@{[unpack('U*', pack('U*', 100, 200, 300))]}", "100 200 300"); - -# is unpack U the reverse of pack U for byte string? -is("@{[unpack('U*', pack('U*', 100, 200))]}", "100 200"); - - -SKIP: { - skip "Not for EBCDIC", 4 if $Is_EBCDIC; - - # does pack U0C create Unicode? - is("@{[pack('U0C*', 100, 195, 136)]}", v100.v200); - - # does pack C0U create characters? - is("@{[pack('C0U*', 100, 200)]}", pack("C*", 100, 195, 136)); - - # does unpack U0U on byte data warn? - { - use warnings qw(NONFATAL all); - - my $bad = pack("U0C", 255); - local $SIG{__WARN__} = sub { $@ = "@_" }; - my @null = unpack('U0U', $bad); - like($@, qr/^Malformed UTF-8 character /); - } -} - -{ - my $p = pack 'i*', -2147483648, ~0, 0, 1, 2147483647; - my (@a); - # bug - % had to be at the start of the pattern, no leading whitespace or - # comments. %i! didn't work at all. - foreach my $pat ('%32i*', ' %32i*', "# Muhahahaha\n%32i*", '%32i* ', - '%32i!*', ' %32i!*', "\n#\n#\n\r \t\f%32i!*", '%32i!*#') { - @a = unpack $pat, $p; - is($a[0], 0xFFFFFFFF) || print "# $pat\n"; - @a = scalar unpack $pat, $p; - is($a[0], 0xFFFFFFFF) || print "# $pat\n"; - } - - - $p = pack 'I*', 42, 12; - # Multiline patterns in scalar context failed. - foreach my $pat ('I', < 32 bits with floating - # point, so a pathologically long pattern would wrap at 32 bits. - my $pat = "\xff\xff"x65538; # Start with it long, to save any copying. - foreach (4,3,2,1,0) { - my $len = 65534 + $_; - is(unpack ("%33n$len", $pat), 65535 * $len); - } -} - - -# pack x X @ -foreach ( - ['x', "N", "\0"], - ['x4', "N", "\0"x4], - ['xX', "N", ""], - ['xXa*', "Nick", "Nick"], - ['a5Xa5', "cameL", "llama", "camellama"], - ['@4', 'N', "\0"x4], - ['a*@8a*', 'Camel', 'Dromedary', "Camel\0\0\0Dromedary"], - ['a*@4a', 'Perl rules', '!', 'Perl!'], -) -{ - my ($template, @in) = @$_; - my $out = pop @in; - my $got = eval {pack $template, @in}; - is($@, ''); - is($out, $got) || - printf "# pack ('$template', %s) gave %s expected %s\n", - encode_list (@in), encode_list ($got), encode_list ($out); -} - -# unpack x X @ -foreach ( - ['x', "N"], - ['xX', "N"], - ['xXa*', "Nick", "Nick"], - ['a5Xa5', "camellama", "camel", "llama"], - ['@3', "ice"], - ['@2a2', "water", "te"], - ['a*@1a3', "steam", "steam", "tea"], -) -{ - my ($template, $in, @out) = @$_; - my @got = eval {unpack $template, $in}; - is($@, ''); - ok (list_eq (\@got, \@out)) || - printf "# list unpack ('$template', %s) gave %s expected %s\n", - _qq($in), encode_list (@got), encode_list (@out); - - my $got = eval {unpack $template, $in}; - is($@, ''); - @out ? is( $got, $out[0] ) # 1 or more items; should get first - : ok( !defined $got ) # 0 items; should get undef - or printf "# scalar unpack ('$template', %s) gave %s expected %s\n", - _qq($in), encode_list ($got), encode_list ($out[0]); -} - -{ - my $t = 'Z*Z*'; - my ($u, $v) = qw(foo xyzzy); - my $p = pack($t, $u, $v); - my @u = unpack($t, $p); - is(scalar @u, 2); - is($u[0], $u); - is($u[1], $v); -} - -{ - is((unpack("w/a*", "\x02abc"))[0], "ab"); - - # "w/a*" should be seen as one unit - - is(scalar unpack("w/a*", "\x02abc"), "ab"); -} - -SKIP: { - print "# group modifiers\n"; - - skip $no_endianness, 3 * 2 + 3 * 2 + 1 if $no_endianness; - - for my $t (qw{ (s<)< (sl>s)> (s(l(sl) (sl>s)< (s(l(sl) }) { - print "# testing pattern '$t'\n"; - eval { ($_) = unpack($t, 'x'x18); }; - like($@, qr/Can't use '[<>]' in a group with different byte-order in unpack/); - eval { $_ = pack($t, (0)x6); }; - like($@, qr/Can't use '[<>]' in a group with different byte-order in pack/); - } - - is(pack('L', (0x12345678)x2), - pack('(((L1)1)<)(((L)1)1)>1', (0x12345678)x2)); -} - -{ - sub compress_template { - my $t = shift; - for my $mod (qw( < > )) { - $t =~ s/((?:(?:[SILQJFDP]!?$mod|[^SILQJFDP\W]!?)(?:\d+|\*|\[(?:[^]]+)\])?\/?){2,})/ - my $x = $1; $x =~ s!$mod!!g ? "($x)$mod" : $x /ieg; - } - return $t; - } - - my %templates = ( - 's<' => [-42], - 's [-42, -11, 12, 4711], - '(i [-11, -22, -33, 1000000, 1100, 2201, 3302, - -1000000, 32767, -32768, 1, -123456789 ], - '(I!<4(J<2L<)3)5' => [1 .. 65], - 'q [-50000000005, 60000000006], - 'f [3.14159, 111.11, 2222.22], - 'D [1e42, -128, 255, 1e-42], - 'n/a*' => ['/usr/bin/perl'], - 'C/a*S [qw(Just another Perl hacker)], - ); - - for my $tle (sort keys %templates) { - my @d = @{$templates{$tle}}; - my $tbe = $tle; - $tbe =~ y//; - for my $t ($tbe, $tle) { - my $c = compress_template($t); - print "# '$t' -> '$c'\n"; - SKIP: { - my $p1 = eval { pack $t, @d }; - skip "cannot pack '$t' on this perl", 5 if is_valid_error($@); - my $p2 = eval { pack $c, @d }; - is($@, ''); - is($p1, $p2); - s!(/[aAZ])\*!$1!g for $t, $c; - my @u1 = eval { unpack $t, $p1 }; - is($@, ''); - my @u2 = eval { unpack $c, $p2 }; - is($@, ''); - is(join('!', @u1), join('!', @u2)); - } - } - } -} - -{ - # from Wolfgang Laun: fix in change #13163 - - my $s = 'ABC' x 10; - my $t = '*'; - my $x = ord($t); - my $buf = pack( 'Z*/A* C', $s, $x ); - my $y; - - my $h = $buf; - $h =~ s/[^[:print:]]/./g; - ( $s, $y ) = unpack( "Z*/A* C", $buf ); - is($h, "30.ABCABCABCABCABCABCABCABCABCABC$t"); - is(length $buf, 34); - is($s, "ABCABCABCABCABCABCABCABCABCABC"); - is($y, $x); -} - -{ - # from Wolfgang Laun: fix in change #13288 - - eval { my $t=unpack("P*", "abc") }; - like($@, qr/'P' must have an explicit size/); -} - -{ # Grouping constructs - my (@a, @b); - @a = unpack '(SL)', pack 'SLSLSL', 67..90; - is("@a", "67 68"); - @a = unpack '(SL)3', pack 'SLSLSL', 67..90; - @b = (67..72); - is("@a", "@b"); - @a = unpack '(SL)3', pack 'SLSLSLSL', 67..90; - is("@a", "@b"); - @a = unpack '(SL)[3]', pack 'SLSLSLSL', 67..90; - is("@a", "@b"); - @a = unpack '(SL)[2] SL', pack 'SLSLSLSL', 67..90; - is("@a", "@b"); - @a = unpack 'A/(SL)', pack 'ASLSLSLSL', 3, 67..90; - is("@a", "@b"); - @a = unpack 'A/(SL)SL', pack 'ASLSLSLSL', 2, 67..90; - is("@a", "@b"); - @a = unpack '(SL)*', pack 'SLSLSLSL', 67..90; - @b = (67..74); - is("@a", "@b"); - @a = unpack '(SL)*SL', pack 'SLSLSLSL', 67..90; - is("@a", "@b"); - eval { @a = unpack '(*SL)', '' }; - like($@, qr/\(\)-group starts with a count/); - eval { @a = unpack '(3SL)', '' }; - like($@, qr/\(\)-group starts with a count/); - eval { @a = unpack '([3]SL)', '' }; - like($@, qr/\(\)-group starts with a count/); - eval { @a = pack '(*SL)' }; - like($@, qr/\(\)-group starts with a count/); - @a = unpack '(SL)3 SL', pack '(SL)4', 67..74; - is("@a", "@b"); - @a = unpack '(SL)3 SL', pack '(SL)[4]', 67..74; - is("@a", "@b"); - @a = unpack '(SL)3 SL', pack '(SL)*', 67..74; - is("@a", "@b"); -} - -{ # more on grouping (W.Laun) - # @ absolute within ()-group - my $badc = pack( '(a)*', unpack( '(@1a @0a @2)*', 'abcd' ) ); - is( $badc, 'badc' ); - my @b = ( 1, 2, 3 ); - my $buf = pack( '(@1c)((@2C)@3c)', @b ); - is( $buf, "\0\1\0\0\2\3" ); - my @a = unpack( '(@1c)((@2c)@3c)', $buf ); - is( "@a", "@b" ); - - # various unpack count/code scenarios - my @Env = ( a => 'AAA', b => 'BBB' ); - my $env = pack( 'S(S/A*S/A*)*', @Env/2, @Env ); - - # unpack full length - ok - my @pup = unpack( 'S/(S/A* S/A*)', $env ); - is( "@pup", "@Env" ); - - # warn when count/code goes beyond end of string - # \0002 \0001 a \0003 AAA \0001 b \0003 BBB - # 2 4 5 7 10 1213 - eval { @pup = unpack( 'S/(S/A* S/A*)', substr( $env, 0, 13 ) ) }; - like( $@, qr{length/code after end of string} ); - - # postfix repeat count - $env = pack( '(S/A* S/A*)' . @Env/2, @Env ); - - # warn when count/code goes beyond end of string - # \0001 a \0003 AAA \0001 b \0003 BBB - # 2 3c 5 8 10 11 13 16 - eval { @pup = unpack( '(S/A* S/A*)' . @Env/2, substr( $env, 0, 11 ) ) }; - like( $@, qr{length/code after end of string} ); - - # catch stack overflow/segfault - eval { $_ = pack( ('(' x 105) . 'A' . (')' x 105) ); }; - like( $@, qr{Too deeply nested \(\)-groups} ); -} - -{ # syntax checks (W.Laun) - use warnings qw(NONFATAL all); - my @warning; - local $SIG{__WARN__} = sub { - push( @warning, $_[0] ); - }; - eval { my $s = pack( 'Ax![4c]A', 1..5 ); }; - like( $@, qr{Malformed integer in \[\]} ); - - eval { my $buf = pack( '(c/*a*)', 'AAA', 'BB' ); }; - like( $@, qr{'/' does not take a repeat count} ); - - eval { my @inf = unpack( 'c/1a', "\x03AAA\x02BB" ); }; - like( $@, qr{'/' does not take a repeat count} ); - - eval { my @inf = unpack( 'c/*a', "\x03AAA\x02BB" ); }; - like( $@, qr{'/' does not take a repeat count} ); - - # white space where possible - my @Env = ( a => 'AAA', b => 'BBB' ); - my $env = pack( ' S ( S / A* S / A* )* ', @Env/2, @Env ); - my @pup = unpack( ' S / ( S / A* S / A* ) ', $env ); - is( "@pup", "@Env" ); - - # white space in 4 wrong places - for my $temp ( 'A ![4]', 'A [4]', 'A *', 'A 4' ){ - eval { my $s = pack( $temp, 'B' ); }; - like( $@, qr{Invalid type } ); - } - - # warning for commas - @warning = (); - my $x = pack( 'I,A', 4, 'X' ); - like( $warning[0], qr{Invalid type ','} ); - - # comma warning only once - @warning = (); - $x = pack( 'C(C,C)C,C', 65..71 ); - like( scalar @warning, 1 ); - - # forbidden code in [] - eval { my $x = pack( 'A[@4]', 'XXXX' ); }; - like( $@, qr{Within \[\]-length '\@' not allowed} ); - - # @ repeat default 1 - my $s = pack( 'AA@A', 'A', 'B', 'C' ); - my @c = unpack( 'AA@A', $s ); - is( $s, 'AC' ); - is( "@c", "A C C" ); - - # no unpack code after / - eval { my @a = unpack( "C/", "\3" ); }; - like( $@, qr{Code missing after '/'} ); - - SKIP: { - skip $no_endianness, 6 if $no_endianness; - - # modifier warnings - @warning = (); - $x = pack "I>>s!!", 47, 11; - ($x) = unpack "I<!>", 'x'x20; - is(scalar @warning, 5); - like($warning[0], qr/Duplicate modifier '>' after 'I' in pack/); - like($warning[1], qr/Duplicate modifier '!' after 's' in pack/); - like($warning[2], qr/Duplicate modifier '<' after 'I' in unpack/); - like($warning[3], qr/Duplicate modifier '!' after 'l' in unpack/); - like($warning[4], qr/Duplicate modifier '>' after 'l' in unpack/); - } -} - -{ # Repeat count [SUBEXPR] - my @codes = qw( x A Z a c C W B b H h s v n S i I l V N L p P f F d - s! S! i! I! l! L! j J); - my $G; - if (eval { pack 'q', 1 } ) { - push @codes, qw(q Q); - } else { - push @codes, qw(s S); # Keep the count the same - } - if (eval { pack 'D', 1 } ) { - push @codes, 'D'; - } else { - push @codes, 'd'; # Keep the count the same - } - - push @codes, map { /^[silqjfdp]/i ? ("$_<", "$_>") : () } @codes; - - my %val; - @val{@codes} = map { / [Xx] (?{ undef }) - | [AZa] (?{ 'something' }) - | C (?{ 214 }) - | W (?{ 8188 }) - | c (?{ 114 }) - | [Bb] (?{ '101' }) - | [Hh] (?{ 'b8' }) - | [svnSiIlVNLqQjJ] (?{ 10111 }) - | [FfDd] (?{ 1.36514538e67 }) - | [pP] (?{ "try this buffer" }) - /x; $^R } @codes; - my @end = (0x12345678, 0x23456781, 0x35465768, 0x15263748); - my $end = "N4"; - - for my $type (@codes) { - my @list = $val{$type}; - @list = () unless defined $list[0]; - for my $count ('', '3', '[11]') { - my $c = 1; - $c = $1 if $count =~ /(\d+)/; - my @list1 = @list; - @list1 = (@list1) x $c unless $type =~ /[XxAaZBbHhP]/; - for my $groupend ('', ')2', ')[8]') { - my $groupbegin = ($groupend ? '(' : ''); - $c = 1; - $c = $1 if $groupend =~ /(\d+)/; - my @list2 = (@list1) x $c; - - SKIP: { - my $junk1 = "$groupbegin $type$count $groupend"; - # print "# junk1=$junk1\n"; - my $p = eval { pack $junk1, @list2 }; - skip "cannot pack '$type' on this perl", 12 - if is_valid_error($@); - die "pack $junk1 failed: $@" if $@; - - my $half = int( (length $p)/2 ); - for my $move ('', "X$half", "X!$half", 'x1', 'x!8', "x$half") { - my $junk = "$junk1 $move"; - # print "# junk='$junk', list=(@list2)\n"; - $p = pack "$junk $end", @list2, @end; - my @l = unpack "x[$junk] $end", $p; - is(scalar @l, scalar @end); - is("@l", "@end", "skipping x[$junk]"); - } - } - } - } - } -} - -# / is recognized after spaces in scalar context -# XXXX no spaces are allowed in pack... In pack only before the slash... -is(scalar unpack('A /A Z20', pack 'A/A* Z20', 'bcde', 'xxxxx'), 'bcde'); -is(scalar unpack('A /A /A Z20', '3004bcde'), 'bcde'); - -{ # X! and x! - my $t = 'C[3] x!8 C[2]'; - my @a = (0x73..0x77); - my $p = pack($t, @a); - is($p, "\x73\x74\x75\0\0\0\0\0\x76\x77"); - my @b = unpack $t, $p; - is(scalar @b, scalar @a); - is("@b", "@a", 'x!8'); - $t = 'x[5] C[6] X!8 C[2]'; - @a = (0x73..0x7a); - $p = pack($t, @a); - is($p, "\0\0\0\0\0\x73\x74\x75\x79\x7a"); - @b = unpack $t, $p; - @a = (0x73..0x75, 0x79, 0x7a, 0x79, 0x7a); - is(scalar @b, scalar @a); - is("@b", "@a"); -} - -{ # struct {char c1; double d; char cc[2];} - my $t = 'C x![d] d C[2]'; - my @a = (173, 1.283476517e-45, 42, 215); - my $p = pack $t, @a; - ok( length $p); - my @b = unpack "$t X[$t] $t", $p; # Extract, step back, extract again - is(scalar @b, 2 * scalar @a); - $b = "@b"; - $b =~ s/(?:17000+|16999+)\d+(e-45) /17$1 /gi; # stringification is gamble - is($b, "@a @a"); - - use warnings qw(NONFATAL all); - my $warning; - local $SIG{__WARN__} = sub { - $warning = $_[0]; - }; - @b = unpack "x[C] x[$t] X[$t] X[C] $t", "$p\0"; - - is($warning, undef); - is(scalar @b, scalar @a); - $b = "@b"; - $b =~ s/(?:17000+|16999+)\d+(e-45) /17$1 /gi; # stringification is gamble - is($b, "@a"); -} - -is(length(pack("j", 0)), $Config{ivsize}); -is(length(pack("J", 0)), $Config{uvsize}); -is(length(pack("F", 0)), $Config{nvsize}); - -numbers ('j', -2147483648, -1, 0, 1, 2147483647); -numbers ('J', 0, 1, 2147483647, 2147483648, 4294967295); -numbers ('F', -(2**34), -1, 0, 1, 2**34); -SKIP: { - my $t = eval { unpack("D*", pack("D", 12.34)) }; - - skip "Long doubles not in use", 166 if $@ =~ /Invalid type/; - - is(length(pack("D", 0)), $Config{longdblsize}); - numbers ('D', -(2**34), -1, 0, 1, 2**34); -} - -# Maybe this knowledge needs to be "global" for all of pack.t -# Or a "can checksum" which would effectively be all the number types" -my %cant_checksum = map {$_=> 1} qw(A Z u w); -# not a b B h H -foreach my $template (qw(A Z c C s S i I l L n N v V q Q j J f d F D u U w)) { - SKIP: { - my $packed = eval {pack "${template}4", 1, 4, 9, 16}; - if ($@) { - die unless $@ =~ /Invalid type '$template'/; - skip ("$template not supported on this perl", - $cant_checksum{$template} ? 4 : 8); - } - my @unpack4 = unpack "${template}4", $packed; - my @unpack = unpack "${template}*", $packed; - my @unpack1 = unpack "${template}", $packed; - my @unpack1s = scalar unpack "${template}", $packed; - my @unpack4s = scalar unpack "${template}4", $packed; - my @unpacks = scalar unpack "${template}*", $packed; - - my @tests = ( ["${template}4 vs ${template}*", \@unpack4, \@unpack], - ["scalar ${template} ${template}", \@unpack1s, \@unpack1], - ["scalar ${template}4 vs ${template}", \@unpack4s, \@unpack1], - ["scalar ${template}* vs ${template}", \@unpacks, \@unpack1], - ); - - unless ($cant_checksum{$template}) { - my @unpack4_c = unpack "\%${template}4", $packed; - my @unpack_c = unpack "\%${template}*", $packed; - my @unpack1_c = unpack "\%${template}", $packed; - my @unpack1s_c = scalar unpack "\%${template}", $packed; - my @unpack4s_c = scalar unpack "\%${template}4", $packed; - my @unpacks_c = scalar unpack "\%${template}*", $packed; - - push @tests, - ( ["% ${template}4 vs ${template}*", \@unpack4_c, \@unpack_c], - ["% scalar ${template} ${template}", \@unpack1s_c, \@unpack1_c], - ["% scalar ${template}4 vs ${template}*", \@unpack4s_c, \@unpack_c], - ["% scalar ${template}* vs ${template}*", \@unpacks_c, \@unpack_c], - ); - } - foreach my $test (@tests) { - ok (list_eq ($test->[1], $test->[2]), $test->[0]) || - printf "# unpack gave %s expected %s\n", - encode_list (@{$test->[1]}), encode_list (@{$test->[2]}); - } - } -} - -ok(pack('u2', 'AA'), "[perl #8026]"); # used to hang and eat RAM in perl 5.7.2 - -$_ = pack('c', 65); # 'A' would not be EBCDIC-friendly -is(unpack('c'), 65, "one-arg unpack (change #18751)"); # defaulting to $_ - -{ - my $a = "X\x0901234567\n" x 100; # \t would not be EBCDIC TAB - my @a = unpack("(a1 c/a)*", $a); - is(scalar @a, 200, "[perl #15288]"); - is($a[-1], "01234567\n", "[perl #15288]"); - is($a[-2], "X", "[perl #15288]"); -} - -{ - use warnings qw(NONFATAL all); - my $warning; - local $SIG{__WARN__} = sub { - $warning = $_[0]; - }; - my $out = pack("u99", "foo" x 99); - like($warning, qr/Field too wide in 'u' format in pack at /, - "Warn about too wide uuencode"); - is($out, ("_" . "9F]O" x 21 . "\n") x 4 . "M" . "9F]O" x 15 . "\n", - "Use max width in case of too wide uuencode"); -} - -# checksums -{ - # verify that unpack advances correctly wrt a checksum - my (@x) = unpack("b10a", "abcd"); - my (@y) = unpack("%b10a", "abcd"); - is($x[1], $y[1], "checksum advance ok"); - - # verify that the checksum is not overflowed with C0 - if (ord('A') == 193) { - is(unpack("C0%128U", "/bcd"), unpack("U0%128U", "abcd"), "checksum not overflowed"); - } else { - is(unpack("C0%128U", "abcd"), unpack("U0%128U", "abcd"), "checksum not overflowed"); - } -} - -{ - # U0 and C0 must be scoped - my (@x) = unpack("a(U0)U", "b\341\277\274"); - is($x[0], 'b', 'before scope'); - is($x[1], 8188, 'after scope'); - - is(pack("a(U0)U", "b", 8188), "b\341\277\274"); -} - -{ - # counted length prefixes shouldn't change C0/U0 mode - # (note the length is actually 0 in this test) - if (ord('A') == 193) { - is(join(',', unpack("aU0C/UU", "b\0\341\277\274")), 'b,0'); - is(join(',', unpack("aU0C/CU", "b\0\341\277\274")), 'b,0'); - } else { - is(join(',', unpack("aC/UU", "b\0\341\277\274")), 'b,8188'); - is(join(',', unpack("aC/CU", "b\0\341\277\274")), 'b,8188'); - is(join(',', unpack("aU0C/UU", "b\0\341\277\274")), 'b,225'); - is(join(',', unpack("aU0C/CU", "b\0\341\277\274")), 'b,225'); - } -} - -{ - # "Z0" (bug #34062) - my (@x) = unpack("C*", pack("CZ0", 1, "b")); - is(join(',', @x), '1', 'pack Z0 doesn\'t destroy the character before'); -} - -{ - # Encoding neutrality - # String we will pull apart and rebuild in several ways: - my $down = "\xf8\xf9\xfa\xfb\xfc\xfd\xfe\xff\x05\x06"; - my $up = $down; - utf8::upgrade($up); - - my %expect = - # [expected result, - # how many chars it should progress, - # (optional) expected result of pack] - (a5 => ["\xf8\xf9\xfa\xfb\xfc", 5], - A5 => ["\xf8\xf9\xfa\xfb\xfc", 5], - Z5 => ["\xf8\xf9\xfa\xfb\xfc", 5, "\xf8\xf9\xfa\xfb\x00\xfd"], - b21 => ["000111111001111101011", 3, "\xf8\xf9\x1a\xfb"], - B21 => ["111110001111100111111", 3, "\xf8\xf9\xf8\xfb"], - H5 => ["f8f9f", 3, "\xf8\xf9\xf0\xfb"], - h5 => ["8f9fa", 3, "\xf8\xf9\x0a\xfb"], - "s<" => [-1544, 2], - "s>" => [-1799, 2], - "S<" => [0xf9f8, 2], - "S>" => [0xf8f9, 2], - "l<" => [-67438088, 4], - "l>" => [-117835013, 4], - "L>" => [0xf8f9fafb, 4], - "L<" => [0xfbfaf9f8, 4], - n => [0xf8f9, 2], - N => [0xf8f9fafb, 4], - v => [63992, 2], - V => [0xfbfaf9f8, 4], - c => [-8, 1], - U0U => [0xf8, 1], - w => ["8715569050387726213", 9], - q => ["-283686952306184", 8], - Q => ["18446460386757245432", 8], - ); - - for my $string ($down, $up) { - for my $format (sort {lc($a) cmp lc($b) || $a cmp $b } keys %expect) { - SKIP: { - my $expect = $expect{$format}; - # unpack upgraded and downgraded string - my @result = eval { unpack("$format C0 W", $string) }; - skip "cannot pack/unpack '$format C0 W' on this perl", 5 if - $@ && is_valid_error($@); - is(@result, 2, "Two results from unpack $format C0 W"); - - # pack to downgraded - my $new = pack("$format C0 W", @result); - is(length($new), $expect->[1]+1, - "pack $format C0 W should give $expect->[1]+1 chars"); - is($new, $expect->[2] || substr($string, 0, length $new), - "pack $format C0 W returns expected value"); - - # pack to upgraded - $new = pack("a0 $format C0 W", chr(256), @result); - is(length($new), $expect->[1]+1, - "pack a0 $format C0 W should give $expect->[1]+1 chars"); - is($new, $expect->[2] || substr($string, 0, length $new), - "pack a0 $format C0 W returns expected value"); - } - } - } -} - -{ - # Encoding neutrality, numbers - my $val = -2.68; - for my $format (qw(s S i I l L j J f d F D q Q - s! S! i! I! l! L! n! N! v! V!)) { - SKIP: { - my $down = eval { pack($format, $val) }; - skip "cannot pack/unpack $format on this perl", 9 if - $@ && is_valid_error($@); - ok(!utf8::is_utf8($down), "Simple $format pack doesn't get upgraded"); - my $up = pack("a0 $format", chr(256), $val); - ok(utf8::is_utf8($up), "a0 $format with high char leads to upgrade"); - is($down, $up, "$format generated strings are equal though"); - my @down_expanded = unpack("$format W", $down . chr(0xce)); - is(@down_expanded, 2, "Expand to two values"); - is($down_expanded[1], 0xce, - "unpack $format left us at the expected position"); - my @up_expanded = unpack("$format W", $up . chr(0xce)); - is(@up_expanded, 2, "Expand to two values"); - is($up_expanded[1], 0xce, - "unpack $format left us at the expected position"); - is($down_expanded[0], $up_expanded[0], "$format unpack was neutral"); - is(pack($format, $down_expanded[0]), $down, "Pack $format undoes unpack $format"); - } - } -} - -{ - # C *is* neutral - my $down = "\xf8\xf9\xfa\xfb\xfc\xfd\xfe\xff\x05\x06"; - my $up = $down; - utf8::upgrade($up); - my @down = unpack("C*", $down); - my @expect_down = (0xf8, 0xf9, 0xfa, 0xfb, 0xfc, 0xfd, 0xfe, 0xff, 0x05, 0x06); - is("@down", "@expect_down", "byte expand"); - is(pack("C*", @down), $down, "byte join"); - - my @up = unpack("C*", $up); - my @expect_up = (0xf8, 0xf9, 0xfa, 0xfb, 0xfc, 0xfd, 0xfe, 0xff, 0x05, 0x06); - is("@up", "@expect_up", "UTF-8 expand"); - is(pack("U0C0C*", @up), $up, "UTF-8 join"); -} - -{ - # Harder cases for the neutrality test - - # u format - my $down = "\xf8\xf9\xfa\xfb\xfc\xfd\xfe\xff\x05\x06"; - my $up = $down; - utf8::upgrade($up); - is(pack("u", $down), pack("u", $up), "u pack is neutral"); - is(unpack("u", pack("u", $down)), $down, "u unpack to downgraded works"); - is(unpack("U0C0u", pack("u", $down)), $up, "u unpack to upgraded works"); - - # p/P format - # This actually only tests something if the address contains a byte >= 0x80 - my $str = "abc\xa5\x00\xfede"; - $down = pack("p", $str); - is(pack("P", $str), $down); - is(pack("U0C0p", $str), $down); - is(pack("U0C0P", $str), $down); - is(unpack("p", $down), "abc\xa5", "unpack p downgraded"); - $up = $down; - utf8::upgrade($up); - is(unpack("p", $up), "abc\xa5", "unpack p upgraded"); - - is(unpack("P7", $down), "abc\xa5\x00\xfed", "unpack P downgraded"); - is(unpack("P7", $up), "abc\xa5\x00\xfed", "unpack P upgraded"); - - # x, X and @ - $down = "\xf8\xf9\xfa\xfb\xfc\xfd\xfe\xff\x05\x06"; - $up = $down; - utf8::upgrade($up); - - is(unpack('@4W', $down), 0xfc, "\@positioning on downgraded string"); - is(unpack('@4W', $up), 0xfc, "\@positioning on upgraded string"); - - is(unpack('@4x2W', $down), 0xfe, "x moving on downgraded string"); - is(unpack('@4x2W', $up), 0xfe, "x moving on upgraded string"); - is(unpack('@4x!4W', $down), 0xfc, "x! moving on downgraded string"); - is(unpack('@4x!4W', $up), 0xfc, "x! moving on upgraded string"); - is(unpack('@5x!4W', $down), 0x05, "x! moving on downgraded string"); - is(unpack('@5x!4W', $up), 0x05, "x! moving on upgraded string"); - - is(unpack('@4X2W', $down), 0xfa, "X moving on downgraded string"); - is(unpack('@4X2W', $up), 0xfa, "X moving on upgraded string"); - is(unpack('@4X!4W', $down), 0xfc, "X! moving on downgraded string"); - is(unpack('@4X!4W', $up), 0xfc, "X! moving on upgraded string"); - is(unpack('@5X!4W', $down), 0xfc, "X! moving on downgraded string"); - is(unpack('@5X!4W', $up), 0xfc, "X! moving on upgraded string"); - is(unpack('@5X!8W', $down), 0xf8, "X! moving on downgraded string"); - is(unpack('@5X!8W', $up), 0xf8, "X! moving on upgraded string"); - - is(pack("W2x", 0xfa, 0xe3), "\xfa\xe3\x00", "x on downgraded string"); - is(pack("W2x!4", 0xfa, 0xe3), "\xfa\xe3\x00\x00", - "x! on downgraded string"); - is(pack("W2x!2", 0xfa, 0xe3), "\xfa\xe3", "x! on downgraded string"); - is(pack("U0C0W2x", 0xfa, 0xe3), "\xfa\xe3\x00", "x on upgraded string"); - is(pack("U0C0W2x!4", 0xfa, 0xe3), "\xfa\xe3\x00\x00", - "x! on upgraded string"); - is(pack("U0C0W2x!2", 0xfa, 0xe3), "\xfa\xe3", "x! on upgraded string"); - is(pack("W2X", 0xfa, 0xe3), "\xfa", "X on downgraded string"); - is(pack("U0C0W2X", 0xfa, 0xe3), "\xfa", "X on upgraded string"); - is(pack("W2X!2", 0xfa, 0xe3), "\xfa\xe3", "X! on downgraded string"); - is(pack("U0C0W2X!2", 0xfa, 0xe3), "\xfa\xe3", "X! on upgraded string"); - is(pack("W3X!2", 0xfa, 0xe3, 0xa6), "\xfa\xe3", "X! on downgraded string"); - is(pack("U0C0W3X!2", 0xfa, 0xe3, 0xa6), "\xfa\xe3", - "X! on upgraded string"); - - # backward eating through a ( moves the group starting point backwards - is(pack("a*(Xa)", "abc", "q"), "abq", - "eating before strbeg moves it back"); - is(pack("a*(Xa)", "ab" . chr(512), "q"), "abq", - "eating before strbeg moves it back"); - - # Check marked_upgrade - is(pack('W(W(Wa@3W)@6W)@9W', 0xa1, 0xa2, 0xa3, "a", 0xa4, 0xa5, 0xa6), - "\xa1\xa2\xa3a\x00\xa4\x00\xa5\x00\xa6"); - $up = "a"; - utf8::upgrade($up); - is(pack('W(W(Wa@3W)@6W)@9W', 0xa1, 0xa2, 0xa3, $up, 0xa4, 0xa5, 0xa6), - "\xa1\xa2\xa3a\x00\xa4\x00\xa5\x00\xa6", "marked upgrade caused by a"); - is(pack('W(W(WW@3W)@6W)@9W', 0xa1, 0xa2, 0xa3, 256, 0xa4, 0xa5, 0xa6), - "\xa1\xa2\xa3\x{100}\x00\xa4\x00\xa5\x00\xa6", - "marked upgrade caused by W"); - is(pack('W(W(WU0aC0@3W)@6W)@9W', 0xa1, 0xa2, 0xa3, "a", 0xa4, 0xa5, 0xa6), - "\xa1\xa2\xa3a\x00\xa4\x00\xa5\x00\xa6", "marked upgrade caused by U0"); - - # a, A and Z - $down = "\xa4\xa6\xa7"; - $up = $down; - utf8::upgrade($up); - utf8::upgrade(my $high = "\xfeb"); - - for my $format ("a0", "A0", "Z0", "U0a0C0", "U0A0C0", "U0Z0C0") { - is(pack("a* $format a*", "ab", $down, "cd"), "abcd", - "$format format on plain string"); - is(pack("a* $format a*", "ab", $up, "cd"), "abcd", - "$format format on upgraded string"); - is(pack("a* $format a*", $high, $down, "cd"), "\xfebcd", - "$format format on plain string"); - is(pack("a* $format a*", $high, $up, "cd"), "\xfebcd", - "$format format on upgraded string"); - my @down = unpack("a1 $format a*", "\xfeb"); - is("@down", "\xfe b", "unpack $format"); - my @up = unpack("a1 $format a*", $high); - is("@up", "\xfe b", "unpack $format"); - } - is(pack("a1", $high), "\xfe"); - is(pack("A1", $high), "\xfe"); - is(pack("Z1", $high), "\x00"); - is(pack("a2", $high), "\xfeb"); - is(pack("A2", $high), "\xfeb"); - is(pack("Z2", $high), "\xfe\x00"); - is(pack("a5", $high), "\xfeb\x00\x00\x00"); - is(pack("A5", $high), "\xfeb "); - is(pack("Z5", $high), "\xfeb\x00\x00\x00"); - is(pack("a*", $high), "\xfeb"); - is(pack("A*", $high), "\xfeb"); - is(pack("Z*", $high), "\xfeb\x00"); - - utf8::upgrade($high = "\xc3\xbeb"); - is(pack("U0a2", $high), "\xfe"); - is(pack("U0A2", $high), "\xfe"); - is(pack("U0Z1", $high), "\x00"); - is(pack("U0a3", $high), "\xfeb"); - is(pack("U0A3", $high), "\xfeb"); - is(pack("U0Z3", $high), "\xfe\x00"); - is(pack("U0a6", $high), "\xfeb\x00\x00\x00"); - is(pack("U0A6", $high), "\xfeb "); - is(pack("U0Z6", $high), "\xfeb\x00\x00\x00"); - is(pack("U0a*", $high), "\xfeb"); - is(pack("U0A*", $high), "\xfeb"); - is(pack("U0Z*", $high), "\xfeb\x00"); -} -{ - # pack / - my @array = 1..14; - my @out = unpack("N/S", pack("N/S", @array) . "abcd"); - is("@out", "@array", "pack N/S works"); - @out = unpack("N/S*", pack("N/S*", @array) . "abcd"); - is("@out", "@array", "pack N/S* works"); - @out = unpack("N/S*", pack("N/S14", @array) . "abcd"); - is("@out", "@array", "pack N/S14 works"); - @out = unpack("N/S*", pack("N/S15", @array) . "abcd"); - is("@out", "@array", "pack N/S15 works"); - @out = unpack("N/S*", pack("N/S13", @array) . "abcd"); - is("@out", "@array[0..12]", "pack N/S13 works"); - @out = unpack("N/S*", pack("N/S0", @array) . "abcd"); - is("@out", "", "pack N/S0 works"); - is(pack("Z*/a0", "abc"), "0\0", "pack Z*/a0 makes a short string"); - is(pack("Z*/Z0", "abc"), "0\0", "pack Z*/Z0 makes a short string"); - is(pack("Z*/a3", "abc"), "3\0abc", "pack Z*/a3 makes a full string"); - is(pack("Z*/Z3", "abc"), "3\0ab\0", "pack Z*/Z3 makes a short string"); - is(pack("Z*/a5", "abc"), "5\0abc\0\0", "pack Z*/a5 makes a long string"); - is(pack("Z*/Z5", "abc"), "5\0abc\0\0", "pack Z*/Z5 makes a long string"); - is(pack("Z*/Z"), "1\0\0", "pack Z*/Z makes an extended string"); - is(pack("Z*/Z", ""), "1\0\0", "pack Z*/Z makes an extended string"); - is(pack("Z*/a", ""), "0\0", "pack Z*/a makes an extended string"); -} -{ - # unpack("A*", $unicode) strips general unicode spaces - is(unpack("A*", "ab \n\xa0 \0"), "ab \n\xa0", - 'normal A* strip leaves \xa0'); - is(unpack("U0C0A*", "ab \n\xa0 \0"), "ab \n\xa0", - 'normal A* strip leaves \xa0 even if it got upgraded for technical reasons'); - is(unpack("A*", pack("a*(U0U)a*", "ab \n", 0xa0, " \0")), "ab", - 'upgraded strings A* removes \xa0'); - is(unpack("A*", pack("a*(U0UU)a*", "ab \n", 0xa0, 0x1680, " \0")), "ab", - 'upgraded strings A* removes all unicode whitespace'); - is(unpack("A5", pack("a*(U0U)a*", "ab \n", 0x1680, "def", "ab")), "ab", - 'upgraded strings A5 removes all unicode whitespace'); - is(unpack("A*", pack("U", 0x1680)), "", - 'upgraded strings A* with nothing left'); -} -{ - # Testing unpack . and .! - is(unpack(".", "ABCD"), 0, "offset at start of string is 0"); - is(unpack(".", ""), 0, "offset at start of empty string is 0"); - is(unpack("x3.", "ABCDEF"), 3, "simple offset works"); - is(unpack("x3.", "ABC"), 3, "simple offset at end of string works"); - is(unpack("x3.0", "ABC"), 0, "self offset is 0"); - is(unpack("x3(x2.)", "ABCDEF"), 2, "offset is relative to inner group"); - is(unpack("x3(X2.)", "ABCDEF"), -2, - "negative offset relative to inner group"); - is(unpack("x3(X2.2)", "ABCDEF"), 1, "offset is relative to inner group"); - is(unpack("x3(x2.0)", "ABCDEF"), 0, "self offset in group is still 0"); - is(unpack("x3(x2.2)", "ABCDEF"), 5, "offset counts groups"); - is(unpack("x3(x2.*)", "ABCDEF"), 5, "star offset is relative to start"); - - my $high = chr(8188) x 6; - is(unpack("x3(x2.)", $high), 2, "utf8 offset is relative to inner group"); - is(unpack("x3(X2.)", $high), -2, - "utf8 negative offset relative to inner group"); - is(unpack("x3(X2.2)", $high), 1, "utf8 offset counts groups"); - is(unpack("x3(x2.0)", $high), 0, "utf8 self offset in group is still 0"); - is(unpack("x3(x2.2)", $high), 5, "utf8 offset counts groups"); - is(unpack("x3(x2.*)", $high), 5, "utf8 star offset is relative to start"); - - is(unpack("U0x3(x2.)", $high), 2, - "U0 mode utf8 offset is relative to inner group"); - is(unpack("U0x3(X2.)", $high), -2, - "U0 mode utf8 negative offset relative to inner group"); - is(unpack("U0x3(X2.2)", $high), 1, - "U0 mode utf8 offset counts groups"); - is(unpack("U0x3(x2.0)", $high), 0, - "U0 mode utf8 self offset in group is still 0"); - is(unpack("U0x3(x2.2)", $high), 5, - "U0 mode utf8 offset counts groups"); - is(unpack("U0x3(x2.*)", $high), 5, - "U0 mode utf8 star offset is relative to start"); - - is(unpack("x3(x2.!)", $high), 2*3, - "utf8 offset is relative to inner group"); - is(unpack("x3(X2.!)", $high), -2*3, - "utf8 negative offset relative to inner group"); - is(unpack("x3(X2.!2)", $high), 1*3, - "utf8 offset counts groups"); - is(unpack("x3(x2.!0)", $high), 0, - "utf8 self offset in group is still 0"); - is(unpack("x3(x2.!2)", $high), 5*3, - "utf8 offset counts groups"); - is(unpack("x3(x2.!*)", $high), 5*3, - "utf8 star offset is relative to start"); - - is(unpack("U0x3(x2.!)", $high), 2, - "U0 mode utf8 offset is relative to inner group"); - is(unpack("U0x3(X2.!)", $high), -2, - "U0 mode utf8 negative offset relative to inner group"); - is(unpack("U0x3(X2.!2)", $high), 1, - "U0 mode utf8 offset counts groups"); - is(unpack("U0x3(x2.!0)", $high), 0, - "U0 mode utf8 self offset in group is still 0"); - is(unpack("U0x3(x2.!2)", $high), 5, - "U0 mode utf8 offset counts groups"); - is(unpack("U0x3(x2.!*)", $high), 5, - "U0 mode utf8 star offset is relative to start"); -} -{ - # Testing pack . and .! - is(pack("(a)5 .", 1..5, 3), "123", ". relative to string start, shorten"); - eval { () = pack("(a)5 .", 1..5, -3) }; - like($@, qr{'\.' outside of string in pack}, "Proper error message"); - is(pack("(a)5 .", 1..5, 8), "12345\x00\x00\x00", - ". relative to string start, extend"); - is(pack("(a)5 .", 1..5, 5), "12345", ". relative to string start, keep"); - - is(pack("(a)5 .0", 1..5, -3), "12", - ". relative to string current, shorten"); - is(pack("(a)5 .0", 1..5, 2), "12345\x00\x00", - ". relative to string current, extend"); - is(pack("(a)5 .0", 1..5, 0), "12345", - ". relative to string current, keep"); - - is(pack("(a)5 (.)", 1..5, -3), "12", - ". relative to group, shorten"); - is(pack("(a)5 (.)", 1..5, 2), "12345\x00\x00", - ". relative to group, extend"); - is(pack("(a)5 (.)", 1..5, 0), "12345", - ". relative to group, keep"); - - is(pack("(a)3 ((a)2 .)", 1..5, -2), "1", - ". relative to group, shorten"); - is(pack("(a)3 ((a)2 .)", 1..5, 2), "12345", - ". relative to group, keep"); - is(pack("(a)3 ((a)2 .)", 1..5, 4), "12345\x00\x00", - ". relative to group, extend"); - - is(pack("(a)3 ((a)2 .2)", 1..5, 2), "12", - ". relative to counted group, shorten"); - is(pack("(a)3 ((a)2 .2)", 1..5, 7), "12345\x00\x00", - ". relative to counted group, extend"); - is(pack("(a)3 ((a)2 .2)", 1..5, 5), "12345", - ". relative to counted group, keep"); - - is(pack("(a)3 ((a)2 .*)", 1..5, 2), "12", - ". relative to start, shorten"); - is(pack("(a)3 ((a)2 .*)", 1..5, 7), "12345\x00\x00", - ". relative to start, extend"); - is(pack("(a)3 ((a)2 .*)", 1..5, 5), "12345", - ". relative to start, keep"); - - is(pack('(a)5 (. @2 a)', 1..5, -3, "a"), "12\x00\x00a", - ". based shrink properly updates group starts"); - - is(pack("(W)3 ((W)2 .)", 0x301..0x305, -2), "\x{301}", - "utf8 . relative to group, shorten"); - is(pack("(W)3 ((W)2 .)", 0x301..0x305, 2), - "\x{301}\x{302}\x{303}\x{304}\x{305}", - "utf8 . relative to group, keep"); - is(pack("(W)3 ((W)2 .)", 0x301..0x305, 4), - "\x{301}\x{302}\x{303}\x{304}\x{305}\x00\x00", - "utf8 . relative to group, extend"); - - is(pack("(W)3 ((W)2 .!)", 0x301..0x305, -2), "\x{301}\x{302}", - "utf8 . relative to group, shorten"); - is(pack("(W)3 ((W)2 .!)", 0x301..0x305, 4), - "\x{301}\x{302}\x{303}\x{304}\x{305}", - "utf8 . relative to group, keep"); - is(pack("(W)3 ((W)2 .!)", 0x301..0x305, 6), - "\x{301}\x{302}\x{303}\x{304}\x{305}\x00\x00", - "utf8 . relative to group, extend"); - - is(pack('(W)5 (. @2 a)', 0x301..0x305, -3, "a"), - "\x{301}\x{302}\x00\x00a", - "utf8 . based shrink properly updates group starts"); -} -{ - # Testing @! - is(pack('a* @3', "abcde"), "abc", 'Test basic @'); - is(pack('a* @!3', "abcde"), "abc", 'Test basic @!'); - is(pack('a* @2', "\x{301}\x{302}\x{303}\x{304}\x{305}"), "\x{301}\x{302}", - 'Test basic utf8 @'); - is(pack('a* @!2', "\x{301}\x{302}\x{303}\x{304}\x{305}"), "\x{301}", - 'Test basic utf8 @!'); - - is(unpack('@4 a*', "abcde"), "e", 'Test basic @'); - is(unpack('@!4 a*', "abcde"), "e", 'Test basic @!'); - is(unpack('@4 a*', "\x{301}\x{302}\x{303}\x{304}\x{305}"), "\x{305}", - 'Test basic utf8 @'); - is(unpack('@!4 a*', "\x{301}\x{302}\x{303}\x{304}\x{305}"), - "\x{303}\x{304}\x{305}", 'Test basic utf8 @!'); -} -{ - #50256 - my ($v) = split //, unpack ('(B)*', 'ab'); - is($v, 0); # Doesn't SEGV :-) -} -{ - #73814 - my $x = runperl( prog => 'print split( /,/, unpack(q(%2H*), q(hello world))), qq(\n)' ); - is($x, "0\n", "split /a/, unpack('%2H*'...) didn't crash"); - - my $y = runperl( prog => 'print split( /,/, unpack(q(%32u*), q(#,3,Q)), qq(\n)), qq(\n)' ); - is($y, "0\n", "split /a/, unpack('%32u*'...) didn't crash"); -} - -#90160 -is(eval { () = unpack "C0 U*", ""; "ok" }, "ok", - 'medial U* on empty string'); diff --git a/t/CORE/op/packagev.t b/t/CORE/op/packagev.t deleted file mode 100644 index 5c9f14d66..000000000 --- a/t/CORE/op/packagev.t +++ /dev/null @@ -1,189 +0,0 @@ -#!./perl - -BEGIN { - unshift @INC, 't/CORE/lib'; - require 't/CORE/test.pl'; -} - -# XXX remove this later -- dagolden, 2010-01-13 -# local *STDERR = *STDOUT; - -my @syntax_cases = ( - 'package Foo', - 'package Bar 1.23', - 'package Baz v1.2.3', -); - -my @version_cases = ; - -plan tests => 7 * @syntax_cases + 7 * (grep { $_ !~ /^#/ } @version_cases) - + 2 * 3; - -use warnings qw/syntax/; -# perlcc issue 177 - https://code.google.com/p/perl-compiler/issues/detail?id=177 -use version; - -for my $string ( @syntax_cases ) { - eval "$string"; - is( $@, '', qq/eval "$string"/ ); - eval "$string;"; - is( $@, '', qq/eval "$string;"/ ); - eval "$string ;"; - is( $@, '', qq/eval "$string ;"/ ); - eval "{$string}"; - is( $@, '', qq/eval "{$string}"/ ); - eval "{ $string }"; - is( $@, '', qq/eval "{ $string }"/ ); - eval "${string}{}"; - is( $@, '', qq/eval "${string}{}"/ ); - eval "$string {}"; - is( $@, '', qq/eval "$string {}"/ ); -} - -LINE: -for my $line (@version_cases) { - chomp $line; - # comments in data section are just diagnostics - if ($line =~ /^#/) { - diag $line; - next LINE; - } - - my ($v, $package, $quoted, $bare, $match) = split /\t+/, $line; - my $warning = ""; - local $SIG{__WARN__} = sub { $warning .= $_[0] . "\n" }; - $match = defined $match ? $match : ""; - $match =~ s/\s*\z//; # kill trailing spaces - - # First handle the 'package NAME VERSION' case - foreach my $suffix (";", "{}") { - $withversion::VERSION = undef; - if ($package eq 'fail') { - note "package withversion $v$suffix"; - eval "package withversion $v$suffix"; - like($@, qr/$match/, "package withversion $v$suffix -> syntax error ($match)"); - ok(! version::is_strict($v), qq{... and "$v" should also fail STRICT regex}); - } - else { - my $ok = eval "package withversion $v$suffix $v eq \$withversion::VERSION"; - ok($ok, "package withversion $v$suffix") - or diag( $@ ? $@ : "and \$VERSION = $withversion::VERSION"); - ok( version::is_strict($v), qq{... and "$v" should pass STRICT regex}); - } - } - - # Now check the version->new("V") case - my $ver = undef; - eval qq/\$ver = version->new("$v")/; - if ($quoted eq 'fail') { - like($@, qr/$match/, qq{version->new("$v") -> invalid format ($match)}) - or diag( $@ ? $@ : "and \$ver = $ver" ); - ok( ! version::is_lax($v), qq{... and "$v" should fail LAX regex}); - } - else { - is($@, "", qq{version->new("$v")}); - ok( version::is_lax($v), qq{... and "$v" should pass LAX regex}); - } - - # Now check the version->new(V) case, unless we're skipping it - if ( $bare eq 'na' ) { - pass( "... skipping version->new($v)" ); - next LINE; - } - $ver = undef; - eval qq/\$ver = version->new($v)/; - if ($bare eq 'fail') { - like($@, qr/$match/m, qq{... and unquoted version->new($v) has same error}) - or diag( $@ ? $@ : "and \$ver = $ver" ); - } - else { - is($@, "", qq{... and version->new($v) is ok}); - } -} - -# -# Tests for #72432 - which reports a syntax error if there's a newline -# between the package name and the version. -# -# Note that we are using 'run_perl' here - there's no problem if -# "package Foo\n1;" is evalled. -# -for my $v ("1", "1.23", "v1.2.3") { - ok (run_perl (prog => "package Foo\n$v; print 1;"), - "New line between package name and version"); - ok (run_perl (prog => "package Foo\n$v { print 1; }"), - "New line between package name and version"); -} - -# The data is organized in tab delimited format with these columns: -# -# value package version->new version->new regex -# quoted unquoted -# -# For each value, it is tested using eval in the following expressions -# -# package foo $value; # column 2 -# and -# my $ver = version->new("$value"); # column 3 -# and -# my $ver = version->new($value); # column 4 -# -# The second through fourth columns can contain 'pass' or 'fail'. -# -# For any column with 'pass', the tests makes sure that no warning/error -# was thrown. For any column with 'fail', the tests make sure that the -# error thrown matches the regex in the last column. The unquoted column -# may also have 'na' indicating that it's pointless to test as behavior -# is subject to the perl parser before a stringifiable value is available -# to version->new -# -# If all columns are marked 'pass', the regex column is left empty. -# -# there are multiple ways that underscores can fail depending on strict -# vs lax format so these test do not distinguish between them -# -# If the DATA line begins with a # mark, it is used as a diag comment -__DATA__ -1.00 pass pass pass -1.00001 pass pass pass -0.123 pass pass pass -12.345 pass pass pass -42 pass pass pass -0 pass pass pass -0.0 pass pass pass -v1.2.3 pass pass pass -v1.2.3.4 pass pass pass -v0.1.2 pass pass pass -v0.0.0 pass pass pass -01 fail pass pass no leading zeros -01.0203 fail pass pass no leading zeros -v01 fail pass pass no leading zeros -v01.02.03 fail pass pass no leading zeros -.1 fail pass pass 0 before decimal required -.1.2 fail pass pass 0 before decimal required -1. fail pass pass fractional part required -1.a fail fail na fractional part required -1._ fail fail na fractional part required -1.02_03 fail pass pass underscore -v1.2_3 fail pass pass underscore -v1.02_03 fail pass pass underscore -v1.2_3_4 fail fail fail underscore -v1.2_3.4 fail fail fail underscore -1.2_3.4 fail fail fail underscore -0_ fail fail na underscore -1_ fail fail na underscore -1_. fail fail na underscore -1.1_ fail fail na underscore -1.02_03_04 fail fail na underscore -1.2.3 fail pass pass dotted-decimal versions must begin with 'v' -v1.2 fail pass pass dotted-decimal versions require at least three parts -v0 fail pass pass dotted-decimal versions require at least three parts -v1 fail pass pass dotted-decimal versions require at least three parts -v.1.2.3 fail fail na dotted-decimal versions require at least three parts -v fail fail na dotted-decimal versions require at least three parts -v1.2345.6 fail pass pass maximum 3 digits between decimals -undef fail pass pass non-numeric data -1a fail fail na non-numeric data -1.2a3 fail fail na non-numeric data -bar fail fail na non-numeric data -_ fail fail na non-numeric data diff --git a/t/CORE/op/pos.t b/t/CORE/op/pos.t deleted file mode 100644 index 8fb0b1ba2..000000000 --- a/t/CORE/op/pos.t +++ /dev/null @@ -1,48 +0,0 @@ -#!./perl - -BEGIN { - unshift @INC, 't/CORE/lib'; - require 't/CORE/test.pl'; -} - -plan tests => 8; - -$x='banana'; -$x=~/.a/g; -is(pos($x), 2); - -$x=~/.z/gc; -is(pos($x), 2); - -sub f { my $p=$_[0]; return $p } - -$x=~/.a/g; -is(f(pos($x)), 4); - -# Is pos() set inside //g? (bug id 19990615.008) -$x = "test string?"; $x =~ s/\w/pos($x)/eg; -is($x, "0123 5678910?"); - -$x = "123 56"; $x =~ / /g; -is(pos($x), 4); -{ local $x } -is(pos($x), 4); - -# Explicit test that triggers the utf8_mg_len_cache_update() code path in -# Perl_sv_pos_b2u(). - -$x = "\x{100}BC"; -$x =~ m/.*/g; -is(pos $x, 3); - - -my $destroyed; -{ package Class; DESTROY { ++$destroyed; } } - -$destroyed = 0; -{ - my $x = ''; - pos($x) = 0; - $x = bless({}, 'Class'); -} -is($destroyed, 1, 'Timely scalar destruction with lvalue pos'); diff --git a/t/CORE/op/pow.t b/t/CORE/op/pow.t deleted file mode 100644 index 435845879..000000000 --- a/t/CORE/op/pow.t +++ /dev/null @@ -1,71 +0,0 @@ -#!./perl -w -# Now they'll be wanting biff! and zap! tests too. - -BEGIN { - unshift @INC, 't/CORE/lib'; - require 't/CORE/test.pl'; -} - -# This calculation ought to be within 0.001 of the right answer. -my $bits_in_uv = int (0.001 + log (~0+1) / log 2); - -# 3**30 < 2**48, don't trust things outside that range on a Cray -# Likewise other 3 should not overflow 48 bits if I did my sums right. -my @pow = ([ 3, 30, 1e-14], - [ 4, 32, 0], - [ 5, 20, 1e-14], - [2.5, 10, 1e-14], - [ -2, 69, 0], - [ -3, 30, 1e-14], -); -my $tests; -$tests += $_->[1] foreach @pow; - -plan tests => 13 + $bits_in_uv + $tests; - -# (-3)**3 gave 27 instead of -27 before change #20167. -# Let's test the other similar edge cases, too. -is((-3)**0, 1, "negative ** 0 = 1"); -is((-3)**1, -3, "negative ** 1 = self"); -is((-3)**2, 9, "negative ** 2 = positive"); -is((-3)**3, -27, "(negative int) ** (odd power) is negative"); - -# Positives shouldn't be a problem -is(3**0, 1, "positive ** 0 = 1"); -is(3**1, 3, "positive ** 1 = self"); -is(3**2, 9, "positive ** 2 = positive"); -is(3**3, 27, "(positive int) ** (odd power) is positive"); - -# And test order of operations while we're at it -is(-3**0, -1); -is(-3**1, -3); -is(-3**2, -9); -is(-3**3, -27); - - -# Ought to be 32, 64, 36 or something like that. - -my $remainder = $bits_in_uv & 3; - -cmp_ok ($remainder, '==', 0, 'Sanity check bits in UV calculation') - or printf "# ~0 is %d (0x%d) which gives $bits_in_uv bits\n", ~0, ~0; - -# These are a lot of brute force tests to see how accurate $m ** $n is. -# Unfortunately rather a lot of perl programs expect 2 ** $n to be integer -# perfect, forgetting that it's a call to floating point pow() which never -# claims to deliver perfection. -foreach my $n (0..$bits_in_uv - 1) { - my $pow = 2 ** $n; - my $int = 1 << $n; - cmp_ok ($pow, '==', $int, "2 ** $n vs 1 << $n"); -} - -foreach my $pow (@pow) { - my ($base, $max, $range) = @$pow; - my $expect = 1; - foreach my $n (0..$max-1) { - my $got = $base ** $n; - within ($got, $expect, $range, "$base ** $n got[$got] expect[$expect]"); - $expect *= $base; - } -} diff --git a/t/CORE/op/print.t b/t/CORE/op/print.t deleted file mode 100644 index 87d960056..000000000 --- a/t/CORE/op/print.t +++ /dev/null @@ -1,12 +0,0 @@ -#!./perl - -BEGIN { - require 't/CORE/test.pl'; -} - -plan(2); - -fresh_perl_is('$_ = qq{OK\n}; print;', "OK\n", - 'print without arguments outputs $_'); -fresh_perl_is('$_ = qq{OK\n}; print STDOUT;', "OK\n", - 'print with only a filehandle outputs $_'); diff --git a/t/CORE/op/protowarn.t b/t/CORE/op/protowarn.t deleted file mode 100644 index 0602e6036..000000000 --- a/t/CORE/op/protowarn.t +++ /dev/null @@ -1,86 +0,0 @@ -#!./perl - -BEGIN { require 't/CORE/test.pl' } - -use strict; -use warnings; - -plan( tests => 12 ); - -use vars qw{ @warnings $sub $warn }; - -BEGIN { - $warn = 'Illegal character in prototype'; -} - -sub one_warning_ok { - cmp_ok(scalar(@warnings), '==', 1, 'One warning'); - cmp_ok(substr($warnings[0],0,length($warn)),'eq',$warn,'warning message'); - @warnings = (); -} - -sub no_warnings_ok { - cmp_ok(scalar(@warnings), '==', 0, 'No warnings'); - @warnings = (); -} - -$SIG{'__WARN__'} = sub { push @warnings, @_ }; -$| = 1; - -@warnings = (); - -eval q/$sub = sub (x) { }/; -one_warning_ok(); - - -eval q{ - no warnings 'syntax'; - $sub = sub (x) { }; -}; - -no_warnings_ok; - - -eval q{ - no warnings 'illegalproto'; - $sub = sub (x) { }; -}; - -no_warnings_ok; - -eval q{ - no warnings 'syntax'; - use warnings 'illegalproto'; - $sub = sub (x) { }; -}; - -one_warning_ok; - -$warn = q{Prototype after '@' for}; -eval q/$sub = sub (@$) { }/; - -one_warning_ok; - -eval q{ - no warnings 'syntax'; - $sub = sub (@$) { }; -}; - -no_warnings_ok; - - -eval q{ - no warnings 'illegalproto'; - $sub = sub (@$) { }; -}; - -no_warnings_ok; - -eval q{ - no warnings 'syntax'; - use warnings 'illegalproto'; - $sub = sub (@$) { }; -}; - -one_warning_ok; - diff --git a/t/CORE/op/push.t b/t/CORE/op/push.t deleted file mode 100644 index 813898e66..000000000 --- a/t/CORE/op/push.t +++ /dev/null @@ -1,124 +0,0 @@ -#!./perl - -@tests = split(/\n/, < [qw/a b c/]; -push CONST_ARRAYREF(), qw/d e f/; -if (join(':',@{CONST_ARRAYREF()}) eq 'a:b:c:d:e:f') {print "ok 9\n";} else {print "not ok 9\n";} - -# test implicit dereference errors -eval "push 42, 0, 1, 2, 3"; -if ( $@ && $@ =~ /must be array/ ) {print "ok 10\n"} else {print "not ok 10 # \$\@ = $@\n"} - -$hashref = { }; -eval { push $hashref, 0, 1, 2, 3 }; -if ( $@ && $@ =~ /Not an ARRAY reference/ ) {print "ok 11\n"} else {print "not ok 11 # \$\@ = $@\n"} - -eval { push bless([]), 0, 1, 2, 3 }; -if ( $@ && $@ =~ /Not an unblessed ARRAY reference/ ) {print "ok 12\n"} else {print "not ok 12 # \$\@ = $@\n"} - -$test = 13; - -# test context -{ - my($first, $second) = ([1], [2]); - sub two_things { return +($first, $second) } - push two_things(), 3; - if (join(':',@$first) eq '1' && - join(':',@$second) eq '2:3') { - print "ok ",$test++,"\n"; - } - else { - print "not ok ",$test++," got: \$first = [ @$first ]; \$second = [ @$second ];\n"; - } - - push @{ two_things() }, 4; - if (join(':',@$first) eq '1' && - join(':',@$second) eq '2:3:4') { - print "ok ",$test++,"\n"; - } - else { - print "not ok ",$test++," got: \$first = [ @$first ]; \$second = [ @$second ];\n"; - } -} - -foreach $line (@tests) { - ($list,$get,$leave) = split(/,\t*/,$line); - ($pos, $len, @list) = split(' ',$list); - @get = split(' ',$get); - @leave = split(' ',$leave); - @x = (0,1,2,3,4,5,6,7); - $y = [0,1,2,3,4,5,6,7]; - if (defined $len) { - @got = splice(@x, $pos, $len, @list); - @got2 = splice($y, $pos, $len, @list); - } - else { - @got = splice(@x, $pos); - @got2 = splice($y, $pos); - } - if (join(':',@got) eq join(':',@get) && - join(':',@x) eq join(':',@leave)) { - print "ok ",$test++,"\n"; - } - else { - print "not ok ",$test++," got: @got == @get left: @x == @leave\n"; - } - if (join(':',@got2) eq join(':',@get) && - join(':',@$y) eq join(':',@leave)) { - print "ok ",$test++,"\n"; - } - else { - print "not ok ",$test++," got (arrayref): @got2 == @get left: @$y == @leave\n"; - } -} - -1; # this file is require'd by lib/tie-stdpush.t diff --git a/t/CORE/op/pwent.t b/t/CORE/op/pwent.t deleted file mode 100644 index adacb5573..000000000 --- a/t/CORE/op/pwent.t +++ /dev/null @@ -1,241 +0,0 @@ -#!./perl - -BEGIN { - unshift @INC, 't/CORE/lib'; - require 't/CORE/test.pl'; -} - -use strict; -use warnings; - -eval {my @n = getpwuid 0; setpwent()}; -skip_all($1) if $@ && $@ =~ /(The \w+ function is unimplemented)/; - -eval { require Config; }; - -sub try_prog { - my ($where, $args, @pathnames) = @_; - foreach my $prog (@pathnames) { - next unless -x $prog; - next unless open PW, '-|', "$prog $args 2>/dev/null"; - next unless defined ; - return $where; - } - return; -} - -# Try NIS. -my $where = try_prog('NIS passwd', 'passwd', - qw(/usr/bin/ypcat /bin/ypcat /etc/ypcat)); - -# Try NetInfo. -$where //= try_prog('NetInfo passwd', 'passwd .', '/usr/bin/nidump'); - -# Try NIS+. -$where //= try_prog('NIS+', 'passwd.org_dir', '/bin/niscat'); - -# Try dscl -if (!defined $where && $Config::Config{useperlio}) { - # Map dscl items to passwd fields, and provide support for - # mucking with the dscl output if we need to (and we do). - my %want = do { - my $inx = 0; - map {$_ => {inx => $inx++, mung => sub {$_[0]}}} - qw{RecordName Password UniqueID PrimaryGroupID - RealName NFSHomeDirectory UserShell}; - }; - - # The RecordName for a /User record is the username. In some - # cases there are synonyms (e.g. _www and www), in which case we - # get a blank-delimited list. We prefer the first entry in the - # list because getpwnam() does. - $want{RecordName}{mung} = sub {(split '\s+', $_[0], 2)[0]}; - - # The UniqueID and PrimaryGroupID for a /User record are the - # user ID and the primary group ID respectively. In cases where - # the high bit is set, 'dscl' returns a negative number, whereas - # getpwnam() returns its twos complement. This mungs the dscl - # output to agree with what getpwnam() produces. Interestingly - # enough, getpwuid(-2) returns the right record ('nobody'), even - # though it returns the uid as 4294967294. If you track uid_t - # on an i386, you find it is an unsigned int, which makes the - # unsigned version the right one; but both /etc/passwd and - # /etc/master.passwd contain negative numbers. - $want{UniqueID}{mung} = $want{PrimaryGroupID}{mung} = sub { - unpack 'L', pack 'l', $_[0]}; - - foreach my $dscl (qw(/usr/bin/dscl)) { - next unless -x $dscl; - next unless open my $fh, '-|', "$dscl . -readall /Users @{[keys %want]} 2>/dev/null"; - my @lines; - my @rec; - while (<$fh>) { - chomp; - if ($_ eq '-') { - if (@rec) { - push @lines, join (':', @rec) . "\n"; - @rec = (); - } - next; - } - my ($name, $value) = split ':\s+', $_, 2; - unless (defined $value) { - s/:$//; - $name = $_; - $value = <$fh>; - chomp $value; - $value =~ s/^\s+//; - } - if (defined (my $info = $want{$name})) { - $rec[$info->{inx}] = $info->{mung}->($value); - } - } - if (@rec) { - push @lines, join (':', @rec) . "\n"; - } - my $data = join '', @lines; - if (open PW, '<', \$data) { - $where = "dscl . -readall /Users"; - last; - } - } -} - -if (not defined $where) { - # Try local. - my $no_i_pwd = !$Config::Config{i_pwd} && '$Config{i_pwd} undefined'; - - my $PW = "/etc/passwd"; - if (!-f $PW) { - skip_all($no_i_pwd) if $no_i_pwd; - skip_all("no $PW file"); - } elsif (open PW, '<', $PW) { - if(defined ) { - $where = $PW; - } else { - skip_all($no_i_pwd) if $no_i_pwd; - die "\$Config{i_pwd} is defined, $PW exists but has no entries, all other approaches failed, giving up"; - } - } else { - die "Can't open $PW: $!"; - } -} - -# By now the PW filehandle should be open and full of juicy password entries. - -plan(tests => 2); - -# Go through at most this many users. -# (note that the first entry has been read away by now) -my $max = 25; - -my $n = 0; -my %perfect; -my %seen; - -print "# where $where\n"; - -setpwent(); - -while () { - chomp; - # LIMIT -1 so that users with empty shells don't fall off - my @s = split /:/, $_, -1; - my ($name_s, $passwd_s, $uid_s, $gid_s, $gcos_s, $home_s, $shell_s); - (my $v) = $Config::Config{osvers} =~ /^(\d+)/; - if ($^O eq 'darwin' && $v < 9) { - ($name_s, $passwd_s, $uid_s, $gid_s, $gcos_s, $home_s, $shell_s) = @s[0,1,2,3,7,8,9]; - } else { - ($name_s, $passwd_s, $uid_s, $gid_s, $gcos_s, $home_s, $shell_s) = @s; - } - next if /^\+/; # ignore NIS includes - if (@s) { - push @{ $seen{$name_s} }, $.; - } else { - warn "# Your $where line $. is empty.\n"; - next; - } - if ($n == $max) { - local $/; - my $junk = ; - last; - } - # In principle we could whine if @s != 7 but do we know enough - # of passwd file formats everywhere? - if (@s == 7 || ($^O eq 'darwin' && @s == 10)) { - my @n = getpwuid($uid_s); - # 'nobody' et al. - next unless @n; - my ($name,$passwd,$uid,$gid,$quota,$comment,$gcos,$home,$shell) = @n; - # Protect against one-to-many and many-to-one mappings. - if ($name_s ne $name) { - @n = getpwnam($name_s); - ($name,$passwd,$uid,$gid,$quota,$comment,$gcos,$home,$shell) = @n; - next if $name_s ne $name; - } - $perfect{$name_s}++ - if $name eq $name_s and - $uid eq $uid_s and -# Do not compare passwords: think shadow passwords. - $gid eq $gid_s and - $gcos eq $gcos_s and - $home eq $home_s and - $shell eq $shell_s; - } - $n++; -} - -endpwent(); - -print "# max = $max, n = $n, perfect = ", scalar keys %perfect, "\n"; - -SKIP: { - skip("Found no password entries", 1) unless $n; - - if (keys %perfect == 0) { - $max++; - print <', 0) - or note("(not necessarily serious: run t/op/pwent.t by itself)"); -} - -# Test both the scalar and list contexts. - -my @pw1; - -setpwent(); -for (1..$max) { - my $pw = scalar getpwent(); - last unless defined $pw; - push @pw1, $pw; -} -endpwent(); - -my @pw2; - -setpwent(); -for (1..$max) { - my ($pw) = (getpwent()); - last unless defined $pw; - push @pw2, $pw; -} -endpwent(); - -is("@pw1", "@pw2"); - -close(PW); diff --git a/t/CORE/op/qq.t b/t/CORE/op/qq.t deleted file mode 100644 index 479c36ce7..000000000 --- a/t/CORE/op/qq.t +++ /dev/null @@ -1,72 +0,0 @@ -#!./perl - -BEGIN { - unshift @INC, 't/CORE/lib'; -} - -print q(1..28 -); - -# This is() function is written to avoid "" -my $test = 1; -sub is { - my($left, $right) = @_; - - if ($left eq $right) { - printf 'ok %d -', $test++; - return 1; - } - foreach ($left, $right) { - # Comment out these regexps to map non-printables to ord if the perl under - # test is so broken that it's not helping - s/([^-+A-Za-z_0-9])/sprintf q{'.chr(%d).'}, ord $1/ge; - $_ = sprintf q('%s'), $_; - s/^''\.//; - s/\.''$//; - } - printf q(not ok %d - got %s expected %s -), $test++, $left, $right; - - printf q(# Failed test at line %d -), (caller)[2]; - - return 0; -} - -is ("\x53", chr 83); -is ("\x4EE", chr (78) . 'E'); -is ("\x4i", chr (4) . 'i'); # This will warn -is ("\xh", chr (0) . 'h'); # This will warn -is ("\xx", chr (0) . 'x'); # This will warn -is ("\xx9", chr (0) . 'x9'); # This will warn. \x9 is tab in EBCDIC too? -is ("\x9_E", chr (9) . '_E'); # This will warn - -is ("\x{4E}", chr 78); -is ("\x{6_9}", chr 105); -is ("\x{_6_3}", chr 99); -is ("\x{_6B}", chr 107); - -is ("\x{9__0}", chr 9); # multiple underscores not allowed. -is ("\x{77_}", chr 119); # trailing underscore warns. -is ("\x{6FQ}z", chr (111) . 'z'); - -is ("\x{0x4E}", chr 0); -is ("\x{x4E}", chr 0); - -is ("\x{0065}", chr 101); -is ("\x{000000000000000000000000000000000000000000000000000000000000000072}", - chr 114); -is ("\x{0_06_5}", chr 101); -is ("\x{1234}", chr 4660); -is ("\x{10FFFD}", chr 1114109); -is ("\400", chr 0x100); -is ("\600", chr 0x180); -is ("\777", chr 0x1FF); -is ("a\o{120}b", "a" . chr(0x50) . "b"); -is ("a\o{400}b", "a" . chr(0x100) . "b"); -is ("a\o{1000}b", "a" . chr(0x200) . "b"); - -# This caused a memory fault -no warnings "utf8"; -is ("abc", eval qq[qq\x{8000_0000}abc\x{8000_0000}]) diff --git a/t/CORE/op/qr.t b/t/CORE/op/qr.t deleted file mode 100644 index 21fc1d856..000000000 --- a/t/CORE/op/qr.t +++ /dev/null @@ -1,58 +0,0 @@ -#!./perl -w - -use strict; - -require 't/CORE/test.pl'; - -plan(tests => 18); - -sub r { - return qr/Good/; -} - -my $a = r(); -isa_ok($a, 'Regexp'); -my $b = r(); -isa_ok($b, 'Regexp'); - -my $b1 = $b; - -isnt($a + 0, $b + 0, 'Not the same object'); - -bless $b, 'Pie'; - -isa_ok($b, 'Pie'); -isa_ok($a, 'Regexp'); -isa_ok($b1, 'Pie'); - -my $c = r(); -like("$c", qr/Good/); -my $d = r(); -like("$d", qr/Good/); - -my $d1 = $d; - -isnt($c + 0, $d + 0, 'Not the same object'); - -$$d = 'Bad'; - -like("$c", qr/Good/); -is($$d, 'Bad'); -is($$d1, 'Bad'); - -# Assignment to an implicitly blessed Regexp object retains the class -# (No different from direct value assignment to any other blessed SV - -isa_ok($d, 'Regexp'); -like("$d", qr/\ARegexp=SCALAR\(0x[0-9a-f]+\)\z/); - -# As does an explicitly blessed Regexp object. - -my $e = bless qr/Faux Pie/, 'Stew'; - -isa_ok($e, 'Stew'); -$$e = 'Fake!'; - -is($$e, 'Fake!'); -isa_ok($e, 'Stew'); -like("$e", qr/\Stew=SCALAR\(0x[0-9a-f]+\)\z/); diff --git a/t/CORE/op/quotemeta.t b/t/CORE/op/quotemeta.t deleted file mode 100644 index 6201b2804..000000000 --- a/t/CORE/op/quotemeta.t +++ /dev/null @@ -1,54 +0,0 @@ -#!./perl - -BEGIN { - unshift @INC, "./lib"; - require Config; import Config; - require 't/CORE/test.pl'; -} - -plan tests => 22; - -if ($Config{ebcdic} eq 'define') { - $_ = join "", map chr($_), 129..233; - - # 105 characters - 52 letters = 53 backslashes - # 105 characters + 53 backslashes = 158 characters - $_ = quotemeta $_; - is(length($_), 158, "quotemeta string"); - # 104 non-backslash characters - is(tr/\\//cd, 104, "tr count non-backslashed"); -} else { # some ASCII descendant, then. - $_ = join "", map chr($_), 32..127; - - # 96 characters - 52 letters - 10 digits - 1 underscore = 33 backslashes - # 96 characters + 33 backslashes = 129 characters - $_ = quotemeta $_; - is(length($_), 129, "quotemeta string"); - # 95 non-backslash characters - is(tr/\\//cd, 95, "tr count non-backslashed"); -} - -is(length(quotemeta ""), 0, "quotemeta empty string"); - -is("aA\UbB\LcC\EdD", "aABBccdD", 'aA\UbB\LcC\EdD'); -is("aA\LbB\UcC\EdD", "aAbbCCdD", 'aA\LbB\UcC\EdD'); -is("\L\upERL", "Perl", '\L\upERL'); -is("\u\LpERL", "Perl", '\u\LpERL'); -is("\U\lPerl", "pERL", '\U\lPerl'); -is("\l\UPerl", "pERL", '\l\UPerl'); -is("\u\LpE\Q#X#\ER\EL", "Pe\\#x\\#rL", '\u\LpE\Q#X#\ER\EL'); -is("\l\UPe\Q!x!\Er\El", "pE\\!X\\!Rl", '\l\UPe\Q!x!\Er\El'); -is("\Q\u\LpE.X.R\EL\E.", "Pe\\.x\\.rL.", '\Q\u\LpE.X.R\EL\E.'); -is("\Q\l\UPe*x*r\El\E*", "pE\\*X\\*Rl*", '\Q\l\UPe*x*r\El\E*'); -is("\U\lPerl\E\E\E\E", "pERL", '\U\lPerl\E\E\E\E'); -is("\l\UPerl\E\E\E\E", "pERL", '\l\UPerl\E\E\E\E'); - -is(quotemeta("\x{263a}"), "\x{263a}", "quotemeta Unicode"); -is(length(quotemeta("\x{263a}")), 1, "quotemeta Unicode length"); - -$a = "foo|bar"; -is("a\Q\Ec$a", "acfoo|bar", '\Q\E'); -is("a\L\Ec$a", "acfoo|bar", '\L\E'); -is("a\l\Ec$a", "acfoo|bar", '\l\E'); -is("a\U\Ec$a", "acfoo|bar", '\U\E'); -is("a\u\Ec$a", "acfoo|bar", '\u\E'); diff --git a/t/CORE/op/rand.t b/t/CORE/op/rand.t deleted file mode 100644 index 3d189d92c..000000000 --- a/t/CORE/op/rand.t +++ /dev/null @@ -1,243 +0,0 @@ -#!./perl - -# From Tom Phoenix 22 Feb 1997 -# Based upon a test script by kgb@ast.cam.ac.uk (Karl Glazebrook) - -# Looking for the hints? You're in the right place. -# The hints are near each test, so search for "TEST #", where -# the pound sign is replaced by the number of the test. - -# I'd like to include some more robust tests, but anything -# too subtle to be detected here would require a time-consuming -# test. Also, of course, we're here to detect only flaws in Perl; -# if there are flaws in the underlying system rand, that's not -# our responsibility. But if you want better tests, see -# The Art of Computer Programming, Donald E. Knuth, volume 2, -# chapter 3. ISBN 0-201-03822-6 (v. 2) - -INIT { - unshift @INC, "./lib"; - require 't/CORE/test.pl'; -} - -use strict; -use Config; - -plan(tests => 8); - - -my $reps = 15000; # How many times to try rand each time. - # May be changed, but should be over 500. - # The more the better! (But slower.) - -sub bits ($) { - # Takes a small integer and returns the number of one-bits in it. - my $total; - my $bits = sprintf "%o", $_[0]; - while (length $bits) { - $total += (0,1,1,2,1,2,2,3)[chop $bits]; # Oct to bits - } - $total; -} - -# First, let's see whether randbits is set right -{ - my($max, $min, $sum); # Characteristics of rand - my($off, $shouldbe); # Problems with randbits - my($dev, $bits); # Number of one bits - my $randbits = $Config{randbits}; - $max = $min = rand(1); - for (1..$reps) { - my $n = rand(1); - if ($n < 0.0 or $n >= 1.0) { - print <= 1.0. -# Make sure \$Config{drand01} is a valid expression in the -# C-language, and produces values in the range [0.0,1.0). -# -# I give up. -EOM - exit; - } - $sum += $n; - $bits += bits($n * 256); # Don't be greedy; 8 is enough - # It's too many if randbits is less than 8! - # But that should never be the case... I hope. - # Note: If you change this, you must adapt the - # formula for absolute standard deviation, below. - $max = $n if $n > $max; - $min = $n if $n < $min; - } - - - # This test checks for one of Perl's most frequent - # mis-configurations. Your system's documentation - # for rand(2) should tell you what value you need - # for randbits. Usually the diagnostic message - # has the right value as well. Just fix it and - # recompile, and you'll usually be fine. (The main - # reason that the diagnostic message might get the - # wrong value is that Config.pm is incorrect.) - # - unless (ok( !$max <= 0 or $max >= (2 ** $randbits))) {# Just in case... - print < 0); # Next more positive int - unless (is( $off, 0 )) { - $shouldbe = $Config{randbits} + $off; - print "# max=[$max] min=[$min]\n"; - print "# This perl was compiled with randbits=$randbits on $^O.\n"; - print "# Consider using randbits=$shouldbe instead.\n"; - # And skip the remaining tests; they would be pointless now. - print "# Skipping remaining tests until randbits is fixed.\n"; - exit; - } - - - # This should always be true: 0 <= rand(1) < 1 - # If this test is failing, something is seriously wrong, - # either in perl or your system's rand function. - # - unless (ok( !($min < 0 or $max >= 1) )) { # Slightly redundant... - print "# min too low\n" if $min < 0; - print "# max too high\n" if $max >= 1; - } - - - # This is just a crude test. The average number produced - # by rand should be about one-half. But once in a while - # it will be relatively far away. Note: This test will - # occasionally fail on a perfectly good system! - # See the hints for test 4 to see why. - # - $sum /= $reps; - unless (ok( !($sum < 0.4 or $sum > 0.6) )) { - print "# Average random number is far from 0.5\n"; - } - - - # NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE - # This test will fail .006% of the time on a normal system. - # also - # This test asks you to see these hints 100% of the time! - # NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE - # - # There is probably no reason to be alarmed that - # something is wrong with your rand function. But, - # if you're curious or if you can't help being - # alarmed, keep reading. - # - # This is a less-crude test than test 3. But it has - # the same basic flaw: Unusually distributed random - # values should occasionally appear in every good - # random number sequence. (If you flip a fair coin - # twenty times every day, you'll see it land all - # heads about one time in a million days, on the - # average. That might alarm you if you saw it happen - # on the first day!) - # - # So, if this test failed on you once, run it a dozen - # times. If it keeps failing, it's likely that your - # rand is bogus. If it keeps passing, it's likely - # that the one failure was bogus. If it's a mix, - # read on to see about how to interpret the tests. - # - # The number printed in square brackets is the - # standard deviation, a statistical measure - # of how unusual rand's behavior seemed. It should - # fall in these ranges with these *approximate* - # probabilities: - # - # under 1 68.26% of the time - # 1-2 27.18% of the time - # 2-3 4.30% of the time - # over 3 0.26% of the time - # - # If the numbers you see are not scattered approximately - # (not exactly!) like that table, check with your vendor - # to find out what's wrong with your rand. Or with this - # algorithm. :-) - # - # Calculating absolute standard deviation for number of bits set - # (eight bits per rep) - $dev = abs ($bits - $reps * 4) / sqrt($reps * 2); - - ok( $dev < 4.0 ); - - if ($dev < 1.96) { - print "# Your rand seems fine. If this test failed\n"; - print "# previously, you may want to run it again.\n"; - } elsif ($dev < 2.575) { - print "# This is ok, but suspicious. But it will happen\n"; - print "# one time out of 25, more or less.\n"; - print "# You should run this test again to be sure.\n"; - } elsif ($dev < 3.3) { - print "# This is very suspicious. It will happen only\n"; - print "# about one time out of 100, more or less.\n"; - print "# You should run this test again to be sure.\n"; - } elsif ($dev < 3.9) { - print "# This is VERY suspicious. It will happen only\n"; - print "# about one time out of 1000, more or less.\n"; - print "# You should run this test again to be sure.\n"; - } else { - print "# This is VERY VERY suspicious.\n"; - print "# Your rand seems to be bogus.\n"; - } - print "#\n# If you are having random number troubles,\n"; - print "# see the hints within the test script for more\n"; - printf "# information on why this might fail. [ %.3f ]\n", $dev; -} - - -# Now, let's see whether rand accepts its argument -{ - my($max, $min); - $max = $min = rand(100); - for (1..$reps) { - my $n = rand(100); - $max = $n if $n > $max; - $min = $n if $n < $min; - } - - # This test checks to see that rand(100) really falls - # within the range 0 - 100, and that the numbers produced - # have a reasonably-large range among them. - # - unless ( ok( !($min < 0 or $max >= 100 or ($max - $min) < 65) ) ) { - print "# min too low\n" if $min < 0; - print "# max too high\n" if $max >= 100; - print "# range too narrow\n" if ($max - $min) < 65; - } - - - # This test checks that rand without an argument - # is equivalent to rand(1). - # - $_ = 12345; # Just for fun. - srand 12345; - my $r = rand; - srand 12345; - is(rand(1), $r, 'rand() without args is rand(1)'); - - - # This checks that rand without an argument is not - # rand($_). (In case somebody got overzealous.) - # - ok($r < 1, 'rand() without args is under 1'); -} - diff --git a/t/CORE/op/range.t b/t/CORE/op/range.t deleted file mode 100644 index 47df0b841..000000000 --- a/t/CORE/op/range.t +++ /dev/null @@ -1,418 +0,0 @@ -#!./perl - -BEGIN { require 't/CORE/test.pl' } - -# Avoid using eq_array below as it uses .. internally. - -use Config; - -plan (141); - -is(join(':',1..5), '1:2:3:4:5'); - -@foo = (1,2,3,4,5,6,7,8,9); -@foo[2..4] = ('c','d','e'); - -is(join(':',@foo[$foo[0]..5]), '2:c:d:e:6'); - -@bar[2..4] = ('c','d','e'); -is(join(':',@bar[1..5]), ':c:d:e:'); - -($a,@bcd[0..2],$e) = ('a','b','c','d','e'); -is(join(':',$a,@bcd[0..2],$e), 'a:b:c:d:e'); - -$x = 0; -for (1..100) { - $x += $_; -} -is($x, 5050); - -$x = 0; -for ((100,2..99,1)) { - $x += $_; -} -is($x, 5050); - -$x = join('','a'..'z'); -is($x, 'abcdefghijklmnopqrstuvwxyz'); - -@x = 'A'..'ZZ'; -is (scalar @x, 27 * 26); - -@x = '09' .. '08'; # should produce '09', '10',... '99' (strange but true) -is(join(",", @x), join(",", map {sprintf "%02d",$_} 9..99)); - -# same test with foreach (which is a separate implementation) -@y = (); -foreach ('09'..'08') { - push(@y, $_); -} -is(join(",", @y), join(",", @x)); - -# check bounds -if ($Config{ivsize} == 8) { - @a = eval "0x7ffffffffffffffe..0x7fffffffffffffff"; - $a = "9223372036854775806 9223372036854775807"; - @b = eval "-0x7fffffffffffffff..-0x7ffffffffffffffe"; - $b = "-9223372036854775807 -9223372036854775806"; -} -else { - @a = eval "0x7ffffffe..0x7fffffff"; - $a = "2147483646 2147483647"; - @b = eval "-0x7fffffff..-0x7ffffffe"; - $b = "-2147483647 -2147483646"; -} - -is ("@a", $a); - -is ("@b", $b); - -# check magic -{ - my $bad = 0; - local $SIG{'__WARN__'} = sub { $bad = 1 }; - my $x = 'a-e'; - $x =~ s/(\w)-(\w)/join ':', $1 .. $2/e; - is ($x, 'a:b:c:d:e'); -} - -# Should use magical autoinc only when both are strings -{ - my $scalar = (() = "0"..-1); - is ($scalar, 0); -} -{ - my $fail = 0; - for my $x ("0"..-1) { - $fail++; - } - is ($fail, 0); -} - -# [#18165] Should allow "-4".."0", broken by #4730. (AMS 20021031) -is(join(":","-4".."0") , "-4:-3:-2:-1:0"); -is(join(":","-4".."-0") , "-4:-3:-2:-1:0"); -is(join(":","-4\n".."0\n") , "-4:-3:-2:-1:0"); -is(join(":","-4\n".."-0\n"), "-4:-3:-2:-1:0"); - -# undef should be treated as 0 for numerical range -is(join(":",undef..2), '0:1:2'); -is(join(":",-2..undef), '-2:-1:0'); -is(join(":",undef..'2'), '0:1:2'); -is(join(":",'-2'..undef), '-2:-1:0'); - -# undef should be treated as "" for magical range -is(join(":", map "[$_]", "".."B"), '[]'); -is(join(":", map "[$_]", undef.."B"), '[]'); -is(join(":", map "[$_]", "B"..""), ''); -is(join(":", map "[$_]", "B"..undef), ''); - -# undef..undef used to segfault -is(join(":", map "[$_]", undef..undef), '[]'); - -# also test undef in foreach loops -@foo=(); push @foo, $_ for undef..2; -is(join(":", @foo), '0:1:2'); - -@foo=(); push @foo, $_ for -2..undef; -is(join(":", @foo), '-2:-1:0'); - -@foo=(); push @foo, $_ for undef..'2'; -is(join(":", @foo), '0:1:2'); - -@foo=(); push @foo, $_ for '-2'..undef; -is(join(":", @foo), '-2:-1:0'); - -@foo=(); push @foo, $_ for undef.."B"; -is(join(":", map "[$_]", @foo), '[]'); - -@foo=(); push @foo, $_ for "".."B"; -is(join(":", map "[$_]", @foo), '[]'); - -@foo=(); push @foo, $_ for "B"..undef; -is(join(":", map "[$_]", @foo), ''); - -@foo=(); push @foo, $_ for "B"..""; -is(join(":", map "[$_]", @foo), ''); - -@foo=(); push @foo, $_ for undef..undef; -is(join(":", map "[$_]", @foo), '[]'); - -# again with magic -{ - my @a = (1..3); - @foo=(); push @foo, $_ for undef..$#a; - is(join(":", @foo), '0:1:2'); -} -{ - my @a = (); - @foo=(); push @foo, $_ for $#a..undef; - is(join(":", @foo), '-1:0'); -} -{ - local $1; - "2" =~ /(.+)/; - @foo=(); push @foo, $_ for undef..$1; - is(join(":", @foo), '0:1:2'); -} -{ - local $1; - "-2" =~ /(.+)/; - @foo=(); push @foo, $_ for $1..undef; - is(join(":", @foo), '-2:-1:0'); -} -{ - local $1; - "B" =~ /(.+)/; - @foo=(); push @foo, $_ for undef..$1; - is(join(":", map "[$_]", @foo), '[]'); -} -{ - local $1; - "B" =~ /(.+)/; - @foo=(); push @foo, $_ for ""..$1; - is(join(":", map "[$_]", @foo), '[]'); -} -{ - local $1; - "B" =~ /(.+)/; - @foo=(); push @foo, $_ for $1..undef; - is(join(":", map "[$_]", @foo), ''); -} -{ - local $1; - "B" =~ /(.+)/; - @foo=(); push @foo, $_ for $1..""; - is(join(":", map "[$_]", @foo), ''); -} - -# Test upper range limit -my $MAX_INT = ~0>>1; - -foreach my $ii (-3 .. 3) { - my ($first, $last); - eval { - my $lim=0; - for ($MAX_INT-10 .. $MAX_INT+$ii) { - if (! defined($first)) { - $first = $_; - } - $last = $_; - last if ($lim++ > 100); # Protect against integer wrap - } - }; - if ($ii <= 0) { - ok(! $@, 'Upper bound accepted: ' . ($MAX_INT+$ii)); - is($first, $MAX_INT-10, 'Lower bound okay'); - is($last, $MAX_INT+$ii, 'Upper bound okay'); - } else { - ok($@, 'Upper bound rejected: ' . ($MAX_INT+$ii)); - } -} - -foreach my $ii (-3 .. 3) { - my ($first, $last); - eval { - my $lim=0; - for ($MAX_INT+$ii .. $MAX_INT) { - if (! defined($first)) { - $first = $_; - } - $last = $_; - last if ($lim++ > 100); - } - }; - if ($ii <= 0) { - ok(! $@, 'Lower bound accepted: ' . ($MAX_INT+$ii)); - is($first, $MAX_INT+$ii, 'Lower bound okay'); - is($last, $MAX_INT, 'Upper bound okay'); - } else { - ok($@, 'Lower bound rejected: ' . ($MAX_INT+$ii)); - } -} - -{ - my $first; - eval { - my $lim=0; - for ($MAX_INT .. $MAX_INT-1) { - if (! defined($first)) { - $first = $_; - } - $last = $_; - last if ($lim++ > 100); - } - }; - ok(! $@, 'Range accepted'); - ok(! defined($first), 'Range ineffectual'); -} - -foreach my $ii (~0, ~0+1, ~0+(~0>>4)) { - eval { - my $lim=0; - for ($MAX_INT-10 .. $ii) { - last if ($lim++ > 100); - } - }; - ok($@, 'Upper bound rejected: ' . $ii); -} - -# Test lower range limit -my $MIN_INT = -1-$MAX_INT; - -if (! $Config{d_nv_preserves_uv}) { - # $MIN_INT needs adjustment when IV won't fit into an NV - my $NV = $MIN_INT - 1; - my $OFFSET = 1; - while (($NV + $OFFSET) == $MIN_INT) { - $OFFSET++ - } - $MIN_INT += $OFFSET; -} - -foreach my $ii (-3 .. 3) { - my ($first, $last); - eval { - my $lim=0; - for ($MIN_INT+$ii .. $MIN_INT+10) { - if (! defined($first)) { - $first = $_; - } - $last = $_; - last if ($lim++ > 100); - } - }; - if ($ii >= 0) { - ok(! $@, 'Lower bound accepted: ' . ($MIN_INT+$ii)); - is($first, $MIN_INT+$ii, 'Lower bound okay'); - is($last, $MIN_INT+10, 'Upper bound okay'); - } else { - ok($@, 'Lower bound rejected: ' . ($MIN_INT+$ii)); - } -} - -foreach my $ii (-3 .. 3) { - my ($first, $last); - eval { - my $lim=0; - for ($MIN_INT .. $MIN_INT+$ii) { - if (! defined($first)) { - $first = $_; - } - $last = $_; - last if ($lim++ > 100); - } - }; - if ($ii >= 0) { - ok(! $@, 'Upper bound accepted: ' . ($MIN_INT+$ii)); - is($first, $MIN_INT, 'Lower bound okay'); - is($last, $MIN_INT+$ii, 'Upper bound okay'); - } else { - ok($@, 'Upper bound rejected: ' . ($MIN_INT+$ii)); - } -} - -{ - my $first; - eval { - my $lim=0; - for ($MIN_INT+1 .. $MIN_INT) { - if (! defined($first)) { - $first = $_; - } - $last = $_; - last if ($lim++ > 100); - } - }; - ok(! $@, 'Range accepted'); - ok(! defined($first), 'Range ineffectual'); -} - -foreach my $ii (~0, ~0+1, ~0+(~0>>4)) { - eval { - my $lim=0; - for (-$ii .. $MIN_INT+10) { - last if ($lim++ > 100); - } - }; - ok($@, 'Lower bound rejected: ' . -$ii); -} - -# double/triple magic tests -sub TIESCALAR { bless { value => $_[1], orig => $_[1] } } -sub STORE { $_[0]{store}++; $_[0]{value} = $_[1] } -sub FETCH { $_[0]{fetch}++; $_[0]{value} } -sub stores { tied($_[0])->{value} = tied($_[0])->{orig}; - delete(tied($_[0])->{store}) || 0 } -sub fetches { delete(tied($_[0])->{fetch}) || 0 } - -tie $x, "main", 6; - -my @foo; -@foo = 4 .. $x; -is(scalar @foo, 3); -is("@foo", "4 5 6"); -{ - local $TODO = "test for double magic with range operator"; - is(fetches($x), 1); -} -is(stores($x), 0); - -@foo = $x .. 8; -is(scalar @foo, 3); -is("@foo", "6 7 8"); -{ - local $TODO = "test for double magic with range operator"; - is(fetches($x), 1); -} -is(stores($x), 0); - -@foo = $x .. $x + 1; -is(scalar @foo, 2); -is("@foo", "6 7"); -{ - local $TODO = "test for double magic with range operator"; - is(fetches($x), 2); -} -is(stores($x), 0); - -@foo = (); -for (4 .. $x) { - push @foo, $_; -} -is(scalar @foo, 3); -is("@foo", "4 5 6"); -{ - local $TODO = "test for double magic with range operator"; - is(fetches($x), 1); -} -is(stores($x), 0); - -@foo = (); -for (reverse 4 .. $x) { - push @foo, $_; -} -is(scalar @foo, 3); -is("@foo", "6 5 4"); -{ - local $TODO = "test for double magic with range operator"; - is(fetches($x), 1); -} -is(stores($x), 0); - -is( ( join ' ', map { join '', map ++$_, ($x=1)..4 } 1..2 ), '2345 2345', - 'modifiable variable num range' ); -is( ( join ' ', map { join '', map ++$_, 1..4 } 1..2 ), '2345 3456', - 'modifiable const num range' ); # Unresolved bug RT#3105 -$s = ''; for (1..2) { for (1..4) { $s .= ++$_ } $s.=' ' if $_==1; } -is( $s, '2345 2345','modifiable num counting loop counter' ); - - -is( ( join ' ', map { join '', map ++$_, ($x='a')..'d' } 1..2 ), 'bcde bcde', - 'modifiable variable alpha range' ); -is( ( join ' ', map { join '', map ++$_, 'a'..'d' } 1..2 ), 'bcde cdef', - 'modifiable const alpha range' ); # Unresolved bug RT#3105 -$s = ''; for (1..2) { for ('a'..'d') { $s .= ++$_ } $s.=' ' if $_==1; } -is( $s, 'bcde bcde','modifiable alpha counting loop counter' ); - -# EOF diff --git a/t/CORE/op/read.t b/t/CORE/op/read.t deleted file mode 100644 index 991daaa70..000000000 --- a/t/CORE/op/read.t +++ /dev/null @@ -1,95 +0,0 @@ -#!./perl - -BEGIN { - unshift @INC, 't/CORE/lib'; - require 't/CORE/test.pl'; -} -use strict; - -plan tests => 2564; - -open(FOO,'t/CORE/op/read.t') || open(FOO,'t/op/read.t') || open(FOO,':op:read.t') || die "Can't open op.read"; -seek(FOO,4,0) or die "Seek failed: $!"; -my $buf; -my $got = read(FOO,$buf,4); - -is ($got, 4); -is ($buf, "perl"); - -seek (FOO,0,2) || seek(FOO,20000,0); -$got = read(FOO,$buf,4); - -is ($got, 0); -is ($buf, ""); - -# This is true if Config is not built, or if PerlIO is enabled -# ie assume that PerlIO is present, unless we know for sure otherwise. -my $has_perlio = !eval { - no warnings; - require Config; - !$Config::Config{useperlio} -}; - -my $tmpfile = tempfile(); - -my (@values, @buffers) = ('', ''); - -foreach (65, 161, 253, 9786) { - push @values, join "", map {chr $_} $_ .. $_ + 4; - push @buffers, join "", map {chr $_} $_ + 5 .. $_ + 20; -} -my @offsets = (0, 3, 7, 22, -1, -3, -5, -7); -my @lengths = (0, 2, 5, 10); - -foreach my $value (@values) { - foreach my $initial_buffer (@buffers) { - my @utf8 = 1; - if ($value !~ tr/\0-\377//c) { - # It's all 8 bit - unshift @utf8, 0; - } - SKIP: - foreach my $utf8 (@utf8) { - skip "Needs :utf8 layer but no perlio", 2 * @offsets * @lengths - if $utf8 and !$has_perlio; - - open FH, ">$tmpfile" or die "Can't open $tmpfile: $!"; - binmode FH, "utf8" if $utf8; - print FH $value; - close FH; - foreach my $offset (@offsets) { - foreach my $length (@lengths) { - # Will read the lesser of the length of the file and the - # read length - my $will_read = $value; - if ($length < length $will_read) { - substr ($will_read, $length) = ''; - } - # Going to trash this so need a copy - my $buffer = $initial_buffer; - - my $expect = $buffer; - if ($offset > 0) { - # Right pad with NUL bytes - $expect .= "\0" x $offset; - substr ($expect, $offset) = ''; - } - substr ($expect, $offset) = $will_read; - - open FH, $tmpfile or die "Can't open $tmpfile: $!"; - binmode FH, "utf8" if $utf8; - my $what = sprintf "%d into %d l $length o $offset", - ord $value, ord $buffer; - $what .= ' u' if $utf8; - $got = read (FH, $buffer, $length, $offset); - is ($got, length $will_read, "got $what"); - is ($buffer, $expect, "buffer $what"); - close FH; - } - } - } - } -} - - - diff --git a/t/CORE/op/readdir.t b/t/CORE/op/readdir.t deleted file mode 100644 index 7e4e07c24..000000000 --- a/t/CORE/op/readdir.t +++ /dev/null @@ -1,258 +0,0 @@ -#!./perl - -BEGIN { - unshift @INC, 't/CORE/lib'; - require 't/CORE/test.pl'; -} - -use strict; -use warnings; -use vars qw($fh @fh %fh); - -eval 'opendir(NOSUCH, "no/such/directory");'; -skip_all($@) if $@; -plan (tests => 13); - -for my $i (1..2000) { - local *OP; - opendir(OP, "t/CORE/op") or die "can't opendir: $!"; - # should auto-closedir() here -} - -is(opendir(OP, "t/CORE/op"), 1); -my @D = grep(/^[^\.].*\.t$/i, readdir(OP)); -closedir(OP); - -my $expect; -{ - while () { - ++$expect if m!^t/CORE/op/[^/]+!; - } -} - -my ($min, $max) = ($expect - 10, $expect + 10); -within(scalar @D, $expect, 10, 'counting op/*.t'); - -my @R = sort @D; -my @G = sort ; -if ($G[0] =~ m#.*\](\w+\.t)#i) { - # grep is to convert filespecs returned from glob under VMS to format - # identical to that returned by readdir - @G = grep(s#.*\](\w+\.t).*#op/$1#i,); -} -while (@R && @G && $G[0] eq 't/CORE/op/'.$R[0]) { - shift(@R); - shift(@G); -} -is(scalar @R, 0, 'readdir results all accounted for'); -is(scalar @G, 0, 'glob results all accounted for'); - -is(opendir($fh, "t/CORE/op"), 1); -is(ref $fh, 'GLOB'); -is(opendir($fh[0], "t/CORE/op"), 1); -is(ref $fh[0], 'GLOB'); -is(opendir($fh{abc}, "t/CORE/op"), 1); -is(ref $fh{abc}, 'GLOB'); -isnt("$fh", "$fh[0]"); -isnt("$fh", "$fh{abc}"); - -# See that perl does not segfault upon readdir($x="."); -# http://rt.perl.org/rt3/Ticket/Display.html?id=68182 -fresh_perl_like(<<'EOP', qr/^$|^Bad symbol for dirhandle at/, {}, 'RT #68182 - perlcc adjusted'); - my $x = "."; - my @files = readdir($x); -EOP - -#done_testing(); - -__DATA__ -t/CORE/op/64bitint.t -t/CORE/op/alarm.t -t/CORE/op/anonsub.t -t/CORE/op/append.t -t/CORE/op/args.t -t/CORE/op/arith.t -t/CORE/op/array_base.t -t/CORE/op/array.t -t/CORE/op/assignwarn.t -t/CORE/op/attrhand.t -t/CORE/op/attrs.t -t/CORE/op/auto.t -t/CORE/op/avhv.t -t/CORE/op/bless.t -t/CORE/op/blocks.subtest.t -t/CORE/op/blocks.t -t/CORE/op/bop.t -t/CORE/op/caller.t -t/CORE/op/chars.t -t/CORE/op/chdir.t -t/CORE/op/chop.t -t/CORE/op/chr.t -t/CORE/op/closure.subtest.t -t/CORE/op/closure.t -t/CORE/op/cmp.t -t/CORE/op/concat2.subtest.t -t/CORE/op/concat2.t -t/CORE/op/concat.t -t/CORE/op/cond.t -t/CORE/op/context.t -t/CORE/op/cproto.t -t/CORE/op/crypt.t -t/CORE/op/dbm.subtest.t -t/CORE/op/dbm.t -t/CORE/op/defins.t -t/CORE/op/delete.t -t/CORE/op/die_except.t -t/CORE/op/die_exit.t -t/CORE/op/die_keeperr.t -t/CORE/op/die.t -t/CORE/op/die_unwind.t -t/CORE/op/dor.t -t/CORE/op/do.t -t/CORE/op/each_array.t -t/CORE/op/each.t -t/CORE/op/eval.subtest.t -t/CORE/op/eval.t -t/CORE/op/exec.t -t/CORE/op/exists_sub.t -t/CORE/op/exp.t -t/CORE/op/fh.t -t/CORE/op/filehandle.t -t/CORE/op/filetest_stack_ok.t -t/CORE/op/filetest.t -t/CORE/op/filetest_t.t -t/CORE/op/flip.t -t/CORE/op/fork.t -t/CORE/op/getpid.t -t/CORE/op/getppid.t -t/CORE/op/gmagic.t -t/CORE/op/goto.t -t/CORE/op/grent.t -t/CORE/op/grep.t -t/CORE/op/groups.t -t/CORE/op/gv.t -t/CORE/op/hashassign.t -t/CORE/op/hash.t -t/CORE/op/hashwarn.t -t/CORE/op/inccode.t -t/CORE/op/inccode-tie.t -t/CORE/op/incfilter.t -t/CORE/op/inc.t -t/CORE/op/index.subtest.t -t/CORE/op/index.t -t/CORE/op/index_thr.t -t/CORE/op/int.t -t/CORE/op/join.t -t/CORE/op/kill0.t -t/CORE/op/lc.t -t/CORE/op/lc_user.t -t/CORE/op/leaky-magic.subtest.t -t/CORE/op/leaky-magic.t -t/CORE/op/length.t -t/CORE/op/lex_assign.t -t/CORE/op/lex.t -t/CORE/op/lfs.t -t/CORE/op/list.t -t/CORE/op/localref.t -t/CORE/op/local.t -t/CORE/op/loopctl.t -t/CORE/op/lop.t -t/CORE/op/magic-27839.t -t/CORE/op/magic_phase.t -t/CORE/op/magic.subtest.t -t/CORE/op/magic.t -t/CORE/op/method.t -t/CORE/op/mkdir.t -t/CORE/op/mydef.t -t/CORE/op/my_stash.t -t/CORE/op/my.t -t/CORE/op/negate.t -t/CORE/op/not.t -t/CORE/op/numconvert.t -t/CORE/op/oct.t -t/CORE/op/ord.t -t/CORE/op/or.t -t/CORE/op/overload_integer.t -t/CORE/op/override.t -t/CORE/op/packagev.t -t/CORE/op/pack.t -t/CORE/op/pos.t -t/CORE/op/pow.t -t/CORE/op/print.subtest.t -t/CORE/op/print.t -t/CORE/op/protowarn.t -t/CORE/op/push.t -t/CORE/op/pwent.t -t/CORE/op/qq.t -t/CORE/op/qr.t -t/CORE/op/quotemeta.t -t/CORE/op/rand.t -t/CORE/op/range.t -t/CORE/op/readdir.subtest.t -t/CORE/op/readdir.t -t/CORE/op/readline.subtest.t -t/CORE/op/readline.t -t/CORE/op/read.t -t/CORE/op/recurse.t -t/CORE/op/ref.subtest.t -t/CORE/op/ref.t -t/CORE/op/repeat.t -t/CORE/op/require_errors.t -t/CORE/op/reset.t -t/CORE/op/reverse.t -t/CORE/op/runlevel.t -t/CORE/op/setpgrpstack.t -t/CORE/op/sigdispatch.t -t/CORE/op/sleep.t -t/CORE/op/smartkve.t -t/CORE/op/smartmatch.t -t/CORE/op/sort.t -t/CORE/op/splice.t -t/CORE/op/split.t -t/CORE/op/split_unicode.t -t/CORE/op/sprintf2.subtest.t -t/CORE/op/sprintf2.t -t/CORE/op/sprintf.t -t/CORE/op/srand.t -t/CORE/op/sselect.t -t/CORE/op/stash.subtest.t -t/CORE/op/stash.t -t/CORE/op/state.t -t/CORE/op/stat.t -t/CORE/op/study.t -t/CORE/op/studytied.t -t/CORE/op/sub_lval.subtest.t -t/CORE/op/sub_lval.t -t/CORE/op/sub.t -t/CORE/op/svleak.t -t/CORE/op/switch.t -t/CORE/op/symbolcache.t -t/CORE/op/sysio.t -t/CORE/op/taint.t -t/CORE/op/tiearray.t -t/CORE/op/tie_fetch_count.t -t/CORE/op/tiehandle.t -t/CORE/op/tie.t -t/CORE/op/time_loop.t -t/CORE/op/time.t -t/CORE/op/tr.subtest.t -t/CORE/op/tr.t -t/CORE/op/turkish.t -t/CORE/op/undef.t -t/CORE/op/universal.subtest.t -t/CORE/op/universal.t -t/CORE/op/unshift.t -t/CORE/op/upgrade.t -t/CORE/op/utf8cache.t -t/CORE/op/utf8decode.t -t/CORE/op/utf8magic.t -t/CORE/op/utfhash.t -t/CORE/op/utftaint.t -t/CORE/op/vec.t -t/CORE/op/ver.t -t/CORE/op/wantarray.t -t/CORE/op/warn.subtest.t -t/CORE/op/warn.t -t/CORE/op/while_readdir.t -t/CORE/op/write.t -t/CORE/op/yadayada.t diff --git a/t/CORE/op/readline.t b/t/CORE/op/readline.t deleted file mode 100644 index 2276e2038..000000000 --- a/t/CORE/op/readline.t +++ /dev/null @@ -1,247 +0,0 @@ -#!./perl - -BEGIN { require 't/CORE/test.pl' } - -plan tests => 24; - -# [perl #19566]: sv_gets writes directly to its argument via -# TARG. Test that we respect SvREADONLY. -eval { for (\2) { $_ = } }; -like($@, 'Modification of a read-only value attempted', '[perl #19566]'); - -# [perl #21628] -{ - my $file = tempfile(); - open A,'+>',$file; $a = 3; - is($a .= , 3, '#21628 - $a .= , A eof'); - close A; $a = 4; - is($a .= , 4, '#21628 - $a .= , A closed'); -} - -# [perl #21614]: 82 is chosen to exceed the length for sv_grow in -# do_readline (80) -foreach my $k (1, 82) { - my $result - = runperl (stdin => '', stderr => 1, - prog => "\$x = q(k) x $k; \$a{\$x} = qw(v); \$_ = <> foreach keys %a; print qw(end)", - ); - $result =~ s/\n\z// if $^O eq 'VMS'; - is ($result, "end", '[perl #21614] for length ' . length('k' x $k)); -} - - -foreach my $k (1, 21) { - my $result - = runperl (stdin => ' rules', stderr => 1, - prog => "\$x = q(perl) x $k; \$a{\$x} = q(v); foreach (keys %a) {\$_ .= <>; print}", - ); - $result =~ s/\n\z// if $^O eq 'VMS'; - is ($result, ('perl' x $k) . " rules", 'rcatline to shared sv for length ' . length('perl' x $k)); -} - -foreach my $l (1, 82) { - my $k = $l; - $k = 'k' x $k; - my $copy = $k; - $k = ; - is ($k, "moo\n", 'catline to COW sv for length ' . length $copy); -} - - -foreach my $l (1, 21) { - my $k = $l; - $k = 'perl' x $k; - my $perl = $k; - $k .= ; - is ($k, "$perl rules\n", 'rcatline to COW sv for length ' . length $perl); -} - -use strict; - -open F, '.' and sysread F, $_, 1; -my $err = $! + 0; -close F; - -SKIP: { - skip "you can read directories as plain files", 2 unless( $err ); - - $!=0; - open F, '.' and $_=; - ok( $!==$err && !defined($_) => 'readline( DIRECTORY )' ); - close F; - - $!=0; - { local $/; - open F, '.' and $_=; - ok( $!==$err && !defined($_) => 'readline( DIRECTORY ) slurp mode' ); - close F; - } -} - -fresh_perl_is('print readline', 'foo', - { switches => ['-w'], stdin => 'foo', stderr => 1 }, - 'readline() defaults to *ARGV'); - -# [perl #72720] Test that sv_gets clears any variables that should be -# empty so if the read() aborts with EINTER, the TARG is actually -# cleared. -sub test_eintr_readline { - my ( $fh, $timeout ) = @_; - - # This variable, the TARG for the readline is the core of this - # test. The test is to see that after a my() and a failure in - # readline() has the variable revived old, "dead" values from the - # past or is it still undef like expected. - my $line; - - # Do a readline into $line. - if ( $timeout ) { - - # Do a SIGALARM aborted readline(). The underlying sv_gets() - # from sv.c will use the syscall read() while will exit early - # and return something like EINTR or ERESTARTSYS. - my $timed_out; - my $errno; - eval { - local $SIG{ALRM} = sub { - $timed_out = 1; - die 'abort this timeout'; - }; - alarm $timeout; - undef $!; - $line = readline $fh; - $errno = $!; - alarm 0; - }; - - # The code should have timed out. - if ( ! $timed_out ) { - warn $@ - ? "$@: $errno\n" - : "Interrupted readline() test couldn't get interrupted: $errno"; - } - } - else { - $line = readline $fh; - } - return $line; -} -SKIP: { - - # Connect two handles together. - my ( $in, $out ); - my $piped; - eval { - pipe $in, $out; - $piped = 1; - }; - if ( ! $piped ) { - skip( 2, 'The pipe function is unimplemented' ); - } - - # Make the pipe autoflushing - { - my $old_fh = select $out; - $| = 1; - select $old_fh; - } - - # Only one line is loaded into the pipe. It's written unbuffered - # so I'm confident it'll not be buffered. - syswrite $out, "once\n"; - - # Buggy perls will return the last thing successfully - # returned. Buggy perls will return "once\n" a second (and - # "infinitely" if we desired) as long as the internal read() - # syscall fails. In our case, it fails because the inner my($line) - # retains all its allocated space and buggy perl sets SvPOK to - # make the value valid but before it starts read(). - my $once = test_eintr_readline( $in, 0 ); - is( $once, "once\n", "readline read first line ok" ); - - my $twice; - TODO: { - todo_skip( 'alarm() on Windows does not interrupt system calls' ) if $^O eq 'MSWin32'; - todo_skip( 'readline not interrupted by alarm on VMS -- why?' ) if $^O eq 'VMS'; - $twice = test_eintr_readline( $in, 1 ); - isnt( $twice, "once\n", "readline didn't re-return things when interrupted" ); - } - - TODO: { - todo_skip( 'alarm() on Windows does not interrupt system calls' ) if $^O eq 'MSWin32'; - todo_skip( 'readline not interrupted by alarm on VMS -- why?' ) if $^O eq 'VMS'; - local our $TODO = "bad readline returns '', not undef"; - is( $twice, undef, "readline returned undef when interrupted" ); - } -} - -{ - my $line = 'ascii'; - my ( $in, $out ); - pipe $in, $out; - binmode $in; - binmode $out; - syswrite $out, "...\n"; - $line .= readline $in; - - is( $line, "ascii...\n", 'Appending from ascii to ascii' ); -} - -{ - my $line = "\x{2080} utf8"; - my ( $in, $out ); - pipe $in, $out; - binmode $out; - binmode $in; - syswrite $out, "...\n"; - $line .= readline $in; - - is( $line, "\x{2080} utf8...\n", 'Appending from ascii to utf8' ); -} - -{ - my $line = 'ascii'; - my ( $in, $out ); - pipe $in, $out; - binmode $out, ':utf8'; - binmode $in, ':utf8'; - syswrite $out, "...\n"; - $line .= readline $in; - - is( $line, "ascii...\n", 'Appending from utf8 to ascii' ); -} - -{ - my $line = "\x{2080} utf8";; - my ( $in, $out ); - pipe $in, $out; - binmode $out, ':utf8'; - binmode $in, ':utf8'; - syswrite $out, "\x{2080}...\n"; - $line .= readline $in; - - is( $line, "\x{2080} utf8\x{2080}...\n", 'appending from utf to utf8' ); -} - -my $obj = bless []; -$obj .= ; -like($obj, qr/main=ARRAY.*world/, 'rcatline and refs'); - -# bug #38631 -require Tie::Scalar; -tie our $one, 'Tie::StdScalar', "A: "; -tie our $two, 'Tie::StdScalar', "B: "; -my $junk = $one; -$one .= ; -$two .= ; -is( $one, "A: One\n", "rcatline works with tied scalars" ); -is( $two, "B: Two\n", "rcatline works with tied scalars" ); - -__DATA__ -moo -moo - rules - rules -world -One -Two diff --git a/t/CORE/op/recurse.t b/t/CORE/op/recurse.t deleted file mode 100644 index 3ee2fb2c1..000000000 --- a/t/CORE/op/recurse.t +++ /dev/null @@ -1,145 +0,0 @@ -#!./perl - -# -# test recursive functions. -# - -BEGIN { - *main::curr_test = sub { die "undef" }; -} - -INIT { - unshift @INC, "./lib"; - require 't/CORE/test.pl'; - plan(tests => 28); -} - -use strict; - -sub gcd { - return gcd($_[0] - $_[1], $_[1]) if ($_[0] > $_[1]); - return gcd($_[0], $_[1] - $_[0]) if ($_[0] < $_[1]); - $_[0]; -} - -sub factorial { - $_[0] < 2 ? 1 : $_[0] * factorial($_[0] - 1); -} - -sub fibonacci { - $_[0] < 2 ? 1 : fibonacci($_[0] - 2) + fibonacci($_[0] - 1); -} - -# Highly recursive, highly aggressive. -# Kids, don't try this at home. -# -# For example ackermann(4,1) will take quite a long time. -# It will simply eat away your memory. Trust me. - -sub ackermann { - return $_[1] + 1 if ($_[0] == 0); - return ackermann($_[0] - 1, 1) if ($_[1] == 0); - ackermann($_[0] - 1, ackermann($_[0], $_[1] - 1)); -} - -# Highly recursive, highly boring. - -sub takeuchi { - $_[1] < $_[0] ? - takeuchi(takeuchi($_[0] - 1, $_[1], $_[2]), - takeuchi($_[1] - 1, $_[2], $_[0]), - takeuchi($_[2] - 1, $_[0], $_[1])) - : $_[2]; -} - -is(gcd(1147, 1271), 31, "gcd(1147, 1271) == 31"); - -is(gcd(1908, 2016), 36, "gcd(1908, 2016) == 36"); - -is(factorial(10), 3628800, "factorial(10) == 3628800"); - -is(factorial(factorial(3)), 720, "factorial(factorial(3)) == 720"); - -is(fibonacci(10), 89, "fibonacci(10) == 89"); - -is(fibonacci(fibonacci(7)), 17711, "fibonacci(fibonacci(7)) == 17711"); - -my @ack = qw(1 2 3 4 2 3 4 5 3 5 7 9 5 13 29 61); - -for my $x (0..3) { - for my $y (0..3) { - my $a = ackermann($x, $y); - is($a, shift(@ack), "ackermann($x, $y) == $a"); - } -} - -my ($x, $y, $z) = (18, 12, 6); - -is(takeuchi($x, $y, $z), $z + 1, "takeuchi($x, $y, $z) == $z + 1"); - -{ - sub get_first1 { - get_list1(@_)->[0]; - } - - sub get_list1 { - return [curr_test] unless $_[0]; - my $u = get_first1(0); - [$u]; - } - my $x = get_first1(1); - ok($x, "premature FREETMPS (change 5699)"); -} - -{ - sub get_first2 { - return get_list2(@_)->[0]; - } - - sub get_list2 { - return [curr_test] unless $_[0]; - my $u = get_first2(0); - return [$u]; - } - my $x = get_first2(1); - ok($x, "premature FREETMPS (change 5699)"); -} - -{ - local $^W = 0; # We do not need recursion depth warning. - - sub sillysum { - return $_[0] + ($_[0] > 0 ? sillysum($_[0] - 1) : 0); - } - - is(sillysum(1000), 1000*1001/2, "recursive sum of 1..1000"); -} - -# check ok for recursion depth > 65536 -{ - my $r; - eval { - $r = runperl( - nolib => 1, - stderr => 1, - prog => q{$d=0; $e=1; sub c { ++$d; if ($d > 66000) { $e=0 } else { c(); c() unless $d % 32768 } --$d } c(); exit $e}); - }; - - if ($@) { - # $@ will be undef in this case so the is $r, '' will red-herringly fail, so catch that here and give a more usful error - - # [issue 211] - # we could die *but* then the compiled $@ is somehow magically output and then this output happens, sometimes before the TAP starts when the binary is run under prove - # If we just print to STDERR the $@ does not magically get output but this output still happens before TAP starts when the binary is run under prove - # thus we print (so that the output we expect happens where we expect it all the time) and exit 1 (so that we'll know the test needs attention) - print "\n# could not test recursion since runperl() failed:\n#\t$@\n"; - exit 1; - } - - SKIP: { - skip("Out of memory -- increase your data/heap?", 2) if $r =~ /Out of memory/i; - is($r, '', "64K deep recursion - no output expected"); - is($?, 0, "64K deep recursion - no coredump expected"); - } -} - diff --git a/t/CORE/op/ref.t b/t/CORE/op/ref.t deleted file mode 100644 index b15bef188..000000000 --- a/t/CORE/op/ref.t +++ /dev/null @@ -1,768 +0,0 @@ -#!./perl - -BEGIN { require 't/CORE/test.pl' } - -use strict qw(refs subs); - -plan(217); - -# Test glob operations. - -$bar = "one"; -$foo = "two"; -{ - local(*foo) = *bar; - is($foo, 'one'); -} -is ($foo, 'two'); - -$baz = "three"; -$foo = "four"; -{ - local(*foo) = 'baz'; - is ($foo, 'three'); -} -is ($foo, 'four'); - -$foo = "global"; -{ - local(*foo); - is ($foo, undef); - $foo = "local"; - is ($foo, 'local'); -} -is ($foo, 'global'); - -{ - no strict 'refs'; -# Test fake references. - - $baz = "valid"; - $bar = 'baz'; - $foo = 'bar'; - is ($$$foo, 'valid'); -} - -# Test real references. - -$FOO = \$BAR; -$BAR = \$BAZ; -$BAZ = "hit"; -is ($$$FOO, 'hit'); - -# Test references to real arrays. - -my $test = curr_test(); -@ary = ($test,$test+1,$test+2,$test+3); -$ref[0] = \@a; -$ref[1] = \@b; -$ref[2] = \@c; -$ref[3] = \@d; -for $i (3,1,2,0) { - push(@{$ref[$i]}, "ok $ary[$i]\n"); -} -print @a; -print ${$ref[1]}[0]; -print @{$ref[2]}[0]; -{ - no strict 'refs'; - print @{'d'}; -} -curr_test($test+4); - -# Test references to references. - -$refref = \\$x; -$x = "Good"; -is ($$$refref, 'Good'); - -# Test nested anonymous lists. - -$ref = [[],2,[3,4,5,]]; -is (scalar @$ref, 3); -is ($$ref[1], 2); -is (${$$ref[2]}[2], 5); -is (scalar @{$$ref[0]}, 0); - -is ($ref->[1], 2); -is ($ref->[2]->[0], 3); - -# Test references to hashes of references. - -$refref = \%whatever; -$refref->{"key"} = $ref; -is ($refref->{"key"}->[2]->[0], 3); - -# Test to see if anonymous subarrays spring into existence. - -$spring[5]->[0] = 123; -$spring[5]->[1] = 456; -push(@{$spring[5]}, 789); -is (join(':',@{$spring[5]}), "123:456:789"); - -# Test to see if anonymous subhashes spring into existence. - -@{$spring2{"foo"}} = (1,2,3); -$spring2{"foo"}->[3] = 4; -is (join(':',@{$spring2{"foo"}}), "1:2:3:4"); - -# Test references to subroutines. - -{ - my $called; - sub mysub { $called++; } - $subref = \&mysub; - &$subref; - is ($called, 1); -} - -# Test references to return values of operators (TARGs/PADTMPs) -{ - my @refs; - for("a", "b") { - push @refs, \"$_" - } - is join(" ", map $$_, @refs), "a b", 'refgen+PADTMP'; -} - -$subrefref = \\&mysub2; -is ($$subrefref->("GOOD"), "good"); -sub mysub2 { lc shift } - -# Test REGEXP assignment - -{ - require re; - my $x = qr/x/; - my $str = "$x"; # regex stringification may change - - my $y = $$x; - is ($y, $str, "bare REGEXP stringifies correctly"); - ok (eval { "x" =~ $y }, "bare REGEXP matches correctly"); - - my $z = \$y; - ok (re::is_regexp($z), "new ref to REXEXP passes is_regexp"); - is ($z, $str, "new ref to REGEXP stringifies correctly"); - ok (eval { "x" =~ $z }, "new ref to REGEXP matches correctly"); -} -{ - my ($x, $str); - { - my $y = qr/x/; - $str = "$y"; - $x = $$y; - } - is ($x, $str, "REGEXP keeps a ref to its mother_re"); - ok (eval { "x" =~ $x }, "REGEXP with mother_re still matches"); -} - -# Test the ref operator. - -sub PVBM () { 'foo' } -{ my $dummy = index 'foo', PVBM } - -my $pviv = 1; "$pviv"; -my $pvnv = 1.0; "$pvnv"; -my $x; - -# we don't test -# tied lvalue => SCALAR, as we haven't tested tie yet -# BIND, 'cos we can't create them yet -# REGEXP, 'cos that requires overload or Scalar::Util -# LVALUE ref, 'cos I can't work out how to create one :) - -for ( - [ 'undef', SCALAR => \undef ], - [ 'constant IV', SCALAR => \1 ], - [ 'constant NV', SCALAR => \1.0 ], - [ 'constant PV', SCALAR => \'f' ], - [ 'scalar', SCALAR => \$x ], - [ 'PVIV', SCALAR => \$pviv ], - [ 'PVNV', SCALAR => \$pvnv ], - [ 'PVMG', SCALAR => \$0 ], - [ 'PVBM', SCALAR => \PVBM ], - [ 'vstring', VSTRING => \v1 ], - [ 'ref', REF => \\1 ], - [ 'lvalue', LVALUE => \substr($x, 0, 0) ], - [ 'named array', ARRAY => \@ary ], - [ 'anon array', ARRAY => [ 1 ] ], - [ 'named hash', HASH => \%whatever ], - [ 'anon hash', HASH => { a => 1 } ], - [ 'named sub', CODE => \&mysub, ], - [ 'anon sub', CODE => sub { 1; } ], - [ 'glob', GLOB => \*foo ], - [ 'format', FORMAT => *STDERR{FORMAT} ], # issue 285 -) { - my ($desc, $type, $ref) = @$_; - is (ref $ref, $type, "ref() for ref to $desc"); - like ("$ref", qr/^$type\(0x[0-9a-f]+\)$/, "stringify for ref to $desc"); -} - -is (ref *STDOUT{IO}, 'IO::File', 'IO refs are blessed into IO::File'); -like (*STDOUT{IO}, qr/^IO::File=IO\(0x[0-9a-f]+\)$/, - 'stringify for IO refs'); - -# Test anonymous hash syntax. - -$anonhash = {}; -is (ref $anonhash, 'HASH'); -$anonhash2 = {FOO => 'BAR', ABC => 'XYZ',}; -is (join('', sort values %$anonhash2), 'BARXYZ'); - -# Test bless operator. - -package MYHASH; - -$object = bless $main'anonhash2; -main::is (ref $object, 'MYHASH'); -main::is ($object->{ABC}, 'XYZ'); - -$object2 = bless {}; -main::is (ref $object2, 'MYHASH'); - -# Test ordinary call on object method. - -&mymethod($object,"argument"); - -sub mymethod { - local($THIS, @ARGS) = @_; - die 'Got a "' . ref($THIS). '" instead of a MYHASH' - unless ref $THIS eq 'MYHASH'; - main::is ($ARGS[0], "argument"); - main::is ($THIS->{FOO}, 'BAR'); -} - -# Test automatic destructor call. - -$string = "bad"; -$object = "foo"; -$string = "good"; -$main'anonhash2 = "foo"; -$string = ""; - -DESTROY { - return unless $string; - main::is ($string, 'good'); - - # Test that the object has not already been "cursed". - main::isnt (ref shift, 'HASH'); -} - -# Now test inheritance of methods. - -package OBJ; - -@ISA = ('BASEOBJ'); - -$main'object = bless {FOO => 'foo', BAR => 'bar'}; - -package main; - -# Test arrow-style method invocation. - -is ($object->doit("BAR"), 'bar'); - -# Test indirect-object-style method invocation. - -$foo = doit $object "FOO"; -main::is ($foo, 'foo'); - -sub BASEOBJ'doit { - local $ref = shift; - die "Not an OBJ" unless ref $ref eq 'OBJ'; - $ref->{shift()}; -} - -package UNIVERSAL; -@ISA = 'LASTCHANCE'; - -package LASTCHANCE; -sub foo { main::is ($_[1], 'works') } - -package WHATEVER; -foo WHATEVER "works"; - -# -# test the \(@foo) construct -# -package main; -@foo = \(1..3); -@bar = \(@foo); -@baz = \(1,@foo,@bar); -is (scalar (@bar), 3); -is (scalar grep(ref($_), @bar), 3); -is (scalar (@baz), 3); - -my(@fuu) = \(1..2,3); -my(@baa) = \(@fuu); -my(@bzz) = \(1,@fuu,@baa); -is (scalar (@baa), 3); -is (scalar grep(ref($_), @baa), 3); -is (scalar (@bzz), 3); - -# also, it can't be an lvalue -eval '\\($x, $y) = (1, 2);'; -like ($@, qr/Can\'t modify.*ref.*in.*assignment/); - -# test for proper destruction of lexical objects -$test = curr_test(); -sub larry::DESTROY { print "# larry\nok $test\n"; } -sub curly::DESTROY { print "# curly\nok ", $test + 1, "\n"; } -sub moe::DESTROY { print "# moe\nok ", $test + 2, "\n"; } - -{ - my ($joe, @curly, %larry); - my $moe = bless \$joe, 'moe'; - my $curly = bless \@curly, 'curly'; - my $larry = bless \%larry, 'larry'; - print "# leaving block\n"; -} - -print "# left block\n"; -curr_test($test + 3); - -# another glob test - - -$foo = "garbage"; -{ local(*bar) = "foo" } -$bar = "glob 3"; -local(*bar) = *bar; -is ($bar, "glob 3"); - -$var = "glob 4"; -$_ = \$var; -is ($$_, 'glob 4'); - - -# test if reblessing during destruction results in more destruction -$test = curr_test(); -{ - package A; - sub new { bless {}, shift } - DESTROY { print "# destroying 'A'\nok ", $test + 1, "\n" } - package _B; - sub new { bless {}, shift } - DESTROY { print "# destroying '_B'\nok $test\n"; bless shift, 'A' } - package main; - my $b = _B->new; -} -curr_test($test + 2); - -# test if $_[0] is properly protected in DESTROY() - -{ - my $test = curr_test(); - my $i = 0; - # perlcc issue 196 - https://code.google.com/p/perl-compiler/issues/detail?id=196 - # eval block solve that - local $SIG{'__DIE__'} = sub { - my $m = shift; - if ($i++ > 4) { - print "# infinite recursion, bailing\nnot ok $test\n"; - exit 1; - } - like ($m, qr{^Modification of a read-only}); - }; - package C2; - sub new { bless {}, shift } - DESTROY { $_[0] = 'foo' } - { - print "# should generate an error...\n"; - my $c = C2->new; - } - print "# good, didn't recurse\n"; -} - -# test that DESTROY is called on all objects during global destruction, -# even those without hard references [perl #36347] - -$TODO = 'bug #36347'; -is( - runperl( - stderr => 1, prog => 'sub DESTROY { print qq-aaa\n- } bless \$a[0]' - ), - "aaa\n", 'DESTROY called on array elem' -); -is( - runperl( - stderr => 1, - prog => '{ bless \my@x; *a=sub{@x}}sub DESTROY { print qq-aaa\n- }' - ), - "aaa\n", - 'DESTROY called on closure variable' -); -$TODO = undef; - -# test if refgen behaves with autoviv magic -{ - my @a; - $a[1] = "good"; - my $got; - for (@a) { - $got .= ${\$_}; - $got .= ';'; - } - is ($got, ";good;"); -} - -# This test is the reason for postponed destruction in sv_unref -$a = [1,2,3]; -$a = $a->[1]; -is ($a, 2); - -# This test used to coredump. The BEGIN block is important as it causes the -# op that created the constant reference to be freed. Hence the only -# reference to the constant string "pass" is in $a. The hack that made -# sure $a = $a->[1] would work didn't work with references to constants. - - -foreach my $lexical ('', 'my $a; ') { - my $expect = "pass\n"; - my $result = runperl (switches => ['-wl'], stderr => 1, - prog => $lexical . 'BEGIN {$a = \q{pass}}; $a = $$a; print $a'); - - is ($?, 0); - is ($result, $expect); -} - -$test = curr_test(); -sub x::DESTROY {print "ok ", $test + shift->[0], "\n"} -{ my $a1 = bless [3],"x"; - my $a2 = bless [2],"x"; - { my $a3 = bless [1],"x"; - my $a4 = bless [0],"x"; - 567; - } -} -curr_test($test+4); - -is (runperl (switches=>['-l'], - prog=> 'print 1; print qq-*$\*-;print 1;'), - "1\n*\n*\n1\n"); - -# bug #21347 - -runperl(prog => 'sub UNIVERSAL::AUTOLOAD { qr// } a->p' ); -is ($?, 0, 'UNIVERSAL::AUTOLOAD called when freeing qr//'); - -runperl(prog => 'sub UNIVERSAL::DESTROY { warn } bless \$a, A', stderr => 1); -is ($?, 0, 'warn called inside UNIVERSAL::DESTROY'); - - -# bug #22719 - -runperl(prog => 'sub f { my $x = shift; *z = $x; } f({}); f();'); -is ($?, 0, 'coredump on typeglob = (SvRV && !SvROK)'); - -# bug #27268: freeing self-referential typeglobs could trigger -# "Attempt to free unreferenced scalar" warnings - -is (runperl( - prog => 'use Symbol;my $x=bless \gensym,q{t}; print;*$$x=$x', - stderr => 1 -), '', 'freeing self-referential typeglob'); - -# using a regex in the destructor for STDOUT segfaulted because the -# REGEX pad had already been freed (ithreads build only). The -# object is required to trigger the early freeing of GV refs to to STDOUT - -TODO: { - local $TODO = "works but output through pipe is mangled" if $^O eq 'VMS'; - like (runperl( - prog => '$x=bless[]; sub IO::Handle::DESTROY{$_=q{bad};s/bad/ok/;print}', - stderr => 1 - ), qr/^(ok)+$/, 'STDOUT destructor'); -} - -TODO: { - no strict 'refs'; - $name8 = chr 163; - $name_utf8 = $name8 . chr 256; - chop $name_utf8; - - is ($$name8, undef, 'Nothing before we start'); - is ($$name_utf8, undef, 'Nothing before we start'); - $$name8 = "Pound"; - is ($$name8, "Pound", 'Accessing via 8 bit symref works'); - local $TODO = "UTF8 mangled in symrefs"; - is ($$name_utf8, "Pound", 'Accessing via UTF8 symref works'); -} - -TODO: { - no strict 'refs'; - $name_utf8 = $name = chr 9787; - utf8::encode $name_utf8; - - is (length $name, 1, "Name is 1 char"); - is (length $name_utf8, 3, "UTF8 representation is 3 chars"); - - is ($$name, undef, 'Nothing before we start'); - is ($$name_utf8, undef, 'Nothing before we start'); - $$name = "Face"; - is ($$name, "Face", 'Accessing via Unicode symref works'); - local $TODO = "UTF8 mangled in symrefs"; - is ($$name_utf8, undef, - 'Accessing via the UTF8 byte sequence gives nothing'); -} - -{ - no strict 'refs'; - $name1 = "\0Chalk"; - $name2 = "\0Cheese"; - - isnt ($name1, $name2, "They differ"); - - is ($$name1, undef, 'Nothing before we start (scalars)'); - is ($$name2, undef, 'Nothing before we start'); - $$name1 = "Yummy"; - is ($$name1, "Yummy", 'Accessing via the correct name works'); - is ($$name2, undef, - 'Accessing via a different NUL-containing name gives nothing'); - # defined uses a different code path - ok (defined $$name1, 'defined via the correct name works'); - ok (!defined $$name2, - 'defined via a different NUL-containing name gives nothing'); - - is ($name1->[0], undef, 'Nothing before we start (arrays)'); - is ($name2->[0], undef, 'Nothing before we start'); - $name1->[0] = "Yummy"; - is ($name1->[0], "Yummy", 'Accessing via the correct name works'); - is ($name2->[0], undef, - 'Accessing via a different NUL-containing name gives nothing'); - ok (defined $name1->[0], 'defined via the correct name works'); - ok (!defined$name2->[0], - 'defined via a different NUL-containing name gives nothing'); - - my (undef, $one) = @{$name1}[2,3]; - my (undef, $two) = @{$name2}[2,3]; - is ($one, undef, 'Nothing before we start (array slices)'); - is ($two, undef, 'Nothing before we start'); - @{$name1}[2,3] = ("Very", "Yummy"); - (undef, $one) = @{$name1}[2,3]; - (undef, $two) = @{$name2}[2,3]; - is ($one, "Yummy", 'Accessing via the correct name works'); - is ($two, undef, - 'Accessing via a different NUL-containing name gives nothing'); - ok (defined $one, 'defined via the correct name works'); - ok (!defined $two, - 'defined via a different NUL-containing name gives nothing'); - - is ($name1->{PWOF}, undef, 'Nothing before we start (hashes)'); - is ($name2->{PWOF}, undef, 'Nothing before we start'); - $name1->{PWOF} = "Yummy"; - is ($name1->{PWOF}, "Yummy", 'Accessing via the correct name works'); - is ($name2->{PWOF}, undef, - 'Accessing via a different NUL-containing name gives nothing'); - ok (defined $name1->{PWOF}, 'defined via the correct name works'); - ok (!defined $name2->{PWOF}, - 'defined via a different NUL-containing name gives nothing'); - - my (undef, $one) = @{$name1}{'SNIF', 'BEEYOOP'}; - my (undef, $two) = @{$name2}{'SNIF', 'BEEYOOP'}; - is ($one, undef, 'Nothing before we start (hash slices)'); - is ($two, undef, 'Nothing before we start'); - @{$name1}{'SNIF', 'BEEYOOP'} = ("Very", "Yummy"); - (undef, $one) = @{$name1}{'SNIF', 'BEEYOOP'}; - (undef, $two) = @{$name2}{'SNIF', 'BEEYOOP'}; - is ($one, "Yummy", 'Accessing via the correct name works'); - is ($two, undef, - 'Accessing via a different NUL-containing name gives nothing'); - ok (defined $one, 'defined via the correct name works'); - ok (!defined $two, - 'defined via a different NUL-containing name gives nothing'); - - $name1 = "Left"; $name2 = "Left\0Right"; - my $glob2 = *{$name2}; - - is ($glob1, undef, "We get different typeglobs. In fact, undef"); - - *{$name1} = sub {"One"}; - *{$name2} = sub {"Two"}; - - is (&{$name1}, "One"); - is (&{$name2}, "Two"); -} - -# test derefs after list slice - -is ( ({foo => "bar"})[0]{foo}, "bar", 'hash deref from list slice w/o ->' ); -is ( ({foo => "bar"})[0]->{foo}, "bar", 'hash deref from list slice w/ ->' ); -is ( ([qw/foo bar/])[0][1], "bar", 'array deref from list slice w/o ->' ); -is ( ([qw/foo bar/])[0]->[1], "bar", 'array deref from list slice w/ ->' ); -is ( (sub {"bar"})[0](), "bar", 'code deref from list slice w/o ->' ); -is ( (sub {"bar"})[0]->(), "bar", 'code deref from list slice w/ ->' ); - -# deref on empty list shouldn't autovivify -{ - local $@; - eval { ()[0]{foo} }; - like ( "$@", "Can't use an undefined value as a HASH reference", - "deref of undef from list slice fails" ); -} - -# test dereferencing errors -{ - format STDERR = -. - my $ref; - foreach $ref (*STDOUT{IO}, *STDERR{FORMAT}) { # issue 286 - eval q/ $$ref /; - like($@, qr/Not a SCALAR reference/, "Scalar dereference"); - eval q/ @$ref /; - like($@, qr/Not an ARRAY reference/, "Array dereference"); - eval q/ %$ref /; - like($@, qr/Not a HASH reference/, "Hash dereference"); - eval q/ &$ref /; - like($@, qr/Not a CODE reference/, "Code dereference"); - } - - $ref = *STDERR{FORMAT}; - eval q/ *$ref /; - like($@, qr/Not a GLOB reference/, "Glob dereference"); - - $ref = *STDOUT{IO}; - eval q/ *$ref /; - is($@, '', "Glob dereference of PVIO is acceptable"); - - is($ref, *{$ref}{IO}, "IO slot of the temporary glob is set correctly"); -} - -# these will segfault if they fail - -my $pvbm = PVBM; -my $rpvbm = \$pvbm; - -ok (!eval { *$rpvbm }, 'PVBM ref is not a GLOB ref'); -ok (!eval { *$pvbm }, 'PVBM is not a GLOB ref'); -ok (!eval { $$pvbm }, 'PVBM is not a SCALAR ref'); -ok (!eval { @$pvbm }, 'PVBM is not an ARRAY ref'); -ok (!eval { %$pvbm }, 'PVBM is not a HASH ref'); -ok (!eval { $pvbm->() }, 'PVBM is not a CODE ref'); -ok (!eval { $rpvbm->foo }, 'PVBM is not an object'); - -# bug 24254 -is( runperl(stderr => 1, prog => 'map eval qq(exit),1 for 1'), ""); -is( runperl(stderr => 1, prog => 'eval { for (1) { map { die } 2 } };'), ""); -is( runperl(stderr => 1, prog => 'for (125) { map { exit } (213)}'), ""); -my $hushed = $^O eq 'VMS' ? 'use vmsish qw(hushed);' : ''; -is( runperl(stderr => 1, prog => $hushed . 'map die,4 for 3'), "Died at -e line 1.\n"); -is( runperl(stderr => 1, prog => $hushed . 'grep die,4 for 3'), "Died at -e line 1.\n"); -is( runperl(stderr => 1, prog => $hushed . 'for $a (3) {@b=sort {die} 4,5}'), "Died at -e line 1.\n"); - -# bug 57564 -is( runperl(stderr => 1, prog => 'my $i;for $i (1) { for $i (2) { } }'), ""); - -# The mechanism for freeing objects in globs used to leave dangling -# pointers to freed SVs. To test this, we construct this nested structure: -# GV => blessed(AV) => RV => GV => blessed(SV) -# all with a refcnt of 1, and hope that the second GV gets processed first -# by do_clean_named_objs. Then when the first GV is processed, it mustn't -# find anything nasty left by the previous GV processing. -# The eval is stop things in the main body of the code holding a reference -# to a GV, and the print at the end seems to bee necessary to ensure -# the correct freeing order of *x and *y (no, I don't know why - DAPM). - -is (runperl( - prog => 'eval q[bless \@y; bless \$x; $y[0] = \*x; $z = \*y; ]; ' - . 'delete $::{x}; delete $::{y}; print qq{ok\n};', - stderr => 1), - "ok\n", 'freeing freed glob in global destruction'); - - -# Test undefined hash references as arguments to %{} in boolean context -# [perl #81750] -{ - no strict 'refs'; - eval { my $foo; %$foo; }; ok !$@, '%$undef'; - eval { my $foo; scalar %$foo; }; ok !$@, 'scalar %$undef'; - eval { my $foo; !%$foo; }; ok !$@, '!%$undef'; - eval { my $foo; if ( %$foo) {} }; ok !$@, 'if ( %$undef) {}'; - eval { my $foo; if (!%$foo) {} }; ok !$@, 'if (!%$undef) {}'; - eval { my $foo; unless ( %$foo) {} }; ok !$@, 'unless ( %$undef) {}'; - eval { my $foo; unless (!%$foo) {} }; ok !$@, 'unless (!%$undef) {}'; - eval { my $foo; 1 if %$foo; }; ok !$@, '1 if %$undef'; - eval { my $foo; 1 if !%$foo; }; ok !$@, '1 if !%$undef'; - eval { my $foo; 1 unless %$foo; }; ok !$@, '1 unless %$undef;'; - eval { my $foo; 1 unless ! %$foo; }; ok !$@, '1 unless ! %$undef'; - eval { my $foo; %$foo ? 1 : 0; }; ok !$@, ' %$undef ? 1 : 0'; - eval { my $foo; !%$foo ? 1 : 0; }; ok !$@, '!%$undef ? 1 : 0'; -} - -# RT #88330 -# Make sure that a leaked thinggy with multiple weak references to -# it doesn't trigger a panic with multiple rounds of global cleanup -# (Perl_sv_clean_all). - -{ - local $ENV{PERL_DESTRUCT_LEVEL} = 2; - - # we do all permutations of array/hash, 1ref/2ref, to account - # for the different way backref magic is stored - - fresh_perl_is(<<'EOF', 'ok', { stderr => 1 }, 'array with 1 weak ref'); -use Scalar::Util qw(weaken); -my $r = []; -Internals::SvREFCNT(@$r, 9); -my $r1 = $r; -weaken($r1); -print "ok"; -EOF - - fresh_perl_is(<<'EOF', 'ok', { stderr => 1 }, 'array with 2 weak refs'); -use Scalar::Util qw(weaken); -my $r = []; -Internals::SvREFCNT(@$r, 9); -my $r1 = $r; -weaken($r1); -my $r2 = $r; -weaken($r2); -print "ok"; -EOF - - fresh_perl_is(<<'EOF', 'ok', { stderr => 1 }, 'hash with 1 weak ref'); -use Scalar::Util qw(weaken); -my $r = {}; -Internals::SvREFCNT(%$r, 9); -my $r1 = $r; -weaken($r1); -print "ok"; -EOF - - fresh_perl_is(<<'EOF', 'ok', { stderr => 1 }, 'hash with 2 weak refs'); -use Scalar::Util qw(weaken); -my $r = {}; -Internals::SvREFCNT(%$r, 9); -my $r1 = $r; -weaken($r1); -my $r2 = $r; -weaken($r2); -print "ok"; -EOF - -} - -# Bit of a hack to make test.pl happy. There are 3 more tests after it leaves. -$test = curr_test(); -curr_test($test + 3); -# test global destruction - -my $test1 = $test + 1; -my $test2 = $test + 2; - -{ -package FINALE; - -{ - # perlcc issue 197 - https://code.google.com/p/perl-compiler/issues/detail?id=197 - $ref3 = bless ["ok $test2 - package destruction\n"]; # package destruction - my $ref2 = bless ["ok $test1 - lexical destruction\n"]; # lexical destruction - local $ref1 = bless ["ok $test - dynamic destruction\n"]; # dynamic destruction - 1; # flush any temp values on stack -} - -DESTROY { - print $_[0][0]; -} -} - diff --git a/t/CORE/op/repeat.t b/t/CORE/op/repeat.t deleted file mode 100644 index 7bea76836..000000000 --- a/t/CORE/op/repeat.t +++ /dev/null @@ -1,155 +0,0 @@ -#!./perl - -INIT { - unshift @INC, 't/CORE/lib'; - require 't/CORE/test.pl'; -} - -plan(tests => 42); - -# compile time - -is('-' x 5, '-----', 'compile time x'); -is('-' x 3.1, '---', 'compile time 3.1'); -is('-' x 3.9, '---', 'compile time 3.9'); -is('-' x 1, '-', ' x 1'); -is('-' x 0, '', ' x 0'); -is('-' x -1, '', ' x -1'); -is('-' x undef, '', ' x undef'); -is('-' x "foo", '', ' x "foo"'); -is('-' x "3rd", '---', ' x "3rd"'); - -is('ab' x 3, 'ababab', ' more than one char'); - -# run time - -$a = '-'; -is($a x 5, '-----', 'run time x'); -is($a x 3.1, '---', ' x 3.1'); -is($a x 3.9, '---', ' x 3.9'); -is($a x 1, '-', ' x 1'); -is($a x 0, '', ' x 0'); -is($a x -3, '', ' x -3'); -is($a x undef, '', ' x undef'); -is($a x "foo", '', ' x "foo"'); -is($a x "3rd", '---', ' x "3rd"'); - -$a = 'ab'; -is($a x 3, 'ababab', ' more than one char'); -$a = 'ab'; -is($a x 0, '', ' more than one char'); -$a = 'ab'; -is($a x -12, '', ' more than one char'); - -$a = 'xyz'; -$a x= 2; -is($a, 'xyzxyz', 'x=2'); -$a x= 1; -is($a, 'xyzxyz', 'x=1'); -$a x= 0; -is($a, '', 'x=0'); - -@x = (1,2,3); - -is(join('', @x x 4), '3333', '@x x Y'); -is(join('', (@x) x 4), '123123123123', '(@x) x Y'); -is(join('', (@x,()) x 4), '123123123123', '(@x,()) x Y'); -is(join('', (@x,1) x 4), '1231123112311231', '(@x,1) x Y'); -is(join(':', () x 4), '', '() x Y'); -is(join(':', (9) x 4), '9:9:9:9', '(X) x Y'); -is(join(':', (9,9) x 4), '9:9:9:9:9:9:9:9', '(X,X) x Y'); -is(join('', (split(//,"123")) x 2), '123123', 'split and x'); - -is(join('', @x x -12), '', '@x x -12'); -is(join('', (@x) x -14), '', '(@x) x -14'); - - -# This test is actually testing for Digital C compiler optimizer bug, -# present in Dec C versions 5.* and 6.0 (used in Digital UNIX and VMS), -# found in December 1998. The bug was reported to Digital^WCompaq as -# DECC 2745 (21-Dec-1998) -# GEM_BUGS 7619 (23-Dec-1998) -# As of April 1999 the bug has been fixed in Tru64 UNIX 5.0 and is planned -# to be fixed also in 4.0G. -# -# The bug was as follows: broken code was produced for util.c:repeatcpy() -# (a utility function for the 'x' operator) in the case *all* these -# four conditions held: -# -# (1) len == 1 -# (2) "from" had the 8th bit on in its single character -# (3) count > 7 (the 'x' count > 16) -# (4) the highest optimization level was used in compilation -# (which is the default when compiling Perl) -# -# The bug looked like this (. being the eight-bit character and ? being \xff): -# -# 16 ................ -# 17 .........???????. -# 18 .........???????.. -# 19 .........???????... -# 20 .........???????.... -# 21 .........???????..... -# 22 .........???????...... -# 23 .........???????....... -# 24 .........???????.??????? -# 25 .........???????.???????. -# -# The bug was triggered in the "if (len == 1)" branch. The fix -# was to introduce a new temporary variable. In diff -u format: -# -# register char *frombase = from; -# -# if (len == 1) { -#- todo = *from; -#+ register char c = *from; -# while (count-- > 0) -#- *to++ = todo; -#+ *to++ = c; -# return; -# } -# -# The bug could also be (obscurely) avoided by changing "from" to -# be an unsigned char pointer. -# -# This obscure bug was not found by the then test suite but instead -# by Mark.Martinec@nsc.ijs.si while trying to install Digest-MD5-2.00. -# -# jhi@iki.fi -# -is("\xdd" x 24, "\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd", 'Dec C bug'); - - -# When we use a list repeat in a scalar context, it behaves like -# a scalar repeat. Make sure that works properly, and doesn't leave -# extraneous values on the stack. -# -- robin@kitsite.com - -my ($x, $y) = scalar ((1,2)x2); -is($x, "22", 'list repeat in scalar context'); -is($y, undef, ' no extra values on stack'); - -# Make sure the stack doesn't get truncated too much - the left -# operand of the eq binop needs to remain! -is(77, scalar ((1,7)x2), 'stack truncation'); - - -# perlbug 20011113.110 works in 5.6.1, broken in 5.7.2 -{ - my $x= [("foo") x 2]; - is( join('', @$x), 'foofoo', 'list repeat in anon array ref broken [ID 20011113.110]' ); -} - -# [ID 20010809.028] x operator not copying elements in 'for' list? -{ - local $TODO = "x operator not copying elements in 'for' list? [ID 20010809.028]"; - my $x = 'abcd'; - my $y = ''; - for (($x =~ /./g) x 2) { - $y .= chop; - } - is($y, 'abcdabcd'); -} - -# [perl #35885] -is( (join ',', (qw(a b c) x 3)), 'a,b,c,a,b,c,a,b,c', 'x on qw produces list' ); diff --git a/t/CORE/op/require_errors.t b/t/CORE/op/require_errors.t deleted file mode 100644 index 203b6f519..000000000 --- a/t/CORE/op/require_errors.t +++ /dev/null @@ -1,35 +0,0 @@ -#!perl -use strict; -use warnings; - -BEGIN { - require 't/CORE/test.pl'; -} - -plan(tests => 3); - -my $nonfile = tempfile(); - -unshift @INC, "./lib"; - -eval { - require $nonfile; -}; - -like $@, qr/^Can't locate $nonfile in \@INC \(\@INC contains: @INC\) at/; - -eval { - require "$nonfile.ph"; -}; - -like $@, qr/^Can't locate $nonfile\.ph in \@INC \(did you run h2ph\?\) \(\@INC contains: @INC\) at/; - -eval { - require "$nonfile.h"; -}; - -like $@, qr/^Can't locate $nonfile\.h in \@INC \(change \.h to \.ph maybe\?\) \(did you run h2ph\?\) \(\@INC contains: @INC\) at/; - -# I can't see how to test the EMFILE case -# I can't see how to test the case of not displaying @INC in the message. -# (and does that only happen on VMS?) diff --git a/t/CORE/op/reset.t b/t/CORE/op/reset.t deleted file mode 100644 index a95d75c08..000000000 --- a/t/CORE/op/reset.t +++ /dev/null @@ -1,135 +0,0 @@ -#!./perl -w - -BEGIN { - *main::skip = sub { die "undef" }; -} - -INIT { - unshift @INC, 't/CORE/lib'; - require 't/CORE/test.pl'; -} -use strict; - -# Currently only testing the reset of patterns. -plan( tests => 24 ); - -package aiieee; - -sub zlopp { - (shift =~ m?zlopp?) ? 1 : 0; -} - -sub reset_zlopp { - reset; -} - -package CLINK; - -sub ZZIP { - shift =~ m?ZZIP? ? 1 : 0; -} - -sub reset_ZZIP { - reset; -} - -package main; - -is(aiieee::zlopp(""), 0, "mismatch doesn't match"); -is(aiieee::zlopp("zlopp"), 1, "match matches first time"); -is(aiieee::zlopp(""), 0, "mismatch doesn't match"); -is(aiieee::zlopp("zlopp"), 0, "match doesn't match second time"); -aiieee::reset_zlopp(); -is(aiieee::zlopp("zlopp"), 1, "match matches after reset"); -is(aiieee::zlopp(""), 0, "mismatch doesn't match"); - -aiieee::reset_zlopp(); - -is(aiieee::zlopp(""), 0, "mismatch doesn't match"); -is(aiieee::zlopp("zlopp"), 1, "match matches first time"); -is(CLINK::ZZIP(""), 0, "mismatch doesn't match"); -is(CLINK::ZZIP("ZZIP"), 1, "match matches first time"); -is(CLINK::ZZIP(""), 0, "mismatch doesn't match"); -is(CLINK::ZZIP("ZZIP"), 0, "match doesn't match second time"); -is(aiieee::zlopp(""), 0, "mismatch doesn't match"); -is(aiieee::zlopp("zlopp"), 0, "match doesn't match second time"); - -aiieee::reset_zlopp(); -is(aiieee::zlopp("zlopp"), 1, "match matches after reset"); -is(aiieee::zlopp(""), 0, "mismatch doesn't match"); - -is(CLINK::ZZIP(""), 0, "mismatch doesn't match"); -is(CLINK::ZZIP("ZZIP"), 0, "match doesn't match third time"); - -CLINK::reset_ZZIP(); -is(CLINK::ZZIP("ZZIP"), 1, "match matches after reset"); -is(CLINK::ZZIP(""), 0, "mismatch doesn't match"); - - -undef $/; -my $prog = ; - -SKIP: -{ - eval {require threads; 1} or - skip "No threads", 4; - foreach my $eight ('/', '?') { - foreach my $nine ('/', '?') { - my $copy = $prog; - $copy =~ s/8/$eight/gm; - $copy =~ s/9/$nine/gm; - fresh_perl_is($copy, "pass", "", - "first pattern $eight$eight, second $nine$nine"); - } - } -} - -__DATA__ -#!perl -use warnings; -use strict; - -# Note that there are no digits in this program, other than the placeholders -sub a { -m8one8; -} -sub b { -m9two9; -} - -use threads; -use threads::shared; - -sub wipe { - eval 'no warnings; sub b {}'; -} - -sub lock_then_wipe { - my $l_r = shift; - lock $$l_r; - cond_wait($$l_r) until $$l_r eq "B"; - wipe; - $$l_r = "C"; - cond_signal $$l_r; -} - -my $lock : shared = "A"; -my $r = \$lock; - -my $t; -{ - lock $$r; - $t = threads->new(\&lock_then_wipe, $r); - wipe; - $lock = "B"; - cond_signal $lock; -} - -{ - lock $lock; - cond_wait($lock) until $lock eq "C"; - reset; -} - -$t->join; -print "pass\n"; diff --git a/t/CORE/op/reverse.t b/t/CORE/op/reverse.t deleted file mode 100644 index d48687506..000000000 --- a/t/CORE/op/reverse.t +++ /dev/null @@ -1,104 +0,0 @@ -#!./perl - -BEGIN { - unshift @INC, 't/CORE/lib'; - require 't/CORE/test.pl'; -} - -plan tests => 26; - -is(reverse("abc"), "cba"); - -$_ = "foobar"; -is(reverse(), "raboof"); - -{ - my @a = ("foo", "bar"); - my @b = reverse @a; - - is($b[0], $a[1]); - is($b[1], $a[0]); -} - -{ - my @a = (1, 2, 3, 4); - @a = reverse @a; - is("@a", "4 3 2 1"); - - delete $a[1]; - @a = reverse @a; - ok(!exists $a[2]); - is($a[0] . $a[1] . $a[3], '124'); - - @a = (5, 6, 7, 8, 9); - @a = reverse @a; - is("@a", "9 8 7 6 5"); - - delete $a[3]; - @a = reverse @a; - ok(!exists $a[1]); - is($a[0] . $a[2] . $a[3] . $a[4], '5789'); - - delete $a[2]; - @a = reverse @a; - ok(!exists $a[2] && !exists $a[3]); - is($a[0] . $a[1] . $a[4], '985'); - - my @empty; - @empty = reverse @empty; - is("@empty", ""); -} - -use Tie::Array; - -{ - tie my @a, 'Tie::StdArray'; - - @a = (1, 2, 3, 4); - @a = reverse @a; - is("@a", "4 3 2 1"); - - delete $a[1]; - @a = reverse @a; - ok(!exists $a[2]); - is($a[0] . $a[1] . $a[3], '124'); - - @a = (5, 6, 7, 8, 9); - @a = reverse @a; - is("@a", "9 8 7 6 5"); - - delete $a[3]; - @a = reverse @a; - ok(!exists $a[1]); - is($a[0] . $a[2] . $a[3] . $a[4], '5789'); - - delete $a[2]; - @a = reverse @a; - ok(!exists $a[2] && !exists $a[3]); - is($a[0] . $a[1] . $a[4], '985'); - - tie my @empty, "Tie::StdArray"; - @empty = reverse @empty; - is(scalar(@empty), 0); -} - -{ - # Unicode. - - my $a = "\x{263A}\x{263A}x\x{263A}y\x{263A}"; - my $b = scalar reverse($a); - my $c = scalar reverse($b); - is($a, $c); -} - -{ - # Lexical $_. - sub blurp { my $_ = shift; reverse } - - is(blurp("foo"), "oof"); - is(sub { my $_ = shift; reverse }->("bar"), "rab"); - { - local $_ = "XXX"; - is(blurp("paz"), "zap"); - } -} diff --git a/t/CORE/op/runlevel.t b/t/CORE/op/runlevel.t deleted file mode 100644 index f4edc99e7..000000000 --- a/t/CORE/op/runlevel.t +++ /dev/null @@ -1,367 +0,0 @@ -#!./perl - -## -## Many of these tests are originally from Michael Schroeder -## -## Adapted and expanded by Gurusamy Sarathy -## - -unshift @INC, 't/CORE/lib'; -require 't/CORE/test.pl'; - -$|=1; - -run_multiple_progs('', \*DATA); - -done_testing(); - -__END__ -@a = (1, 2, 3); -{ - @a = sort { last ; } @a; -} -EXPECT -Can't "last" outside a loop block at - line 3. -######## -package TEST; - -sub TIESCALAR { - my $foo; - return bless \$foo; -} -sub FETCH { - eval 'die("test")'; - print "still in fetch\n"; - return ">$@<"; -} -package main; - -tie $bar, TEST; -print "- $bar\n"; -EXPECT -still in fetch -- >test at (eval 1) line 1. -< -######## -package TEST; - -sub TIESCALAR { - my $foo; - eval('die("foo\n")'); - print "after eval\n"; - return bless \$foo; -} -sub FETCH { - return "ZZZ"; -} - -package main; - -tie $bar, TEST; -print "- $bar\n"; -print "OK\n"; -EXPECT -after eval -- ZZZ -OK -######## -package TEST; - -sub TIEHANDLE { - my $foo; - return bless \$foo; -} -sub PRINT { -print STDERR "PRINT CALLED\n"; -(split(/./, 'x'x10000))[0]; -eval('die("test\n")'); -} - -package main; - -open FH, ">&STDOUT"; -tie *FH, TEST; -print FH "OK\n"; -print STDERR "DONE\n"; -EXPECT -PRINT CALLED -DONE -######## -sub warnhook { - print "WARNHOOK\n"; - eval('die("foooo\n")'); -} -$SIG{'__WARN__'} = 'warnhook'; -warn("dfsds\n"); -print "END\n"; -EXPECT -WARNHOOK -END -######## -package TEST; - -use overload - "\"\"" => \&str -; - -sub str { - eval('die("test\n")'); - return "STR"; -} - -package main; - -$bar = bless {}, TEST; -print "$bar\n"; -print "OK\n"; -EXPECT -STR -OK -######## -sub foo { - $a <=> $b unless eval('$a == 0 ? bless undef : ($a <=> $b)'); -} -@a = (3, 2, 0, 1); -@a = sort foo @a; -print join(', ', @a)."\n"; -EXPECT -0, 1, 2, 3 -######## -sub foo { - goto bar if $a == 0 || $b == 0; - $a <=> $b; -} -@a = (3, 2, 0, 1); -@a = sort foo @a; -print join(', ', @a)."\n"; -exit; -bar: -print "bar reached\n"; -EXPECT -Can't "goto" out of a pseudo block at - line 2. -######## -%seen = (); -sub sortfn { - (split(/./, 'x'x10000))[0]; - my (@y) = ( 4, 6, 5); - @y = sort { $a <=> $b } @y; - my $t = "sortfn ".join(', ', @y)."\n"; - print $t if ($seen{$t}++ == 0); - return $_[0] <=> $_[1]; -} -@x = ( 3, 2, 1 ); -@x = sort { &sortfn($a, $b) } @x; -print "---- ".join(', ', @x)."\n"; -EXPECT -sortfn 4, 5, 6 ----- 1, 2, 3 -######## -@a = (3, 2, 1); -@a = sort { eval('die("no way")') , $a <=> $b} @a; -print join(", ", @a)."\n"; -EXPECT -1, 2, 3 -######## -@a = (1, 2, 3); -foo: -{ - @a = sort { last foo; } @a; -} -EXPECT -Label not found for "last foo" at - line 2. -######## -package TEST; - -sub TIESCALAR { - my $foo; - return bless \$foo; -} -sub FETCH { - next; - return "ZZZ"; -} -sub STORE { -} - -package main; - -tie $bar, TEST; -{ - print "- $bar\n"; -} -print "OK\n"; -EXPECT -Can't "next" outside a loop block at - line 8. -######## -package TEST; - -sub TIESCALAR { - my $foo; - return bless \$foo; -} -sub FETCH { - goto bbb; - return "ZZZ"; -} - -package main; - -tie $bar, TEST; -print "- $bar\n"; -exit; -bbb: -print "bbb\n"; -EXPECT -Can't find label bbb at - line 8. -######## -sub foo { - $a <=> $b unless eval('$a == 0 ? die("foo\n") : ($a <=> $b)'); -} -@a = (3, 2, 0, 1); -@a = sort foo @a; -print join(', ', @a)."\n"; -EXPECT -0, 1, 2, 3 -######## -package TEST; -sub TIESCALAR { - my $foo; - return bless \$foo; -} -sub FETCH { - return "fetch"; -} -sub STORE { -(split(/./, 'x'x10000))[0]; -} -package main; -tie $bar, TEST; -$bar = "x"; -######## -package TEST; -sub TIESCALAR { - my $foo; - next; - return bless \$foo; -} -package main; -{ -tie $bar, TEST; -} -EXPECT -Can't "next" outside a loop block at - line 4. -######## -@a = (1, 2, 3); -foo: -{ - @a = sort { exit(0) } @a; -} -END { print "foobar\n" } -EXPECT -foobar -######## -$SIG{__DIE__} = sub { - print "In DIE\n"; - $i = 0; - while (($p,$f,$l,$s) = caller(++$i)) { - print "$p|$f|$l|$s\n"; - } -}; -eval { die }; -&{sub { eval 'die' }}(); -sub foo { eval { die } } foo(); -{package rmb; sub{ eval{die} } ->() }; # check __ANON__ knows package -EXPECT -In DIE -main|-|8|(eval) -In DIE -main|-|9|(eval) -main|-|9|main::__ANON__ -In DIE -main|-|10|(eval) -main|-|10|main::foo -In DIE -rmb|-|11|(eval) -rmb|-|11|rmb::__ANON__ -######## -package TEST; - -sub TIEARRAY { - return bless [qw(foo fee fie foe)], $_[0]; -} -sub FETCH { - my ($s,$i) = @_; - if ($i) { - goto bbb; - } -bbb: - return $s->[$i]; -} - -package main; -tie my @bar, 'TEST'; -print join('|', @bar[0..3]), "\n"; -EXPECT -foo|fee|fie|foe -######## -package TH; -sub TIEHASH { bless {}, TH } -sub STORE { eval { print "@_[1,2]\n" }; die "bar\n" } -tie %h, TH; -eval { $h{A} = 1; print "never\n"; }; -print $@; -eval { $h{B} = 2; }; -print $@; -EXPECT -A 1 -bar -B 2 -bar -######## -sub n { 0 } -sub f { my $x = shift; d(); } -f(n()); -f(); - -sub d { - my $i = 0; my @a; - while (do { { package DB; @a = caller($i++) } } ) { - @a = @DB::args; - for (@a) { print "$_\n"; $_ = '' } - } -} -EXPECT -0 -######## -sub TIEHANDLE { bless {} } -sub PRINT { next } - -tie *STDERR, ''; -{ map ++$_, 1 } - -EXPECT -Can't "next" outside a loop block at - line 2. -######## -sub TIEHANDLE { bless {} } -sub PRINT { print "[TIE] $_[1]" } - -tie *STDERR, ''; -die "DIE\n"; - -EXPECT -[TIE] DIE -######## -sub TIEHANDLE { bless {} } -sub PRINT { - (split(/./, 'x'x10000))[0]; - eval('die("test\n")'); - warn "[TIE] $_[1]"; -} -open OLDERR, '>&STDERR'; -tie *STDERR, ''; - -use warnings FATAL => qw(uninitialized); -print undef; - -EXPECT -[TIE] Use of uninitialized value in print at - line 11. diff --git a/t/CORE/op/setpgrpstack.t b/t/CORE/op/setpgrpstack.t deleted file mode 100644 index a14b56dc5..000000000 --- a/t/CORE/op/setpgrpstack.t +++ /dev/null @@ -1,15 +0,0 @@ -#!./perl -w - -BEGIN { - unshift @INC, 't/CORE/lib'; - require 't/CORE/test.pl'; -} - -use Config; -plan tests => 2; - -SKIP: { - skip "setpgrp() is not available", 2 unless $Config{d_setpgrp}; - ok(!eval { package A;sub foo { die("got here") }; package main; A->foo(setpgrp())}); - ok($@ =~ /got here/, "setpgrp() should extend the stack before modifying it"); -} diff --git a/t/CORE/op/sigdispatch.t b/t/CORE/op/sigdispatch.t deleted file mode 100644 index e4510ad65..000000000 --- a/t/CORE/op/sigdispatch.t +++ /dev/null @@ -1,122 +0,0 @@ -#!perl -w - -# We assume that TestInit has been used. - -BEGIN { - require 't/CORE/test.pl'; -} - -use strict; -use Config; - -plan tests => 17; - -watchdog(15); - -# perlcc issue 168 - https://code.google.com/p/perl-compiler/issues/detail?id=168 -$SIG{ALRM} = sub { - die "Alarm!\n"; -}; - -pass('before the first loop'); - -alarm 2; - -eval { - 1 while 1; -}; - -is($@, "Alarm!\n", 'after the first loop'); - -pass('before the second loop'); - -alarm 2; - -eval { - while (1) { - } -}; - -is($@, "Alarm!\n", 'after the second loop'); - -SKIP: { - skip('We can\'t test blocking without sigprocmask', 11) - if !$Config{d_sigprocmask}; - skip('This doesn\'t work on OpenBSD threaded builds RT#88814', 11) - if $^O eq 'openbsd' && $Config{useithreads}; - - require POSIX; - my $new = POSIX::SigSet->new(&POSIX::SIGUSR1); - POSIX::sigprocmask(&POSIX::SIG_BLOCK, $new); - - my $gotit = 0; - $SIG{USR1} = sub { $gotit++ }; - kill SIGUSR1, $$; - is $gotit, 0, 'Haven\'t received third signal yet'; - - my $old = POSIX::SigSet->new(); - POSIX::sigsuspend($old); - is $gotit, 1, 'Received third signal'; - - { - kill SIGUSR1, $$; - local $SIG{USR1} = sub { die "FAIL\n" }; - POSIX::sigprocmask(&POSIX::SIG_BLOCK, undef, $old); - ok $old->ismember(&POSIX::SIGUSR1), 'SIGUSR1 is blocked'; - eval { POSIX::sigsuspend(POSIX::SigSet->new) }; - is $@, "FAIL\n", 'Exception is thrown, so received fourth signal'; - POSIX::sigprocmask(&POSIX::SIG_BLOCK, undef, $old); -TODO: - { - local $::TODO = "Needs investigation" if $^O eq 'VMS'; - ok $old->ismember(&POSIX::SIGUSR1), 'SIGUSR1 is still blocked'; - } - } - -TODO: - { - local $::TODO = "Needs investigation" if $^O eq 'VMS'; - kill SIGUSR1, $$; - is $gotit, 1, 'Haven\'t received fifth signal yet'; - POSIX::sigprocmask(&POSIX::SIG_UNBLOCK, $new, $old); - ok $old->ismember(&POSIX::SIGUSR1), 'SIGUSR1 was still blocked'; - } - is $gotit, 2, 'Received fifth signal'; - - # test unsafe signal handlers in combination with exceptions - my $action = POSIX::SigAction->new(sub { $gotit--, die }, POSIX::SigSet->new, 0); - POSIX::sigaction(&POSIX::SIGALRM, $action); - eval { - alarm 1; - my $set = POSIX::SigSet->new; - POSIX::sigprocmask(&POSIX::SIG_BLOCK, undef, $set); - is $set->ismember(&POSIX::SIGALRM), 0, "SIGALRM is not blocked on attempt $_"; - POSIX::sigsuspend($set); - } for 1..2; - is $gotit, 0, 'Received both signals'; -} - -SKIP: { - skip("alarm cannot interrupt blocking system calls on $^O", 2) - if ($^O eq 'MSWin32' || $^O eq 'VMS'); - # RT #88774 - # make sure the signal handler's called in an eval block *before* - # the eval is popped - - # perlcc issue 168 - https://code.google.com/p/perl-compiler/issues/detail?id=168 - $SIG{'ALRM'} = sub { die "HANDLER CALLED\n" }; - - eval { - alarm(2); - select(undef,undef,undef,10); - }; - alarm(0); - is($@, "HANDLER CALLED\n", 'block eval'); - - eval q{ - alarm(2); - select(undef,undef,undef,10); - }; - alarm(0); - is($@, "HANDLER CALLED\n", 'string eval'); -} diff --git a/t/CORE/op/sleep.t b/t/CORE/op/sleep.t deleted file mode 100644 index 5350fee7a..000000000 --- a/t/CORE/op/sleep.t +++ /dev/null @@ -1,21 +0,0 @@ -#!./perl - -INIT { - unshift @INC, "./lib"; - require 't/CORE/test.pl'; -} - -plan( tests => 4 ); - -use strict; -use warnings; - -my $start = time; -my $sleep_says = sleep 3; -my $diff = time - $start; - -cmp_ok( $sleep_says, '>=', 2, 'Sleep says it slept at least 2 seconds' ); -cmp_ok( $sleep_says, '<=', 10, '... and no more than 10' ); - -cmp_ok( $diff, '>=', 2, 'Actual time diff is at least 2 seconds' ); -cmp_ok( $diff, '<=', 10, '... and no more than 10' ); diff --git a/t/CORE/op/smartkve.t b/t/CORE/op/smartkve.t deleted file mode 100644 index d05ae0d29..000000000 --- a/t/CORE/op/smartkve.t +++ /dev/null @@ -1,414 +0,0 @@ -#!./perl - -BEGIN { - unshift @INC, 't/CORE/lib'; - require 't/CORE/test.pl'; -} -use strict; -use warnings; -no warnings 'deprecated'; -use vars qw($data $array $values $hash $errpat); - -plan 'no_plan'; - -sub j { join(":",@_) } - -BEGIN { # in BEGIN for "use constant ..." later - $array = [ qw(pi e i) ]; - $values = [ 3.14, 2.72, -1 ]; - $hash = { pi => 3.14, e => 2.72, i => -1 } ; - $data = { - hash => { %$hash }, - array => [ @$array ], - }; -} - -package Foo; -sub new { - my $self = { - hash => {%{$main::hash} }, - array => [@{$main::array}] - }; - bless $self, shift; -} -sub hash { no overloading; $_[0]->{hash} }; -sub array { no overloading; $_[0]->{array} }; - -package Foo::Overload::Array; -sub new { return bless [ qw/foo bar/ ], shift } -use overload '@{}' => sub { $main::array }, fallback => 1; - -package Foo::Overload::Hash; -sub new { return bless { qw/foo bar/ }, shift } -use overload '%{}' => sub { $main::hash }, fallback => 1; - -package Foo::Overload::Both; -sub new { return bless { qw/foo bar/ }, shift } -use overload '%{}' => sub { $main::hash }, - '@{}' => sub { $main::array }, fallback => 1; - -package Foo::Overload::HashOnArray; -sub new { return bless [ qw/foo bar/ ], shift } -use overload '%{}' => sub { $main::hash }, fallback => 1; - -package Foo::Overload::ArrayOnHash; -sub new { return bless { qw/foo bar/ }, shift } -use overload '@{}' => sub { $main::array }, fallback => 1; - -package main; - -use constant CONST_HASH => { %$hash }; -use constant CONST_ARRAY => [ @$array ]; - -my %a_hash = %$hash; -my @an_array = @$array; -sub hash_sub { return \%a_hash; } -sub array_sub { return \@an_array; } - -my $obj = Foo->new; - -my ($empty, $h_expect, $a_expect, @tmp, @tmp2, $k, $v); - -# Keys -- void - -keys $hash; pass('Void: keys $hash;'); -keys $data->{hash}; pass('Void: keys $data->{hash};'); -keys CONST_HASH; pass('Void: keys CONST_HASH;'); -keys CONST_HASH(); pass('Void: keys CONST_HASH();'); -keys hash_sub(); pass('Void: keys hash_sub();'); -keys hash_sub; pass('Void: keys hash_sub;'); -keys $obj->hash; pass('Void: keys $obj->hash;'); -keys $array; pass('Void: keys $array;'); -keys $data->{array}; pass('Void: keys $data->{array};'); -keys CONST_ARRAY; pass('Void: keys CONST_ARRAY;'); -keys CONST_ARRAY(); pass('Void: keys CONST_ARRAY();'); -keys array_sub; pass('Void: keys array_sub;'); -keys array_sub(); pass('Void: keys array_sub();'); -keys $obj->array; pass('Void: keys $obj->array;'); - -# Keys -- scalar -# perlcc issue 178 - https://code.google.com/p/perl-compiler/issues/detail?id=178 -is(keys $hash ,3, 'Scalar: keys $hash'); -is(keys $data->{hash} ,3, 'Scalar: keys $data->{hash}'); -is(keys CONST_HASH ,3, 'Scalar: keys CONST_HASH'); -is(keys CONST_HASH() ,3, 'Scalar: keys CONST_HASH()'); -is(keys hash_sub ,3, 'Scalar: keys hash_sub'); -is(keys hash_sub() ,3, 'Scalar: keys hash_sub()'); -is(keys $obj->hash ,3, 'Scalar: keys $obj->hash'); -is(keys $array ,3, 'Scalar: keys $array'); -is(keys $data->{array} ,3, 'Scalar: keys $data->{array}'); -is(keys CONST_ARRAY ,3, 'Scalar: keys CONST_ARRAY'); -is(keys CONST_ARRAY() ,3, 'Scalar: keys CONST_ARRAY()'); -is(keys array_sub ,3, 'Scalar: keys array_sub'); -is(keys array_sub() ,3, 'Scalar: keys array_sub()'); -is(keys $obj->array ,3, 'Scalar: keys $obj->array'); - -# Keys -- list - -$h_expect = j(keys %$hash); -$a_expect = j(keys @$array); - -is(j(keys $hash) ,$h_expect, 'List: keys $hash'); -is(j(keys $data->{hash}) ,$h_expect, 'List: keys $data->{hash}'); -is(j(keys CONST_HASH) ,$h_expect, 'List: keys CONST_HASH'); -is(j(keys CONST_HASH()) ,$h_expect, 'List: keys CONST_HASH()'); -is(j(keys hash_sub) ,$h_expect, 'List: keys hash_sub'); -is(j(keys hash_sub()) ,$h_expect, 'List: keys hash_sub()'); -is(j(keys $obj->hash) ,$h_expect, 'List: keys $obj->hash'); -is(j(keys $array) ,$a_expect, 'List: keys $array'); -is(j(keys $data->{array}) ,$a_expect, 'List: keys $data->{array}'); -is(j(keys CONST_ARRAY) ,$a_expect, 'List: keys CONST_ARRAY'); -is(j(keys CONST_ARRAY()) ,$a_expect, 'List: keys CONST_ARRAY()'); -is(j(keys array_sub) ,$a_expect, 'List: keys array_sub'); -is(j(keys array_sub()) ,$a_expect, 'List: keys array_sub()'); -is(j(keys $obj->array) ,$a_expect, 'List: keys $obj->array'); - -# Keys -- vivification -undef $empty; -eval { keys $empty->{hash} }; -ok(defined $empty, - 'Vivify: $empty (after keys $empty->{hash}) is HASHREF'); -ok(!defined $empty->{hash} , 'Vivify: $empty->{hash} is undef'); - -# Keys -- lvalue -$_{foo} = "bar"; -keys \%_ = 65; -is scalar %_, '1/128', 'keys $hashref as lvalue'; -eval 'keys \@_ = 65'; -like $@, qr/Can't modify keys on reference in scalar assignment/, - 'keys $arrayref as lvalue dies'; - -# Keys -- errors -$errpat = qr/ - (?-x:Type of argument to keys on reference must be unblessed hashref or) - (?-x: arrayref) -/x; - -eval "keys undef"; -ok($@ =~ $errpat, - 'Errors: keys undef throws error' -); - -undef $empty; -eval q"keys $empty"; -ok($@ =~ $errpat, - 'Errors: keys $undef throws error' -); - -is($empty, undef, 'keys $undef does not vivify $undef'); - -eval "keys 3"; -ok($@ =~ qr/Type of arg 1 to keys must be hash/, - 'Errors: keys CONSTANT throws error' -); - -eval "keys qr/foo/"; -ok($@ =~ $errpat, - 'Errors: keys qr/foo/ throws error' -); - -eval "keys $hash qw/fo bar/"; -ok($@ =~ qr/syntax error/, - 'Errors: keys $hash, @stuff throws error' -) or print "# Got: $@"; - -# Values -- void - -values $hash; pass('Void: values $hash;'); -values $data->{hash}; pass('Void: values $data->{hash};'); -values CONST_HASH; pass('Void: values CONST_HASH;'); -values CONST_HASH(); pass('Void: values CONST_HASH();'); -values hash_sub(); pass('Void: values hash_sub();'); -values hash_sub; pass('Void: values hash_sub;'); -values $obj->hash; pass('Void: values $obj->hash;'); -values $array; pass('Void: values $array;'); -values $data->{array}; pass('Void: values $data->{array};'); -values CONST_ARRAY; pass('Void: values CONST_ARRAY;'); -values CONST_ARRAY(); pass('Void: values CONST_ARRAY();'); -values array_sub; pass('Void: values array_sub;'); -values array_sub(); pass('Void: values array_sub();'); -values $obj->array; pass('Void: values $obj->array;'); - -# Values -- scalar - -is(values $hash ,3, 'Scalar: values $hash'); -is(values $data->{hash} ,3, 'Scalar: values $data->{hash}'); -is(values CONST_HASH ,3, 'Scalar: values CONST_HASH'); -is(values CONST_HASH() ,3, 'Scalar: values CONST_HASH()'); -is(values hash_sub ,3, 'Scalar: values hash_sub'); -is(values hash_sub() ,3, 'Scalar: values hash_sub()'); -is(values $obj->hash ,3, 'Scalar: values $obj->hash'); -is(values $array ,3, 'Scalar: values $array'); -is(values $data->{array} ,3, 'Scalar: values $data->{array}'); -is(values CONST_ARRAY ,3, 'Scalar: values CONST_ARRAY'); -is(values CONST_ARRAY() ,3, 'Scalar: values CONST_ARRAY()'); -is(values array_sub ,3, 'Scalar: values array_sub'); -is(values array_sub() ,3, 'Scalar: values array_sub()'); -is(values $obj->array ,3, 'Scalar: values $obj->array'); - -# Values -- list - -$h_expect = j(values %$hash); -$a_expect = j(values @$array); - -is(j(values $hash) ,$h_expect, 'List: values $hash'); -is(j(values $data->{hash}) ,$h_expect, 'List: values $data->{hash}'); -is(j(values CONST_HASH) ,$h_expect, 'List: values CONST_HASH'); -is(j(values CONST_HASH()) ,$h_expect, 'List: values CONST_HASH()'); -is(j(values hash_sub) ,$h_expect, 'List: values hash_sub'); -is(j(values hash_sub()) ,$h_expect, 'List: values hash_sub()'); -is(j(values $obj->hash) ,$h_expect, 'List: values $obj->hash'); -is(j(values $array) ,$a_expect, 'List: values $array'); -is(j(values $data->{array}) ,$a_expect, 'List: values $data->{array}'); -is(j(values CONST_ARRAY) ,$a_expect, 'List: values CONST_ARRAY'); -is(j(values CONST_ARRAY()) ,$a_expect, 'List: values CONST_ARRAY()'); -is(j(values array_sub) ,$a_expect, 'List: values array_sub'); -is(j(values array_sub()) ,$a_expect, 'List: values array_sub()'); -is(j(values $obj->array) ,$a_expect, 'List: values $obj->array'); - -# Values -- vivification -undef $empty; -eval { values $empty->{hash} }; -ok(defined $empty, - 'Vivify: $empty (after values $empty->{hash}) is HASHREF'); -ok(!defined $empty->{hash} , 'Vivify: $empty->{hash} is undef'); - -# Values -- errors -$errpat = qr/ - (?-x:Type of argument to values on reference must be unblessed hashref or) - (?-x: arrayref) -/x; - -eval "values undef"; -ok($@ =~ $errpat, - 'Errors: values undef throws error' -); - -undef $empty; -eval q"values $empty"; -ok($@ =~ $errpat, - 'Errors: values $undef throws error' -); - -is($empty, undef, 'values $undef does not vivify $undef'); - -eval "values 3"; -ok($@ =~ qr/Type of arg 1 to values must be hash/, - 'Errors: values CONSTANT throws error' -); - -eval "values qr/foo/"; -ok($@ =~ $errpat, - 'Errors: values qr/foo/ throws error' -); - -eval "values $hash qw/fo bar/"; -ok($@ =~ qr/syntax error/, - 'Errors: values $hash, @stuff throws error' -) or print "# Got: $@"; - -# Each -- void - -each $hash; pass('Void: each $hash'); -each $data->{hash}; pass('Void: each $data->{hash}'); -each CONST_HASH; pass('Void: each CONST_HASH'); -each CONST_HASH(); pass('Void: each CONST_HASH()'); -each hash_sub(); pass('Void: each hash_sub()'); -each hash_sub; pass('Void: each hash_sub'); -each $obj->hash; pass('Void: each $obj->hash'); -each $array; pass('Void: each $array'); -each $data->{array}; pass('Void: each $data->{array}'); -each CONST_ARRAY; pass('Void: each CONST_ARRAY'); -each CONST_ARRAY(); pass('Void: each CONST_ARRAY()'); -each array_sub; pass('Void: each array_sub'); -each array_sub(); pass('Void: each array_sub()'); -each $obj->array; pass('Void: each $obj->array'); - -# Reset iterators - -keys $hash; -keys $data->{hash}; -keys CONST_HASH; -keys CONST_HASH(); -keys hash_sub(); -keys hash_sub; -keys $obj->hash; -keys $array; -keys $data->{array}; -keys CONST_ARRAY; -keys CONST_ARRAY(); -keys array_sub; -keys array_sub(); -keys $obj->array; - -# Each -- scalar - -@tmp=(); while(defined( $k = each $hash)) {push @tmp,$k}; is(j(@tmp),j(keys $hash), 'Scalar: each $hash'); -@tmp=(); while(defined( $k = each $data->{hash})){push @tmp,$k}; is(j(@tmp),j(keys $data->{hash}), 'Scalar: each $data->{hash}'); -@tmp=(); while(defined( $k = each CONST_HASH)){push @tmp,$k}; is(j(@tmp),j(keys CONST_HASH), 'Scalar: each CONST_HASH'); -@tmp=(); while(defined( $k = each CONST_HASH())){push @tmp,$k}; is(j(@tmp),j(keys CONST_HASH()), 'Scalar: each CONST_HASH()'); -@tmp=(); while(defined( $k = each hash_sub())){push @tmp,$k}; is(j(@tmp),j(keys hash_sub()), 'Scalar: each hash_sub()'); -@tmp=(); while(defined( $k = each hash_sub)){push @tmp,$k}; is(j(@tmp),j(keys hash_sub), 'Scalar: each hash_sub'); -@tmp=(); while(defined( $k = each $obj->hash)){push @tmp,$k}; is(j(@tmp),j(keys $obj->hash), 'Scalar: each $obj->hash'); -@tmp=(); while(defined( $k = each $array)){push @tmp,$k}; is(j(@tmp),j(keys $array), 'Scalar: each $array'); -@tmp=(); while(defined( $k = each $data->{array})){push @tmp,$k}; is(j(@tmp),j(keys $data->{array}), 'Scalar: each $data->{array}'); -@tmp=(); while(defined( $k = each CONST_ARRAY)){push @tmp,$k}; is(j(@tmp),j(keys CONST_ARRAY), 'Scalar: each CONST_ARRAY'); -@tmp=(); while(defined( $k = each CONST_ARRAY())){push @tmp,$k}; is(j(@tmp),j(keys CONST_ARRAY()), 'Scalar: each CONST_ARRAY()'); -@tmp=(); while(defined( $k = each array_sub)){push @tmp,$k}; is(j(@tmp),j(keys array_sub), 'Scalar: each array_sub'); -@tmp=(); while(defined( $k = each array_sub())){push @tmp,$k}; is(j(@tmp),j(keys array_sub()), 'Scalar: each array_sub()'); -@tmp=(); while(defined( $k = each $obj->array)){push @tmp,$k}; is(j(@tmp),j(keys $obj->array), 'Scalar: each $obj->array'); - -# Each -- list - -@tmp=@tmp2=(); while(($k,$v) = each $hash) {push @tmp,$k; push @tmp2,$v}; is(j(@tmp,@tmp2),j(keys $hash, values $hash), 'List: each $hash'); -@tmp=@tmp2=(); while(($k,$v) = each $data->{hash}){push @tmp,$k; push @tmp2,$v}; is(j(@tmp,@tmp2),j(keys $data->{hash}, values $data->{hash}), 'List: each $data->{hash}'); -@tmp=@tmp2=(); while(($k,$v) = each CONST_HASH){push @tmp,$k; push @tmp2,$v}; is(j(@tmp,@tmp2),j(keys CONST_HASH, values CONST_HASH), 'List: each CONST_HASH'); -@tmp=@tmp2=(); while(($k,$v) = each CONST_HASH()){push @tmp,$k; push @tmp2,$v}; is(j(@tmp,@tmp2),j(keys CONST_HASH(), values CONST_HASH()), 'List: each CONST_HASH()'); -@tmp=@tmp2=(); while(($k,$v) = each hash_sub()){push @tmp,$k; push @tmp2,$v}; is(j(@tmp,@tmp2),j(keys hash_sub(), values hash_sub()), 'List: each hash_sub()'); -@tmp=@tmp2=(); while(($k,$v) = each hash_sub){push @tmp,$k; push @tmp2,$v}; is(j(@tmp,@tmp2),j(keys hash_sub, values hash_sub), 'List: each hash_sub'); -@tmp=@tmp2=(); while(($k,$v) = each $obj->hash){push @tmp,$k; push @tmp2,$v}; is(j(@tmp,@tmp2),j(keys $obj->hash, values $obj->hash), 'List: each $obj->hash'); -@tmp=@tmp2=(); while(($k,$v) = each $array){push @tmp,$k; push @tmp2,$v}; is(j(@tmp,@tmp2),j(keys $array, values $array), 'List: each $array'); -@tmp=@tmp2=(); while(($k,$v) = each $data->{array}){push @tmp,$k; push @tmp2,$v}; is(j(@tmp,@tmp2),j(keys $data->{array}, values $data->{array}), 'List: each $data->{array}'); -@tmp=@tmp2=(); while(($k,$v) = each CONST_ARRAY){push @tmp,$k; push @tmp2,$v}; is(j(@tmp,@tmp2),j(keys CONST_ARRAY, values CONST_ARRAY), 'List: each CONST_ARRAY'); -@tmp=@tmp2=(); while(($k,$v) = each CONST_ARRAY()){push @tmp,$k; push @tmp2,$v}; is(j(@tmp,@tmp2),j(keys CONST_ARRAY(), values CONST_ARRAY()), 'List: each CONST_ARRAY()'); -@tmp=@tmp2=(); while(($k,$v) = each array_sub){push @tmp,$k; push @tmp2,$v}; is(j(@tmp,@tmp2),j(keys array_sub, values array_sub), 'List: each array_sub'); -@tmp=@tmp2=(); while(($k,$v) = each array_sub()){push @tmp,$k; push @tmp2,$v}; is(j(@tmp,@tmp2),j(keys array_sub(), values array_sub()), 'List: each array_sub()'); -@tmp=@tmp2=(); while(($k,$v) = each $obj->array){push @tmp,$k; push @tmp2,$v}; is(j(@tmp,@tmp2),j(keys $obj->array, values $obj->array), 'List: each $obj->array'); - -# Each -- vivification -undef $empty; -eval { each $empty->{hash} }; -ok(defined $empty, - 'Vivify: $empty (after each $empty->{hash}) is HASHREF'); -ok(!defined $empty->{hash} , 'Vivify: $empty->{hash} is undef'); - -# Each -- errors -$errpat = qr/ - (?-x:Type of argument to each on reference must be unblessed hashref or) - (?-x: arrayref) -/x; - -eval "each undef"; -ok($@ =~ $errpat, - 'Errors: each undef throws error' -); - -undef $empty; -eval q"each $empty"; -ok($@ =~ $errpat, - 'Errors: each $undef throws error' -); - -is($empty, undef, 'each $undef does not vivify $undef'); - -eval "each 3"; -ok($@ =~ qr/Type of arg 1 to each must be hash/, - 'Errors: each CONSTANT throws error' -); - -eval "each qr/foo/"; -ok($@ =~ $errpat, - 'Errors: each qr/foo/ throws error' -); - -eval "each $hash qw/foo bar/"; -ok($@ =~ qr/syntax error/, - 'Errors: each $hash, @stuff throws error' -) or print "# Got: $@"; - -# Overloaded objects -my $over_a = Foo::Overload::Array->new; -my $over_h = Foo::Overload::Hash->new; -my $over_b = Foo::Overload::Both->new; -my $over_h_a = Foo::Overload::HashOnArray->new; -my $over_a_h = Foo::Overload::ArrayOnHash->new; - -{ - my $warn = ''; - local $SIG{__WARN__} = sub { $warn = shift }; - - $errpat = qr/ - (?-x:Type of argument to keys on reference must be unblessed hashref or) - (?-x: arrayref) - /x; - - eval { keys $over_a }; - like($@, $errpat, "Overload: array dereference"); - is($warn, '', "no warning issued"); $warn = ''; - - eval { keys $over_h }; - like($@, $errpat, "Overload: hash dereference"); - is($warn, '', "no warning issued"); $warn = ''; - - eval { keys $over_b }; - like($@, $errpat, "Overload: ambiguous dereference (both)"); - is($warn, '', "no warning issued"); $warn = ''; - - eval { keys $over_h_a }; - like($@, $errpat, "Overload: ambiguous dereference"); - is($warn, '', "no warning issued"); $warn = ''; - - eval { keys $over_a_h }; - like($@, $errpat, "Overload: ambiguous dereference"); - is($warn, '', "no warning issued"); $warn = ''; -} diff --git a/t/CORE/op/smartmatch.t b/t/CORE/op/smartmatch.t deleted file mode 100644 index 638ba84b3..000000000 --- a/t/CORE/op/smartmatch.t +++ /dev/null @@ -1,518 +0,0 @@ -#!./perl - -BEGIN { - unshift @INC, 't/CORE/lib'; - require 't/CORE/test.pl'; -} -use strict; -use warnings; -no warnings 'uninitialized'; - -use Tie::Array; -use Tie::Hash; - -# perlcc issue 179 - https://code.google.com/p/perl-compiler/issues/detail?id=179 - -# Predeclare vars used in the tests: -my @empty; -my %empty; -my @sparse; $sparse[2] = 2; - -my $deep1 = []; push @$deep1, $deep1; -my $deep2 = []; push @$deep2, $deep2; - -my @nums = (1..10); -tie my @tied_nums, 'Tie::StdArray'; -@tied_nums = (1..10); - -my %hash = (foo => 17, bar => 23); -tie my %tied_hash, 'Tie::StdHash'; -%tied_hash = %hash; - -{ - package Test::Object::NoOverload; - sub new { bless { key => 1 } } -} - -{ - package Test::Object::StringOverload; - use overload '""' => sub { "object" }, fallback => 1; - sub new { bless { key => 1 } } -} - -{ - package Test::Object::WithOverload; - sub new { bless { key => ($_[1] // 'magic') } } - use overload '~~' => sub { - my %hash = %{ $_[0] }; - if ($_[2]) { # arguments reversed ? - return $_[1] eq reverse $hash{key}; - } - else { - return $_[1] eq $hash{key}; - } - }; - use overload '""' => sub { "stringified" }; - use overload 'eq' => sub {"$_[0]" eq "$_[1]"}; -} - -our $ov_obj = Test::Object::WithOverload->new; -our $ov_obj_2 = Test::Object::WithOverload->new("object"); -our $obj = Test::Object::NoOverload->new; -our $str_obj = Test::Object::StringOverload->new; - -my %refh; -require Tie::RefHash; -tie %refh, 'Tie::RefHash'; -$refh{$ov_obj} = 1; - -my @keyandmore = qw(key and more); -my @fooormore = qw(foo or more); -my %keyandmore = map { $_ => 0 } @keyandmore; -my %fooormore = map { $_ => 0 } @fooormore; - -# Load and run the tests -plan tests => 349; - -while () { - SKIP: { - next if /^#/ || !/\S/; - chomp; - my ($yn, $left, $right, $note) = split /\t+/; - - local $::TODO = $note =~ /TODO/; - - die "Bad test spec: ($yn, $left, $right)" if $yn =~ /[^!@=]/; - - my $tstr = "$left ~~ $right"; - - test_again: - my $res; - if ($note =~ /NOWARNINGS/) { - $res = eval "no warnings; $tstr"; - } - else { - $res = eval $tstr; - } - - chomp $@; - - if ( $yn =~ /@/ ) { - ok( $@ ne '', "$tstr dies" ) - and print "# \$\@ was: $@\n"; - } else { - my $test_name = $tstr . ($yn =~ /!/ ? " does not match" : " matches"); - if ( $@ ne '' ) { - fail($test_name); - print "# \$\@ was: $@\n"; - } else { - ok( ($yn =~ /!/ xor $res), $test_name ); - } - } - - if ( $yn =~ s/=// ) { - $tstr = "$right ~~ $left"; - goto test_again; - } - } -} - -sub foo {} -sub bar {42} -sub gorch {42} -sub fatal {die "fatal sub\n"} - -# to test constant folding -sub FALSE() { 0 } -sub TRUE() { 1 } -sub NOT_DEF() { undef } - -# Prefix character : -# - expected to match -# ! - expected to not match -# @ - expected to be a compilation failure -# = - expected to match symmetrically (runs test twice) -# Data types to test : -# undef -# Object-overloaded -# Object -# Coderef -# Hash -# Hashref -# Array -# Arrayref -# Tied arrays and hashes -# Arrays that reference themselves -# Regex (// and qr//) -# Range -# Num -# Str -# Other syntactic items of interest: -# Constants -# Values returned by a sub call -__DATA__ -# Any ~~ undef -! $ov_obj undef -! $obj undef -! sub {} undef -! %hash undef -! \%hash undef -! {} undef -! @nums undef -! \@nums undef -! [] undef -! %tied_hash undef -! @tied_nums undef -! $deep1 undef -! /foo/ undef -! qr/foo/ undef -! 21..30 undef -! 189 undef -! "foo" undef -! "" undef -! !1 undef - undef undef - (my $u) undef - NOT_DEF undef - &NOT_DEF undef - -# Any ~~ object overloaded -! \&fatal $ov_obj - 'cigam' $ov_obj -! 'cigam on' $ov_obj -! ['cigam'] $ov_obj -! ['stringified'] $ov_obj -! { cigam => 1 } $ov_obj -! { stringified => 1 } $ov_obj -! $obj $ov_obj -! undef $ov_obj - -# regular object -@ $obj $obj -@ $ov_obj $obj -=@ \&fatal $obj -@ \&FALSE $obj -@ \&foo $obj -@ sub { 1 } $obj -@ sub { 0 } $obj -@ %keyandmore $obj -@ {"key" => 1} $obj -@ @fooormore $obj -@ ["key" => 1] $obj -@ /key/ $obj -@ qr/key/ $obj -@ "key" $obj -@ FALSE $obj - -# regular object with "" overload -@ $obj $str_obj -=@ \&fatal $str_obj -@ \&FALSE $str_obj -@ \&foo $str_obj -@ sub { 1 } $str_obj -@ sub { 0 } $str_obj -@ %keyandmore $str_obj -@ {"object" => 1} $str_obj -@ @fooormore $str_obj -@ ["object" => 1] $str_obj -@ /object/ $str_obj -@ qr/object/ $str_obj -@ "object" $str_obj -@ FALSE $str_obj -# Those will treat the $str_obj as a string because of fallback: - -# object (overloaded or not) ~~ Any - $obj qr/NoOverload/ - $ov_obj qr/^stringified$/ -= "$ov_obj" "stringified" -= "$str_obj" "object" -!= $ov_obj "stringified" - $str_obj "object" - $ov_obj 'magic' -! $ov_obj 'not magic' - -# ~~ Coderef - sub{0} sub { ref $_[0] eq "CODE" } - %fooormore sub { $_[0] =~ /^(foo|or|more)$/ } -! %fooormore sub { $_[0] =~ /^(foo|or|less)$/ } - \%fooormore sub { $_[0] =~ /^(foo|or|more)$/ } -! \%fooormore sub { $_[0] =~ /^(foo|or|less)$/ } - +{%fooormore} sub { $_[0] =~ /^(foo|or|more)$/ } -! +{%fooormore} sub { $_[0] =~ /^(foo|or|less)$/ } - @fooormore sub { $_[0] =~ /^(foo|or|more)$/ } -! @fooormore sub { $_[0] =~ /^(foo|or|less)$/ } - \@fooormore sub { $_[0] =~ /^(foo|or|more)$/ } -! \@fooormore sub { $_[0] =~ /^(foo|or|less)$/ } - [@fooormore] sub { $_[0] =~ /^(foo|or|more)$/ } -! [@fooormore] sub { $_[0] =~ /^(foo|or|less)$/ } - %fooormore sub{@_==1} - @fooormore sub{@_==1} - "foo" sub { $_[0] =~ /^(foo|or|more)$/ } -! "more" sub { $_[0] =~ /^(foo|or|less)$/ } - /fooormore/ sub{ref $_[0] eq 'Regexp'} - qr/fooormore/ sub{ref $_[0] eq 'Regexp'} - 1 sub{shift} -! 0 sub{shift} -! undef sub{shift} - undef sub{not shift} - NOT_DEF sub{not shift} - &NOT_DEF sub{not shift} - FALSE sub{not shift} - [1] \&bar - {a=>1} \&bar - qr// \&bar -! [1] \&foo -! {a=>1} \&foo - $obj sub { ref($_[0]) =~ /NoOverload/ } - $ov_obj sub { ref($_[0]) =~ /WithOverload/ } -# empty stuff matches, because the sub is never called: - [] \&foo - {} \&foo - @empty \&foo - %empty \&foo -! qr// \&foo -! undef \&foo - undef \&bar -@ undef \&fatal -@ 1 \&fatal -@ [1] \&fatal -@ {a=>1} \&fatal -@ "foo" \&fatal -@ qr// \&fatal -# sub is not called on empty hashes / arrays - [] \&fatal - +{} \&fatal - @empty \&fatal - %empty \&fatal -# sub is not special on the left - sub {0} qr/^CODE/ - sub {0} sub { ref shift eq "CODE" } - -# HASH ref against: -# - another hash ref - {} {} -=! {} {1 => 2} - {1 => 2} {1 => 2} - {1 => 2} {1 => 3} -=! {1 => 2} {2 => 3} -= \%main:: {map {$_ => 'x'} keys %main::} - -# - tied hash ref -= \%hash \%tied_hash - \%tied_hash \%tied_hash -!= {"a"=>"b"} \%tied_hash -= %hash %tied_hash - %tied_hash %tied_hash -!= {"a"=>"b"} %tied_hash - $ov_obj %refh MINISKIP -! "$ov_obj" %refh MINISKIP - [$ov_obj] %refh MINISKIP -! ["$ov_obj"] %refh MINISKIP - %refh %refh MINISKIP - -# - an array ref -# (since this is symmetrical, tests as well hash~~array) -= [keys %main::] \%:: -= [qw[STDIN STDOUT]] \%:: -=! [] \%:: -=! [""] {} -=! [] {} -=! @empty {} -= [undef] {"" => 1} -= [""] {"" => 1} -= ["foo"] { foo => 1 } -= ["foo", "bar"] { foo => 1 } -= ["foo", "bar"] \%hash -= ["foo"] \%hash -=! ["quux"] \%hash -= [qw(foo quux)] \%hash -= @fooormore { foo => 1, or => 2, more => 3 } -= @fooormore %fooormore -= @fooormore \%fooormore -= \@fooormore %fooormore - -# - a regex -= qr/^(fo[ox])$/ {foo => 1} -= /^(fo[ox])$/ %fooormore -=! qr/[13579]$/ +{0..99} -=! qr/a*/ {} -= qr/a*/ {b=>2} -= qr/B/i {b=>2} -= /B/i {b=>2} -=! qr/a+/ {b=>2} -= qr/^à/ {"à"=>2} - -# - a scalar - "foo" +{foo => 1, bar => 2} - "foo" %fooormore -! "baz" +{foo => 1, bar => 2} -! "boz" %fooormore -! 1 +{foo => 1, bar => 2} -! 1 %fooormore - 1 { 1 => 3 } - 1.0 { 1 => 3 } -! "1.0" { 1 => 3 } -! "1.0" { 1.0 => 3 } - "1.0" { "1.0" => 3 } - "à" { "à" => "À" } - -# - undef -! undef { hop => 'zouu' } -! undef %hash -! undef +{"" => "empty key"} -! undef {} - -# ARRAY ref against: -# - another array ref - [] [] -=! [] [1] - [["foo"], ["bar"]] [qr/o/, qr/a/] -! [["foo"], ["bar"]] [qr/ARRAY/, qr/ARRAY/] - ["foo", "bar"] [qr/o/, qr/a/] -! [qr/o/, qr/a/] ["foo", "bar"] - ["foo", "bar"] [["foo"], ["bar"]] -! ["foo", "bar"] [qr/o/, "foo"] - ["foo", undef, "bar"] [qr/o/, undef, "bar"] -! ["foo", undef, "bar"] [qr/o/, "", "bar"] -! ["foo", "", "bar"] [qr/o/, undef, "bar"] - $deep1 $deep1 - @$deep1 @$deep1 -! $deep1 $deep2 - -= \@nums \@tied_nums -= @nums \@tied_nums -= \@nums @tied_nums -= @nums @tied_nums - -# - an object -! $obj @fooormore - $obj [sub{ref shift}] - -# - a regex -= qr/x/ [qw(foo bar baz quux)] -=! qr/y/ [qw(foo bar baz quux)] -= /x/ [qw(foo bar baz quux)] -=! /y/ [qw(foo bar baz quux)] -= /FOO/i @fooormore -=! /bar/ @fooormore - -# - a number - 2 [qw(1.00 2.00)] - 2 [qw(foo 2)] - 2.0_0e+0 [qw(foo 2)] -! 2 [qw(1foo bar2)] - -# - a string -! "2" [qw(1foo 2bar)] - "2bar" [qw(1foo 2bar)] - -# - undef - undef [1, 2, undef, 4] -! undef [1, 2, [undef], 4] -! undef @fooormore - undef @sparse - undef [undef] -! 0 [undef] -! "" [undef] -! undef [0] -! undef [""] - -# - nested arrays and ~~ distributivity - 11 [[11]] -! 11 [[12]] - "foo" [{foo => "bar"}] -! "bar" [{foo => "bar"}] - -# Number against number - 2 2 - 20 2_0 -! 2 3 - 0 FALSE - 3-2 TRUE -! undef 0 -! (my $u) 0 - -# Number against string -= 2 "2" -= 2 "2.0" -! 2 "2bananas" -!= 2_3 "2_3" NOWARNINGS - FALSE "0" -! undef "0" -! undef "" - -# Regex against string - "x" qr/x/ -! "x" qr/y/ - -# Regex against number - 12345 qr/3/ -! 12345 qr/7/ - -# array/hash against string - @fooormore "".\@fooormore -! @keyandmore "".\@fooormore - %fooormore "".\%fooormore -! %keyandmore "".\%fooormore - -# Test the implicit referencing - 7 @nums - @nums \@nums -! @nums \\@nums - @nums [1..10] -! @nums [0..9] - - "foo" %hash - /bar/ %hash - [qw(bar)] %hash -! [qw(a b c)] %hash - %hash %hash - %hash +{%hash} - %hash \%hash - %hash %tied_hash - %tied_hash %tied_hash - %hash { foo => 5, bar => 10 } -! %hash { foo => 5, bar => 10, quux => 15 } - - @nums { 1, '', 2, '' } - @nums { 1, '', 12, '' } -! @nums { 11, '', 12, '' } - -# array slices - @nums[0..-1] [] - @nums[0..0] [1] -! @nums[0..1] [0..2] - @nums[0..4] [1..5] - -! undef @nums[0..-1] - 1 @nums[0..0] - 2 @nums[0..1] -! @nums[0..1] 2 - - @nums[0..1] @nums[0..1] - -# hash slices - @keyandmore{qw(not)} [undef] - @keyandmore{qw(key)} [0] - - undef @keyandmore{qw(not)} - 0 @keyandmore{qw(key and more)} -! 2 @keyandmore{qw(key and)} - - @fooormore{qw(foo)} @keyandmore{qw(key)} - @fooormore{qw(foo or more)} @keyandmore{qw(key and more)} - -# UNDEF -! 3 undef -! 1 undef -! [] undef -! {} undef -! \%::main undef -! [1,2] undef -! %hash undef -! @nums undef -! "foo" undef -! "" undef -! !1 undef -! \&foo undef -! sub { } undef diff --git a/t/CORE/op/sort.t b/t/CORE/op/sort.t deleted file mode 100644 index 171eafe47..000000000 --- a/t/CORE/op/sort.t +++ /dev/null @@ -1,937 +0,0 @@ -#!./perl - -BEGIN { require 't/CORE/test.pl' } - -use warnings; -plan( tests => 162 ); - -# these shouldn't hang -{ - no warnings; - sort { for ($_ = 0;; $_++) {} } @a; - sort { while(1) {} } @a; - sort { while(1) { last; } } @a; - sort { while(0) { last; } } @a; - - # Change 26011: Re: A surprising segfault - map scalar(sort(+())), ('')x68; -} - -sub Backwards { $a lt $b ? 1 : $a gt $b ? -1 : 0 } -sub Backwards_stacked($$) { my($a,$b) = @_; $a lt $b ? 1 : $a gt $b ? -1 : 0 } -sub Backwards_other { $a lt $b ? 1 : $a gt $b ? -1 : 0 } - -my $upperfirst = 'A' lt 'a'; - -# Beware: in future this may become hairier because of possible -# collation complications: qw(A a B b) can be sorted at least as -# any of the following -# -# A a B b -# A B a b -# a b A B -# a A b B -# -# All the above orders make sense. -# -# That said, EBCDIC sorts all small letters first, as opposed -# to ASCII which sorts all big letters first. - -@harry = ('dog','cat','x','Cain','Abel'); -@george = ('gone','chased','yz','punished','Axed'); - -$x = join('', sort @harry); -$expected = $upperfirst ? 'AbelCaincatdogx' : 'catdogxAbelCain'; - -cmp_ok($x,'eq',$expected,'upper first 1'); - -$x = join('', sort( Backwards @harry)); -$expected = $upperfirst ? 'xdogcatCainAbel' : 'CainAbelxdogcat'; - -cmp_ok($x,'eq',$expected,'upper first 2'); - -$x = join('', sort( Backwards_stacked @harry)); -$expected = $upperfirst ? 'xdogcatCainAbel' : 'CainAbelxdogcat'; - -cmp_ok($x,'eq',$expected,'upper first 3'); - -$x = join('', sort @george, 'to', @harry); -$expected = $upperfirst ? - 'AbelAxedCaincatchaseddoggonepunishedtoxyz' : - 'catchaseddoggonepunishedtoxyzAbelAxedCain' ; - -cmp_ok($x,'eq',$expected,'upper first 4'); -$" = ' '; -@a = (); -@b = reverse @a; -cmp_ok("@b",'eq',"",'reverse 1'); - -@a = (1); -@b = reverse @a; -cmp_ok("@b",'eq',"1",'reverse 2'); - -@a = (1,2); -@b = reverse @a; -cmp_ok("@b",'eq',"2 1",'reverse 3'); - -@a = (1,2,3); -@b = reverse @a; -cmp_ok("@b",'eq',"3 2 1",'reverse 4'); - -@a = (1,2,3,4); -@b = reverse @a; -cmp_ok("@b",'eq',"4 3 2 1",'reverse 5'); - -@a = (10,2,3,4); -@b = sort {$a <=> $b;} @a; -cmp_ok("@b",'eq',"2 3 4 10",'sort numeric'); - -$sub = 'Backwards'; -$x = join('', sort $sub @harry); -$expected = $upperfirst ? 'xdogcatCainAbel' : 'CainAbelxdogcat'; - -cmp_ok($x,'eq',$expected,'sorter sub name in var 1'); - -$sub = 'Backwards_stacked'; -$x = join('', sort $sub @harry); -$expected = $upperfirst ? 'xdogcatCainAbel' : 'CainAbelxdogcat'; - -cmp_ok($x,'eq',$expected,'sorter sub name in var 2'); - -# literals, combinations - -@b = sort (4,1,3,2); -cmp_ok("@b",'eq','1 2 3 4','just sort'); - - -@b = sort grep { $_ } (4,1,3,2); -cmp_ok("@b",'eq','1 2 3 4','grep then sort'); - - -@b = sort map { $_ } (4,1,3,2); -cmp_ok("@b",'eq','1 2 3 4','map then sort'); - - -@b = sort reverse (4,1,3,2); -cmp_ok("@b",'eq','1 2 3 4','reverse then sort'); - - - -sub twoface { no warnings 'redefine'; *twoface = sub { $a <=> $b }; &twoface } -eval { @b = sort twoface 4,1,3,2 }; -cmp_ok("@b",'eq','1 2 3 4','redefine sort sub inside the sort sub'); - - -eval { no warnings 'redefine'; *twoface = sub { &Backwards } }; -ok(!$@,"redefining sort subs outside the sort \$@=[$@]"); - -eval { @b = sort twoface 4,1,3,2 }; -cmp_ok("@b",'eq','4 3 2 1','twoface redefinition'); - -{ - no warnings 'redefine'; - *twoface = sub { *twoface = *Backwards_other; $a <=> $b }; -} - -eval { @b = sort twoface 4,1,9,5 }; -ok(($@ eq "" && "@b" eq "1 4 5 9"),'redefinition should not take effect during the sort'); - -{ - no warnings 'redefine'; - *twoface = sub { - eval 'sub twoface { $a <=> $b }'; - die($@ eq "" ? "good\n" : "bad\n"); - $a <=> $b; - }; -} -eval { @b = sort twoface 4,1 }; -cmp_ok(substr($@,0,4), 'eq', 'good', 'twoface eval'); - -eval <<'CODE'; - my @result = sort main'Backwards 'one', 'two'; -CODE -cmp_ok($@,'eq','',q(old skool package)); - -eval <<'CODE'; - # "sort 'one', 'two'" should not try to parse "'one" as a sort sub - my @result = sort 'one', 'two'; -CODE -cmp_ok($@,'eq','',q(one is not a sub)); - -{ - my $sortsub = \&Backwards; - my $sortglob = *Backwards; - my $sortglobr = \*Backwards; - my $sortname = 'Backwards'; - @b = sort $sortsub 4,1,3,2; - cmp_ok("@b",'eq','4 3 2 1','sortname 1'); - @b = sort $sortglob 4,1,3,2; - cmp_ok("@b",'eq','4 3 2 1','sortname 2'); - @b = sort $sortname 4,1,3,2; - cmp_ok("@b",'eq','4 3 2 1','sortname 3'); - @b = sort $sortglobr 4,1,3,2; - cmp_ok("@b",'eq','4 3 2 1','sortname 4'); -} - -{ - my $sortsub = \&Backwards_stacked; - my $sortglob = *Backwards_stacked; - my $sortglobr = \*Backwards_stacked; - my $sortname = 'Backwards_stacked'; - @b = sort $sortsub 4,1,3,2; - cmp_ok("@b",'eq','4 3 2 1','sortname 5'); - @b = sort $sortglob 4,1,3,2; - cmp_ok("@b",'eq','4 3 2 1','sortname 6'); - @b = sort $sortname 4,1,3,2; - cmp_ok("@b",'eq','4 3 2 1','sortname 7'); - @b = sort $sortglobr 4,1,3,2; - cmp_ok("@b",'eq','4 3 2 1','sortname 8'); -} - -{ - local $sortsub = \&Backwards; - local $sortglob = *Backwards; - local $sortglobr = \*Backwards; - local $sortname = 'Backwards'; - @b = sort $sortsub 4,1,3,2; - cmp_ok("@b",'eq','4 3 2 1','sortname local 1'); - @b = sort $sortglob 4,1,3,2; - cmp_ok("@b",'eq','4 3 2 1','sortname local 2'); - @b = sort $sortname 4,1,3,2; - cmp_ok("@b",'eq','4 3 2 1','sortname local 3'); - @b = sort $sortglobr 4,1,3,2; - cmp_ok("@b",'eq','4 3 2 1','sortname local 4'); -} - -{ - local $sortsub = \&Backwards_stacked; - local $sortglob = *Backwards_stacked; - local $sortglobr = \*Backwards_stacked; - local $sortname = 'Backwards_stacked'; - @b = sort $sortsub 4,1,3,2; - cmp_ok("@b",'eq','4 3 2 1','sortname local 5'); - @b = sort $sortglob 4,1,3,2; - cmp_ok("@b",'eq','4 3 2 1','sortname local 6'); - @b = sort $sortname 4,1,3,2; - cmp_ok("@b",'eq','4 3 2 1','sortname local 7'); - @b = sort $sortglobr 4,1,3,2; - cmp_ok("@b",'eq','4 3 2 1','sortname local 8'); -} - -## exercise sort builtins... ($a <=> $b already tested) -@a = ( 5, 19, 1996, 255, 90 ); -@b = sort { - my $dummy; # force blockness - return $b <=> $a -} @a; -cmp_ok("@b",'eq','1996 255 90 19 5','force blockness'); - -$x = join('', sort { $a cmp $b } @harry); -$expected = $upperfirst ? 'AbelCaincatdogx' : 'catdogxAbelCain'; -cmp_ok($x,'eq',$expected,'a cmp b'); - -$x = join('', sort { $b cmp $a } @harry); -$expected = $upperfirst ? 'xdogcatCainAbel' : 'CainAbelxdogcat'; -cmp_ok($x,'eq',$expected,'b cmp a'); - -{ - use integer; - @b = sort { $a <=> $b } @a; - cmp_ok("@b",'eq','5 19 90 255 1996','integer a <=> b'); - - @b = sort { $b <=> $a } @a; - cmp_ok("@b",'eq','1996 255 90 19 5','integer b <=> a'); - - $x = join('', sort { $a cmp $b } @harry); - $expected = $upperfirst ? 'AbelCaincatdogx' : 'catdogxAbelCain'; - cmp_ok($x,'eq',$expected,'integer a cmp b'); - - $x = join('', sort { $b cmp $a } @harry); - $expected = $upperfirst ? 'xdogcatCainAbel' : 'CainAbelxdogcat'; - cmp_ok($x,'eq',$expected,'integer b cmp a'); - -} - - - -$x = join('', sort { $a <=> $b } 3, 1, 2); -cmp_ok($x,'eq','123',q(optimized-away comparison block doesn't take any other arguments away with it)); - -# test sorting in non-main package -{ - package Foo; - @a = ( 5, 19, 1996, 255, 90 ); - @b = sort { $b <=> $a } @a; - ::cmp_ok("@b",'eq','1996 255 90 19 5','not in main:: 1'); - - @b = sort ::Backwards_stacked @a; - ::cmp_ok("@b",'eq','90 5 255 1996 19','not in main:: 2'); - - # check if context for sort arguments is handled right - sub test_if_list { - my $gimme = wantarray; - ::is($gimme,1,'wantarray 1'); - } - my $m = sub { $a <=> $b }; - - sub cxt_one { sort $m test_if_list() } - cxt_one(); - sub cxt_two { sort { $a <=> $b } test_if_list() } - cxt_two(); - sub cxt_three { sort &test_if_list() } - cxt_three(); - - sub test_if_scalar { - my $gimme = wantarray; - ::is(!($gimme or !defined($gimme)),1,'wantarray 2'); - } - - $m = \&test_if_scalar; - sub cxt_four { sort $m 1,2 } - @x = cxt_four(); - sub cxt_five { sort { test_if_scalar($a,$b); } 1,2 } - @x = cxt_five(); - sub cxt_six { sort test_if_scalar 1,2 } - @x = cxt_six(); -} - - -# test against a reentrancy bug -{ - package Bar; - sub compare { $a cmp $b } - sub reenter { my @force = sort compare qw/a b/ } -} -{ - my($def, $init) = (0, 0); - @b = sort { - $def = 1 if defined $Bar::a; - Bar::reenter() unless $init++; - $a <=> $b - } qw/4 3 1 2/; - cmp_ok("@b",'eq','1 2 3 4','reenter 1'); - - ok(!$def,'reenter 2'); -} - - -{ - sub routine { "one", "two" }; - @a = sort(routine(1)); - cmp_ok("@a",'eq',"one two",'bug id 19991001.003'); -} - - -# check for in-place optimisation of @a = sort @a -{ - my ($r1,$r2,@a); - our @g; - @g = (3,2,1); $r1 = \$g[2]; @g = sort @g; $r2 = \$g[0]; - is "$r1-@g", "$r2-1 2 3", "inplace sort of global"; - - @a = qw(b a c); $r1 = \$a[1]; @a = sort @a; $r2 = \$a[0]; - is "$r1-@a", "$r2-a b c", "inplace sort of lexical"; - - @g = (2,3,1); $r1 = \$g[1]; @g = sort { $b <=> $a } @g; $r2 = \$g[0]; - is "$r1-@g", "$r2-3 2 1", "inplace reversed sort of global"; - - @g = (2,3,1); - $r1 = \$g[1]; @g = sort { $a<$b?1:$a>$b?-1:0 } @g; $r2 = \$g[0]; - is "$r1-@g", "$r2-3 2 1", "inplace custom sort of global"; - - sub mysort { $b cmp $a }; - @a = qw(b c a); $r1 = \$a[1]; @a = sort mysort @a; $r2 = \$a[0]; - is "$r1-@a", "$r2-c b a", "inplace sort with function of lexical"; - - use Tie::Array; - my @t; - tie @t, 'Tie::StdArray'; - - @t = qw(b c a); @t = sort @t; - is "@t", "a b c", "inplace sort of tied array"; - - @t = qw(b c a); @t = sort mysort @t; - is "@t", "c b a", "inplace sort of tied array with function"; - - # [perl #29790] don't optimise @a = ('a', sort @a) ! - - @g = (3,2,1); @g = ('0', sort @g); - is "@g", "0 1 2 3", "un-inplace sort of global"; - @g = (3,2,1); @g = (sort(@g),'4'); - is "@g", "1 2 3 4", "un-inplace sort of global 2"; - - @a = qw(b a c); @a = ('x', sort @a); - is "@a", "x a b c", "un-inplace sort of lexical"; - @a = qw(b a c); @a = ((sort @a), 'x'); - is "@a", "a b c x", "un-inplace sort of lexical 2"; - - @g = (2,3,1); @g = ('0', sort { $b <=> $a } @g); - is "@g", "0 3 2 1", "un-inplace reversed sort of global"; - @g = (2,3,1); @g = ((sort { $b <=> $a } @g),'4'); - is "@g", "3 2 1 4", "un-inplace reversed sort of global 2"; - - @g = (2,3,1); @g = ('0', sort { $a<$b?1:$a>$b?-1:0 } @g); - is "@g", "0 3 2 1", "un-inplace custom sort of global"; - @g = (2,3,1); @g = ((sort { $a<$b?1:$a>$b?-1:0 } @g),'4'); - is "@g", "3 2 1 4", "un-inplace custom sort of global 2"; - - @a = qw(b c a); @a = ('x', sort mysort @a); - is "@a", "x c b a", "un-inplace sort with function of lexical"; - @a = qw(b c a); @a = ((sort mysort @a),'x'); - is "@a", "c b a x", "un-inplace sort with function of lexical 2"; - - # RT#54758. Git 62b40d2474e7487e6909e1872b6bccdf812c6818 - no warnings 'void'; - my @m; push @m, 0 for 1 .. 1024; $#m; @m = sort @m; - ::pass("in-place sorting segfault"); -} - -# Test optimisations of reversed sorts. As we now guarantee stability by -# default, # optimisations which do not provide this are bogus. - -{ - package Oscalar; - use overload (qw("" stringify 0+ numify fallback 1)); - - sub new { - bless [$_[1], $_[2]], $_[0]; - } - - sub stringify { $_[0]->[0] } - - sub numify { $_[0]->[1] } -} - -sub generate { - my $count = 0; - map {new Oscalar $_, $count++} qw(A A A B B B C C C); -} - -my @input = &generate; -my @output = sort @input; -is join(" ", map {0+$_} @output), "0 1 2 3 4 5 6 7 8", "Simple stable sort"; - -@input = &generate; -@input = sort @input; -is join(" ", map {0+$_} @input), "0 1 2 3 4 5 6 7 8", - "Simple stable in place sort"; - -# This won't be very interesting -@input = &generate; -@output = sort {$a <=> $b} @input; -is "@output", "A A A B B B C C C", 'stable $a <=> $b sort'; - -@input = &generate; -@output = sort {$a cmp $b} @input; -is join(" ", map {0+$_} @output), "0 1 2 3 4 5 6 7 8", 'stable $a cmp $b sort'; - -@input = &generate; -@input = sort {$a cmp $b} @input; -is join(" ", map {0+$_} @input), "0 1 2 3 4 5 6 7 8", - 'stable $a cmp $b in place sort'; - -@input = &generate; -@output = sort {$b cmp $a} @input; -is join(" ", map {0+$_} @output), "6 7 8 3 4 5 0 1 2", 'stable $b cmp $a sort'; - -@input = &generate; -@input = sort {$b cmp $a} @input; -is join(" ", map {0+$_} @input), "6 7 8 3 4 5 0 1 2", - 'stable $b cmp $a in place sort'; - -@input = &generate; -@output = reverse sort @input; -is join(" ", map {0+$_} @output), "8 7 6 5 4 3 2 1 0", "Reversed stable sort"; - -@input = &generate; -@input = reverse sort @input; -is join(" ", map {0+$_} @input), "8 7 6 5 4 3 2 1 0", - "Reversed stable in place sort"; - -@input = &generate; -my $output = reverse sort @input; -is $output, "CCCBBBAAA", "Reversed stable sort in scalar context"; - - -@input = &generate; -@output = reverse sort {$a cmp $b} @input; -is join(" ", map {0+$_} @output), "8 7 6 5 4 3 2 1 0", - 'reversed stable $a cmp $b sort'; - -@input = &generate; -@input = reverse sort {$a cmp $b} @input; -is join(" ", map {0+$_} @input), "8 7 6 5 4 3 2 1 0", - 'revesed stable $a cmp $b in place sort'; - -@input = &generate; -$output = reverse sort {$a cmp $b} @input; -is $output, "CCCBBBAAA", 'Reversed stable $a cmp $b sort in scalar context'; - -@input = &generate; -@output = reverse sort {$b cmp $a} @input; -is join(" ", map {0+$_} @output), "2 1 0 5 4 3 8 7 6", - 'reversed stable $b cmp $a sort'; - -@input = &generate; -@input = reverse sort {$b cmp $a} @input; -is join(" ", map {0+$_} @input), "2 1 0 5 4 3 8 7 6", - 'revesed stable $b cmp $a in place sort'; - -@input = &generate; -$output = reverse sort {$b cmp $a} @input; -is $output, "AAABBBCCC", 'Reversed stable $b cmp $a sort in scalar context'; - -sub stuff { - # Something complex enough to defeat any constant folding optimiser - $$ - $$; -} - -@input = &generate; -@output = reverse sort {stuff || $a cmp $b} @input; -is join(" ", map {0+$_} @output), "8 7 6 5 4 3 2 1 0", - 'reversed stable complex sort'; - -@input = &generate; -@input = reverse sort {stuff || $a cmp $b} @input; -is join(" ", map {0+$_} @input), "8 7 6 5 4 3 2 1 0", - 'revesed stable complex in place sort'; - -@input = &generate; -$output = reverse sort {stuff || $a cmp $b } @input; -is $output, "CCCBBBAAA", 'Reversed stable complex sort in scalar context'; - -sub sortr { - reverse sort @_; -} - -@output = sortr &generate; -is join(" ", map {0+$_} @output), "8 7 6 5 4 3 2 1 0", - 'reversed stable sort return list context'; -$output = sortr &generate; -is $output, "CCCBBBAAA", - 'reversed stable sort return scalar context'; - -sub sortcmpr { - reverse sort {$a cmp $b} @_; -} - -@output = sortcmpr &generate; -is join(" ", map {0+$_} @output), "8 7 6 5 4 3 2 1 0", - 'reversed stable $a cmp $b sort return list context'; -$output = sortcmpr &generate; -is $output, "CCCBBBAAA", - 'reversed stable $a cmp $b sort return scalar context'; - -sub sortcmprba { - reverse sort {$b cmp $a} @_; -} - -@output = sortcmprba &generate; -is join(" ", map {0+$_} @output), "2 1 0 5 4 3 8 7 6", - 'reversed stable $b cmp $a sort return list context'; -$output = sortcmprba &generate; -is $output, "AAABBBCCC", -'reversed stable $b cmp $a sort return scalar context'; - -sub sortcmprq { - reverse sort {stuff || $a cmp $b} @_; -} - -@output = sortcmpr &generate; -is join(" ", map {0+$_} @output), "8 7 6 5 4 3 2 1 0", - 'reversed stable complex sort return list context'; -$output = sortcmpr &generate; -is $output, "CCCBBBAAA", - 'reversed stable complex sort return scalar context'; - -# And now with numbers - -sub generate1 { - my $count = 'A'; - map {new Oscalar $count++, $_} 0, 0, 0, 1, 1, 1, 2, 2, 2; -} - -# This won't be very interesting -@input = &generate1; -@output = sort {$a cmp $b} @input; -is "@output", "A B C D E F G H I", 'stable $a cmp $b sort'; - -@input = &generate1; -@output = sort {$a <=> $b} @input; -is "@output", "A B C D E F G H I", 'stable $a <=> $b sort'; - -@input = &generate1; -@input = sort {$a <=> $b} @input; -is "@input", "A B C D E F G H I", 'stable $a <=> $b in place sort'; - -@input = &generate1; -@output = sort {$b <=> $a} @input; -is "@output", "G H I D E F A B C", 'stable $b <=> $a sort'; - -@input = &generate1; -@input = sort {$b <=> $a} @input; -is "@input", "G H I D E F A B C", 'stable $b <=> $a in place sort'; - -# test that optimized {$b cmp $a} and {$b <=> $a} remain stable -# (new in 5.9) without overloading -{ no warnings; -@b = sort { $b <=> $a } @input = qw/5first 6first 5second 6second/; -is "@b" , "6first 6second 5first 5second", "optimized {$b <=> $a} without overloading" ; -@input = sort {$b <=> $a} @input; -is "@input" , "6first 6second 5first 5second","inline optimized {$b <=> $a} without overloading" ; -}; - -# These two are actually doing string cmp on 0 1 and 2 -@input = &generate1; -@output = reverse sort @input; -is "@output", "I H G F E D C B A", "Reversed stable sort"; - -@input = &generate1; -@input = reverse sort @input; -is "@input", "I H G F E D C B A", "Reversed stable in place sort"; - -@input = &generate1; -$output = reverse sort @input; -is $output, "IHGFEDCBA", "Reversed stable sort in scalar context"; - -@input = &generate1; -@output = reverse sort {$a <=> $b} @input; -is "@output", "I H G F E D C B A", 'reversed stable $a <=> $b sort'; - -@input = &generate1; -@input = reverse sort {$a <=> $b} @input; -is "@input", "I H G F E D C B A", 'revesed stable $a <=> $b in place sort'; - -@input = &generate1; -$output = reverse sort {$a <=> $b} @input; -is $output, "IHGFEDCBA", 'reversed stable $a <=> $b sort in scalar context'; - -@input = &generate1; -@output = reverse sort {$b <=> $a} @input; -is "@output", "C B A F E D I H G", 'reversed stable $b <=> $a sort'; - -@input = &generate1; -@input = reverse sort {$b <=> $a} @input; -is "@input", "C B A F E D I H G", 'revesed stable $b <=> $a in place sort'; - -@input = &generate1; -$output = reverse sort {$b <=> $a} @input; -is $output, "CBAFEDIHG", 'reversed stable $b <=> $a sort in scalar context'; - -@input = &generate1; -@output = reverse sort {stuff || $a <=> $b} @input; -is "@output", "I H G F E D C B A", 'reversed stable complex sort'; - -@input = &generate1; -@input = reverse sort {stuff || $a <=> $b} @input; -is "@input", "I H G F E D C B A", 'revesed stable complex in place sort'; - -@input = &generate1; -$output = reverse sort {stuff || $a <=> $b} @input; -is $output, "IHGFEDCBA", 'reversed stable complex sort in scalar context'; - -sub sortnumr { - reverse sort {$a <=> $b} @_; -} - -@output = sortnumr &generate1; -is "@output", "I H G F E D C B A", - 'reversed stable $a <=> $b sort return list context'; -$output = sortnumr &generate1; -is $output, "IHGFEDCBA", 'reversed stable $a <=> $b sort return scalar context'; - -sub sortnumrba { - reverse sort {$b <=> $a} @_; -} - -@output = sortnumrba &generate1; -is "@output", "C B A F E D I H G", - 'reversed stable $b <=> $a sort return list context'; -$output = sortnumrba &generate1; -is $output, "CBAFEDIHG", 'reversed stable $b <=> $a sort return scalar context'; - -sub sortnumrq { - reverse sort {stuff || $a <=> $b} @_; -} - -@output = sortnumrq &generate1; -is "@output", "I H G F E D C B A", - 'reversed stable complex sort return list context'; -$output = sortnumrq &generate1; -is $output, "IHGFEDCBA", 'reversed stable complex sort return scalar context'; - -@output = reverse (sort(qw(C A B)), 0); -is "@output", "0 C B A", 'reversed sort with trailing argument'; - -@output = reverse (0, sort(qw(C A B))); -is "@output", "C B A 0", 'reversed sort with leading argument'; - -eval { @output = sort {goto sub {}} 1,2; }; -$fail_msg = q(Can't goto subroutine outside a subroutine); -cmp_ok(substr($@,0,length($fail_msg)),'eq',$fail_msg,'goto subr outside subr'); - - - -sub goto_sub {goto sub{}} -eval { @output = sort goto_sub 1,2; }; -$fail_msg = q(Can't goto subroutine from a sort sub); -cmp_ok(substr($@,0,length($fail_msg)),'eq',$fail_msg,'goto subr from a sort sub'); - - - -eval { @output = sort {goto label} 1,2; }; -$fail_msg = q(Can't "goto" out of a pseudo block); -cmp_ok(substr($@,0,length($fail_msg)),'eq',$fail_msg,'goto out of a pseudo block 1'); - - - -sub goto_label {goto label} -label: eval { @output = sort goto_label 1,2; }; -$fail_msg = q(Can't "goto" out of a pseudo block); -cmp_ok(substr($@,0,length($fail_msg)),'eq',$fail_msg,'goto out of a pseudo block 2'); - - - -sub self_immolate {undef &self_immolate; $a<=>$b} -eval { @output = sort self_immolate 1,2,3 }; -$fail_msg = q(Can't undef active subroutine); -cmp_ok(substr($@,0,length($fail_msg)),'eq',$fail_msg,'undef active subr'); - - -for(1,2) # We run this twice, to make sure sort does not lower the ref -{ # count. See bug 71076. - my $failed = 0; - - sub rec { - my $n = shift; - if (!defined($n)) { # No arg means we're being called by sort() - return 1; - } - if ($n<5) { rec($n+1); } - else { () = sort rec 1,2; } - - $failed = 1 if !defined $n; - } - - rec(1); - ok(!$failed, "sort from active sub"); -} - -# $a and $b are set in the package the sort() is called from, -# *not* the package the sort sub is in. This is longstanding -# de facto behaviour that shouldn't be broken. -my $answer = "good"; -() = sort OtherPack::foo 1,2,3,4; - -{ - package OtherPack; - no warnings 'once'; - sub foo { - $answer = "something was unexpectedly defined or undefined" if - defined($a) || defined($b) || !defined($main::a) || !defined($main::b); - $main::a <=> $main::b; - } -} - -cmp_ok($answer,'eq','good','sort subr called from other package'); - - -# Bug 36430 - sort called in package2 while a -# sort in package1 is active should set $package2::a/b. -{ - my $answer = "good"; - my @list = sort { A::min(@$a) <=> A::min(@$b) } - [3, 1, 5], [2, 4], [0]; - - cmp_ok($answer,'eq','good','bug 36430'); - - package A; - sub min { - my @list = sort { - $answer = '$a and/or $b are not defined ' if !defined($a) || !defined($b); - $a <=> $b; - } @_; - $list[0]; - } -} - - -# Bug 7567 - an array shouldn't be modifiable while it's being -# sorted in-place. -{ - eval { @a=(1..8); @a = sort { @a = (0) } @a; }; - - $fail_msg = q(Modification of a read-only value attempted); - cmp_ok(substr($@,0,length($fail_msg)),'eq',$fail_msg,'bug 7567'); -} - -{ - local $TODO = "sort should make sure elements are not freed in the sort block"; - eval { @nomodify_x=(1..8); our @copy = sort { @nomodify_x = (0) } (@nomodify_x, 3); }; - is($@, ""); -} - - -# Sorting shouldn't increase the refcount of a sub -{ - sub sportello {(1+$a) <=> (1+$b)} - my $refcnt = &Internals::SvREFCNT(\&sportello); - @output = sort sportello 3,7,9; - - { - package Doc; - ::is($refcnt, &Internals::SvREFCNT(\&::sportello), "sort sub refcnt"); - $fail_msg = q(Modification of a read-only value attempted); - # Sorting a read-only array in-place shouldn't be allowed - my @readonly = (1..10); - Internals::SvREADONLY(@readonly, 1); - eval { @readonly = sort @readonly; }; - ::cmp_ok(substr($@,0,length($fail_msg)),'eq',$fail_msg,'in-place sort of read-only array'); - } -} - - -# Using return() should be okay even in a deeper context -@b = sort {while (1) {return ($a <=> $b)} } 1..10; -is("@b", "1 2 3 4 5 6 7 8 9 10", "return within loop"); - -# Using return() should be okay even if there are other items -# on the stack at the time. -@b = sort {$_ = ($a<=>$b) + do{return $b<=> $a}} 1..10; -is("@b", "10 9 8 7 6 5 4 3 2 1", "return with SVs on stack"); - -# As above, but with a sort sub rather than a sort block. -sub ret_with_stacked { $_ = ($a<=>$b) + do {return $b <=> $a} } -@b = sort ret_with_stacked 1..10; -is("@b", "10 9 8 7 6 5 4 3 2 1", "return with SVs on stack"); - -# Comparison code should be able to give result in non-integer representation. -sub cmp_as_string($$) { $_[0] < $_[1] ? "-1" : $_[0] == $_[1] ? "0" : "+1" } -@b = sort { cmp_as_string($a, $b) } (1,5,4,7,3,2,3); -is("@b", "1 2 3 3 4 5 7", "comparison result as string"); -@b = sort cmp_as_string (1,5,4,7,3,2,3); -is("@b", "1 2 3 3 4 5 7", "comparison result as string"); - -# RT #34604: sort didn't honour overloading if the overloaded elements -# were retrieved via tie - -{ - package RT34604; - - sub TIEHASH { bless { - p => bless({ val => 2 }), - q => bless({ val => 1 }), - } - } - sub FETCH { $_[0]{$_[1] } } - - my $cc = 0; - sub compare { $cc++; $_[0]{val} cmp $_[1]{val} } - my $cs = 0; - sub str { $cs++; $_[0]{val} } - - use overload 'cmp' => \&compare, '""' => \&str; - - package main; - - tie my %h, 'RT34604'; - my @sorted = sort @h{qw(p q)}; - is($cc, 1, 'overload compare called once'); - is("@sorted","1 2", 'overload sort result'); - is($cs, 2, 'overload string called twice'); -} - -fresh_perl_is('sub w ($$) {my ($l, my $r) = @_; my $v = \@_; undef @_; $l <=> $r}; print join q{ }, sort w 3, 1, 2, 0', - '0 1 2 3', - {stderr => 1, switches => ['-w']}, - 'RT #72334'); - -fresh_perl_is('sub w ($$) {my ($l, my $r) = @_; my $v = \@_; undef @_; @_ = 0..2; $l <=> $r}; print join q{ }, sort w 3, 1, 2, 0', - '0 1 2 3', - {stderr => 1, switches => ['-w']}, - 'RT #72334'); - -{ - my $count = 0; - { - package Counter; - - sub new { - ++$count; - bless []; - } - - sub DESTROY { - --$count; - } - } - - sub sorter ($$) { - my ($l, $r) = @_; - my $q = \@_; - $l <=> $r; - } - - is($count, 0, 'None before we start'); - my @a = map { Counter->new() } 0..1; - is($count, 2, '2 here'); - - my @b = sort sorter @a; - - is(scalar @b, 2); - cmp_ok($b[0], '<', $b[1], 'sorted!'); - - is($count, 2, 'still the same 2 here'); - - @a = (); @b = (); - - is($count, 0, 'all gone'); -} - -# [perl #77930] The context stack may be reallocated during a sort, as a -# result of deeply-nested (or not-so-deeply-nested) calls -# from a custom sort subroutine. -fresh_perl_is - ' - $sub = sub { - local $count = $count+1; - ()->$sub if $count < 1000; - $a cmp $b - }; - () = sort $sub qw; - print "ok" - ', - 'ok', - {}, - '[perl #77930] cx_stack reallocation during sort' -; - -# [perl #76026] -# Match vars should not leak from one sort sub call to the next -{ - my $output = ''; - sub soarter { - $output .= $1; - "Leakage" =~ /(.*)/; - 1 - } - sub soarterdd($$) { - $output .= $1; - "Leakage" =~ /(.*)/; - 1 - } - - "Win" =~ /(.*)/; - my @b = sort soarter 0..2; - - like $output, qr/^(?:Win)+\z/, - "Match vars do not leak from one plain sort sub to the next"; - - $output = ''; - - "Win" =~ /(.*)/; - @b = sort soarterdd 0..2; - - like $output, qr/^(?:Win)+\z/, - 'Match vars do not leak from one $$ sort sub to the next'; -} diff --git a/t/CORE/op/splice.t b/t/CORE/op/splice.t deleted file mode 100644 index bc6fb4027..000000000 --- a/t/CORE/op/splice.t +++ /dev/null @@ -1,99 +0,0 @@ -#!./perl - -print "1..21\n"; - -@a = (1..10); - -sub j { join(":",@_) } - -print "not " unless j(splice(@a,@a,0,11,12)) eq "" && j(@a) eq j(1..12); -print "ok 1\n"; - -print "not " unless j(splice(@a,-1)) eq "12" && j(@a) eq j(1..11); -print "ok 2\n"; - -print "not " unless j(splice(@a,0,1)) eq "1" && j(@a) eq j(2..11); -print "ok 3\n"; - -print "not " unless j(splice(@a,0,0,0,1)) eq "" && j(@a) eq j(0..11); -print "ok 4\n"; - -print "not " unless j(splice(@a,5,1,5)) eq "5" && j(@a) eq j(0..11); -print "ok 5\n"; - -print "not " unless j(splice(@a, @a, 0, 12, 13)) eq "" && j(@a) eq j(0..13); -print "ok 6\n"; - -print "not " unless j(splice(@a, -@a, @a, 1, 2, 3)) eq j(0..13) && j(@a) eq j(1..3); -print "ok 7\n"; - -print "not " unless j(splice(@a, 1, -1, 7, 7)) eq "2" && j(@a) eq j(1,7,7,3); -print "ok 8\n"; - -print "not " unless j(splice(@a,-3,-2,2)) eq j(7) && j(@a) eq j(1,2,7,3); -print "ok 9\n"; - -# Bug 20000223.001 - no test for splice(@array). Destructive test! -print "not " unless j(splice(@a)) eq j(1,2,7,3) && j(@a) eq ''; -print "ok 10\n"; - -# Tests 11 and 12: -# [ID 20010711.005] in Tie::Array, SPLICE ignores context, breaking SHIFT - -my $foo; - -@a = ('red', 'green', 'blue'); -$foo = splice @a, 1, 2; -print "not " unless $foo eq 'blue'; -print "ok 11\n"; - -@a = ('red', 'green', 'blue'); -$foo = shift @a; -print "not " unless $foo eq 'red'; -print "ok 12\n"; - -# Bug [perl #30568] - insertions of deleted elements -@a = (1, 2, 3); -splice( @a, 0, 3, $a[1], $a[0] ); -print "not " unless j(@a) eq j(2,1); -print "ok 13\n"; - -@a = (1, 2, 3); -splice( @a, 0, 3 ,$a[0], $a[1] ); -print "not " unless j(@a) eq j(1,2); -print "ok 14\n"; - -@a = (1, 2, 3); -splice( @a, 0, 3 ,$a[2], $a[1], $a[0] ); -print "not " unless j(@a) eq j(3,2,1); -print "ok 15\n"; - -@a = (1, 2, 3); -splice( @a, 0, 3, $a[0], $a[1], $a[2], $a[0], $a[1], $a[2] ); -print "not " unless j(@a) eq j(1,2,3,1,2,3); -print "ok 16\n"; - -@a = (1, 2, 3); -splice( @a, 1, 2, $a[2], $a[1] ); -print "not " unless j(@a) eq j(1,3,2); -print "ok 17\n"; - -@a = (1, 2, 3); -splice( @a, 1, 2, $a[1], $a[1] ); -print "not " unless j(@a) eq j(1,2,2); -print "ok 18\n"; - -# splice should invoke get magic - -print "not " if Foo->isa('Bar'); -print "ok 19\n"; - -splice @Foo::ISA, 0, 0, 'Bar'; - -print "not " if !Foo->isa('Bar'); -print "ok 20\n"; - -# Test undef first arg -eval { splice( $new_arrayref, 0, 0, 1, 2, 3 ) }; -print "not " unless $@ && $@ =~ /Not an ARRAY/; -print "ok 21\n"; diff --git a/t/CORE/op/split.t b/t/CORE/op/split.t deleted file mode 100644 index 81761b9a4..000000000 --- a/t/CORE/op/split.t +++ /dev/null @@ -1,418 +0,0 @@ -#!./perl - -BEGIN { - unshift @INC, 't/CORE/lib'; - require 't/CORE/test.pl'; -} - -plan tests => 102; - -$FS = ':'; - -$_ = 'a:b:c'; - -($a,$b,$c) = split($FS,$_); - -is(join(';',$a,$b,$c), 'a;b;c'); - -@ary = split(/:b:/); -$cnt = split(/:b:/); -is(join("$_",@ary), 'aa:b:cc'); -is($cnt, scalar(@ary)); - -$_ = "abc\n"; -my @xyz = (@ary = split(//)); -$cnt = split(//); -is(join(".",@ary), "a.b.c.\n"); -is($cnt, scalar(@ary)); - -$_ = "a:b:c::::"; -@ary = split(/:/); -$cnt = split(/:/); -is(join(".",@ary), "a.b.c"); -is($cnt, scalar(@ary)); - -$_ = join(':',split(' '," a b\tc \t d ")); -is($_, 'a:b:c:d'); -@ary = split(' '," a b\tc \t d "); -$cnt = split(' '," a b\tc \t d "); -is($cnt, scalar(@ary)); - -$_ = join(':',split(/ */,"foo bar bie\tdoll")); -is($_ , "f:o:o:b:a:r:b:i:e:\t:d:o:l:l"); -@ary = split(/ */,"foo bar bie\tdoll"); -$cnt = split(/ */,"foo bar bie\tdoll"); -is($cnt, scalar(@ary)); - -$_ = join(':', 'foo', split(/ /,'a b c'), 'bar'); -is($_, "foo:a:b::c:bar"); -@ary = split(/ /,'a b c'); -$cnt = split(/ /,'a b c'); -is($cnt, scalar(@ary)); - -# Can we say how many fields to split to? -$_ = join(':', split(' ','1 2 3 4 5 6', 3)); -is($_, '1:2:3 4 5 6'); -@ary = split(' ','1 2 3 4 5 6', 3); -$cnt = split(' ','1 2 3 4 5 6', 3); -is($cnt, scalar(@ary)); - -# Can we do it as a variable? -$x = 4; -$_ = join(':', split(' ','1 2 3 4 5 6', $x)); -is($_, '1:2:3:4 5 6'); -@ary = split(' ','1 2 3 4 5 6', $x); -$cnt = split(' ','1 2 3 4 5 6', $x); -is($cnt, scalar(@ary)); - -# Does the 999 suppress null field chopping? -$_ = join(':', split(/:/,'1:2:3:4:5:6:::', 999)); -is($_ , '1:2:3:4:5:6:::'); -@ary = split(/:/,'1:2:3:4:5:6:::', 999); -$cnt = split(/:/,'1:2:3:4:5:6:::', 999); -is($cnt, scalar(@ary)); - -# Splitting without pattern -$_ = "1 2 3 4"; -$_ = join(':', split); -is($_ , '1:2:3:4'); - -# Does assignment to a list imply split to one more field than that? -$foo = runperl( switches => ['-Dt'], stderr => 1, prog => '($a,$b)=split;' ); -ok($foo =~ /DEBUGGING/ || $foo =~ /const\n?\Q(IV(3))\E/); - -# Can we say how many fields to split to when assigning to a list? -($a,$b) = split(' ','1 2 3 4 5 6', 2); -$_ = join(':',$a,$b); -is($_, '1:2 3 4 5 6'); - -# do subpatterns generate additional fields (without trailing nulls)? -$_ = join '|', split(/,|(-)/, "1-10,20,,,"); -is($_, "1|-|10||20"); -@ary = split(/,|(-)/, "1-10,20,,,"); -$cnt = split(/,|(-)/, "1-10,20,,,"); -is($cnt, scalar(@ary)); - -# do subpatterns generate additional fields (with a limit)? -$_ = join '|', split(/,|(-)/, "1-10,20,,,", 10); -is($_, "1|-|10||20||||||"); -@ary = split(/,|(-)/, "1-10,20,,,", 10); -$cnt = split(/,|(-)/, "1-10,20,,,", 10); -is($cnt, scalar(@ary)); - -# is the 'two undefs' bug fixed? -(undef, $a, undef, $b) = qw(1 2 3 4); -is("$a|$b", "2|4"); - -# .. even for locals? -{ - local(undef, $a, undef, $b) = qw(1 2 3 4); - is("$a|$b", "2|4"); -} - -# check splitting of null string -$_ = join('|', split(/x/, '',-1), 'Z'); -is($_, "Z"); -@ary = split(/x/, '',-1); -$cnt = split(/x/, '',-1); -is($cnt, scalar(@ary)); - -$_ = join('|', split(/x/, '', 1), 'Z'); -is($_, "Z"); -@ary = split(/x/, '', 1); -$cnt = split(/x/, '', 1); -is($cnt, scalar(@ary)); - -$_ = join('|', split(/(p+)/,'',-1), 'Z'); -is($_, "Z"); -@ary = split(/(p+)/,'',-1); -$cnt = split(/(p+)/,'',-1); -is($cnt, scalar(@ary)); - -$_ = join('|', split(/.?/, '',-1), 'Z'); -is($_, "Z"); -@ary = split(/.?/, '',-1); -$cnt = split(/.?/, '',-1); -is($cnt, scalar(@ary)); - - -# Are /^/m patterns scanned? -$_ = join '|', split(/^a/m, "a b a\na d a", 20); -is($_, "| b a\n| d a"); -@ary = split(/^a/m, "a b a\na d a", 20); -$cnt = split(/^a/m, "a b a\na d a", 20); -is($cnt, scalar(@ary)); - -# Are /$/m patterns scanned? -$_ = join '|', split(/a$/m, "a b a\na d a", 20); -is($_, "a b |\na d |"); -@ary = split(/a$/m, "a b a\na d a", 20); -$cnt = split(/a$/m, "a b a\na d a", 20); -is($cnt, scalar(@ary)); - -# Are /^/m patterns scanned? -$_ = join '|', split(/^aa/m, "aa b aa\naa d aa", 20); -is($_, "| b aa\n| d aa"); -@ary = split(/^aa/m, "aa b aa\naa d aa", 20); -$cnt = split(/^aa/m, "aa b aa\naa d aa", 20); -is($cnt, scalar(@ary)); - -# Are /$/m patterns scanned? -$_ = join '|', split(/aa$/m, "aa b aa\naa d aa", 20); -is($_, "aa b |\naa d |"); -@ary = split(/aa$/m, "aa b aa\naa d aa", 20); -$cnt = split(/aa$/m, "aa b aa\naa d aa", 20); -is($cnt, scalar(@ary)); - -# Greedyness: -$_ = "a : b :c: d"; -@ary = split(/\s*:\s*/); -$cnt = split(/\s*:\s*/); -is(($res = join(".",@ary)), "a.b.c.d", $res); -is($cnt, scalar(@ary)); - -# use of match result as pattern (!) -is('p:q:r:s', join ':', split('abc' =~ /b/, 'p1q1r1s')); -@ary = split('abc' =~ /b/, 'p1q1r1s'); -$cnt = split('abc' =~ /b/, 'p1q1r1s'); -is($cnt, scalar(@ary)); - -# /^/ treated as /^/m -$_ = join ':', split /^/, "ab\ncd\nef\n"; -is($_, "ab\n:cd\n:ef\n"); - -# see if @a = @b = split(...) optimization works -@list1 = @list2 = split ('p',"a p b c p"); -ok(@list1 == @list2 && - "@list1" eq "@list2" && - @list1 == 2 && - "@list1" eq "a b c "); - -# zero-width assertion -$_ = join ':', split /(?=\w)/, "rm b"; -is($_, "r:m :b"); -@ary = split /(?=\w)/, "rm b"; -$cnt = split /(?=\w)/, "rm b"; -is($cnt, scalar(@ary)); - -# unicode splittage - -@ary = map {ord} split //, v1.20.300.4000.50000.4000.300.20.1; -$cnt = split //, v1.20.300.4000.50000.4000.300.20.1; -is("@ary", "1 20 300 4000 50000 4000 300 20 1"); -is($cnt, scalar(@ary)); - -@ary = split(/\x{FE}/, "\x{FF}\x{FE}\x{FD}"); # bug id 20010105.016 -$cnt = split(/\x{FE}/, "\x{FF}\x{FE}\x{FD}"); # bug id 20010105.016 -ok(@ary == 2 && - $ary[0] eq "\xFF" && $ary[1] eq "\xFD" && - $ary[0] eq "\x{FF}" && $ary[1] eq "\x{FD}"); -is($cnt, scalar(@ary)); - -@ary = split(/(\x{FE}\xFE)/, "\xFF\x{FF}\xFE\x{FE}\xFD\x{FD}"); # variant of 31 -$cnt = split(/(\x{FE}\xFE)/, "\xFF\x{FF}\xFE\x{FE}\xFD\x{FD}"); # variant of 31 -ok(@ary == 3 && - $ary[0] eq "\xFF\xFF" && - $ary[0] eq "\x{FF}\xFF" && - $ary[0] eq "\x{FF}\x{FF}" && - $ary[1] eq "\xFE\xFE" && - $ary[1] eq "\x{FE}\xFE" && - $ary[1] eq "\x{FE}\x{FE}" && - $ary[2] eq "\xFD\xFD" && - $ary[2] eq "\x{FD}\xFD" && - $ary[2] eq "\x{FD}\x{FD}"); -is($cnt, scalar(@ary)); - -{ - my @a = map ord, split(//, join("", map chr, (1234, 123, 2345))); - my $c = split(//, join("", map chr, (1234, 123, 2345))); - is("@a", "1234 123 2345"); - is($c, scalar(@a)); -} - -{ - my $x = 'A'; - my @a = map ord, split(/$x/, join("", map chr, (1234, ord($x), 2345))); - my $c = split(/$x/, join("", map chr, (1234, ord($x), 2345))); - is("@a", "1234 2345"); - is($c, scalar(@a)); -} - -{ - # bug id 20000427.003 - - use warnings; - use strict; - - my $sushi = "\x{b36c}\x{5a8c}\x{ff5b}\x{5079}\x{505b}"; - - my @charlist = split //, $sushi; - my $charnum = split //, $sushi; - is($charnum, scalar(@charlist)); - my $r = ''; - foreach my $ch (@charlist) { - $r = $r . " " . sprintf "U+%04X", ord($ch); - } - - is($r, " U+B36C U+5A8C U+FF5B U+5079 U+505B"); -} - -{ - my $s = "\x20\x40\x{80}\x{100}\x{80}\x40\x20"; - - SKIP: { - if (ord('A') == 193) { - skip("EBCDIC", 1); - } else { - # bug id 20000426.003 - - my ($a, $b, $c) = split(/\x40/, $s); - ok($a eq "\x20" && $b eq "\x{80}\x{100}\x{80}" && $c eq $a); - } - } - - my ($a, $b) = split(/\x{100}/, $s); - ok($a eq "\x20\x40\x{80}" && $b eq "\x{80}\x40\x20"); - - my ($a, $b) = split(/\x{80}\x{100}\x{80}/, $s); - ok($a eq "\x20\x40" && $b eq "\x40\x20"); - - SKIP: { - if (ord('A') == 193) { - skip("EBCDIC", 1); - } else { - my ($a, $b) = split(/\x40\x{80}/, $s); - ok($a eq "\x20" && $b eq "\x{100}\x{80}\x40\x20"); - } - } - - my ($a, $b, $c) = split(/[\x40\x{80}]+/, $s); - ok($a eq "\x20" && $b eq "\x{100}" && $c eq "\x20"); -} - -{ - # 20001205.014 - - my $a = "ABC\x{263A}"; - - my @b = split( //, $a ); - my $c = split( //, $a ); - is($c, scalar(@b)); - - is(scalar @b, 4); - - ok(length($b[3]) == 1 && $b[3] eq "\x{263A}"); - - $a =~ s/^A/Z/; - ok(length($a) == 4 && $a eq "ZBC\x{263A}"); -} - -{ - my @a = split(/\xFE/, "\xFF\xFE\xFD"); - my $b = split(/\xFE/, "\xFF\xFE\xFD"); - - ok(@a == 2 && $a[0] eq "\xFF" && $a[1] eq "\xFD"); - is($b, scalar(@a)); -} - -{ - # check that PMf_WHITE is cleared after \s+ is used - # reported in <20010627113312.RWGY6087.viemta06@localhost> - my $r; - foreach my $pat ( qr/\s+/, qr/ll/ ) { - $r = join ':' => split($pat, "hello cruel world"); - } - is($r, "he:o cruel world"); -} - - -{ - # split /(A)|B/, "1B2" should return (1, undef, 2) - my @x = split /(A)|B/, "1B2"; - my $y = split /(A)|B/, "1B2"; - is($y, scalar(@x)); - ok($x[0] eq '1' and (not defined $x[1]) and $x[2] eq '2'); -} - -{ - # [perl #17064] - my $warn; - local $SIG{__WARN__} = sub { $warn = join '', @_; chomp $warn }; - my $char = "\x{10f1ff}"; - my @a = split /\r?\n/, "$char\n"; - my $b = split /\r?\n/, "$char\n"; - is($b, scalar(@a)); - ok(@a == 1 && $a[0] eq $char && !defined($warn)); -} - -{ - # [perl #18195] - for my $u (0, 1) { - for my $a (0, 1) { - $_ = 'readin,database,readout'; - utf8::upgrade $_ if $u; - /(.+)/; - my @d = split /[,]/,$1; - my $e = split /[,]/,$1; - is($e, scalar(@d)); - is(join (':',@d), 'readin:database:readout', "[perl #18195]"); - } - } -} - -{ - $p="a,b"; - utf8::upgrade $p; - eval { @a=split(/[, ]+/,$p) }; - eval { $b=split(/[, ]+/,$p) }; - is($b, scalar(@a)); - is ("$@-@a-", '-a b-', '#20912 - split() to array with /[]+/ and utf8'); -} - -{ - is (\@a, \@{"a"}, '@a must be global for following test'); - $p=""; - $n = @a = split /,/,$p; - is ($n, 0, '#21765 - pmreplroot hack used to return undef for 0 iters'); -} - -{ - # [perl #28938] - # assigning off the end of the array after a split could leave garbage - # in the inner elements - - my $x; - @a = split /,/, ',,,,,'; - $a[3]=1; - $x = \$a[2]; - is (ref $x, 'SCALAR', '#28938 - garbage after extend'); -} - -{ - my $src = "ABC \0 FOO \0 XYZ"; - my @s = split(" \0 ", $src); - my @r = split(/ \0 /, $src); - my $cs = split(" \0 ", $src); - my $cr = split(/ \0 /, $src); - is(scalar(@s), 3); - is($cs, 3); - is($cr, 3); - is($s[0], "ABC"); - is($s[1], "FOO"); - is($s[2]," XYZ"); - is(join(':',@s), join(':',@r)); -} - -{ - use constant BANG => {}; - () = split m/,/, "", BANG; - ok(1); -} - -{ - # Bug #69875 - # 'Hybrid' scalar-and-array context - scalar(our @PATH = split /::/, "Font::GlyphNames"); - # 'my' doesn't trigger the bug - is "@PATH", "Font GlyphNames", "hybrid scalar-and-array context"; -} diff --git a/t/CORE/op/split_unicode.t b/t/CORE/op/split_unicode.t deleted file mode 100644 index 9801714bd..000000000 --- a/t/CORE/op/split_unicode.t +++ /dev/null @@ -1,64 +0,0 @@ -#!./perl - -BEGIN { - require 't/CORE/test.pl'; -} - -plan(tests => 150); - -{ - # check the special casing of split /\s/ and unicode - use charnames qw(:full); - # below test data is extracted from - # PropList-5.0.0.txt - # Date: 2006-06-07, 23:22:52 GMT [MD] - # - # Unicode Character Database - # Copyright (c) 1991-2006 Unicode, Inc. - # For terms of use, see http://www.unicode.org/terms_of_use.html - # For documentation, see UCD.html - my @spaces=( - ord("\t"), # Cc - ord("\n"), # Cc - # not PerlSpace # Cc - ord("\f"), # Cc - ord("\r"), # Cc - ord(" "), # Zs SPACE - ord("\N{NEL}"), # Cc - ord("\N{NO-BREAK SPACE}"), - # Zs NO-BREAK SPACE - 0x1680, # Zs OGHAM SPACE MARK - 0x180E, # Zs MONGOLIAN VOWEL SEPARATOR - 0x2000..0x200A, # Zs [11] EN QUAD..HAIR SPACE - 0x2028, # Zl LINE SEPARATOR - 0x2029, # Zp PARAGRAPH SEPARATOR - 0x202F, # Zs NARROW NO-BREAK SPACE - 0x205F, # Zs MEDIUM MATHEMATICAL SPACE - 0x3000 # Zs IDEOGRAPHIC SPACE - ); - #diag "Have @{[0+@spaces]} to test\n"; - foreach my $cp (@spaces) { - my $msg = sprintf "Space: U+%04x", $cp; - my $space = chr($cp); - my $str="A:$space:B\x{FFFD}"; - chop $str; - - my @res=split(/\s+/,$str); - my $cnt=split(/\s+/,$str); - ok(@res == 2 && join('-',@res) eq "A:-:B", "$msg - /\\s+/"); - is($cnt, scalar(@res), "$msg - /\\s+/ (count)"); - - my $s2 = "$space$space:A:$space$space:B\x{FFFD}"; - chop $s2; - - my @r2 = split(' ',$s2); - my $c2 = split(' ',$s2); - ok(@r2 == 2 && join('-', @r2) eq ":A:-:B", "$msg - ' '"); - is($c2, scalar(@r2), "$msg - ' ' (count)"); - - my @r3 = split(/\s+/, $s2); - my $c3 = split(/\s+/, $s2); - ok(@r3 == 3 && join('-', @r3) eq "-:A:-:B", "$msg - /\\s+/ No.2"); - is($c3, scalar(@r3), "$msg - /\\s+/ No.2 (count)"); - } -} diff --git a/t/CORE/op/sprintf.t b/t/CORE/op/sprintf.t deleted file mode 100644 index 51e9c24eb..000000000 --- a/t/CORE/op/sprintf.t +++ /dev/null @@ -1,711 +0,0 @@ -#!./perl - -# Tests sprintf, excluding handling of 64-bit integers or long -# doubles (if supported), of machine-specific short and long -# integers, machine-specific floating point exceptions (infinity, -# not-a-number ...), of the effects of locale, and of features -# specific to multi-byte characters (under the utf8 pragma and such). - -BEGIN { - unshift @INC, 't/CORE/lib'; -} -use warnings; -use version; -use Config; -use strict; - -my @tests = (); -my ($i, $template, $data, $result, $comment, $w, $x, $evalData, $n, $p); - -my $Is_VMS_VAX = 0; -# We use HW_MODEL since ARCH_NAME was not in VMS V5.* -if ($^O eq 'VMS') { - my $hw_model; - chomp($hw_model = `write sys\$output f\$getsyi("HW_MODEL")`); - $Is_VMS_VAX = $hw_model < 1024 ? 1 : 0; -} - -# No %Config. -my $Is_Ultrix_VAX = $^O eq 'ultrix' && `uname -m` =~ /^VAX$/; - -while () { - s/^\s*>//; s/<\s*$//; - ($template, $data, $result, $comment) = split(/<\s*>/, $_, 4); - if ($^O eq 'os390' || $^O eq 's390') { # non-IEEE (s390 is UTS) - $data =~ s/([eE])96$/${1}63/; # smaller exponents - $result =~ s/([eE]\+)102$/${1}69/; # " " - $data =~ s/([eE])\-101$/${1}-56/; # larger exponents - $result =~ s/([eE])\-102$/${1}-57/; # " " - } - if ($Is_VMS_VAX || $Is_Ultrix_VAX) { - # VAX DEC C 5.3 at least since there is no - # ccflags =~ /float=ieee/ on VAX. - # AXP is unaffected whether or not it's using ieee. - $data =~ s/([eE])96$/${1}26/; # smaller exponents - $result =~ s/([eE]\+)102$/${1}32/; # " " - $data =~ s/([eE])\-101$/${1}-24/; # larger exponents - $result =~ s/([eE])\-102$/${1}-25/; # " " - } - - $evalData = eval $data; - $evalData = ref $evalData ? $evalData : [$evalData]; - push @tests, [$template, $evalData, $result, $comment, $data]; -} - -print '1..', scalar @tests, "\n"; - -$SIG{__WARN__} = sub { - if ($_[0] =~ /^Invalid conversion/) { - $w .= ' INVALID'; - } elsif ($_[0] =~ /^Use of uninitialized value/) { - $w .= ' UNINIT'; - } elsif ($_[0] =~ /^Missing argument/) { - $w .= ' MISSING'; - } else { - warn @_; - } -}; - -for ($i = 1; @tests; $i++) { - ($template, $evalData, $result, $comment, $data) = @{shift @tests}; - $w = undef; - $x = sprintf($template, @$evalData); - $x = ">$x<" if defined $x; - substr($x, -1, 0) = $w if $w; - # $x may have 3 exponent digits, not 2 - my $y = $x; - if ($y =~ s/([Ee][-+])0(\d)/$1$2/) { - # if result is left-adjusted, append extra space - if ($template =~ /%\+?\-/ and $result =~ / $/) { - $y =~ s/<$/ 0/>00/; - } - # if result is right-adjusted, prepend extra space - elsif ($result =~ /^ /) { - $y =~ s/^>/> /; - } - } - - my $skip = 0; - if ($comment =~ s/\s+skip:\s*(.*)//) { - my $os = $1; - my $osv = exists $Config{osvers} ? $Config{osvers} : "0"; - # >comment skip: all< - if ($os =~ /\ball\b/i) { - $skip = 1; - # >comment skip: VMS hpux:10.20< - } elsif ($os =~ /\b$^O(?::(\S+))?\b/i) { - my $vsn = defined $1 ? $1 : "0"; - # Only compare on the the first pair of digits, as numeric - # compares don't like 2.6.10-3mdksmp or 2.6.8-24.10-default - s/^(\d+(\.\d+)?).*/$1/ for $osv, $vsn; - $skip = $vsn ? ($osv <= $vsn ? 1 : 0) : 1; - } - $skip and $comment =~ s/$/, failure expected on $^O $osv/; - } - - if ($x eq ">$result<") { - print "ok $i\n"; - } - elsif ($skip) { - print "ok $i # skip $comment\n"; - } - elsif ($y eq ">$result<") # Some C libraries always give - { # three-digit exponent - print("ok $i # >$result< $x three-digit exponent accepted\n"); - } - elsif ($result =~ /[-+]\d{3}$/ && - # Suppress tests with modulo of exponent >= 100 on platforms - # which can't handle such magnitudes (or where we can't tell). - ((!eval {require POSIX}) || # Costly: only do this if we must! - (length(&POSIX::DBL_MAX) - rindex(&POSIX::DBL_MAX, '+')) == 3)) - { - print("ok $i # >$template< >$data< >$result<", - " Suppressed: exponent out of range?\n"); - } - else { - $y = ($x eq $y ? "" : " => $y"); - print("not ok $i >$template< >$data< >$result< $x$y", - $comment ? " # $comment\n" : "\n"); - } -} - -# In each of the following lines, there are three required fields: -# printf template, data to be formatted (as a Perl expression), and -# expected result of formatting. An optional fourth field can contain -# a comment. Each field is delimited by a starting '>' and a -# finishing '<'; any whitespace outside these start and end marks is -# not part of the field. If formatting requires more than one data -# item (for example, if variable field widths are used), the Perl data -# expression should return a reference to an array having the requisite -# number of elements. Even so, subterfuge is sometimes required: see -# tests for %n and %p. -# -# Tests that are expected to fail on a certain OS can be marked as such -# by trailing the comment with a skip: section. Skips are tags separated -# bu space consisting of a $^O optionally trailed with :osvers. In the -# latter case, all os-levels below that are expected to fail. A special -# tag 'all' is allowed for todo tests that should fail on any system -# -# >%G< >1234567e96< >1.23457E+102< >exponent too big skip: os390< -# >%.0g< >-0.0< >-0< >No minus skip: MSWin32 VMS hpux:10.20< -# >%d< >4< >1< >4 != 1 skip: all< -# -# The following tests are not currently run, for the reasons stated: - -=pod - -=begin problematic - ->%.0f< >1.5< >2< >Standard vague: no rounding rules< ->%.0f< >2.5< >2< >Standard vague: no rounding rules< - -=end problematic - -=cut - -# template data result -__END__ ->%6. 6s< >''< >%6. 6s INVALID< >(See use of $w in code above)< ->%6 .6s< >''< >%6 .6s INVALID< ->%6.6 s< >''< >%6.6 s INVALID< ->%A< >''< >%A INVALID< ->%B< >2**32-1< >11111111111111111111111111111111< ->%+B< >2**32-1< >11111111111111111111111111111111< ->%#B< >2**32-1< >0B11111111111111111111111111111111< ->%C< >''< >%C INVALID< ->%D< >0x7fffffff< >2147483647< >Synonym for %ld< ->%E< >123456.789< >1.234568E+05< >Like %e, but using upper-case "E"< ->%F< >123456.789< >123456.789000< >Synonym for %f< ->%G< >1234567.89< >1.23457E+06< >Like %g, but using upper-case "E"< ->%G< >1234567e96< >1.23457E+102< ->%G< >.1234567e-101< >1.23457E-102< ->%G< >12345.6789< >12345.7< ->%G< >1234567e96< >1.23457E+102< >exponent too big skip: os390< ->%G< >.1234567e-101< >1.23457E-102< >exponent too small skip: os390< ->%H< >''< >%H INVALID< ->%I< >''< >%I INVALID< ->%J< >''< >%J INVALID< ->%K< >''< >%K INVALID< ->%L< >''< >%L INVALID< ->%M< >''< >%M INVALID< ->%N< >''< >%N INVALID< ->%O< >2**32-1< >37777777777< >Synonym for %lo< ->%P< >''< >%P INVALID< ->%Q< >''< >%Q INVALID< ->%R< >''< >%R INVALID< ->%S< >''< >%S INVALID< ->%T< >''< >%T INVALID< ->%U< >2**32-1< >4294967295< >Synonym for %lu< ->%V< >''< >%V INVALID< ->%W< >''< >%W INVALID< ->%X< >2**32-1< >FFFFFFFF< >Like %x, but with u/c letters< ->%#X< >2**32-1< >0XFFFFFFFF< ->%Y< >''< >%Y INVALID< ->%Z< >''< >%Z INVALID< ->%a< >''< >%a INVALID< ->%b< >2**32-1< >11111111111111111111111111111111< ->%+b< >2**32-1< >11111111111111111111111111111111< ->%#b< >2**32-1< >0b11111111111111111111111111111111< ->%34b< >2**32-1< > 11111111111111111111111111111111< ->%034b< >2**32-1< >0011111111111111111111111111111111< ->%-34b< >2**32-1< >11111111111111111111111111111111 < ->%-034b< >2**32-1< >11111111111111111111111111111111 < ->%6b< >12< > 1100< ->%6.5b< >12< > 01100< ->%-6.5b< >12< >01100 < ->%+6.5b< >12< > 01100< ->% 6.5b< >12< > 01100< ->%06.5b< >12< > 01100< >0 flag with precision: no effect< ->%.5b< >12< >01100< ->%.0b< >0< >< ->%+.0b< >0< >< ->% .0b< >0< >< ->%-.0b< >0< >< ->%#.0b< >0< >< ->%#3.0b< >0< > < ->%#3.1b< >0< > 0< ->%#3.2b< >0< > 00< ->%#3.3b< >0< >000< ->%#3.4b< >0< >0000< ->%.0b< >1< >1< ->%+.0b< >1< >1< ->% .0b< >1< >1< ->%-.0b< >1< >1< ->%#.0b< >1< >0b1< ->%#3.0b< >1< >0b1< ->%#3.1b< >1< >0b1< ->%#3.2b< >1< >0b01< ->%#3.3b< >1< >0b001< ->%#3.4b< >1< >0b0001< ->%c< >ord('A')< >A< ->%10c< >ord('A')< > A< ->%#10c< >ord('A')< > A< ># modifier: no effect< ->%010c< >ord('A')< >000000000A< ->%10lc< >ord('A')< > A< >l modifier: no effect< ->%10hc< >ord('A')< > A< >h modifier: no effect< ->%10.5c< >ord('A')< > A< >precision: no effect< ->%-10c< >ord('A')< >A < ->%d< >123456.789< >123456< ->%d< >-123456.789< >-123456< ->%d< >0< >0< ->%-d< >0< >0< ->%+d< >0< >+0< ->% d< >0< > 0< ->%0d< >0< >0< ->%-3d< >1< >1 < ->%+3d< >1< > +1< ->% 3d< >1< > 1< ->%03d< >1< >001< ->%+ 3d< >1< > +1< ->% +3d< >1< > +1< ->%.0d< >0< >< ->%+.0d< >0< >+< ->% .0d< >0< > < ->%-.0d< >0< >< ->%#.0d< >0< >< ->%.0d< >1< >1< ->%d< >1< >1< ->%+d< >1< >+1< ->%#3.2d< >1< > 01< ># modifier: no effect< ->%3.2d< >1< > 01< ->%03.2d< >1< > 01< >0 flag with precision: no effect< ->%-3.2d< >1< >01 < ->%+3.2d< >1< >+01< ->% 3.2d< >1< > 01< ->%-03.2d< >1< >01 < >zero pad + left just.: no effect< ->%3.*d< >[2,1]< > 01< ->%3.*d< >[1,1]< > 1< ->%3.*d< >[0,1]< > 1< ->%3.*d< >[-1,1]< > 1< ->%.*d< >[0,0]< >< ->%-.*d< >[0,0]< >< ->%+.*d< >[0,0]< >+< ->% .*d< >[0,0]< > < ->%0.*d< >[0,0]< >< ->%.*d< >[-2,0]< >0< ->%-.*d< >[-2,0]< >0< ->%+.*d< >[-2,0]< >+0< ->% .*d< >[-2,0]< > 0< ->%0.*d< >[-2,0]< >0< ->%d< >-1< >-1< ->%-d< >-1< >-1< ->%+d< >-1< >-1< ->% d< >-1< >-1< ->%-3d< >-1< >-1 < ->%+3d< >-1< > -1< ->% 3d< >-1< > -1< ->%03d< >-1< >-01< ->%hd< >1< >1< >More extensive testing of< ->%hhd< >1< >1< >length modifiers would be< ->%ld< >1< >1< >platform-specific< ->%Vd< >1< >1< ->%zd< >1< >1< ->%td< >1< >1< ->%vd< >chr(1)< >1< ->%+vd< >chr(1)< >+1< ->%#vd< >chr(1)< >1< ->%vd< >"\01\02\03"< >1.2.3< ->%vd< >v1.2.3< >1.2.3< ->%vd< >[version::qv("1.2.3")]< >1.2.3< ->%vd< >[version->new("1.2")]< >1.2< ->%vd< >[version->new("1.02")]< >1.2< ->%vd< >[version->new("1.002")]< >1.2< ->%vd< >[version->new("1048576.5")]< >1048576.5< ->%vd< >[version->new("50")]< >50< ->%v.3d< >"\01\02\03"< >001.002.003< ->%0v3d< >"\01\02\03"< >001.002.003< ->%v.3d< >[version::qv("1.2.3")]< >001.002.003< ->%-v3d< >"\01\02\03"< >1 .2 .3 < ->%+-v3d< >"\01\02\03"< >+1 .2 .3 < ->%+-v3d< >[version::qv("1.2.3")]< >+1 .2 .3 < ->%v4.3d< >"\01\02\03"< > 001. 002. 003< ->%0v4.3d< >"\01\02\03"< > 001. 002. 003< ->%0*v2d< >['-', "\0\7\14"]< >00-07-12< ->%v.*d< >[3, "\01\02\03"]< >001.002.003< >cf perl #83194< ->%0v*d< >[3, "\01\02\03"]< >001.002.003< >cf perl #83194< ->%-v*d< >[3, "\01\02\03"]< >1 .2 .3 < >cf perl #83194< ->%+-v*d< >[3, "\01\02\03"]< >+1 .2 .3 < >cf perl #83194< ->%v*.*d< >[4, 3, "\01\02\03"]< > 001. 002. 003< >cf perl #83194< ->%0v*.*d< >[4, 3, "\01\02\03"]< > 001. 002. 003< >cf perl #83194< ->%0*v*d< >['-', 2, "\0\7\13"]< >00-07-11< >cf perl #83194< ->%0*v*d< >['-', 2, version::qv("0.7.11")]< >00-07-11< >cf perl #83194< ->%e< >1234.875< >1.234875e+03< ->%e< >0.000012345< >1.234500e-05< ->%e< >1234567E96< >1.234567e+102< ->%e< >0< >0.000000e+00< ->%e< >.1234567E-101< >1.234567e-102< ->%+e< >1234.875< >+1.234875e+03< ->%#e< >1234.875< >1.234875e+03< ->%e< >-1234.875< >-1.234875e+03< ->%+e< >-1234.875< >-1.234875e+03< ->%#e< >-1234.875< >-1.234875e+03< ->%.0e< >1234.875< >1e+03< ->%#.0e< >1234.875< >1.e+03< ->%.0e< >1.875< >2e+00< ->%.0e< >0.875< >9e-01< ->%.*e< >[0, 1234.875]< >1e+03< ->%.1e< >1234.875< >1.2e+03< ->%-12.4e< >1234.875< >1.2349e+03 < ->%12.4e< >1234.875< > 1.2349e+03< ->%+-12.4e< >1234.875< >+1.2349e+03 < ->%+12.4e< >1234.875< > +1.2349e+03< ->%+-12.4e< >-1234.875< >-1.2349e+03 < ->%+12.4e< >-1234.875< > -1.2349e+03< ->%e< >1234567E96< >1.234567e+102< >exponent too big skip: os390< ->%e< >.1234567E-101< >1.234567e-102< >exponent too small skip: os390< ->%f< >1234.875< >1234.875000< ->%+f< >1234.875< >+1234.875000< ->%#f< >1234.875< >1234.875000< ->%f< >-1234.875< >-1234.875000< ->%+f< >-1234.875< >-1234.875000< ->%#f< >-1234.875< >-1234.875000< ->%6f< >1234.875< >1234.875000< ->%*f< >[6, 1234.875]< >1234.875000< ->%.0f< >-0.1< >-0< >C library bug: no minus skip: VMS< ->%.0f< >1234.875< >1235< ->%.1f< >1234.875< >1234.9< ->%-8.1f< >1234.875< >1234.9 < ->%8.1f< >1234.875< > 1234.9< ->%+-8.1f< >1234.875< >+1234.9 < ->%+8.1f< >1234.875< > +1234.9< ->%+-8.1f< >-1234.875< >-1234.9 < ->%+8.1f< >-1234.875< > -1234.9< ->%*.*f< >[5, 2, 12.3456]< >12.35< ->%f< >0< >0.000000< ->%.0f< >[]< >0 MISSING< -> %.0f< >[]< > 0 MISSING< ->%.2f< >[]< >0.00 MISSING< ->%.2fC< >[]< >0.00C MISSING< ->%.0f< >0< >0< ->%.0f< >2**38< >274877906944< >Should have exact int'l rep'n< ->%.0f< >0.1< >0< ->%.0f< >0.6< >1< >Known to fail with sfio, (irix|nonstop-ux|powerux); -DHAS_LDBL_SPRINTF_BUG may fix< ->%.0f< >-0.6< >-1< >Known to fail with sfio, (irix|nonstop-ux|powerux); -DHAS_LDBL_SPRINTF_BUG may fix< ->%.0f< >1.6< >2< ->%.0f< >-1.6< >-2< ->%.0f< >1< >1< ->%#.0f< >1< >1.< ->%.0lf< >1< >1< >'l' should have no effect< ->%.0hf< >1< >%.0hf INVALID< >'h' should be rejected< ->%g< >12345.6789< >12345.7< ->%+g< >12345.6789< >+12345.7< ->%#g< >12345.6789< >12345.7< ->%.0g< >[]< >0 MISSING< -> %.0g< >[]< > 0 MISSING< ->%.2g< >[]< >0 MISSING< ->%.2gC< >[]< >0C MISSING< ->%.0g< >-0.0< >-0< >C99 standard mandates minus sign but C89 does not skip: MSWin32 VMS hpux:10.20 openbsd netbsd:1.5 irix darwin< ->%.0g< >12345.6789< >1e+04< ->%#.0g< >12345.6789< >1.e+04< ->%.2g< >12345.6789< >1.2e+04< ->%.*g< >[2, 12345.6789]< >1.2e+04< ->%.9g< >12345.6789< >12345.6789< ->%12.9g< >12345.6789< > 12345.6789< ->%012.9g< >12345.6789< >0012345.6789< ->%-12.9g< >12345.6789< >12345.6789 < ->%*.*g< >[-12, 9, 12345.6789]< >12345.6789 < ->%-012.9g< >12345.6789< >12345.6789 < ->%g< >-12345.6789< >-12345.7< ->%+g< >-12345.6789< >-12345.7< ->%g< >1234567.89< >1.23457e+06< ->%+g< >1234567.89< >+1.23457e+06< ->%#g< >1234567.89< >1.23457e+06< ->%g< >-1234567.89< >-1.23457e+06< ->%+g< >-1234567.89< >-1.23457e+06< ->%#g< >-1234567.89< >-1.23457e+06< ->%g< >0.00012345< >0.00012345< ->%g< >0.000012345< >1.2345e-05< ->%g< >1234567E96< >1.23457e+102< ->%g< >.1234567E-101< >1.23457e-102< ->%g< >0< >0< ->%13g< >1234567.89< > 1.23457e+06< ->%+13g< >1234567.89< > +1.23457e+06< ->%013g< >1234567.89< >001.23457e+06< ->%-13g< >1234567.89< >1.23457e+06 < ->%g< >.1234567E-101< >1.23457e-102< >exponent too small skip: os390< ->%g< >1234567E96< >1.23457e+102< >exponent too big skip: os390< ->%h< >''< >%h INVALID< ->%i< >123456.789< >123456< >Synonym for %d< ->%j< >''< >%j INVALID< ->%k< >''< >%k INVALID< ->%l< >''< >%l INVALID< ->%m< >''< >%m INVALID< ->%s< >sprintf('%%n%n %d', $n, $n)< >%n 2< >Slight sneakiness to test %n< ->%o< >2**32-1< >37777777777< ->%+o< >2**32-1< >37777777777< ->%#o< >2**32-1< >037777777777< ->%o< >642< >1202< >check smaller octals across platforms< ->%+o< >642< >1202< ->% o< >642< >1202< ->%#o< >642< >01202< ->%4o< >18< > 22< ->%4.3o< >18< > 022< ->%-4.3o< >18< >022 < ->%+4.3o< >18< > 022< ->% 4.3o< >18< > 022< ->%04.3o< >18< > 022< >0 flag with precision: no effect< ->%4.o< >36< > 44< ->%-4.o< >36< >44 < ->%+4.o< >36< > 44< ->% 4.o< >36< > 44< ->%04.o< >36< > 44< >0 flag with precision: no effect< ->%.3o< >18< >022< ->%.0o< >0< >< ->%+.0o< >0< >< ->% .0o< >0< >< ->%-.0o< >0< >< ->%#.0o< >0< >0< ->%#3.0o< >0< > 0< ->%#3.1o< >0< > 0< ->%#3.2o< >0< > 00< ->%#3.3o< >0< >000< ->%#3.4o< >0< >0000< ->%.0o< >1< >1< ->%+.0o< >1< >1< ->% .0o< >1< >1< ->%-.0o< >1< >1< ->%#.0o< >1< >01< ->%#3.0o< >1< > 01< ->%#3.1o< >1< > 01< ->%#3.2o< >1< > 01< ->%#3.3o< >1< >001< ->%#3.4o< >1< >0001< ->%#.5o< >012345< >012345< ->%#.5o< >012< >00012< ->%#4o< >17< > 021< ->%#-4o< >17< >021 < ->%-#4o< >17< >021 < ->%#+4o< >17< > 021< ->%# 4o< >17< > 021< ->%#04o< >17< >0021< ->%#4.o< >16< > 020< ->%#-4.o< >16< >020 < ->%-#4.o< >16< >020 < ->%#+4.o< >16< > 020< ->%# 4.o< >16< > 020< ->%#04.o< >16< > 020< >0 flag with precision: no effect< ->%#4.3o< >18< > 022< ->%#-4.3o< >18< >022 < ->%-#4.3o< >18< >022 < ->%#+4.3o< >18< > 022< ->%# 4.3o< >18< > 022< ->%#04.3o< >18< > 022< >0 flag with precision: no effect< ->%#6.4o< >18< > 0022< ->%#-6.4o< >18< >0022 < ->%-#6.4o< >18< >0022 < ->%#+6.4o< >18< > 0022< ->%# 6.4o< >18< > 0022< ->%#06.4o< >18< > 0022< >0 flag with precision: no effect< ->%d< >$p=sprintf('%p',$p);$p=~/^[0-9a-f]+$/< >1< >Coarse hack: hex from %p?< ->%d< >$p=sprintf('%-8p',$p);$p=~/^[0-9a-f]+\s*$/< >1< >Coarse hack: hex from %p?< ->%#p< >''< >%#p INVALID< ->%q< >''< >%q INVALID< ->%r< >''< >%r INVALID< ->%s< >[]< > MISSING< -> %s< >[]< > MISSING< ->%s< >'string'< >string< ->%10s< >'string'< > string< ->%+10s< >'string'< > string< ->%#10s< >'string'< > string< ->%010s< >'string'< >0000string< ->%0*s< >[10, 'string']< >0000string< ->%-10s< >'string'< >string < ->%3s< >'string'< >string< ->%.3s< >'string'< >str< ->%.*s< >[3, 'string']< >str< ->%.*s< >[2, 'string']< >st< ->%.*s< >[1, 'string']< >s< ->%.*s< >[0, 'string']< >< ->%.*s< >[-1,'string']< >string< >negative precision to be ignored< ->%3.*s< >[3, 'string']< >str< ->%3.*s< >[2, 'string']< > st< ->%3.*s< >[1, 'string']< > s< ->%3.*s< >[0, 'string']< > < ->%3.*s< >[-1,'string']< >string< >negative precision to be ignored< ->%t< >''< >%t INVALID< ->%u< >2**32-1< >4294967295< ->%+u< >2**32-1< >4294967295< ->%#u< >2**32-1< >4294967295< ->%12u< >2**32-1< > 4294967295< ->%012u< >2**32-1< >004294967295< ->%-12u< >2**32-1< >4294967295 < ->%-012u< >2**32-1< >4294967295 < ->%4u< >18< > 18< ->%4.3u< >18< > 018< ->%-4.3u< >18< >018 < ->%+4.3u< >18< > 018< ->% 4.3u< >18< > 018< ->%04.3u< >18< > 018< >0 flag with precision: no effect< ->%.3u< >18< >018< ->%v< >''< >%v INVALID< ->%w< >''< >%w INVALID< ->%x< >2**32-1< >ffffffff< ->%+x< >2**32-1< >ffffffff< ->%#x< >2**32-1< >0xffffffff< ->%10x< >2**32-1< > ffffffff< ->%010x< >2**32-1< >00ffffffff< ->%-10x< >2**32-1< >ffffffff < ->%-010x< >2**32-1< >ffffffff < ->%0-10x< >2**32-1< >ffffffff < ->%4x< >18< > 12< ->%4.3x< >18< > 012< ->%-4.3x< >18< >012 < ->%+4.3x< >18< > 012< ->% 4.3x< >18< > 012< ->%04.3x< >18< > 012< >0 flag with precision: no effect< ->%.3x< >18< >012< ->%4X< >28< > 1C< ->%4.3X< >28< > 01C< ->%-4.3X< >28< >01C < ->%+4.3X< >28< > 01C< ->% 4.3X< >28< > 01C< ->%04.3X< >28< > 01C< >0 flag with precision: no effect< ->%.3X< >28< >01C< ->%.0x< >0< >< ->%+.0x< >0< >< ->% .0x< >0< >< ->%-.0x< >0< >< ->%#.0x< >0< >< ->%#3.0x< >0< > < ->%#3.1x< >0< > 0< ->%#3.2x< >0< > 00< ->%#3.3x< >0< >000< ->%#3.4x< >0< >0000< ->%.0x< >1< >1< ->%+.0x< >1< >1< ->% .0x< >1< >1< ->%-.0x< >1< >1< ->%#.0x< >1< >0x1< ->%#3.0x< >1< >0x1< ->%#3.1x< >1< >0x1< ->%#3.2x< >1< >0x01< ->%#3.3x< >1< >0x001< ->%#3.4x< >1< >0x0001< ->%#.5x< >0x12345< >0x12345< ->%#.5x< >0x12< >0x00012< ->%#4x< >28< >0x1c< ->%#4.3x< >28< >0x01c< ->%#-4.3x< >28< >0x01c< ->%#+4.3x< >28< >0x01c< ->%# 4.3x< >28< >0x01c< ->%#04.3x< >28< >0x01c< >0 flag with precision: no effect< ->%#.3x< >28< >0x01c< ->%#6.3x< >28< > 0x01c< ->%#-6.3x< >28< >0x01c < ->%-#6.3x< >28< >0x01c < ->%#+6.3x< >28< > 0x01c< ->%+#6.3x< >28< > 0x01c< ->%# 6.3x< >28< > 0x01c< ->% #6.3x< >28< > 0x01c< ->%0*x< >[-10, ,2**32-1]< >ffffffff < ->%vx< >[version::qv("1.2.3")]< >1.2.3< ->%vx< >[version::qv("1.20.300")]< >1.14.12c< ->%.*x< >[0,0]< >< ->%-.*x< >[0,0]< >< ->%+.*x< >[0,0]< >< ->% .*x< >[0,0]< >< ->%0.*x< >[0,0]< >< ->%.*x< >[-3,0]< >0< ->%-.*x< >[-3,0]< >0< ->%+.*x< >[-3,0]< >0< ->% .*x< >[-3,0]< >0< ->%0.*x< >[-3,0]< >0< ->%#.*x< >[0,0]< >< ->%#-.*x< >[0,0]< >< ->%#+.*x< >[0,0]< >< ->%# .*x< >[0,0]< >< ->%#0.*x< >[0,0]< >< ->%#.*x< >[-1,0]< >0< ->%#-.*x< >[-1,0]< >0< ->%#+.*x< >[-1,0]< >0< ->%# .*x< >[-1,0]< >0< ->%#0.*x< >[-1,0]< >0< ->%y< >''< >%y INVALID< ->%z< >''< >%z INVALID< ->%2$d %1$d< >[12, 34]< >34 12< ->%*2$d< >[12, 3]< > 12< ->%2$d %d< >[12, 34]< >34 12< ->%2$d %d %d< >[12, 34]< >34 12 34< ->%3$d %d %d< >[12, 34, 56]< >56 12 34< ->%2$*3$d %d< >[12, 34, 3]< > 34 12< ->%*3$2$d %d< >[12, 34, 3]< >%*3$2$d 12 INVALID< ->%2$d< >12< >0 MISSING< ->%0$d< >12< >%0$d INVALID< ->%1$$d< >12< >%1$$d INVALID< ->%1$1$d< >12< >%1$1$d INVALID< ->%*2$*2$d< >[12, 3]< >%*2$*2$d INVALID< ->%*2*2$d< >[12, 3]< >%*2*2$d INVALID< ->%*2$1d< >[12, 3]< >%*2$1d INVALID< ->%0v2.2d< >''< >< ->%vc,%d< >[63, 64, 65]< >%vc,63 INVALID< ->%v%,%d< >[63, 64, 65]< >%v%,63 INVALID< ->%vd,%d< >["\x1", 2, 3]< >1,2< ->%vf,%d< >[1, 2, 3]< >%vf,1 INVALID< ->%vF,%d< >[1, 2, 3]< >%vF,1 INVALID< ->%ve,%d< >[1, 2, 3]< >%ve,1 INVALID< ->%vE,%d< >[1, 2, 3]< >%vE,1 INVALID< ->%vg,%d< >[1, 2, 3]< >%vg,1 INVALID< ->%vG,%d< >[1, 2, 3]< >%vG,1 INVALID< ->%vp< >''< >%vp INVALID< ->%vn< >''< >%vn INVALID< ->%vs,%d< >[1, 2, 3]< >%vs,1 INVALID< ->%v_< >''< >%v_ INVALID< ->%v#x< >''< >%v#x INVALID< ->%v02x< >"\x66\x6f\x6f\012"< >66.6f.6f.0a< ->%#v.8b< >"\141\000\142"< >0b01100001.00000000.0b01100010< >perl #39530< ->%#v.0o< >"\001\000\002\000"< >01.0.02.0< ->%#v.1o< >"\001\000\002\000"< >01.0.02.0< ->%#v.4o< >"\141\000\142"< >0141.0000.0142< >perl #39530< ->%#v.3i< >"\141\000\142"< >097.000.098< >perl #39530< ->%#v.0x< >"\001\000\002\000"< >0x1..0x2.< ->%#v.1x< >"\001\000\002\000"< >0x1.0.0x2.0< ->%#v.2x< >"\141\000\142"< >0x61.00.0x62< >perl #39530< ->%#v.2X< >"\141\000\142"< >0X61.00.0X62< >perl #39530< ->%#v.8b< >"\141\017\142"< >0b01100001.0b00001111.0b01100010< >perl #39530< ->%#v.4o< >"\141\017\142"< >0141.0017.0142< >perl #39530< ->%#v.3i< >"\141\017\142"< >097.015.098< >perl #39530< ->%#v.2x< >"\141\017\142"< >0x61.0x0f.0x62< >perl #39530< ->%#v.2X< >"\141\017\142"< >0X61.0X0F.0X62< >perl #39530< ->%#*v.8b< >["][", "\141\000\142"]< >0b01100001][00000000][0b01100010< >perl #39530< ->%#*v.4o< >["][", "\141\000\142"]< >0141][0000][0142< >perl #39530< ->%#*v.3i< >["][", "\141\000\142"]< >097][000][098< >perl #39530< ->%#*v.2x< >["][", "\141\000\142"]< >0x61][00][0x62< >perl #39530< ->%#*v.2X< >["][", "\141\000\142"]< >0X61][00][0X62< >perl #39530< ->%#*v.8b< >["][", "\141\017\142"]< >0b01100001][0b00001111][0b01100010< >perl #39530< ->%#*v.4o< >["][", "\141\017\142"]< >0141][0017][0142< >perl #39530< ->%#*v.3i< >["][", "\141\017\142"]< >097][015][098< >perl #39530< ->%#*v.2x< >["][", "\141\017\142"]< >0x61][0x0f][0x62< >perl #39530< ->%#*v.2X< >["][", "\141\017\142"]< >0X61][0X0F][0X62< >perl #39530< ->%#v.8b< >"\141\x{1e01}\000\142\x{1e03}"< >0b01100001.0b1111000000001.00000000.0b01100010.0b1111000000011< >perl #39530< ->%#v.4o< >"\141\x{1e01}\000\142\x{1e03}"< >0141.017001.0000.0142.017003< >perl #39530< ->%#v.3i< >"\141\x{1e01}\000\142\x{1e03}"< >097.7681.000.098.7683< >perl #39530< ->%#v.2x< >"\141\x{1e01}\000\142\x{1e03}"< >0x61.0x1e01.00.0x62.0x1e03< >perl #39530< ->%#v.2X< >"\141\x{1e01}\000\142\x{1e03}"< >0X61.0X1E01.00.0X62.0X1E03< >perl #39530< ->%#v.8b< >"\141\x{1e01}\017\142\x{1e03}"< >0b01100001.0b1111000000001.0b00001111.0b01100010.0b1111000000011< >perl #39530< ->%#v.4o< >"\141\x{1e01}\017\142\x{1e03}"< >0141.017001.0017.0142.017003< >perl #39530< ->%#v.3i< >"\141\x{1e01}\017\142\x{1e03}"< >097.7681.015.098.7683< >perl #39530< ->%#v.2x< >"\141\x{1e01}\017\142\x{1e03}"< >0x61.0x1e01.0x0f.0x62.0x1e03< >perl #39530< ->%#v.2X< >"\141\x{1e01}\017\142\x{1e03}"< >0X61.0X1E01.0X0F.0X62.0X1E03< >perl #39530< ->%V-%s< >["Hello"]< >%V-Hello INVALID< ->%K %d %d< >[13, 29]< >%K 13 29 INVALID< ->%*.*K %d< >[13, 29, 76]< >%*.*K 13 INVALID< ->%4$K %d< >[45, 67]< >%4$K 45 MISSING INVALID< ->%d %K %d< >[23, 45]< >23 %K 45 INVALID< ->%*v*999\$d %d %d< >[11, 22, 33]< >%*v*999\$d 11 22 INVALID< ->%#b< >0< >0< ->%#o< >0< >0< ->%#x< >0< >0< ->%2147483647$v2d< >''< >< ->%*2147483647$v2d< >''< > MISSING< ->%.3X< >[11]< >00B< >perl #83194: hex, zero-padded to 3 places< ->%.*X< >[3, 11]< >00B< >perl #83194: dynamic precision< ->%vX< >['012']< >30.31.32< >perl #83194: vector flag< ->%*vX< >[':', '012']< >30:31:32< >perl #83194: vector flag + custom separator< ->%v.3X< >['012']< >030.031.032< >perl #83194: vector flag + static precision< ->%v.*X< >[3, '012']< >030.031.032< >perl #83194: vector flag + dynamic precision< ->%*v.3X< >[':', '012']< >030:031:032< >perl #83194: vector flag + custom separator + static precision< ->%*v.*X< >[':', 3, '012']< >030:031:032< >perl #83194: vector flag + custom separator + dynamic precision< diff --git a/t/CORE/op/sprintf2.t b/t/CORE/op/sprintf2.t deleted file mode 100644 index ddca59414..000000000 --- a/t/CORE/op/sprintf2.t +++ /dev/null @@ -1,181 +0,0 @@ -#!./perl -w - -BEGIN { - unshift @INC, 't/CORE/lib'; - require 't/CORE/test.pl'; -} - -plan tests => 1368; - -use strict; -use Config; - -is( - sprintf("%.40g ",0.01), - sprintf("%.40g", 0.01)." ", - q(the sprintf "%.g" optimization) -); -is( - sprintf("%.40f ",0.01), - sprintf("%.40f", 0.01)." ", - q(the sprintf "%.f" optimization) -); - -# cases of $i > 1 are against [perl #39126] -for my $i (1, 5, 10, 20, 50, 100) { - chop(my $utf8_format = "%-*s\x{100}"); - my $string = "\xB4"x$i; # latin1 ACUTE or ebcdic COPYRIGHT - my $expect = $string." "x$i; # followed by 2*$i spaces - is(sprintf($utf8_format, 3*$i, $string), $expect, - "width calculation under utf8 upgrade, length=$i"); -} - -# check simultaneous width & precision with wide characters -for my $i (1, 3, 5, 10) { - my $string = "\x{0410}"x($i+10); # cyrillic capital A - my $expect = "\x{0410}"x$i; # cut down to exactly $i characters - my $format = "%$i.${i}s"; - is(sprintf($format, $string), $expect, - "width & precision interplay with utf8 strings, length=$i"); -} - -# Used to mangle PL_sv_undef -fresh_perl_like( - 'print sprintf "xxx%n\n"; print undef', - 'Modification of a read-only value attempted at', - { switches => [ '-w' ] }, - q(%n should not be able to modify read-only constants), -); - -# check overflows -for (int(~0/2+1), ~0, "9999999999999999999") { - is(eval {sprintf "%${_}d", 0}, undef, "no sprintf result expected %${_}d"); - like($@, qr/^Integer overflow in format string for sprintf /, "overflow in sprintf"); - is(eval {printf "%${_}d\n", 0}, undef, "no printf result expected %${_}d"); - like($@, qr/^Integer overflow in format string for printf /, "overflow in printf"); -} - -# check %NNN$ for range bounds -{ - my ($warn, $bad) = (0,0); - local $SIG{__WARN__} = sub { - if ($_[0] =~ /missing argument/i) { - $warn++ - } - else { - $bad++ - } - }; - - my $fmt = join('', map("%$_\$s%" . ((1 << 31)-$_) . '$s', 1..20)); - my $result = sprintf $fmt, qw(a b c d); - is($result, "abcd", "only four valid values in $fmt"); - is($warn, 36, "expected warnings"); - is($bad, 0, "unexpected warnings"); -} - -{ - foreach my $ord (0 .. 255) { - my $bad = 0; - local $SIG{__WARN__} = sub { - if ($_[0] !~ /^Invalid conversion in sprintf/) { - warn $_[0]; - $bad++; - } - }; - my $r = eval {sprintf '%v' . chr $ord}; - is ($bad, 0, "pattern '%v' . chr $ord"); - } -} - -sub mysprintf_int_flags { - my ($fmt, $num) = @_; - die "wrong format $fmt" if $fmt !~ /^%([-+ 0]+)([1-9][0-9]*)d\z/; - my $flag = $1; - my $width = $2; - my $sign = $num < 0 ? '-' : - $flag =~ /\+/ ? '+' : - $flag =~ /\ / ? ' ' : - ''; - my $abs = abs($num); - my $padlen = $width - length($sign.$abs); - return - $flag =~ /0/ && $flag !~ /-/ # do zero padding - ? $sign . '0' x $padlen . $abs - : $flag =~ /-/ # left or right - ? $sign . $abs . ' ' x $padlen - : ' ' x $padlen . $sign . $abs; -} - -# Whole tests for "%4d" with 2 to 4 flags; -# total counts: 3 * (4**2 + 4**3 + 4**4) == 1008 - -my @flags = ("-", "+", " ", "0"); -for my $num (0, -1, 1) { - for my $f1 (@flags) { - for my $f2 (@flags) { - for my $f3 ('', @flags) { # '' for doubled flags - my $flag = $f1.$f2.$f3; - my $width = 4; - my $fmt = '%'."${flag}${width}d"; - my $result = sprintf($fmt, $num); - my $expect = mysprintf_int_flags($fmt, $num); - is($result, $expect, qq/sprintf("$fmt",$num)/); - - next if $f3 eq ''; - - for my $f4 (@flags) { # quadrupled flags - my $flag = $f1.$f2.$f3.$f4; - my $fmt = '%'."${flag}${width}d"; - my $result = sprintf($fmt, $num); - my $expect = mysprintf_int_flags($fmt, $num); - is($result, $expect, qq/sprintf("$fmt",$num)/); - } - } - } - } -} - -# test that %f doesn't panic with +Inf, -Inf, NaN [perl #45383] -foreach my $n (2**1e100, -2**1e100, 2**1e100/2**1e100) { # +Inf, -Inf, NaN - eval { my $f = sprintf("%f", $n); }; - is $@, "", "sprintf(\"%f\", $n)"; -} - -# test %ll formats with and without HAS_QUAD -eval { my $q = pack "q", 0 }; -my $Q = $@ eq ''; - -my @tests = ( - [ '%lld' => [qw( 4294967296 -100000000000000 )] ], - [ '%lli' => [qw( 4294967296 -100000000000000 )] ], - [ '%llu' => [qw( 4294967296 100000000000000 )] ], - [ '%Ld' => [qw( 4294967296 -100000000000000 )] ], - [ '%Li' => [qw( 4294967296 -100000000000000 )] ], - [ '%Lu' => [qw( 4294967296 100000000000000 )] ], -); - -for my $t (@tests) { - my($fmt, $nums) = @$t; - for my $num (@$nums) { - my $w; local $SIG{__WARN__} = sub { $w = shift }; - is(sprintf($fmt, $num), $Q ? $num : $fmt, "quad: $fmt -> $num"); - like($w, $Q ? '' : qr/Invalid conversion in sprintf: "$fmt"/, "warning: $fmt"); - } -} - -# Check unicode vs byte length -for my $width (1,2,3,4,5,6,7) { - for my $precis (1,2,3,4,5,6,7) { - my $v = "\x{20ac}\x{20ac}"; - my $format = "%" . $width . "." . $precis . "s"; - my $chars = ($precis > 2 ? 2 : $precis); - my $space = ($width < 2 ? 0 : $width - $chars); - fresh_perl_is( - 'my $v = "\x{20ac}\x{20ac}"; my $x = sprintf "'.$format.'", $v; $x =~ /^(\s*)(\S*)$/; print "$_" for map {length} $1, $2', - "$space$chars", - {}, - q(sprintf ").$format.q(", "\x{20ac}\x{20ac}"), - ); - } -} diff --git a/t/CORE/op/srand.t b/t/CORE/op/srand.t deleted file mode 100644 index 658736bfc..000000000 --- a/t/CORE/op/srand.t +++ /dev/null @@ -1,80 +0,0 @@ -#!./perl -w - -INIT { - unshift @INC, "t/CORE/lib"; -} - -# Test srand. - -use strict; - -require 't/CORE/test.pl'; -plan(tests => 9); - -# Generate a load of random numbers. -# int() avoids possible floating point error. -sub mk_rand { map int rand 10000, 1..100; } - - -# Check that rand() is deterministic. -srand(1138); -my @first_run = mk_rand; - -srand(1138); -my @second_run = mk_rand; - -ok( eq_array(\@first_run, \@second_run), 'srand(), same arg, same rands' ); - - -# Check that different seeds provide different random numbers -srand(31337); -@first_run = mk_rand; - -srand(1138); -@second_run = mk_rand; - -ok( !eq_array(\@first_run, \@second_run), - 'srand(), different arg, different rands' ); - - -# Check that srand() isn't affected by $_ -{ - local $_ = 42; - srand(); - @first_run = mk_rand; - - srand(42); - @second_run = mk_rand; - - ok( !eq_array(\@first_run, \@second_run), - 'srand(), no arg, not affected by $_'); -} - -# This test checks whether Perl called srand for you. -@first_run = `$^X -le "print int rand 100 for 1..100"`; -sleep(1); # in case our srand() is too time-dependent -@second_run = `$^X -le "print int rand 100 for 1..100"`; - -ok( !eq_array(\@first_run, \@second_run), 'srand() called automatically'); - -# check srand's return value -my $seed = srand(1764); -is( $seed, 1764, "return value" ); - -$seed = srand(0); -ok( $seed, "true return value for srand(0)"); -cmp_ok( $seed, '==', 0, "numeric 0 return value for srand(0)"); - -{ - my @warnings; - my $b; - { - local $SIG{__WARN__} = sub { - push @warnings, "@_"; - warn @_; - }; - $b = $seed + 0; - } - is( $b, 0, "Quacks like a zero"); - is( "@warnings", "", "Does not warn"); -} diff --git a/t/CORE/op/sselect.t b/t/CORE/op/sselect.t deleted file mode 100644 index 8729a8719..000000000 --- a/t/CORE/op/sselect.t +++ /dev/null @@ -1,45 +0,0 @@ -#!./perl - -require 't/CORE/test.pl'; - -plan (11); - -my $blank = ""; -eval {select undef, $blank, $blank, 0}; -is ($@, ""); -eval {select $blank, undef, $blank, 0}; -is ($@, ""); -eval {select $blank, $blank, undef, 0}; -is ($@, ""); - -eval {select "", $blank, $blank, 0}; -is ($@, ""); -eval {select $blank, "", $blank, 0}; -is ($@, ""); -eval {select $blank, $blank, "", 0}; -is ($@, ""); - -eval {select "a", $blank, $blank, 0}; -like ($@, qr/^Modification of a read-only value attempted/); -eval {select $blank, "a", $blank, 0}; -like ($@, qr/^Modification of a read-only value attempted/); -eval {select $blank, $blank, "a", 0}; -like ($@, qr/^Modification of a read-only value attempted/); - -my($sleep,$fudge) = (3,0); -# Actual sleep time on Windows may be rounded down to an integral -# multiple of the system clock tick interval. Clock tick interval -# is configurable, but usually about 15.625 milliseconds. -# time() however doesn't return fractional values, so the observed -# delay may be 1 second short. -($sleep,$fudge) = (4,1) if $^O eq "MSWin32"; - -my $t = time; -select(undef, undef, undef, $sleep); -ok(time-$t >= $sleep-$fudge, "$sleep seconds have passed"); - -my $empty = ""; -vec($empty,0,1) = 0; -$t = time; -select($empty, undef, undef, $sleep); -ok(time-$t >= $sleep-$fudge, "$sleep seconds have passed"); diff --git a/t/CORE/op/stash.t b/t/CORE/op/stash.t deleted file mode 100644 index db3400f84..000000000 --- a/t/CORE/op/stash.t +++ /dev/null @@ -1,319 +0,0 @@ -#!./perl - -BEGIN { - unshift @INC, "./lib"; -} - -BEGIN { require 't/CORE/test.pl'; } - -plan( tests => 54 ); - -# Used to segfault (bug #15479) -fresh_perl_like( - 'use warnings; %:: = ""', - qr/Odd number of elements in hash assignment at/, - { switches => [ '-w' ] }, - 'delete $::{STDERR} and print a warning', -); - -# Used to segfault -fresh_perl_is( - 'BEGIN { $::{"X::"} = 2 }', - '', - { switches => [ '-w' ] }, - q(Insert a non-GV in a stash, under warnings 'once'), -); - -{ - no warnings 'deprecated'; - ok( defined %oedipa::maas::, q(stashes happen to be defined if not used) ); - ok( defined %{"oedipa::maas::"}, q(- work with hard refs too) ); - - ok( defined %tyrone::slothrop::, q(stashes are defined if seen at compile time) ); - ok( defined %{"tyrone::slothrop::"}, q(- work with hard refs too) ); - - ok( defined %bongo::shaftsbury::, q(stashes are defined if a var is seen at compile time) ); - ok( defined %{"bongo::shaftsbury::"}, q(- work with hard refs too) ); -} - -package tyrone::slothrop; -$bongo::shaftsbury::scalar = 1; - -package main; - -# Used to warn -# Unbalanced string table refcount: (1) for "A::" during global destruction. -# for ithreads. -{ - local $ENV{PERL_DESTRUCT_LEVEL} = 2; - fresh_perl_is( - 'package A; sub a { // }; %::=""', - '', - '', - ); -} - -# now tests in eval - -ok( eval { no warnings 'deprecated'; defined %achtfaden:: }, 'works in eval{}' ); -ok( eval q{ no warnings 'deprecated'; defined %schoenmaker:: }, 'works in eval("")' ); - -# now tests with strictures - -{ - use strict; - no warnings 'deprecated'; - ok( defined %pig::, q(referencing a non-existent stash doesn't produce stricture errors) ); - ok( !exists $pig::{bodine}, q(referencing a non-existent stash element doesn't produce stricture errors) ); -} - -SKIP: { - eval { require B; 1 } or skip "no B", 29; - - *b = \&B::svref_2object; - my $CVf_ANON = B::CVf_ANON(); - - # perlcc issue - https://code.google.com/p/perl-compiler/issues/detail?id=186 - my $sub; - eval q/$sub = do { - package one; - \&{"one"}; - }; - /; - delete $one::{one}; - - my $gv = b($sub)->GV; - - isa_ok( $gv, "B::GV", "deleted stash entry leaves CV with valid GV"); - is( b($sub)->CvFLAGS & $CVf_ANON, $CVf_ANON, "...and CVf_ANON set"); - is( eval { $gv->NAME }, "__ANON__", "...and an __ANON__ name"); - is( eval { $gv->STASH->NAME }, "one", "...but leaves stash intact"); - - eval q/$sub = do { - package two; - \&{"two"}; - }/; - %two:: = (); - $gv = b($sub)->GV; - - isa_ok( $gv, "B::GV", "cleared stash leaves CV with valid GV"); - is( b($sub)->CvFLAGS & $CVf_ANON, $CVf_ANON, "...and CVf_ANON set"); - is( eval { $gv->NAME }, "__ANON__", "...and an __ANON__ name"); - is( eval { $gv->STASH->NAME }, "two", "...but leaves stash intact"); - - eval q/$sub = do { - package three; - \&{"three"}; - }/; - undef %three::; - $gv = b($sub)->GV; - - isa_ok( $gv, "B::GV", "undefed stash leaves CV with valid GV"); - is( b($sub)->CvFLAGS & $CVf_ANON, $CVf_ANON, "...and CVf_ANON set"); - is( eval { $gv->NAME }, "__ANON__", "...and an __ANON__ name"); - is( eval { $gv->STASH->NAME }, "__ANON__", "...and an __ANON__ stash"); - - eval q/$sub = do { - package four; - sub { 1 }; - }/; - %four:: = (); - - my $gv = B::svref_2object($sub)->GV; - ok($gv->isa(q/B::GV/), "cleared stash leaves anon CV with valid GV"); - - my $st = eval { $gv->STASH->NAME }; - is($st, q/four/, "...but leaves the stash intact"); - - eval q/$sub = do { - package five; - sub { 1 }; - }/; - undef %five::; - - $gv = B::svref_2object($sub)->GV; - ok($gv->isa(q/B::GV/), "undefed stash leaves anon CV with valid GV"); - - $st = eval { $gv->STASH->NAME }; - { local $TODO = 'STASHES not anonymized'; - is($st, q/__ANON__/, "...and an __ANON__ stash"); - } - - my $sub = do { - package six; - \&{"six"} - }; - my $stash_glob = delete $::{"six::"}; - # Now free the GV while the stash still exists (though detached) - delete $$stash_glob{"six"}; - $gv = B::svref_2object($sub)->GV; - ok($gv->isa(q/B::GV/), - 'anonymised CV whose stash is detached still has a GV'); - is $gv->STASH->NAME, '__ANON__', - 'CV anonymised when its stash is detached becomes __ANON__::__ANON__'; - - # CvSTASH should be null on a named sub if the stash has been deleted - { - package FOO; - sub foo {} - my $rfoo = \&foo; - package main; - delete $::{'FOO::'}; - my $cv = B::svref_2object($rfoo); - # (is there a better way of testing for NULL ?) - my $stash = $cv->STASH; - like($stash, qr/B::SPECIAL/, "NULL CvSTASH on named sub"); - } - - # on glob reassignment, orphaned CV should have anon CvGV - - { - my $r; - eval q[ - package FOO2; - sub f{}; - $r = \&f; - *f = sub {}; - ]; - delete $FOO2::{f}; - my $cv = B::svref_2object($r); - my $gv = $cv->GV; - ok($gv->isa(q/B::GV/), "orphaned CV has valid GV"); - is($gv->NAME, '__ANON__', "orphaned CV has anon GV"); - } - - # deleting __ANON__ glob shouldn't break things - { - my ( $anon, $named ); - eval q/package FOO3; - sub named {}; - $anon = sub {}; - $named = eval q[\&named]; - 1;/ or die $@; - package main; - delete $FOO3::{named}; # make named anonymous - - delete $FOO3::{__ANON__}; # whoops! - my ($cv,$gv); - $cv = B::svref_2object($named); - $gv = $cv->GV; - ok($gv->isa(q/B::GV/), "ex-named CV has valid GV"); - is($gv->NAME, '__ANON__', "ex-named CV has anon GV"); - - $cv = B::svref_2object($anon); - $gv = $cv->GV; - ok($gv->isa(q/B::GV/), "anon CV has valid GV"); - is($gv->NAME, '__ANON__', "anon CV has anon GV"); - } - - { - my $r; - { - package bloop; - - BEGIN { - $r = \&main::whack; - } - } - - my $br = B::svref_2object($r); - is ($br->STASH->NAME, 'bloop', - 'stub records the package it was compiled in'); - # Arguably this shouldn't quite be here, but it's easy to add it - # here, and tricky to figure out a different good place for it. - like ($br->FILE, qr/stash/i, - 'stub records the file it was compiled in'); - - # We need to take this reference "late", after the subroutine is - # defined. - $br = B::svref_2object(eval 'sub whack {}; \&whack'); - die $@ if $@; - - is ($br->STASH->NAME, 'main', - 'definition overrides the package it was compiled in'); - like ($br->FILE, qr/eval/, - 'definition overrides the file it was compiled in'); - } -} - -# [perl #58530] -fresh_perl_is( - 'sub foo { 1 }; use overload q/""/ => \&foo;' . - 'delete $main::{foo}; bless []', - "", - {}, - "no segfault with overload/deleted stash entry [#58530]", -); - -# make sure having a sub called __ANON__ doesn't confuse perl. - -{ - my $c; - sub __ANON__ { $c = (caller(0))[3]; } - __ANON__(); - is ($c, 'main::__ANON__', '__ANON__ sub called ok'); -} - - -# Stashes that are effectively renamed -{ - package rile; - - use Config; - - my $obj = bless []; - my $globref = \*tat; - - # effectively rename a stash - *slin:: = *rile::; *rile:: = *zor::; - - ::is *$globref, "*rile::tat", - 'globs stringify the same way when stashes are moved'; - ::is ref $obj, "rile", - 'ref() returns the same thing when an object’s stash is moved'; - ::like "$obj", qr "^rile=ARRAY\(0x[\da-f]+\)\z", - 'objects stringify the same way when their stashes are moved'; - { - local $::TODO = $Config{useithreads} ? "fails under threads" : undef; - ::is eval '__PACKAGE__', 'rile', - '__PACKAGE__ returns the same when the current stash is moved'; - } - - # Now detach it completely from the symtab, making it effect- - # ively anonymous - my $life_raft = \%slin::; - *slin:: = *zor::; - - ::is *$globref, "*rile::tat", - 'globs stringify the same way when stashes are detached'; - ::is ref $obj, "rile", - 'ref() returns the same thing when an object’s stash is detached'; - ::like "$obj", qr "^rile=ARRAY\(0x[\da-f]+\)\z", - 'objects stringify the same way when their stashes are detached'; - { - local $::TODO = $Config{useithreads} ? "fails under threads" : undef; - ::is eval '__PACKAGE__', 'rile', - '__PACKAGE__ returns the same when the current stash is detached'; - } -} - -# Setting the name during undef %stash:: should have no effect. -{ - # perlcc issue 187 - https://code.google.com/p/perl-compiler/issues/detail?id=187 - my $glob = \*Phoo::glob; - sub o::DESTROY { eval '++$Phoo::bar' } - no strict 'refs'; - ${"Phoo::thing1"} = bless [], "o"; - undef %Phoo::; - is "$$glob", "*__ANON__::glob", - "setting stash name during undef has no effect"; -} - -# [perl #88134] incorrect package structure -{ - package Bear::; - sub baz{1} - package main; - ok eval { Bear::::baz() }, - 'packages ending with :: are self-consistent'; -} diff --git a/t/CORE/op/stat.t b/t/CORE/op/stat.t deleted file mode 100644 index 60b3e0fa2..000000000 --- a/t/CORE/op/stat.t +++ /dev/null @@ -1,567 +0,0 @@ -#!./perl - -BEGIN { - unshift @INC, 't/CORE/lib'; - require 't/CORE/test.pl'; # for which_perl() etc -} - -use Config; - -my ($Null, $Curdir); -if(eval {require File::Spec; 1}) { - $Null = File::Spec->devnull; - $Curdir = File::Spec->curdir; -} else { - die $@; -} - - -plan tests => 108; - -my $Perl = which_perl(); - -$Is_Amiga = $^O eq 'amigaos'; -$Is_Cygwin = $^O eq 'cygwin'; -$Is_Darwin = $^O eq 'darwin'; -$Is_Dos = $^O eq 'dos'; -$Is_MPE = $^O eq 'mpeix'; -$Is_MSWin32 = $^O eq 'MSWin32'; -$Is_NetWare = $^O eq 'NetWare'; -$Is_OS2 = $^O eq 'os2'; -$Is_Solaris = $^O eq 'solaris'; -$Is_VMS = $^O eq 'VMS'; -$Is_DGUX = $^O eq 'dgux'; -$Is_MPRAS = $^O =~ /svr4/ && -f '/etc/.relid'; -$Is_Rhapsody= $^O eq 'rhapsody'; - -$Is_Dosish = $Is_Dos || $Is_OS2 || $Is_MSWin32 || $Is_NetWare; - -$Is_UFS = $Is_Darwin && (() = `df -t ufs . 2>/dev/null`) == 2; - -if ($Is_Cygwin) { - require Win32; - Win32->import; -} - -my($DEV, $INO, $MODE, $NLINK, $UID, $GID, $RDEV, $SIZE, - $ATIME, $MTIME, $CTIME, $BLKSIZE, $BLOCKS) = (0..12); - -my $tmpfile = tempfile(); -my $tmpfile_link = tempfile(); - -chmod 0666, $tmpfile; -unlink_all $tmpfile; -open(FOO, ">$tmpfile") || DIE("Can't open temp test file: $!"); -close FOO; - -open(FOO, ">$tmpfile") || DIE("Can't open temp test file: $!"); - -my($nlink, $mtime, $ctime) = (stat(FOO))[$NLINK, $MTIME, $CTIME]; - -# The clock on a network filesystem might be different from the -# system clock. -my $Filesystem_Time_Offset = abs($mtime - time); - -#nlink should if link support configured in Perl. -SKIP: { - skip "No link count - Hard link support not built in.", 1 - unless $Config{d_link}; - - is($nlink, 1, 'nlink on regular file'); -} - -SKIP: { - skip "mtime and ctime not reliable", 2 - if $Is_MSWin32 or $Is_NetWare or $Is_Cygwin or $Is_Dos or $Is_Darwin; - - ok( $mtime, 'mtime' ); - is( $mtime, $ctime, 'mtime == ctime' ); -} - - -# Cygwin seems to have a 3 second granularity on its timestamps. -my $funky_FAT_timestamps = $Is_Cygwin; -sleep 3 if $funky_FAT_timestamps; - -print FOO "Now is the time for all good men to come to.\n"; -close(FOO); - -sleep 2; - - -SKIP: { - unlink $tmpfile_link; - my $lnk_result = eval { link $tmpfile, $tmpfile_link }; - skip "link() unimplemented", 6 if $@ =~ /unimplemented/; - - is( $@, '', 'link() implemented' ); - ok( $lnk_result, 'linked tmp testfile' ); - ok( chmod(0644, $tmpfile), 'chmoded tmp testfile' ); - - my($nlink, $mtime, $ctime) = (stat($tmpfile))[$NLINK, $MTIME, $CTIME]; - - SKIP: { - skip "No link count", 1 if $Config{dont_use_nlink}; - skip "Cygwin9X fakes hard links by copying", 1 - if $Config{myuname} =~ /^cygwin_(?:9\d|me)\b/i; - - is($nlink, 2, 'Link count on hard linked file' ); - } - - SKIP: { - my $cwd = File::Spec->rel2abs($Curdir); - skip "Solaris tmpfs has different mtime/ctime link semantics", 2 - if $Is_Solaris and $cwd =~ m#^/tmp# and - $mtime && $mtime == $ctime; - skip "AFS has different mtime/ctime link semantics", 2 - if $cwd =~ m#$Config{'afsroot'}/#; - skip "AmigaOS has different mtime/ctime link semantics", 2 - if $Is_Amiga; - # Win32 could pass $mtime test but as FAT and NTFS have - # no ctime concept $ctime is ALWAYS == $mtime - # expect netware to be the same ... - skip "No ctime concept on this OS", 2 - if $Is_MSWin32 || - ($Is_Darwin && $Is_UFS); - - if( !ok($mtime, 'hard link mtime') || - !isnt($mtime, $ctime, 'hard link ctime != mtime') ) { - print STDERR <$tmpfile") || DIE("Can't open temp test file: $!"); -ok(-z \*F, '-z on empty filehandle'); -ok(! -s \*F, ' and -s'); -close F; - -ok(-z $tmpfile, '-z on empty file'); -ok(! -s $tmpfile, ' and -s'); - -open(F, ">$tmpfile") || DIE("Can't open temp test file: $!"); -print F "hi\n"; -close F; - -open(F, "<$tmpfile") || DIE("Can't open temp test file: $!"); -ok(!-z *F, '-z on empty filehandle'); -ok( -s *F, ' and -s'); -close F; - -ok(! -z $tmpfile, '-z on non-empty file'); -ok(-s $tmpfile, ' and -s'); - - -# Strip all access rights from the file. -ok( chmod(0000, $tmpfile), 'chmod 0000' ); - -SKIP: { - skip "-r, -w and -x have different meanings on VMS", 3 if $Is_VMS; - - SKIP: { - # Going to try to switch away from root. Might not work. - my $olduid = $>; - eval { $> = 1; }; - skip "Can't test -r or -w meaningfully if you're superuser", 2 - if ($Is_Cygwin ? Win32::IsAdminUser : $> == 0); - - SKIP: { - skip "Can't test -r meaningfully?", 1 if $Is_Dos; - ok(!-r $tmpfile, " -r"); - } - - ok(!-w $tmpfile, " -w"); - - # switch uid back (may not be implemented) - eval { $> = $olduid; }; - } - - ok(! -x $tmpfile, ' -x'); -} - - - -ok(chmod(0700,$tmpfile), 'chmod 0700'); -ok(-r $tmpfile, ' -r'); -ok(-w $tmpfile, ' -w'); - -SKIP: { - skip "-x simply determines if a file ends in an executable suffix", 1 - if $Is_Dosish; - - ok(-x $tmpfile, ' -x'); -} - -ok( -f $tmpfile, ' -f'); -ok(! -d $tmpfile, ' !-d'); - -# Is this portable? -ok( -d '.', '-d cwd' ); -ok(! -f '.', '!-f cwd' ); - - -SKIP: { - unlink($tmpfile_link); - my $symlink_rslt = eval { symlink $tmpfile, $tmpfile_link }; - skip "symlink not implemented", 3 if $@ =~ /unimplemented/; - - is( $@, '', 'symlink() implemented' ); - ok( $symlink_rslt, 'symlink() ok' ); - ok(-l $tmpfile_link, '-l'); -} - -ok(-o $tmpfile, '-o'); - -ok(-e $tmpfile, '-e'); - -unlink($tmpfile_link); -ok(! -e $tmpfile_link, ' -e on unlinked file'); - -SKIP: { - skip "No character, socket or block special files", 6 - if $Is_MSWin32 || $Is_NetWare || $Is_Dos; - skip "/dev isn't available to test against", 6 - unless -d '/dev' && -r '/dev' && -x '/dev'; - skip "Skipping: unexpected ls output in MP-RAS", 6 - if $Is_MPRAS; - - # VMS problem: If GNV or other UNIX like tool is installed, then - # sometimes Perl will find /bin/ls, and will try to run it. - # But since Perl on VMS does not know to run it under Bash, it will - # try to run the DCL verb LS. And if the VMS product Language - # Sensitive Editor is installed, or some other LS verb, that will - # be run instead. So do not do this until we can teach Perl - # when to use BASH on VMS. - skip "ls command not available to Perl in OpenVMS right now.", 6 - if $Is_VMS; - - my $LS = $Config{d_readlink} ? "ls -lL" : "ls -l"; - my $CMD = "$LS /dev 2>/dev/null"; - my $DEV = qx($CMD); - - skip "$CMD failed", 6 if $DEV eq ''; - - my @DEV = do { my $dev; opendir($dev, "/dev") ? readdir($dev) : () }; - - skip "opendir failed: $!", 6 if @DEV == 0; - - # /dev/stdout might be either character special or a named pipe, - # or a symlink, or a socket, depending on which OS and how are - # you running the test, so let's censor that one away. - # Similar remarks hold for stderr. - $DEV =~ s{^[cpls].+?\sstdout$}{}m; - @DEV = grep { $_ ne 'stdout' } @DEV; - $DEV =~ s{^[cpls].+?\sstderr$}{}m; - @DEV = grep { $_ ne 'stderr' } @DEV; - - # /dev/printer is also naughty: in IRIX it shows up as - # Srwx-----, not srwx------. - $DEV =~ s{^.+?\sprinter$}{}m; - @DEV = grep { $_ ne 'printer' } @DEV; - - # If running as root, we will see .files in the ls result, - # and readdir() will see them always. Potential for conflict, - # so let's weed them out. - $DEV =~ s{^.+?\s\..+?$}{}m; - @DEV = grep { ! m{^\..+$} } @DEV; - - # Irix ls -l marks sockets with 'S' while 's' is a 'XENIX semaphore'. - if ($^O eq 'irix') { - $DEV =~ s{^S(.+?)}{s$1}mg; - } - - my $try = sub { - my @c1 = eval qq[\$DEV =~ /^$_[0].*/mg]; - my @c2 = eval qq[grep { $_[1] "/dev/\$_" } \@DEV]; - my $c1 = scalar @c1; - my $c2 = scalar @c2; - is($c1, $c2, "ls and $_[1] agreeing on /dev ($c1 $c2)"); - }; - -SKIP: { - skip("DG/UX ls -L broken", 3) if $Is_DGUX; - - $try->('b', '-b'); - $try->('c', '-c'); - $try->('s', '-S'); - -} - -ok(! -b $Curdir, '!-b cwd'); -ok(! -c $Curdir, '!-c cwd'); -ok(! -S $Curdir, '!-S cwd'); - -} - -SKIP: { - my($cnt, $uid); - $cnt = $uid = 0; - - # Find a set of directories that's very likely to have setuid files - # but not likely to be *all* setuid files. - my @bin = grep {-d && -r && -x} qw(/sbin /usr/sbin /bin /usr/bin); - skip "Can't find a setuid file to test with", 3 unless @bin; - - for my $bin (@bin) { - opendir BIN, $bin or die "Can't opendir $bin: $!"; - while (defined($_ = readdir BIN)) { - $_ = "$bin/$_"; - $cnt++; - $uid++ if -u; - last if $uid && $uid < $cnt; - } - } - closedir BIN; - - skip "No setuid programs", 3 if $uid == 0; - - isnt($cnt, 0, 'found some programs'); - isnt($uid, 0, ' found some setuid programs'); - ok($uid < $cnt, " they're not all setuid"); -} - - -# To assist in automated testing when a controlling terminal (/dev/tty) -# may not be available (at, cron rsh etc), the PERL_SKIP_TTY_TEST env var -# can be set to skip the tests that need a tty. -SKIP: { - skip "These tests require a TTY", 4 if $ENV{PERL_SKIP_TTY_TEST}; - - my $TTY = $Is_Rhapsody ? "/dev/ttyp0" : "/dev/tty"; - - SKIP: { - skip "Test uses unixisms", 2 if $Is_MSWin32 || $Is_NetWare; - skip "No TTY to test -t with", 2 unless -e $TTY; - - open(TTY, $TTY) || - warn "Can't open $TTY--run t/TEST outside of make.\n"; - ok(-t TTY, '-t'); - ok(-c TTY, 'tty is -c'); - close(TTY); - } - ok(! -t TTY, '!-t on closed TTY filehandle'); - - { - local $TODO = 'STDIN not a tty when output is to pipe' if $Is_VMS; - ok(-t, '-t on STDIN'); - } -} - -SKIP: { - skip "No null device to test with", 1 unless -e $Null; - skip "We know Win32 thinks '$Null' is a TTY", 1 if $Is_MSWin32; - - open(NULL, $Null) or DIE("Can't open $Null: $!"); - ok(! -t NULL, 'null device is not a TTY'); - close(NULL); -} - - -# These aren't strictly "stat" calls, but so what? -my $statfile; -foreach my $f ( './op/stat.t', './CORE/op/stat.t', './t/CORE/op/stat.t' ) { - $statfile = $f; - last if -e $statfile; -} - -ok -e $statfile, "statfile exists [prerequire]" or die "Cannot find file $statfile"; -ok( -T $statfile, '-T'); -ok(! -B $statfile, '!-B'); - -note "perl $Perl"; - -SKIP: { - skip("DG/UX", 1) if $Is_DGUX; - ok(-B $Perl, '-B'); -} - -ok(! -T $Perl, '!-T'); - -open(FOO,$statfile); -SKIP: { - eval { -T FOO; }; - skip "-T/B on filehandle not implemented", 15 if $@ =~ /not implemented/; - - is( $@, '', '-T on filehandle causes no errors' ); - - ok(-T FOO, ' -T'); - ok(! -B FOO, ' !-B'); - - $_ = ; - like($_, qr/perl/, 'after readline'); - ok(-T FOO, ' still -T'); - ok(! -B FOO, ' still -B'); - close(FOO); - - open(FOO,$statfile); - $_ = ; - like($_, qr/perl/, 'reopened and after readline'); - ok(-T FOO, ' still -T'); - ok(! -B FOO, ' still !-B'); - - ok(seek(FOO,0,0), 'after seek'); - ok(-T FOO, ' still -T'); - ok(! -B FOO, ' still !-B'); - - # It's documented this way in perlfunc *shrug* - () = ; - ok(eof FOO, 'at EOF'); - ok(-T FOO, ' still -T'); - ok(-B FOO, ' now -B'); -} -close(FOO); - - -SKIP: { - skip "No null device to test with", 2 unless -e $Null; - - ok(-T $Null, 'null device is -T'); - ok(-B $Null, ' and -B'); -} - - -# and now, a few parsing tests: -$_ = $tmpfile; -ok(-f, 'bare -f uses $_'); -ok(-f(), ' -f() "'); - -unlink $tmpfile or print "# unlink failed: $!\n"; - -# bug id 20011101.069 -my @r = \stat($Curdir); -is(scalar @r, 13, 'stat returns full 13 elements'); - -stat $0; -eval { lstat _ }; -like( $@, qr/^The stat preceding lstat\(\) wasn't an lstat/, - 'lstat _ croaks after stat' ); -eval { -l _ }; -like( $@, qr/^The stat preceding -l _ wasn't an lstat/, - '-l _ croaks after stat' ); - -lstat $0; -eval { lstat _ }; -is( "$@", "", "lstat _ ok after lstat" ); -eval { -l _ }; -is( "$@", "", "-l _ ok after lstat" ); - -SKIP: { - skip "No lstat", 2 unless $Config{d_lstat}; - - # bug id 20020124.004 - # If we have d_lstat, we should have symlink() - my $linkname = 'dolzero'; - symlink $0, $linkname or die "# Can't symlink $0: $!"; - lstat $linkname; - -T _; - eval { lstat _ }; - like( $@, qr/^The stat preceding lstat\(\) wasn't an lstat/, - 'lstat croaks after -T _' ); - eval { -l _ }; - like( $@, qr/^The stat preceding -l _ wasn't an lstat/, - '-l _ croaks after -T _' ); - unlink $linkname or print "# unlink $linkname failed: $!\n"; -} - -SKIP: { - skip "Too much clock skew between system and filesystem", 5 - if ($Filesystem_Time_Offset > 5); - print "# Zzz...\n"; - sleep($Filesystem_Time_Offset+1); - my $f = 'tstamp.tmp'; - unlink $f; - ok (open(S, "> $f"), 'can create tmp file'); - close S or die; - my @a = stat $f; - print "# time=$^T, stat=(@a)\n"; - my @b = (-M _, -A _, -C _); - print "# -MAC=(@b)\n"; - ok( (-M _) < 0, 'negative -M works'); - ok( (-A _) < 0, 'negative -A works'); - ok( (-C _) < 0, 'negative -C works'); - ok(unlink($f), 'unlink tmp file'); -} - -{ - ok(open(F, ">", $tmpfile), 'can create temp file'); - close F; - chmod 0077, $tmpfile; - my @a = stat($tmpfile); - my $s1 = -s _; - -T _; - my $s2 = -s _; - is($s1, $s2, q(-T _ doesn't break the statbuffer)); - unlink $tmpfile; -} - -SKIP: { - skip "No dirfd()", 9 unless $Config{d_dirfd} || $Config{d_dir_dd_fd}; - ok(opendir(DIR, "."), 'Can open "." dir') || diag "Can't open '.': $!"; - ok(stat(DIR), "stat() on dirhandle works"); - ok(-d -r _ , "chained -x's on dirhandle"); - ok(-d DIR, "-d on a dirhandle works"); - - # And now for the ambiguous bareword case - { - no warnings 'deprecated'; - - ok(open(DIR, q{TESTS}), "Can open 'TESTS' dir") - || diag "Can't open 'TESTS': $!"; - } - my $size = (stat(DIR))[7]; - ok(defined $size, "stat() on bareword works"); - is($size, -s q{TESTS}, "size returned by stat of bareword is for the file"); - ok(-f _, "ambiguous bareword uses file handle, not dir handle"); - ok(-f DIR); - closedir DIR or die $!; - close DIR or die $!; -} - -{ - # RT #8244: *FILE{IO} does not behave like *FILE for stat() and -X() operators - ok(open(F, ">", $tmpfile), 'can create temp file'); - my @thwap = stat *F{IO}; - ok(@thwap, "stat(*F{IO}) works"); - ok( -f *F{IO} , "single file tests work with *F{IO}"); - close F; - unlink $tmpfile; - - #PVIO's hold dirhandle information, so let's test them too. - - SKIP: { - skip "No dirfd()", 9 unless $Config{d_dirfd} || $Config{d_dir_dd_fd}; - ok(opendir(DIR, "."), 'Can open "." dir') || diag "Can't open '.': $!"; - ok(stat(*DIR{IO}), "stat() on *DIR{IO} works"); - ok(-d _ , "The special file handle _ is set correctly"); - ok(-d -r *DIR{IO} , "chained -x's on *DIR{IO}"); - - # And now for the ambiguous bareword case - { - no warnings 'deprecated'; - ok(open(DIR, "TESTS"), 'Can open "TEST" dir') - || diag "Can't open 'TEST': $!"; - } - my $size = (stat(*DIR{IO}))[7]; - ok(defined $size, "stat() on *THINGY{IO} works"); - is($size, -s "TESTS", - "size returned by stat of *THINGY{IO} is for the file"); - ok(-f _, "ambiguous *THINGY{IO} uses file handle, not dir handle"); - ok(-f *DIR{IO}); - closedir DIR or die $!; - close DIR or die $!; - } -} - -END { - chmod 0666, $tmpfile; - unlink_all $tmpfile; -} diff --git a/t/CORE/op/state.t b/t/CORE/op/state.t deleted file mode 100644 index 7412c3e2e..000000000 --- a/t/CORE/op/state.t +++ /dev/null @@ -1,417 +0,0 @@ -#!./perl -w -# tests state variables - -BEGIN { - unshift @INC, 't/CORE/lib'; - require 't/CORE/test.pl'; -} - -use strict; -use feature ":5.10"; - -plan tests => 130; - -ok( ! defined state $uninit, q(state vars are undef by default) ); - -# basic functionality - -sub stateful { - state $x; - state $y = 1; - my $z = 2; - state ($t) //= 3; - return ($x++, $y++, $z++, $t++); -} - -my ($x, $y, $z, $t) = stateful(); -is( $x, 0, 'uninitialized state var' ); -is( $y, 1, 'initialized state var' ); -is( $z, 2, 'lexical' ); -is( $t, 3, 'initialized state var, list syntax' ); - -($x, $y, $z, $t) = stateful(); -is( $x, 1, 'incremented state var' ); -is( $y, 2, 'incremented state var' ); -is( $z, 2, 'reinitialized lexical' ); -is( $t, 4, 'incremented state var, list syntax' ); - -($x, $y, $z, $t) = stateful(); -is( $x, 2, 'incremented state var' ); -is( $y, 3, 'incremented state var' ); -is( $z, 2, 'reinitialized lexical' ); -is( $t, 5, 'incremented state var, list syntax' ); - -# in a nested block - -sub nesting { - state $foo = 10; - my $t; - { state $bar = 12; $t = ++$bar } - ++$foo; - return ($foo, $t); -} - -($x, $y) = nesting(); -is( $x, 11, 'outer state var' ); -is( $y, 13, 'inner state var' ); - -($x, $y) = nesting(); -is( $x, 12, 'outer state var' ); -is( $y, 14, 'inner state var' ); - -# in a closure - -sub generator { - my $outer; - # we use $outer to generate a closure - sub { ++$outer; ++state $x } -} - -my $f1 = generator(); -is( $f1->(), 1, 'generator 1' ); -is( $f1->(), 2, 'generator 1' ); -my $f2 = generator(); -is( $f2->(), 1, 'generator 2' ); -is( $f1->(), 3, 'generator 1 again' ); -is( $f2->(), 2, 'generator 2 once more' ); - -# with ties -{ - package countfetches; - our $fetchcount = 0; - sub TIESCALAR {bless {}}; - sub FETCH { ++$fetchcount; 18 }; - tie my $y, "countfetches"; - sub foo { state $x = $y; $x++ } - ::is( foo(), 18, "initialisation with tied variable" ); - ::is( foo(), 19, "increments correctly" ); - ::is( foo(), 20, "increments correctly, twice" ); - ::is( $fetchcount, 1, "fetch only called once" ); -} - -# state variables are shared among closures - -sub gen_cashier { - my $amount = shift; - state $cash_in_store = 0; - return { - add => sub { $cash_in_store += $amount }, - del => sub { $cash_in_store -= $amount }, - bal => sub { $cash_in_store }, - }; -} - -gen_cashier(59)->{add}->(); -gen_cashier(17)->{del}->(); -is( gen_cashier()->{bal}->(), 42, '$42 in my drawer' ); - -# stateless assignment to a state variable - -sub stateless { - state $reinitme = 42; - ++$reinitme; -} -is( stateless(), 43, 'stateless function, first time' ); -is( stateless(), 44, 'stateless function, second time' ); - -# array state vars - -sub stateful_array { - state @x; - push @x, 'x'; - return $#x; -} - -my $xsize = stateful_array(); -is( $xsize, 0, 'uninitialized state array' ); - -$xsize = stateful_array(); -is( $xsize, 1, 'uninitialized state array after one iteration' ); - -# hash state vars - -sub stateful_hash { - state %hx; - return $hx{foo}++; -} - -my $xhval = stateful_hash(); -is( $xhval, 0, 'uninitialized state hash' ); - -$xhval = stateful_hash(); -is( $xhval, 1, 'uninitialized state hash after one iteration' ); - -# Recursion - -sub noseworth { - my $level = shift; - state $recursed_state = 123; - is($recursed_state, 123, "state kept through recursion ($level)"); - noseworth($level - 1) if $level; -} -noseworth(2); - -# Assignment return value - -sub pugnax { my $x = state $y = 42; $y++; $x; } - -is( pugnax(), 42, 'scalar state assignment return value' ); -is( pugnax(), 43, 'scalar state assignment return value' ); - - -# -# Test various blocks. -# -foreach my $x (1 .. 3) { - state $y = $x; - is ($y, 1, "foreach $x"); -} - -for (my $x = 1; $x < 4; $x ++) { - state $y = $x; - is ($y, 1, "for $x"); -} - -while ($x < 4) { - state $y = $x; - is ($y, 1, "while $x"); - $x ++; -} - -$x = 1; -until ($x >= 4) { - state $y = $x; - is ($y, 1, "until $x"); - $x ++; -} - -$x = 0; -$y = 0; -{ - state $z = $x; - $z ++; - $y ++; - is ($z, $y, "bare block $y"); - redo if $y < 3 -} - - -# -# Check state $_ -# -my @stones = qw [fred wilma barny betty]; -my $first = $stones [0]; -my $First = ucfirst $first; -$_ = "bambam"; -foreach my $flint (@stones) { - state $_ = $flint; - is $_, $first, 'state $_'; - ok /$first/, '/.../ binds to $_'; - is ucfirst, $First, '$_ default argument'; -} -is $_, "bambam", '$_ is still there'; - -# -# Goto. -# -my @simpsons = qw [Homer Marge Bart Lisa Maggie]; -again: - my $next = shift @simpsons; - state $simpson = $next; - is $simpson, 'Homer', 'goto 1'; - goto again if @simpsons; - -my $vi; -{ - goto Elvis unless $vi; - state $calvin = ++ $vi; - Elvis: state $vile = ++ $vi; - redo unless defined $calvin; - is $calvin, 2, "goto 2"; - is $vile, 1, "goto 3"; - is $vi, 2, "goto 4"; -} -my @presidents = qw [Taylor Garfield Ford Arthur Monroe]; -sub president { - my $next = shift @presidents; - state $president = $next; - goto &president if @presidents; - $president; -} -my $president_answer = $presidents [0]; -is president, $president_answer, '&goto'; - -my @flowers = qw [Bluebonnet Goldenrod Hawthorn Peony]; -foreach my $f (@flowers) { - goto state $flower = $f; - ok 0, 'computed goto 0'; next; - Bluebonnet: ok 1, 'computed goto 1'; next; - Goldenrod: ok 0, 'computed goto 2'; next; - Hawthorn: ok 0, 'computed goto 3'; next; - Peony: ok 0, 'computed goto 4'; next; - ok 0, 'computed goto 5'; next; -} - -# -# map/grep -# -my @apollo = qw [Eagle Antares Odyssey Aquarius]; -my @result1 = map {state $x = $_;} @apollo; -my @result2 = grep {state $x = /Eagle/} @apollo; -{ - local $" = ""; - is "@result1", $apollo [0] x @apollo, "map"; - is "@result2", "@apollo", "grep"; -} - -# -# Reference to state variable. -# -sub reference {\state $x} -my $ref1 = reference; -my $ref2 = reference; -is $ref1, $ref2, "Reference to state variable"; - -# -# Pre/post increment. -# -foreach my $x (1 .. 3) { - ++ state $y; - state $z ++; - is $y, $x, "state pre increment"; - is $z, $x, "state post increment"; -} - - -# -# Substr -# -my $tintin = "Tin-Tin"; -my @thunderbirds = qw [Scott Virgel Alan Gordon John]; -my @thunderbirds2 = qw [xcott xxott xxxtt xxxxt xxxxx]; -foreach my $x (0 .. 4) { - state $c = \substr $tintin, $x, 1; - my $d = \substr ((state $tb = $thunderbirds [$x]), $x, 1); - $$c = "x"; - $$d = "x"; - is $tintin, "xin-Tin", "substr"; - is $tb, $thunderbirds2 [$x], "substr"; -} - - -# -# Use with given. -# -my @spam = qw [spam ham bacon beans]; -foreach my $spam (@spam) { - given (state $spam = $spam) { - when ($spam [0]) {ok 1, "given"} - default {ok 0, "given"} - } -} - -# -# Redefine. -# -{ - state $x = "one"; - no warnings; - state $x = "two"; - is $x, "two", "masked" -} - -# normally closureless anon subs share a CV and pad. If the anon sub has a -# state var, this would mean that it is shared. Check that this doesn't -# happen - -{ - my @f; - push @f, sub { state $x; ++$x } for 1..2; - $f[0]->() for 1..10; - is $f[0]->(), 11; - is $f[1]->(), 1; -} - -# each copy of an anon sub should get its own 'once block' - -{ - my $x; # used to force a closure - my @f; - push @f, sub { $x=0; state $s = $_[0]; $s } for 1..2; - is $f[0]->(1), 1; - is $f[0]->(2), 1; - is $f[1]->(3), 3; - is $f[1]->(4), 3; -} - - - - -foreach my $forbidden () { - chomp $forbidden; - no strict 'vars'; - eval $forbidden; - like $@, qr/Initialization of state variables in list context currently forbidden/, "Currently forbidden: $forbidden"; -} - -# [perl #49522] state variable not available - -{ - my @warnings; - local $SIG{__WARN__} = sub { push @warnings, $_[0] }; - - eval q{ - use warnings; - - sub f_49522 { - state $s = 88; - sub g_49522 { $s } - sub { $s }; - } - - sub h_49522 { - state $t = 99; - sub i_49522 { - sub { $t }; - } - } - }; - is $@, '', "eval f_49522"; - # shouldn't be any 'not available' or 'not stay shared' warnings - ok !@warnings, "suppress warnings part 1 [@warnings]"; - - @warnings = (); - my $f = f_49522(); - is $f->(), 88, "state var closure 1"; - is g_49522(), 88, "state var closure 2"; - ok !@warnings, "suppress warnings part 2 [@warnings]"; - - - @warnings = (); - $f = i_49522(); - h_49522(); # initialise $t - is $f->(), 99, "state var closure 3"; - ok !@warnings, "suppress warnings part 3 [@warnings]"; - - -} - - -__DATA__ -state ($a) = 1; -(state $a) = 1; -state @a = 1; -state (@a) = 1; -(state @a) = 1; -state %a = (); -state (%a) = (); -(state %a) = (); -state ($a, $b) = (); -state ($a, @b) = (); -(state $a, state $b) = (); -(state $a, $b) = (); -(state $a, my $b) = (); -(state $a, state @b) = (); -(state $a, local @b) = (); -(state $a, undef, state $b) = (); -state ($a, undef, $b) = (); diff --git a/t/CORE/op/study.t b/t/CORE/op/study.t deleted file mode 100644 index cc350128d..000000000 --- a/t/CORE/op/study.t +++ /dev/null @@ -1,86 +0,0 @@ -#!./perl -w - -BEGIN { - unshift @INC, 't/CORE/lib'; - require 't/CORE/test.pl'; -} - -watchdog(10); -plan(tests => 29); -use strict; -use vars '$x'; - -use Config; -my $have_alarm = $Config{d_alarm}; - -$x = "abc\ndef\n"; -study($x); - -ok($x =~ /^abc/); -ok($x !~ /^def/); - -# used to be a test for $* -ok($x =~ /^def/m); - -$_ = '123'; -study; -ok(/^([0-9][0-9]*)/); - -ok(!($x =~ /^xxx/)); -ok(!($x !~ /^abc/)); - -ok($x =~ /def/); -ok(!($x !~ /def/)); - -study($x); -ok($x !~ /.def/); -ok(!($x =~ /.def/)); - -ok($x =~ /\ndef/); -ok(!($x !~ /\ndef/)); - -$_ = 'aaabbbccc'; -study; -ok(/(a*b*)(c*)/); -is($1, 'aaabbb'); -is($2,'ccc'); -ok(/(a+b+c+)/); -is($1, 'aaabbbccc'); - -ok(!/a+b?c+/); - -$_ = 'aaabccc'; -study; -ok(/a+b?c+/); -ok(/a*b+c*/); - -$_ = 'aaaccc'; -study; -ok(/a*b?c*/); -ok(!/a*b+c*/); - -$_ = 'abcdef'; -study; -ok(/bcd|xyz/); -ok(/xyz|bcd/); - -ok(m|bc/*d|); - -ok(/^$_$/); - -# used to be a test for $* -ok("ab\ncd\n" =~ /^cd/m); - -TODO: { - # Even with the alarm() OS/390 and BS2000 can't manage these tests - # (Perl just goes into a busy loop, luckily an interruptable one) - todo_skip('busy loop - compiler bug?', 2) - if $^O eq 'os390' or $^O eq 'posix-bc'; - - # [ID ] tests 25..26 may loop - - $_ = 'FGF'; - study; - ok(!/G.F$/, 'bug 20010618.006'); - ok(!/[F]F$/, 'bug 20010618.006'); -} diff --git a/t/CORE/op/studytied.t b/t/CORE/op/studytied.t deleted file mode 100644 index 937357764..000000000 --- a/t/CORE/op/studytied.t +++ /dev/null @@ -1,50 +0,0 @@ -#!./perl - -BEGIN { - unshift @INC, 't/CORE/lib'; - require 't/CORE/test.pl'; -} - -use strict; -use warnings; - -plan tests => 14; - -{ - package J; - my $c = 0; - sub reset { $c = 0 } - sub TIESCALAR { bless [] } - sub FETCH { $c++ ? "next" : "first" } -} - -# This test makes sure that we can't pull a fast one on study(). If we -# study() a tied variable, perl should know that the studying isn't -# valid on subsequent references, and should account for it. - -for my $do_study (0,1) { - J::reset(); - my $x; - tie $x, "J"; - - if ($do_study) { - study $x; - pass( "Studying..." ); - } else { - my $first_fetch = $x; - pass( "Not studying..." ); - } - - # When it was studied (or first_fetched), $x was "first", but is now "next", so - # should not match /f/. - ok( $x !~ /f/, qq{"next" doesn't match /f/} ); - is( index( $x, 'f' ), -1, qq{"next" doesn't contain "f"} ); - - # Subsequent references to $x are "next", so should match /n/ - ok( $x =~ /n/, qq{"next" matches /n/} ); - is( index( $x, 'n' ), 0, qq{"next" contains "n" at pos 0} ); - - # The letter "t" is in both, but in different positions - ok( $x =~ /t/, qq{"next" matches /t/} ); - is( index( $x, 't' ), 3, qq{"next" contains "t" at pos 3} ); -} diff --git a/t/CORE/op/sub.t b/t/CORE/op/sub.t deleted file mode 100644 index 7a6b1cd4d..000000000 --- a/t/CORE/op/sub.t +++ /dev/null @@ -1,42 +0,0 @@ -#!./perl -w - -BEGIN { - unshift @INC, 't/CORE/lib'; - require 't/CORE/test.pl'; -} - -plan( tests => 8 ); - -sub empty_sub {} - -is(empty_sub,undef,"Is empty"); -is(empty_sub(1,2,3),undef,"Is still empty"); -@test = empty_sub(); -is(scalar(@test), 0, 'Didnt return anything'); -@test = empty_sub(1,2,3); -is(scalar(@test), 0, 'Didnt return anything'); - -# RT #63790: calling PL_sv_yes as a sub is special-cased to silently -# return (so Foo->import() silently fails if import() doesn't exist), -# But make sure it correctly pops the stack and mark stack before returning. - -# perlcc issue 183 - https://code.google.com/p/perl-compiler/issues/detail?id=183 -{ - my @a; - push @a, 4, 5, main->import(6,7); - ok(eq_array(\@a, [4,5]), "import with args"); - - @a = (); - push @a, 14, 15, main->import; - ok(eq_array(\@a, [14,15]), "import without args"); - - my $x = 1; - - @a = (); - push @a, 24, 25, &{$x == $x}(26,27); - ok(eq_array(\@a, [24,25]), "yes with args"); - - @a = (); - push @a, 34, 35, &{$x == $x}; - ok(eq_array(\@a, [34,35]), "yes without args"); -} diff --git a/t/CORE/op/sub_lval.t b/t/CORE/op/sub_lval.t deleted file mode 100644 index b3bfed9f9..000000000 --- a/t/CORE/op/sub_lval.t +++ /dev/null @@ -1,601 +0,0 @@ -BEGIN { - unshift @INC, 't/CORE/lib'; - require 't/CORE/test.pl'; -} -plan( tests=>75 ); - -sub a : lvalue { my $a = 34; ${\(bless \$a)} } # Return a temporary -sub b : lvalue { ${\shift} } - -my $out = a(b()); # Check that temporaries are allowed. -is(ref $out, 'main'); # Not reached if error. - -my @out = grep /main/, a(b()); # Check that temporaries are allowed. -cmp_ok(scalar @out, '==', 1); # Not reached if error. - -my $in; - -# Check that we can return localized values from subroutines: - -sub in : lvalue { $in = shift; } -sub neg : lvalue { #(num_str) return num_str - local $_ = shift; - s/^\+/-/; - $_; -} -in(neg("+2")); - - -is($in, '-2'); - -sub get_lex : lvalue { $in } -sub get_st : lvalue { $blah } -sub id : lvalue { ${\shift} } -sub id1 : lvalue { $_[0] } -sub inc : lvalue { ${\++$_[0]} } - -$in = 5; -$blah = 3; - -get_st = 7; - -cmp_ok($blah, '==', 7); - -get_lex = 7; - -cmp_ok($in, '==', 7); - -++get_st; - -cmp_ok($blah, '==', 8); - -++get_lex; - -cmp_ok($in, '==', 8); - -id(get_st) = 10; - -cmp_ok($blah, '==', 10); - -id(get_lex) = 10; - -cmp_ok($in, '==', 10); - -++id(get_st); - -cmp_ok($blah, '==', 11); - -++id(get_lex); - -cmp_ok($in, '==', 11); - -id1(get_st) = 20; - -cmp_ok($blah, '==', 20); - -id1(get_lex) = 20; - -cmp_ok($in, '==', 20); - -++id1(get_st); - -cmp_ok($blah, '==', 21); - -++id1(get_lex); - -cmp_ok($in, '==', 21); - -inc(get_st); - -cmp_ok($blah, '==', 22); - -inc(get_lex); - -cmp_ok($in, '==', 22); - -inc(id(get_st)); - -cmp_ok($blah, '==', 23); - -inc(id(get_lex)); - -cmp_ok($in, '==', 23); - -++inc(id1(id(get_st))); - -cmp_ok($blah, '==', 25); - -++inc(id1(id(get_lex))); - -cmp_ok($in, '==', 25); - -@a = (1) x 3; -@b = (undef) x 2; -$#c = 3; # These slots are not fillable. - -# Explanation: empty slots contain &sv_undef. - -=for disabled constructs - -sub a3 :lvalue {@a} -sub b2 : lvalue {@b} -sub c4: lvalue {@c} - -$_ = ''; - -eval <<'EOE' or $_ = $@; - ($x, a3, $y, b2, $z, c4, $t) = (34 .. 78); - 1; -EOE - -#@out = ($x, a3, $y, b2, $z, c4, $t); -#@in = (34 .. 41, (undef) x 4, 46); -#print "# `@out' ne `@in'\nnot " unless "@out" eq "@in"; - -like($_, qr/Can\'t return an uninitialized value from lvalue subroutine/); -print "ok 22\n"; - -=cut - - -my $var; - -sub a::var : lvalue { $var } - -"a"->var = 45; - -cmp_ok($var, '==', 45); - -my $oo; -$o = bless \$oo, "a"; - -$o->var = 47; - -cmp_ok($var, '==', 47); - -sub o : lvalue { $o } - -o->var = 49; - -cmp_ok($var, '==', 49); - -sub nolv () { $x0, $x1 } # Not lvalue - -$_ = ''; - -eval <<'EOE' or $_ = $@; - nolv = (2,3); - 1; -EOE - -like($_, qr/Can\'t modify non-lvalue subroutine call in scalar assignment/); - -$_ = ''; - -eval <<'EOE' or $_ = $@; - nolv = (2,3) if $_; - 1; -EOE - -like($_, qr/Can\'t modify non-lvalue subroutine call in scalar assignment/); - -$_ = ''; - -eval <<'EOE' or $_ = $@; - &nolv = (2,3) if $_; - 1; -EOE - -like($_, qr/Can\'t modify non-lvalue subroutine call in scalar assignment/); - -$x0 = $x1 = $_ = undef; -$nolv = \&nolv; - -eval <<'EOE' or $_ = $@; - $nolv->() = (2,3) if $_; - 1; -EOE - -ok(!defined $_) or diag("'$_', '$x0', '$x1'"); - -$x0 = $x1 = $_ = undef; -$nolv = \&nolv; - -eval <<'EOE' or $_ = $@; - $nolv->() = (2,3); - 1; -EOE - -like($_, qr/Can\'t modify non-lvalue subroutine call/) - or diag("'$_', '$x0', '$x1'"); - -sub lv0 : lvalue { } # Converted to lv10 in scalar context - -$_ = undef; -eval <<'EOE' or $_ = $@; - lv0 = (2,3); - 1; -EOE - -like($_, qr/Can't return undef from lvalue subroutine/); - -sub lv10 : lvalue {} - -$_ = undef; -eval <<'EOE' or $_ = $@; - (lv0) = (2,3); - 1; -EOE - -ok(!defined $_) or diag $_; - -sub lv1u :lvalue { undef } - -$_ = undef; -eval <<'EOE' or $_ = $@; - lv1u = (2,3); - 1; -EOE - -like($_, qr/Can't return undef from lvalue subroutine/); - -$_ = undef; -eval <<'EOE' or $_ = $@; - (lv1u) = (2,3); - 1; -EOE - -# Fixed by change @10777 -#print "# '$_'.\nnot " -# unless /Can\'t return an uninitialized value from lvalue subroutine/; -# print "ok 34 # Skip: removed test\n"; - -$x = '1234567'; - -$_ = undef; -eval <<'EOE' or $_ = $@; - sub lv1t : lvalue { index $x, 2 } - lv1t = (2,3); - 1; -EOE - -like($_, qr/Can\'t modify index in lvalue subroutine return/); - -$_ = undef; -eval <<'EOE' or $_ = $@; - sub lv2t : lvalue { shift } - (lv2t) = (2,3); - 1; -EOE - -like($_, qr/Can\'t modify shift in lvalue subroutine return/); - -$xxx = 'xxx'; -sub xxx () { $xxx } # Not lvalue - -$_ = undef; -eval <<'EOE' or $_ = $@; - sub lv1tmp : lvalue { xxx } # is it a TEMP? - lv1tmp = (2,3); - 1; -EOE - -like($_, qr/Can\'t modify non-lvalue subroutine call in lvalue subroutine return/); - -$_ = undef; -eval <<'EOE' or $_ = $@; - (lv1tmp) = (2,3); - 1; -EOE - -like($_, qr/Can\'t return a temporary from lvalue subroutine/); - -sub yyy () { 'yyy' } # Const, not lvalue - -$_ = undef; -eval <<'EOE' or $_ = $@; - sub lv1tmpr : lvalue { yyy } # is it read-only? - lv1tmpr = (2,3); - 1; -EOE - -like($_, qr/Can\'t modify (.+) in lvalue subroutine return/); - -$_ = undef; -eval <<'EOE' or $_ = $@; - (lv1tmpr) = (2,3); - 1; -EOE - -like($_, qr/Can\'t return a readonly value from lvalue subroutine/); - -sub lva : lvalue {@a} - -$_ = undef; -@a = (); -$a[1] = 12; -eval <<'EOE' or $_ = $@; - (lva) = (2,3); - 1; -EOE - -is("'@a' $_", "'2 3' "); - -$_ = undef; -@a = (); -$a[0] = undef; -$a[1] = 12; -eval <<'EOE' or $_ = $@; - (lva) = (2,3); - 1; -EOE - -is("'@a' $_", "'2 3' "); - -$_ = undef; -@a = (); -$a[0] = undef; -$a[1] = 12; -eval <<'EOE' or $_ = $@; - (lva) = (2,3); - 1; -EOE - -is("'@a' $_", "'2 3' "); - -sub lv1n : lvalue { $newvar } - -$_ = undef; -eval <<'EOE' or $_ = $@; - lv1n = (3,4); - 1; -EOE - -is("'$newvar' $_", "'4' "); - -sub lv1nn : lvalue { $nnewvar } - -$_ = undef; -eval <<'EOE' or $_ = $@; - (lv1nn) = (3,4); - 1; -EOE - -is("'$nnewvar' $_", "'3' "); - -$a = \&lv1nn; -$a->() = 8; -is($nnewvar, '8'); - -eval 'sub AUTOLOAD : lvalue { $newvar }'; -foobar() = 12; -is($newvar, "12"); - -{ -my %hash; my @array; -sub alv : lvalue { $array[1] } -sub alv2 : lvalue { $array[$_[0]] } -sub hlv : lvalue { $hash{"foo"} } -sub hlv2 : lvalue { $hash{$_[0]} } -$array[1] = "not ok 51\n"; -alv() = "ok 50\n"; -is(alv(), "ok 50\n"); - -alv2(20) = "ok 51\n"; -is($array[20], "ok 51\n"); - -$hash{"foo"} = "not ok 52\n"; -hlv() = "ok 52\n"; -is($hash{foo}, "ok 52\n"); - -$hash{bar} = "not ok 53\n"; -hlv("bar") = "ok 53\n"; -is(hlv("bar"), "ok 53\n"); - -sub array : lvalue { @array } -sub array2 : lvalue { @array2 } # This is a global. -sub hash : lvalue { %hash } -sub hash2 : lvalue { %hash2 } # So's this. -@array2 = qw(foo bar); -%hash2 = qw(foo bar); - -(array()) = qw(ok 54); -is("@array", "ok 54"); - -(array2()) = qw(ok 55); -is("@array2", "ok 55"); - -(hash()) = qw(ok 56); -cmp_ok($hash{ok}, '==', 56); - -(hash2()) = qw(ok 57); -cmp_ok($hash2{ok}, '==', 57); - -@array = qw(a b c d); -sub aslice1 : lvalue { @array[0,2] }; -(aslice1()) = ("ok", "already"); -is("@array", "ok b already d"); - -@array2 = qw(a B c d); -sub aslice2 : lvalue { @array2[0,2] }; -(aslice2()) = ("ok", "already"); -is("@array2", "ok B already d"); - -%hash = qw(a Alpha b Beta c Gamma); -sub hslice : lvalue { @hash{"c", "b"} } -(hslice()) = ("CISC", "BogoMIPS"); -is(join("/",@hash{"c","a","b"}), "CISC/Alpha/BogoMIPS"); -} - -$str = "Hello, world!"; -sub sstr : lvalue { substr($str, 1, 4) } -sstr() = "i"; -is($str, "Hi, world!"); - -$str = "Made w/ JavaScript"; -sub veclv : lvalue { vec($str, 2, 32) } -if (ord('A') != 193) { - veclv() = 0x5065726C; -} -else { # EBCDIC? - veclv() = 0xD7859993; -} -is($str, "Made w/ PerlScript"); - -sub position : lvalue { pos } -@p = (); -$_ = "fee fi fo fum"; -while (/f/g) { - push @p, position; - position() += 6; -} -is("@p", "1 8"); - -# Bug 20001223.002: split thought that the list had only one element -@ary = qw(4 5 6); -sub lval1 : lvalue { $ary[0]; } -sub lval2 : lvalue { $ary[1]; } -(lval1(), lval2()) = split ' ', "1 2 3 4"; - -is(join(':', @ary), "1:2:6"); - -# check that an element of a tied hash/array can be assigned to via lvalueness - -package Tie_Hash; - -our ($key, $val); -sub TIEHASH { bless \my $v => __PACKAGE__ } -sub STORE { ($key, $val) = @_[1,2] } - -package main; -sub lval_tie_hash : lvalue { - tie my %t => 'Tie_Hash'; - $t{key}; -} - -eval { lval_tie_hash() = "value"; }; - -is($@, "", "element of tied hash"); - -is("$Tie_Hash::key-$Tie_Hash::val", "key-value"); - - -package Tie_Array; - -our @val; -sub TIEARRAY { bless \my $v => __PACKAGE__ } -sub STORE { $val[ $_[1] ] = $_[2] } - -package main; -sub lval_tie_array : lvalue { - tie my @t => 'Tie_Array'; - $t[0]; -} - -eval { lval_tie_array() = "value"; }; - - -is($@, "", "element of tied array"); - -is ($Tie_Array::val[0], "value"); - -TODO: { - local $TODO = 'test explicit return of lval expr'; - - # subs are corrupted copies from tests 1-~4 - sub bad_get_lex : lvalue { return $in }; - sub bad_get_st : lvalue { return $blah } - - sub bad_id : lvalue { return ${\shift} } - sub bad_id1 : lvalue { return $_[0] } - sub bad_inc : lvalue { return ${\++$_[0]} } - - $in = 5; - $blah = 3; - - bad_get_st = 7; - - is( $blah, 7 ); - - bad_get_lex = 7; - - is($in, 7, "yada"); - - ++bad_get_st; - - is($blah, 8, "yada"); -} - -{ # bug #23790 - my @arr = qw /one two three/; - my $line = "zero"; - sub lval_array () : lvalue {@arr} - - for (lval_array) { - $line .= $_; - } - - is($line, "zeroonetwothree"); - - sub trythislval { scalar(@_)."x".join "", @_ } - is(trythislval(lval_array()), "3xonetwothree"); - - sub changeme { $_[2] = "free" } - changeme(lval_array); - is("@arr", "one two free"); -} - -{ - package Foo; - sub AUTOLOAD :lvalue { *{$AUTOLOAD} }; - package main; - my $foo = bless {},"Foo"; - my $result; - $foo->bar = sub { $result = "bar" }; - $foo->bar; - is ($result, 'bar', "RT #41550"); -} - -# This is a test of BEGIN / compile time behavior which can't be tested in B::C -#$@ = ''; -#fresh_perl_is(<<'----', <<'====', "lvalue can not be set after definition. [perl #68758]", stderr => 0); -#use warnings; -#our $x; -#sub foo { $x } -#sub foo : lvalue; -#foo = 3; -#---- -#lvalue attribute ignored after the subroutine has been defined at - line 4. -#Can't modify non-lvalue subroutine call in scalar assignment at - line 5, near "3;" -#Execution of - aborted due to compilation errors. -#==== - -{ - my $x; - sub lval_decl : lvalue; - sub lval_decl { $x } - lval_decl = 5; - is($x, 5, "subroutine declared with lvalue before definition retains lvalue. [perl #68758]"); -} - -sub fleen : lvalue { $pnare } -$pnare = __PACKAGE__; -ok(eval { fleen = 1 }, "lvalues can return COWs (CATTLE?) [perl #75656]"); -is($pnare, 1, 'and returning CATTLE actually works'); - -{ - my $result_3363; - sub a_3363 { - my ($word, $replace) = @_; - my $ref = \substr($word, 0, 1); - $$ref = $replace; - if ($replace eq "b") { - $result_3363 = $word; - } else { - a_3363($word, "b"); - } - } - a_3363($_, "v") for "test"; - - is($result_3363, "best", "ref-to-substr retains lvalue-ness under recursion [perl #3363]"); -} diff --git a/t/CORE/op/svleak.t b/t/CORE/op/svleak.t deleted file mode 100644 index 8f6fb94d4..000000000 --- a/t/CORE/op/svleak.t +++ /dev/null @@ -1,141 +0,0 @@ -#!./perl - -# A place to put some simple leak tests. Uses XS::APItest to make -# PL_sv_count available, allowing us to run a bit of code multiple times and -# see if the count increases. - -BEGIN { - unshift @INC, 't/CORE/lib'; - require 't/CORE/test.pl'; -} - -plan tests => 19; -eval { require XS::APItest; XS::APItest->import('sv_count'); 1 } - or skip_all("XS::APItest not available"); - -# run some code N times. If the number of SVs at the end of loop N is -# greater than (N-1)*delta at the end of loop 1, we've got a leak -# -sub leak { - my ($n, $delta, $code, @rest) = @_; - my $sv0 = 0; - my $sv1 = 0; - for my $i (1..$n) { - &$code(); - $sv1 = sv_count(); - $sv0 = $sv1 if $i == 1; - } - cmp_ok($sv1-$sv0, '<=', ($n-1)*$delta, @rest); -} - -# run some expression N times. The expr is concatenated N times and then -# evaled, ensuring that that there are no scope exits between executions. -# If the number of SVs at the end of expr N is greater than (N-1)*delta at -# the end of expr 1, we've got a leak -# -sub leak_expr { - my ($n, $delta, $expr, @rest) = @_; - my $sv0 = 0; - my $sv1 = 0; - my $true = 1; # avoid stuff being optimised away - my $code1 = "($expr || \$true)"; - my $code = "$code1 && (\$sv0 = sv_count())" . ("&& $code1" x 4) - . " && (\$sv1 = sv_count())"; - if (eval $code) { - cmp_ok($sv1-$sv0, '<=', ($n-1)*$delta, @rest); - } - else { - fail("eval @rest: $@"); - } -} - - -my @a; - -leak(5, 0, sub {}, "basic check 1 of leak test infrastructure"); -leak(5, 0, sub {push @a,1;pop @a}, "basic check 2 of leak test infrastructure"); -leak(5, 1, sub {push @a,1;}, "basic check 3 of leak test infrastructure"); - -sub TIEARRAY { bless [], $_[0] } -sub FETCH { $_[0]->[$_[1]] } -sub STORE { $_[0]->[$_[1]] = $_[2] } - -# local $tied_elem[..] leaks <20020502143736.N16831@dansat.data-plan.com>" -{ - tie my @a, 'main'; - leak(5, 0, sub {local $a[0]}, "local \$tied[0]"); -} - -# [perl #74484] repeated tries leaked SVs on the tmps stack - -leak_expr(5, 0, q{"YYYYYa" =~ /.+?(a(.+?)|b)/ }, "trie leak"); - -# [perl #48004] map/grep didn't free tmps till the end - -{ - # qr/1/ just creates tmps that are hopefully freed per iteration - - my $s; - my @a; - my @count = (0) x 4; # pre-allocate - - grep qr/1/ && ($count[$_] = sv_count()) && 99, 0..3; - is(@count[3] - @count[0], 0, "void grep expr: no new tmps per iter"); - grep { qr/1/ && ($count[$_] = sv_count()) && 99 } 0..3; - is(@count[3] - @count[0], 0, "void grep block: no new tmps per iter"); - - $s = grep qr/1/ && ($count[$_] = sv_count()) && 99, 0..3; - is(@count[3] - @count[0], 0, "scalar grep expr: no new tmps per iter"); - $s = grep { qr/1/ && ($count[$_] = sv_count()) && 99 } 0..3; - is(@count[3] - @count[0], 0, "scalar grep block: no new tmps per iter"); - - @a = grep qr/1/ && ($count[$_] = sv_count()) && 99, 0..3; - is(@count[3] - @count[0], 0, "list grep expr: no new tmps per iter"); - @a = grep { qr/1/ && ($count[$_] = sv_count()) && 99 } 0..3; - is(@count[3] - @count[0], 0, "list grep block: no new tmps per iter"); - - - map qr/1/ && ($count[$_] = sv_count()) && 99, 0..3; - is(@count[3] - @count[0], 0, "void map expr: no new tmps per iter"); - map { qr/1/ && ($count[$_] = sv_count()) && 99 } 0..3; - is(@count[3] - @count[0], 0, "void map block: no new tmps per iter"); - - $s = map qr/1/ && ($count[$_] = sv_count()) && 99, 0..3; - is(@count[3] - @count[0], 0, "scalar map expr: no new tmps per iter"); - $s = map { qr/1/ && ($count[$_] = sv_count()) && 99 } 0..3; - is(@count[3] - @count[0], 0, "scalar map block: no new tmps per iter"); - - @a = map qr/1/ && ($count[$_] = sv_count()) && 99, 0..3; - is(@count[3] - @count[0], 3, "list map expr: one new tmp per iter"); - @a = map { qr/1/ && ($count[$_] = sv_count()) && 99 } 0..3; - is(@count[3] - @count[0], 3, "list map block: one new tmp per iter"); - -} - -SKIP: -{ # broken by 304474c3, fixed by cefd5c7c, but didn't seem to cause - # any other test failures - # base test case from ribasushi (Peter Rabbitson) - eval { require Scalar::Util; Scalar::Util->import("weaken"); 1; } - or skip "no weaken", 1; - my $weak; - { - $weak = my $in = {}; - weaken($weak); - my $out = { in => $in, in => undef } - } - ok(!$weak, "hash referenced weakened SV released"); -} - -# RT #72246: rcatline memory leak on bad $/ - -leak(2, 0, - sub { - my $f; - open CATLINE, '<', \$f; - local $/ = "\x{262E}"; - my $str = "\x{2622}"; - eval { $str .= }; - }, - "rcatline leak" -); diff --git a/t/CORE/op/switch.t b/t/CORE/op/switch.t deleted file mode 100644 index 81f1c5893..000000000 --- a/t/CORE/op/switch.t +++ /dev/null @@ -1,1203 +0,0 @@ -#!./perl - -BEGIN { - unshift @INC, 't/CORE/lib'; - require 't/CORE/test.pl'; -} - -use strict; -use warnings; - -plan tests => 164; - -# The behaviour of the feature pragma should be tested by lib/switch.t -# using the tests in t/lib/switch/*. This file tests the behaviour of -# the switch ops themselves. - -use feature 'switch'; - -eval { continue }; -like($@, qr/^Can't "continue" outside/, "continue outside"); - -eval { break }; -like($@, qr/^Can't "break" outside/, "break outside"); - -# Scoping rules - -{ - my $x = "foo"; - given(my $x = "bar") { - is($x, "bar", "given scope starts"); - } - is($x, "foo", "given scope ends"); -} - -sub be_true {1} - -given(my $x = "foo") { - when(be_true(my $x = "bar")) { - is($x, "bar", "given scope starts"); - } - is($x, "foo", "given scope ends"); -} - -$_ = "outside"; -given("inside") { check_outside1() } -sub check_outside1 { is($_, "outside", "\$_ lexically scoped") } - -{ - my $_ = "outside"; - given("inside") { check_outside2() } - sub check_outside2 { - is($_, "outside", "\$_ lexically scoped (lexical \$_)") - } -} - -# Basic string/numeric comparisons and control flow - -{ - my $ok; - given(3) { - when(2) { $ok = 'two'; } - when(3) { $ok = 'three'; } - when(4) { $ok = 'four'; } - default { $ok = 'd'; } - } - is($ok, 'three', "numeric comparison"); -} - -{ - my $ok; - use integer; - given(3.14159265) { - when(2) { $ok = 'two'; } - when(3) { $ok = 'three'; } - when(4) { $ok = 'four'; } - default { $ok = 'd'; } - } - is($ok, 'three', "integer comparison"); -} - -{ - my ($ok1, $ok2); - given(3) { - when(3.1) { $ok1 = 'n'; } - when(3.0) { $ok1 = 'y'; continue } - when("3.0") { $ok2 = 'y'; } - default { $ok2 = 'n'; } - } - is($ok1, 'y', "more numeric (pt. 1)"); - is($ok2, 'y', "more numeric (pt. 2)"); -} - -{ - my $ok; - given("c") { - when("b") { $ok = 'B'; } - when("c") { $ok = 'C'; } - when("d") { $ok = 'D'; } - default { $ok = 'def'; } - } - is($ok, 'C', "string comparison"); -} - -{ - my $ok; - given("c") { - when("b") { $ok = 'B'; } - when("c") { $ok = 'C'; continue } - when("c") { $ok = 'CC'; } - default { $ok = 'D'; } - } - is($ok, 'CC', "simple continue"); -} - -# Definedness -{ - my $ok = 1; - given (0) { when(undef) {$ok = 0} } - is($ok, 1, "Given(0) when(undef)"); -} -{ - my $undef; - my $ok = 1; - given (0) { when($undef) {$ok = 0} } - is($ok, 1, 'Given(0) when($undef)'); -} -{ - my $undef; - my $ok = 0; - given (0) { when($undef++) {$ok = 1} } - is($ok, 1, "Given(0) when($undef++)"); -} -{ - no warnings "uninitialized"; - my $ok = 1; - given (undef) { when(0) {$ok = 0} } - is($ok, 1, "Given(undef) when(0)"); -} -{ - no warnings "uninitialized"; - my $undef; - my $ok = 1; - given ($undef) { when(0) {$ok = 0} } - is($ok, 1, 'Given($undef) when(0)'); -} -######## -{ - my $ok = 1; - given ("") { when(undef) {$ok = 0} } - is($ok, 1, 'Given("") when(undef)'); -} -{ - my $undef; - my $ok = 1; - given ("") { when($undef) {$ok = 0} } - is($ok, 1, 'Given("") when($undef)'); -} -{ - no warnings "uninitialized"; - my $ok = 1; - given (undef) { when("") {$ok = 0} } - is($ok, 1, 'Given(undef) when("")'); -} -{ - no warnings "uninitialized"; - my $undef; - my $ok = 1; - given ($undef) { when("") {$ok = 0} } - is($ok, 1, 'Given($undef) when("")'); -} -######## -{ - my $ok = 0; - given (undef) { when(undef) {$ok = 1} } - is($ok, 1, "Given(undef) when(undef)"); -} -{ - my $undef; - my $ok = 0; - given (undef) { when($undef) {$ok = 1} } - is($ok, 1, 'Given(undef) when($undef)'); -} -{ - my $undef; - my $ok = 0; - given ($undef) { when(undef) {$ok = 1} } - is($ok, 1, 'Given($undef) when(undef)'); -} -{ - my $undef; - my $ok = 0; - given ($undef) { when($undef) {$ok = 1} } - is($ok, 1, 'Given($undef) when($undef)'); -} - - -# Regular expressions -{ - my ($ok1, $ok2); - given("Hello, world!") { - when(/lo/) - { $ok1 = 'y'; continue} - when(/no/) - { $ok1 = 'n'; continue} - when(/^(Hello,|Goodbye cruel) world[!.?]/) - { $ok2 = 'Y'; continue} - when(/^(Hello cruel|Goodbye,) world[!.?]/) - { $ok2 = 'n'; continue} - } - is($ok1, 'y', "regex 1"); - is($ok2, 'Y', "regex 2"); -} - -# Comparisons -{ - my $test = "explicit numeric comparison (<)"; - my $twenty_five = 25; - my $ok; - given($twenty_five) { - when ($_ < 10) { $ok = "ten" } - when ($_ < 20) { $ok = "twenty" } - when ($_ < 30) { $ok = "thirty" } - when ($_ < 40) { $ok = "forty" } - default { $ok = "default" } - } - is($ok, "thirty", $test); -} - -{ - use integer; - my $test = "explicit numeric comparison (integer <)"; - my $twenty_five = 25; - my $ok; - given($twenty_five) { - when ($_ < 10) { $ok = "ten" } - when ($_ < 20) { $ok = "twenty" } - when ($_ < 30) { $ok = "thirty" } - when ($_ < 40) { $ok = "forty" } - default { $ok = "default" } - } - is($ok, "thirty", $test); -} - -{ - my $test = "explicit numeric comparison (<=)"; - my $twenty_five = 25; - my $ok; - given($twenty_five) { - when ($_ <= 10) { $ok = "ten" } - when ($_ <= 20) { $ok = "twenty" } - when ($_ <= 30) { $ok = "thirty" } - when ($_ <= 40) { $ok = "forty" } - default { $ok = "default" } - } - is($ok, "thirty", $test); -} - -{ - use integer; - my $test = "explicit numeric comparison (integer <=)"; - my $twenty_five = 25; - my $ok; - given($twenty_five) { - when ($_ <= 10) { $ok = "ten" } - when ($_ <= 20) { $ok = "twenty" } - when ($_ <= 30) { $ok = "thirty" } - when ($_ <= 40) { $ok = "forty" } - default { $ok = "default" } - } - is($ok, "thirty", $test); -} - - -{ - my $test = "explicit numeric comparison (>)"; - my $twenty_five = 25; - my $ok; - given($twenty_five) { - when ($_ > 40) { $ok = "forty" } - when ($_ > 30) { $ok = "thirty" } - when ($_ > 20) { $ok = "twenty" } - when ($_ > 10) { $ok = "ten" } - default { $ok = "default" } - } - is($ok, "twenty", $test); -} - -{ - my $test = "explicit numeric comparison (>=)"; - my $twenty_five = 25; - my $ok; - given($twenty_five) { - when ($_ >= 40) { $ok = "forty" } - when ($_ >= 30) { $ok = "thirty" } - when ($_ >= 20) { $ok = "twenty" } - when ($_ >= 10) { $ok = "ten" } - default { $ok = "default" } - } - is($ok, "twenty", $test); -} - -{ - use integer; - my $test = "explicit numeric comparison (integer >)"; - my $twenty_five = 25; - my $ok; - given($twenty_five) { - when ($_ > 40) { $ok = "forty" } - when ($_ > 30) { $ok = "thirty" } - when ($_ > 20) { $ok = "twenty" } - when ($_ > 10) { $ok = "ten" } - default { $ok = "default" } - } - is($ok, "twenty", $test); -} - -{ - use integer; - my $test = "explicit numeric comparison (integer >=)"; - my $twenty_five = 25; - my $ok; - given($twenty_five) { - when ($_ >= 40) { $ok = "forty" } - when ($_ >= 30) { $ok = "thirty" } - when ($_ >= 20) { $ok = "twenty" } - when ($_ >= 10) { $ok = "ten" } - default { $ok = "default" } - } - is($ok, "twenty", $test); -} - - -{ - my $test = "explicit string comparison (lt)"; - my $twenty_five = "25"; - my $ok; - given($twenty_five) { - when ($_ lt "10") { $ok = "ten" } - when ($_ lt "20") { $ok = "twenty" } - when ($_ lt "30") { $ok = "thirty" } - when ($_ lt "40") { $ok = "forty" } - default { $ok = "default" } - } - is($ok, "thirty", $test); -} - -{ - my $test = "explicit string comparison (le)"; - my $twenty_five = "25"; - my $ok; - given($twenty_five) { - when ($_ le "10") { $ok = "ten" } - when ($_ le "20") { $ok = "twenty" } - when ($_ le "30") { $ok = "thirty" } - when ($_ le "40") { $ok = "forty" } - default { $ok = "default" } - } - is($ok, "thirty", $test); -} - -{ - my $test = "explicit string comparison (gt)"; - my $twenty_five = 25; - my $ok; - given($twenty_five) { - when ($_ ge "40") { $ok = "forty" } - when ($_ ge "30") { $ok = "thirty" } - when ($_ ge "20") { $ok = "twenty" } - when ($_ ge "10") { $ok = "ten" } - default { $ok = "default" } - } - is($ok, "twenty", $test); -} - -{ - my $test = "explicit string comparison (ge)"; - my $twenty_five = 25; - my $ok; - given($twenty_five) { - when ($_ ge "40") { $ok = "forty" } - when ($_ ge "30") { $ok = "thirty" } - when ($_ ge "20") { $ok = "twenty" } - when ($_ ge "10") { $ok = "ten" } - default { $ok = "default" } - } - is($ok, "twenty", $test); -} - -# Make sure it still works with a lexical $_: -{ - my $_; - my $test = "explicit comparison with lexical \$_"; - my $twenty_five = 25; - my $ok; - given($twenty_five) { - when ($_ ge "40") { $ok = "forty" } - when ($_ ge "30") { $ok = "thirty" } - when ($_ ge "20") { $ok = "twenty" } - when ($_ ge "10") { $ok = "ten" } - default { $ok = "default" } - } - is($ok, "twenty", $test); -} - -# Optimized-away comparisons -{ - my $ok; - given(23) { - when (2 + 2 == 4) { $ok = 'y'; continue } - when (2 + 2 == 5) { $ok = 'n' } - } - is($ok, 'y', "Optimized-away comparison"); -} - -{ - my $ok; - given(23) { - when (scalar 24) { $ok = 'n'; continue } - default { $ok = 'y' } - } - is($ok,'y','scalar()'); -} - -# File tests -# (How to be both thorough and portable? Pinch a few ideas -# from t/op/filetest.t. We err on the side of portability for -# the time being.) - -{ - my ($ok_d, $ok_f, $ok_r); - given("op") { - when(-d) {$ok_d = 1; continue} - when(!-f) {$ok_f = 1; continue} - when(-r) {$ok_r = 1; continue} - } - ok($ok_d, "Filetest -d"); - ok($ok_f, "Filetest -f"); - ok($ok_r, "Filetest -r"); -} - -# Sub and method calls -sub notfoo {"bar"} -{ - my $ok = 0; - given("foo") { - when(notfoo()) {$ok = 1} - } - ok($ok, "Sub call acts as boolean") -} - -{ - my $ok = 0; - given("foo") { - when(main->notfoo()) {$ok = 1} - } - ok($ok, "Class-method call acts as boolean") -} - -{ - my $ok = 0; - my $obj = bless []; - given("foo") { - when($obj->notfoo()) {$ok = 1} - } - ok($ok, "Object-method call acts as boolean") -} - -# Other things that should not be smart matched -{ - my $ok = 0; - given(12) { - when( /(\d+)/ and ( 1 <= $1 and $1 <= 12 ) ) { - $ok = 1; - } - } - ok($ok, "bool not smartmatches"); -} - -{ - my $ok = 0; - given(0) { - when(eof(DATA)) { - $ok = 1; - } - } - ok($ok, "eof() not smartmatched"); -} - -{ - my $ok = 0; - my %foo = ("bar", 0); - given(0) { - when(exists $foo{bar}) { - $ok = 1; - } - } - ok($ok, "exists() not smartmatched"); -} - -{ - my $ok = 0; - given(0) { - when(defined $ok) { - $ok = 1; - } - } - ok($ok, "defined() not smartmatched"); -} - -{ - my $ok = 1; - given("foo") { - when((1 == 1) && "bar") { - $ok = 0; - } - when((1 == 1) && $_ eq "foo") { - $ok = 2; - } - } - is($ok, 2, "((1 == 1) && \"bar\") not smartmatched"); -} - -{ - my $n = 0; - for my $l (qw(a b c d)) { - given ($l) { - when ($_ eq "b" .. $_ eq "c") { $n = 1 } - default { $n = 0 } - } - ok(($n xor $l =~ /[ad]/), 'when(E1..E2) evaluates in boolean context'); - } -} - -{ - my $n = 0; - for my $l (qw(a b c d)) { - given ($l) { - when ($_ eq "b" ... $_ eq "c") { $n = 1 } - default { $n = 0 } - } - ok(($n xor $l =~ /[ad]/), 'when(E1...E2) evaluates in boolean context'); - } -} - -{ - my $ok = 0; - given("foo") { - when((1 == $ok) || "foo") { - $ok = 1; - } - } - ok($ok, '((1 == $ok) || "foo") smartmatched'); -} - -{ - my $ok = 0; - given("foo") { - when((1 == $ok || undef) // "foo") { - $ok = 1; - } - } - ok($ok, '((1 == $ok || undef) // "foo") smartmatched'); -} - -# Make sure we aren't invoking the get-magic more than once - -{ # A helper class to count the number of accesses. - package FetchCounter; - sub TIESCALAR { - my ($class) = @_; - bless {value => undef, count => 0}, $class; - } - sub STORE { - my ($self, $val) = @_; - $self->{count} = 0; - $self->{value} = $val; - } - sub FETCH { - my ($self) = @_; - # Avoid pre/post increment here - $self->{count} = 1 + $self->{count}; - $self->{value}; - } - sub count { - my ($self) = @_; - $self->{count}; - } -} - -my $f = tie my $v, "FetchCounter"; - -{ my $test_name = "Only one FETCH (in given)"; - my $ok; - given($v = 23) { - when(undef) {} - when(sub{0}->()) {} - when(21) {} - when("22") {} - when(23) {$ok = 1} - when(/24/) {$ok = 0} - } - is($ok, 1, "precheck: $test_name"); - is($f->count(), 1, $test_name); -} - -{ my $test_name = "Only one FETCH (numeric when)"; - my $ok; - $v = 23; - is($f->count(), 0, "Sanity check: $test_name"); - given(23) { - when(undef) {} - when(sub{0}->()) {} - when(21) {} - when("22") {} - when($v) {$ok = 1} - when(/24/) {$ok = 0} - } - is($ok, 1, "precheck: $test_name"); - is($f->count(), 1, $test_name); -} - -{ my $test_name = "Only one FETCH (string when)"; - my $ok; - $v = "23"; - is($f->count(), 0, "Sanity check: $test_name"); - given("23") { - when(undef) {} - when(sub{0}->()) {} - when("21") {} - when("22") {} - when($v) {$ok = 1} - when(/24/) {$ok = 0} - } - is($ok, 1, "precheck: $test_name"); - is($f->count(), 1, $test_name); -} - -{ my $test_name = "Only one FETCH (undef)"; - my $ok; - $v = undef; - is($f->count(), 0, "Sanity check: $test_name"); - no warnings "uninitialized"; - given(my $undef) { - when(sub{0}->()) {} - when("21") {} - when("22") {} - when($v) {$ok = 1} - when(undef) {$ok = 0} - } - is($ok, 1, "precheck: $test_name"); - is($f->count(), 1, $test_name); -} - -# Loop topicalizer -{ - my $first = 1; - for (1, "two") { - when ("two") { - is($first, 0, "Loop: second"); - eval {break}; - like($@, qr/^Can't "break" in a loop topicalizer/, - q{Can't "break" in a loop topicalizer}); - } - when (1) { - is($first, 1, "Loop: first"); - $first = 0; - # Implicit break is okay - } - } -} - -{ - my $first = 1; - for $_ (1, "two") { - when ("two") { - is($first, 0, "Explicit \$_: second"); - eval {break}; - like($@, qr/^Can't "break" in a loop topicalizer/, - q{Can't "break" in a loop topicalizer}); - } - when (1) { - is($first, 1, "Explicit \$_: first"); - $first = 0; - # Implicit break is okay - } - } -} - -{ - my $first = 1; - my $_; - for (1, "two") { - when ("two") { - is($first, 0, "Implicitly lexical loop: second"); - eval {break}; - like($@, qr/^Can't "break" in a loop topicalizer/, - q{Can't "break" in a loop topicalizer}); - } - when (1) { - is($first, 1, "Implicitly lexical loop: first"); - $first = 0; - # Implicit break is okay - } - } -} - -{ - my $first = 1; - my $_; - for $_ (1, "two") { - when ("two") { - is($first, 0, "Implicitly lexical, explicit \$_: second"); - eval {break}; - like($@, qr/^Can't "break" in a loop topicalizer/, - q{Can't "break" in a loop topicalizer}); - } - when (1) { - is($first, 1, "Implicitly lexical, explicit \$_: first"); - $first = 0; - # Implicit break is okay - } - } -} - -{ - my $first = 1; - for my $_ (1, "two") { - when ("two") { - is($first, 0, "Lexical loop: second"); - eval {break}; - like($@, qr/^Can't "break" in a loop topicalizer/, - q{Can't "break" in a loop topicalizer}); - } - when (1) { - is($first, 1, "Lexical loop: first"); - $first = 0; - # Implicit break is okay - } - } -} - - -# Code references -{ - my $called_foo = 0; - sub foo {$called_foo = 1; "@_" eq "foo"} - my $called_bar = 0; - sub bar {$called_bar = 1; "@_" eq "bar"} - my ($matched_foo, $matched_bar) = (0, 0); - given("foo") { - when(\&bar) {$matched_bar = 1} - when(\&foo) {$matched_foo = 1} - } - is($called_foo, 1, "foo() was called"); - is($called_bar, 1, "bar() was called"); - is($matched_bar, 0, "bar didn't match"); - is($matched_foo, 1, "foo did match"); -} - -sub contains_x { - my $x = shift; - return ($x =~ /x/); -} -{ - my ($ok1, $ok2) = (0,0); - given("foxy!") { - when(contains_x($_)) - { $ok1 = 1; continue } - when(\&contains_x) - { $ok2 = 1; continue } - } - is($ok1, 1, "Calling sub directly (true)"); - is($ok2, 1, "Calling sub indirectly (true)"); - - given("foggy") { - when(contains_x($_)) - { $ok1 = 2; continue } - when(\&contains_x) - { $ok2 = 2; continue } - } - is($ok1, 1, "Calling sub directly (false)"); - is($ok2, 1, "Calling sub indirectly (false)"); -} - -{ - # Test overloading - { package OverloadTest; - - use overload '""' => sub{"string value of obj"}; - use overload 'eq' => sub{"$_[0]" eq "$_[1]"}; - - use overload "~~" => sub { - my ($self, $other, $reversed) = @_; - if ($reversed) { - $self->{left} = $other; - $self->{right} = $self; - $self->{reversed} = 1; - } else { - $self->{left} = $self; - $self->{right} = $other; - $self->{reversed} = 0; - } - $self->{called} = 1; - return $self->{retval}; - }; - - sub new { - my ($pkg, $retval) = @_; - bless { - called => 0, - retval => $retval, - }, $pkg; - } - } - - { - my $test = "Overloaded obj in given (true)"; - my $obj = OverloadTest->new(1); - my $matched; - given($obj) { - when ("other arg") {$matched = 1} - default {$matched = 0} - } - - is($obj->{called}, 1, "$test: called"); - ok($matched, "$test: matched"); - } - - { - my $test = "Overloaded obj in given (false)"; - my $obj = OverloadTest->new(0); - my $matched; - given($obj) { - when ("other arg") {$matched = 1} - } - - is($obj->{called}, 1, "$test: called"); - ok(!$matched, "$test: not matched"); - } - - { - my $test = "Overloaded obj in when (true)"; - my $obj = OverloadTest->new(1); - my $matched; - given("topic") { - when ($obj) {$matched = 1} - default {$matched = 0} - } - - is($obj->{called}, 1, "$test: called"); - ok($matched, "$test: matched"); - is($obj->{left}, "topic", "$test: left"); - is($obj->{right}, "string value of obj", "$test: right"); - ok($obj->{reversed}, "$test: reversed"); - } - - { - my $test = "Overloaded obj in when (false)"; - my $obj = OverloadTest->new(0); - my $matched; - given("topic") { - when ($obj) {$matched = 1} - default {$matched = 0} - } - - is($obj->{called}, 1, "$test: called"); - ok(!$matched, "$test: not matched"); - is($obj->{left}, "topic", "$test: left"); - is($obj->{right}, "string value of obj", "$test: right"); - ok($obj->{reversed}, "$test: reversed"); - } -} - -# Postfix when -{ - my $ok; - given (undef) { - $ok = 1 when undef; - } - is($ok, 1, "postfix undef"); -} -{ - my $ok; - given (2) { - $ok += 1 when 7; - $ok += 2 when 9.1685; - $ok += 4 when $_ > 4; - $ok += 8 when $_ < 2.5; - } - is($ok, 8, "postfix numeric"); -} -{ - my $ok; - given ("apple") { - $ok = 1, continue when $_ eq "apple"; - $ok += 2; - $ok = 0 when "banana"; - } - is($ok, 3, "postfix string"); -} -{ - my $ok; - given ("pear") { - do { $ok = 1; continue } when /pea/; - $ok += 2; - $ok = 0 when /pie/; - default { $ok += 4 } - $ok = 0; - } - is($ok, 7, "postfix regex"); -} -# be_true is defined at the beginning of the file -{ - my $x = "what"; - given(my $x = "foo") { - do { - is($x, "foo", "scope inside ... when my \$x = ..."); - continue; - } when be_true(my $x = "bar"); - is($x, "bar", "scope after ... when my \$x = ..."); - } -} -{ - my $x = 0; - given(my $x = 1) { - my $x = 2, continue when be_true(); - is($x, undef, "scope after my \$x = ... when ..."); - } -} - -# Tests for last and next in when clauses -my $letter; - -$letter = ''; -for ("a".."e") { - given ($_) { - $letter = $_; - when ("b") { last } - } - $letter = "z"; -} -is($letter, "b", "last in when"); - -$letter = ''; -LETTER1: for ("a".."e") { - given ($_) { - $letter = $_; - when ("b") { last LETTER1 } - } - $letter = "z"; -} -is($letter, "b", "last LABEL in when"); - -$letter = ''; -for ("a".."e") { - given ($_) { - when (/b|d/) { next } - $letter .= $_; - } - $letter .= ','; -} -is($letter, "a,c,e,", "next in when"); - -$letter = ''; -LETTER2: for ("a".."e") { - given ($_) { - when (/b|d/) { next LETTER2 } - $letter .= $_; - } - $letter .= ','; -} -is($letter, "a,c,e,", "next LABEL in when"); - -# Test goto with given/when -{ - my $flag = 0; - goto GIVEN1; - $flag = 1; - GIVEN1: given ($flag) { - when (0) { break; } - $flag = 2; - } - is($flag, 0, "goto GIVEN1"); -} -{ - my $flag = 0; - given ($flag) { - when (0) { $flag = 1; } - goto GIVEN2; - $flag = 2; - } -GIVEN2: - is($flag, 1, "goto inside given"); -} -{ - my $flag = 0; - given ($flag) { - when (0) { $flag = 1; goto GIVEN3; $flag = 2; } - $flag = 3; - } -GIVEN3: - is($flag, 1, "goto inside given and when"); -} -{ - my $flag = 0; - for ($flag) { - when (0) { $flag = 1; goto GIVEN4; $flag = 2; } - $flag = 3; - } -GIVEN4: - is($flag, 1, "goto inside for and when"); -} -{ - my $flag = 0; -GIVEN5: - given ($flag) { - when (0) { $flag = 1; goto GIVEN5; $flag = 2; } - when (1) { break; } - $flag = 3; - } - is($flag, 1, "goto inside given and when to the given stmt"); -} - -# test with unreified @_ in smart match [perl #71078] -sub unreified_check { ok([@_] ~~ \@_) } # should always match -unreified_check(1,2,"lala"); -unreified_check(1,2,undef); -unreified_check(undef); -unreified_check(undef,""); - -# Test do { given } as a rvalue - -{ - # Simple scalar - my $lexical = 5; - my @things = (11 .. 26); # 16 elements - my @exp = (5, 16, 9); - no warnings 'void'; - for (0, 1, 2) { - my $scalar = do { given ($_) { - when (0) { $lexical } - when (2) { 'void'; 8, 9 } - @things; - } }; - is($scalar, shift(@exp), "rvalue given - simple scalar [$_]"); - } -} -{ - # Postfix scalar - my $lexical = 5; - my @exp = (5, 7, 9); - for (0, 1, 2) { - no warnings 'void'; - my $scalar = do { given ($_) { - $lexical when 0; - 8, 9 when 2; - 6, 7; - } }; - is($scalar, shift(@exp), "rvalue given - postfix scalar [$_]"); - } -} -{ - # Default scalar - my @exp = (5, 9, 9); - for (0, 1, 2) { - my $scalar = do { given ($_) { - no warnings 'void'; - when (0) { 5 } - default { 8, 9 } - 6, 7; - } }; - is($scalar, shift(@exp), "rvalue given - default scalar [$_]"); - } -} -{ - # Simple list - my @things = (11 .. 13); - my @exp = ('3 4 5', '11 12 13', '8 9'); - for (0, 1, 2) { - my @list = do { given ($_) { - when (0) { 3 .. 5 } - when (2) { my $fake = 'void'; 8, 9 } - @things; - } }; - is("@list", shift(@exp), "rvalue given - simple list [$_]"); - } -} -{ - # Postfix list - my @things = (12); - my @exp = ('3 4 5', '6 7', '12'); - for (0, 1, 2) { - my @list = do { given ($_) { - 3 .. 5 when 0; - @things when 2; - 6, 7; - } }; - is("@list", shift(@exp), "rvalue given - postfix list [$_]"); - } -} -{ - # Default list - my @things = (11 .. 20); # 10 elements - my @exp = ('m o o', '8 10', '8 10'); - for (0, 1, 2) { - my @list = do { given ($_) { - when (0) { "moo" =~ /(.)/g } - default { 8, scalar(@things) } - 6, 7; - } }; - is("@list", shift(@exp), "rvalue given - default list [$_]"); - } -} -{ - # Switch control - my @exp = ('6 7', '', '6 7'); - for (0, 1, 2, 3) { - my @list = do { given ($_) { - continue when $_ <= 1; - break when 1; - next when 2; - 6, 7; - } }; - is("@list", shift(@exp), "rvalue given - default list [$_]"); - } -} -{ - # Context propagation - my $smart_hash = sub { - do { given ($_[0]) { - 'undef' when undef; - when ([ 1 .. 3 ]) { 1 .. 3 } - when (4) { my $fake; do { 4, 5 } } - } }; - }; - - my $scalar; - - $scalar = $smart_hash->(); - is($scalar, 'undef', "rvalue given - scalar context propagation [undef]"); - - $scalar = $smart_hash->(4); - is($scalar, 5, "rvalue given - scalar context propagation [4]"); - - $scalar = $smart_hash->(999); - is($scalar, undef, "rvalue given - scalar context propagation [999]"); - - my @list; - - @list = $smart_hash->(); - is("@list", 'undef', "rvalue given - list context propagation [undef]"); - - @list = $smart_hash->(2); - is("@list", '1 2 3', "rvalue given - list context propagation [2]"); - - @list = $smart_hash->(4); - is("@list", '4 5', "rvalue given - list context propagation [4]"); - - @list = $smart_hash->(999); - is("@list", '', "rvalue given - list context propagation [999]"); -} -{ - # Array slices - my @list = 10 .. 15; - my @in_list; - my @in_slice; - for (5, 10, 15) { - given ($_) { - when (@list) { - push @in_list, $_; - continue; - } - when (@list[0..2]) { - push @in_slice, $_; - } - } - } - is("@in_list", "10 15", "when(array)"); - is("@in_slice", "10", "when(array slice)"); -} -{ - # Hash slices - my %list = map { $_ => $_ } "a" .. "f"; - my @in_list; - my @in_slice; - for ("a", "e", "i") { - given ($_) { - when (%list) { - push @in_list, $_; - continue; - } - when (@list{"a".."c"}) { - push @in_slice, $_; - } - } - } - is("@in_list", "a e", "when(hash)"); - is("@in_slice", "a", "when(hash slice)"); -} - -# Okay, that'll do for now. The intricacies of the smartmatch -# semantics are tested in t/op/smartmatch.t -__END__ diff --git a/t/CORE/op/symbolcache.t b/t/CORE/op/symbolcache.t deleted file mode 100644 index b98ff0bdf..000000000 --- a/t/CORE/op/symbolcache.t +++ /dev/null @@ -1,45 +0,0 @@ -#!./perl - -BEGIN { - require 't/CORE/test.pl'; -} - -plan( tests => 8 ); - -use strict; - -# first, with delete -# simple removal -sub removed { 23 } -sub bound { removed() } -delete $main::{removed}; -is( bound(), 23, 'function still bound' ); -ok( !main->can('removed'), 'function not available as method' ); - -# replacement -eval q/ -sub replaced { 'func' } -is( replaced(), 'func', 'original function still bound' ); -is( main->replaced, 'meth', 'method is replaced function' ); -BEGIN { delete $main::{replaced} } -sub replaced { 'meth' } -/; - -# and now with undef -# simple removal -sub removed2 { 24 } -sub bound2 { removed2() } -undef $main::{removed2}; -eval { bound2() }; -like( $@, qr/Undefined subroutine &main::removed2 called/, - 'function not bound' ); -ok( !main->can('removed2'), 'function not available as method' ); - -# replacement -eval q/ -sub replaced2 { 'func' } -is( replaced2(), 'meth', 'original function not bound, was replaced' ); -ok( main->replaced2 eq 'meth', 'method is replaced function' ); -BEGIN { undef $main::{replaced2} } -sub replaced2 { 'meth' } -/; \ No newline at end of file diff --git a/t/CORE/op/sysio.t b/t/CORE/op/sysio.t deleted file mode 100644 index 2aa1f9854..000000000 --- a/t/CORE/op/sysio.t +++ /dev/null @@ -1,243 +0,0 @@ -#!./perl - -BEGIN { - require 't/CORE/test.pl'; -} - -INIT { - unshift @INC, 't/CORE/lib'; -} - -plan(tests => 48); - -open(I, 't/CORE/op/sysio.t') || die "sysio.t: cannot find myself: $!"; - -$reopen = ($^O eq 'VMS' || - $^O eq 'os2' || - $^O eq 'MSWin32' || - $^O eq 'NetWare' || - $^O eq 'dos' || - $^O eq 'mpeix'); - -$x = 'abc'; - -# should not be able to do negative lengths -eval { sysread(I, $x, -1) }; -like($@, qr/^Negative length /); - -# $x should be intact -is($x, 'abc'); - -# should not be able to read before the buffer -eval { sysread(I, $x, 1, -4) }; -like($@, qr/^Offset outside string /); - -# $x should be intact -is($x, 'abc'); - -$a ='0123456789'; - -# default offset 0 -is(sysread(I, $a, 3), 3); - -# $a should be as follows -is($a, '#!.'); - -# reading past the buffer should zero pad -is(sysread(I, $a, 2, 5), 2); - -# the zero pad should be seen now -is($a, "#!.\0\0/p"); - -# try changing the last two characters of $a -is(sysread(I, $a, 3, -2), 3); - -# the last two characters of $a should have changed (into three) -is($a, "#!.\0\0erl"); - -$outfile = tempfile(); - -open(O, ">$outfile") || die "sysio.t: cannot write $outfile: $!"; - -select(O); $|=1; select(STDOUT); - -# cannot write negative lengths -eval { syswrite(O, $x, -1) }; -like($@, qr/^Negative length /); - -# $x still intact -is($x, 'abc'); - -# $outfile still intact -ok(!-s $outfile); - -# should not be able to write from after the buffer -eval { syswrite(O, $x, 1, 4) }; -like($@, qr/^Offset outside string /); - -# $x still intact -is($x, 'abc'); - -# but it should be ok to write from the end of the buffer -syswrite(O, $x, 0, 3); -syswrite(O, $x, 1, 3); - -# $outfile still intact -if ($reopen) { # must close file to update EOF marker for stat - close O; open(O, ">>$outfile") || die "sysio.t: cannot write $outfile: $!"; -} -ok(!-s $outfile); - -# should not be able to write from before the buffer - -eval { syswrite(O, $x, 1, -4) }; -like($@, qr/^Offset outside string /); - -# $x still intact -is($x, 'abc'); - -# $outfile still intact -if ($reopen) { # must close file to update EOF marker for stat - close O; open(O, ">>$outfile") || die "sysio.t: cannot write $outfile: $!"; -} -ok(!-s $outfile); - -# [perl #67912] syswrite prints garbage if called with empty scalar and non-zero offset -eval { my $buf = ''; syswrite(O, $buf, 1, 1) }; -like($@, qr/^Offset outside string /); - -# $x still intact -is($x, 'abc'); - -# $outfile still intact -if ($reopen) { # must close file to update EOF marker for stat - close O; open(O, ">>$outfile") || die "sysio.t: cannot write $outfile: $!"; -} -ok(!-s $outfile); - -eval { my $buf = 'x'; syswrite(O, $buf, 1, 2) }; -like($@, qr/^Offset outside string /); - -# $x still intact -is($x, 'abc'); - -# $outfile still intact -if ($reopen) { # must close file to update EOF marker for stat - close O; open(O, ">>$outfile") || die "sysio.t: cannot write $outfile: $!"; -} -ok(!-s $outfile); - -# default offset 0 -if (syswrite(O, $a, 2) == 2){ - pass(); -} else { - diag($!); - fail(); - # most other tests make no sense after e.g. "No space left on device" - die $!; -} - - -# $a still intact -is($a, "#!.\0\0erl"); - -# $outfile should have grown now -if ($reopen) { # must close file to update EOF marker for stat - close O; open(O, ">>$outfile") || die "sysio.t: cannot write $outfile: $!"; -} -is(-s $outfile, 2); - -# with offset -is(syswrite(O, $a, 2, 5), 2); - -# $a still intact -is($a, "#!.\0\0erl"); - -# $outfile should have grown now -if ($reopen) { # must close file to update EOF marker for stat - close O; open(O, ">>$outfile") || die "sysio.t: cannot write $outfile: $!"; -} -is(-s $outfile, 4); - -# with negative offset and a bit too much length -is(syswrite(O, $a, 5, -3), 3); - -# $a still intact -is($a, "#!.\0\0erl"); - -# $outfile should have grown now -if ($reopen) { # must close file to update EOF marker for stat - close O; open(O, ">>$outfile") || die "sysio.t: cannot write $outfile: $!"; -} -is(-s $outfile, 7); - -# with implicit length argument -is(syswrite(O, $x), 3); - -# $a still intact -is($x, "abc"); - -# $outfile should have grown now -if ($reopen) { # must close file to update EOF marker for stat - close O; open(O, ">>$outfile") || die "sysio.t: cannot write $outfile: $!"; -} -is(-s $outfile, 10); - -close(O); - -open(I, $outfile) || die "sysio.t: cannot read $outfile: $!"; - -$b = 'xyz'; - -# reading too much only return as much as available -is(sysread(I, $b, 100), 10); - -# this we should have -is($b, '#!ererlabc'); - -# test sysseek - -is(sysseek(I, 2, 0), 2); -sysread(I, $b, 3); -is($b, 'ere'); - -is(sysseek(I, -2, 1), 3); -sysread(I, $b, 4); -is($b, 'rerl'); - -ok(sysseek(I, 0, 0) eq '0 but true'); - -ok(not defined sysseek(I, -1, 1)); - -close(I); - -unlink_all($outfile); - -# Check that utf8 IO doesn't upgrade the scalar -open(I, ">$outfile") || die "sysio.t: cannot write $outfile: $!"; -# Will skip harmlessly on stdioperl -eval {binmode STDOUT, ":utf8"}; -die $@ if $@ and $@ !~ /^IO layers \(like ':utf8'\) unavailable/; - -# y diaresis is \w when UTF8 -$a = chr 255; - -unlike($a, qr/\w/); - -syswrite I, $a; - -# Should not be upgraded as a side effect of syswrite. -unlike($a, qr/\w/); - -# This should work -eval {syswrite I, 2;}; -is($@, ''); - -close(I); -unlink_all $outfile; - -chdir('..'); - -1; - -# eof diff --git a/t/CORE/op/taint.t b/t/CORE/op/taint.t deleted file mode 100644 index ef9081377..000000000 --- a/t/CORE/op/taint.t +++ /dev/null @@ -1,2198 +0,0 @@ -#!./perl -T -# -# Taint tests by Tom Phoenix . -# -# I don't claim to know all about tainting. If anyone sees -# tests that I've missed here, please add them. But this is -# better than having no tests at all, right? -# - -# view perlcc issue #151 https://code.google.com/p/perl-compiler/issues/detail?id=151 - -BEGIN { - unshift @INC, 't/CORE/lib', '.'; - require 't/CORE/test.pl'; - chdir 't/CORE'; -} - -use strict; -use Config; - -plan tests => 779; - -$| = 1; - -use vars qw($ipcsysv); # did we manage to load IPC::SysV? - -my ($old_env_path, $old_env_dcl_path, $old_env_term); -BEGIN { - $old_env_path = $ENV{'PATH'}; - $old_env_dcl_path = $ENV{'DCL$PATH'}; - $old_env_term = $ENV{'TERM'}; - if ($^O eq 'VMS' && !defined($Config{d_setenv})) { - $ENV{PATH} = $ENV{PATH}; - $ENV{TERM} = $ENV{TERM} ne ''? $ENV{TERM} : 'dummy'; - } - if ($Config{'extensions'} =~ /\bIPC\/SysV\b/ - && ($Config{d_shm} || $Config{d_msg})) { - eval { require IPC::SysV }; - unless ($@) { - $ipcsysv++; - IPC::SysV->import(qw(IPC_PRIVATE IPC_RMID IPC_CREAT S_IRWXU IPC_NOWAIT)); - } - } -} - -my $Is_VMS = $^O eq 'VMS'; -my $Is_MSWin32 = $^O eq 'MSWin32'; -my $Is_NetWare = $^O eq 'NetWare'; -my $Is_Dos = $^O eq 'dos'; -my $Is_Cygwin = $^O eq 'cygwin'; -my $Is_OpenBSD = $^O eq 'openbsd'; -my $Is_MirBSD = $^O eq 'mirbsd'; -my $Invoke_Perl = $Is_VMS ? 'MCR Sys$Disk:[]Perl.exe' : - $Is_MSWin32 ? '.\perl' : - $Is_NetWare ? 'perl' : - './perl' ; -my @MoreEnv = qw/IFS CDPATH ENV BASH_ENV/; - -if ($Is_VMS) { - my (%old, $x); - for $x ('DCL$PATH', @MoreEnv) { - ($old{$x}) = $ENV{$x} =~ /^(.*)$/ if exists $ENV{$x}; - } - # VMS note: PATH and TERM are automatically created by the C - # library in VMS on reference to the their keys in %ENV. - # There is currently no way to determine if they did not exist - # before this test was run. - eval <(); }, undef, $desc); - like($@, qr/^Insecure dependency in $what while running with -T switch/); -} - -# We need an external program to call. -my $ECHO = ($Is_MSWin32 ? ".\\echo$$" : ($Is_NetWare ? "echo$$" : "./echo$$")); -END { unlink $ECHO } -open my $fh, '>', $ECHO or die "Can't create $ECHO: $!"; -print $fh 'print "@ARGV\n"', "\n"; -close $fh; -my $echo = "$Invoke_Perl $ECHO"; - -my $TEST = 'TEST'; - -# First, let's make sure that Perl is checking the dangerous -# environment variables. Maybe they aren't set yet, so we'll -# taint them ourselves. -{ - $ENV{'DCL$PATH'} = '' if $Is_VMS; - - if ($Is_MSWin32 && $Config{ccname} =~ /bcc32/ && ! -f 'cc3250mt.dll') { - my $bcc_dir; - foreach my $dir (split /$Config{path_sep}/, $ENV{PATH}) { - if (-f "$dir/cc3250mt.dll") { - $bcc_dir = $dir and last; - } - } - if (defined $bcc_dir) { - require File::Copy; - File::Copy::copy("$bcc_dir/cc3250mt.dll", '.') or - die "$0: failed to copy cc3250mt.dll: $!\n"; - eval q{ - END { unlink "cc3250mt.dll" } - }; - } - } - $ENV{PATH} = ($Is_Cygwin) ? '/usr/bin' : ''; - delete @ENV{@MoreEnv}; - $ENV{TERM} = 'dumb'; - - is(eval { `$echo 1` }, "1\n"); - - SKIP: { - skip "Environment tainting tests skipped", 4 - if $Is_MSWin32 || $Is_NetWare || $Is_VMS || $Is_Dos; - - my @vars = ('PATH', @MoreEnv); - while (my $v = $vars[0]) { - local $ENV{$v} = $TAINT; - last if eval { `$echo 1` }; - last unless $@ =~ /^Insecure \$ENV{$v}/; - shift @vars; - } - is("@vars", ""); - - # tainted $TERM is unsafe only if it contains metachars - local $ENV{TERM}; - $ENV{TERM} = 'e=mc2'; - is(eval { `$echo 1` }, "1\n"); - $ENV{TERM} = 'e=mc2' . $TAINT; - is(eval { `$echo 1` }, undef); - like($@, qr/^Insecure \$ENV{TERM}/); - } - - my $tmp; - if ($^O eq 'os2' || $^O eq 'amigaos' || $Is_MSWin32 || $Is_NetWare || $Is_Dos) { - print "# all directories are writeable\n"; - } - else { - $tmp = (grep { defined and -d and (stat _)[2] & 2 } - qw(sys$scratch /tmp /var/tmp /usr/tmp), - @ENV{qw(TMP TEMP)})[0] - or print "# can't find world-writeable directory to test PATH\n"; - } - - SKIP: { - skip "all directories are writeable", 2 unless $tmp; - - local $ENV{PATH} = $tmp; - is(eval { `$echo 1` }, undef); - like($@, qr/^Insecure directory in \$ENV{PATH}/); - } - - SKIP: { - skip "This is not VMS", 4 unless $Is_VMS; - - $ENV{'DCL$PATH'} = $TAINT; - is(eval { `$echo 1` }, undef); - like($@, qr/^Insecure \$ENV{DCL\$PATH}/); - SKIP: { - skip q[can't find world-writeable directory to test DCL$PATH], 2 - unless $tmp; - - $ENV{'DCL$PATH'} = $tmp; - is(eval { `$echo 1` }, undef); - like($@, qr/^Insecure directory in \$ENV{DCL\$PATH}/); - } - $ENV{'DCL$PATH'} = ''; - } -} - -# Let's see that we can taint and untaint as needed. -{ - my $foo = $TAINT; - is_tainted($foo); - - # That was a sanity check. If it failed, stop the insanity! - die "Taint checks don't seem to be enabled" unless tainted $foo; - - $foo = "foo"; - isnt_tainted($foo); - - taint_these($foo); - is_tainted($foo); - - my @list = 1..10; - isnt_tainted($_) foreach @list; - taint_these @list[1,3,5,7,9]; - is_tainted($_) foreach @list[1,3,5,7,9]; - isnt_tainted($_) foreach @list[0,2,4,6,8]; - - ($foo) = $foo =~ /(.+)/; - isnt_tainted($foo); - - my ($desc, $s, $res, $res2, $one); - - $desc = "match with string tainted"; - - $s = 'abcd' . $TAINT; - $res = $s =~ /(.+)/; - $one = $1; - is_tainted($s, "$desc: s tainted"); - isnt_tainted($res, "$desc: res not tainted"); - isnt_tainted($one, "$desc: \$1 not tainted"); - is($res, 1, "$desc: res value"); - is($one, 'abcd', "$desc: \$1 value"); - - $desc = "match /g with string tainted"; - - $s = 'abcd' . $TAINT; - $res = $s =~ /(.)/g; - $one = $1; - is_tainted($s, "$desc: s tainted"); - isnt_tainted($res, "$desc: res not tainted"); - isnt_tainted($one, "$desc: \$1 not tainted"); - is($res, 1, "$desc: res value"); - is($one, 'a', "$desc: \$1 value"); - - $desc = "match with string tainted, list cxt"; - - $s = 'abcd' . $TAINT; - ($res) = $s =~ /(.+)/; - $one = $1; - is_tainted($s, "$desc: s tainted"); - isnt_tainted($res, "$desc: res not tainted"); - isnt_tainted($one, "$desc: \$1 not tainted"); - is($res, 'abcd', "$desc: res value"); - is($one, 'abcd', "$desc: \$1 value"); - - $desc = "match /g with string tainted, list cxt"; - - $s = 'abcd' . $TAINT; - ($res, $res2) = $s =~ /(.)/g; - $one = $1; - is_tainted($s, "$desc: s tainted"); - isnt_tainted($res, "$desc: res not tainted"); - isnt_tainted($res2,"$desc: res2 not tainted"); - isnt_tainted($one, "$desc: \$1 not tainted"); - is($res, 'a', "$desc: res value"); - is($res2,'b', "$desc: res2 value"); - is($one, 'd', "$desc: \$1 value"); - - $desc = "match with pattern tainted"; - - $s = 'abcd'; - $res = $s =~ /$TAINT(.+)/; - $one = $1; - isnt_tainted($s, "$desc: s not tainted"); - isnt_tainted($res, "$desc: res not tainted"); - is_tainted($one, "$desc: \$1 tainted"); - is($res, 1, "$desc: res value"); - is($one, 'abcd', "$desc: \$1 value"); - - $desc = "match /g with pattern tainted"; - - $s = 'abcd'; - $res = $s =~ /$TAINT(.)/g; - $one = $1; - isnt_tainted($s, "$desc: s not tainted"); - isnt_tainted($res, "$desc: res not tainted"); - is_tainted($one, "$desc: \$1 tainted"); - is($res, 1, "$desc: res value"); - is($one, 'a', "$desc: \$1 value"); - - $desc = "match with pattern tainted via locale"; - - $s = 'abcd'; - { use locale; $res = $s =~ /(\w+)/; $one = $1; } - isnt_tainted($s, "$desc: s not tainted"); - isnt_tainted($res, "$desc: res not tainted"); - is_tainted($one, "$desc: \$1 tainted"); - is($res, 1, "$desc: res value"); - is($one, 'abcd', "$desc: \$1 value"); - - $desc = "match /g with pattern tainted via locale"; - - $s = 'abcd'; - { use locale; $res = $s =~ /(\w)/g; $one = $1; } - isnt_tainted($s, "$desc: s not tainted"); - isnt_tainted($res, "$desc: res not tainted"); - is_tainted($one, "$desc: \$1 tainted"); - is($res, 1, "$desc: res value"); - is($one, 'a', "$desc: \$1 value"); - - $desc = "match with pattern tainted, list cxt"; - - $s = 'abcd'; - ($res) = $s =~ /$TAINT(.+)/; - $one = $1; - isnt_tainted($s, "$desc: s not tainted"); - is_tainted($res, "$desc: res tainted"); - is_tainted($one, "$desc: \$1 tainted"); - is($res, 'abcd', "$desc: res value"); - is($one, 'abcd', "$desc: \$1 value"); - - $desc = "match /g with pattern tainted, list cxt"; - - $s = 'abcd'; - ($res, $res2) = $s =~ /$TAINT(.)/g; - $one = $1; - isnt_tainted($s, "$desc: s not tainted"); - is_tainted($res, "$desc: res tainted"); - is_tainted($one, "$desc: \$1 tainted"); - is($res, 'a', "$desc: res value"); - is($res2,'b', "$desc: res2 value"); - is($one, 'd', "$desc: \$1 value"); - - $desc = "match with pattern tainted via locale, list cxt"; - - $s = 'abcd'; - { use locale; ($res) = $s =~ /(\w+)/; $one = $1; } - isnt_tainted($s, "$desc: s not tainted"); - is_tainted($res, "$desc: res tainted"); - is_tainted($one, "$desc: \$1 tainted"); - is($res, 'abcd', "$desc: res value"); - is($one, 'abcd', "$desc: \$1 value"); - - $desc = "match /g with pattern tainted via locale, list cxt"; - - $s = 'abcd'; - { use locale; ($res, $res2) = $s =~ /(\w)/g; $one = $1; } - isnt_tainted($s, "$desc: s not tainted"); - is_tainted($res, "$desc: res tainted"); - is_tainted($res2, "$desc: res2 tainted"); - is_tainted($one, "$desc: \$1 tainted"); - is($res, 'a', "$desc: res value"); - is($res2,'b', "$desc: res2 value"); - is($one, 'd', "$desc: \$1 value"); - - $desc = "substitution with string tainted"; - - $s = 'abcd' . $TAINT; - $res = $s =~ s/(.+)/xyz/; - $one = $1; - is_tainted($s, "$desc: s tainted"); - isnt_tainted($res, "$desc: res not tainted"); - isnt_tainted($one, "$desc: \$1 not tainted"); - is($s, 'xyz', "$desc: s value"); - is($res, 1, "$desc: res value"); - is($one, 'abcd', "$desc: \$1 value"); - - $desc = "substitution /g with string tainted"; - - $s = 'abcd' . $TAINT; - $res = $s =~ s/(.)/x/g; - $one = $1; - is_tainted($s, "$desc: s tainted"); - is_tainted($res, "$desc: res tainted"); - isnt_tainted($one, "$desc: \$1 not tainted"); - is($s, 'xxxx', "$desc: s value"); - is($res, 4, "$desc: res value"); - is($one, 'd', "$desc: \$1 value"); - - $desc = "substitution /r with string tainted"; - - $s = 'abcd' . $TAINT; - $res = $s =~ s/(.+)/xyz/r; - $one = $1; - is_tainted($s, "$desc: s tainted"); - is_tainted($res, "$desc: res tainted"); - isnt_tainted($one, "$desc: \$1 not tainted"); - is($s, 'abcd', "$desc: s value"); - is($res, 'xyz', "$desc: res value"); - is($one, 'abcd', "$desc: \$1 value"); - - $desc = "substitution /e with string tainted"; - - $s = 'abcd' . $TAINT; - $one = ''; - $res = $s =~ s{(.+)}{ - $one = $one . "x"; # make sure code not tainted - isnt_tainted($one, "$desc: code not tainted within /e"); - $one = $1; - isnt_tainted($one, "$desc: \$1 not tainted within /e"); - "xyz"; - }e; - $one = $1; - is_tainted($s, "$desc: s tainted"); - isnt_tainted($res, "$desc: res not tainted"); - isnt_tainted($one, "$desc: \$1 not tainted"); - is($s, 'xyz', "$desc: s value"); - is($res, 1, "$desc: res value"); - is($one, 'abcd', "$desc: \$1 value"); - - $desc = "substitution with pattern tainted"; - - $s = 'abcd'; - $res = $s =~ s/$TAINT(.+)/xyz/; - $one = $1; - is_tainted($s, "$desc: s tainted"); - isnt_tainted($res, "$desc: res not tainted"); - is_tainted($one, "$desc: \$1 tainted"); - is($s, 'xyz', "$desc: s value"); - is($res, 1, "$desc: res value"); - is($one, 'abcd', "$desc: \$1 value"); - - $desc = "substitution /g with pattern tainted"; - - $s = 'abcd'; - $res = $s =~ s/$TAINT(.)/x/g; - $one = $1; - is_tainted($s, "$desc: s tainted"); - is_tainted($res, "$desc: res tainted"); - is_tainted($one, "$desc: \$1 tainted"); - is($s, 'xxxx', "$desc: s value"); - is($res, 4, "$desc: res value"); - is($one, 'd', "$desc: \$1 value"); - - $desc = "substitution /ge with pattern tainted"; - - $s = 'abc'; - { - my $i = 0; - my $j; - $res = $s =~ s{(.)$TAINT}{ - $j = $i; # make sure code not tainted - $one = $1; - isnt_tainted($j, "$desc: code not tainted within /e"); - $i++; - if ($i == 1) { - isnt_tainted($s, "$desc: s not tainted loop 1"); - } - else { - is_tainted($s, "$desc: s tainted loop $i"); - } - is_tainted($one, "$desc: \$1 tainted loop $i"); - $i.$TAINT; - }ge; - $one = $1; - } - is_tainted($s, "$desc: s tainted"); - is_tainted($res, "$desc: res tainted"); - is_tainted($one, "$desc: \$1 tainted"); - is($s, '123', "$desc: s value"); - is($res, 3, "$desc: res value"); - is($one, 'c', "$desc: \$1 value"); - - $desc = "substitution /r with pattern tainted"; - - $s = 'abcd'; - $res = $s =~ s/$TAINT(.+)/xyz/r; - $one = $1; - isnt_tainted($s, "$desc: s not tainted"); - is_tainted($res, "$desc: res tainted"); - is_tainted($one, "$desc: \$1 tainted"); - is($s, 'abcd', "$desc: s value"); - is($res, 'xyz', "$desc: res value"); - is($one, 'abcd', "$desc: \$1 value"); - - $desc = "substitution with pattern tainted via locale"; - - $s = 'abcd'; - { use locale; $res = $s =~ s/(\w+)/xyz/; $one = $1; } - is_tainted($s, "$desc: s tainted"); - isnt_tainted($res, "$desc: res not tainted"); - is_tainted($one, "$desc: \$1 tainted"); - is($s, 'xyz', "$desc: s value"); - is($res, 1, "$desc: res value"); - is($one, 'abcd', "$desc: \$1 value"); - - $desc = "substitution /g with pattern tainted via locale"; - - $s = 'abcd'; - { use locale; $res = $s =~ s/(\w)/x/g; $one = $1; } - is_tainted($s, "$desc: s tainted"); - is_tainted($res, "$desc: res tainted"); - is_tainted($one, "$desc: \$1 tainted"); - is($s, 'xxxx', "$desc: s value"); - is($res, 4, "$desc: res value"); - is($one, 'd', "$desc: \$1 value"); - - $desc = "substitution /r with pattern tainted via locale"; - - $s = 'abcd'; - { use locale; $res = $s =~ s/(\w+)/xyz/r; $one = $1; } - isnt_tainted($s, "$desc: s not tainted"); - is_tainted($res, "$desc: res tainted"); - is_tainted($one, "$desc: \$1 tainted"); - is($s, 'abcd', "$desc: s value"); - is($res, 'xyz', "$desc: res value"); - is($one, 'abcd', "$desc: \$1 value"); - - $desc = "substitution with replacement tainted"; - - $s = 'abcd'; - $res = $s =~ s/(.+)/xyz$TAINT/; - $one = $1; - is_tainted($s, "$desc: s tainted"); - isnt_tainted($res, "$desc: res not tainted"); - isnt_tainted($one, "$desc: \$1 not tainted"); - is($s, 'xyz', "$desc: s value"); - is($res, 1, "$desc: res value"); - is($one, 'abcd', "$desc: \$1 value"); - - $desc = "substitution /g with replacement tainted"; - - $s = 'abcd'; - $res = $s =~ s/(.)/x$TAINT/g; - $one = $1; - is_tainted($s, "$desc: s tainted"); - isnt_tainted($res, "$desc: res not tainted"); - isnt_tainted($one, "$desc: \$1 not tainted"); - is($s, 'xxxx', "$desc: s value"); - is($res, 4, "$desc: res value"); - is($one, 'd', "$desc: \$1 value"); - - $desc = "substitution /ge with replacement tainted"; - - $s = 'abc'; - { - my $i = 0; - my $j; - $res = $s =~ s{(.)}{ - $j = $i; # make sure code not tainted - $one = $1; - isnt_tainted($j, "$desc: code not tainted within /e"); - $i++; - if ($i == 1) { - isnt_tainted($s, "$desc: s not tainted loop 1"); - } - else { - is_tainted($s, "$desc: s tainted loop $i"); - } - isnt_tainted($one, "$desc: \$1 not tainted within /e"); - $i.$TAINT; - }ge; - $one = $1; - } - is_tainted($s, "$desc: s tainted"); - is_tainted($res, "$desc: res tainted"); - isnt_tainted($one, "$desc: \$1 not tainted"); - is($s, '123', "$desc: s value"); - is($res, 3, "$desc: res value"); - is($one, 'c', "$desc: \$1 value"); - - $desc = "substitution /r with replacement tainted"; - - $s = 'abcd'; - $res = $s =~ s/(.+)/xyz$TAINT/r; - $one = $1; - isnt_tainted($s, "$desc: s not tainted"); - is_tainted($res, "$desc: res tainted"); - isnt_tainted($one, "$desc: \$1 not tainted"); - is($s, 'abcd', "$desc: s value"); - is($res, 'xyz', "$desc: res value"); - is($one, 'abcd', "$desc: \$1 value"); - - { - # now do them all again with "use re 'taint" - - use re 'taint'; - - $desc = "use re 'taint': match with string tainted"; - - $s = 'abcd' . $TAINT; - $res = $s =~ /(.+)/; - $one = $1; - is_tainted($s, "$desc: s tainted"); - isnt_tainted($res, "$desc: res not tainted"); - is_tainted($one, "$desc: \$1 tainted"); - is($res, 1, "$desc: res value"); - is($one, 'abcd', "$desc: \$1 value"); - - $desc = "use re 'taint': match /g with string tainted"; - - $s = 'abcd' . $TAINT; - $res = $s =~ /(.)/g; - $one = $1; - is_tainted($s, "$desc: s tainted"); - isnt_tainted($res, "$desc: res not tainted"); - is_tainted($one, "$desc: \$1 tainted"); - is($res, 1, "$desc: res value"); - is($one, 'a', "$desc: \$1 value"); - - $desc = "use re 'taint': match with string tainted, list cxt"; - - $s = 'abcd' . $TAINT; - ($res) = $s =~ /(.+)/; - $one = $1; - is_tainted($s, "$desc: s tainted"); - is_tainted($res, "$desc: res tainted"); - is_tainted($one, "$desc: \$1 tainted"); - is($res, 'abcd', "$desc: res value"); - is($one, 'abcd', "$desc: \$1 value"); - - $desc = "use re 'taint': match /g with string tainted, list cxt"; - - $s = 'abcd' . $TAINT; - ($res, $res2) = $s =~ /(.)/g; - $one = $1; - is_tainted($s, "$desc: s tainted"); - is_tainted($res, "$desc: res tainted"); - is_tainted($res2, "$desc: res2 tainted"); - is_tainted($one, "$desc: \$1 not tainted"); - is($res, 'a', "$desc: res value"); - is($res2,'b', "$desc: res2 value"); - is($one, 'd', "$desc: \$1 value"); - - $desc = "use re 'taint': match with pattern tainted"; - - $s = 'abcd'; - $res = $s =~ /$TAINT(.+)/; - $one = $1; - isnt_tainted($s, "$desc: s not tainted"); - isnt_tainted($res, "$desc: res not tainted"); - is_tainted($one, "$desc: \$1 tainted"); - is($res, 1, "$desc: res value"); - is($one, 'abcd', "$desc: \$1 value"); - - $desc = "use re 'taint': match /g with pattern tainted"; - - $s = 'abcd'; - $res = $s =~ /$TAINT(.)/g; - $one = $1; - isnt_tainted($s, "$desc: s not tainted"); - isnt_tainted($res, "$desc: res not tainted"); - is_tainted($one, "$desc: \$1 tainted"); - is($res, 1, "$desc: res value"); - is($one, 'a', "$desc: \$1 value"); - - $desc = "use re 'taint': match with pattern tainted via locale"; - - $s = 'abcd'; - { use locale; $res = $s =~ /(\w+)/; $one = $1; } - isnt_tainted($s, "$desc: s not tainted"); - isnt_tainted($res, "$desc: res not tainted"); - is_tainted($one, "$desc: \$1 tainted"); - is($res, 1, "$desc: res value"); - is($one, 'abcd', "$desc: \$1 value"); - - $desc = "use re 'taint': match /g with pattern tainted via locale"; - - $s = 'abcd'; - { use locale; $res = $s =~ /(\w)/g; $one = $1; } - isnt_tainted($s, "$desc: s not tainted"); - isnt_tainted($res, "$desc: res not tainted"); - is_tainted($one, "$desc: \$1 tainted"); - is($res, 1, "$desc: res value"); - is($one, 'a', "$desc: \$1 value"); - - $desc = "use re 'taint': match with pattern tainted, list cxt"; - - $s = 'abcd'; - ($res) = $s =~ /$TAINT(.+)/; - $one = $1; - isnt_tainted($s, "$desc: s not tainted"); - is_tainted($res, "$desc: res tainted"); - is_tainted($one, "$desc: \$1 tainted"); - is($res, 'abcd', "$desc: res value"); - is($one, 'abcd', "$desc: \$1 value"); - - $desc = "use re 'taint': match /g with pattern tainted, list cxt"; - - $s = 'abcd'; - ($res, $res2) = $s =~ /$TAINT(.)/g; - $one = $1; - isnt_tainted($s, "$desc: s not tainted"); - is_tainted($res, "$desc: res tainted"); - is_tainted($one, "$desc: \$1 tainted"); - is($res, 'a', "$desc: res value"); - is($res2,'b', "$desc: res2 value"); - is($one, 'd', "$desc: \$1 value"); - - $desc = "use re 'taint': match with pattern tainted via locale, list cxt"; - - $s = 'abcd'; - { use locale; ($res) = $s =~ /(\w+)/; $one = $1; } - isnt_tainted($s, "$desc: s not tainted"); - is_tainted($res, "$desc: res tainted"); - is_tainted($one, "$desc: \$1 tainted"); - is($res, 'abcd', "$desc: res value"); - is($one, 'abcd', "$desc: \$1 value"); - - $desc = "use re 'taint': match /g with pattern tainted via locale, list cxt"; - - $s = 'abcd'; - { use locale; ($res, $res2) = $s =~ /(\w)/g; $one = $1; } - isnt_tainted($s, "$desc: s not tainted"); - is_tainted($res, "$desc: res tainted"); - is_tainted($res2, "$desc: res2 tainted"); - is_tainted($one, "$desc: \$1 tainted"); - is($res, 'a', "$desc: res value"); - is($res2,'b', "$desc: res2 value"); - is($one, 'd', "$desc: \$1 value"); - - $desc = "use re 'taint': substitution with string tainted"; - - $s = 'abcd' . $TAINT; - $res = $s =~ s/(.+)/xyz/; - $one = $1; - is_tainted($s, "$desc: s tainted"); - isnt_tainted($res, "$desc: res not tainted"); - is_tainted($one, "$desc: \$1 tainted"); - is($s, 'xyz', "$desc: s value"); - is($res, 1, "$desc: res value"); - is($one, 'abcd', "$desc: \$1 value"); - - $desc = "use re 'taint': substitution /g with string tainted"; - - $s = 'abcd' . $TAINT; - $res = $s =~ s/(.)/x/g; - $one = $1; - is_tainted($s, "$desc: s tainted"); - is_tainted($res, "$desc: res tainted"); - is_tainted($one, "$desc: \$1 tainted"); - is($s, 'xxxx', "$desc: s value"); - is($res, 4, "$desc: res value"); - is($one, 'd', "$desc: \$1 value"); - - $desc = "use re 'taint': substitution /r with string tainted"; - - $s = 'abcd' . $TAINT; - $res = $s =~ s/(.+)/xyz/r; - $one = $1; - is_tainted($s, "$desc: s tainted"); - is_tainted($res, "$desc: res tainted"); - is_tainted($one, "$desc: \$1 tainted"); - is($s, 'abcd', "$desc: s value"); - is($res, 'xyz', "$desc: res value"); - is($one, 'abcd', "$desc: \$1 value"); - - $desc = "use re 'taint': substitution /e with string tainted"; - - $s = 'abcd' . $TAINT; - $one = ''; - $res = $s =~ s{(.+)}{ - $one = $one . "x"; # make sure code not tainted - isnt_tainted($one, "$desc: code not tainted within /e"); - $one = $1; - is_tainted($one, "$desc: $1 tainted within /e"); - "xyz"; - }e; - $one = $1; - is_tainted($s, "$desc: s tainted"); - isnt_tainted($res, "$desc: res not tainted"); - is_tainted($one, "$desc: \$1 tainted"); - is($s, 'xyz', "$desc: s value"); - is($res, 1, "$desc: res value"); - is($one, 'abcd', "$desc: \$1 value"); - - $desc = "use re 'taint': substitution with pattern tainted"; - - $s = 'abcd'; - $res = $s =~ s/$TAINT(.+)/xyz/; - $one = $1; - is_tainted($s, "$desc: s tainted"); - isnt_tainted($res, "$desc: res not tainted"); - is_tainted($one, "$desc: \$1 tainted"); - is($s, 'xyz', "$desc: s value"); - is($res, 1, "$desc: res value"); - is($one, 'abcd', "$desc: \$1 value"); - - $desc = "use re 'taint': substitution /g with pattern tainted"; - - $s = 'abcd'; - $res = $s =~ s/$TAINT(.)/x/g; - $one = $1; - is_tainted($s, "$desc: s tainted"); - is_tainted($res, "$desc: res tainted"); - is_tainted($one, "$desc: \$1 tainted"); - is($s, 'xxxx', "$desc: s value"); - is($res, 4, "$desc: res value"); - is($one, 'd', "$desc: \$1 value"); - - $desc = "use re 'taint': substitution /ge with pattern tainted"; - - $s = 'abc'; - { - my $i = 0; - my $j; - $res = $s =~ s{(.)$TAINT}{ - $j = $i; # make sure code not tainted - $one = $1; - isnt_tainted($j, "$desc: code not tainted within /e"); - $i++; - if ($i == 1) { - isnt_tainted($s, "$desc: s not tainted loop 1"); - } - else { - is_tainted($s, "$desc: s tainted loop $i"); - } - is_tainted($one, "$desc: \$1 tainted loop $i"); - $i.$TAINT; - }ge; - $one = $1; - } - is_tainted($s, "$desc: s tainted"); - is_tainted($res, "$desc: res tainted"); - is_tainted($one, "$desc: \$1 tainted"); - is($s, '123', "$desc: s value"); - is($res, 3, "$desc: res value"); - is($one, 'c', "$desc: \$1 value"); - - - $desc = "use re 'taint': substitution /r with pattern tainted"; - - $s = 'abcd'; - $res = $s =~ s/$TAINT(.+)/xyz/r; - $one = $1; - isnt_tainted($s, "$desc: s not tainted"); - is_tainted($res, "$desc: res tainted"); - is_tainted($one, "$desc: \$1 tainted"); - is($s, 'abcd', "$desc: s value"); - is($res, 'xyz', "$desc: res value"); - is($one, 'abcd', "$desc: \$1 value"); - - $desc = "use re 'taint': substitution with pattern tainted via locale"; - - $s = 'abcd'; - { use locale; $res = $s =~ s/(\w+)/xyz/; $one = $1; } - is_tainted($s, "$desc: s tainted"); - isnt_tainted($res, "$desc: res not tainted"); - is_tainted($one, "$desc: \$1 tainted"); - is($s, 'xyz', "$desc: s value"); - is($res, 1, "$desc: res value"); - is($one, 'abcd', "$desc: \$1 value"); - - $desc = "use re 'taint': substitution /g with pattern tainted via locale"; - - $s = 'abcd'; - { use locale; $res = $s =~ s/(\w)/x/g; $one = $1; } - is_tainted($s, "$desc: s tainted"); - is_tainted($res, "$desc: res tainted"); - is_tainted($one, "$desc: \$1 tainted"); - is($s, 'xxxx', "$desc: s value"); - is($res, 4, "$desc: res value"); - is($one, 'd', "$desc: \$1 value"); - - $desc = "use re 'taint': substitution /r with pattern tainted via locale"; - - $s = 'abcd'; - { use locale; $res = $s =~ s/(\w+)/xyz/r; $one = $1; } - isnt_tainted($s, "$desc: s not tainted"); - is_tainted($res, "$desc: res tainted"); - is_tainted($one, "$desc: \$1 tainted"); - is($s, 'abcd', "$desc: s value"); - is($res, 'xyz', "$desc: res value"); - is($one, 'abcd', "$desc: \$1 value"); - - $desc = "use re 'taint': substitution with replacement tainted"; - - $s = 'abcd'; - $res = $s =~ s/(.+)/xyz$TAINT/; - $one = $1; - is_tainted($s, "$desc: s tainted"); - isnt_tainted($res, "$desc: res not tainted"); - isnt_tainted($one, "$desc: \$1 not tainted"); - is($s, 'xyz', "$desc: s value"); - is($res, 1, "$desc: res value"); - is($one, 'abcd', "$desc: \$1 value"); - - $desc = "use re 'taint': substitution /g with replacement tainted"; - - $s = 'abcd'; - $res = $s =~ s/(.)/x$TAINT/g; - $one = $1; - is_tainted($s, "$desc: s tainted"); - isnt_tainted($res, "$desc: res not tainted"); - isnt_tainted($one, "$desc: \$1 not tainted"); - is($s, 'xxxx', "$desc: s value"); - is($res, 4, "$desc: res value"); - is($one, 'd', "$desc: \$1 value"); - - $desc = "use re 'taint': substitution /ge with replacement tainted"; - - $s = 'abc'; - { - my $i = 0; - my $j; - $res = $s =~ s{(.)}{ - $j = $i; # make sure code not tainted - $one = $1; - isnt_tainted($j, "$desc: code not tainted within /e"); - $i++; - if ($i == 1) { - isnt_tainted($s, "$desc: s not tainted loop 1"); - } - else { - is_tainted($s, "$desc: s tainted loop $i"); - } - isnt_tainted($one, "$desc: \$1 not tainted"); - $i.$TAINT; - }ge; - $one = $1; - } - is_tainted($s, "$desc: s tainted"); - is_tainted($res, "$desc: res tainted"); - isnt_tainted($one, "$desc: \$1 not tainted"); - is($s, '123', "$desc: s value"); - is($res, 3, "$desc: res value"); - is($one, 'c', "$desc: \$1 value"); - - $desc = "use re 'taint': substitution /r with replacement tainted"; - - $s = 'abcd'; - $res = $s =~ s/(.+)/xyz$TAINT/r; - $one = $1; - isnt_tainted($s, "$desc: s not tainted"); - is_tainted($res, "$desc: res tainted"); - isnt_tainted($one, "$desc: \$1 not tainted"); - is($s, 'abcd', "$desc: s value"); - is($res, 'xyz', "$desc: res value"); - is($one, 'abcd', "$desc: \$1 value"); - } - - $foo = $1 if 'bar' =~ /(.+)$TAINT/; - is_tainted($foo); - is($foo, 'bar'); - - my $pi = 4 * atan2(1,1) + $TAINT0; - is_tainted($pi); - - ($pi) = $pi =~ /(\d+\.\d+)/; - isnt_tainted($pi); - is(sprintf("%.5f", $pi), '3.14159'); -} - -# How about command-line arguments? The problem is that we don't -# always get some, so we'll run another process with some. -SKIP: { - my $arg = tempfile(); - open $fh, '>', $arg or die "Can't create $arg: $!"; - print $fh q{ - eval { join('', @ARGV), kill 0 }; - exit 0 if $@ =~ /^Insecure dependency/; - print "# Oops: \$@ was [$@]\n"; - exit 1; - }; - close $fh or die "Can't close $arg: $!"; - print `$Invoke_Perl "-T" $arg and some suspect arguments`; - is($?, 0, "Exited with status $?"); - unlink $arg; -} - -# Reading from a file should be tainted -{ - ok(open my $fh, '<', $TEST) or diag("Couldn't open '$TEST': $!"); - - my $block; - sysread($fh, $block, 100); - my $line = <$fh>; - close $fh; - is_tainted($block); - is_tainted($line); -} - -# Output of commands should be tainted -{ - my $foo = `$echo abc`; - is_tainted($foo); -} - -# Certain system variables should be tainted -{ - is_tainted($^X); - is_tainted($0); -} - -# Results of matching should all be untainted -{ - my $foo = "abcdefghi" . $TAINT; - is_tainted($foo); - - $foo =~ /def/; - isnt_tainted($`); - isnt_tainted($&); - isnt_tainted($'); - - $foo =~ /(...)(...)(...)/; - isnt_tainted($1); - isnt_tainted($2); - isnt_tainted($3); - isnt_tainted($+); - - my @bar = $foo =~ /(...)(...)(...)/; - isnt_tainted($_) foreach @bar; - - is_tainted($foo); # $foo should still be tainted! - is($foo, "abcdefghi"); -} - -# Operations which affect files can't use tainted data. -{ - violates_taint(sub { chmod 0, $TAINT }, 'chmod'); - - SKIP: { - skip "truncate() is not available", 2 unless $Config{d_truncate}; - - violates_taint(sub { truncate 'NoSuChFiLe', $TAINT0 }, 'truncate'); - } - - violates_taint(sub { rename '', $TAINT }, 'rename'); - violates_taint(sub { unlink $TAINT }, 'unlink'); - violates_taint(sub { utime $TAINT }, 'utime'); - - SKIP: { - skip "chown() is not available", 2 unless $Config{d_chown}; - - violates_taint(sub { chown -1, -1, $TAINT }, 'chown'); - } - - SKIP: { - skip "link() is not available", 2 unless $Config{d_link}; - -violates_taint(sub { link $TAINT, '' }, 'link'); - } - - SKIP: { - skip "symlink() is not available", 2 unless $Config{d_symlink}; - - violates_taint(sub { symlink $TAINT, '' }, 'symlink'); - } -} - -# Operations which affect directories can't use tainted data. -{ - violates_taint(sub { mkdir "foo".$TAINT, 0755 . $TAINT0 }, 'mkdir'); - violates_taint(sub { rmdir $TAINT }, 'rmdir'); - violates_taint(sub { chdir "foo".$TAINT }, 'chdir'); - - SKIP: { - skip "chroot() is not available", 2 unless $Config{d_chroot}; - - violates_taint(sub { chroot $TAINT }, 'chroot'); - } -} - -# Some operations using files can't use tainted data. -{ - my $foo = "imaginary library" . $TAINT; - violates_taint(sub { require $foo }, 'require'); - - my $filename = tempfile(); # NB: $filename isn't tainted! - $foo = $filename . $TAINT; - unlink $filename; # in any case - - is(eval { open FOO, $foo }, undef, 'open for read'); - is($@, ''); # NB: This should be allowed - is(eval { open my $fh, , '<', $foo }, undef, 'open for read'); - is($@, ''); # NB: This should be allowed - - # Try first new style but allow also old style. - # We do not want the whole taint.t to fail - # just because Errno possibly failing. - ok(eval('$!{ENOENT}') || - $! == 2 || # File not found - ($Is_Dos && $! == 22)); - - violates_taint(sub { open FOO, "> $foo" }, 'open', 'open for write'); - violates_taint(sub { open my $fh, '>', $foo }, 'open', 'open for write'); -} - -# Commands to the system can't use tainted data -{ - my $foo = $TAINT; - - SKIP: { - skip "open('|') is not available", 8 if $^O eq 'amigaos'; - - violates_taint(sub { open FOO, "| x$foo" }, 'piped open', 'popen to'); - violates_taint(sub { open FOO, "x$foo |" }, 'piped open', 'popen from'); - violates_taint(sub { open my $fh, '|-', "x$foo" }, 'piped open', 'popen to'); - violates_taint(sub { open my $fh, '-|', "x$foo" }, 'piped open', 'popen from'); - } - - violates_taint(sub { exec $TAINT }, 'exec'); - violates_taint(sub { system $TAINT }, 'system'); - - $foo = "*"; - taint_these $foo; - - violates_taint(sub { `$echo 1$foo` }, '``', 'backticks'); - - SKIP: { - # wildcard expansion doesn't invoke shell on VMS, so is safe - skip "This is not VMS", 2 unless $Is_VMS; - - isnt(join('', eval { glob $foo } ), '', 'globbing'); - is($@, ''); - } -} - -# Operations which affect processes can't use tainted data. -{ - violates_taint(sub { kill 0, $TAINT }, 'kill'); - - SKIP: { - skip "setpgrp() is not available", 2 unless $Config{d_setpgrp}; - - violates_taint(sub { setpgrp 0, $TAINT0 }, 'setpgrp'); - } - - SKIP: { - skip "setpriority() is not available", 2 unless $Config{d_setprior}; - - violates_taint(sub { setpriority 0, $TAINT0, $TAINT0 }, 'setpriority'); - } -} - -# Some miscellaneous operations can't use tainted data. -{ - SKIP: { - skip "syscall() is not available", 2 unless $Config{d_syscall}; - - violates_taint(sub { syscall $TAINT }, 'syscall'); - } - - { - my $foo = "x" x 979; - taint_these $foo; - local *FOO; - my $temp = tempfile(); - ok(open FOO, "> $temp") or diag("Couldn't open $temp for write: $!"); - violates_taint(sub { ioctl FOO, $TAINT0, $foo }, 'ioctl'); - - my $temp2 = tempfile(); - ok(open my $fh, '>', $temp2) or diag("Couldn't open $temp2 for write: $!"); - violates_taint(sub { ioctl $fh, $TAINT0, $foo }, 'ioctl'); - - SKIP: { - skip "fcntl() is not available", 4 unless $Config{d_fcntl}; - - violates_taint(sub { fcntl FOO, $TAINT0, $foo }, 'fcntl'); - violates_taint(sub { fcntl $fh, $TAINT0, $foo }, 'fcntl'); - } - - close FOO; - } -} - -# Some tests involving references -{ - my $foo = 'abc' . $TAINT; - my $fooref = \$foo; - isnt_tainted($fooref); - is_tainted($$fooref); - is_tainted($foo); -} - -# Some tests involving assignment -{ - my $foo = $TAINT0; - my $bar = $foo; - is_tainted($foo); - is_tainted($bar); - is_tainted($foo = $bar); - is_tainted($bar = $bar); - is_tainted($bar += $bar); - is_tainted($bar -= $bar); - is_tainted($bar *= $bar); - is_tainted($bar++); - is_tainted($bar /= $bar); - is_tainted($bar += 0); - is_tainted($bar -= 2); - is_tainted($bar *= -1); - is_tainted($bar /= 1); - is_tainted($bar--); - is($bar, 0); -} - -# Test assignment and return of lists -{ - my @foo = ("A", "tainted" . $TAINT, "B"); - isnt_tainted($foo[0]); - is_tainted( $foo[1]); - isnt_tainted($foo[2]); - my @bar = @foo; - isnt_tainted($bar[0]); - is_tainted( $bar[1]); - isnt_tainted($bar[2]); - my @baz = eval { "A", "tainted" . $TAINT, "B" }; - isnt_tainted($baz[0]); - is_tainted( $baz[1]); - isnt_tainted($baz[2]); - my @plugh = eval q[ "A", "tainted" . $TAINT, "B" ]; - isnt_tainted($plugh[0]); - is_tainted( $plugh[1]); - isnt_tainted($plugh[2]); - my $nautilus = sub { "A", "tainted" . $TAINT, "B" }; - isnt_tainted(((&$nautilus)[0])); - is_tainted( ((&$nautilus)[1])); - isnt_tainted(((&$nautilus)[2])); - my @xyzzy = &$nautilus; - isnt_tainted($xyzzy[0]); - is_tainted( $xyzzy[1]); - isnt_tainted($xyzzy[2]); - my $red_october = sub { return "A", "tainted" . $TAINT, "B" }; - isnt_tainted(((&$red_october)[0])); - is_tainted( ((&$red_october)[1])); - isnt_tainted(((&$red_october)[2])); - my @corge = &$red_october; - isnt_tainted($corge[0]); - is_tainted( $corge[1]); - isnt_tainted($corge[2]); -} - -# Test for system/library calls returning string data of dubious origin. -{ - # No reliable %Config check for getpw* - SKIP: { - skip "getpwent() is not available", 9 unless - eval { setpwent(); getpwent() }; - - setpwent(); - my @getpwent = getpwent(); - die "getpwent: $!\n" unless (@getpwent); - isnt_tainted($getpwent[0]); - is_tainted($getpwent[1]); - isnt_tainted($getpwent[2]); - isnt_tainted($getpwent[3]); - isnt_tainted($getpwent[4]); - isnt_tainted($getpwent[5]); - is_tainted($getpwent[6], 'ge?cos'); - isnt_tainted($getpwent[7]); - is_tainted($getpwent[8], 'shell'); - endpwent(); - } - - SKIP: { - # pretty hard to imagine not - skip "readdir() is not available", 1 unless $Config{d_readdir}; - - opendir my $dh, "op" or die "opendir op/: $!"; - my $readdir = readdir $dh; - is_tainted($readdir); - closedir $dh; - } - - SKIP: { - skip "readlink() or symlink() is not available" unless - $Config{d_readlink} && $Config{d_symlink}; - - my $symlink = "sl$$"; - unlink($symlink); - my $sl = "/something/naughty"; - # it has to be a real path on Mac OS - symlink($sl, $symlink) or die "symlink: $!\n"; - my $readlink = readlink($symlink); - is_tainted($readlink); - unlink($symlink); - } -} - -# test bitwise ops (regression bug) -{ - my $why = "y"; - my $j = "x" | $why; - isnt_tainted($j); - $why = $TAINT."y"; - $j = "x" | $why; - is_tainted( $j); -} - -# test target of substitution (regression bug) -{ - my $why = $TAINT."y"; - $why =~ s/y/z/; - is_tainted( $why); - - my $z = "[z]"; - $why =~ s/$z/zee/; - is_tainted( $why); - - $why =~ s/e/'-'.$$/ge; - is_tainted( $why); -} - - -SKIP: { - skip "no IPC::SysV", 2 unless $ipcsysv; - - # test shmread - SKIP: { - skip "shm*() not available", 1 unless $Config{d_shm}; - - no strict 'subs'; - my $sent = "foobar"; - my $rcvd; - my $size = 2000; - my $id = shmget(IPC_PRIVATE, $size, S_IRWXU); - - if (defined $id) { - if (shmwrite($id, $sent, 0, 60)) { - if (shmread($id, $rcvd, 0, 60)) { - substr($rcvd, index($rcvd, "\0")) = ''; - } else { - warn "# shmread failed: $!\n"; - } - } else { - warn "# shmwrite failed: $!\n"; - } - shmctl($id, IPC_RMID, 0) or warn "# shmctl failed: $!\n"; - } else { - warn "# shmget failed: $!\n"; - } - - skip "SysV shared memory operation failed", 1 unless - $rcvd eq $sent; - - is_tainted($rcvd); - } - - - # test msgrcv - SKIP: { - skip "msg*() not available", 1 unless $Config{d_msg}; - - no strict 'subs'; - my $id = msgget(IPC_PRIVATE, IPC_CREAT | S_IRWXU); - - my $sent = "message"; - my $type_sent = 1234; - my $rcvd; - my $type_rcvd; - - if (defined $id) { - if (msgsnd($id, pack("l! a*", $type_sent, $sent), IPC_NOWAIT)) { - if (msgrcv($id, $rcvd, 60, 0, IPC_NOWAIT)) { - ($type_rcvd, $rcvd) = unpack("l! a*", $rcvd); - } else { - warn "# msgrcv failed: $!\n"; - } - } else { - warn "# msgsnd failed: $!\n"; - } - msgctl($id, IPC_RMID, 0) or warn "# msgctl failed: $!\n"; - } else { - warn "# msgget failed\n"; - } - - SKIP: { - skip "SysV message queue operation failed", 1 - unless $rcvd eq $sent && $type_sent == $type_rcvd; - - is_tainted($rcvd); - } - } -} - -{ - # bug id 20001004.006 - - open my $fh, '<', $TEST or warn "$0: cannot read $TEST: $!" ; - local $/; - my $a = <$fh>; - my $b = <$fh>; - - is_tainted($a); - is_tainted($b); - is($b, undef); -} - -{ - # bug id 20001004.007 - - open my $fh, '<', $TEST or warn "$0: cannot read $TEST: $!" ; - my $a = <$fh>; - - my $c = { a => 42, - b => $a }; - - isnt_tainted($c->{a}); - is_tainted($c->{b}); - - - my $d = { a => $a, - b => 42 }; - is_tainted($d->{a}); - isnt_tainted($d->{b}); - - - my $e = { a => 42, - b => { c => $a, d => 42 } }; - isnt_tainted($e->{a}); - isnt_tainted($e->{b}); - is_tainted($e->{b}->{c}); - isnt_tainted($e->{b}->{d}); -} - -{ - # bug id 20010519.003 - - BEGIN { - use vars qw($has_fcntl); - eval { require Fcntl; import Fcntl; }; - unless ($@) { - $has_fcntl = 1; - } - } - - SKIP: { - skip "no Fcntl", 18 unless $has_fcntl; - - my $foo = tempfile(); - my $evil = $foo . $TAINT; - - is(eval { sysopen(my $ro, $evil, &O_RDONLY) }, undef); - is($@, ''); - - violates_taint(sub { sysopen(my $wo, $evil, &O_WRONLY) }, 'sysopen'); - violates_taint(sub { sysopen(my $rw, $evil, &O_RDWR) }, 'sysopen'); - violates_taint(sub { sysopen(my $ap, $evil, &O_APPEND) }, 'sysopen'); - violates_taint(sub { sysopen(my $cr, $evil, &O_CREAT) }, 'sysopen'); - violates_taint(sub { sysopen(my $tr, $evil, &O_TRUNC) }, 'sysopen'); - - is(eval { sysopen(my $ro, $foo, &O_RDONLY | $TAINT0) }, undef); - is($@, ''); - - violates_taint(sub { sysopen(my $wo, $foo, &O_WRONLY | $TAINT0) }, 'sysopen'); - violates_taint(sub { sysopen(my $rw, $foo, &O_RDWR | $TAINT0) }, 'sysopen'); - violates_taint(sub { sysopen(my $ap, $foo, &O_APPEND | $TAINT0) }, 'sysopen'); - violates_taint(sub { sysopen(my $cr, $foo, &O_CREAT | $TAINT0) }, 'sysopen'); - violates_taint(sub { sysopen(my $tr, $foo, &O_TRUNC | $TAINT0) }, 'sysopen'); - is(eval { sysopen(my $ro, $foo, &O_RDONLY, $TAINT0) }, undef); - is($@, ''); - - violates_taint(sub { sysopen(my $wo, $foo, &O_WRONLY, $TAINT0) }, 'sysopen'); - violates_taint(sub { sysopen(my $rw, $foo, &O_RDWR, $TAINT0) }, 'sysopen'); - violates_taint(sub { sysopen(my $ap, $foo, &O_APPEND, $TAINT0) }, 'sysopen'); - violates_taint(sub { sysopen(my $cr, $foo, &O_CREAT, $TAINT0) }, 'sysopen'); - violates_taint(sub { sysopen(my $tr, $foo, &O_TRUNC, $TAINT0) }, 'sysopen'); - } -} - -{ - # bug 20010526.004 - - use warnings; - - my $saw_warning = 0; - local $SIG{__WARN__} = sub { ++$saw_warning }; - - sub fmi { - my $divnum = shift()/1; - sprintf("%1.1f\n", $divnum); - } - - fmi(21 . $TAINT); - fmi(37); - fmi(248); - - is($saw_warning, 0); -} - - -{ - # Bug ID 20010730.010 - - my $i = 0; - - sub Tie::TIESCALAR { - my $class = shift; - my $arg = shift; - - bless \$arg => $class; - } - - sub Tie::FETCH { - $i ++; - ${$_ [0]} - } - - - package main; - - my $bar = "The Big Bright Green Pleasure Machine"; - taint_these $bar; - tie my ($foo), Tie => $bar; - - my $baz = $foo; - - ok $i == 1; -} - -{ - # Check that all environment variables are tainted. - my @untainted; - while (my ($k, $v) = each %ENV) { - if (!tainted($v) && - # These we have explicitly untainted or set earlier. - $k !~ /^(BASH_ENV|CDPATH|ENV|IFS|PATH|PERL_CORE|TEMP|TERM|TMP)$/) { - push @untainted, "# '$k' = '$v'\n"; - } - } - is("@untainted", ""); -} - - -is(${^TAINT}, 1, '$^TAINT is on'); - -eval { ${^TAINT} = 0 }; -is(${^TAINT}, 1, '$^TAINT is not assignable'); -like($@, qr/^Modification of a read-only value attempted/, - 'Assigning to ${^TAINT} fails'); - -{ - # bug 20011111.105 - - my $re1 = qr/x$TAINT/; - is_tainted($re1); - - my $re2 = qr/^$re1\z/; - is_tainted($re2); - - my $re3 = "$re2"; - is_tainted($re3); -} - -SKIP: { - skip "system {} has different semantics on Win32", 1 if $Is_MSWin32; - - # bug 20010221.005 - local $ENV{PATH} .= $TAINT; - eval { system { "echo" } "/arg0", "arg1" }; - like($@, qr/^Insecure \$ENV/); -} - -TODO: { - todo_skip 'tainted %ENV warning occludes tainted arguments warning', 22 - if $Is_VMS; - - # bug 20020208.005 plus some single arg exec/system extras - violates_taint(sub { exec $TAINT, $TAINT }, 'exec'); - violates_taint(sub { exec $TAINT $TAINT }, 'exec'); - violates_taint(sub { exec $TAINT $TAINT, $TAINT }, 'exec'); - violates_taint(sub { exec $TAINT 'notaint' }, 'exec'); - violates_taint(sub { exec {'notaint'} $TAINT }, 'exec'); - - violates_taint(sub { system $TAINT, $TAINT }, 'system'); - violates_taint(sub { system $TAINT $TAINT }, 'system'); - violates_taint(sub { system $TAINT $TAINT, $TAINT }, 'system'); - violates_taint(sub { system $TAINT 'notaint' }, 'system'); - violates_taint(sub { system {'notaint'} $TAINT }, 'system'); - - eval { - no warnings; - system("lskdfj does not exist","with","args"); - }; - is($@, ""); - - eval { - no warnings; - exec("lskdfj does not exist","with","args"); - }; - is($@, ""); - - # If you add tests here update also the above skip block for VMS. -} - -{ - # [ID 20020704.001] taint propagation failure - use re 'taint'; - $TAINT =~ /(.*)/; - is_tainted(my $foo = $1); -} - -{ - # [perl #24291] this used to dump core - our %nonmagicalenv = ( PATH => "util" ); - local *ENV = \%nonmagicalenv; - eval { system("lskdfj"); }; - like($@, qr/^%ENV is aliased to another variable while running with -T switch/); - local *ENV = *nonmagicalenv; - eval { system("lskdfj"); }; - like($@, qr/^%ENV is aliased to %nonmagicalenv while running with -T switch/); -} -{ - # [perl #24248] - $TAINT =~ /(.*)/; - isnt_tainted($1); - my $notaint = $1; - isnt_tainted($notaint); - - my $l; - $notaint =~ /($notaint)/; - $l = $1; - isnt_tainted($1); - isnt_tainted($l); - $notaint =~ /($TAINT)/; - $l = $1; - is_tainted($1); - is_tainted($l); - - $TAINT =~ /($notaint)/; - $l = $1; - isnt_tainted($1); - isnt_tainted($l); - $TAINT =~ /($TAINT)/; - $l = $1; - is_tainted($1); - is_tainted($l); - - my $r; - ($r = $TAINT) =~ /($notaint)/; - isnt_tainted($1); - ($r = $TAINT) =~ /($TAINT)/; - is_tainted($1); - - # [perl #24674] - # accessing $^O shoudn't taint it as a side-effect; - # assigning tainted data to it is now an error - - isnt_tainted($^O); - if (!$^X) { } elsif ($^O eq 'bar') { } - isnt_tainted($^O); - local $^O; # We're going to clobber something test infrastructure depends on. - eval '$^O = $^X'; - like($@, qr/Insecure dependency in/); -} - -EFFECTIVELY_CONSTANTS: { - my $tainted_number = 12 + $TAINT0; - is_tainted( $tainted_number ); - - # Even though it's always 0, it's still tainted - my $tainted_product = $tainted_number * 0; - is_tainted( $tainted_product ); - is($tainted_product, 0); -} - -TERNARY_CONDITIONALS: { - my $tainted_true = $TAINT . "blah blah blah"; - my $tainted_false = $TAINT0; - is_tainted( $tainted_true ); - is_tainted( $tainted_false ); - - my $result = $tainted_true ? "True" : "False"; - is($result, "True"); - isnt_tainted( $result ); - - $result = $tainted_false ? "True" : "False"; - is($result, "False"); - isnt_tainted( $result ); - - my $untainted_whatever = "The Fabulous Johnny Cash"; - my $tainted_whatever = "Soft Cell" . $TAINT; - - $result = $tainted_true ? $tainted_whatever : $untainted_whatever; - is($result, "Soft Cell"); - is_tainted( $result ); - - $result = $tainted_false ? $tainted_whatever : $untainted_whatever; - is($result, "The Fabulous Johnny Cash"); - isnt_tainted( $result ); -} - -{ - # rt.perl.org 5900 $1 remains tainted if... - # 1) The regular expression contains a scalar variable AND - # 2) The regular expression appears in an elsif clause - - my $foo = "abcdefghi" . $TAINT; - - my $valid_chars = 'a-z'; - if ( $foo eq '' ) { - } - elsif ( $foo =~ /([$valid_chars]+)/o ) { - isnt_tainted($1); - isnt($1, undef); - } - - if ( $foo eq '' ) { - } - elsif ( my @bar = $foo =~ /([$valid_chars]+)/o ) { - isnt_tainted($bar[0]); - is(scalar @bar, 1); - } -} - -# at scope exit, a restored localised value should have its old -# taint status, not the taint status of the current statement - -{ - our $x99 = $^X; - is_tainted($x99); - - $x99 = ''; - isnt_tainted($x99); - - my $c = do { local $x99; $^X }; - isnt_tainted($x99); -} -{ - our $x99 = $^X; - is_tainted($x99); - - my $c = do { local $x99; '' }; - is_tainted($x99); -} - -# an mg_get of a tainted value during localization shouldn't taint the -# statement - -{ - eval { local $0, eval '1' }; - is($@, ''); -} - -# [perl #8262] //g loops infinitely on tainted data - -{ - my @a; - $a[0] = $^X . '-'; - $a[0]=~ m/(.)/g; - cmp_ok pos($a[0]), '>', 0, "infinite m//g on arrays (aelemfast)"; - - my $i = 1; - $a[$i] = $^X . '-'; - $a[$i]=~ m/(.)/g; - cmp_ok pos($a[$i]), '>', 0, "infinite m//g on arrays (aelem)"; - - my %h; - $h{a} = $^X . '-'; - $h{a}=~ m/(.)/g; - cmp_ok pos($h{a}), '>', 0, "infinite m//g on hashes (helem)"; -} - -SKIP: -{ - my $got_dualvar; - eval 'use Scalar::Util "dualvar"; $got_dualvar++'; - skip "No Scalar::Util::dualvar" unless $got_dualvar; - my $a = Scalar::Util::dualvar(3, $^X); - my $b = $a + 5; - is ($b, 8, "Arithmetic on tainted dualvars works"); -} - -# opening '|-' should not trigger $ENV{PATH} check - -{ - SKIP: { - skip "fork() is not available", 3 unless $Config{'d_fork'}; - skip "opening |- is not stable on threaded Open/MirBSD with taint", 3 - if $Config{useithreads} and $Is_OpenBSD || $Is_MirBSD; - - $ENV{'PATH'} = $TAINT; - local $SIG{'PIPE'} = 'IGNORE'; - eval { - my $pid = open my $pipe, '|-'; - if (!defined $pid) { - die "open failed: $!"; - } - if (!$pid) { - kill 'KILL', $$; # child suicide - } - close $pipe; - }; - unlike($@, qr/Insecure \$ENV/, 'fork triggers %ENV check'); - is($@, '', 'pipe/fork/open/close failed'); - eval { - open my $pipe, "|$Invoke_Perl -e 1"; - close $pipe; - }; - like($@, qr/Insecure \$ENV/, 'popen neglects %ENV check'); - } -} - -{ - package AUTOLOAD_TAINT; - sub AUTOLOAD { - our $AUTOLOAD; - return if $AUTOLOAD =~ /DESTROY/; - if ($AUTOLOAD =~ /untainted/) { - main::isnt_tainted($AUTOLOAD, '$AUTOLOAD can be untainted'); - my $copy = $AUTOLOAD; - main::isnt_tainted($copy, '$AUTOLOAD can be untainted'); - } else { - main::is_tainted($AUTOLOAD, '$AUTOLOAD can be tainted'); - my $copy = $AUTOLOAD; - main::is_tainted($copy, '$AUTOLOAD can be tainted'); - } - } - - package main; - my $o = bless [], 'AUTOLOAD_TAINT'; - $o->untainted; - $o->$TAINT; - $o->untainted; -} - -{ - # tests for tainted format in s?printf - my $fmt = $TAINT . "# %s\n"; - violates_taint(sub { printf($fmt, "foo") }, 'printf', - q/printf doesn't like tainted formats/); - violates_taint(sub { printf($TAINT . "# %s\n", "foo") }, 'printf', - q/printf doesn't like tainted format expressions/); - eval { printf("# %s\n", $TAINT . "foo") }; - is($@, '', q/printf accepts other tainted args/); - violates_taint(sub { sprintf($fmt, "foo") }, 'sprintf', - q/sprintf doesn't like tainted formats/); - violates_taint(sub { sprintf($TAINT . "# %s\n", "foo") }, 'sprintf', - q/sprintf doesn't like tainted format expressions/); - eval { sprintf("# %s\n", $TAINT . "foo") }; - is($@, '', q/sprintf accepts other tainted args/); -} - -{ - # 40708 - my $n = 7e9; - 8e9 - $n; - - my $val = $n; - is ($val, '7000000000', 'Assignment to untainted variable'); - $val = $TAINT; - $val = $n; - is ($val, '7000000000', 'Assignment to tainted variable'); -} - -{ - my $val = 0; - my $tainted = '1' . $TAINT; - eval '$val = eval $tainted;'; - is ($val, 0, "eval doesn't like tainted strings"); - like ($@, qr/^Insecure dependency in eval/); - - # Rather nice code to get a tainted undef by from Rick Delaney - open my $fh, 't/CORE/test.pl' or die $!; - seek $fh, 0, 2 or die $!; - $tainted = <$fh>; - - eval 'eval $tainted'; - like ($@, qr/^Insecure dependency in eval/); -} - -foreach my $ord (78, 163, 256) { - # 47195 - my $line = 'A1' . $TAINT . chr $ord; - chop $line; - is($line, 'A1'); - $line =~ /(A\S*)/; - isnt_tainted($1, "\\S match with chr $ord"); -} - -{ - # 59998 - sub cr { my $x = crypt($_[0], $_[1]); $x } - sub co { my $x = ~$_[0]; $x } - my ($a, $b); - $a = cr('hello', 'foo' . $TAINT); - $b = cr('hello', 'foo'); - is_tainted($a, "tainted crypt"); - isnt_tainted($b, "untainted crypt"); - $a = co('foo' . $TAINT); - $b = co('foo'); - is_tainted($a, "tainted complement"); - isnt_tainted($b, "untainted complement"); -} - -{ - my @data = qw(bonk zam zlonk qunckkk); - # Clearly some sort of usenet bang-path - my $string = $TAINT . join "!", @data; - - is_tainted($string, "tainted data"); - - my @got = split /!|,/, $string; - - # each @got would be useful here, but I want the test for earlier perls - for my $i (0 .. $#data) { - is_tainted($got[$i], "tainted result $i"); - is($got[$i], $data[$i], "correct content $i"); - } - - is_tainted($string, "still tainted data"); - - my @got = split /[!,]/, $string; - - # each @got would be useful here, but I want the test for earlier perls - for my $i (0 .. $#data) { - is_tainted($got[$i], "tainted result $i"); - is($got[$i], $data[$i], "correct content $i"); - } - - is_tainted($string, "still tainted data"); - - my @got = split /!/, $string; - - # each @got would be useful here, but I want the test for earlier perls - for my $i (0 .. $#data) { - is_tainted($got[$i], "tainted result $i"); - is($got[$i], $data[$i], "correct content $i"); - } -} - -# Bug RT #52552 - broken by change at git commit id f337b08 -{ - my $x = $TAINT. q{print "Hello world\n"}; - my $y = pack "a*", $x; - is_tainted($y, "pack a* preserves tainting"); - - my $z = pack "A*", q{print "Hello world\n"}.$TAINT; - is_tainted($z, "pack A* preserves tainting"); - - my $zz = pack "a*a*", q{print "Hello world\n"}, $TAINT; - is_tainted($zz, "pack a*a* preserves tainting"); -} - -# Bug RT #61976 tainted $! would show numeric rather than string value - -{ - my $tainted_path = substr($^X,0,0) . "/no/such/file"; - my $err; - # $! is used in a tainted expression, so gets tainted - open my $fh, $tainted_path or $err= "$!"; - unlike($err, qr/^\d+$/, 'tainted $!'); -} - -{ - # #6758: tainted values become untainted in tied hashes - # (also applies to other value magic such as pos) - - - package P6758; - - sub TIEHASH { bless {} } - sub TIEARRAY { bless {} } - - my $i = 0; - - sub STORE { - main::is_tainted($_[1], "tied arg1 tainted"); - main::is_tainted($_[2], "tied arg2 tainted"); - $i++; - } - - package main; - - my ($k,$v) = qw(1111 val); - taint_these($k,$v); - tie my @array, 'P6758'; - tie my %hash , 'P6758'; - $array[$k] = $v; - $hash{$k} = $v; - ok $i == 2, "tied STORE called correct number of times"; -} - -# Bug RT #45167 the return value of sprintf sometimes wasn't tainted -# when the args were tainted. This only occured on the first use of -# sprintf; after that, its TARG has taint magic attached, so setmagic -# at the end works. That's why there are multiple sprintf's below, rather -# than just one wrapped in an inner loop. Also, any plaintext between -# fprmat entires would correctly cause tainting to get set. so test with -# "%s%s" rather than eg "%s %s". - -{ - for my $var1 ($TAINT, "123") { - for my $var2 ($TAINT0, "456") { - is( tainted(sprintf '%s', $var1, $var2), tainted($var1), - "sprintf '%s', '$var1', '$var2'" ); - is( tainted(sprintf ' %s', $var1, $var2), tainted($var1), - "sprintf ' %s', '$var1', '$var2'" ); - is( tainted(sprintf '%s%s', $var1, $var2), - tainted($var1) || tainted($var2), - "sprintf '%s%s', '$var1', '$var2'" ); - } - } -} - - -# Bug RT #67962: old tainted $1 gets treated as tainted -# in next untainted # match - -{ - use re 'taint'; - "abc".$TAINT =~ /(.*)/; # make $1 tainted - is_tainted($1, '$1 should be tainted'); - - my $untainted = "abcdef"; - isnt_tainted($untainted, '$untainted should be untainted'); - $untainted =~ s/(abc)/$1/; - isnt_tainted($untainted, '$untainted should still be untainted'); - $untainted =~ s/(abc)/x$1/; - isnt_tainted($untainted, '$untainted should yet still be untainted'); -} - -{ - # On Windows we can't spawn a fresh Perl interpreter unless at - # least the Windows system directory (usually C:\Windows\System32) - # is still on the PATH. There is however no way to determine the - # actual path on the current system without loading the Win32 - # module, so we just restore the original $ENV{PATH} here. - local $ENV{PATH} = $ENV{PATH}; - $ENV{PATH} = $old_env_path if $Is_MSWin32; - - fresh_perl_is(<<'end', "ok", { switches => [ '-T' ] }, - $TAINT = substr($^X, 0, 0); - formline('@'.('<'x("2000".$TAINT)).' | @*', 'hallo', 'welt'); - print "ok"; -end - "formline survives a tainted dynamic picture"); -} - -{ - isnt_tainted($^A, "format accumulator not tainted yet"); - formline('@ | @*', 'hallo' . $TAINT, 'welt'); - is_tainted($^A, "tainted formline argument makes a tainted accumulator"); - $^A = ""; - isnt_tainted($^A, "accumulator can be explicitly untainted"); - formline('@' .('<'*5) . ' | @*', 'hallo', 'welt'); - isnt_tainted($^A, "accumulator still untainted"); - $^A = "" . $TAINT; - is_tainted($^A, "accumulator can be explicitly tainted"); - formline('@' .('<'*5) . ' | @*', 'hallo', 'welt'); - is_tainted($^A, "accumulator still tainted"); - $^A = ""; - isnt_tainted($^A, "accumulator untainted again"); - formline('@' .('<'*5) . ' | @*', 'hallo', 'welt'); - isnt_tainted($^A, "accumulator still untainted"); - formline('@' .('<'*(5+$TAINT0)) . ' | @*', 'hallo', 'welt'); - TODO: { - local $::TODO = "get magic handled too late?"; - is_tainted($^A, "the accumulator should be tainted already"); - } - is_tainted($^A, "tainted formline picture makes a tainted accumulator"); -} - -{ # Bug #80610 - "Constant(1)" =~ / ^ ([a-z_]\w*) (?: [(] (.*) [)] )? $ /xi; - my $a = $1; - my $b = $2; - isnt_tainted($a, "regex optimization of single char /[]/i doesn't taint"); - isnt_tainted($b, "regex optimization of single char /[]/i doesn't taint"); -} - -{ - # RT 81230: tainted value during FETCH created extra ref to tied obj - - package P81230; - use warnings; - - my %h; - - sub TIEHASH { - my $x = $^X; # tainted - bless \$x; - } - sub FETCH { my $x = $_[0]; $$x . "" } - - tie %h, 'P81230'; - - my $w = ""; - local $SIG{__WARN__} = sub { $w .= "@_" }; - - untie %h if $h{"k"}; - - ::is($w, "", "RT 81230"); -} - -{ - # Compiling a subroutine inside a tainted expression does not make the - # constant folded values tainted. - my $x = sub { "x" . "y" }; - my $y = $ENV{PATH} . $x->(); # Compile $x inside a tainted expression - my $z = $x->(); - isnt_tainted($z, "Constants folded value not tainted"); -} - -{ - # now that regexes are first class SVs, make sure that they themselves - # as well as references to them are tainted - - my $rr = qr/(.)$TAINT/; - my $r = $$rr; # bare REGEX - my $s ="abc"; - ok($s =~ s/$r/x/, "match bare regex"); - is_tainted($s, "match bare regex taint"); - is($s, 'xbc', "match bare regex taint value"); -} - -{ - # [perl #82616] security Issues with user-defined \p{} properties - # A using a tainted user-defined property should croak - - sub IsA { sprintf "%02x", ord("A") } - - my $prop = "IsA"; - ok("A" =~ /\p{$prop}/, "user-defined property: non-tainted case"); - $prop = "IsA$TAINT"; - eval { "A" =~ /\p{$prop}/}; - like($@, qr/Insecure user-defined property \\p{main::IsA}/, - "user-defined property: tainted case"); -} - -{ - # [perl #87336] lc/uc(first) failing to taint the returned string - my $source = "foo$TAINT"; - my $dest = lc $source; - is_tainted $dest, "lc(tainted) taints its return value"; - $dest = lcfirst $source; - is_tainted $dest, "lcfirst(tainted) taints its return value"; - $dest = uc $source; - is_tainted $dest, "uc(tainted) taints its return value"; - $dest = ucfirst $source; - is_tainted $dest, "ucfirst(tainted) taints its return value"; -} - - -# tainted constants and index() -# RT 64804; http://bugs.debian.org/291450 -{ - ok(tainted $old_env_path, "initial taintedness"); - BEGIN { no strict 'refs'; my $v = $old_env_path; *{"::C"} = sub () { $v }; } - ok(tainted C, "constant is tainted properly"); - ok(!tainted "", "tainting not broken yet"); - index(undef, C); - ok(!tainted "", "tainting still works after index() of the constant"); -} - -{ # 111654 - eval { - eval { die "Test\n".substr($ENV{PATH}, 0, 0); }; - die; - }; - like($@, qr/^Test\n\t\.\.\.propagated at /, "error should be propagated"); -} - -# This may bomb out with the alarm signal so keep it last -SKIP: { - skip "No alarm()" unless $Config{d_alarm}; - # Test from RT #41831] - # [PATCH] Bug & fix: hang when using study + taint mode (perl 5.6.1, 5.8.x) - - my $DATA = <<'END' . $TAINT; -line1 is here -line2 is here -line3 is here -line4 is here - -END - - #study $DATA; - - ## don't set $SIG{ALRM}, since we'd never get to a user-level handler as - ## perl is stuck in a regexp infinite loop! - - alarm(10); - - if ($DATA =~ /^line2.*line4/m) { - fail("Should not be a match") - } else { - pass("Match on tainted multiline data should fail promptly"); - } - - alarm(0); -} -__END__ -# Keep the previous test last diff --git a/t/CORE/op/tie.t b/t/CORE/op/tie.t deleted file mode 100644 index f24c45f24..000000000 --- a/t/CORE/op/tie.t +++ /dev/null @@ -1,1031 +0,0 @@ -#!./perl - -# Add new tests to the end with format: -# ######## -# -# # test description -# Test code -# EXPECT -# Warn or die msgs (if any) at - line 1234 -# - -unshift @INC, 't/CORE/lib'; -require 't/CORE/test.pl'; - -$|=1; - -run_multiple_progs('', \*DATA); - -done_testing(); - -__END__ - -# standard behaviour, without any extra references -use Tie::Hash ; -tie %h, Tie::StdHash; -untie %h; -EXPECT -######## - -# standard behaviour, without any extra references -use Tie::Hash ; -{package Tie::HashUntie; - use base 'Tie::StdHash'; - sub UNTIE - { - warn "Untied\n"; - } -} -tie %h, Tie::HashUntie; -untie %h; -EXPECT -Untied -######## - -# standard behaviour, with 1 extra reference -use Tie::Hash ; -$a = tie %h, Tie::StdHash; -untie %h; -EXPECT -######## - -# standard behaviour, with 1 extra reference via tied -use Tie::Hash ; -tie %h, Tie::StdHash; -$a = tied %h; -untie %h; -EXPECT -######## - -# standard behaviour, with 1 extra reference which is destroyed -use Tie::Hash ; -$a = tie %h, Tie::StdHash; -$a = 0 ; -untie %h; -EXPECT -######## - -# standard behaviour, with 1 extra reference via tied which is destroyed -use Tie::Hash ; -tie %h, Tie::StdHash; -$a = tied %h; -$a = 0 ; -untie %h; -EXPECT -######## - -# strict behaviour, without any extra references -use warnings 'untie'; -use Tie::Hash ; -tie %h, Tie::StdHash; -untie %h; -EXPECT -######## - -# strict behaviour, with 1 extra references generating an error -use warnings 'untie'; -use Tie::Hash ; -$a = tie %h, Tie::StdHash; -untie %h; -EXPECT -untie attempted while 1 inner references still exist at - line 6. -######## - -# strict behaviour, with 1 extra references via tied generating an error -use warnings 'untie'; -use Tie::Hash ; -tie %h, Tie::StdHash; -$a = tied %h; -untie %h; -EXPECT -untie attempted while 1 inner references still exist at - line 7. -######## - -# strict behaviour, with 1 extra references which are destroyed -use warnings 'untie'; -use Tie::Hash ; -$a = tie %h, Tie::StdHash; -$a = 0 ; -untie %h; -EXPECT -######## - -# strict behaviour, with extra 1 references via tied which are destroyed -use warnings 'untie'; -use Tie::Hash ; -tie %h, Tie::StdHash; -$a = tied %h; -$a = 0 ; -untie %h; -EXPECT -######## - -# strict error behaviour, with 2 extra references -use warnings 'untie'; -use Tie::Hash ; -$a = tie %h, Tie::StdHash; -$b = tied %h ; -untie %h; -EXPECT -untie attempted while 2 inner references still exist at - line 7. -######## - -# strict behaviour, check scope of strictness. -no warnings 'untie'; -use Tie::Hash ; -$A = tie %H, Tie::StdHash; -$C = $B = tied %H ; -{ - use warnings 'untie'; - use Tie::Hash ; - tie %h, Tie::StdHash; - untie %h; -} -untie %H; -EXPECT -######## - -# Forbidden aggregate self-ties -sub Self::TIEHASH { bless $_[1], $_[0] } -{ - my %c; - tie %c, 'Self', \%c; -} -EXPECT -Self-ties of arrays and hashes are not supported at - line 6. -######## - -# Allowed scalar self-ties -my $destroyed = 0; -sub Self::TIESCALAR { bless $_[1], $_[0] } -sub Self::DESTROY { $destroyed = 1; } -{ - my $c = 42; - tie $c, 'Self', \$c; -} -die "self-tied scalar not DESTROYed" unless $destroyed == 1; -EXPECT -######## - -# Allowed glob self-ties -my $destroyed = 0; -my $printed = 0; -sub Self2::TIEHANDLE { bless $_[1], $_[0] } -sub Self2::DESTROY { $destroyed = 1; } -sub Self2::PRINT { $printed = 1; } -{ - use Symbol; - my $c = gensym; - tie *$c, 'Self2', $c; - print $c 'Hello'; -} -die "self-tied glob not PRINTed" unless $printed == 1; -die "self-tied glob not DESTROYed" unless $destroyed == 1; -EXPECT -######## - -# Allowed IO self-ties -my $destroyed = 0; -sub Self3::TIEHANDLE { bless $_[1], $_[0] } -sub Self3::DESTROY { $destroyed = 1; } -sub Self3::PRINT { $printed = 1; } -{ - use Symbol 'geniosym'; - my $c = geniosym; - tie *$c, 'Self3', $c; - print $c 'Hello'; -} -die "self-tied IO not PRINTed" unless $printed == 1; -die "self-tied IO not DESTROYed" unless $destroyed == 1; -EXPECT -######## - -# TODO IO "self-tie" via TEMP glob -my $destroyed = 0; -sub Self3::TIEHANDLE { bless $_[1], $_[0] } -sub Self3::DESTROY { $destroyed = 1; } -sub Self3::PRINT { $printed = 1; } -{ - use Symbol 'geniosym'; - my $c = geniosym; - tie *$c, 'Self3', \*$c; - print $c 'Hello'; -} -die "IO tied to TEMP glob not PRINTed" unless $printed == 1; -die "IO tied to TEMP glob not DESTROYed" unless $destroyed == 1; -EXPECT -######## - -# Interaction of tie and vec - -my ($a, $b); -use Tie::Scalar; -tie $a,Tie::StdScalar or die; -vec($b,1,1)=1; -$a = $b; -vec($a,1,1)=0; -vec($b,1,1)=0; -die unless $a eq $b; -EXPECT -######## - -# correct unlocalisation of tied hashes (patch #16431) -use Tie::Hash ; -tie %tied, Tie::StdHash; -{ local $hash{'foo'} } warn "plain hash bad unlocalize" if exists $hash{'foo'}; -{ local $tied{'foo'} } warn "tied hash bad unlocalize" if exists $tied{'foo'}; -{ local $ENV{'foo'} } warn "%ENV bad unlocalize" if exists $ENV{'foo'}; -EXPECT -######## - -# An attempt at lvalueable barewords broke this -tie FH, 'main'; -EXPECT -Can't modify constant item in tie at - line 3, near "'main';" -Execution of - aborted due to compilation errors. -######## - -# localizing tied hash slices -$ENV{FooA} = 1; -$ENV{FooB} = 2; -print exists $ENV{FooA} ? 1 : 0, "\n"; -print exists $ENV{FooB} ? 2 : 0, "\n"; -print exists $ENV{FooC} ? 3 : 0, "\n"; -{ - local @ENV{qw(FooA FooC)}; - print exists $ENV{FooA} ? 4 : 0, "\n"; - print exists $ENV{FooB} ? 5 : 0, "\n"; - print exists $ENV{FooC} ? 6 : 0, "\n"; -} -print exists $ENV{FooA} ? 7 : 0, "\n"; -print exists $ENV{FooB} ? 8 : 0, "\n"; -print exists $ENV{FooC} ? 9 : 0, "\n"; # this should not exist -EXPECT -1 -2 -0 -4 -5 -6 -7 -8 -0 -######## -# -# FETCH freeing tie'd SV -sub TIESCALAR { bless [] } -sub FETCH { *a = \1; 1 } -tie $a, 'main'; -print $a; -EXPECT -######## - -# [20020716.007] - nested FETCHES - -sub F1::TIEARRAY { bless [], 'F1' } -sub F1::FETCH { 1 } -my @f1; -tie @f1, 'F1'; - -sub F2::TIEARRAY { bless [2], 'F2' } -sub F2::FETCH { my $self = shift; my $x = $f1[3]; $self } -my @f2; -tie @f2, 'F2'; - -print $f2[4][0],"\n"; - -sub F3::TIEHASH { bless [], 'F3' } -sub F3::FETCH { 1 } -my %f3; -tie %f3, 'F3'; - -sub F4::TIEHASH { bless [3], 'F4' } -sub F4::FETCH { my $self = shift; my $x = $f3{3}; $self } -my %f4; -tie %f4, 'F4'; - -print $f4{'foo'}[0],"\n"; - -EXPECT -2 -3 -######## -# test untie() from within FETCH -package Foo; -sub TIESCALAR { my $pkg = shift; return bless [@_], $pkg; } -sub FETCH { - my $self = shift; - my ($obj, $field) = @$self; - untie $obj->{$field}; - $obj->{$field} = "Bar"; -} -package main; -tie $a->{foo}, "Foo", $a, "foo"; -my $s = $a->{foo}; # access once -# the hash element should not be tied anymore -print defined tied $a->{foo} ? "not ok" : "ok"; -EXPECT -ok -######## -# the tmps returned by FETCH should appear to be SCALAR -# (even though they are now implemented using PVLVs.) -package X; -sub TIEHASH { bless {} } -sub TIEARRAY { bless {} } -sub FETCH {1} -my (%h, @a); -tie %h, 'X'; -tie @a, 'X'; -my $r1 = \$h{1}; -my $r2 = \$a[0]; -my $s = "$r1 ". ref($r1) . " $r2 " . ref($r2); -$s=~ s/\(0x\w+\)//g; -print $s, "\n"; -EXPECT -SCALAR SCALAR SCALAR SCALAR -######## -# [perl #23287] segfault in untie -sub TIESCALAR { bless $_[1], $_[0] } -my $var; -tie $var, 'main', \$var; -untie $var; -EXPECT -######## -# Test case from perlmonks by runrig -# http://www.perlmonks.org/index.pl?node_id=273490 -# "Here is what I tried. I think its similar to what you've tried -# above. Its odd but convenient that after untie'ing you are left with -# a variable that has the same value as was last returned from -# FETCH. (At least on my perl v5.6.1). So you don't need to pass a -# reference to the variable in order to set it after the untie (here it -# is accessed through a closure)." -use strict; -use warnings; -package MyTied; -sub TIESCALAR { - my ($class,$code) = @_; - bless $code, $class; -} -sub FETCH { - my $self = shift; - print "Untie\n"; - $self->(); -} -package main; -my $var; -tie $var, 'MyTied', sub { untie $var; 4 }; -print "One\n"; -print "$var\n"; -print "Two\n"; -print "$var\n"; -print "Three\n"; -print "$var\n"; -EXPECT -One -Untie -4 -Two -4 -Three -4 -######## -# [perl #22297] cannot untie scalar from within tied FETCH -my $counter = 0; -my $x = 7; -my $ref = \$x; -tie $x, 'Overlay', $ref, $x; -my $y; -$y = $x; -$y = $x; -$y = $x; -$y = $x; -#print "WILL EXTERNAL UNTIE $ref\n"; -untie $$ref; -$y = $x; -$y = $x; -$y = $x; -$y = $x; -#print "counter = $counter\n"; - -print (($counter == 1) ? "ok\n" : "not ok\n"); - -package Overlay; - -sub TIESCALAR -{ - my $pkg = shift; - my ($ref, $val) = @_; - return bless [ $ref, $val ], $pkg; -} - -sub FETCH -{ - my $self = shift; - my ($ref, $val) = @$self; - #print "WILL INTERNAL UNITE $ref\n"; - $counter++; - untie $$ref; - return $val; -} -EXPECT -ok -######## - -# [perl #948] cannot meaningfully tie $, -package TieDollarComma; - -sub TIESCALAR { - my $pkg = shift; - return bless \my $x, $pkg; -} - -sub STORE { - my $self = shift; - $$self = shift; - print "STORE set '$$self'\n"; -} - -sub FETCH { - my $self = shift; - print ""; - return $$self; -} -package main; - -tie $,, 'TieDollarComma'; -$, = 'BOBBINS'; -print "join", "things", "up\n"; -EXPECT -STORE set 'BOBBINS' -joinBOBBINSthingsBOBBINSup -######## - -# test SCALAR method -package TieScalar; - -sub TIEHASH { - my $pkg = shift; - bless { } => $pkg; -} - -sub STORE { - $_[0]->{$_[1]} = $_[2]; -} - -sub FETCH { - $_[0]->{$_[1]} -} - -sub CLEAR { - %{ $_[0] } = (); -} - -sub SCALAR { - print "SCALAR\n"; - return 0 if ! keys %{$_[0]}; - sprintf "%i/%i", scalar keys %{$_[0]}, scalar keys %{$_[0]}; -} - -package main; -tie my %h => "TieScalar"; -$h{key1} = "val1"; -$h{key2} = "val2"; -print scalar %h, "\n" - if %h; # this should also call SCALAR but implicitly -%h = (); -print scalar %h, "\n" - if !%h; # this should also call SCALAR but implicitly -EXPECT -SCALAR -SCALAR -2/2 -SCALAR -SCALAR -0 -######## - -# test scalar on tied hash when no SCALAR method has been given -package TieScalar; - -sub TIEHASH { - my $pkg = shift; - bless { } => $pkg; -} -sub STORE { - $_[0]->{$_[1]} = $_[2]; -} -sub FETCH { - $_[0]->{$_[1]} -} -sub CLEAR { - %{ $_[0] } = (); -} -sub FIRSTKEY { - my $a = keys %{ $_[0] }; - print "FIRSTKEY\n"; - each %{ $_[0] }; -} - -package main; -tie my %h => "TieScalar"; - -if (!%h) { - print "empty\n"; -} else { - print "not empty\n"; -} - -$h{key1} = "val1"; -print "not empty\n" if %h; -print "not empty\n" if %h; -print "-->\n"; -my ($k,$v) = each %h; -print "<--\n"; -print "not empty\n" if %h; -%h = (); -print "empty\n" if ! %h; -EXPECT -FIRSTKEY -empty -FIRSTKEY -not empty -FIRSTKEY -not empty ---> -FIRSTKEY -<-- -not empty -FIRSTKEY -empty -######## -sub TIESCALAR { bless {} } -sub FETCH { my $x = 3.3; 1 if 0+$x; $x } -tie $h, "main"; -print $h,"\n"; -EXPECT -3.3 -######## -sub TIESCALAR { bless {} } -sub FETCH { shift()->{i} ++ } -tie $h, "main"; -print $h.$h; -EXPECT -01 -######## -# Bug 53482 (and maybe others) -sub TIESCALAR { my $foo = $_[1]; bless \$foo, $_[0] } -sub FETCH { ${$_[0]} } -tie my $x1, "main", 2; -tie my $y1, "main", 8; -print $x1 | $y1; -print $x1 | $y1; -tie my $x2, "main", "2"; -tie my $y2, "main", "8"; -print $x2 | $y2; -print $x2 | $y2; -EXPECT -1010:: -######## -# Bug 36267 -sub TIEHASH { bless {}, $_[0] } -sub STORE { $_[0]->{$_[1]} = $_[2] } -sub FIRSTKEY { my $a = scalar keys %{$_[0]}; each %{$_[0]} } -sub NEXTKEY { each %{$_[0]} } -sub DELETE { delete $_[0]->{$_[1]} } -sub CLEAR { %{$_[0]} = () } -$h{b}=1; -delete $h{b}; -print scalar keys %h, "\n"; -tie %h, 'main'; -$i{a}=1; -%h = %i; -untie %h; -print scalar keys %h, "\n"; -EXPECT -0 -0 -######## -# Bug 37731 -sub foo::TIESCALAR { bless {value => $_[1]}, $_[0] } -sub foo::FETCH { $_[0]->{value} } -tie my $VAR, 'foo', '42'; -foreach my $var ($VAR) { - print +($var eq $VAR) ? "yes\n" : "no\n"; -} -EXPECT -yes -######## -sub TIEARRAY { bless [], 'main' } -{ - local @a; - tie @a, 'main'; -} -print "tied\n" if tied @a; -EXPECT -######## -sub TIEHASH { bless [], 'main' } -{ - local %h; - tie %h, 'main'; -} -print "tied\n" if tied %h; -EXPECT -######## -# RT 20727: PL_defoutgv is left as a tied element -sub TIESCALAR { return bless {}, 'main' } - -sub STORE { - select($_[1]); - $_[1] = 1; - select(); # this used to coredump or assert fail -} -tie $SELECT, 'main'; -$SELECT = *STDERR; -EXPECT -######## -# RT 23810: eval in die in FETCH can corrupt context stack - -my $file = 'rt23810.pm'; - -my $e; -my $s; - -sub do_require { - my ($str, $eval) = @_; - open my $fh, '>', $file or die "Can't create $file: $!\n"; - print $fh $str; - close $fh; - if ($eval) { - $s .= '-ERQ'; - eval { require $pm; $s .= '-ENDE' } - } - else { - $s .= '-RQ'; - require $pm; - } - $s .= '-ENDRQ'; - unlink $file; -} - -sub TIEHASH { bless {} } - -sub FETCH { - # 10 or more syntax errors makes yyparse croak() - my $bad = q{$x+;$x+;$x+;$x+;$x+;$x+;$x+;$x+;$x+$x+;$x+;$x+;$x+;$x+;;$x+;}; - - if ($_[1] eq 'eval') { - $s .= 'EVAL'; - eval q[BEGIN { die; $s .= '-X1' }]; - $s .= '-BD'; - eval q[BEGIN { $x+ }]; - $s .= '-BS'; - eval '$x+'; - $s .= '-E1'; - $s .= '-S1' while $@ =~ /syntax error at/g; - eval $bad; - $s .= '-E2'; - $s .= '-S2' while $@ =~ /syntax error at/g; - } - elsif ($_[1] eq 'require') { - $s .= 'REQUIRE'; - my @text = ( - q[BEGIN { die; $s .= '-X1' }], - q[BEGIN { $x+ }], - '$x+', - $bad - ); - for my $i (0..$#text) { - $s .= "-$i"; - do_require($txt[$i], 0) if $e;; - do_require($txt[$i], 1); - } - } - elsif ($_[1] eq 'exit') { - eval q[exit(0); print "overshot eval\n"]; - } - else { - print "unknown key: '$_[1]'\n"; - } - return "-R"; -} -my %foo; -tie %foo, "main"; - -for my $action(qw(eval require)) { - $s = ''; $e = 0; $s .= main->FETCH($action); print "$action: s0=$s\n"; - $s = ''; $e = 1; eval { $s .= main->FETCH($action)}; print "$action: s1=$s\n"; - $s = ''; $e = 0; $s .= $foo{$action}; print "$action: s2=$s\n"; - $s = ''; $e = 1; eval { $s .= $foo{$action}}; print "$action: s3=$s\n"; -} -1 while unlink $file; - -$foo{'exit'}; -print "overshot main\n"; # shouldn't reach here - -EXPECT -eval: s0=EVAL-BD-BS-E1-S1-E2-S2-S2-S2-S2-S2-S2-S2-S2-S2-S2-R -eval: s1=EVAL-BD-BS-E1-S1-E2-S2-S2-S2-S2-S2-S2-S2-S2-S2-S2-R -eval: s2=EVAL-BD-BS-E1-S1-E2-S2-S2-S2-S2-S2-S2-S2-S2-S2-S2-R -eval: s3=EVAL-BD-BS-E1-S1-E2-S2-S2-S2-S2-S2-S2-S2-S2-S2-S2-R -require: s0=REQUIRE-0-ERQ-ENDRQ-1-ERQ-ENDRQ-2-ERQ-ENDRQ-3-ERQ-ENDRQ-R -require: s1=REQUIRE-0-RQ -require: s2=REQUIRE-0-ERQ-ENDRQ-1-ERQ-ENDRQ-2-ERQ-ENDRQ-3-ERQ-ENDRQ-R -require: s3=REQUIRE-0-RQ -######## -# RT 8857: STORE incorrectly invoked for local($_) on aliased tied array -# element - -sub TIEARRAY { bless [], $_[0] } -sub TIEHASH { bless [], $_[0] } -sub FETCH { $_[0]->[$_[1]] } -sub STORE { $_[0]->[$_[1]] = $_[2] } - - -sub f { - local $_[0]; -} -tie @a, 'main'; -tie %h, 'main'; - -foreach ($a[0], $h{a}) { - f($_); -} -# on failure, chucks up 'premature free' etc messages -EXPECT -######## -# RT 5475: -# the initial fix for this bug caused tied scalar FETCH to be called -# multiple times when that scalar was an element in an array. Check it -# only gets called once now. - -sub TIESCALAR { bless [], $_[0] } -my $c = 0; -sub FETCH { $c++; 0 } -sub FETCHSIZE { 1 } -sub STORE { $c += 100; 0 } - - -my (@a, %h); -tie $a[0], 'main'; -tie $h{foo}, 'main'; - -my $i = 0; -my $x = $a[0] + $h{foo} + $a[$i] + (@a)[0]; -print "x=$x c=$c\n"; -EXPECT -x=0 c=4 -######## -# Bug 68192 - numeric ops not calling mg_get when tied scalar holds a ref -sub TIESCALAR { bless {}, __PACKAGE__ }; -sub STORE {}; -sub FETCH { - print "fetching... "; # make sure FETCH is called once per op - 123456 -}; -my $foo; -tie $foo, __PACKAGE__; -my $a = [1234567]; -$foo = $a; -print "+ ", 0 + $foo, "\n"; -print "** ", $foo**1, "\n"; -print "* ", $foo*1, "\n"; -print "/ ", $foo*1, "\n"; -print "% ", $foo%123457, "\n"; -print "- ", $foo-0, "\n"; -print "neg ", - -$foo, "\n"; -print "int ", int $foo, "\n"; -print "abs ", abs $foo, "\n"; -print "== ", 123456 == $foo, "\n"; -print "< ", 123455 < $foo, "\n"; -print "> ", 123457 > $foo, "\n"; -print "<= ", 123456 <= $foo, "\n"; -print ">= ", 123456 >= $foo, "\n"; -print "!= ", 0 != $foo, "\n"; -print "<=> ", 123457 <=> $foo, "\n"; -EXPECT -fetching... + 123456 -fetching... ** 123456 -fetching... * 123456 -fetching... / 123456 -fetching... % 123456 -fetching... - 123456 -fetching... neg 123456 -fetching... int 123456 -fetching... abs 123456 -fetching... == 1 -fetching... < 1 -fetching... > 1 -fetching... <= 1 -fetching... >= 1 -fetching... != 1 -fetching... <=> 1 -######## -# Ties returning overloaded objects -{ - package overloaded; - use overload - '*{}' => sub { print '*{}'; \*100 }, - '@{}' => sub { print '@{}'; \@100 }, - '%{}' => sub { print '%{}'; \%100 }, - '${}' => sub { print '${}'; \$100 }, - map { - my $op = $_; - $_ => sub { print "$op"; 100 } - } qw< 0+ "" + ** * / % - neg int abs == < > <= >= != <=> <> > -} -$o = bless [], overloaded; - -sub TIESCALAR { bless {}, "" } -sub FETCH { print "fetching... "; $o } -sub STORE{} -tie $ghew, ""; - -$ghew=undef; 1+$ghew; print "\n"; -$ghew=undef; $ghew**1; print "\n"; -$ghew=undef; $ghew*1; print "\n"; -$ghew=undef; $ghew/1; print "\n"; -$ghew=undef; $ghew%1; print "\n"; -$ghew=undef; $ghew-1; print "\n"; -$ghew=undef; -$ghew; print "\n"; -$ghew=undef; int $ghew; print "\n"; -$ghew=undef; abs $ghew; print "\n"; -$ghew=undef; 1 == $ghew; print "\n"; -$ghew=undef; $ghew<1; print "\n"; -$ghew=undef; $ghew>1; print "\n"; -$ghew=undef; $ghew<=1; print "\n"; -$ghew=undef; $ghew >=1; print "\n"; -$ghew=undef; $ghew != 1; print "\n"; -$ghew=undef; $ghew<=>1; print "\n"; -$ghew=undef; <$ghew>; print "\n"; -$ghew=\*shrext; *$ghew; print "\n"; -$ghew=\@spled; @$ghew; print "\n"; -$ghew=\%frit; %$ghew; print "\n"; -$ghew=\$drile; $$ghew; print "\n"; -EXPECT -fetching... + -fetching... ** -fetching... * -fetching... / -fetching... % -fetching... - -fetching... neg -fetching... int -fetching... abs -fetching... == -fetching... < -fetching... > -fetching... <= -fetching... >= -fetching... != -fetching... <=> -fetching... <> -fetching... *{} -fetching... @{} -fetching... %{} -fetching... ${} -######## -# RT 51636: segmentation fault with array ties - -tie my @a, 'T'; -@a = (1); -print "ok\n"; # if we got here we didn't crash - -package T; - -sub TIEARRAY { bless {} } -sub STORE { tie my @b, 'T' } -sub CLEAR { } -sub EXTEND { } - -EXPECT -ok -######## -# RT 8438: Tied scalars don't call FETCH when subref is dereferenced - -sub TIESCALAR { bless {} } - -my $fetch = 0; -my $called = 0; -sub FETCH { $fetch++; sub { $called++ } } - -tie my $f, 'main'; -$f->(1) for 1,2; -print "fetch=$fetch\ncalled=$called\n"; - -EXPECT -fetch=2 -called=2 -######## -# tie mustn't attempt to call methods on bareword filehandles. -sub IO::File::TIEARRAY { - die "Did not want to invoke IO::File::TIEARRAY"; -} -fileno FOO; tie @a, "FOO" -EXPECT -Can't locate object method "TIEARRAY" via package "FOO" at - line 5. -######## - -# Deprecation warnings for tie $handle - -use warnings 'deprecated'; -$SIG{__WARN__} = sub { $w = shift }; -$handle = *foo; -eval { tie $handle, "" }; -print $w =~ /^Use of tie on a handle without \* is deprecated/ - ? "ok tie\n" : "$w\n"; -$handle = *bar; -tied $handle; -print $w =~ /^Use of tied on a handle without \* is deprecated/ - ? "ok tied\n" : "$w\n"; -$handle = *baz; -untie $handle; -print $w =~ /^Use of untie on a handle without \* is deprecated/ - ? "ok untie\n" : "$w\n"; - -EXPECT -ok tie -ok tied -ok untie -######## -# -# STORE freeing tie'd AV -sub TIEARRAY { bless [] } -sub STORE { *a = []; 1 } -sub STORESIZE { } -sub EXTEND { } -tie @a, 'main'; -$a[0] = 1; -EXPECT -######## -# -# CLEAR freeing tie'd AV -sub TIEARRAY { bless [] } -sub CLEAR { *a = []; 1 } -sub STORESIZE { } -sub EXTEND { } -sub STORE { } -tie @a, 'main'; -@a = (1,2,3); -EXPECT -######## -# -# FETCHSIZE freeing tie'd AV -sub TIEARRAY { bless [] } -sub FETCHSIZE { *a = []; 100 } -sub STORESIZE { } -sub EXTEND { } -sub STORE { } -tie @a, 'main'; -print $#a,"\n" -EXPECT -99 -######## -# -# [perl #86328] Crash when freeing tie magic that can increment the refcnt - -eval { require Scalar::Util } or print("ok\n"), exit; - -sub TIEHASH { - return $_[1]; -} -*TIEARRAY = *TIEHASH; - -sub DESTROY { - my ($tied) = @_; - my $b = $tied->[0]; -} - -my $a = {}; -my $o = bless []; -Scalar::Util::weaken($o->[0] = $a); -tie %$a, "main", $o; - -my $b = []; -my $p = bless []; -Scalar::Util::weaken($p->[0] = $b); -tie @$b, "main", $p; - -# Done setting up the evil data structures - -$a = undef; -$b = undef; -print "ok\n"; - -EXPECT -ok -######## -# -# Localising a tied COW scalar should not make it read-only. - -sub TIESCALAR { bless [] } -sub FETCH { __PACKAGE__ } -sub STORE {} -tie $x, ""; -"$x"; -{ - local $x; - $x = 3; -} -print "ok\n"; -EXPECT -ok diff --git a/t/CORE/op/tie_fetch_count.t b/t/CORE/op/tie_fetch_count.t deleted file mode 100644 index fdab7264f..000000000 --- a/t/CORE/op/tie_fetch_count.t +++ /dev/null @@ -1,260 +0,0 @@ -#!./perl -# Tests counting number of FETCHes. -# -# See Bugs #76814 and #87708. - -BEGIN { - unshift @INC, 't/CORE/lib'; - require 't/CORE/test.pl'; -} - -plan tests => 210; - -use strict; -use warnings; - -my $count = 0; - -# Usage: -# tie $var, "main", $val; # FETCH returns $val -# tie $var, "main", $val1, $val2; # FETCH returns the values in order, -# # one at a time, repeating the last -# # when the list is exhausted. -sub TIESCALAR {my $pack = shift; bless [@_], $pack;} -sub FETCH {$count ++; @{$_ [0]} == 1 ? ${$_ [0]}[0] : shift @{$_ [0]}} -sub STORE { unshift @{$_[0]}, $_[1] } - - -sub check_count { - my $op = shift; - my $expected = shift() // 1; - is $count, $expected, - "FETCH called " . ( - $expected == 1 ? "just once" : - $expected == 2 ? "twice" : - "$count times" - ) . " using '$op'"; - $count = 0; -} - -my ($dummy, @dummy); - -tie my $var => 'main', 1; - -# Assignment. -$dummy = $var ; check_count "="; - -# Unary +/- -$dummy = +$var ; check_count "unary +"; -$dummy = -$var ; check_count "unary -"; - -# Basic arithmetic and string operators. -$dummy = $var + 1 ; check_count '+'; -$dummy = $var - 1 ; check_count '-'; -$dummy = $var / 1 ; check_count '/'; -$dummy = $var * 1 ; check_count '*'; -$dummy = $var % 1 ; check_count '%'; -$dummy = $var ** 1 ; check_count '**'; -$dummy = $var << 1 ; check_count '<<'; -$dummy = $var >> 1 ; check_count '>>'; -$dummy = $var x 1 ; check_count 'x'; -@dummy = ($var) x 1 ; check_count 'x'; -$dummy = $var . 1 ; check_count '.'; - -# Pre/post in/decrement - $var ++ ; check_count 'post ++'; - $var -- ; check_count 'post --'; - ++ $var ; check_count 'pre ++'; - -- $var ; check_count 'pre --'; - -# Numeric comparison -$dummy = $var < 1 ; check_count '<'; -$dummy = $var <= 1 ; check_count '<='; -$dummy = $var == 1 ; check_count '=='; -$dummy = $var >= 1 ; check_count '>='; -$dummy = $var > 1 ; check_count '>'; -$dummy = $var != 1 ; check_count '!='; -$dummy = $var <=> 1 ; check_count '<=>'; - -# String comparison -$dummy = $var lt 1 ; check_count 'lt'; -$dummy = $var le 1 ; check_count 'le'; -$dummy = $var eq 1 ; check_count 'eq'; -$dummy = $var ge 1 ; check_count 'ge'; -$dummy = $var gt 1 ; check_count 'gt'; -$dummy = $var ne 1 ; check_count 'ne'; -$dummy = $var cmp 1 ; check_count 'cmp'; - -# Bitwise operators -$dummy = $var & 1 ; check_count '&'; -$dummy = $var ^ 1 ; check_count '^'; -$dummy = $var | 1 ; check_count '|'; -$dummy = ~$var ; check_count '~'; - -# Logical operators -$dummy = !$var ; check_count '!'; -tie my $v_1, "main", 0; -$dummy = $v_1 || 1 ; check_count '||'; -$dummy = ($v_1 or 1); check_count 'or'; -$dummy = $var && 1 ; check_count '&&'; -$dummy = ($var and 1); check_count 'and'; -$dummy = ($var xor 1); check_count 'xor'; -$dummy = $var ? 1 : 1 ; check_count '?:'; - -# Overloadable functions -$dummy = sin $var ; check_count 'sin'; -$dummy = cos $var ; check_count 'cos'; -$dummy = exp $var ; check_count 'exp'; -$dummy = abs $var ; check_count 'abs'; -$dummy = log $var ; check_count 'log'; -$dummy = sqrt $var ; check_count 'sqrt'; -$dummy = int $var ; check_count 'int'; -$dummy = atan2 $var, 1 ; check_count 'atan2'; - -# Readline/glob -tie my $var0, "main", \*DATA; -$dummy = <$var0> ; check_count ''; -$dummy = <${var}> ; check_count ''; - -# File operators -$dummy = -r $var ; check_count '-r'; -$dummy = -w $var ; check_count '-w'; -$dummy = -x $var ; check_count '-x'; -$dummy = -o $var ; check_count '-o'; -$dummy = -R $var ; check_count '-R'; -$dummy = -W $var ; check_count '-W'; -$dummy = -X $var ; check_count '-X'; -$dummy = -O $var ; check_count '-O'; -$dummy = -e $var ; check_count '-e'; -$dummy = -z $var ; check_count '-z'; -$dummy = -s $var ; check_count '-s'; -$dummy = -f $var ; check_count '-f'; -$dummy = -d $var ; check_count '-d'; -$dummy = -l $var ; check_count '-l'; -$dummy = -p $var ; check_count '-p'; -$dummy = -S $var ; check_count '-S'; -$dummy = -b $var ; check_count '-b'; -$dummy = -c $var ; check_count '-c'; -$dummy = -t $var ; check_count '-t'; -$dummy = -u $var ; check_count '-u'; -$dummy = -g $var ; check_count '-g'; -$dummy = -k $var ; check_count '-k'; -$dummy = -T $var ; check_count '-T'; -$dummy = -B $var ; check_count '-B'; -$dummy = -M $var ; check_count '-M'; -$dummy = -A $var ; check_count '-A'; -$dummy = -C $var ; check_count '-C'; - -# Matching -$_ = "foo"; -$dummy = $var =~ m/ / ; check_count 'm//'; -$dummy = $var =~ s/ //; check_count 's///'; -$dummy = $var ~~ 1 ; check_count '~~'; -$dummy = $var =~ y/ //; check_count 'y///'; - /$var/ ; check_count 'm/pattern/'; - /$var foo/ ; check_count 'm/$tied foo/'; - s/$var// ; check_count 's/pattern//'; - s/$var foo// ; check_count 's/$tied foo//'; - s/./$var/ ; check_count 's//replacement/'; - -# Dereferencing -tie my $var1 => 'main', \1; -$dummy = $$var1 ; check_count '${}'; -tie my $var2 => 'main', []; -$dummy = @$var2 ; check_count '@{}'; -$dummy = shift $var2 ; check_count 'shift arrayref'; -tie my $var3 => 'main', {}; -$dummy = %$var3 ; check_count '%{}'; -$dummy = keys $var3 ; check_count 'keys hashref'; -{ - no strict 'refs'; - tie my $var4 => 'main', **; - $dummy = *$var4 ; check_count '*{}'; -} - -tie my $var5 => 'main', sub {1}; -$dummy = &$var5 ; check_count '&{}'; - - -############################################### -# Tests for $foo binop $foo # -############################################### - -# These test that binary ops call FETCH twice if the same scalar is used -# for both operands. They also test that both return values from -# FETCH are used. - -my %mutators = map { ($_ => 1) } qw(. + - * / % ** << >> & | ^); - - -sub _bin_test { - my $int = shift; - my $op = shift; - my $exp = pop; - my @fetches = @_; - - $int = $int ? 'use integer; ' : ''; - - tie my $var, "main", @fetches; - is(eval "$int\$var $op \$var", $exp, "retval of $int\$var $op \$var"); - check_count "$int$op", 2; - - return unless $mutators{$op}; - - tie my $var2, "main", @fetches; - is(eval "$int \$var2 $op= \$var2", $exp, "retval of $int \$var2 $op= \$var2"); - check_count "$int$op=", 3; -} - -sub bin_test { - _bin_test(0, @_); -} - -sub bin_int_test { - _bin_test(1, @_); -} - -bin_test '**', 2, 3, 8; -bin_test '*' , 2, 3, 6; -bin_test '/' , 10, 2, 5; -bin_test '%' , 11, 2, 1; -bin_test 'x' , 11, 2, 1111; -bin_test '-' , 11, 2, 9; -bin_test '<<', 11, 2, 44; -bin_test '>>', 44, 2, 11; -bin_test '<' , 1, 2, 1; -bin_test '>' , 44, 2, 1; -bin_test '<=', 44, 2, ""; -bin_test '>=', 1, 2, ""; -bin_test '!=', 1, 2, 1; -bin_test '<=>', 1, 2, -1; -bin_test 'le', 4, 2, ""; -bin_test 'lt', 1, 2, 1; -bin_test 'gt', 4, 2, 1; -bin_test 'ge', 1, 2, ""; -bin_test 'eq', 1, 2, ""; -bin_test 'ne', 1, 2, 1; -bin_test 'cmp', 1, 2, -1; -bin_test '&' , 1, 2, 0; -bin_test '|' , 1, 2, 3; -bin_test '^' , 3, 5, 6; -bin_test '.' , 1, 2, 12; -bin_test '==', 1, 2, ""; -bin_test '+' , 1, 2, 3; -bin_int_test '*' , 2, 3, 6; -bin_int_test '/' , 10, 2, 5; -bin_int_test '%' , 11, 2, 1; -bin_int_test '+' , 1, 2, 3; -bin_int_test '-' , 11, 2, 9; -bin_int_test '<' , 1, 2, 1; -bin_int_test '>' , 44, 2, 1; -bin_int_test '<=', 44, 2, ""; -bin_int_test '>=', 1, 2, ""; -bin_int_test '==', 1, 2, ""; -bin_int_test '!=', 1, 2, 1; -bin_int_test '<=>', 1, 2, -1; -tie $var, "main", 1, 4; -cmp_ok(atan2($var, $var), '<', .3, 'retval of atan2 $var, $var'); -check_count 'atan2', 2; - -__DATA__ diff --git a/t/CORE/op/tiearray.t b/t/CORE/op/tiearray.t deleted file mode 100644 index 9d8ced384..000000000 --- a/t/CORE/op/tiearray.t +++ /dev/null @@ -1,299 +0,0 @@ -#!./perl - -BEGIN { - unshift @INC, 't/CORE/lib'; - require 't/CORE/test.pl'; -} - -my %seen; - -package Implement; - -sub TIEARRAY -{ - $seen{'TIEARRAY'}++; - my ($class,@val) = @_; - return bless \@val,$class; -} - -sub STORESIZE -{ - $seen{'STORESIZE'}++; - my ($ob,$sz) = @_; - return $#{$ob} = $sz-1; -} - -sub EXTEND -{ - $seen{'EXTEND'}++; - my ($ob,$sz) = @_; - return @$ob = $sz; -} - -sub FETCHSIZE -{ - $seen{'FETCHSIZE'}++; - return scalar(@{$_[0]}); -} - -sub FETCH -{ - $seen{'FETCH'}++; - my ($ob,$id) = @_; - return $ob->[$id]; -} - -sub STORE -{ - $seen{'STORE'}++; - my ($ob,$id,$val) = @_; - $ob->[$id] = $val; -} - -sub UNSHIFT -{ - $seen{'UNSHIFT'}++; - my $ob = shift; - unshift(@$ob,@_); -} - -sub PUSH -{ - $seen{'PUSH'}++; - my $ob = shift;; - push(@$ob,@_); -} - -sub CLEAR -{ - $seen{'CLEAR'}++; - @{$_[0]} = (); -} - -sub DESTROY -{ - $seen{'DESTROY'}++; -} - -sub POP -{ - $seen{'POP'}++; - my ($ob) = @_; - return pop(@$ob); -} - -sub SHIFT -{ - $seen{'SHIFT'}++; - my ($ob) = @_; - return shift(@$ob); -} - -sub SPLICE -{ - $seen{'SPLICE'}++; - my $ob = shift; - my $off = @_ ? shift : 0; - my $len = @_ ? shift : @$ob-1; - return splice(@$ob,$off,$len,@_); -} - -package NegIndex; # 20020220 MJD -@ISA = 'Implement'; - -# simulate indices -2 .. 2 -my $offset = 2; -$NegIndex::NEGATIVE_INDICES = 1; - -sub FETCH { - my ($ob,$id) = @_; -# print "# FETCH @_\n"; - $id += $offset; - $ob->[$id]; -} - -sub STORE { - my ($ob,$id,$value) = @_; -# print "# STORE @_\n"; - $id += $offset; - $ob->[$id] = $value; -} - -sub DELETE { - my ($ob,$id) = @_; -# print "# DELETE @_\n"; - $id += $offset; - delete $ob->[$id]; -} - -sub EXISTS { - my ($ob,$id) = @_; -# print "# EXISTS @_\n"; - $id += $offset; - exists $ob->[$id]; -} - -# -# Returning -1 from FETCHSIZE used to get casted to U32 causing a -# segfault -# - -package NegFetchsize; - -sub TIEARRAY { bless [] } -sub FETCH { } -sub FETCHSIZE { -1 } - -package main; - -plan(tests => 69); - -{my @ary; - -{ my $ob = tie @ary,'Implement',3,2,1; - ok($ob); - is(tied(@ary), $ob); -} - -is(@ary, 3); -is($#ary, 2); -is(join(':',@ary), '3:2:1'); -cmp_ok($seen{'FETCH'}, '>=', 3); - -@ary = (1,2,3); - -cmp_ok($seen{'STORE'}, '>=', 3); -is(join(':',@ary), '1:2:3'); - -{my @thing = @ary; -is(join(':',@thing), '1:2:3'); - -tie @thing,'Implement'; -@thing = @ary; -is(join(':',@thing), '1:2:3'); -} - -is(pop(@ary), 3); -is($seen{'POP'}, 1); -is(join(':',@ary), '1:2'); - -is(push(@ary,4), 3); -is($seen{'PUSH'}, 1); -is(join(':',@ary), '1:2:4'); - -my @x = splice(@ary,1,1,7); - -is($seen{'SPLICE'}, 1); -is(@x, 1); -is($x[0], 2); -is(join(':',@ary), '1:7:4'); - -is(shift(@ary), 1); -is($seen{'SHIFT'}, 1); -is(join(':',@ary), '7:4'); - -my $n = unshift(@ary,5,6); -is($seen{'UNSHIFT'}, 1); -is($n, 4); -is(join(':',@ary), '5:6:7:4'); - -@ary = split(/:/,'1:2:3'); -is(join(':',@ary), '1:2:3'); - -my $t = 0; -foreach $n (@ary) - { - is($n, ++$t); - } - -# (30-33) 20020303 mjd-perl-patch+@plover.com -@ary = (); -$seen{POP} = 0; -pop @ary; # this didn't used to call POP at all -is($seen{POP}, 1); -$seen{SHIFT} = 0; -shift @ary; # this didn't used to call SHIFT at all -is($seen{SHIFT}, 1); -$seen{PUSH} = 0; -my $got = push @ary; # this didn't used to call PUSH at all -is($got, 0); -is($seen{PUSH}, 1); -$seen{UNSHIFT} = 0; -$got = unshift @ary; # this didn't used to call UNSHIFT at all -is($got, 0); -is($seen{UNSHIFT}, 1); - -@ary = qw(3 2 1); -is(join(':',@ary), '3:2:1'); - -$#ary = 1; -is($seen{'STORESIZE'}, 1, 'seen STORESIZE'); -is(join(':',@ary), '3:2'); - -sub arysize :lvalue { $#ary } -arysize()--; -is($seen{'STORESIZE'}, 2, 'seen STORESIZE'); -is(join(':',@ary), '3'); - -untie @ary; - -} - -# 20020401 mjd-perl-patch+@plover.com -# Thanks to Dave Mitchell for the small test case and the fix -{ - my @a; - - sub X::TIEARRAY { bless {}, 'X' } - - sub X::SPLICE { - do '/dev/null'; - die; - } - - tie @a, 'X'; - eval { splice(@a) }; - # If we survived this far. - pass(); -} - -{ # 20020220 mjd-perl-patch+@plover.com - my @n; - tie @n => 'NegIndex', ('A' .. 'E'); - - # FETCH - is($n[0], 'C'); - is($n[1], 'D'); - is($n[2], 'E'); - is($n[-1], 'B'); - is($n[-2], 'A'); - - # STORE - $n[-2] = 'a'; - is($n[-2], 'a'); - $n[-1] = 'b'; - is($n[-1], 'b'); - $n[0] = 'c'; - is($n[0], 'c'); - $n[1] = 'd'; - is($n[1], 'd'); - $n[2] = 'e'; - is($n[2], 'e'); - - # DELETE and EXISTS - for (-2 .. 2) { - ok($n[$_]); - delete $n[$_]; - is(defined($n[$_]), ''); - is(exists($n[$_]), ''); - } -} - -{ - tie my @dummy, "NegFetchsize"; - eval { "@dummy"; }; - like($@, qr/^FETCHSIZE returned a negative value/, - " - croak on negative FETCHSIZE"); -} - -is($seen{'DESTROY'}, 3); diff --git a/t/CORE/op/tiehandle.t b/t/CORE/op/tiehandle.t deleted file mode 100644 index 136189f2c..000000000 --- a/t/CORE/op/tiehandle.t +++ /dev/null @@ -1,302 +0,0 @@ -#!./perl -w - -INIT { - unshift @INC, 't/CORE/lib'; - require 't/CORE/test.pl'; -} - -my @expect; -my $data = ""; -my @data = (); - -plan(tests => 63); - -sub compare { - local $Level = $Level + 1; - - return unless @expect; - return ::fail() unless(@_ == @expect); - - for my $i (0..$#_) { - next if $_[$i] eq $expect[$i]; - return ::fail(); - } - - ::pass(); -} - - -package Implement; - -sub TIEHANDLE { - ::compare(TIEHANDLE => @_); - my ($class,@val) = @_; - return bless \@val,$class; -} - -sub PRINT { - ::compare(PRINT => @_); - 1; -} - -sub PRINTF { - ::compare(PRINTF => @_); - 2; -} - -sub READLINE { - ::compare(READLINE => @_); - wantarray ? @data : shift @data; -} - -sub GETC { - ::compare(GETC => @_); - substr($data,0,1); -} - -sub READ { - ::compare(READ => @_); - substr($_[1],$_[3] || 0) = substr($data,0,$_[2]); - 3; -} - -sub EOF { - ::compare(EOF => @_); - @data ? '' : 1; -} - -sub WRITE { - ::compare(WRITE => @_); - $data = substr($_[1],$_[3] || 0, $_[2]); - length($data); -} - -sub CLOSE { - ::compare(CLOSE => @_); - 5; -} - -package main; - -use Symbol; - -my $fh = gensym; - -@expect = (TIEHANDLE => 'Implement'); -my $ob = tie *$fh,'Implement'; -is(ref($ob), 'Implement'); -is(tied(*$fh), $ob); - -@expect = (PRINT => $ob,"some","text"); -$r = print $fh @expect[2,3]; -is($r, 1); - -@expect = (PRINTF => $ob,"%s","text"); -$r = printf $fh @expect[2,3]; -is($r, 2); - -@data = ("the line\n"); -@expect = (EOF => $ob, 1); -is(eof($fh), ''); - -$text = $data[0]; -@expect = (READLINE => $ob); -$ln = <$fh>; -is($ln, $text); - -@expect = (EOF => $ob, 0); -is(eof, 1); - -@expect = (); -@in = @data = qw(a line at a time); -@line = <$fh>; -@expect = @in; -compare(@line); - -@expect = (GETC => $ob); -$data = "abc"; -$ch = getc $fh; -is($ch, "a"); - -$buf = "xyz"; -@expect = (READ => $ob, $buf, 3); -$data = "abc"; -$r = read $fh,$buf,3; -is($r, 3); -is($buf, "abc"); - - -$buf = "xyzasd"; -@expect = (READ => $ob, $buf, 3,3); -$data = "abc"; -$r = sysread $fh,$buf,3,3; -is($r, 3); -is($buf, "xyzabc"); - -$buf = "qwerty"; -@expect = (WRITE => $ob, $buf, 4,1); -$data = ""; -$r = syswrite $fh,$buf,4,1; -is($r, 4); -is($data, "wert"); - -$buf = "qwerty"; -@expect = (WRITE => $ob, $buf, 4); -$data = ""; -$r = syswrite $fh,$buf,4; -is($r, 4); -is($data, "qwer"); - -$buf = "qwerty"; -@expect = (WRITE => $ob, $buf, 6); -$data = ""; -$r = syswrite $fh,$buf; -is($r, 6); -is($data, "qwerty"); - -@expect = (CLOSE => $ob); -$r = close $fh; -is($r, 5); - -# Does aliasing work with tied FHs? -*ALIAS = *$fh; -@expect = (PRINT => $ob,"some","text"); -$r = print ALIAS @expect[2,3]; -is($r, 1); - -{ - use warnings; - # Special case of aliasing STDERR, which used - # to dump core when warnings were enabled - local *STDERR = *$fh; - @expect = (PRINT => $ob,"some","text"); - $r = print STDERR @expect[2,3]; - is($r, 1); -} - -{ - package Bar::Say; - use feature 'say'; - use base qw(Implement); - - my $ors; - sub PRINT { - $ors = $\; - my $self = shift; - return $self->SUPER::PRINT(@_); - } - - my $fh = Symbol::gensym; - @expect = (TIEHANDLE => 'Bar::Say'); - ::ok( my $obj = tie *$fh, 'Bar::Say' ); - - local $\ = 'something'; - @expect = (PRINT => $obj, "stuff", "and", "things"); - ::ok( print $fh @expect[2..4] ); - ::is( $ors, 'something' ); - - ::ok( say $fh @expect[2..4] ); - ::is( $ors, "\n", 'say sets $\ to \n in PRINT' ); - ::is( $\, "something", " and it's localized" ); -} - -{ - # Test for change #11536 - package Foo; - use strict; - sub TIEHANDLE { bless {} } - my $cnt = 'a'; - sub READ { - $_[1] = $cnt++; - 1; - } - sub do_read { - my $fh = shift; - read $fh, my $buff, 1; - ::pass(); - } - $|=1; - tie *STDIN, 'Foo'; - read STDIN, my $buff, 1; - ::pass(); - do_read(\*STDIN); - untie *STDIN; -} - - -{ - # test for change 11639: Can't localize *FH, then tie it - { - local *foo; - tie %foo, 'Blah'; - } - ok(!tied %foom, 'foom not tied'); - - { - local *bar; - tie @bar, 'Blah'; - } - ok(!tied @bar, 'bar not tied'); - - { - local *BAZ; - tie *BAZ, 'Blah'; - } - ok(!tied *BAZ, 'BAZ not tied'); - - package Blah; - - sub TIEHANDLE {bless {}} - sub TIEHASH {bless {}} - sub TIEARRAY {bless {}} -} - -eval q{ - # warnings should pass to the PRINT method of tied STDERR - my @received; - - local *STDERR = *$fh; - no warnings 'redefine'; - local *Implement::PRINT = sub { @received = @_ }; - - $r = warn("some", "text", "\n"); - @expect = (PRINT => $ob,"sometext\n"); - compare(PRINT => @received); - use warnings; - print undef; - - like($received[1], qr/Use of uninitialized value/, 'recevied uninitialized value'); -}; - -{ - # [ID 20020713.001] chomp($data=) - local *TEST; - tie *TEST, 'CHOMP'; - my $data; - chomp($data = ); - is($data, 'foobar'); - - package CHOMP; - sub TIEHANDLE { bless {}, $_[0] } - sub READLINE { "foobar\n" } -} - -{ - # make sure the new eof() features work with @ARGV magic - local *ARGV; - @ARGV = ('haha'); - - @expect = (TIEHANDLE => 'Implement'); - $ob = tie *ARGV, 'Implement'; - is(ref($ob), 'Implement'); - is(tied(*ARGV), $ob); - - @data = ("stuff\n"); - @expect = (EOF => $ob, 1); - is(eof(ARGV), ''); - @expect = (EOF => $ob, 2); - is(eof(), ''); - shift @data; - @expect = (EOF => $ob, 0); - is(eof, 1); -} diff --git a/t/CORE/op/time.t b/t/CORE/op/time.t deleted file mode 100644 index a03e2f959..000000000 --- a/t/CORE/op/time.t +++ /dev/null @@ -1,236 +0,0 @@ -#!./perl -w - -BEGIN { - unshift @INC, 't/CORE/lib'; - require 't/CORE/test.pl'; -} - -plan tests => 66; - -# These tests make sure, among other things, that we don't end up -# burning tons of CPU for dates far in the future. -# watchdog() makes sure that the test script eventually exits if -# the tests are triggering the failing behavior -watchdog(15); - -($beguser,$begsys) = times; - -$beg = time; - -while (($now = time) == $beg) { sleep 1 } - -ok($now > $beg && $now - $beg < 10, 'very basic time test'); - -for ($i = 0; $i < 1_000_000; $i++) { - for my $j (1..100) {}; # burn some user cycles - ($nowuser, $nowsys) = times; - $i = 2_000_000 if $nowuser > $beguser && ( $nowsys >= $begsys || - (!$nowsys && !$begsys)); - last if time - $beg > 20; -} - -ok($i >= 2_000_000, 'very basic times test'); - -($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($beg); -($xsec,$foo) = localtime($now); -$localyday = $yday; - -isnt($sec, $xsec, 'localtime() list context'); -ok $mday, ' month day'; -ok $year, ' year'; - -ok(localtime() =~ /^(Sun|Mon|Tue|Wed|Thu|Fri|Sat)[ ] - (Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec)[ ] - ([ \d]\d)\ (\d\d):(\d\d):(\d\d)\ (\d{4})$ - /x, - 'localtime(), scalar context' - ); - -SKIP: { - # This conditional of "No tzset()" is stolen from ext/POSIX/t/time.t - skip "No tzset()", 1 - if $^O eq "VMS" || $^O eq "cygwin" || - $^O eq "djgpp" || $^O eq "MSWin32" || $^O eq "dos" || - $^O eq "interix"; - -# check that localtime respects changes to $ENV{TZ} -$ENV{TZ} = "GMT-5"; -($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($beg); -$ENV{TZ} = "GMT+5"; -($sec,$min,$hour2,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($beg); -ok($hour != $hour2, 'changes to $ENV{TZ} respected'); -} - - -($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = gmtime($beg); -($xsec,$foo) = localtime($now); - -isnt($sec, $xsec, 'gmtime() list conext'); -ok $mday, ' month day'; -ok $year, ' year'; - -my $day_diff = $localyday - $yday; -ok( grep({ $day_diff == $_ } (0, 1, -1, 364, 365, -364, -365)), - 'gmtime() and localtime() agree what day of year'); - - -# This could be stricter. -ok(gmtime() =~ /^(Sun|Mon|Tue|Wed|Thu|Fri|Sat)[ ] - (Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec)[ ] - ([ \d]\d)\ (\d\d):(\d\d):(\d\d)\ (\d{4})$ - /x, - 'gmtime(), scalar context' - ); - - - -# Test gmtime over a range of times. -{ - # The range should be limited only by the 53-bit mantissa of an IEEE double (or - # whatever kind of double you've got). Here we just prove that we're comfortably - # beyond the range possible with 32-bit time_t. - my %tests = ( - # time_t gmtime list scalar - -2**35 => [52, 13, 20, 7, 2, -1019, 5, 65, 0, "Fri Mar 7 20:13:52 881"], - -2**32 => [44, 31, 17, 24, 10, -67, 0, 327, 0, "Sun Nov 24 17:31:44 1833"], - -2**31 => [52, 45, 20, 13, 11, 1, 5, 346, 0, "Fri Dec 13 20:45:52 1901"], - -1 => [59, 59, 23, 31, 11, 69, 3, 364, 0, "Wed Dec 31 23:59:59 1969"], - 0 => [0, 0, 0, 1, 0, 70, 4, 0, 0, "Thu Jan 1 00:00:00 1970"], - 1 => [1, 0, 0, 1, 0, 70, 4, 0, 0, "Thu Jan 1 00:00:01 1970"], - 2**30 => [4, 37, 13, 10, 0, 104, 6, 9, 0, "Sat Jan 10 13:37:04 2004"], - 2**31 => [8, 14, 3, 19, 0, 138, 2, 18, 0, "Tue Jan 19 03:14:08 2038"], - 2**32 => [16, 28, 6, 7, 1, 206, 0, 37, 0, "Sun Feb 7 06:28:16 2106"], - 2**39 => [8, 18, 12, 25, 0, 17491, 2, 24, 0, "Tue Jan 25 12:18:08 19391"], - ); - - for my $time (keys %tests) { - my @expected = @{$tests{$time}}; - my $scalar = pop @expected; - - ok eq_array([gmtime($time)], \@expected), "gmtime($time) list context"; - is scalar gmtime($time), $scalar, " scalar"; - } -} - - -# Test localtime -{ - # We pick times which fall in the middle of a month, so the month and year should be - # the same regardless of the time zone. - my %tests = ( - # time_t month, year, scalar - -8589934592 => [9, -203, qr/Oct \d+ .* 1697$/], - -1296000 => [11, 69, qr/Dec \d+ .* 1969$/], - 1296000 => [0, 70, qr/Jan \d+ .* 1970$/], - 5000000000 => [5, 228, qr/Jun \d+ .* 2128$/], - 1163500000 => [10, 106, qr/Nov \d+ .* 2006$/], - ); - - for my $time (keys %tests) { - my @expected = @{$tests{$time}}; - my $scalar = pop @expected; - - my @time = (localtime($time))[4,5]; - ok( eq_array(\@time, \@expected), "localtime($time) list context" ) - or diag("@time"); - like scalar localtime($time), $scalar, " scalar"; - } -} - -# Test floating point args -{ - warning_is(sub {is( (localtime(1296000.23))[5] + 1900, 1970 )}, - undef, 'Ignore fractional time'); - warning_is(sub {is( (gmtime(1.23))[5] + 1900, 1970 )}, - undef, 'Ignore fractional time'); -} - - -# Some sanity tests for the far, far future and far, far past -{ - my %time2year = ( - -2**52 => -142711421, - -2**48 => -8917617, - -2**46 => -2227927, - 2**46 => 2231866, - 2**48 => 8921556, - 2**52 => 142715360, - ); - - for my $time (sort keys %time2year) { - my $want = $time2year{$time}; - - my $have = (gmtime($time))[5] + 1900; - is $have, $want, "year check, gmtime($time)"; - - $have = (localtime($time))[5] + 1900; - is $have, $want, "year check, localtime($time)"; - } -} - - -# Test that Perl warns properly when it can't handle a time. -{ - my $warning; - local $SIG{__WARN__} = sub { $warning .= join "\n", @_; }; - - my $big_time = 2**60; - my $small_time = -2**60; - - $warning = ''; - my $date = gmtime($big_time); - like $warning, qr/^gmtime(.*) too large/; - - $warning = ''; - $date = localtime($big_time); - like $warning, qr/^localtime(.*) too large/; - - $warning = ''; - $date = gmtime($small_time); - like $warning, qr/^gmtime(.*) too small/; - - $warning = ''; - $date = localtime($small_time); - like $warning, qr/^localtime(.*) too small/; -} - -SKIP: { #rt #73040 - # these are from the definitions of TIME_LOWER_BOUND AND TIME_UPPER_BOUND - my $smallest = -67768100567755200.0; - my $biggest = 67767976233316800.0; - - # offset to a value that will fail - my $small_time = $smallest - 200; - my $big_time = $biggest + 200; - - # check they're representable - typically means NV is - # long double - if ($small_time + 200 != $smallest - || $small_time == $smallest - || $big_time - 200 != $biggest - || $big_time == $biggest) { - skip "Can't represent test values", 4; - } - my $small_time_f = sprintf("%.0f", $small_time); - my $big_time_f = sprintf("%.0f", $big_time); - - # check the numbers in the warning are correct - my $warning; - local $SIG{__WARN__} = sub { $warning .= join "\n", @_; }; - $warning = ''; - my $date = gmtime($big_time); - like $warning, qr/^gmtime\($big_time_f\) too large/; - - $warning = ''; - $date = localtime($big_time); - like $warning, qr/^localtime\($big_time_f\) too large/; - - $warning = ''; - $date = gmtime($small_time); - like $warning, qr/^gmtime\($small_time_f\) too small/; - - $warning = ''; - $date = localtime($small_time); - like $warning, qr/^localtime\($small_time_f\) too small/; - -} diff --git a/t/CORE/op/time_loop.t b/t/CORE/op/time_loop.t deleted file mode 100644 index 2ad37c930..000000000 --- a/t/CORE/op/time_loop.t +++ /dev/null @@ -1,16 +0,0 @@ -#!perl -w - -# d95a2ea538e6c332f36c34ca45b78d6ad93c3a1f allowed times greater than -# 2**63 to be handed to gm/localtime() which caused an internal overflow -# and an excessively long loop. Test this does not happen. - -use strict; - -INIT { require 't/CORE/test.pl'; } - -plan(tests => 2); -watchdog(2); - -local $SIG{__WARN__} = sub {}; -is(gmtime(2**69), undef); -is(localtime(2**69), undef); diff --git a/t/CORE/op/tr.t b/t/CORE/op/tr.t deleted file mode 100644 index 21f004c18..000000000 --- a/t/CORE/op/tr.t +++ /dev/null @@ -1,506 +0,0 @@ -# tr.t - -BEGIN { - unshift @INC, 't/CORE/lib'; - require 't/CORE/test.pl'; -} - -plan tests => 128; - -my $Is_EBCDIC = (ord('i') == 0x89 & ord('J') == 0xd1); - -$_ = "abcdefghijklmnopqrstuvwxyz"; - -tr/a-z/A-Z/; - -is($_, "ABCDEFGHIJKLMNOPQRSTUVWXYZ", 'uc'); - -tr/A-Z/a-z/; - -is($_, "abcdefghijklmnopqrstuvwxyz", 'lc'); - -tr/b-y/B-Y/; -is($_, "aBCDEFGHIJKLMNOPQRSTUVWXYz", 'partial uc'); - - -# In EBCDIC 'I' is \xc9 and 'J' is \0xd1, 'i' is \x89 and 'j' is \x91. -# Yes, discontinuities. Regardless, the \xca in the below should stay -# untouched (and not became \x8a). -{ - no utf8; - $_ = "I\xcaJ"; - - tr/I-J/i-j/; - - is($_, "i\xcaj", 'EBCDIC discontinuity'); -} -# - - -($x = 12) =~ tr/1/3/; -(my $y = 12) =~ tr/1/3/; -($f = 1.5) =~ tr/1/3/; -(my $g = 1.5) =~ tr/1/3/; -is($x + $y + $f + $g, 71, 'tr cancels IOK and NOK'); - -# /r -$_ = 'adam'; -is y/dam/ve/rd, 'eve', '/r'; -is $_, 'adam', '/r leaves param alone'; -$g = 'ruby'; -is $g =~ y/bury/repl/r, 'perl', '/r with explicit param'; -is $g, 'ruby', '/r leaves explicit param alone'; -is "aaa" =~ y\a\b\r, 'bbb', '/r with constant param'; -ok !eval '$_ !~ y///r', "!~ y///r is forbidden"; -like $@, qr\^Using !~ with tr///r doesn't make sense\, - "!~ y///r error message"; -{ - my $w; - my $wc; - local $SIG{__WARN__} = sub { $w = shift; ++$wc }; - local $^W = 1; - eval 'y///r; 1'; - like $w, qr '^Useless use of non-destructive transliteration \(tr///r\)', - '/r warns in void context'; - is $wc, 1, '/r warns just once'; -} - -# perlbug [ID 20000511.005] -$_ = 'fred'; -/([a-z]{2})/; -$1 =~ tr/A-Z//; -s/^(\s*)f/$1F/; -is($_, 'Fred', 'harmless if explicitly not updating'); - - -# A variant of the above, added in 5.7.2 -$_ = 'fred'; -/([a-z]{2})/; -eval '$1 =~ tr/A-Z/A-Z/;'; -s/^(\s*)f/$1F/; -is($_, 'Fred', 'harmless if implicitly not updating'); -is($@, '', ' no error'); - - -# check tr handles UTF8 correctly -($x = 256.65.258) =~ tr/a/b/; -is($x, 256.65.258, 'handles UTF8'); -is(length $x, 3); - -$x =~ tr/A/B/; -is(length $x, 3); -if (ord("\t") == 9) { # ASCII - is($x, 256.66.258); -} -else { - is($x, 256.65.258); -} - -# EBCDIC variants of the above tests -($x = 256.193.258) =~ tr/a/b/; -is(length $x, 3); -is($x, 256.193.258); - -$x =~ tr/A/B/; -is(length $x, 3); -if (ord("\t") == 9) { # ASCII - is($x, 256.193.258); -} -else { - is($x, 256.194.258); -} - - -{ - my $l = chr(300); my $r = chr(400); - $x = 200.300.400; - $x =~ tr/\x{12c}/\x{190}/; - is($x, 200.400.400, - 'changing UTF8 chars in a UTF8 string, same length'); - is(length $x, 3); - - $x = 200.300.400; - $x =~ tr/\x{12c}/\x{be8}/; - is($x, 200.3048.400, ' more bytes'); - is(length $x, 3); - - $x = 100.125.60; - $x =~ tr/\x{64}/\x{190}/; - is($x, 400.125.60, 'Putting UT8 chars into a non-UTF8 string'); - is(length $x, 3); - - $x = 400.125.60; - $x =~ tr/\x{190}/\x{64}/; - is($x, 100.125.60, 'Removing UTF8 chars from UTF8 string'); - is(length $x, 3); - - $x = 400.125.60.400; - $y = $x =~ tr/\x{190}/\x{190}/; - is($y, 2, 'Counting UTF8 chars in UTF8 string'); - - $x = 60.400.125.60.400; - $y = $x =~ tr/\x{3c}/\x{3c}/; - is($y, 2, ' non-UTF8 chars in UTF8 string'); - - # 17 - counting UTF8 chars in non-UTF8 string - $x = 200.125.60; - $y = $x =~ tr/\x{190}/\x{190}/; - is($y, 0, ' UTF8 chars in non-UTFs string'); -} - -$_ = "abcdefghijklmnopqrstuvwxyz"; -eval 'tr/a-z-9/ /'; -like($@, qr/^Ambiguous range in transliteration operator/, 'tr/a-z-9//'); - -# 19-21: Make sure leading and trailing hyphens still work -$_ = "car-rot9"; -tr/-a-m/./; -is($_, '..r.rot9', 'hyphens, leading'); - -$_ = "car-rot9"; -tr/a-m-/./; -is($_, '..r.rot9', ' trailing'); - -$_ = "car-rot9"; -tr/-a-m-/./; -is($_, '..r.rot9', ' both'); - -$_ = "abcdefghijklmnop"; -tr/ae-hn/./; -is($_, '.bcd....ijklm.op'); - -$_ = "abcdefghijklmnop"; -tr/a-cf-kn-p/./; -is($_, '...de......lm...'); - -$_ = "abcdefghijklmnop"; -tr/a-ceg-ikm-o/./; -is($_, '...d.f...j.l...p'); - - -# 20000705 MJD -eval "tr/m-d/ /"; -like($@, qr/^Invalid range "m-d" in transliteration operator/, - 'reversed range check'); - -'abcdef' =~ /(bcd)/; -is(eval '$1 =~ tr/abcd//', 3, 'explicit read-only count'); -is($@, '', ' no error'); - -'abcdef' =~ /(bcd)/; -is(eval '$1 =~ tr/abcd/abcd/', 3, 'implicit read-only count'); -is($@, '', ' no error'); - -is(eval '"123" =~ tr/12//', 2, 'LHS of non-updating tr'); - -eval '"123" =~ tr/1/2/'; -like($@, qr|^Can't modify constant item in transliteration \(tr///\)|, - 'LHS bad on updating tr'); - - -# v300 (0x12c) is UTF-8-encoded as 196 172 (0xc4 0xac) -# v400 (0x190) is UTF-8-encoded as 198 144 (0xc6 0x90) - -# Transliterate a byte to a byte, all four ways. - -($a = v300.196.172.300.196.172) =~ tr/\xc4/\xc5/; -is($a, v300.197.172.300.197.172, 'byte2byte transliteration'); - -($a = v300.196.172.300.196.172) =~ tr/\xc4/\x{c5}/; -is($a, v300.197.172.300.197.172); - -($a = v300.196.172.300.196.172) =~ tr/\x{c4}/\xc5/; -is($a, v300.197.172.300.197.172); - -($a = v300.196.172.300.196.172) =~ tr/\x{c4}/\x{c5}/; -is($a, v300.197.172.300.197.172); - - -($a = v300.196.172.300.196.172) =~ tr/\xc4/\x{12d}/; -is($a, v300.301.172.300.301.172, 'byte2wide transliteration'); - -($a = v300.196.172.300.196.172) =~ tr/\x{12c}/\xc3/; -is($a, v195.196.172.195.196.172, ' wide2byte'); - -($a = v300.196.172.300.196.172) =~ tr/\x{12c}/\x{12d}/; -is($a, v301.196.172.301.196.172, ' wide2wide'); - - -($a = v300.196.172.300.196.172) =~ tr/\xc4\x{12c}/\x{12d}\xc3/; -is($a, v195.301.172.195.301.172, 'byte2wide & wide2byte'); - - -($a = v300.196.172.300.196.172.400.198.144) =~ - tr/\xac\xc4\x{12c}\x{190}/\xad\x{12d}\xc5\x{191}/; -is($a, v197.301.173.197.301.173.401.198.144, 'all together now!'); - - -is((($a = v300.196.172.300.196.172) =~ tr/\xc4/\xc5/), 2, - 'transliterate and count'); - -is((($a = v300.196.172.300.196.172) =~ tr/\x{12c}/\x{12d}/), 2); - - -($a = v300.196.172.300.196.172) =~ tr/\xc4/\x{12d}/c; -is($a, v301.196.301.301.196.301, 'translit w/complement'); - -($a = v300.196.172.300.196.172) =~ tr/\x{12c}/\xc5/c; -is($a, v300.197.197.300.197.197); - - -($a = v300.196.172.300.196.172) =~ tr/\xc4//d; -is($a, v300.172.300.172, 'translit w/deletion'); - -($a = v300.196.172.300.196.172) =~ tr/\x{12c}//d; -is($a, v196.172.196.172); - - -($a = v196.196.172.300.300.196.172) =~ tr/\xc4/\xc5/s; -is($a, v197.172.300.300.197.172, 'translit w/squeeze'); - -($a = v196.172.300.300.196.172.172) =~ tr/\x{12c}/\x{12d}/s; -is($a, v196.172.301.196.172.172); - - -# Tricky cases (When Simon Cozens Attacks) -($a = v196.172.200) =~ tr/\x{12c}/a/; -is(sprintf("%vd", $a), '196.172.200'); - -($a = v196.172.200) =~ tr/\x{12c}/\x{12c}/; -is(sprintf("%vd", $a), '196.172.200'); - -($a = v196.172.200) =~ tr/\x{12c}//d; -is(sprintf("%vd", $a), '196.172.200'); - - -# UTF8 range tests from Inaba Hiroto - -# Not working in EBCDIC as of 12674. -($a = v300.196.172.302.197.172) =~ tr/\x{12c}-\x{130}/\xc0-\xc4/; -is($a, v192.196.172.194.197.172, 'UTF range'); - -($a = v300.196.172.302.197.172) =~ tr/\xc4-\xc8/\x{12c}-\x{130}/; -is($a, v300.300.172.302.301.172); - - -# UTF8 range tests from Karsten Sperling (patch #9008 required) - -($a = "\x{0100}") =~ tr/\x00-\x{100}/X/; -is($a, "X"); - -($a = "\x{0100}") =~ tr/\x{0000}-\x{00ff}/X/c; -is($a, "X"); - -($a = "\x{0100}") =~ tr/\x{0000}-\x{00ff}\x{0101}/X/c; -is($a, "X"); - -($a = v256) =~ tr/\x{0000}-\x{00ff}\x{0101}/X/c; -is($a, "X"); - - -# UTF8 range tests from Inaba Hiroto - -($a = "\x{200}") =~ tr/\x00-\x{100}/X/c; -is($a, "X"); - -($a = "\x{200}") =~ tr/\x00-\x{100}/X/cs; -is($a, "X"); - - -# Tricky on EBCDIC: while [a-z] [A-Z] must not match the gap characters, -# (i-j, r-s, I-J, R-S), [\x89-\x91] [\xc9-\xd1] has to match them, -# from Karsten Sperling. - -$c = ($a = "\x89\x8a\x8b\x8c\x8d\x8f\x90\x91") =~ tr/\x89-\x91/X/; -is($c, 8); -is($a, "XXXXXXXX"); - -$c = ($a = "\xc9\xca\xcb\xcc\xcd\xcf\xd0\xd1") =~ tr/\xc9-\xd1/X/; -is($c, 8); -is($a, "XXXXXXXX"); - -SKIP: { - skip "not EBCDIC", 4 unless $Is_EBCDIC; - - $c = ($a = "\x89\x8a\x8b\x8c\x8d\x8f\x90\x91") =~ tr/i-j/X/; - is($c, 2); - is($a, "X\x8a\x8b\x8c\x8d\x8f\x90X"); - - $c = ($a = "\xc9\xca\xcb\xcc\xcd\xcf\xd0\xd1") =~ tr/I-J/X/; - is($c, 2); - is($a, "X\xca\xcb\xcc\xcd\xcf\xd0X"); -} - -($a = "\x{100}") =~ tr/\x00-\xff/X/c; -is(ord($a), ord("X")); - -($a = "\x{100}") =~ tr/\x00-\xff/X/cs; -is(ord($a), ord("X")); - -($a = "\x{100}\x{100}") =~ tr/\x{101}-\x{200}//c; -is($a, "\x{100}\x{100}"); - -($a = "\x{100}\x{100}") =~ tr/\x{101}-\x{200}//cs; -is($a, "\x{100}"); - -$a = "\xfe\xff"; $a =~ tr/\xfe\xff/\x{1ff}\x{1fe}/; -is($a, "\x{1ff}\x{1fe}"); - - -# From David Dyck -($a = "R0_001") =~ tr/R_//d; -is(hex($a), 1); - -# From Inaba Hiroto -@a = (1,2); map { y/1/./ for $_ } @a; -is("@a", ". 2"); - -@a = (1,2); map { y/1/./ for $_.'' } @a; -is("@a", "1 2"); - - -# Additional test for Inaba Hiroto patch (robin@kitsite.com) -($a = "\x{100}\x{102}\x{101}") =~ tr/\x00-\377/XYZ/c; -is($a, "XZY"); - - -# Used to fail with "Modification of a read-only value attempted" -%a = (N=>1); -foreach (keys %a) { - eval 'tr/N/n/'; - is($_, 'n', 'pp_trans needs to unshare shared hash keys'); - is($@, '', ' no error'); -} - - -$x = eval '"1213" =~ tr/1/1/'; -is($x, 2, 'implicit count on constant'); -is($@, '', ' no error'); - - -my @foo = (); -eval '$foo[-1] =~ tr/N/N/'; -is( $@, '', 'implicit count outside array bounds, index negative' ); -is( scalar @foo, 0, " doesn't extend the array"); - -eval '$foo[1] =~ tr/N/N/'; -is( $@, '', 'implicit count outside array bounds, index positive' ); -is( scalar @foo, 0, " doesn't extend the array"); - - -my %foo = (); -eval '$foo{bar} =~ tr/N/N/'; -is( $@, '', 'implicit count outside hash bounds' ); -is( scalar keys %foo, 0, " doesn't extend the hash"); - -$x = \"foo"; -is( $x =~ tr/A/A/, 2, 'non-modifying tr/// on a scalar ref' ); -is( ref $x, 'SCALAR', " doesn't stringify its argument" ); - -# rt.perl.org 36622. Perl didn't like a y/// at end of file. No trailing -# newline allowed. -fresh_perl_is(q[$_ = "foo"; y/A-Z/a-z/], ''); - - -{ # [perl #38293] chr(65535) should be allowed in regexes -no warnings 'utf8'; # to allow non-characters - -$s = "\x{d800}\x{ffff}"; -$s =~ tr/\0/A/; -is($s, "\x{d800}\x{ffff}", "do_trans_simple"); - -$s = "\x{d800}\x{ffff}"; -$i = $s =~ tr/\0//; -is($i, 0, "do_trans_count"); - -$s = "\x{d800}\x{ffff}"; -$s =~ tr/\0/A/s; -is($s, "\x{d800}\x{ffff}", "do_trans_complex, SQUASH"); - -$s = "\x{d800}\x{ffff}"; -$s =~ tr/\0/A/c; -is($s, "AA", "do_trans_complex, COMPLEMENT"); - -$s = "A\x{ffff}B"; -$s =~ tr/\x{ffff}/\x{1ffff}/; -is($s, "A\x{1ffff}B", "utf8, SEARCHLIST"); - -$s = "\x{fffd}\x{fffe}\x{ffff}"; -$s =~ tr/\x{fffd}-\x{ffff}/ABC/; -is($s, "ABC", "utf8, SEARCHLIST range"); - -$s = "ABC"; -$s =~ tr/ABC/\x{ffff}/; -is($s, "\x{ffff}"x3, "utf8, REPLACEMENTLIST"); - -$s = "ABC"; -$s =~ tr/ABC/\x{fffd}-\x{ffff}/; -is($s, "\x{fffd}\x{fffe}\x{ffff}", "utf8, REPLACEMENTLIST range"); - -$s = "A\x{ffff}B\x{100}\0\x{fffe}\x{ffff}"; -$i = $s =~ tr/\x{ffff}//; -is($i, 2, "utf8, count"); - -$s = "A\x{ffff}\x{ffff}C"; -$s =~ tr/\x{ffff}/\x{100}/s; -is($s, "A\x{100}C", "utf8, SQUASH"); - -$s = "A\x{ffff}\x{ffff}\x{fffe}\x{fffe}\x{fffe}C"; -$s =~ tr/\x{fffe}\x{ffff}//s; -is($s, "A\x{ffff}\x{fffe}C", "utf8, SQUASH"); - -$s = "xAABBBy"; -$s =~ tr/AB/\x{ffff}/s; -is($s, "x\x{ffff}y", "utf8, SQUASH"); - -$s = "xAABBBy"; -$s =~ tr/AB/\x{fffe}\x{ffff}/s; -is($s, "x\x{fffe}\x{ffff}y", "utf8, SQUASH"); - -$s = "A\x{ffff}B\x{fffe}C"; -$s =~ tr/\x{fffe}\x{ffff}/x/c; -is($s, "x\x{ffff}x\x{fffe}x", "utf8, COMPLEMENT"); - -$s = "A\x{10000}B\x{2abcd}C"; -$s =~ tr/\0-\x{ffff}/x/c; -is($s, "AxBxC", "utf8, COMPLEMENT range"); - -$s = "A\x{fffe}B\x{ffff}C"; -$s =~ tr/\x{fffe}\x{ffff}/x/d; -is($s, "AxBC", "utf8, DELETE"); - -} # non-characters end - -{ # related to [perl #27940] - my $c; - - ($c = "\x20\c@\x30\cA\x40\cZ\x50\c_\x60") =~ tr/\c@-\c_//d; - is($c, "\x20\x30\x40\x50\x60", "tr/\\c\@-\\c_//d"); - - ($c = "\x20\x00\x30\x01\x40\x1A\x50\x1F\x60") =~ tr/\x00-\x1f//d; - is($c, "\x20\x30\x40\x50\x60", "tr/\\x00-\\x1f//d"); -} - -my ($s) = keys %{{pie => 3}}; # must be my'd or it does not remain RO -my $wasro = Internals::SvREADONLY($s); -{ - $wasro or local $TODO = "didn't have a COW"; - $s =~ tr/i//; - ok( Internals::SvREADONLY($s), "count-only tr doesn't deCOW COWs" ); -} - -# [ RT #61520 ] -# -# under threads, unicode tr within a cloned closure would SEGV or assert -# fail, since the pointer in the pad to the swash was getting zeroed out -# in the proto-CV - -{ - my $x = "\x{142}"; - sub { - $x =~ tr[\x{142}][\x{143}]; - }->(); - is($x,"\x{143}", "utf8 + closure"); -} - - diff --git a/t/CORE/op/turkish.t b/t/CORE/op/turkish.t deleted file mode 100644 index 6a52e71bf..000000000 --- a/t/CORE/op/turkish.t +++ /dev/null @@ -1,99 +0,0 @@ -# Verifies that can implement Turkish casing as defined by Unicode 5.2. - -use Config; - -BEGIN { - unshift @INC, 't/CORE/lib'; - require 't/CORE/test.pl'; -} - -use subs qw(lc lcfirst uc ucfirst); - -sub uc($) { - my $string = shift; - utf8::upgrade($string); - return CORE::uc($string); -} - -sub ucfirst($) { - my $string = shift; - utf8::upgrade($string); - return CORE::ucfirst($string); -} - -sub lc($) { - my $string = shift; - utf8::upgrade($string); - - # Unless an I is before a dot_above, it turns into a dotless i. - $string =~ s/I (?! [^\p{ccc=0}\p{ccc=Above}]* \x{0307} )/\x{131}/gx; - - # But when the I is followed by a dot_above, remove the dot_above so - # the end result will be i. - $string =~ s/I ([^\p{ccc=0}\p{ccc=Above}]* ) \x{0307}/i$1/gx; - return CORE::lc($string); -} - -sub lcfirst($) { - my $string = shift; - utf8::upgrade($string); - - # Unless an I is before a dot_above, it turns into a dotless i. - $string =~ s/^I (?! [^\p{ccc=0}\p{ccc=Above}]* \x{0307} )/\x{131}/x; - - # But when the I is followed by a dot_above, remove the dot_above so - # the end result will be i. - $string =~ s/^I ([^\p{ccc=0}\p{ccc=Above}]* ) \x{0307}/i$1/x; - return CORE::lcfirst($string); -} - -plan tests => 22; - -my $map_directory = "$Config{privlib}/unicore/To"; -my $upper = "$map_directory/Upper.pl"; -my $lower = "$map_directory/Lower.pl"; -my $title = "$map_directory/Title.pl"; - -sub ToUpper { - my $official = do $upper; - $utf8::ToSpecUpper{'i'} = "\x{0130}"; - return $official; -} - -sub ToTitle { - my $official = do $title; - $utf8::ToSpecTitle{'i'} = "\x{0130}"; - return $official; -} - -sub ToLower { - my $official = do $lower; - $utf8::ToSpecLower{"\xc4\xb0"} = "i"; - return $official; -} - -is(uc("\x{DF}\x{DF}"), "SSSS", "Verify that uc of non-overridden multi-char works"); -is(uc("aa"), "AA", "Verify that uc of non-overridden ASCII works"); -is(uc("\x{101}\x{101}"), "\x{100}\x{100}", "Verify that uc of non-overridden utf8 works"); -is(uc("ii"), "\x{130}\x{130}", "Verify uc('ii') eq \\x{130}\\x{130}"); - -is(ucfirst("\x{DF}\x{DF}"), "Ss\x{DF}", "Verify that ucfirst of non-overridden multi-char works"); -is(ucfirst("\x{101}\x{101}"), "\x{100}\x{101}", "Verify that ucfirst of non-overridden utf8 works"); -is(ucfirst("aa"), "Aa", "Verify that ucfirst of non-overridden ASCII works"); -is(ucfirst("ii"), "\x{130}i", "Verify ucfirst('ii') eq \"\\x{130}i\""); - -is(lc("AA"), "aa", "Verify that lc of non-overridden ASCII works"); -is(lc("\x{C0}\x{C0}"), "\x{E0}\x{E0}", "Verify that lc of non-overridden latin1 works"); -is(lc("\x{0178}\x{0178}"), "\x{FF}\x{FF}", "Verify that lc of non-overridden utf8 works"); -is(lc("II"), "\x{131}\x{131}", "Verify that lc('I') eq \\x{131}"); -is(lc("IG\x{0307}IG\x{0307}"), "\x{131}g\x{0307}\x{131}g\x{0307}", "Verify that lc(\"I...\\x{0307}\") eq \"\\x{131}...\\x{0307}\""); -is(lc("I\x{0307}I\x{0307}"), "ii", "Verify that lc(\"I\\x{0307}\") removes the \\x{0307}, leaving 'i'"); -is(lc("\x{130}\x{130}"), "ii", "Verify that lc(\"\\x{130}\\x{130}\") eq 'ii'"); - -is(lcfirst("AA"), "aA", "Verify that lcfirst of non-overridden ASCII works"); -is(lcfirst("\x{C0}\x{C0}"), "\x{E0}\x{C0}", "Verify that lcfirst of non-overridden latin1 works"); -is(lcfirst("\x{0178}\x{0178}"), "\x{FF}\x{0178}", "Verify that lcfirst of non-overridden utf8 works"); -is(lcfirst("I"), "\x{131}", "Verify that lcfirst('II') eq \"\\x{131}I\""); -is(lcfirst("IG\x{0307}"), "\x{131}G\x{0307}", "Verify that lcfirst(\"I...\\x{0307}\") eq \"\\x{131}...\\x{0307}\""); -is(lcfirst("I\x{0307}I\x{0307}"), "iI\x{0307}", "Verify that lcfirst(\"I\\x{0307}I\\x{0307}\") removes the first \\x{0307}, leaving 'iI\\x{0307}'"); -is(lcfirst("\x{130}\x{130}"), "i\x{130}", "Verify that lcfirst(\"\\x{130}\\x{130}\") eq \"i\\x{130}\""); diff --git a/t/CORE/op/undef.t b/t/CORE/op/undef.t deleted file mode 100644 index 59e6edb79..000000000 --- a/t/CORE/op/undef.t +++ /dev/null @@ -1,131 +0,0 @@ -#!./perl - -BEGIN { - unshift @INC, 't/CORE/lib'; - require 't/CORE/test.pl'; -} - -use strict; - -use vars qw(@ary %ary %hash); - -plan 40; - -ok !defined($a); - -$a = 1+1; -ok defined($a); - -undef $a; -ok !defined($a); - -$a = "hi"; -ok defined($a); - -$a = $b; -ok !defined($a); - -@ary = ("1arg"); -$a = pop(@ary); -ok defined($a); -$a = pop(@ary); -ok !defined($a); - -@ary = ("1arg"); -$a = shift(@ary); -ok defined($a); -$a = shift(@ary); -ok !defined($a); - -$ary{'foo'} = 'hi'; -ok defined($ary{'foo'}); -ok !defined($ary{'bar'}); -undef $ary{'foo'}; -ok !defined($ary{'foo'}); - -ok defined(@ary); -{ - no warnings 'deprecated'; - ok defined(%ary); -} -ok %ary; -undef @ary; -ok !defined(@ary); -undef %ary; -{ - no warnings 'deprecated'; - ok !defined(%ary); -} -ok !%ary; -@ary = (1); -ok defined @ary; -%ary = (1,1); -{ - no warnings 'deprecated'; - ok defined %ary; -} -ok %ary; - -sub foo { pass; 1 } - -&foo || fail; - -ok defined &foo; -undef &foo; -ok !defined(&foo); - -eval { undef $1 }; -like $@, qr/^Modification of a read/; - -eval { $1 = undef }; -like $@, qr/^Modification of a read/; - -{ - require Tie::Hash; - tie my %foo, 'Tie::StdHash'; - no warnings 'deprecated'; - ok defined %foo; - %foo = ( a => 1 ); - ok defined %foo; -} - -{ - require Tie::Array; - tie my @foo, 'Tie::StdArray'; - no warnings 'deprecated'; - ok defined @foo; - @foo = ( a => 1 ); - ok defined @foo; -} - -{ - # [perl #17753] segfault when undef'ing unquoted string constant - eval 'undef tcp'; - like $@, qr/^Can't modify constant item/; -} - -# bugid 3096 -# undefing a hash may free objects with destructors that then try to -# modify the hash. To them, the hash should appear empty. - -%hash = ( - key1 => bless({}, 'X'), - key2 => bless({}, 'X'), -); -undef %hash; -sub X::DESTROY { - is scalar keys %hash, 0; - is scalar values %hash, 0; - my @l = each %hash; - is @l, 0; - is delete $hash{'key2'}, undef; -} - -# this will segfault if it fails - -sub PVBM () { 'foo' } -{ my $dummy = index 'foo', PVBM } - -my $pvbm = PVBM; -undef $pvbm; -ok !defined $pvbm; diff --git a/t/CORE/op/universal.t b/t/CORE/op/universal.t deleted file mode 100644 index bfcf5fc85..000000000 --- a/t/CORE/op/universal.t +++ /dev/null @@ -1,316 +0,0 @@ -#!./perl -# -# check UNIVERSAL -# - -BEGIN { - unshift @INC, 't/CORE/lib'; - $| = 1; - require 't/CORE/test.pl'; -} - -plan tests => 125; - -$a = {}; -bless $a, "Bob"; -ok $a->isa("Bob"); - -package Human; -sub eat {} - -package Female; -@ISA=qw(Human); - -package Alice; -@ISA=qw(Bob Female); -sub sing; -sub drink { return "drinking " . $_[1] } -sub new { bless {} } - -$Alice::VERSION = 2.718; - -{ - package Cedric; - our @ISA; - use base qw(Human); -} - -{ - package Programmer; - our $VERSION = 1.667; - - sub write_perl { 1 } -} - -package main; - - - -$a = new Alice; - -ok $a->isa("Alice"); -ok $a->isa("main::Alice"); # check that alternate class names work - -ok(("main::Alice"->new)->isa("Alice")); - -ok $a->isa("Bob"); -ok $a->isa("main::Bob"); - -ok $a->isa("Female"); - -ok $a->isa("Human"); - -ok ! $a->isa("Male"); - -ok ! $a->isa('Programmer'); - -ok $a->isa("HASH"); - -ok $a->can("eat"); -ok ! $a->can("sleep"); -ok my $ref = $a->can("drink"); # returns a coderef -is $a->$ref("tea"), "drinking tea"; # ... which works -ok $ref = $a->can("sing"); -eval { $a->$ref() }; -ok $@; # ... but not if no actual subroutine - -ok (!Cedric->isa('Programmer')); - -ok (Cedric->isa('Human')); - -push(@Cedric::ISA,'Programmer'); - -ok (Cedric->isa('Programmer')); - -{ - package Alice; - base::->import('Programmer'); -} - -ok $a->isa('Programmer'); -ok $a->isa("Female"); - -@Cedric::ISA = qw(Bob); - -ok (!Cedric->isa('Programmer')); - -my $b = 'abc'; -my @refs = qw(SCALAR SCALAR LVALUE GLOB ARRAY HASH CODE); -my @vals = ( \$b, \3.14, \substr($b,1,1), \*b, [], {}, sub {} ); -for ($p=0; $p < @refs; $p++) { - for ($q=0; $q < @vals; $q++) { - is UNIVERSAL::isa($vals[$p], $refs[$q]), ($p==$q or $p+$q==1); - }; -}; - -ok ! UNIVERSAL::can(23, "can"); - -ok $a->can("VERSION"); - -ok $a->can("can"); -ok ! $a->can("export_tags"); # a method in Exporter - -cmp_ok eval { $a->VERSION }, '==', 2.718; - -ok ! (eval { $a->VERSION(2.719) }); -like $@, qr/^Alice version 2.719 required--this is only version 2.718 at /; - -ok (eval { $a->VERSION(2.718) }); -is $@, ''; - -my $subs = join ' ', sort grep { defined &{"UNIVERSAL::$_"} } keys %UNIVERSAL::; -## The test for import here is *not* because we want to ensure that UNIVERSAL -## can always import; it is an historical accident that UNIVERSAL can import. -if ('a' lt 'A') { - is $subs, "can import isa DOES VERSION"; -} else { - is $subs, "DOES VERSION can import isa"; -} - -ok $a->isa("UNIVERSAL"); - -ok ! UNIVERSAL::isa([], "UNIVERSAL"); - -ok ! UNIVERSAL::can({}, "can"); - -ok UNIVERSAL::isa(Alice => "UNIVERSAL"); - -cmp_ok UNIVERSAL::can(Alice => "can"), '==', \&UNIVERSAL::can; - -# now use UNIVERSAL.pm and see what changes -eval "use UNIVERSAL"; - -ok $a->isa("UNIVERSAL"); - -my $sub2 = join ' ', sort grep { defined &{"UNIVERSAL::$_"} } keys %UNIVERSAL::; -# XXX import being here is really a bug -if ('a' lt 'A') { - is $sub2, "can import isa DOES VERSION"; -} else { - is $sub2, "DOES VERSION can import isa"; -} - -eval 'sub UNIVERSAL::sleep {}'; -ok $a->can("sleep"); - -ok ! UNIVERSAL::can($b, "can"); - -ok ! $a->can("export_tags"); # a method in Exporter - -ok ! UNIVERSAL::isa("\xff\xff\xff\0", 'HASH'); - -{ - package Pickup; - use UNIVERSAL qw( isa can VERSION ); - - ::ok isa "Pickup", UNIVERSAL; - ::cmp_ok can( "Pickup", "can" ), '==', \&UNIVERSAL::can; - ::ok VERSION "UNIVERSAL" ; -} - -{ - # test isa() and can() on magic variables - "Human" =~ /(.*)/; - ok $1->isa("Human"); - ok $1->can("eat"); - package HumanTie; - sub TIESCALAR { bless {} } - sub FETCH { "Human" } - tie my($x), "HumanTie"; - ::ok $x->isa("Human"); - ::ok $x->can("eat"); -} - -# bugid 3284 -# a second call to isa('UNIVERSAL') when @ISA is null failed due to caching - -@X::ISA=(); -my $x = {}; bless $x, 'X'; -ok $x->isa('UNIVERSAL'); -ok $x->isa('UNIVERSAL'); - - -# Check that the "historical accident" of UNIVERSAL having an import() -# method doesn't effect anyone else. -eval { Some::Package->import("bar") }; -is $@, ''; - - -# This segfaulted in a blead. -fresh_perl_is('package Foo; Foo->VERSION; print "ok"', 'ok'); - -# So did this. -fresh_perl_is('$:; UNIVERSAL::isa(":","Unicode::String");print "ok"','ok'); - -package Foo; - -sub DOES { 1 } - -package Bar; - -@Bar::ISA = 'Foo'; - -package Baz; - -package main; -ok( Foo->DOES( 'bar' ), 'DOES() should call DOES() on class' ); -ok( Bar->DOES( 'Bar' ), '... and should fall back to isa()' ); -ok( Bar->DOES( 'Foo' ), '... even when inherited' ); -ok( Baz->DOES( 'Baz' ), '... even without inheriting any other DOES()' ); -ok( ! Baz->DOES( 'Foo' ), '... returning true or false appropriately' ); - -package Pig; -package Bodine; -Bodine->isa('Pig'); -*isa = \&UNIVERSAL::isa; -eval { isa({}, 'HASH') }; -::is($@, '', "*isa correctly found"); - -package main; -eval { UNIVERSAL::DOES([], "foo") }; -like( $@, qr/Can't call method "DOES" on unblessed reference/, - 'DOES call error message says DOES, not isa' ); - -# Tests for can seem to be split between here and method.t -# Add the verbatim perl code mentioned in the comments of -# http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2001-05/msg01710.html -# but never actually tested. -is(UNIVERSAL->can("NoSuchPackage::foo"), undef); - -@splatt::ISA = 'zlopp'; -ok (splatt->isa('zlopp')); -ok (!splatt->isa('plop')); - -# This should reset the ->isa lookup cache -@splatt::ISA = 'plop'; -# And here is the new truth. -ok (!splatt->isa('zlopp')); -ok (splatt->isa('plop')); - -use warnings "deprecated"; -{ - my $m; - local $SIG{__WARN__} = sub { $m = $_[0] }; - eval "use UNIVERSAL 'can'"; - like($m, qr/^UNIVERSAL->import is deprecated/, - "deprecation warning for UNIVERSAL->import('can')"); - - undef $m; - eval "use UNIVERSAL"; - is($m, undef, - "no deprecation warning for UNIVERSAL->import"); -} - -# Test: [perl #66112]: change @ISA inside sub isa -{ - package RT66112::A; - - package RT66112::B; - - sub isa { - my $self = shift; - @ISA = qw/RT66112::A/; - return $self->SUPER::isa(@_); - } - - package RT66112::C; - - package RT66112::D; - - sub isa { - my $self = shift; - @RT66112::E::ISA = qw/RT66112::A/; - return $self->SUPER::isa(@_); - } - - package RT66112::E; - - package main; - - @RT66112::B::ISA = qw//; - @RT66112::C::ISA = qw/RT66112::B/; - @RT66112::T1::ISA = qw/RT66112::C/; - ok(RT66112::T1->isa('RT66112::C'), "modify \@ISA in isa (RT66112::T1 isa RT66112::C)"); - - @RT66112::B::ISA = qw//; - @RT66112::C::ISA = qw/RT66112::B/; - @RT66112::T2::ISA = qw/RT66112::C/; - ok(RT66112::T2->isa('RT66112::B'), "modify \@ISA in isa (RT66112::T2 isa RT66112::B)"); - - @RT66112::B::ISA = qw//; - @RT66112::C::ISA = qw/RT66112::B/; - @RT66112::T3::ISA = qw/RT66112::C/; - ok(RT66112::T3->isa('RT66112::A'), "modify \@ISA in isa (RT66112::T3 isa RT66112::A)") or require mro, diag "@{mro::get_linear_isa('RT66112::T3')}"; - - @RT66112::E::ISA = qw/RT66112::D/; - @RT66112::T4::ISA = qw/RT66112::E/; - ok(RT66112::T4->isa('RT66112::E'), "modify \@ISA in isa (RT66112::T4 isa RT66112::E)"); - - @RT66112::E::ISA = qw/RT66112::D/; - @RT66112::T5::ISA = qw/RT66112::E/; - ok(! RT66112::T5->isa('RT66112::D'), "modify \@ISA in isa (RT66112::T5 not isa RT66112::D)"); - - @RT66112::E::ISA = qw/RT66112::D/; - @RT66112::T6::ISA = qw/RT66112::E/; - ok(RT66112::T6->isa('RT66112::A'), "modify \@ISA in isa (RT66112::T6 isa RT66112::A)"); -} diff --git a/t/CORE/op/unshift.t b/t/CORE/op/unshift.t deleted file mode 100644 index 625096c53..000000000 --- a/t/CORE/op/unshift.t +++ /dev/null @@ -1,101 +0,0 @@ -#!./perl - -BEGIN { - require 't/CORE/test.pl'; -} - -plan(36); - -@array = (1, 2, 3); -$aref = [1, 2, 3]; - -{ - no warnings 'syntax'; - $count3 = unshift (@array); - $count3r = unshift ($aref); -} -is(join(' ',@array), '1 2 3', 'unshift null'); -cmp_ok($count3, '==', 3, 'unshift count == 3'); -is(join(' ',@$aref), '1 2 3', 'unshift null (ref)'); -cmp_ok($count3r, '==', 3, 'unshift count == 3 (ref)'); - - -$count3_2 = unshift (@array, ()); -is(join(' ',@array), '1 2 3', 'unshift null empty'); -cmp_ok($count3_2, '==', 3, 'unshift count == 3 again'); -$count3_2r = unshift ($aref, ()); -is(join(' ',@$aref), '1 2 3', 'unshift null empty (ref)'); -cmp_ok($count3_2r, '==', 3, 'unshift count == 3 again (ref)'); - -$count4 = unshift (@array, 0); -is(join(' ',@array), '0 1 2 3', 'unshift singleton list'); -cmp_ok($count4, '==', 4, 'unshift count == 4'); -$count4r = unshift ($aref, 0); -is(join(' ',@$aref), '0 1 2 3', 'unshift singleton list (ref)'); -cmp_ok($count4r, '==', 4, 'unshift count == 4 (ref)'); - -$count7 = unshift (@array, 3, 2, 1); -is(join(' ',@array), '3 2 1 0 1 2 3', 'unshift list'); -cmp_ok($count7, '==', 7, 'unshift count == 7'); -$count7r = unshift ($aref, 3, 2, 1); -is(join(' ',@$aref), '3 2 1 0 1 2 3', 'unshift list (ref)'); -cmp_ok($count7r, '==', 7, 'unshift count == 7 (ref)'); - -@list = (5, 4); -$count9 = unshift (@array, @list); -is(join(' ',@array), '5 4 3 2 1 0 1 2 3', 'unshift array'); -cmp_ok($count9, '==', 9, 'unshift count == 9'); -$count9r = unshift ($aref, @list); -is(join(' ',@$aref), '5 4 3 2 1 0 1 2 3', 'unshift array (ref)'); -cmp_ok($count9r, '==', 9, 'unshift count == 9 (ref)'); - - -@list = (7); -@list2 = (6); -$count11 = unshift (@array, @list, @list2); -is(join(' ',@array), '7 6 5 4 3 2 1 0 1 2 3', 'unshift arrays'); -cmp_ok($count11, '==', 11, 'unshift count == 11'); -$count11r = unshift ($aref, @list, @list2); -is(join(' ',@$aref), '7 6 5 4 3 2 1 0 1 2 3', 'unshift arrays (ref)'); -cmp_ok($count11r, '==', 11, 'unshift count == 11 (ref)'); - -# ignoring counts -@alpha = ('y', 'z'); -$alpharef = ['y', 'z']; - -{ - no warnings 'syntax'; - unshift (@alpha); - unshift ($alpharef); -} -is(join(' ',@alpha), 'y z', 'void unshift null'); -is(join(' ',@$alpharef), 'y z', 'void unshift null (ref)'); - -unshift (@alpha, ()); -is(join(' ',@alpha), 'y z', 'void unshift null empty'); -unshift ($alpharef, ()); -is(join(' ',@$alpharef), 'y z', 'void unshift null empty (ref)'); - -unshift (@alpha, 'x'); -is(join(' ',@alpha), 'x y z', 'void unshift singleton list'); -unshift ($alpharef, 'x'); -is(join(' ',@$alpharef), 'x y z', 'void unshift singleton list (ref)'); - -unshift (@alpha, 'u', 'v', 'w'); -is(join(' ',@alpha), 'u v w x y z', 'void unshift list'); -unshift ($alpharef, 'u', 'v', 'w'); -is(join(' ',@$alpharef), 'u v w x y z', 'void unshift list (ref)'); - -@bet = ('s', 't'); -unshift (@alpha, @bet); -is(join(' ',@alpha), 's t u v w x y z', 'void unshift array'); -unshift ($alpharef, @bet); -is(join(' ',@$alpharef), 's t u v w x y z', 'void unshift array (ref)'); - -@bet = ('q'); -@gimel = ('r'); -unshift (@alpha, @bet, @gimel); -is(join(' ',@alpha), 'q r s t u v w x y z', 'void unshift arrays'); -unshift ($alpharef, @bet, @gimel); -is(join(' ',@$alpharef), 'q r s t u v w x y z', 'void unshift arrays (ref)'); - diff --git a/t/CORE/op/upgrade.t b/t/CORE/op/upgrade.t deleted file mode 100644 index b2d40d74a..000000000 --- a/t/CORE/op/upgrade.t +++ /dev/null @@ -1,49 +0,0 @@ -#!./perl -w - -# Check that we can "upgrade" from anything to anything else. -# Curiously, before this, lib/Math/Trig.t was the only code anywhere in the -# build or testsuite that upgraded an NV to an RV - -BEGIN { - unshift @INC, 't/CORE/lib'; - require 't/CORE/test.pl'; -} - -use strict; - -my $null; - -$! = 1; -my %types = ( - null => $null, - iv => 3, - nv => .5, - rv => [], - pv => "Perl rules", - pviv => 3, - pvnv => 1==1, - pvmg => $^, -); - -# This is somewhat cheating but I can't think of anything built in that I can -# copy that already has type PVIV -$types{pviv} = "Perl rules!"; - -# use Devel::Peek; Dump $pvmg; - -my @keys = keys %types; -plan tests => @keys * @keys; - -foreach my $source_type (@keys) { - foreach my $dest_type (@keys) { - # Pads re-using variables might contaminate this - my $vars = {}; - $vars->{dest} = $types{$dest_type}; - $vars->{source} = $types{$source_type}; - # The assignment can potentially trigger assertion failures, so it's - # useful to have the diagnostics about what was attempted printed first - print "# Assigning $source_type to $dest_type\n"; - $vars->{dest} = $vars->{source}; - is ($vars->{dest}, $vars->{source}); - } -} diff --git a/t/CORE/op/utf8cache.t b/t/CORE/op/utf8cache.t deleted file mode 100644 index 4edaabb56..000000000 --- a/t/CORE/op/utf8cache.t +++ /dev/null @@ -1,35 +0,0 @@ -#!./perl -w -# Test for malfunctions of utf8 cache - -INIT { - unshift @INC, 't/CORE/lib'; - require 't/CORE/test.pl'; -} - -use strict; - -plan(tests => 1); - -my $pid = open CHILD, '-|'; -die "kablam: $!\n" unless defined $pid; -unless ($pid) { - open STDERR, ">&STDOUT"; - $a = "hello \x{1234}"; - for (1..2) { - bar(substr($a, $_, 1)); - } - sub bar { - $_[0] = "\x{4321}"; - Devel::Peek::Dump($_[0]); - } - exit; -} - -{ local $/; $_ = } - -my $utf8magic = qr{ ^ \s+ MAGIC \s = .* \n - \s+ MG_VIRTUAL \s = .* \n - \s+ MG_TYPE \s = \s PERL_MAGIC_utf8 .* \n - \s+ MG_LEN \s = .* \n }xm; - -unlike($_, qr{ $utf8magic $utf8magic }x); diff --git a/t/CORE/op/utf8decode.t b/t/CORE/op/utf8decode.t deleted file mode 100644 index edce104ab..000000000 --- a/t/CORE/op/utf8decode.t +++ /dev/null @@ -1,182 +0,0 @@ -#!./perl - -BEGIN { - unshift @INC, 't/CORE/lib'; - require 't/CORE/test.pl'; -} - -{ - my $wide = v256; - use bytes; - my $ordwide = ord($wide); - printf "# under use bytes ord(v256) = 0x%02x\n", $ordwide; - skip_all('UTF-EBCDIC (not UTF-8) used here') if $ordwide == 140; - - if ($ordwide != 196) { - printf "# v256 starts with 0x%02x\n", $ordwide; - } -} - -no utf8; - -foreach () { - if (/^(?:\d+(?:\.\d+)?)\s/ || /^#/) { - # print "# $_\n"; - } elsif (my ($id, $okay, $Unicode, $byteslen, $hex, $charslen, $experr) - = /^(\d+\.\d+\.\d+[bu]?) # ID - \s+(y|n|N-?\d+) # expect to pass or fail - \s+([0-9a-f]{1,8}(?:,[0-9a-f]{1,8})*|-) # Unicode characters - \s+(\d+) # number of octets - \s+([0-9a-f]{2}(?::[0-9a-f]{2})*) # octets in hex - \s+(\d+|-) # number of characters - (?:\s+(.+))? # expected error (or comment) - $/x) { - my @hex = split(/:/, $hex); - is(scalar @hex, $byteslen, 'Amount of hex tallies with byteslen'); - my $octets = join '', map {chr hex $_} @hex; - is(length $octets, $byteslen, 'Number of octets tallies with byteslen'); - if ($okay eq 'y') { - my @chars = map {hex $_} split ',', $Unicode; - is(scalar @chars, $charslen, 'Amount of hex tallies with charslen'); - my @got; - warning_is(sub {@got = unpack 'C0U*', $octets}, undef, - "No warnings expected for $id"); - is("@got", "@chars", 'Got expected Unicode characters'); - } elsif ($okay eq 'n') { - isnt($experr, '', "Expected warning for $id provided"); - warnings_like(sub {unpack 'C0U*', $octets}, [qr/$experr/], - "Only expected warning for $id"); - } elsif ($okay !~ /^N(-?\d+)/) { - is($okay, 'n', "Confused test description for $id"); - } else { - my $expect = $1; - my @warnings; - - { - local $SIG{__WARN__} = sub { - print "# $id: @_"; - push @warnings, "@_"; - }; - unpack 'C0U*', $octets; - } - - isnt($experr, '', "Expected first warning for $id provided"); - like($warnings[0], qr/$experr/, "Expected first warning for $id seen"); - local $::TODO; - if ($expect < 0) { - $expect = -$expect; - $::TODO = "Markus Kuhn states that $expect invalid sequences should be signalled"; - } - is(scalar @warnings, $expect, "Expected number of warnings for $id seen"); - } - } else { - fail("unknown format '$_'"); - } -} - -done_testing(); - -# This table is based on Markus Kuhn's UTF-8 Decode Stress Tester, -# http://www.cl.cam.ac.uk/~mgk25/ucs/examples/UTF-8-test.txt, -# version dated 2000-09-02. - -__DATA__ -1 Correct UTF-8 -1.1.1 y 3ba,1f79,3c3,3bc,3b5 11 ce:ba:e1:bd:b9:cf:83:ce:bc:ce:b5 5 -2 Boundary conditions -2.1 First possible sequence of certain length -2.1.1 y 0 1 00 1 -2.1.2 y 80 2 c2:80 1 -2.1.3 y 800 3 e0:a0:80 1 -2.1.4 y 10000 4 f0:90:80:80 1 -2.1.5 y 200000 5 f8:88:80:80:80 1 -2.1.6 y 4000000 6 fc:84:80:80:80:80 1 -2.2 Last possible sequence of certain length -2.2.1 y 7f 1 7f 1 -2.2.2 y 7ff 2 df:bf 1 -# The ffff is legal by default since 872c91ae155f6880 -2.2.3 y ffff 3 ef:bf:bf 1 character 0xffff -2.2.4 y 1fffff 4 f7:bf:bf:bf 1 -2.2.5 y 3ffffff 5 fb:bf:bf:bf:bf 1 -2.2.6 y 7fffffff 6 fd:bf:bf:bf:bf:bf 1 -2.3 Other boundary conditions -2.3.1 y d7ff 3 ed:9f:bf 1 -2.3.2 y e000 3 ee:80:80 1 -2.3.3 y fffd 3 ef:bf:bd 1 -2.3.4 y 10ffff 4 f4:8f:bf:bf 1 -2.3.5 y 110000 4 f4:90:80:80 1 -3 Malformed sequences -3.1 Unexpected continuation bytes -3.1.1 n - 1 80 - unexpected continuation byte 0x80 -3.1.2 n - 1 bf - unexpected continuation byte 0xbf -3.1.3 N2 - 2 80:bf - unexpected continuation byte 0x80 -3.1.4 N3 - 3 80:bf:80 - unexpected continuation byte 0x80 -3.1.5 N4 - 4 80:bf:80:bf - unexpected continuation byte 0x80 -3.1.6 N5 - 5 80:bf:80:bf:80 - unexpected continuation byte 0x80 -3.1.7 N6 - 6 80:bf:80:bf:80:bf - unexpected continuation byte 0x80 -3.1.8 N7 - 7 80:bf:80:bf:80:bf:80 - unexpected continuation byte 0x80 -3.1.9 N64 - 64 80:81:82:83:84:85:86:87:88:89:8a:8b:8c:8d:8e:8f:90:91:92:93:94:95:96:97:98:99:9a:9b:9c:9d:9e:9f:a0:a1:a2:a3:a4:a5:a6:a7:a8:a9:aa:ab:ac:ad:ae:af:b0:b1:b2:b3:b4:b5:b6:b7:b8:b9:ba:bb:bc:bd:be:bf - unexpected continuation byte 0x80 -3.2 Lonely start characters -3.2.1 N32 - 64 c0:20:c1:20:c2:20:c3:20:c4:20:c5:20:c6:20:c7:20:c8:20:c9:20:ca:20:cb:20:cc:20:cd:20:ce:20:cf:20:d0:20:d1:20:d2:20:d3:20:d4:20:d5:20:d6:20:d7:20:d8:20:d9:20:da:20:db:20:dc:20:dd:20:de:20:df:20 - unexpected non-continuation byte 0x20, immediately after start byte 0xc0 -3.2.2 N16 - 32 e0:20:e1:20:e2:20:e3:20:e4:20:e5:20:e6:20:e7:20:e8:20:e9:20:ea:20:eb:20:ec:20:ed:20:ee:20:ef:20 - unexpected non-continuation byte 0x20, immediately after start byte 0xe0 -3.2.3 N8 - 16 f0:20:f1:20:f2:20:f3:20:f4:20:f5:20:f6:20:f7:20 - unexpected non-continuation byte 0x20, immediately after start byte 0xf0 -3.2.4 N4 - 8 f8:20:f9:20:fa:20:fb:20 - unexpected non-continuation byte 0x20, immediately after start byte 0xf8 -3.2.5 N2 - 4 fc:20:fd:20 - unexpected non-continuation byte 0x20, immediately after start byte 0xfc -3.3 Sequences with last continuation byte missing -3.3.1 n - 1 c0 - 1 byte, need 2 -3.3.2 n - 2 e0:80 - 2 bytes, need 3 -3.3.3 n - 3 f0:80:80 - 3 bytes, need 4 -3.3.4 n - 4 f8:80:80:80 - 4 bytes, need 5 -3.3.5 n - 5 fc:80:80:80:80 - 5 bytes, need 6 -3.3.6 n - 1 df - 1 byte, need 2 -3.3.7 n - 2 ef:bf - 2 bytes, need 3 -3.3.8 n - 3 f7:bf:bf - 3 bytes, need 4 -3.3.9 n - 4 fb:bf:bf:bf - 4 bytes, need 5 -3.3.10 n - 5 fd:bf:bf:bf:bf - 5 bytes, need 6 -3.4 Concatenation of incomplete sequences -3.4.1 N-10 - 30 c0:e0:80:f0:80:80:f8:80:80:80:fc:80:80:80:80:df:ef:bf:f7:bf:bf:fb:bf:bf:bf:fd:bf:bf:bf:bf - unexpected non-continuation byte 0xe0, immediately after start byte 0xc0 -3.5 Impossible bytes -3.5.1 n - 1 fe - byte 0xfe -3.5.2 n - 1 ff - byte 0xff -3.5.3 N4 - 4 fe:fe:ff:ff - byte 0xfe -4 Overlong sequences -4.1 Examples of an overlong ASCII character -4.1.1 n - 2 c0:af - 2 bytes, need 1 -4.1.2 n - 3 e0:80:af - 3 bytes, need 1 -4.1.3 n - 4 f0:80:80:af - 4 bytes, need 1 -4.1.4 n - 5 f8:80:80:80:af - 5 bytes, need 1 -4.1.5 n - 6 fc:80:80:80:80:af - 6 bytes, need 1 -4.2 Maximum overlong sequences -4.2.1 n - 2 c1:bf - 2 bytes, need 1 -4.2.2 n - 3 e0:9f:bf - 3 bytes, need 2 -4.2.3 n - 4 f0:8f:bf:bf - 4 bytes, need 3 -4.2.4 n - 5 f8:87:bf:bf:bf - 5 bytes, need 4 -4.2.5 n - 6 fc:83:bf:bf:bf:bf - 6 bytes, need 5 -4.3 Overlong representation of the NUL character -4.3.1 n - 2 c0:80 - 2 bytes, need 1 -4.3.2 n - 3 e0:80:80 - 3 bytes, need 1 -4.3.3 n - 4 f0:80:80:80 - 4 bytes, need 1 -4.3.4 n - 5 f8:80:80:80:80 - 5 bytes, need 1 -4.3.5 n - 6 fc:80:80:80:80:80 - 6 bytes, need 1 -5 Illegal code positions -5.1 Single UTF-16 surrogates -5.1.1 y d800 3 ed:a0:80 1 UTF-16 surrogate 0xd800 -5.1.2 y db7f 3 ed:ad:bf 1 UTF-16 surrogate 0xdb7f -5.1.3 y db80 3 ed:ae:80 1 UTF-16 surrogate 0xdb80 -5.1.4 y dbff 3 ed:af:bf 1 UTF-16 surrogate 0xdbff -5.1.5 y dc00 3 ed:b0:80 1 UTF-16 surrogate 0xdc00 -5.1.6 y df80 3 ed:be:80 1 UTF-16 surrogate 0xdf80 -5.1.7 y dfff 3 ed:bf:bf 1 UTF-16 surrogate 0xdfff -5.2 Paired UTF-16 surrogates -5.2.1 y d800,dc00 6 ed:a0:80:ed:b0:80 2 UTF-16 surrogates 0xd800, dc00 -5.2.2 y d800,dfff 6 ed:a0:80:ed:bf:bf 2 UTF-16 surrogates 0xd800, dfff -5.2.3 y db7f,dc00 6 ed:ad:bf:ed:b0:80 2 UTF-16 surrogates 0xdb7f, dc00 -5.2.4 y db7f,dfff 6 ed:ad:bf:ed:bf:bf 2 UTF-16 surrogates 0xdb7f, dfff -5.2.5 y db80,dc00 6 ed:ae:80:ed:b0:80 2 UTF-16 surrogates 0xdb80, dc00 -5.2.6 y db80,dfff 6 ed:ae:80:ed:bf:bf 2 UTF-16 surrogates 0xdb80, dfff -5.2.7 y dbff,dc00 6 ed:af:bf:ed:b0:80 2 UTF-16 surrogates 0xdbff, dc00 -5.2.8 y dbff,dfff 6 ed:af:bf:ed:bf:bf 2 UTF-16 surrogates 0xdbff, dfff -5.3 Other illegal code positions -5.3.1 y fffe 3 ef:bf:be 1 byte order mark 0xfffe -# The ffff is legal by default since 872c91ae155f6880 -5.3.2 y ffff 3 ef:bf:bf 1 character 0xffff diff --git a/t/CORE/op/utf8magic.t b/t/CORE/op/utf8magic.t deleted file mode 100644 index 59e87a811..000000000 --- a/t/CORE/op/utf8magic.t +++ /dev/null @@ -1,24 +0,0 @@ -#!perl - -BEGIN { - unshift @INC, 't/CORE/lib'; - require 't/CORE/test.pl'; -} - -plan tests => 4; - -use strict; - -my $str = "\x{99f1}\x{99dd}"; # "camel" in Japanese kanji -$str =~ /(.)/; - -ok utf8::is_utf8($1), "is_utf8(unistr)"; -scalar "$1"; # invoke SvGETMAGIC -ok utf8::is_utf8($1), "is_utf8(unistr)"; - -utf8::encode($str); # off the utf8 flag -$str =~ /(.)/; - -ok !utf8::is_utf8($1), "is_utf8(bytes)"; -scalar "$1"; # invoke SvGETMAGIC -ok !utf8::is_utf8($1), "is_utf8(bytes)"; diff --git a/t/CORE/op/utfhash.t b/t/CORE/op/utfhash.t deleted file mode 100644 index dbe1ad0ae..000000000 --- a/t/CORE/op/utfhash.t +++ /dev/null @@ -1,220 +0,0 @@ -#!./perl -w - -BEGIN { - require 't/CORE/test.pl'; -} -plan(tests => 99); -use strict; - -# Two hashes one will all keys 8-bit possible (initially), other -# with a utf8 requiring key from the outset. - -my %hash8 = ( "\xff" => 0xff, - "\x7f" => 0x7f, - ); -my %hashu = ( "\xff" => 0xff, - "\x7f" => 0x7f, - "\x{1ff}" => 0x1ff, - ); - -# Check that we can find the 8-bit things by various literals -is($hash8{"\x{00ff}"},0xFF); -is($hash8{"\x{007f}"},0x7F); -is($hash8{"\xff"},0xFF); -is($hash8{"\x7f"},0x7F); -is($hashu{"\x{00ff}"},0xFF); -is($hashu{"\x{007f}"},0x7F); -is($hashu{"\xff"},0xFF); -is($hashu{"\x7f"},0x7F); - -# Now try same thing with variables forced into various forms. -foreach ("\x7f","\xff") - { - my $a = $_; # Force a copy - utf8::upgrade($a); - is($hash8{$a},ord($a)); - is($hashu{$a},ord($a)); - utf8::downgrade($a); - is($hash8{$a},ord($a)); - is($hashu{$a},ord($a)); - my $b = $a.chr(100); - chop($b); - is($hash8{$b},ord($b)); - is($hashu{$b},ord($b)); - } - -# Check we have not got an spurious extra keys -is(join('',sort { ord $a <=> ord $b } keys %hash8),"\x7f\xff"); -is(join('',sort { ord $a <=> ord $b } keys %hashu),"\x7f\xff\x{1ff}"); - -# Now add a utf8 key to the 8-bit hash -$hash8{chr(0x1ff)} = 0x1ff; - -# Check we have not got an spurious extra keys -is(join('',sort { ord $a <=> ord $b } keys %hash8),"\x7f\xff\x{1ff}"); - -foreach ("\x7f","\xff","\x{1ff}") - { - my $a = $_; - utf8::upgrade($a); - is($hash8{$a},ord($a)); - my $b = $a.chr(100); - chop($b); - is($hash8{$b},ord($b)); - } - -# and remove utf8 from the other hash -is(delete $hashu{chr(0x1ff)},0x1ff); -is(join('',sort keys %hashu),"\x7f\xff"); - -foreach ("\x7f","\xff") - { - my $a = $_; - utf8::upgrade($a); - is($hashu{$a},ord($a)); - utf8::downgrade($a); - is($hashu{$a},ord($a)); - my $b = $a.chr(100); - chop($b); - is($hashu{$b},ord($b)); - } - - - -{ - print "# Unicode hash keys and \\w\n"; - # This is not really a regex test but regexes bring - # out the issue nicely. - use strict; - my $u3 = "f\x{df}\x{100}"; - my $u2 = substr($u3,0,2); - my $u1 = substr($u2,0,1); - my $u0 = chr (0xdf)x4; # Make this 4 chars so that all lengths are distinct. - - my @u = ($u0, $u1, $u2, $u3); - - while (@u) { - my %u = (map {( $_, $_)} @u); - my $keys = scalar @u; - $keys .= ($keys == 1) ? " key" : " keys"; - - for (keys %u) { - my $l = 0 + /^\w+$/; - my $r = 0 + $u{$_} =~ /^\w+$/; - is ($l, $r, "\\w on keys with $keys, key of length " . length $_); - } - - my $more; - do { - $more = 0; - # Want to do this direct, rather than copying to a temporary variable - # The first time each will return key and value at the start of the hash. - # each will return () after we've done the last pair. $more won't get - # set then, and the do will exit. - for (each %u) { - $more = 1; - my $l = 0 + /^\w+$/; - my $r = 0 + $u{$_} =~ /^\w+$/; - is ($l, $r, "\\w on each, with $keys, key of length " . length $_); - } - } while ($more); - - for (%u) { - my $l = 0 + /^\w+$/; - my $r = 0 + $u{$_} =~ /^\w+$/; - is ($l, $r, "\\w on hash with $keys, key of length " . length $_); - } - pop @u; - undef %u; - } -} - -{ - my $utf8_sz = my $bytes_sz = "\x{df}"; - $utf8_sz .= chr 256; - chop ($utf8_sz); - - my (%bytes_first, %utf8_first); - - $bytes_first{$bytes_sz} = $bytes_sz; - - for (keys %bytes_first) { - my $l = 0 + /^\w+$/; - my $r = 0 + $bytes_first{$_} =~ /^\w+$/; - is ($l, $r, "\\w on each, bytes"); - } - - $bytes_first{$utf8_sz} = $utf8_sz; - - for (keys %bytes_first) { - my $l = 0 + /^\w+$/; - my $r = 0 + $bytes_first{$_} =~ /^\w+$/; - is ($l, $r, "\\w on each, bytes now utf8"); - } - - $utf8_first{$utf8_sz} = $utf8_sz; - - for (keys %utf8_first) { - my $l = 0 + /^\w+$/; - my $r = 0 + $utf8_first{$_} =~ /^\w+$/; - is ($l, $r, "\\w on each, utf8"); - } - - $utf8_first{$bytes_sz} = $bytes_sz; - - for (keys %utf8_first) { - my $l = 0 + /^\w+$/; - my $r = 0 + $utf8_first{$_} =~ /^\w+$/; - is ($l, $r, "\\w on each, utf8 now bytes"); - } - -} - -{ - local $/; # Slurp. - my $utf8 = ; - my $utfebcdic = ; - if (ord('A') == 65) { - eval $utf8; - } elsif (ord('A') == 193) { - eval $utfebcdic; - } -} -#_#_END__ -{ - # See if utf8 barewords work [perl #22969] - use utf8; - my %hash = (теÑÑ‚ => 123); - is($hash{теÑÑ‚}, $hash{'теÑÑ‚'}); - is($hash{теÑÑ‚}, 123); - is($hash{'теÑÑ‚'}, 123); - %hash = (теÑÑ‚ => 123); - is($hash{теÑÑ‚}, $hash{'теÑÑ‚'}); - is($hash{теÑÑ‚}, 123); - is($hash{'теÑÑ‚'}, 123); - - # See if plain ASCII strings quoted with '=>' erroneously get utf8 flag [perl #68812] - my %foo = (a => 'b', 'c' => 'd'); - for my $key (keys %foo) { - ok !utf8::is_utf8($key), "'$key' shouldn't have utf8 flag"; - } -} -__END__ -{ - # See if utf8 barewords work [perl #22969] - use utf8; # UTF-EBCDIC, really. - my %hash = (½ää½âÀ½äâ½ää => 123); - is($hash{½ää½âÀ½äâ½ää}, $hash{'½ää½âÀ½äâ½ää'}); - is($hash{½ää½âÀ½äâ½ää}, 123); - is($hash{'½ää½âÀ½äâ½ää'}, 123); - %hash = (½ää½âÀ½äâ½ää => 123); - is($hash{½ää½âÀ½äâ½ää}, $hash{'½ää½âÀ½äâ½ää'}); - is($hash{½ää½âÀ½äâ½ää}, 123); - is($hash{'½ää½âÀ½äâ½ää'}, 123); - - # See if plain ASCII strings quoted with '=>' erroneously get utf8 flag [perl #68812] - my %foo = (a => 'b', 'c' => 'd'); - for my $key (keys %foo) { - ok !utf8::is_utf8($key), "'$key' shouldn't have utf8 flag"; - } -} diff --git a/t/CORE/op/utftaint.t b/t/CORE/op/utftaint.t deleted file mode 100644 index 2e26b8250..000000000 --- a/t/CORE/op/utftaint.t +++ /dev/null @@ -1,150 +0,0 @@ -#!./perl -T -# tests whether tainting works with UTF-8 - -BEGIN { - unshift @INC, "."; -} - -use strict; -use Config; - -# How to identify taint when you see it -sub any_tainted (@) { - not eval { my $j=join("",@_);kill 0; 1 }; -} -sub tainted ($) { - any_tainted @_; -} - -require 't/CORE/test.pl'; -plan(tests => 3*10 + 3*8 + 2*16 + 2); - -my $arg = $ENV{PATH}; # a tainted value -use constant UTF8 => "\x{1234}"; - -*is_utf8 = \&utf8::is_utf8; - -for my $ary ([ascii => 'perl'], [latin1 => "\xB6"], [utf8 => "\x{100}"]) { - my $encode = $ary->[0]; - my $string = $ary->[1]; - - my $taint = $arg; substr($taint, 0) = $ary->[1]; - - is(tainted($taint), tainted($arg), "tainted: $encode, before test"); - - my $lconcat = $taint; - $lconcat .= UTF8; - is($lconcat, $string.UTF8, "compare: $encode, concat left"); - - is(tainted($lconcat), tainted($arg), "tainted: $encode, concat left"); - - my $rconcat = UTF8; - $rconcat .= $taint; - is($rconcat, UTF8.$string, "compare: $encode, concat right"); - - is(tainted($rconcat), tainted($arg), "tainted: $encode, concat right"); - - my $ljoin = join('!', $taint, UTF8); - is($ljoin, join('!', $string, UTF8), "compare: $encode, join left"); - - is(tainted($ljoin), tainted($arg), "tainted: $encode, join left"); - - my $rjoin = join('!', UTF8, $taint); - is($rjoin, join('!', UTF8, $string), "compare: $encode, join right"); - - is(tainted($rjoin), tainted($arg), "tainted: $encode, join right"); - - is(tainted($taint), tainted($arg), "tainted: $encode, after test"); -} - - -for my $ary ([ascii => 'perl'], [latin1 => "\xB6"], [utf8 => "\x{100}"]) { - my $encode = $ary->[0]; - - my $utf8 = pack('U*') . $ary->[1]; - my $byte = unpack('U0a*', $utf8); - - my $taint = $arg; substr($taint, 0) = $utf8; - utf8::encode($taint); - - is($taint, $byte, "compare: $encode, encode utf8"); - - is(pack('a*',$taint), pack('a*',$byte), "bytecmp: $encode, encode utf8"); - - ok(!is_utf8($taint), "is_utf8: $encode, encode utf8"); - - is(tainted($taint), tainted($arg), "tainted: $encode, encode utf8"); - - $taint = $arg; substr($taint, 0) = $byte; - utf8::decode($taint); - - is($taint, $utf8, "compare: $encode, decode byte"); - - is(pack('a*',$taint), pack('a*',$utf8), "bytecmp: $encode, decode byte"); - - is(is_utf8($taint), ($encode ne 'ascii'), "is_utf8: $encode, decode byte"); - - is(tainted($taint), tainted($arg), "tainted: $encode, decode byte"); -} - - -for my $ary ([ascii => 'perl'], [latin1 => "\xB6"]) { - my $encode = $ary->[0]; - - my $up = pack('U*') . $ary->[1]; - my $down = pack("a*", $ary->[1]); - - my $taint = $arg; substr($taint, 0) = $up; - utf8::upgrade($taint); - - is($taint, $up, "compare: $encode, upgrade up"); - - is(pack('a*',$taint), pack('a*',$up), "bytecmp: $encode, upgrade up"); - - ok(is_utf8($taint), "is_utf8: $encode, upgrade up"); - - is(tainted($taint), tainted($arg), "tainted: $encode, upgrade up"); - - $taint = $arg; substr($taint, 0) = $down; - utf8::upgrade($taint); - - is($taint, $up, "compare: $encode, upgrade down"); - - is(pack('a*',$taint), pack('a*',$up), "bytecmp: $encode, upgrade down"); - - ok(is_utf8($taint), "is_utf8: $encode, upgrade down"); - - is(tainted($taint), tainted($arg), "tainted: $encode, upgrade down"); - - $taint = $arg; substr($taint, 0) = $up; - utf8::downgrade($taint); - - is($taint, $down, "compare: $encode, downgrade up"); - - is(pack('a*',$taint), pack('a*',$down), "bytecmp: $encode, downgrade up"); - - ok(!is_utf8($taint), "is_utf8: $encode, downgrade up"); - - is(tainted($taint), tainted($arg), "tainted: $encode, downgrade up"); - - $taint = $arg; substr($taint, 0) = $down; - utf8::downgrade($taint); - - is($taint, $down, "compare: $encode, downgrade down"); - - is(pack('a*',$taint), pack('a*',$down), "bytecmp: $encode, downgrade down"); - - ok(!is_utf8($taint), "is_utf8: $encode, downgrade down"); - - is(tainted($taint), tainted($arg), "tainted: $encode, downgrade down"); -} - -{ - fresh_perl_is('$a = substr $^X, 0, 0; /$a\x{100}/ || print q,ok,', - 'ok', {switches => ["-T", "-l"]}, - "matching a regexp is taint agnostic"); - - fresh_perl_is('$a = substr $^X, 0, 0; /$a\x{100}/i || print q,ok,', - 'ok', {switches => ["-T", "-l"]}, - "therefore swash_init should be taint agnostic"); -} diff --git a/t/CORE/op/vec.t b/t/CORE/op/vec.t deleted file mode 100644 index 5d9440502..000000000 --- a/t/CORE/op/vec.t +++ /dev/null @@ -1,108 +0,0 @@ -#!./perl - -INIT { - unshift @INC, "./lib"; - require 't/CORE/test.pl'; -} - -plan( tests => 32 ); - -my $Is_EBCDIC = (ord('A') == 193) ? 1 : 0; - -is(vec($foo,0,1), 0); -is(length($foo), undef); -vec($foo,0,1) = 1; -is(length($foo), 1); -is(unpack('C',$foo), 1); -is(vec($foo,0,1), 1); - -is(vec($foo,20,1), 0); -vec($foo,20,1) = 1; -is(vec($foo,20,1), 1); -is(length($foo), 3); -is(vec($foo,1,8), 0); -vec($foo,1,8) = 0xf1; -is(vec($foo,1,8), 0xf1); -is((unpack('C',substr($foo,1,1)) & 255), 0xf1); -is(vec($foo,2,4), 1);; -is(vec($foo,3,4), 15); -vec($Vec, 0, 32) = 0xbaddacab; -is($Vec, "\xba\xdd\xac\xab"); -is(vec($Vec, 0, 32), 3135089835); - -# ensure vec() handles numericalness correctly -$foo = $bar = $baz = 0; -vec($foo = 0,0,1) = 1; -vec($bar = 0,1,1) = 1; -$baz = $foo | $bar; -ok($foo eq "1" && $foo == 1); -ok($bar eq "2" && $bar == 2); -ok("$foo $bar $baz" eq "1 2 3"); - -# error cases - -$x = eval { vec $foo, 0, 3 }; -like($@, qr/^Illegal number of bits in vec/); -$@ = undef; -$x = eval { vec $foo, 0, 0 }; -like($@, qr/^Illegal number of bits in vec/); -$@ = undef; -$x = eval { vec $foo, 0, -13 }; -like($@, qr/^Illegal number of bits in vec/); -$@ = undef; -$x = eval { vec($foo, -1, 4) = 2 }; -like($@, qr/^Negative offset to vec in lvalue context/); -$@ = undef; -ok(! vec('abcd', 7, 8)); - -# UTF8 -# N.B. currently curiously coded to circumvent bugs elswhere in UTF8 handling - -$foo = "\x{100}" . "\xff\xfe"; -$x = substr $foo, 1; -is(vec($x, 0, 8), 255); -$@ = undef; -eval { vec($foo, 1, 8) }; -ok(! $@); -$@ = undef; -eval { vec($foo, 1, 8) = 13 }; -ok(! $@); -if ($Is_EBCDIC) { - is($foo, "\x8c\x0d\xff\x8a\x69"); -} -else { - is($foo, "\xc4\x0d\xc3\xbf\xc3\xbe"); -} -$foo = "\x{100}" . "\xff\xfe"; -$x = substr $foo, 1; -vec($x, 2, 4) = 7; -is($x, "\xff\xf7"); - -# mixed magic - -$foo = "\x61\x62\x63\x64\x65\x66"; -is(vec(substr($foo, 2, 2), 0, 16), 25444); -vec(substr($foo, 1,3), 5, 4) = 3; -is($foo, "\x61\x62\x63\x34\x65\x66"); - -# A variation of [perl #20933] -{ - my $s = ""; - vec($s, 0, 1) = 0; - vec($s, 1, 1) = 1; - my @r; - $r[$_] = \ vec $s, $_, 1 for (0, 1); - ok(!(${ $r[0] } != 0 || ${ $r[1] } != 1)); -} - - -my $destroyed; -{ package Class; DESTROY { ++$destroyed; } } - -$destroyed = 0; -{ - my $x = ''; - vec($x,0,1) = 0; - $x = bless({}, 'Class'); -} -is($destroyed, 1, 'Timely scalar destruction with lvalue vec'); diff --git a/t/CORE/op/ver.t b/t/CORE/op/ver.t deleted file mode 100644 index 89a869cf5..000000000 --- a/t/CORE/op/ver.t +++ /dev/null @@ -1,274 +0,0 @@ -#!./perl - -INIT { - unshift @INC, "./lib"; - require 't/CORE/test.pl'; - $SIG{'__WARN__'} = sub { warn $_[0] if $DOWARN }; -} - -$DOWARN = 1; # enable run-time warnings now - -use Config; - -plan( tests => 54 ); - -eval 'use v5.5.640'; -is( $@, '', "use v5.5.640; $@"); - -require_ok('v5.5.640'); - -# printing characters should work -if (ord("\t") == 9) { # ASCII - is('ok ',v111.107.32,'ASCII printing characters'); - - # hash keys too - $h{v111.107} = "ok"; - is('ok',$h{v111.107},'ASCII hash keys'); -} -else { # EBCDIC - is('ok ',v150.146.64,'EBCDIC printing characters'); - - # hash keys too - $h{v150.146} = "ok"; - is('ok',$h{v150.146},'EBCDIC hash keys'); -} - -# poetry optimization should also -sub v77 { "ok" } -$x = v77; -is('ok',$x,'poetry optimization'); - -# but not when dots are involved -if (ord("\t") == 9) { # ASCII - $x = v77.78.79; -} -else { - $x = v212.213.214; -} -is($x, 'MNO','poetry optimization with dots'); - -is(v1.20.300.4000, "\x{1}\x{14}\x{12c}\x{fa0}",'compare embedded \x{} string'); - -# -# now do the same without the "v" -eval 'use 5.5.640'; -is( $@, '', "use 5.5.640; $@"); - -require_ok('5.5.640'); - -# hash keys too -if (ord("\t") == 9) { # ASCII - $h{111.107.32} = "ok"; -} -else { - $h{150.146.64} = "ok"; -} -is('ok',$h{ok },'hash keys w/o v'); - -if (ord("\t") == 9) { # ASCII - $x = 77.78.79; -} -else { - $x = 212.213.214; -} -is($x, 'MNO','poetry optimization with dots w/o v'); - -is(1.20.300.4000, "\x{1}\x{14}\x{12c}\x{fa0}",'compare embedded \x{} string w/o v'); - -# test sprintf("%vd"...) etc -if (ord("\t") == 9) { # ASCII - is(sprintf("%vd", "Perl"), '80.101.114.108', 'ASCII sprintf("%vd", "Perl")'); -} -else { - is(sprintf("%vd", "Perl"), '215.133.153.147', 'EBCDIC sprintf("%vd", "Perl")'); -} - -is(sprintf("%vd", v1.22.333.4444), '1.22.333.4444', 'sprintf("%vd", v1.22.333.4444)'); - -if (ord("\t") == 9) { # ASCII - is(sprintf("%vx", "Perl"), '50.65.72.6c', 'ASCII sprintf("%vx", "Perl")'); -} -else { - is(sprintf("%vx", "Perl"), 'd7.85.99.93', 'EBCDIC sprintf("%vx", "Perl")'); -} - -is(sprintf("%vX", 1.22.333.4444), '1.16.14D.115C','ASCII sprintf("%vX", 1.22.333.4444)'); - -if (ord("\t") == 9) { # ASCII - is(sprintf("%#*vo", ":", "Perl"), '0120:0145:0162:0154', 'ASCII sprintf("%vo", "Perl")'); -} -else { - is(sprintf("%#*vo", ":", "Perl"), '0327:0205:0231:0223', 'EBCDIC sprintf("%vo", "Perl")'); -} - -is(sprintf("%*vb", "##", v1.22.333.4444), - '1##10110##101001101##1000101011100', 'sprintf("%vb", 1.22.333.4444)'); - -is(sprintf("%vd", join("", map { chr } - unpack 'U*', pack('U*',2001,2002,2003))), - '2001.2002.2003','unpack/pack U*'); - -{ - use bytes; - - if (ord("\t") == 9) { # ASCII - is(sprintf("%vd", "Perl"), '80.101.114.108', 'ASCII sprintf("%vd", "Perl") w/use bytes'); - } - else { - is(sprintf("%vd", "Perl"), '215.133.153.147', 'EBCDIC sprintf("%vd", "Perl") w/use bytes'); - } - - if (ord("\t") == 9) { # ASCII - is(sprintf("%vd", 1.22.333.4444), '1.22.197.141.225.133.156', 'ASCII sprintf("%vd", v1.22.333.4444 w/use bytes'); - } - else { - is(sprintf("%vd", 1.22.333.4444), '1.22.142.84.187.81.112', 'EBCDIC sprintf("%vd", v1.22.333.4444 w/use bytes'); - } - - if (ord("\t") == 9) { # ASCII - is(sprintf("%vx", "Perl"), '50.65.72.6c', 'ASCII sprintf("%vx", "Perl")'); - } - else { - is(sprintf("%vx", "Perl"), 'd7.85.99.93', 'EBCDIC sprintf("%vx", "Perl")'); - } - - if (ord("\t") == 9) { # ASCII - is(sprintf("%vX", v1.22.333.4444), '1.16.C5.8D.E1.85.9C', 'ASCII sprintf("%vX", v1.22.333.4444)'); - } - else { - is(sprintf("%vX", v1.22.333.4444), '1.16.8E.54.BB.51.70', 'EBCDIC sprintf("%vX", v1.22.333.4444)'); - } - - if (ord("\t") == 9) { # ASCII - is(sprintf("%#*vo", ":", "Perl"), '0120:0145:0162:0154', 'ASCII sprintf("%#*vo", ":", "Perl")'); - } - else { - is(sprintf("%#*vo", ":", "Perl"), '0327:0205:0231:0223', 'EBCDIC sprintf("%#*vo", ":", "Perl")'); - } - - if (ord("\t") == 9) { # ASCII - is(sprintf("%*vb", "##", v1.22.333.4444), - '1##10110##11000101##10001101##11100001##10000101##10011100', - 'ASCII sprintf("%*vb", "##", v1.22.333.4444)'); - } - else { - is(sprintf("%*vb", "##", v1.22.333.4444), - '1##10110##10001110##1010100##10111011##1010001##1110000', - 'EBCDIC sprintf("%*vb", "##", v1.22.333.4444)'); - } -} - -{ - # bug id 20000323.056 - - is( "\x{41}", +v65, 'bug id 20000323.056'); - is( "\x41", +v65, 'bug id 20000323.056'); - is( "\x{c8}", +v200, 'bug id 20000323.056'); - is( "\xc8", +v200, 'bug id 20000323.056'); - is( "\x{221b}", +v8731, 'bug id 20000323.056'); -} - -# See if the things Camel-III says are true: 29..33 - -# Chapter 2 pp67/68 -my $vs = v1.20.300.4000; -is($vs,"\x{1}\x{14}\x{12c}\x{fa0}","v-string ne \\x{}"); -is($vs,chr(1).chr(20).chr(300).chr(4000),"v-string ne chr()"); -is('foo',((chr(193) eq 'A') ? v134.150.150 : v102.111.111),"v-string ne ''"); - -# Chapter 15, pp403 - -# See if sane addr and gethostbyaddr() work -eval { require Socket; gethostbyaddr(v127.0.0.1, &Socket::AF_INET) }; -if ($@) { - # No - so do not test insane fails. - $@ =~ s/\n/\n# /g; -} -SKIP: { - skip("No Socket::AF_INET # $@") if $@; - my $ip = v2004.148.0.1; - my $host; - eval { $host = gethostbyaddr($ip,&Socket::AF_INET) }; - like($@, qr/Wide character/, "Non-bytes leak to gethostbyaddr"); -} - -# Chapter 28, pp671 -ok(v5.6.0 lt v5.7.0, "v5.6.0 lt v5.7.0"); - -# part of 20000323.059 -is(v200, chr(200), "v200 eq chr(200)" ); -is(v200, +v200, "v200 eq +v200" ); -is(v200, eval( "v200"), 'v200 eq "v200"' ); -is(v200, eval("+v200"), 'v200 eq eval("+v200")' ); - -# Tests for string/numeric value of $] itself -my ($revision,$version,$subversion) = split /\./, sprintf("%vd",$^V); - -# $^V always displays the leading 'v' but we don't want that here -$revision =~ s/^v//; - -print "# revision = '$revision'\n"; -print "# version = '$version'\n"; -print "# subversion = '$subversion'\n"; - -my $v = sprintf("%d.%.3d%.3d",$revision,$version,$subversion); - -print "# v = '$v'\n"; -print "# ] = '$]'\n"; - -is( $v, "$]", qq{\$^V eq "\$]"}); - -$v = $revision + $version/1000 + $subversion/1000000; - -ok( abs($v - $]) < 10**-8 , "\$^V == \$] (numeric)" ); - -SKIP: { - skip("In EBCDIC the v-string components cannot exceed 2147483647", 6) - if ord "A" == 193; - - # [ID 20010902.001] check if v-strings handle full UV range or not - if ( $Config{'uvsize'} >= 4 ) { - is( sprintf("%vd", eval 'v2147483647.2147483648'), '2147483647.2147483648', 'v-string > IV_MAX[32-bit]' ); - is( sprintf("%vd", eval 'v3141592653'), '3141592653', 'IV_MAX < v-string < UV_MAX[32-bit]'); - is( sprintf("%vd", eval 'v4294967295'), '4294967295', 'v-string == UV_MAX[32-bit] - 1'); - } - - SKIP: { - skip("No quads", 3) if $Config{uvsize} < 8; - - if ( $Config{'uvsize'} >= 8 ) { - is( sprintf("%vd", eval 'v9223372036854775807.9223372036854775808'), '9223372036854775807.9223372036854775808', 'v-string > IV_MAX[64-bit]' ); - is( sprintf("%vd", eval 'v17446744073709551615'), '17446744073709551615', 'IV_MAX < v-string < UV_MAX[64-bit]'); - is( sprintf("%vd", eval 'v18446744073709551615'), '18446744073709551615', 'v-string == UV_MAX[64-bit] - 1'); - } - } -} - -# Tests for magic v-strings - -$v = 1.2.3; -is( ref(\$v), 'VSTRING', 'v-string objects' ); - -$v = v1.2_3; -is( ref(\$v), 'VSTRING', 'v-string objects with v' ); -is( sprintf("%vd", $v), '1.23', 'v-string ignores underscores' ); - -# [perl #16010] -%h = (v65 => 42); -ok( exists $h{v65}, "v-stringness is not engaged for vX" ); -%h = (v65.66 => 42); -ok( exists $h{chr(65).chr(66)}, "v-stringness is engaged for vX.Y" ); -%h = (65.66.67 => 42); -ok( exists $h{chr(65).chr(66).chr(67)}, "v-stringness is engaged for X.Y.Z" ); - - -# The following tests whether v-strings are correctly -# interpreted by the tokeniser when it's in a XTERMORDORDOR -# state (fittingly, the only tokeniser state to contain the -# word MORDOR). - -*{"\3"} = *DATA; -is( (readline v3), "This is what we expect to see!\n", "v-strings even work in Mordor" ); - -__DATA__ -This is what we expect to see! diff --git a/t/CORE/op/wantarray.t b/t/CORE/op/wantarray.t deleted file mode 100644 index 10be0086b..000000000 --- a/t/CORE/op/wantarray.t +++ /dev/null @@ -1,53 +0,0 @@ -#!./perl - -BEGIN { - unshift @INC, 't/CORE/lib'; - require 't/CORE/test.pl'; -} - -use strict; - -plan 13; - -sub context { - local $::Level = $::Level + 1; - my ( $cona, $testnum ) = @_; - my $conb = (defined wantarray) ? ( wantarray ? 'A' : 'S' ) : 'V'; - is $cona, $conb; -} - -context('V'); -my $a = context('S'); -my @a = context('A'); -scalar context('S'); -$a = scalar context('S'); -($a) = context('A'); -($a) = scalar context('S'); - -{ - # [ID 20020626.011] incorrect wantarray optimisation - sub simple { wantarray ? 1 : 2 } - sub inline { - my $a = wantarray ? simple() : simple(); - $a; - } - my @b = inline(); - my $c = inline(); - is @b, 1; - is "@b", "2"; - is $c, 2; -} - -my $q; - -my $qcontext = q{ - $q = (defined wantarray) ? ( wantarray ? 'A' : 'S' ) : 'V'; -}; -eval $qcontext; -is $q, 'V'; -$a = eval $qcontext; -is $q, 'S'; -@a = eval $qcontext; -is $q, 'A'; - -1; diff --git a/t/CORE/op/warn.t b/t/CORE/op/warn.t deleted file mode 100644 index b8371dba9..000000000 --- a/t/CORE/op/warn.t +++ /dev/null @@ -1,150 +0,0 @@ -#!./perl -#line 3 warn.t - -BEGIN { - unshift @INC, 't/CORE/lib'; - require 't/CORE/test.pl'; -} - -plan 22; - -my @warnings; -my $wa = []; my $ea = []; -$SIG{__WARN__} = sub { push @warnings, $_[0] }; - -@warnings = (); -$@ = ""; -warn "foo\n"; -ok @warnings==1 && $warnings[0] eq "foo\n"; - -@warnings = (); -$@ = ""; -warn "foo", "bar\n"; -ok @warnings==1 && $warnings[0] eq "foobar\n"; - -@warnings = (); -$@ = ""; -warn "foo"; -ok @warnings==1 && $warnings[0] eq "foo at warn.t line 27.\n"; - -@warnings = (); -$@ = ""; -warn $wa; -ok @warnings==1 && ref($warnings[0]) eq "ARRAY" && $warnings[0] == $wa; - -@warnings = (); -$@ = ""; -warn ""; -ok @warnings==1 && - $warnings[0] eq "Warning: something's wrong at warn.t line 37.\n"; - -@warnings = (); -$@ = ""; -warn; -ok @warnings==1 && - $warnings[0] eq "Warning: something's wrong at warn.t line 43.\n"; - -@warnings = (); -$@ = "ERR\n"; -warn "foo\n"; -ok @warnings==1 && $warnings[0] eq "foo\n"; - -@warnings = (); -$@ = "ERR\n"; -warn "foo", "bar\n"; -ok @warnings==1 && $warnings[0] eq "foobar\n"; - -@warnings = (); -$@ = "ERR\n"; -warn "foo"; -ok @warnings==1 && $warnings[0] eq "foo at warn.t line 59.\n"; - -@warnings = (); -$@ = "ERR\n"; -warn $wa; -ok @warnings==1 && ref($warnings[0]) eq "ARRAY" && $warnings[0] == $wa; - -@warnings = (); -$@ = "ERR\n"; -warn ""; -ok @warnings==1 && - $warnings[0] eq "ERR\n\t...caught at warn.t line 69.\n"; - -@warnings = (); -$@ = "ERR\n"; -warn; -ok @warnings==1 && - $warnings[0] eq "ERR\n\t...caught at warn.t line 75.\n"; - -@warnings = (); -$@ = $ea; -warn "foo\n"; -ok @warnings==1 && $warnings[0] eq "foo\n"; - -@warnings = (); -$@ = $ea; -warn "foo", "bar\n"; -ok @warnings==1 && $warnings[0] eq "foobar\n"; - -@warnings = (); -$@ = $ea; -warn "foo"; -ok @warnings==1 && $warnings[0] eq "foo at warn.t line 91.\n"; - -@warnings = (); -$@ = $ea; -warn $wa; -ok @warnings==1 && ref($warnings[0]) eq "ARRAY" && $warnings[0] == $wa; - -@warnings = (); -$@ = $ea; -warn ""; -ok @warnings==1 && ref($warnings[0]) eq "ARRAY" && $warnings[0] == $ea; - -@warnings = (); -$@ = $ea; -warn; -ok @warnings==1 && ref($warnings[0]) eq "ARRAY" && $warnings[0] == $ea; - -fresh_perl_like( - ' - $a = "\xee\n"; - print STDERR $a; warn $a; - utf8::upgrade($a); - print STDERR $a; warn $a; - ', - qr/^\xee(?:\r?\n\xee){3}/, -# { switches => [ "-C0" ] }, # switches don't work with perlcc - 'warn emits logical characters, not internal bytes [perl #45549]' -); - -{ -fresh_perl_like( - ' - INIT { binmode(STDERR, ":utf8") } - $a = "\xee\n"; - print STDERR $a; warn $a; - utf8::upgrade($a); - print STDERR $a; warn $a; - ', - qr/^\xc3\xae(?:\r?\n\xc3\xae){3}/, -# { switches => ['-CE'] }, # switches don't work with perlcc - 'warn respects :utf8 layer' -); -} - -fresh_perl_like( - 'warn chr 300', - qr/^Wide character in warn .*\n\xc4\xac at /, - { switches => [ "-C0" ] }, - 'Wide character in warn (not print)' -); - -fresh_perl_like( - 'warn []', - qr/^ARRAY\(0x[\da-f]+\) at /a, - { }, - 'warn stringifies in the absence of $SIG{__WARN__}' -); - -1; diff --git a/t/CORE/op/while_readdir.t b/t/CORE/op/while_readdir.t deleted file mode 100644 index 862634bbd..000000000 --- a/t/CORE/op/while_readdir.t +++ /dev/null @@ -1,179 +0,0 @@ -#!./perl - -BEGIN { - unshift @INC, 't/CORE/lib'; - require 't/CORE/test.pl'; -} - -use strict; -use warnings; - -plan 10; - -# Need to run this in a quiet private directory as it assumes that it can read -# the contents twice and get the same result. -my $tempdir = tempfile; - -mkdir $tempdir, 0700 or die "Can't mkdir '$tempdir': $!"; -chdir $tempdir or die die "Can't chdir '$tempdir': $!"; - -my $cleanup = 1; -my %tempfiles; - -END { - if ($cleanup) { - foreach my $file (keys %tempfiles) { - # We only wrote each of these once so 1 delete should work: - if (unlink $file) { - warn "unlink tempfile '$file' passed but it's still there" - if -e $file; - } else { - warn "Couldn't unlink tempfile '$file': $!"; - } - } - chdir '..' or die "Couldn't chdir .. for cleanup: $!"; - rmdir $tempdir or die "Couldn't unlink tempdir '$tempdir': $!"; - } -} - -# This is intentionally not random (per run), but intentionally will try to -# give different file names for different people running this test. -srand $< * $]; - -my @chars = ('A' .. 'Z', 'a' .. 'z', 0 .. 9); - -sub make_file { - my $name = shift; - - return if $tempfiles{$name}++; - - print "# Writing to $name in $tempdir\n"; - - open my $fh, '>', $name or die "Can't open '$name' for writing: $!\n"; - print $fh <<'FILE0'; -This file is here for testing - -while(readdir $dir){...} -... while readdir $dir - -etc -FILE0 - close $fh or die "Can't close '$name': $!"; -} - -sub make_some_files { - for (1..int rand 10) { - my $name; - $name .= $chars[rand $#chars] for 1..int(1 + rand 5); - make_file($name); - } -} - -make_some_files(); -make_file('0'); -make_some_files(); - -ok(-f '0', "'0' file is here"); - -opendir my $dirhandle, '.' - or die "Failed test: unable to open directory: $!\n"; - -my @dir = readdir $dirhandle; -rewinddir $dirhandle; - -{ - my @list; - while(readdir $dirhandle){ - push @list, $_; - } - ok( eq_array( \@dir, \@list ), 'while(readdir){push}' ); - rewinddir $dirhandle; -} - -{ - my @list; - push @list, $_ while readdir $dirhandle; - ok( eq_array( \@dir, \@list ), 'push while readdir' ); - rewinddir $dirhandle; -} - -{ - my $tmp; - my @list; - push @list, $tmp while $tmp = readdir $dirhandle; - ok( eq_array( \@dir, \@list ), 'push $dir while $dir = readdir' ); - rewinddir $dirhandle; -} - -{ - my @list; - while( my $dir = readdir $dirhandle){ - push @list, $dir; - } - ok( eq_array( \@dir, \@list ), 'while($dir=readdir){push}' ); - rewinddir $dirhandle; -} - - -{ - my @list; - my $sub = sub{ - push @list, $_; - }; - $sub->($_) while readdir $dirhandle; - ok( eq_array( \@dir, \@list ), '$sub->($_) while readdir' ); - rewinddir $dirhandle; -} - -{ - my $works = 0; - while(readdir $dirhandle){ - $_ =~ s/\.$// if defined $_ && $^O eq 'VMS'; # may have zero-length extension - if( defined $_ && $_ eq '0'){ - $works = 1; - last; - } - } - ok( $works, 'while(readdir){} with file named "0"' ); - rewinddir $dirhandle; -} - -{ - my $works = 0; - my $sub = sub{ - $_ =~ s/\.$// if defined $_ && $^O eq 'VMS'; # may have zero-length extension - if( defined $_ && $_ eq '0' ){ - $works = 1; - } - }; - $sub->($_) while readdir $dirhandle; - ok( $works, '$sub->($_) while readdir; with file named "0"' ); - rewinddir $dirhandle; -} - -{ - my $works = 0; - while( my $dir = readdir $dirhandle ){ - $dir =~ s/\.$// if defined $dir && $^O eq 'VMS'; # may have zero-length extension - if( defined $dir && $dir eq '0'){ - $works = 1; - last; - } - } - ok( $works, 'while($dir=readdir){} with file named "0"'); - rewinddir $dirhandle; -} - -{ - my $tmp; - my $ok; - my @list; - while( $tmp = readdir $dirhandle ){ - $tmp =~ s/\.$// if defined $tmp && $^O eq 'VMS'; # may have zero-length extension - last if defined($tmp)&& !$tmp && ($ok=1) - } - ok( $ok, '$dir while $dir = readdir; with file named "0"' ); - rewinddir $dirhandle; -} - -closedir $dirhandle; diff --git a/t/CORE/op/write.t b/t/CORE/op/write.t deleted file mode 100644 index 66e306018..000000000 --- a/t/CORE/op/write.t +++ /dev/null @@ -1,812 +0,0 @@ -#!./perl - -BEGIN { - unshift @INC, 't/CORE/lib'; - require 't/CORE/test.pl'; -} - -use strict; # Amazed that this hackery can be made strict ... - -# read in a file -sub cat { - my $file = shift; - local $/; - open my $fh, $file or die "can't open '$file': $!"; - my $data = <$fh>; - close $fh; - $data; -} - -#-- testing numeric fields in all variants (WL) - -sub swrite { - my $format = shift; - local $^A = ""; # don't litter, use a local bin - formline( $format, @_ ); - return $^A; -} - -my @NumTests = ( - # [ format, value1, expected1, value2, expected2, .... ] - [ '@###', 0, ' 0', 1, ' 1', 9999.6, '####', - 9999.4999, '9999', -999.6, '####', 1e+100, '####' ], - - [ '@0##', 0, '0000', 1, '0001', 9999.6, '####', - -999.4999, '-999', -999.6, '####', 1e+100, '####' ], - - [ '^###', 0, ' 0', undef, ' ' ], - - [ '^0##', 0, '0000', undef, ' ' ], - - [ '@###.', 0, ' 0.', 1, ' 1.', 9999.6, '#####', - 9999.4999, '9999.', -999.6, '#####' ], - - [ '@##.##', 0, ' 0.00', 1, ' 1.00', 999.996, '######', - 999.99499, '999.99', -100, '######' ], - - [ '@0#.##', 0, '000.00', 1, '001.00', 10, '010.00', - -0.0001, qr/^[\-0]00\.00$/ ], - -); - - -my $num_tests = 0; -for my $tref ( @NumTests ){ - $num_tests += (@$tref - 1)/2; -} -#--------------------------------------------------------- - -# number of tests in section 1 -my $bas_tests = 20; - -# number of tests in section 3 -my $bug_tests = 4 + 3 * 3 * 5 * 2 * 3 + 2 + 2 + 1; - -# number of tests in section 4 -my $hmb_tests = 35; - -my $tests = $bas_tests + $num_tests + $bug_tests + $hmb_tests; - -plan $tests; - -############ -## Section 1 -############ - -use vars qw($fox $multiline $foo $good); - -format OUT = -the quick brown @<< -$fox -jumped -@* -$multiline -^<<<<<<<<< -$foo -^<<<<<<<<< -$foo -^<<<<<<... -$foo -now @<>>> for all@|||||men to come @<<<< -{ - 'i' . 's', "time\n", $good, 'to' -} -. - -open(OUT, '>Op_write.tmp') || die "Can't create Op_write.tmp"; -END { unlink_all 'Op_write.tmp' } - -$fox = 'foxiness'; -$good = 'good'; -$multiline = "forescore\nand\nseven years\n"; -$foo = 'when in the course of human events it becomes necessary'; -write(OUT); -close OUT or die "Could not close: $!"; - -my $right = -"the quick brown fox -jumped -forescore -and -seven years -when in -the course -of huma... -now is the time for all good men to come to\n"; - -is cat('Op_write.tmp'), $right and unlink_all 'Op_write.tmp'; - -$fox = 'wolfishness'; -my $fox = 'foxiness'; # Test a lexical variable. - -format OUT2 = -the quick brown @<< -$fox -jumped -@* -$multiline -^<<<<<<<<< ~~ -$foo -now @<>>> for all@|||||men to come @<<<< -'i' . 's', "time\n", $good, 'to' -. - -open OUT2, '>Op_write.tmp' or die "Can't create Op_write.tmp"; - -$good = 'good'; -$multiline = "forescore\nand\nseven years\n"; -$foo = 'when in the course of human events it becomes necessary'; -write(OUT2); -close OUT2 or die "Could not close: $!"; - -$right = -"the quick brown fox -jumped -forescore -and -seven years -when in -the course -of human -events it -becomes -necessary -now is the time for all good men to come to\n"; - -is cat('Op_write.tmp'), $right and unlink_all 'Op_write.tmp'; - -eval <<'EOFORMAT'; -format OUT2 = -the brown quick @<< -$fox -jumped -@* -$multiline -and -^<<<<<<<<< ~~ -$foo -now @<>>> for all@|||||men to come @<<<< -'i' . 's', "time\n", $good, 'to' -. -EOFORMAT - -open(OUT2, '>Op_write.tmp') || die "Can't create Op_write.tmp"; - -$fox = 'foxiness'; -$good = 'good'; -$multiline = "forescore\nand\nseven years\n"; -$foo = 'when in the course of human events it becomes necessary'; -write(OUT2); -close OUT2 or die "Could not close: $!"; - -$right = -"the brown quick fox -jumped -forescore -and -seven years -and -when in -the course -of human -events it -becomes -necessary -now is the time for all good men to come to\n"; - -is cat('Op_write.tmp'), $right and unlink_all 'Op_write.tmp'; - -# formline tests - -$right = < ab -@>> abc -@>>> abc -@>>>> abc -@>>>>> abc -@>>>>>> abc -@>>>>>>> abc -@>>>>>>>> abc -@>>>>>>>>> abc -@>>>>>>>>>> abc -EOT - -my $was1 = my $was2 = ''; -use vars '$format2'; -for (0..10) { - # lexical picture - $^A = ''; - my $format1 = '@' . '>' x $_; - formline $format1, 'abc'; - $was1 .= "$format1 $^A\n"; - # global - $^A = ''; - local $format2 = '@' . '>' x $_; - formline $format2, 'abc'; - $was2 .= "$format2 $^A\n"; -} -is $was1, $right; -is $was2, $right; - -$^A = ''; - -# more test - -format OUT3 = -^<<<<<<... -$foo -. - -open(OUT3, '>Op_write.tmp') || die "Can't create Op_write.tmp"; - -$foo = 'fit '; -write(OUT3); -close OUT3 or die "Could not close: $!"; - -$right = -"fit\n"; - -is cat('Op_write.tmp'), $right and unlink_all 'Op_write.tmp'; - - -# test lexicals and globals -{ - my $test = curr_test(); - my $this = "ok"; - our $that = $test; - format LEX = -@<<@| -$this,$that -. - open(LEX, ">&STDOUT") or die; - write LEX; - $that = ++$test; - write LEX; - close LEX or die "Could not close: $!"; - curr_test($test + 1); -} -# LEX_INTERPNORMAL test -my %e = ( a => 1 ); -format OUT4 = -@<<<<<< -"$e{a}" -. -open OUT4, ">Op_write.tmp" or die "Can't create Op_write.tmp"; -write (OUT4); -close OUT4 or die "Could not close: $!"; -is cat('Op_write.tmp'), "1\n" and unlink_all "Op_write.tmp"; - -eval <<'EOFORMAT'; -format OUT10 = -@####.## @0###.## -$test1, $test1 -. -EOFORMAT - -open(OUT10, '>Op_write.tmp') || die "Can't create Op_write.tmp"; - -use vars '$test1'; -$test1 = 12.95; -write(OUT10); -close OUT10 or die "Could not close: $!"; - -$right = " 12.95 00012.95\n"; -is cat('Op_write.tmp'), $right and unlink_all 'Op_write.tmp'; - -eval <<'EOFORMAT'; -format OUT11 = -@0###.## -$test1 -@ 0# -$test1 -@0 # -$test1 -. -EOFORMAT - -open(OUT11, '>Op_write.tmp') || die "Can't create Op_write.tmp"; - -$test1 = 12.95; -write(OUT11); -close OUT11 or die "Could not close: $!"; - -$right = -"00012.95 -1 0# -10 #\n"; -is cat('Op_write.tmp'), $right and unlink_all 'Op_write.tmp'; - -{ - my $test = curr_test(); - my $el; - format OUT12 = -ok ^<<<<<<<<<<<<<<~~ # sv_chop() naze -$el -. - my %hash = ($test => 3); - open(OUT12, '>Op_write.tmp') || die "Can't create Op_write.tmp"; - - for $el (keys %hash) { - write(OUT12); - } - close OUT12 or die "Could not close: $!"; - print cat('Op_write.tmp'); - curr_test($test + 1); -} - -{ - my $test = curr_test(); - # Bug report and testcase by Alexey Tourbin - use Tie::Scalar; - my $v; - tie $v, 'Tie::StdScalar'; - $v = $test; - format OUT13 = -ok ^<<<<<<<<< ~~ -$v -. - open(OUT13, '>Op_write.tmp') || die "Can't create Op_write.tmp"; - write(OUT13); - close OUT13 or die "Could not close: $!"; - print cat('Op_write.tmp'); - curr_test($test + 1); -} - -{ # test 14 - # Bug #24774 format without trailing \n failed assertion, but this - # must fail since we have a trailing ; in the eval'ed string (WL) - my @v = ('k'); - eval "format OUT14 = \n@\n\@v"; - like $@, qr/Format not terminated/; -} - -{ # test 15 - # text lost in ^<<< field with \r in value (WL) - my $txt = "line 1\rline 2"; - format OUT15 = -^<<<<<<<<<<<<<<<<<< -$txt -^<<<<<<<<<<<<<<<<<< -$txt -. - open(OUT15, '>Op_write.tmp') || die "Can't create Op_write.tmp"; - write(OUT15); - close OUT15 or die "Could not close: $!"; - my $res = cat('Op_write.tmp'); - is $res, "line 1\nline 2\n"; -} - -{ # test 16: multiple use of a variable in same line with ^< - my $txt = "this_is_block_1 this_is_block_2 this_is_block_3 this_is_block_4"; - format OUT16 = -^<<<<<<<<<<<<<<<< ^<<<<<<<<<<<<<<<< -$txt, $txt -^<<<<<<<<<<<<<<<< ^<<<<<<<<<<<<<<<< -$txt, $txt -. - open(OUT16, '>Op_write.tmp') || die "Can't create Op_write.tmp"; - write(OUT16); - close OUT16 or die "Could not close: $!"; - my $res = cat('Op_write.tmp'); - is $res, <Op_write.tmp') || die "Can't create Op_write.tmp"; - write(OUT17); - close OUT17 or die "Could not close: $!"; - my $res = cat('Op_write.tmp'); - chomp( $txt ); - my $exp = <Op_write.tmp') || die "Can't create Op_write.tmp"; - eval { write(OUT18); }; - like $@, qr/Repeated format line will never terminate/; - close OUT18 or die "Could not close: $!"; -} - -{ # test 19: \0 in an evel'ed format, doesn't cause empty lines (WL) - my $v = 'gaga'; - eval "format OUT19 = \n" . - '@<<<' . "\0\n" . - '$v' . "\n" . - '@<<<' . "\0\n" . - '$v' . "\n.\n"; - open(OUT19, '>Op_write.tmp') || die "Can't create Op_write.tmp"; - write(OUT19); - close OUT19 or die "Could not close: $!"; - my $res = cat('Op_write.tmp'); - is $res, < 'xval', ykey => 'yval' ); - format OUT20 = -@>>>> @<<<< ~~ -each %h -@>>>> @<<<< -$h{xkey}, $h{ykey} -@>>>> @<<<< -{ $h{xkey}, $h{ykey} -} -} -. - my $exp = ''; - while( my( $k, $v ) = each( %h ) ){ - $exp .= sprintf( "%5s %s\n", $k, $v ); - } - $exp .= sprintf( "%5s %s\n", $h{xkey}, $h{ykey} ); - $exp .= sprintf( "%5s %s\n", $h{xkey}, $h{ykey} ); - $exp .= "}\n"; - open(OUT20, '>Op_write.tmp') || die "Can't create Op_write.tmp"; - write(OUT20); - close OUT20 or die "Could not close: $!"; - my $res = cat('Op_write.tmp'); - is $res, $exp; -} - - -##################### -## Section 2 -## numeric formatting -##################### - -curr_test($bas_tests + 1); - -for my $tref ( @NumTests ){ - my $writefmt = shift( @$tref ); - while (@$tref) { - my $val = shift @$tref; - my $expected = shift @$tref; - my $writeres = swrite( $writefmt, $val ); - if (ref $expected) { - like $writeres, $expected, $writefmt; - } else { - is $writeres, $expected, $writefmt; - } - } -} - - -##################################### -## Section 3 -## Easiest to add new tests just here -##################################### - -# DAPM. Exercise a couple of error codepaths - -{ - local $~ = ''; - eval { write }; - like $@, qr/Not a format reference/, 'format reference'; - - $~ = "NOSUCHFORMAT"; - eval { write }; - like $@, qr/Undefined format/, 'no such format'; -} - -{ - package Count; - - sub TIESCALAR { - my $class = shift; - bless [shift, 0, 0], $class; - } - - sub FETCH { - my $self = shift; - ++$self->[1]; - $self->[0]; - } - - sub STORE { - my $self = shift; - ++$self->[2]; - $self->[0] = shift; - } -} - -{ - my ($pound_utf8, $pm_utf8) = map { my $a = "$_\x{100}"; chop $a; $a} - my ($pound, $pm) = ("\xA3", "\xB1"); - - foreach my $first ('N', $pound, $pound_utf8) { - foreach my $base ('N', $pm, $pm_utf8) { - foreach my $second ($base, "$base\n", "$base\nMoo!", "$base\nMoo!\n", - "$base\nMoo!\n",) { - foreach (['^*', qr/(.+)/], ['@*', qr/(.*?)$/s]) { - my ($format, $re) = @$_; - foreach my $class ('', 'Count') { - my $name = "$first, $second $format $class"; - $name =~ s/\n/\\n/g; - - $first =~ /(.+)/ or die $first; - my $expect = "1${1}2"; - $second =~ $re or die $second; - $expect .= " 3${1}4"; - - if ($class) { - my $copy1 = $first; - my $copy2; - tie $copy2, $class, $second; - is swrite("1^*2 3${format}4", $copy1, $copy2), $expect, $name; - my $obj = tied $copy2; - is $obj->[1], 1, 'value read exactly once'; - } else { - my ($copy1, $copy2) = ($first, $second); - is swrite("1^*2 3${format}4", $copy1, $copy2), $expect, $name; - } - } - } - } - } - } -} - -{ - # This will fail an assertion in 5.10.0 built with -DDEBUGGING (because - # pp_formline attempts to set SvCUR() on an SVt_RV). I suspect that it will - # be doing something similarly out of bounds on everything from 5.000 - my $ref = []; - is swrite('>^*<', $ref), ">$ref<"; - is swrite('>@*<', $ref), ">$ref<"; -} - -format EMPTY = -. - -my $test = curr_test(); - -format Comment = -ok @<<<<< -$test -. - - -# [ID 20020227.005] format bug with undefined _TOP - -open STDOUT_DUP, ">&STDOUT"; -my $oldfh = select STDOUT_DUP; -$= = 10; -{ - local $~ = "Comment"; - write; - curr_test($test + 1); - { - local $::TODO = '[ID 20020227.005] format bug with undefined _TOP'; - is $-, 9; - } - is $^, "STDOUT_DUP_TOP"; -} -select $oldfh; -close STDOUT_DUP; - -*CmT = *{$::{Comment}}{FORMAT}; -ok defined *{$::{CmT}}{FORMAT}, "glob assign"; - -{ - my $buf = ""; - open my $fh, ">", \$buf; - my $old_fh = select $fh; - local $~ = "CmT"; - write; - select $old_fh; - close $fh; - is $buf, "ok $test\n", "write to duplicated format"; -} - -# TODO perlcc fails -fresh_perl_like(<<'EOP', qr/^Format STDOUT redefined at/, {stderr => 1}, '#64562 - Segmentation fault with redefined formats and warnings'); -#!./perl - -use strict; -use warnings; # crashes! - -format = -. - -write; - -format = -. - -write; -EOP - -############################# -## Section 4 -## Add new tests *above* here -############################# - -# scary format testing from H.Merijn Brand - -# Just a complete test for format, including top-, left- and bottom marging -# and format detection through glob entries - -if ($^O eq 'VMS' || $^O eq 'MSWin32' || $^O eq 'dos' || - ($^O eq 'os2' and not eval '$OS2::can_fork')) { - $test = curr_test(); - SKIP: { - skip "'|-' and '-|' not supported", $tests - $test + 1; - } - exit(0); -} - - -$^ = "STDOUT_TOP"; -$= = 7; # Page length -$- = 0; # Lines left -my $ps = $^L; $^L = ""; # Catch the page separator -my $tm = 1; # Top margin (empty lines before first output) -my $bm = 2; # Bottom marging (empty lines between last text and footer) -my $lm = 4; # Left margin (indent in spaces) - -# ----------------------------------------------------------------------- -# -# execute the rest of the script in a child process. The parent reads the -# output from the child and compares it with . - -my @data = ; - -select ((select (STDOUT), $| = 1)[0]); # flush STDOUT - -my $opened = open FROM_CHILD, "-|"; -unless (defined $opened) { - fail "open gave $!"; - exit 0; -} - -if ($opened) { - # in parent here - - pass 'open'; - my $s = " " x $lm; - while () { - unless (@data) { - fail 'too much output'; - exit; - } - s/^/$s/; - my $exp = shift @data; - # TODO #291 perlcc fails with \f\n instead of \n - is $_, $exp; - } - close FROM_CHILD; - is "@data", "", "correct length of output"; - exit; -} - -# in child here -$::NO_ENDING = 1; - - select ((select (STDOUT), $| = 1)[0]); -$tm = "\n" x $tm; -$= -= $bm + 1; # count one for the trailing "----" -my $lastmin = 0; - -my @E; - -sub wryte -{ - $lastmin = $-; - write; - } # wryte; - -sub footer -{ - $% == 1 and return ""; - - $lastmin < $= and print "\n" x $lastmin; - print "\n" x $bm, "----\n", $ps; - $lastmin = $-; - ""; - } # footer - -# Yes, this is sick ;-) -format TOP = -@* ~ -@{[footer]} -@* ~ -$tm -. - -format ENTRY = -@ @<<<<~~ -@{(shift @E)||["",""]} -. - -format EOR = -- ----- -. - -sub has_format ($) -{ - my $fmt = shift; - exists $::{$fmt} or return 0; - $^O eq "MSWin32" or return defined *{$::{$fmt}}{FORMAT}; - open my $null, "> /dev/null" or die; - my $fh = select $null; - local $~ = $fmt; - eval "write"; - select $fh; - $@?0:1; - } # has_format - -$^ = has_format ("TOP") ? "TOP" : "EMPTY"; -has_format ("ENTRY") or die "No format defined for ENTRY"; -foreach my $e ( [ map { [ $_, "Test$_" ] } 1 .. 7 ], - [ map { [ $_, "${_}tseT" ] } 1 .. 5 ]) { - @E = @$e; - local $~ = "ENTRY"; - wryte; - has_format ("EOR") or next; - local $~ = "EOR"; - wryte; - } -if (has_format ("EOF")) { - local $~ = "EOF"; - wryte; - } - -close STDOUT; - -# That was test 48. - -__END__ - - 1 Test1 - 2 Test2 - 3 Test3 - - - ---- - - 4 Test4 - 5 Test5 - 6 Test6 - - - ---- - - 7 Test7 - - ----- - - - - ---- - - 1 1tseT - 2 2tseT - 3 3tseT - - - ---- - - 4 4tseT - 5 5tseT - - ----- diff --git a/t/CORE/op/yadayada.t b/t/CORE/op/yadayada.t deleted file mode 100644 index 2bcb669da..000000000 --- a/t/CORE/op/yadayada.t +++ /dev/null @@ -1,49 +0,0 @@ -#!./perl - -BEGIN { - unshift @INC, 't/CORE/lib'; - require 't/CORE/test.pl'; -} - -use strict; - -plan 5; - -my $err = "Unimplemented at t/CORE/op/yadayada.t line " . ( __LINE__ + 2 ) . ".\n"; - -eval { ... }; - -is $@, $err; - - -# -# Regression tests, making sure ... is still parsable as an operator. -# -my @lines = split /\n/ => <<'--'; - -# Check simple range operator. -my @arr = 'A' ... 'D'; - -# Range operator with print. -print 'D' ... 'A'; - -# Without quotes, 'D' could be a file handle. -print D ... A ; - -# Another possible interaction with a file handle. -print ${\"D"} ... A ; --- - -foreach my $line (@lines) { - next if $line =~ /^\s*#/ || $line !~ /\S/; - my $mess = qq {Parsing '...' in "$line" as a range operator}; - eval qq { - {local *STDOUT; no strict "subs"; $line;} - pass \$mess; - 1; - } or do { - my $err = $@; - $err =~ s/\n//g; - fail "$mess ($err)"; - } -} diff --git a/t/CORE/re/charset.t b/t/CORE/re/charset.t deleted file mode 100644 index 698f5f4c6..000000000 --- a/t/CORE/re/charset.t +++ /dev/null @@ -1,273 +0,0 @@ -# Test the /a, /d, etc regex modifiers - -BEGIN { - require q(t/CORE/test.pl); -} - -use strict; -use warnings; - -plan('no_plan'); - -# Each case is a valid element of its hash key. Choose, where available, an -# ASCII-range, Latin-1 non-ASCII range, and above Latin1 range code point. -my %testcases = ( - '\w' => [ ord("A"), 0xE2, 0x16B ], # Below expects these to all be alpha - '\d' => [ ord("0"), 0x0662 ], - '\s' => [ ord("\t"), 0xA0, 0x1680 ], # Below expects these to be [:blank:] - '[:cntrl:]' => [ 0x00, 0x88 ], - '[:graph:]' => [ ord("&"), 0xF7, 0x02C7 ], # Below expects these to be - # [:print:] - '[:lower:]' => [ ord("g"), 0xE3, 0x0127 ], - '[:punct:]' => [ ord("!"), 0xBF, 0x055C ], - '[:upper:]' => [ ord("G"), 0xC3, 0x0126 ], - '[:xdigit:]' => [ ord("4"), 0xFF15 ], -); - -$testcases{'[:digit:]'} = $testcases{'\d'}; -$testcases{'[:alnum:]'} = $testcases{'\w'}; -$testcases{'[:alpha:]'} = $testcases{'\w'}; -$testcases{'[:blank:]'} = $testcases{'\s'}; -$testcases{'[:print:]'} = $testcases{'[:graph:]'}; -$testcases{'[:space:]'} = $testcases{'\s'}; -$testcases{'[:word:]'} = $testcases{'\w'}; - -my @charsets = qw(a d u aa); -if (1) { - require POSIX; - my $current_locale = POSIX::setlocale( &POSIX::LC_ALL, "C") // ""; - if ($current_locale eq 'C') { - use locale; - - # Some locale implementations don't have the 128-255 characters all - # mean nothing. Skip the locale tests in that situation - for my $i (128 .. 255) { - goto bad_locale if chr($i) =~ /[[:print:]]/; - } - push @charsets, 'l'; - bad_locale: - } -} - -# For each possible character set... -foreach my $charset (@charsets) { - - # And in utf8 or not - foreach my $upgrade ("", 'utf8::upgrade($a); ') { - - # reverse gets the, \w, \s, \d first. - for my $class (reverse sort keys %testcases) { - - # The complement of \w is \W; of [:posix:] is [:^posix:] - my $complement = $class; - if ($complement !~ s/ ( \[: ) /$1^/x) { - $complement = uc($class); - } - - # For each test case - foreach my $ord (@{$testcases{$class}}) { - my $char = display(chr($ord)); - - # > 255 already implies upgraded. Skip the ones that don't - # have an explicit upgrade. This shows more clearly in the - # output which tests are in utf8, or not. - next if $ord > 255 && ! $upgrade; - - my $reason = ""; # Explanation output with each test - my $neg_reason = ""; - my $match = 1; # Calculated whether test regex should - # match or not - - # Everything always matches in ASCII, or under /u - if ($ord < 128 || $charset eq 'u') { - $reason = "\"$char\" is a $class under /$charset"; - $neg_reason = "\"$char\" is not a $complement under /$charset"; - } - elsif ($charset eq "a" || $charset eq "aa") { - $match = 0; - $reason = "\"$char\" is non-ASCII, which can't be a $class under /a"; - $neg_reason = "\"$char\" is non-ASCII, which is a $complement under /a"; - } - elsif ($ord > 255) { - $reason = "\"$char\" is a $class under /$charset"; - $neg_reason = "\"$char\" is not a $complement under /$charset"; - } - elsif ($charset eq 'l') { - - # We are using the C locale, which is essentially ASCII, - # but under utf8, the above-latin1 chars are treated as - # Unicode) - $reason = "\"$char\" is not a $class in this locale under /l"; - $neg_reason = "\"$char\" is a $complement in this locale under /l"; - $match = 0; - } - elsif ($upgrade) { - $reason = "\"$char\" is a $class in utf8 under /d"; - $neg_reason = "\"$char\" is not a $complement in utf8 under /d"; - } - else { - $reason = "\"$char\" is above-ASCII latin1, which requires utf8 to be a $class under /d"; - $neg_reason = "\"$char\" is above-ASCII latin1, which is a $complement under /d (unless in utf8)"; - $match = 0; - } - $reason = "; $reason" if $reason; - $neg_reason = "; $neg_reason" if $neg_reason; - - my $op; - my $neg_op; - if ($match) { - $op = '=~'; - $neg_op = '!~'; - } - else { - $op = '!~'; - $neg_op = '=~'; - } - - # In [...] or not - foreach my $bracketed (0, 1) { - my $lb = ""; - my $rb = ""; - if ($bracketed) { - - # Adds an extra char to the character class to make sure - # that the class doesn't get optimized away. - $lb = ($bracketed) ? '[_' : ""; - $rb = ($bracketed) ? ']' : ""; - } - else { # [:posix:] must be inside outer [ ] - next if $class =~ /\[/; - } - - my $length = 10; # For regexec.c regrepeat() cases by - # matching more than one item - # Test both class and its complement, and with one or more - # than one item to match. - foreach my $eval ( - qq[my \$a = "$char"; $upgrade\$a $op qr/ (?$charset: $lb$class$rb ) /x], - qq[my \$a = "$char" x $length; $upgrade\$a $op qr/ (?$charset: $lb$class$rb\{$length} ) /x], - ) { - ok (eval $eval, $eval . $reason); - } - foreach my $eval ( - qq[my \$a = "$char"; $upgrade\$a $neg_op qr/ (?$charset: $lb$complement$rb ) /x], - qq[my \$a = "$char" x $length; $upgrade\$a $neg_op qr/ (?$charset: $lb$complement$rb\{$length} ) /x], - ) { - ok (eval $eval, $eval . $neg_reason); - } - } - - next if $class ne '\w'; - - # Test \b, \B at beginning and end of string - foreach my $eval ( - qq[my \$a = "$char"; $upgrade\$a $op qr/ (?$charset: ^ \\b . ) /x], - qq[my \$a = "$char"; $upgrade\$a $op qr/ (?$charset: . \\b \$) /x], - ) { - ok (eval $eval, $eval . $reason); - } - foreach my $eval ( - qq[my \$a = "$char"; $upgrade\$a $neg_op qr/(?$charset: ^ \\B . ) /x], - qq[my \$a = "$char"; $upgrade\$a $neg_op qr/(?$charset: . \\B \$ ) /x], - ) { - ok (eval $eval, $eval . $neg_reason); - } - - # Test \b, \B adjacent to a non-word char, both before it and - # after. We test with ASCII, Latin1 and Unicode non-word chars - foreach my $space_ord (@{$testcases{'\s'}}) { - - # Useless to try to test non-utf8 when the ord itself - # forces utf8 - next if $space_ord > 255 && ! $upgrade; - - my $space = display(chr $space_ord); - - foreach my $eval ( - qq[my \$a = "$space$char"; $upgrade\$a $op qr/ (?$charset: . \\b . ) /x], - qq[my \$a = "$char$space"; $upgrade\$a $op qr/ (?$charset: . \\b . ) /x], - ) { - ok (eval $eval, $eval . $reason . "; \"$space\" is not a \\w"); - } - foreach my $eval ( - qq[my \$a = "$space$char"; $upgrade\$a $neg_op qr/ (?$charset: . \\B . ) /x], - qq[my \$a = "$char$space"; $upgrade\$a $neg_op qr/ (?$charset: . \\B . ) /x], - ) { - ok (eval $eval, $eval . $neg_reason . "; \"$space\" is not a \\w"); - } - } - - # Test \b, \B in the middle of two nominally word chars, but - # one or both may be considered non-word depending on range - # and charset. - foreach my $other_ord (@{$testcases{'\w'}}) { - next if $other_ord > 255 && ! $upgrade; - my $other = display(chr $other_ord); - - # Determine if the other char is a word char in current - # circumstances - my $other_is_word = 1; - my $other_reason = "\"$other\" is a $class under /$charset"; - my $other_neg_reason = "\"$other\" is not a $complement under /$charset"; - if ($other_ord > 127 - && $charset ne 'u' - && (($charset eq "a" || $charset eq "aa") - || ($other_ord < 256 && ($charset eq 'l' || ! $upgrade)))) - { - $other_is_word = 0; - $other_reason = "\"$other\" is not a $class under /$charset"; - $other_neg_reason = "\"$other\" is a $complement under /$charset"; - } - my $both_reason = $reason; - $both_reason .= "; $other_reason" if $other_ord != $ord; - my $both_neg_reason = $neg_reason; - $both_neg_reason .= "; $other_neg_reason" if $other_ord != $ord; - - # If both are the same wordness, then \b will fail; \B - # succeed - if ($match == $other_is_word) { - $op = '!~'; - $neg_op = '=~'; - } - else { - $op = '=~'; - $neg_op = '!~'; - } - - foreach my $eval ( - qq[my \$a = "$other$char"; $upgrade\$a $op qr/ (?$charset: $other \\b $char ) /x], - qq[my \$a = "$char$other"; $upgrade\$a $op qr/ (?$charset: $char \\b $other ) /x], - ) { - ok (eval $eval, $eval . $both_reason); - } - foreach my $eval ( - qq[my \$a = "$other$char"; $upgrade\$a $neg_op qr/ (?$charset: $other \\B $char ) /x], - qq[my \$a = "$char$other"; $upgrade\$a $neg_op qr/ (?$charset: $char \\B $other ) /x], - ) { - ok (eval $eval, $eval . $both_neg_reason); - } - - next if $other_ord == $ord; - - # These start with the \b or \B. They are included, based - # on source code analysis, to force the testing of the FBC - # (find_by_class) portions of regexec.c. - foreach my $eval ( - qq[my \$a = "$other$char"; $upgrade\$a $op qr/ (?$charset: \\b $char ) /x], - qq[my \$a = "$char$other"; $upgrade\$a $op qr/ (?$charset: \\b $other ) /x], - ) { - ok (eval $eval, $eval . $both_reason); - } - foreach my $eval ( - qq[my \$a = "$other$char"; $upgrade\$a $neg_op qr/ (?$charset: \\B $char ) /x], - qq[my \$a = "$char$other"; $upgrade\$a $neg_op qr/ (?$charset: \\B $other ) /x], - ) { - ok (eval $eval, $eval . $both_neg_reason); - } - } - } # End of each test case in a class - } # End of \w, \s, ... - } # End of utf8 upgraded or not -} - -plan(curr_test() - 1); diff --git a/t/CORE/re/fold_grind.t b/t/CORE/re/fold_grind.t deleted file mode 100644 index f5f43e2c1..000000000 --- a/t/CORE/re/fold_grind.t +++ /dev/null @@ -1,610 +0,0 @@ -# Grind out a lot of combinatoric tests for folding. - -binmode STDOUT, ":utf8"; - -BEGIN { - require q(t/CORE/test.pl); -} - -use charnames ":full"; - -my $DEBUG = 0; # Outputs extra information for debugging this .t - -use strict; -use warnings; -use Encode; -use POSIX; - -# Tests both unicode and not, so make sure not implicitly testing unicode -no feature 'unicode_strings'; - -# Case-insensitive matching is a large and complicated issue. Perl does not -# implement it fully, properly. For example, it doesn't include normalization -# as part of the equation. To test every conceivable combination is clearly -# impossible; these tests are mostly drawn from visual inspection of the code -# and experience, trying to exercise all areas. - -# There are three basic ranges of characters that Perl may treat differently: -# 1) Invariants under utf8 which on ASCII-ish machines are ASCII, and are -# referred to here as ASCII. On EBCDIC machines, the non-ASCII invariants -# are all controls that fold to themselves. -my $ASCII = 1; - -# 2) Other characters that fit into a byte but are different in utf8 than not; -# here referred to, taking some liberties, as Latin1. -my $Latin1 = 2; - -# 3) Characters that won't fit in a byte; here referred to as Unicode -my $Unicode = 3; - -# Within these basic groups are equivalence classes that testing any character -# in is likely to lead to the same results as any other character. This is -# used to cut down the number of tests needed, unless PERL_RUN_SLOW_TESTS is -# set. -my $skip_apparently_redundant = ! $ENV{PERL_RUN_SLOW_TESTS}; - -# Additionally parts of this test run a lot of subtests, outputting the -# resulting TAP can be expensive so the tests are summarised internally. The -# PERL_DEBUG_FULL_TEST environment variable can be set to produce the full -# output for debugging purposes. - -sub range_type { - my $ord = shift; - - return $ASCII if $ord < 128; - return $Latin1 if $ord < 256; - return $Unicode; -} - -sub numerically { - return $a <=> $b -} - -sub run_test($$$$) { - my ($test, $count, $todo, $debug) = @_; - - $debug = "" unless $DEBUG; - ok(eval $test, "$test; $debug"); -} - -my %tests; # The final set of tests. keys are the code points to test -my %simple_folds; -my %multi_folds; - -# First, analyze the current Unicode's folding rules -my %folded_from; -my $file="t/CORE/CaseFolding.txt"; -open my $fh, "<", $file or die "Failed to read '$file': $!"; -while (<$fh>) { - chomp; - - # Lines look like (though without the initial '#') - #0130; F; 0069 0307; # LATIN CAPITAL LETTER I WITH DOT ABOVE - - my ($line, $comment) = split / \s+ \# \s+ /x, $_; - next if $line eq "" || substr($line, 0, 1) eq '#'; - my ($hex_from, $fold_type, @folded) = split /[\s;]+/, $line; - - my $from = hex $hex_from; - - if ($fold_type eq 'F') { - my $from_range_type = range_type($from); - - # If we were testing comprehensively, we would try every combination - # of upper and lower case in the fold, but it is quite likely that if - # the code can handle all combinations if it can handle the cases - # where everything is upper and when everything is lower. Because of - # complement matching, we need to do both. And we use the - # reverse-fold instead of uppercase. - @folded = map { hex $_ } @folded; - # XXX better to use reverse fold of these instead of uc - my @uc_folded = map { ord uc chr $_ } @folded; - - # Include three code points that are handled internally by the regex - # engine specially, plus all non-above-255 multi folds (which actually - # the only one is already included in the three, but this makes sure) - # And if any member of the fold is not the same range type as the - # source, add it directly to the tests. It needs to be an array of an - # array, so that it is distinguished from multiple single folds - if ($from == 0xDF || $from == 0x390 || $from == 0x3B0 - || $from_range_type != $Unicode - || grep { range_type($_) != $from_range_type } @folded) - { - $tests{$from} = [ [ @folded ], [ @uc_folded ] ]; - } - else { - - # The only multi-char non-utf8 fold is DF, which is handled above, - # so here chr() must be utf8. Get the number of bytes in each. - # This is because the optimizer cares about length differences. - my $from_length = length encode('UTF-8', chr($from)); - my $to_length = length encode('UTF-8', pack 'U*', @folded); - push @{$multi_folds{$from_length}{$to_length}}, { $from => [ [ @folded ], [ @uc_folded ] ] }; - } - } - - # Perl only deals with C and F folds - next if $fold_type ne 'C'; - - # C folds are single-char $from to single-char $folded, in chr terms - # folded_from{'s'} = [ 'S', \N{LATIN SMALL LETTER LONG S} ] - push @{$folded_from{hex $folded[0]}}, $from; -} - -# Now try to sort the single char folds into equivalence classes that are -# likely to have identical successes and failures. Any fold that crosses -# range types is suspect, and is automatically tested. Otherwise, store by -# the number of characters that participate in a fold. Likely all folds in a -# range type that fold to each other like B->b->B will have identical success -# and failure; similarly all folds that have three characters participating -# are likely to have the same successes and failures, etc. -foreach my $folded (sort numerically keys %folded_from) { - my $target_range_type = range_type($folded); - my $count = @{$folded_from{$folded}}; - - # Automatically test any fold that crosses range types - if (grep { range_type($_) != $target_range_type } @{$folded_from{$folded}}) - { - $tests{$folded} = $folded_from{$folded}; - } - else { - push @{$simple_folds{$target_range_type}{$count}}, - { $folded => $folded_from{$folded} }; - } -} - -foreach my $from_length (keys %multi_folds) { - foreach my $fold_length (keys %{$multi_folds{$from_length}}) { - #print __LINE__, ref $multi_folds{$from_length}{$fold_length}, Dumper $multi_folds{$from_length}{$fold_length}; - foreach my $test (@{$multi_folds{$from_length}{$fold_length}}) { - #print __LINE__, ": $from_length, $fold_length, $test:\n"; - my ($target, $pattern) = each %$test; - #print __LINE__, ": $target: $pattern\n"; - $tests{$target} = $pattern; - last if $skip_apparently_redundant; - } - } -} - -# Add in tests for single character folds. Add tests for each range type, -# and within those tests for each number of characters participating in a -# fold. Thus B->b has two characters participating. But K->k and Kelvin -# Sign->k has three characters participating. So we would make sure that -# there is a test for 3 chars, 4 chars, ... . (Note that the 'k' example is a -# bad one because it crosses range types, so is automatically tested. In the -# Unicode range there are various of these 3 and 4 char classes, but aren't as -# easily described as the 'k' one.) -foreach my $type (keys %simple_folds) { - foreach my $count (keys %{$simple_folds{$type}}) { - foreach my $test (@{$simple_folds{$type}{$count}}) { - my ($target, $pattern) = each %$test; - $tests{$target} = $pattern; - last if $skip_apparently_redundant; - } - } -} - -# For each range type, test additionally a character that folds to itself -$tests{0x3A} = [ 0x3A ]; -$tests{0xF7} = [ 0xF7 ]; -$tests{0x2C7} = [ 0x2C7 ]; - - -# To cut down on the number of tests -my $has_tested_aa_above_latin1; -my $has_tested_latin1_aa; -my $has_tested_ascii_aa; -my $has_tested_l_above_latin1; -my $has_tested_above_latin1_l; -my $has_tested_ascii_l; -my $has_tested_above_latin1_d; -my $has_tested_ascii_d; -my $has_tested_non_latin1_d; -my $has_tested_above_latin1_a; -my $has_tested_ascii_a; -my $has_tested_non_latin1_a; - -# For use by pairs() in generating combinations -sub prefix { - my $p = shift; - map [ $p, $_ ], @_ -} - -# Returns all ordered combinations of pairs of elements from the input array. -# It doesn't return pairs like (a, a), (b, b). Change the slice to an array -# to do that. This was just to have fewer tests. -sub pairs (@) { - #print __LINE__, ": ", join(" XXX ", @_), "\n"; - map { prefix $_[$_], @_[0..$_-1, $_+1..$#_] } 0..$#_ -} - -my @charsets = qw(d u a aa); -my $current_locale = POSIX::setlocale( &POSIX::LC_ALL, "C") // ""; -push @charsets, 'l' if $current_locale eq 'C'; - -# Finally ready to do the tests -my $count=0; -foreach my $test (sort { numerically } keys %tests) { - - my $previous_target; - my $previous_pattern; - my @pairs = pairs(sort numerically $test, @{$tests{$test}}); - - # Each fold can be viewed as a closure of all the characters that - # participate in it. Look at each possible pairing from a closure, with the - # first member of the pair the target string to match against, and the - # second member forming the pattern. Thus each fold member gets tested as - # the string, and the pattern with every other member in the opposite role. - while (my $pair = shift @pairs) { - my ($target, $pattern) = @$pair; - - # When testing a char that doesn't fold, we can get the same - # permutation twice; so skip all but the first. - next if $previous_target - && $previous_target == $target - && $previous_pattern == $pattern; - ($previous_target, $previous_pattern) = ($target, $pattern); - - # Each side may be either a single char or a string. Extract each into an - # array (perhaps of length 1) - my @target, my @pattern; - @target = (ref $target) ? @$target : $target; - @pattern = (ref $pattern) ? @$pattern : $pattern; - - # Have to convert non-utf8 chars to native char set - @target = map { $_ > 255 ? $_ : ord latin1_to_native(chr($_)) } @target; - @pattern = map { $_ > 255 ? $_ : ord latin1_to_native(chr($_)) } @pattern; - - # Get in hex form. - my @x_target = map { sprintf "\\x{%04X}", $_ } @target; - my @x_pattern = map { sprintf "\\x{%04X}", $_ } @pattern; - - my $target_above_latin1 = grep { $_ > 255 } @target; - my $pattern_above_latin1 = grep { $_ > 255 } @pattern; - my $target_has_ascii = grep { $_ < 128 } @target; - my $pattern_has_ascii = grep { $_ < 128 } @pattern; - my $target_only_ascii = ! grep { $_ > 127 } @target; - my $pattern_only_ascii = ! grep { $_ > 127 } @pattern; - my $target_has_latin1 = grep { $_ < 256 } @target; - my $target_has_upper_latin1 = grep { $_ < 256 && $_ > 127 } @target; - my $pattern_has_upper_latin1 = grep { $_ < 256 && $_ > 127 } @pattern; - my $pattern_has_latin1 = grep { $_ < 256 } @pattern; - my $is_self = @target == 1 && @pattern == 1 && $target[0] == $pattern[0]; - - # We don't test multi-char folding into other multi-chars. We are testing - # a code point that folds to or from other characters. Find the single - # code point for diagnostic purposes. (If both are single, choose the - # target string) - my $ord = @target == 1 ? $target[0] : $pattern[0]; - my $progress = sprintf "%04X: \"%s\" and /%s/", - $test, - join("", @x_target), - join("", @x_pattern); - #print $progress, "\n"; - #diag $progress; - - # Now grind out tests, using various combinations. - foreach my $charset (@charsets) { - - # To cut down somewhat on the enormous quantity of tests this currently - # runs, skip some for some of the character sets whose results aren't - # likely to differ from others. But run all tests on the code points - # that don't fold, plus one other set in each range group. - if (! $is_self) { - - # /aa should only affect things with folds in the ASCII range. But, try - # it on one set in the other ranges just to make sure it doesn't break - # them. - if ($charset eq 'aa') { - if (! $target_has_ascii && ! $pattern_has_ascii) { - if ($target_above_latin1 || $pattern_above_latin1) { - next if defined $has_tested_aa_above_latin1 - && $has_tested_aa_above_latin1 != $test; - $has_tested_aa_above_latin1 = $test; - } - next if defined $has_tested_latin1_aa - && $has_tested_latin1_aa != $test; - $has_tested_latin1_aa = $test; - } - elsif ($target_only_ascii && $pattern_only_ascii) { - - # And, except for one set just to make sure, skip tests - # where both elements in the pair are ASCII. If one works for - # aa, the others are likely too. This skips tests where the - # fold is from non-ASCII to ASCII, but this part of the test - # is just about the ASCII components. - next if defined $has_tested_ascii_l - && $has_tested_ascii_l != $test; - $has_tested_ascii_l = $test; - } - } - elsif ($charset eq 'l') { - - # For l, don't need to test beyond one set those things that are - # all above latin1, because unlikely to have different successes - # than /u - if (! $target_has_latin1 && ! $pattern_has_latin1) { - next if defined $has_tested_above_latin1_l - && $has_tested_above_latin1_l != $test; - $has_tested_above_latin1_l = $test; - } - elsif ($target_only_ascii && $pattern_only_ascii) { - - # And, except for one set just to make sure, skip tests - # where both elements in the pair are ASCII. This is - # essentially the same reasoning as above for /aa. - next if defined $has_tested_ascii_l - && $has_tested_ascii_l != $test; - $has_tested_ascii_l = $test; - } - } - elsif ($charset eq 'd') { - # Similarly for d. Beyond one test (besides self) each, we don't - # test pairs that are both ascii; or both above latin1, or are - # combinations of ascii and above latin1. - if (! $target_has_upper_latin1 && ! $pattern_has_upper_latin1) { - if ($target_has_ascii && $pattern_has_ascii) { - next if defined $has_tested_ascii_d - && $has_tested_ascii_d != $test; - $has_tested_ascii_d = $test - } - elsif (! $target_has_latin1 && ! $pattern_has_latin1) { - next if defined $has_tested_above_latin1_d - && $has_tested_above_latin1_d != $test; - $has_tested_above_latin1_d = $test; - } - else { - next if defined $has_tested_non_latin1_d - && $has_tested_non_latin1_d != $test; - $has_tested_non_latin1_d = $test; - } - } - } - elsif ($charset eq 'a') { - # Similarly for a. This should match identically to /u, so wasn't - # tested at all until a bug was found that was thereby missed. - # As a compromise, beyond one test (besides self) each, we don't - # test pairs that are both ascii; or both above latin1, or are - # combinations of ascii and above latin1. - if (! $target_has_upper_latin1 && ! $pattern_has_upper_latin1) { - if ($target_has_ascii && $pattern_has_ascii) { - next if defined $has_tested_ascii_a - && $has_tested_ascii_a != $test; - $has_tested_ascii_a = $test - } - elsif (! $target_has_latin1 && ! $pattern_has_latin1) { - next if defined $has_tested_above_latin1_a - && $has_tested_above_latin1_a != $test; - $has_tested_above_latin1_a = $test; - } - else { - next if defined $has_tested_non_latin1_a - && $has_tested_non_latin1_a != $test; - $has_tested_non_latin1_a = $test; - } - } - } - } - - foreach my $utf8_target (0, 1) { # Both utf8 and not, for - # code points < 256 - my $upgrade_target = ""; - - # These must already be in utf8 because the string to match has - # something above latin1. So impossible to test if to not to be in - # utf8; and otherwise, no upgrade is needed. - next if $target_above_latin1 && ! $utf8_target; - $upgrade_target = ' utf8::upgrade($c);' if ! $target_above_latin1 && $utf8_target; - - foreach my $utf8_pattern (0, 1) { - next if $pattern_above_latin1 && ! $utf8_pattern; - - # Our testing of 'l' uses the POSIX locale, which is ASCII-only - my $uni_semantics = $charset ne 'l' && ($utf8_target || $charset eq 'u' || ($charset eq 'd' && $utf8_pattern) || $charset =~ /a/); - my $upgrade_pattern = ""; - $upgrade_pattern = ' utf8::upgrade($p);' if ! $pattern_above_latin1 && $utf8_pattern; - - my $lhs = join "", @x_target; - my $lhs_str = eval qq{"$lhs"}; fail($@) if $@; - my @rhs = @x_pattern; - my $rhs = join "", @rhs; - my $should_fail = (! $uni_semantics && $ord >= 128 && $ord < 256 && ! $is_self) - || ($charset eq 'aa' && $target_has_ascii != $pattern_has_ascii) - || ($charset eq 'l' && $target_has_latin1 != $pattern_has_latin1); - - # Do simple tests of referencing capture buffers, named and - # numbered. - my $op = '=~'; - $op = '!~' if $should_fail; - - # I'm afraid this was derived from trial and error. - my $todo = ($test == 0xdf - && $lhs =~ /DF/ - && $uni_semantics - && ($charset eq 'u' || $charset eq 'a' || $charset eq 'd') - && ! (($charset eq 'u' || $charset eq 'a') - && (($upgrade_target eq "") != ($upgrade_pattern eq ""))) - && ! ($charset eq 'd' && (! $upgrade_target || ! $upgrade_pattern)) - ); - my $eval = "my \$c = \"$lhs$rhs\"; my \$p = qr/(?$charset:^($rhs)\\1\$)/i;$upgrade_target$upgrade_pattern \$c $op \$p"; - run_test($eval, ++$count, $todo, ""); - - $eval = "my \$c = \"$lhs$rhs\"; my \$p = qr/(?$charset:^(?$rhs)\\k\$)/i;$upgrade_target$upgrade_pattern \$c $op \$p"; - run_test($eval, ++$count, $todo, ""); - - if ($lhs ne $rhs) { - $eval = "my \$c = \"$rhs$lhs\"; my \$p = qr/(?$charset:^($rhs)\\1\$)/i;$upgrade_target$upgrade_pattern \$c $op \$p"; - run_test($eval, ++$count, "", ""); - - $eval = "my \$c = \"$rhs$lhs\"; my \$p = qr/(?$charset:^(?$rhs)\\k\$)/i;$upgrade_target$upgrade_pattern \$c $op \$p"; - run_test($eval, ++$count, "", ""); - } - - # XXX Doesn't currently test multi-char folds in pattern - next if @pattern != 1; - - # See if works on what could be a simple trie. - $eval = "my \$c = \"$lhs\"; my \$p = qr/$rhs|xyz/i$charset;$upgrade_target$upgrade_pattern \$c $op \$p"; - run_test($eval, ++$count, "", ""); - - my $okays = 0; - my $this_iteration = 0; - - foreach my $bracketed (0, 1) { # Put rhs in [...], or not - foreach my $inverted (0,1) { - next if $inverted && ! $bracketed; # inversion only valid in [^...] - next if $inverted && @target != 1; # [perl #89750] multi-char - # not valid in [^...] - - # In some cases, add an extra character that doesn't fold, and - # looks ok in the output. - my $extra_char = "_"; - foreach my $prepend ("", $extra_char) { - foreach my $append ("", $extra_char) { - - # Assemble the rhs. Put each character in a separate - # bracketed if using charclasses. This creates a stress on - # the code to span a match across multiple elements - my $rhs = ""; - foreach my $rhs_char (@rhs) { - $rhs .= '[' if $bracketed; - $rhs .= '^' if $inverted; - $rhs .= $rhs_char; - - # Add a character to the class, so class doesn't get - # optimized out - $rhs .= '_]' if $bracketed; - } - - # Add one of: no capturing parens - # a single set - # a nested set - # Use quantifiers and extra variable width matches inside - # them to keep some optimizations from happening - foreach my $parend (0, 1, 2) { - my $interior = (! $parend) - ? $rhs - : ($parend == 1) - ? "(${rhs},?)" - : "((${rhs})+,?)"; - foreach my $quantifier ("", '?', '*', '+', '{1,3}') { - - # A ? or * quantifier normally causes the thing to be - # able to match a null string - my $quantifier_can_match_null = $quantifier eq '?' || $quantifier eq '*'; - - # But since we only quantify the last character in a - # multiple fold, the other characters will have width, - # except if we are quantifying the whole rhs - my $can_match_null = $quantifier_can_match_null && (@rhs == 1 || $parend); - - foreach my $l_anchor ("", '^') { # '\A' didn't change result) - foreach my $r_anchor ("", '$') { # '\Z', '\z' didn't change result) - - # The folded part can match the null string if it - # isn't required to have width, and there's not - # something on one or both sides that force it to. - my $both_sides = ($l_anchor && $r_anchor) || ($l_anchor && $append) || ($r_anchor && $prepend) || ($prepend && $append); - my $must_match = ! $can_match_null || $both_sides; - # for performance, but doing this missed many failures - #next unless $must_match; - my $quantified = "(?$charset:$l_anchor$prepend$interior${quantifier}$append$r_anchor)"; - my $op; - if ($must_match && $should_fail) { - $op = 0; - } else { - $op = 1; - } - $op = ! $op if $must_match && $inverted; - - if ($inverted && @target > 1) { - # When doing an inverted match against a - # multi-char target, and there is not something on - # the left to anchor the match, if it shouldn't - # succeed, skip, as what will happen (when working - # correctly) is that it will match the first - # position correctly, and then be inverted to not - # match; then it will go to the second position - # where it won't match, but get inverted to match, - # and hence succeeding. - next if ! ($l_anchor || $prepend) && ! $op; - - # Can't ever match for latin1 code points non-uni - # semantics that have a inverted multi-char fold - # when there is something on both sides and the - # quantifier isn't such as to span the required - # width, which is 2 or 3. - $op = 0 if $ord < 255 - && ! $uni_semantics - && $both_sides - && ( ! $quantifier || $quantifier eq '?') - && $parend < 2; - - # Similarly can't ever match when inverting a multi-char - # fold for /aa and the quantifier isn't sufficient - # to allow it to span to both sides. - $op = 0 if $target_has_ascii && $charset eq 'aa' && $both_sides && ( ! $quantifier || $quantifier eq '?') && $parend < 2; - - # Or for /l - $op = 0 if $target_has_latin1 && $charset eq 'l' && $both_sides && ( ! $quantifier || $quantifier eq '?') && $parend < 2; - } - - - my $desc = "my \$c = \"$prepend$lhs$append\"; " - . "my \$p = qr/$quantified/i;" - . "$upgrade_target$upgrade_pattern " - . "\$c " . ($op ? "=~" : "!~") . " \$p; "; - if ($DEBUG) { - $desc .= ( - "; uni_semantics=$uni_semantics, " - . "should_fail=$should_fail, " - . "bracketed=$bracketed, " - . "prepend=$prepend, " - . "append=$append, " - . "parend=$parend, " - . "quantifier=$quantifier, " - . "l_anchor=$l_anchor, " - . "r_anchor=$r_anchor; " - . "pattern_above_latin1=$pattern_above_latin1; " - . "utf8_pattern=$utf8_pattern" - ); - } - - my $c = "$prepend$lhs_str$append"; - my $p = qr/$quantified/i; - utf8::upgrade($c) if length($upgrade_target); - utf8::upgrade($p) if length($upgrade_pattern); - my $res = $op ? ($c =~ $p): ($c !~ $p); - - if (!$res || $ENV{PERL_DEBUG_FULL_TEST}) { - # Failed or debug; output the result - $count++; - ok($res, $desc); - } else { - # Just count the test as passed - $okays++; - } - $this_iteration++; - } - } - } - } - } - } - } - } - - unless($ENV{PERL_DEBUG_FULL_TEST}) { - $count++; - is $okays, $this_iteration, "Subtests okay for " - . "charset=$charset, utf8_pattern=$utf8_pattern"; - } - } - } - } - } -} - -plan($count); - -1 diff --git a/t/CORE/re/no_utf8_pm.t b/t/CORE/re/no_utf8_pm.t deleted file mode 100644 index 8d49751f3..000000000 --- a/t/CORE/re/no_utf8_pm.t +++ /dev/null @@ -1,12 +0,0 @@ -#!./perl - -print "1..1\n"; - -# Make sure that case-insensitive matching of any Latin1 chars don't load -# utf8.pm. We assume that NULL won't force loading utf8.pm, and since it -# doesn't match any of the other chars, the regexec.c code would try to load -# a swash if it thought there was one. -"\0" =~ /[\001-\xFF]/i; - -print "not" if exists $INC{"utf8.pm"}; -print "ok 1\n"; diff --git a/t/CORE/re/overload.t b/t/CORE/re/overload.t deleted file mode 100644 index 538029ab7..000000000 --- a/t/CORE/re/overload.t +++ /dev/null @@ -1,34 +0,0 @@ -#!./perl -w - -BEGIN { - require q(t/CORE/test.pl); -} - -use strict; -no warnings 'syntax'; - -{ - # Bug #77084 points out a corruption problem when scalar //g is used - # on overloaded objects. - - my @realloc; - my $TAG = "foo:bar"; - use overload '""' => sub {$TAG}; - - my $o = bless []; - my ($one) = $o =~ /(.*)/g; - push @realloc, "xxxxxx"; # encourage realloc of SV and PVX - is $one, $TAG, "list context //g against overloaded object"; - - - my $r = $o =~ /(.*)/g; - push @realloc, "yyyyyy"; # encourage realloc of SV and PVX - is $1, $TAG, "scalar context //g against overloaded object"; - pos ($o) = 0; # Reset pos, as //g in scalar context sets it to non-0. - - $o =~ /(.*)/g; - push @realloc, "zzzzzz"; # encourage realloc of SV and PVX - is $1, $TAG, "void context //g against overloaded object"; -} - -done_testing(); diff --git a/t/CORE/re/pat.t b/t/CORE/re/pat.t deleted file mode 100644 index 93996f84b..000000000 --- a/t/CORE/re/pat.t +++ /dev/null @@ -1,1193 +0,0 @@ -#!./perl -# -# This is a home for regular expression tests that don't fit into -# the format supported by re/regexp.t. If you want to add a test -# that does fit that format, add it to re/re_tests, not here. Tests for \N -# should be added here because they are treated as single quoted strings -# there, which means they avoid the lexer which otherwise would look at them. - -use strict; -use warnings; -use 5.010; - -sub run_tests; - -$| = 1; - - -BEGIN { - require q(t/CORE/test.pl); -} - -plan tests => 452; # Update this when adding/deleting tests. - -run_tests() unless caller; - -# -# Tests start here. -# -sub run_tests { - - { - my $x = "abc\ndef\n"; - (my $x_pretty = $x) =~ s/\n/\\n/g; - - ok $x =~ /^abc/, qq ["$x_pretty" =~ /^abc/]; - ok $x !~ /^def/, qq ["$x_pretty" !~ /^def/]; - - # used to be a test for $* - ok $x =~ /^def/m, qq ["$x_pretty" =~ /^def/m]; - - ok(!($x =~ /^xxx/), qq ["$x_pretty" =~ /^xxx/]); - ok(!($x !~ /^abc/), qq ["$x_pretty" !~ /^abc/]); - - ok $x =~ /def/, qq ["$x_pretty" =~ /def/]; - ok(!($x !~ /def/), qq ["$x_pretty" !~ /def/]); - - ok $x !~ /.def/, qq ["$x_pretty" !~ /.def/]; - ok(!($x =~ /.def/), qq ["$x_pretty" =~ /.def/]); - - ok $x =~ /\ndef/, qq ["$x_pretty" =~ /\\ndef/]; - ok(!($x !~ /\ndef/), qq ["$x_pretty" !~ /\\ndef/]); - } - - { - $_ = '123'; - ok /^([0-9][0-9]*)/, qq [\$_ = '$_'; /^([0-9][0-9]*)/]; - } - - { - $_ = 'aaabbbccc'; - ok /(a*b*)(c*)/ && $1 eq 'aaabbb' && $2 eq 'ccc', - qq [\$_ = '$_'; /(a*b*)(c*)/]; - ok /(a+b+c+)/ && $1 eq 'aaabbbccc', qq [\$_ = '$_'; /(a+b+c+)/]; - unlike($_, qr/a+b?c+/, qq [\$_ = '$_'; /a+b?c+/]); - - $_ = 'aaabccc'; - ok /a+b?c+/, qq [\$_ = '$_'; /a+b?c+/]; - ok /a*b?c*/, qq [\$_ = '$_'; /a*b?c*/]; - - $_ = 'aaaccc'; - ok /a*b?c*/, qq [\$_ = '$_'; /a*b?c*/]; - unlike($_, qr/a*b+c*/, qq [\$_ = '$_'; /a*b+c*/]); - - $_ = 'abcdef'; - ok /bcd|xyz/, qq [\$_ = '$_'; /bcd|xyz/]; - ok /xyz|bcd/, qq [\$_ = '$_'; /xyz|bcd/]; - ok m|bc/*d|, qq [\$_ = '$_'; m|bc/*d|]; - ok /^$_$/, qq [\$_ = '$_'; /^\$_\$/]; - } - - { - # used to be a test for $* - ok "ab\ncd\n" =~ /^cd/m, q ["ab\ncd\n" =~ /^cd/m]; - } - - { - our %XXX = map {($_ => $_)} 123, 234, 345; - - our @XXX = ('ok 1','not ok 1', 'ok 2','not ok 2','not ok 3'); - while ($_ = shift(@XXX)) { - my $e = index ($_, 'not') >= 0 ? '' : 1; - my $r = m?(.*)?; - is($r, $e, "?(.*)?"); - /not/ && reset; - # TODO perlcc #274 issue (2nd reset) - if (/not ok 2/) { - if ($^O eq 'VMS') { - $_ = shift(@XXX); - } - else { - reset 'X'; - } - } - } - - SKIP: { - if ($^O eq 'VMS') { - skip "Reset 'X'", 1; - } - ok !keys %XXX, "%XXX is empty"; - } - - } - - { - my $message = "Test empty pattern"; - my $xyz = 'xyz'; - my $cde = 'cde'; - - $cde =~ /[^ab]*/; - $xyz =~ //; - is($&, $xyz, $message); - - my $foo = '[^ab]*'; - $cde =~ /$foo/; - $xyz =~ //; - is($&, $xyz, $message); - - $cde =~ /$foo/; - my $null; - no warnings 'uninitialized'; - $xyz =~ /$null/; - is($&, $xyz, $message); - - $null = ""; - $xyz =~ /$null/; - is($&, $xyz, $message); - } - - { - my $message = q !Check $`, $&, $'!; - $_ = 'abcdefghi'; - /def/; # optimized up to cmd - is("$`:$&:$'", 'abc:def:ghi', $message); - - no warnings 'void'; - /cde/ + 0; # optimized only to spat - is("$`:$&:$'", 'ab:cde:fghi', $message); - - /[d][e][f]/; # not optimized - is("$`:$&:$'", 'abc:def:ghi', $message); - } - - { - $_ = 'now is the {time for all} good men to come to.'; - / {([^}]*)}/; - is($1, 'time for all', "Match braces"); - } - - { - my $message = "{N,M} quantifier"; - $_ = 'xxx {3,4} yyy zzz'; - ok(/( {3,4})/, $message); - is($1, ' ', $message); - unlike($_, qr/( {4,})/, $message); - ok(/( {2,3}.)/, $message); - is($1, ' y', $message); - ok(/(y{2,3}.)/, $message); - is($1, 'yyy ', $message); - unlike($_, qr/x {3,4}/, $message); - unlike($_, qr/^xxx {3,4}/, $message); - } - - { - my $message = "Test /g"; - local $" = ":"; - $_ = "now is the time for all good men to come to."; - my @words = /(\w+)/g; - my $exp = "now:is:the:time:for:all:good:men:to:come:to"; - - is("@words", $exp, $message); - - @words = (); - while (/\w+/g) { - push (@words, $&); - } - is("@words", $exp, $message); - - @words = (); - pos = 0; - while (/to/g) { - push(@words, $&); - } - is("@words", "to:to", $message); - - pos $_ = 0; - @words = /to/g; - is("@words", "to:to", $message); - } - - { - $_ = "abcdefghi"; - - my $pat1 = 'def'; - my $pat2 = '^def'; - my $pat3 = '.def.'; - my $pat4 = 'abc'; - my $pat5 = '^abc'; - my $pat6 = 'abc$'; - my $pat7 = 'ghi'; - my $pat8 = '\w*ghi'; - my $pat9 = 'ghi$'; - - my $t1 = my $t2 = my $t3 = my $t4 = my $t5 = - my $t6 = my $t7 = my $t8 = my $t9 = 0; - - for my $iter (1 .. 5) { - $t1++ if /$pat1/o; - $t2++ if /$pat2/o; - $t3++ if /$pat3/o; - $t4++ if /$pat4/o; - $t5++ if /$pat5/o; - $t6++ if /$pat6/o; - $t7++ if /$pat7/o; - $t8++ if /$pat8/o; - $t9++ if /$pat9/o; - } - my $x = "$t1$t2$t3$t4$t5$t6$t7$t8$t9"; - is($x, '505550555', "Test /o"); - } - - { - my $xyz = 'xyz'; - ok "abc" =~ /^abc$|$xyz/, "| after \$"; - - # perl 4.009 says "unmatched ()" - my $message = '$ inside ()'; - - my $result; - eval '"abc" =~ /a(bc$)|$xyz/; $result = "$&:$1"'; - is($@, "", $message); - is($result, "abc:bc", $message); - } - - { - my $message = "Scalar /g"; - $_ = "abcfooabcbar"; - - ok( /abc/g && $` eq "", $message); - ok( /abc/g && $` eq "abcfoo", $message); - ok(!/abc/g, $message); - - $message = "Scalar /gi"; - pos = 0; - ok( /ABC/gi && $` eq "", $message); - ok( /ABC/gi && $` eq "abcfoo", $message); - ok(!/ABC/gi, $message); - - $message = "Scalar /g"; - pos = 0; - ok( /abc/g && $' eq "fooabcbar", $message); - ok( /abc/g && $' eq "bar", $message); - - $_ .= ''; - my @x = /abc/g; - is(@x, 2, "/g reset after assignment"); - } - - { - my $message = '/g, \G and pos'; - $_ = "abdc"; - pos $_ = 2; - /\Gc/gc; - is(pos $_, 2, $message); - /\Gc/g; - is(pos $_, undef, $message); - } - - { - my $message = '(?{ })'; - our $out = 1; - 'abc' =~ m'a(?{ $out = 2 })b'; - is($out, 2, $message); - - $out = 1; - 'abc' =~ m'a(?{ $out = 3 })c'; - is($out, 1, $message); - } - - { - $_ = 'foobar1 bar2 foobar3 barfoobar5 foobar6'; - my @out = /(? 1, - 'ax13876y25677mcb' => 0, # not b. - 'ax13876y35677nbc' => 0, # Num too big - 'ax13876y25677y21378obc' => 1, - 'ax13876y25677y21378zbc' => 0, # Not followed by [k-o] - 'ax13876y25677y21378y21378kbc' => 1, - 'ax13876y25677y21378y21378kcb' => 0, # Not b. - 'ax13876y25677y21378y21378y21378kbc' => 0, # 5 runs - ); - - for (keys %ans) { - my $message = "20000 nodes, const-len '$_'"; - ok !($ans{$_} xor /a(?=([yx]($long_constant_len)){2,4}[k-o]).*b./o), $message; - - $message = "20000 nodes, var-len '$_'"; - ok !($ans{$_} xor /a(?=([yx]($long_var_len)){2,4}[k-o]).*b./o,), $message; - } - } - - { - my $message = "Complicated backtracking"; - $_ = " a (bla()) and x(y b((l)u((e))) and b(l(e)e)e"; - my $expect = "(bla()) ((l)u((e))) (l(e)e)"; - - use vars '$c'; - sub matchit { - m/ - ( - \( - (?{ $c = 1 }) # Initialize - (?: - (?(?{ $c == 0 }) # PREVIOUS iteration was OK, stop the loop - (?! - ) # Fail: will unwind one iteration back - ) - (?: - [^()]+ # Match a big chunk - (?= - [()] - ) # Do not try to match subchunks - | - \( - (?{ ++$c }) - | - \) - (?{ --$c }) - ) - )+ # This may not match with different subblocks - ) - (?(?{ $c != 0 }) - (?! - ) # Fail - ) # Otherwise the chunk 1 may succeed with $c>0 - /xg; - } - - my @ans = (); - my $res; - push @ans, $res while $res = matchit; - is("@ans", "1 1 1", $message); - - @ans = matchit; - is("@ans", $expect, $message); - - $message = "Recursion with (??{ })"; - our $matched; - $matched = qr/\((?:(?>[^()]+)|(??{$matched}))*\)/; - - @ans = my @ans1 = (); - push (@ans, $res), push (@ans1, $&) while $res = m/$matched/g; - - is("@ans", "1 1 1", $message); - is("@ans1", $expect, $message); - - @ans = m/$matched/g; - is("@ans", $expect, $message); - - } - - { - ok "abc" =~ /^(??{"a"})b/, '"abc" =~ /^(??{"a"})b/'; - } - - { - my @ans = ('a/b' =~ m%(.*/)?(.*)%); # Stack may be bad - is("@ans", 'a/ b', "Stack may be bad"); - } - - { - my $message = "Eval-group not allowed at runtime"; - my $code = '{$blah = 45}'; - our $blah = 12; - eval { /(?$code)/ }; - ok($@ && $@ =~ /not allowed at runtime/ && $blah == 12, $message); - - $blah = 12; - my $res = eval { "xx" =~ /(?$code)/o }; - { - no warnings 'uninitialized'; - chomp $@; my $message = "$message '$@', '$res', '$blah'"; - ok($@ && $@ =~ /not allowed at runtime/ && $blah == 12, $message); - } - - $code = '=xx'; - $blah = 12; - $res = eval { "xx" =~ /(?$code)/o }; - { - no warnings 'uninitialized'; - my $message = "$message '$@', '$res', '$blah'"; - ok(!$@ && $res, $message); - } - - $code = '{$blah = 45}'; - $blah = 12; - SKIP: { - if (is_perlcc_compiled()) { # test if runnning compiled - skip "wontfix issue 328 lexicals miscompiled in re-eval via perlcc"; - } else { - eval "/(?$code)/"; - is($blah, 45, $message); - } - } - $blah = 12; - /(?{$blah = 45})/; - is($blah, 45, $message); - } - - { - my $message = "Pos checks"; - my $x = 'banana'; - $x =~ /.a/g; - is(pos $x, 2, $message); - - $x =~ /.z/gc; - is(pos $x, 2, $message); - - sub f { - my $p = $_[0]; - return $p; - } - - $x =~ /.a/g; - is(f (pos $x), 4, $message); - } - - { - my $message = 'Checking $^R'; - our $x = $^R = 67; - 'foot' =~ /foo(?{$x = 12; 75})[t]/; - is($^R, 75, $message); - - $x = $^R = 67; - 'foot' =~ /foo(?{$x = 12; 75})[xy]/; - ok($^R eq '67' && $x eq '12', $message); - - $x = $^R = 67; - 'foot' =~ /foo(?{ $^R + 12 })((?{ $x = 12; $^R + 17 })[xy])?/; - ok($^R eq '79' && $x eq '12', $message); - } - - { - is(qr/\b\v$/i, '(?^i:\b\v$)', 'qr/\b\v$/i'); - is(qr/\b\v$/s, '(?^s:\b\v$)', 'qr/\b\v$/s'); - is(qr/\b\v$/m, '(?^m:\b\v$)', 'qr/\b\v$/m'); - is(qr/\b\v$/x, '(?^x:\b\v$)', 'qr/\b\v$/x'); - is(qr/\b\v$/xism, '(?^msix:\b\v$)', 'qr/\b\v$/xism'); - is(qr/\b\v$/, '(?^:\b\v$)', 'qr/\b\v$/'); - } - - { # Test that charset modifier work, and are interpolated - is(qr/\b\v$/, '(?^:\b\v$)', 'Verify no locale, no unicode_strings gives default modifier'); - is(qr/(?l:\b\v$)/, '(?^:(?l:\b\v$))', 'Verify infix l modifier compiles'); - is(qr/(?u:\b\v$)/, '(?^:(?u:\b\v$))', 'Verify infix u modifier compiles'); - is(qr/(?l)\b\v$/, '(?^:(?l)\b\v$)', 'Verify (?l) compiles'); - is(qr/(?u)\b\v$/, '(?^:(?u)\b\v$)', 'Verify (?u) compiles'); - - my $dual = qr/\b\v$/; - use locale; - my $locale = qr/\b\v$/; - is($locale, '(?^l:\b\v$)', 'Verify has l modifier when compiled under use locale'); - no locale; - - use feature 'unicode_strings'; - my $unicode = qr/\b\v$/; - is($unicode, '(?^u:\b\v$)', 'Verify has u modifier when compiled under unicode_strings'); - is(qr/abc$dual/, '(?^u:abc(?^:\b\v$))', 'Verify retains d meaning when interpolated under locale'); - is(qr/abc$locale/, '(?^u:abc(?^l:\b\v$))', 'Verify retains l when interpolated under unicode_strings'); - - no feature 'unicode_strings'; - is(qr/abc$locale/, '(?^:abc(?^l:\b\v$))', 'Verify retains l when interpolated outside locale and unicode strings'); - is(qr/def$unicode/, '(?^:def(?^u:\b\v$))', 'Verify retains u when interpolated outside locale and unicode strings'); - - use locale; - is(qr/abc$dual/, '(?^l:abc(?^:\b\v$))', 'Verify retains d meaning when interpolated under locale'); - is(qr/abc$unicode/, '(?^l:abc(?^u:\b\v$))', 'Verify retains u when interpolated under locale'); - } - - { - my $message = "Look around"; - $_ = 'xabcx'; - foreach my $ans ('', 'c') { - ok(/(?<=(?=a)..)((?=c)|.)/g, $message); - is($1, $ans, $message); - } - } - - { - my $message = "Empty clause"; - $_ = 'a'; - foreach my $ans ('', 'a', '') { - ok(/^|a|$/g, $message); - is($&, $ans, $message); - } - } - - { - sub prefixify { - my $message = "Prefixify"; - { - my ($v, $a, $b, $res) = @_; - ok($v =~ s/\Q$a\E/$b/, $message); - is($v, $res, $message); - } - } - - prefixify ('/a/b/lib/arch', "/a/b/lib", 'X/lib', 'X/lib/arch'); - prefixify ('/a/b/man/arch', "/a/b/man", 'X/man', 'X/man/arch'); - } - - { - $_ = 'var="foo"'; - /(\")/; - ok $1 && /$1/, "Capture a quote"; - } - - if (is_perlcc_compiled()) { # test if runnning compiled - SKIP: { - skip "wontfix issue 328 lexicals miscompiled in re-eval via perlcc", 2; - } - } else { - no warnings 'closure'; - my $message = '(?{ $var } refers to package vars'; - package aa; - our $c = 2; - $::c = 3; - '' =~ /(?{ $c = 4 })/; - main::is($c, 4, $message); - main::is($::c, 3, $message); - } - - { - is(eval 'q(a:[b]:) =~ /[x[:foo:]]/', undef); - like ($@, qr/POSIX class \[:[^:]+:\] unknown in regex/, - 'POSIX class [: :] must have valid name'); - - for my $d (qw [= .]) { - is(eval "/[[${d}foo${d}]]/", undef); - like ($@, qr/\QPOSIX syntax [$d $d] is reserved for future extensions/, - "POSIX syntax [[$d $d]] is an error"); - } - } - - { - # test if failure of patterns returns empty list - my $message = "Failed pattern returns empty list"; - $_ = 'aaa'; - @_ = /bbb/; - is("@_", "", $message); - - @_ = /bbb/g; - is("@_", "", $message); - - @_ = /(bbb)/; - is("@_", "", $message); - - @_ = /(bbb)/g; - is("@_", "", $message); - } - - { - my $message = '@- and @+ tests'; - - /a(?=.$)/; - is($#+, 0, $message); - is($#-, 0, $message); - is($+ [0], 2, $message); - is($- [0], 1, $message); - ok(!defined $+ [1] && !defined $- [1] && - !defined $+ [2] && !defined $- [2], $message); - - /a(a)(a)/; - is($#+, 2, $message); - is($#-, 2, $message); - is($+ [0], 3, $message); - is($- [0], 0, $message); - is($+ [1], 2, $message); - is($- [1], 1, $message); - is($+ [2], 3, $message); - is($- [2], 2, $message); - ok(!defined $+ [3] && !defined $- [3] && - !defined $+ [4] && !defined $- [4], $message); - - # Exists has a special check for @-/@+ - bug 45147 - ok(exists $-[0], $message); - ok(exists $+[0], $message); - ok(exists $-[2], $message); - ok(exists $+[2], $message); - ok(!exists $-[3], $message); - ok(!exists $+[3], $message); - ok(exists $-[-1], $message); - ok(exists $+[-1], $message); - ok(exists $-[-3], $message); - ok(exists $+[-3], $message); - ok(!exists $-[-4], $message); - ok(!exists $+[-4], $message); - - /.(a)(b)?(a)/; - is($#+, 3, $message); - is($#-, 3, $message); - is($+ [1], 2, $message); - is($- [1], 1, $message); - is($+ [3], 3, $message); - is($- [3], 2, $message); - ok(!defined $+ [2] && !defined $- [2] && - !defined $+ [4] && !defined $- [4], $message); - - /.(a)/; - is($#+, 1, $message); - is($#-, 1, $message); - is($+ [0], 2, $message); - is($- [0], 0, $message); - is($+ [1], 2, $message); - is($- [1], 1, $message); - ok(!defined $+ [2] && !defined $- [2] && - !defined $+ [3] && !defined $- [3], $message); - - /.(a)(ba*)?/; - is($#+, 2, $message); - is($#-, 1, $message); - } - - foreach ('$+[0] = 13', '$-[0] = 13', '@+ = (7, 6, 5)', '@- = qw (foo bar)') { - is(eval $_, undef); - like($@, qr/^Modification of a read-only value attempted/, - 'Elements of @- and @+ are read-only'); - } - - { - my $message = '\G testing'; - $_ = 'aaa'; - pos = 1; - my @a = /\Ga/g; - is("@a", "a a", $message); - - my $str = 'abcde'; - pos $str = 2; - unlike($str, qr/^\G/, $message); - unlike($str, qr/^.\G/, $message); - like($str, qr/^..\G/, $message); - unlike($str, qr/^...\G/, $message); - ok($str =~ /\G../ && $& eq 'cd', $message); - - local $::TODO = $::running_as_thread; - ok($str =~ /.\G./ && $& eq 'bc', $message); - } - - { - my $message = 'pos inside (?{ })'; - my $str = 'abcde'; - our ($foo, $bar); - like($str, qr/b(?{$foo = $_; $bar = pos})c/, $message); - is($foo, $str, $message); - is($bar, 2, $message); - is(pos $str, undef, $message); - - undef $foo; - undef $bar; - pos $str = undef; - ok($str =~ /b(?{$foo = $_; $bar = pos})c/g, $message); - is($foo, $str, $message); - is($bar, 2, $message); - is(pos $str, 3, $message); - - $_ = $str; - undef $foo; - undef $bar; - like($_, qr/b(?{$foo = $_; $bar = pos})c/, $message); - is($foo, $str, $message); - is($bar, 2, $message); - - undef $foo; - undef $bar; - ok(/b(?{$foo = $_; $bar = pos})c/g, $message); - is($foo, $str, $message); - is($bar, 2, $message); - is(pos, 3, $message); - - undef $foo; - undef $bar; - pos = undef; - 1 while /b(?{$foo = $_; $bar = pos})c/g; - is($foo, $str, $message); - is($bar, 2, $message); - is(pos, undef, $message); - - undef $foo; - undef $bar; - $_ = 'abcde|abcde'; - ok(s/b(?{$foo = $_; $bar = pos})c/x/g, $message); - is($foo, 'abcde|abcde', $message); - is($bar, 8, $message); - is($_, 'axde|axde', $message); - - # List context: - $_ = 'abcde|abcde'; - our @res; - () = /([ace]).(?{push @res, $1,$2})([ce])(?{push @res, $1,$2})/g; - @res = map {defined $_ ? "'$_'" : 'undef'} @res; - is("@res", "'a' undef 'a' 'c' 'e' undef 'a' undef 'a' 'c'", $message); - - @res = (); - () = /([ace]).(?{push @res, $`,$&,$'})([ce])(?{push @res, $`,$&,$'})/g; - @res = map {defined $_ ? "'$_'" : 'undef'} @res; - is("@res", "'' 'ab' 'cde|abcde' " . - "'' 'abc' 'de|abcde' " . - "'abcd' 'e|' 'abcde' " . - "'abcde|' 'ab' 'cde' " . - "'abcde|' 'abc' 'de'", $message); - } - - { - my $message = '\G anchor checks'; - my $foo = 'aabbccddeeffgg'; - pos ($foo) = 1; - { - local $::TODO = $::running_as_thread; - no warnings 'uninitialized'; - ok($foo =~ /.\G(..)/g, $message); - is($1, 'ab', $message); - - pos ($foo) += 1; - ok($foo =~ /.\G(..)/g, $message); - is($1, 'cc', $message); - - pos ($foo) += 1; - ok($foo =~ /.\G(..)/g, $message); - is($1, 'de', $message); - - ok($foo =~ /\Gef/g, $message); - } - - undef pos $foo; - ok($foo =~ /\G(..)/g, $message); - is($1, 'aa', $message); - - ok($foo =~ /\G(..)/g, $message); - is($1, 'bb', $message); - - pos ($foo) = 5; - ok($foo =~ /\G(..)/g, $message); - is($1, 'cd', $message); - } - - { - $_ = '123x123'; - my @res = /(\d*|x)/g; - local $" = '|'; - is("@res", "123||x|123|", "0 match in alternation"); - } - - { - my $message = "Match against temporaries (created via pp_helem())" . - " is safe"; - ok({foo => "bar\n" . $^X} -> {foo} =~ /^(.*)\n/g, $message); - is($1, "bar", $message); - } - - { - my $message = 'package $i inside (?{ }), ' . - 'saved substrings and changing $_'; - our @a = qw [foo bar]; - our @b = (); - s/(\w)(?{push @b, $1})/,$1,/g for @a; - is("@b", "f o o b a r", $message); - is("@a", ",f,,o,,o, ,b,,a,,r,", $message); - - $message = 'lexical $i inside (?{ }), ' . - 'saved substrings and changing $_'; - no warnings 'closure'; - my @c = qw [foo bar]; - my @d = (); - s/(\w)(?{push @d, $1})/,$1,/g for @c; - SKIP: { - if (is_perlcc_compiled()) { # test if runnning compiled - skip "wontfix issue 328 lexicals miscompiled in re-eval via perlcc"; - } else { - is("@d", "f o o b a r", $message); - } - } - is("@c", ",f,,o,,o, ,b,,a,,r,", $message); - } - - { - my $message = 'Brackets'; - our $brackets; - $brackets = qr { - { (?> [^{}]+ | (??{ $brackets }) )* } - }x; - - ok("{{}" =~ $brackets, $message); - is($&, "{}", $message); - ok("something { long { and } hairy" =~ $brackets, $message); - is($&, "{ and }", $message); - ok("something { long { and } hairy" =~ m/((??{ $brackets }))/, $message); - is($&, "{ and }", $message); - } - - { - $_ = "a-a\nxbb"; - pos = 1; - ok(!m/^-.*bb/mg, '$_ = "a-a\nxbb"; m/^-.*bb/mg'); - } - - { - my $message = '\G anchor checks'; - my $text = "aaXbXcc"; - pos ($text) = 0; - ok($text !~ /\GXb*X/g, $message); - } - - { - $_ = "xA\n" x 500; - unlike($_, qr/^\s*A/m, '$_ = "xA\n" x 500; /^\s*A/m"'); - - my $text = "abc dbf"; - my @res = ($text =~ /.*?(b).*?\b/g); - is("@res", "b b", '\b is not special'); - } - - { - my $message = '\S, [\S], \s, [\s]'; - my @a = map chr, 0 .. 255; - my @b = grep m/\S/, @a; - my @c = grep m/[^\s]/, @a; - is("@b", "@c", $message); - - @b = grep /\S/, @a; - @c = grep /[\S]/, @a; - is("@b", "@c", $message); - - @b = grep /\s/, @a; - @c = grep /[^\S]/, @a; - is("@b", "@c", $message); - - @b = grep /\s/, @a; - @c = grep /[\s]/, @a; - is("@b", "@c", $message); - } - { - my $message = '\D, [\D], \d, [\d]'; - my @a = map chr, 0 .. 255; - my @b = grep /\D/, @a; - my @c = grep /[^\d]/, @a; - is("@b", "@c", $message); - - @b = grep /\D/, @a; - @c = grep /[\D]/, @a; - is("@b", "@c", $message); - - @b = grep /\d/, @a; - @c = grep /[^\D]/, @a; - is("@b", "@c", $message); - - @b = grep /\d/, @a; - @c = grep /[\d]/, @a; - is("@b", "@c", $message); - } - { - my $message = '\W, [\W], \w, [\w]'; - my @a = map chr, 0 .. 255; - my @b = grep /\W/, @a; - my @c = grep /[^\w]/, @a; - is("@b", "@c", $message); - - @b = grep /\W/, @a; - @c = grep /[\W]/, @a; - is("@b", "@c", $message); - - @b = grep /\w/, @a; - @c = grep /[^\W]/, @a; - is("@b", "@c", $message); - - @b = grep /\w/, @a; - @c = grep /[\w]/, @a; - is("@b", "@c", $message); - } - - { - # see if backtracking optimization works correctly - my $message = 'Backtrack optimization'; - like("\n\n", qr/\n $ \n/x, $message); - like("\n\n", qr/\n* $ \n/x, $message); - like("\n\n", qr/\n+ $ \n/x, $message); - like("\n\n", qr/\n? $ \n/x, $message); - like("\n\n", qr/\n*? $ \n/x, $message); - like("\n\n", qr/\n+? $ \n/x, $message); - like("\n\n", qr/\n?? $ \n/x, $message); - unlike("\n\n", qr/\n*+ $ \n/x, $message); - unlike("\n\n", qr/\n++ $ \n/x, $message); - like("\n\n", qr/\n?+ $ \n/x, $message); - } - - { - package S; - use overload '""' => sub {'Object S'}; - sub new {bless []} - - my $message = "Ref stringification"; - ::ok(do { \my $v} =~ /^SCALAR/, "Scalar ref stringification") or diag($message); - ::ok(do {\\my $v} =~ /^REF/, "Ref ref stringification") or diag($message); - ::ok([] =~ /^ARRAY/, "Array ref stringification") or diag($message); - ::ok({} =~ /^HASH/, "Hash ref stringification") or diag($message); - ::ok('S' -> new =~ /^Object S/, "Object stringification") or diag($message); - } - - { - my $message = "Test result of match used as match"; - ok('a1b' =~ ('xyz' =~ /y/), $message); - is($`, 'a', $message); - ok('a1b' =~ ('xyz' =~ /t/), $message); - is($`, 'a', $message); - } - - { - my $message = '"1" is not \s'; - warning_is(sub {unlike("1\n" x 102, qr/^\s*\n/m, $message)}, - undef, "$message (did not warn)"); - } - - { - my $message = '\s, [[:space:]] and [[:blank:]]'; - my %space = (spc => " ", - tab => "\t", - cr => "\r", - lf => "\n", - ff => "\f", - # There's no \v but the vertical tabulator seems miraculously - # be 11 both in ASCII and EBCDIC. - vt => chr(11), - false => "space"); - - my @space0 = sort grep {$space {$_} =~ /\s/ } keys %space; - my @space1 = sort grep {$space {$_} =~ /[[:space:]]/} keys %space; - my @space2 = sort grep {$space {$_} =~ /[[:blank:]]/} keys %space; - - is("@space0", "cr ff lf spc tab", $message); - is("@space1", "cr ff lf spc tab vt", $message); - is("@space2", "spc tab", $message); - } - - { - my $n= 50; - # this must be a high number and go from 0 to N, as the bug we are looking for doesn't - # seem to be predictable. Slight changes to the test make it fail earlier or later. - foreach my $i (0 .. $n) - { - my $str= "\n" x $i; - ok $str=~/.*\z/, "implicit MBOL check string disable does not break things length=$i"; - } - } - { - # we are actually testing that we dont die when executing these patterns - use utf8; - my $e = "Böck"; - ok(utf8::is_utf8($e),"got a unicode string - rt75680"); - - ok($e !~ m/.*?[x]$/, "unicode string against /.*?[x]\$/ - rt75680"); - ok($e !~ m/.*?\p{Space}$/i, "unicode string against /.*?\\p{space}\$/i - rt75680"); - ok($e !~ m/.*?[xyz]$/, "unicode string against /.*?[xyz]\$/ - rt75680"); - ok($e !~ m/(.*?)[,\p{isSpace}]+((?:\p{isAlpha}[\p{isSpace}\.]{1,2})+)\p{isSpace}*$/, "unicode string against big pattern - rt75680"); - } - { - # we are actually testing that we dont die when executing these patterns - my $e = "B\x{f6}ck"; - ok(!utf8::is_utf8($e), "got a latin string - rt75680"); - - ok($e !~ m/.*?[x]$/, "latin string against /.*?[x]\$/ - rt75680"); - ok($e !~ m/.*?\p{Space}$/i, "latin string against /.*?\\p{space}\$/i - rt75680"); - ok($e !~ m/.*?[xyz]$/,"latin string against /.*?[xyz]\$/ - rt75680"); - ok($e !~ m/(.*?)[,\p{isSpace}]+((?:\p{isAlpha}[\p{isSpace}\.]{1,2})+)\p{isSpace}*$/,"latin string against big pattern - rt75680"); - } - - { - # - # Tests for bug 77414. - # - - my $message = '\p property after empty * match'; - { - like("1", qr/\s*\pN/, $message); - like("-", qr/\s*\p{Dash}/, $message); - like(" ", qr/\w*\p{Blank}/, $message); - } - - like("1", qr/\s*\pN+/, $message); - like("-", qr/\s*\p{Dash}{1}/, $message); - like(" ", qr/\w*\p{Blank}{1,4}/, $message); - - } - - SKIP: { # Some constructs with Latin1 characters cause a utf8 string not - # to match itself in non-utf8 - if ($::IS_EBCDIC) { - skip "Needs to be customized to run on EBCDIC", 6; - } - my $c = "\xc0"; - my $pattern = my $utf8_pattern = qr/((\xc0)+,?)/; - utf8::upgrade($utf8_pattern); - ok $c =~ $pattern, "\\xc0 =~ $pattern; Neither pattern nor target utf8"; - ok $c =~ /$pattern/i, "\\xc0 =~ /$pattern/i; Neither pattern nor target utf8"; - ok $c =~ $utf8_pattern, "\\xc0 =~ $pattern; pattern utf8, target not"; - ok $c =~ /$utf8_pattern/i, "\\xc0 =~ /$pattern/i; pattern utf8, target not"; - utf8::upgrade($c); - ok $c =~ $pattern, "\\xc0 =~ $pattern; target utf8, pattern not"; - ok $c =~ /$pattern/i, "\\xc0 =~ /$pattern/i; target utf8, pattern not"; - ok $c =~ $utf8_pattern, "\\xc0 =~ $pattern; Both target and pattern utf8"; - ok $c =~ /$utf8_pattern/i, "\\xc0 =~ /$pattern/i; Both target and pattern utf8"; - } - - SKIP: { # Make sure can override the formatting - if ($::IS_EBCDIC) { - skip "Needs to be customized to run on EBCDIC", 2; - } - use feature 'unicode_strings'; - ok "\xc0" =~ /\w/, 'Under unicode_strings: "\xc0" =~ /\w/'; - ok "\xc0" !~ /(?d:\w)/, 'Under unicode_strings: "\xc0" !~ /(?d:\w)/'; - } - - { - # Test that a regex followed by an operator and/or a statement modifier work - # These tests use string-eval so that it reports a clean error when it fails - # (without the string eval the test script might be unparseable) - - # Note: these test check the behaviour that currently is valid syntax - # If a new regex modifier is added and a test fails then there is a backwards-compatibility issue - # Note-2: a new deprecate warning was added for this with commit e6897b1a5db0410e387ccbf677e89fc4a1d8c97a - # which indicate that this syntax will be removed in 5.16. - # When this happens the tests can be removed - - foreach (['my $r = "a" =~ m/a/lt 2', 'm', 'lt'], - ['my $r = "a" =~ m/a/le 1', 'm', 'le'], - ['my $r = "a" =~ m/a/eq 1', 'm', 'eq'], - ['my $r = "a" =~ m/a/ne 0', 'm', 'ne'], - ['my $r = "a" =~ m/a/and 1', 'm', 'and'], - ['my $r = "a" =~ m/a/unless 0', 'm', 'unless'], - ['my $c = 1; my $r; $r = "a" =~ m/a/while $c--', 'm', 'while'], - ['my $c = 0; my $r; $r = "a" =~ m/a/until $c++', 'm', 'until'], - ['my $r; $r = "a" =~ m/a/for 1', 'm', 'for'], - ['my $r; $r = "a" =~ m/a/foreach 1', 'm', 'foreach'], - - ['my $t = "a"; my $r = $t =~ s/a//lt 2', 's', 'lt'], - ['my $t = "a"; my $r = $t =~ s/a//le 1', 's', 'le'], - ['my $t = "a"; my $r = $t =~ s/a//ne 0', 's', 'ne'], - ['my $t = "a"; my $r = $t =~ s/a//and 1', 's', 'and'], - ['my $t = "a"; my $r = $t =~ s/a//unless 0', 's', 'unless'], - - ['my $c = 1; my $r; my $t = "a"; $r = $t =~ s/a//while $c--', 's', 'while'], - ['my $c = 0; my $r; my $t = "a"; $r = $t =~ s/a//until $c++', 's', 'until'], - ['my $r; my $t = "a"; $r = $t =~ s/a//for 1', 's', 'for'], - ['my $r; my $t = "a"; $r = $t =~ s/a//for 1', 's', 'foreach'], - ) { - my $message = sprintf 'regex (%s) followed by $_->[2]', - $_->[1] eq 'm' ? 'm//' : 's///'; - my $code = "$_->[0]; 'eval_ok ' . \$r"; - my $result = do { - no warnings 'syntax'; - eval $code; - }; - is($@, '', $message); - is($result, 'eval_ok 1', $message); - } - } - - { - my $str= "\x{100}"; - chop $str; - my $qr= qr/$str/; - is("$qr", "(?^:)", "Empty pattern qr// stringifies to (?^:) with unicode flag enabled - Bug #80212"); - $str= ""; - $qr= qr/$str/; - is("$qr", "(?^:)", "Empty pattern qr// stringifies to (?^:) with unicode flag disabled - Bug #80212"); - - } - - { - local $::TODO = "[perl #38133]"; - - "A" =~ /(((?:A))?)+/; - my $first = $2; - - "A" =~ /(((A))?)+/; - my $second = $2; - - is($first, $second); - } - - { - # RT #3516: \G in a m//g expression causes problems - my $count = 0; - while ("abc" =~ m/(\G[ac])?/g) { - last if $count++ > 10; - } - ok($count < 10, 'RT #3516 A'); - - $count = 0; - while ("abc" =~ m/(\G|.)[ac]/g) { - last if $count++ > 10; - } - ok($count < 10, 'RT #3516 B'); - - $count = 0; - while ("abc" =~ m/(\G?[ac])?/g) { - last if $count++ > 10; - } - ok($count < 10, 'RT #3516 C'); - } - { - # RT #84294: Is this a bug in the simple Perl regex? - # : Nested buffers and (?{...}) dont play nicely on partial matches - our @got= (); - ok("ab" =~ /((\w+)(?{ push @got, $2 })){2}/,"RT #84294: Pattern should match"); - my $want= "'ab', 'a', 'b'"; - my $got= join(", ", map { defined($_) ? "'$_'" : "undef" } @got); - is($got,$want,'RT #84294: check that "ab" =~ /((\w+)(?{ push @got, $2 })){2}/ leaves @got in the correct state'); - } - - - { # [perl #101710] - my $pat = "b"; - utf8::upgrade($pat); - like("\xffb", qr/$pat/i, "/i: utf8 pattern, non-utf8 string, latin1-char preceding matching char in string"); - } - -} # End of sub run_tests - -1; diff --git a/t/CORE/re/pat_advanced.t b/t/CORE/re/pat_advanced.t deleted file mode 100644 index aa5587b37..000000000 --- a/t/CORE/re/pat_advanced.t +++ /dev/null @@ -1,2127 +0,0 @@ -#!./perl -# -# This is a home for regular expression tests that don't fit into -# the format supported by re/regexp.t. If you want to add a test -# that does fit that format, add it to re/re_tests, not here. - -use strict; -use warnings; -use 5.010; - - -sub run_tests; - -$| = 1; - - -BEGIN { - require q(t/CORE/test.pl); -} - -run_tests() unless caller; - -# -# Tests start here. -# -sub run_tests { - - { - my $message = '\C matches octet'; - $_ = "a\x{100}b"; - ok(/(.)(\C)(\C)(.)/, $message); - is($1, "a", $message); - if ($::IS_ASCII) { # ASCII (or equivalent), should be UTF-8 - is($2, "\xC4", $message); - is($3, "\x80", $message); - } - elsif ($::IS_EBCDIC) { # EBCDIC (or equivalent), should be UTF-EBCDIC - is($2, "\x8C", $message); - is($3, "\x41", $message); - } - else { - SKIP: { - ok 0, "Unexpected platform", "ord ('A') =" . ord 'A'; - skip "Unexpected platform"; - } - } - is($4, "b", $message); - } - - { - my $message = '\C matches octet'; - $_ = "\x{100}"; - ok(/(\C)/g, $message); - if ($::IS_ASCII) { - is($1, "\xC4", $message); - } - elsif ($::IS_EBCDIC) { - is($1, "\x8C", $message); - } - else { - ok 0, "Unexpected platform", "ord ('A') = " . ord 'A'; - } - ok(/(\C)/g, $message); - if ($::IS_ASCII) { - is($1, "\x80", $message); - } - elsif ($::IS_EBCDIC) { - is($1, "\x41", $message); - } - else { - ok 0, "Unexpected platform", "ord ('A') = " . ord 'A'; - } - } - - { - # Japhy -- added 03/03/2001 - () = (my $str = "abc") =~ /(...)/; - $str = "def"; - is($1, "abc", 'Changing subject does not modify $1'); - } - - SKIP: - { - # The trick is that in EBCDIC the explicit numeric range should - # match (as also in non-EBCDIC) but the explicit alphabetic range - # should not match. - ok "\x8e" =~ /[\x89-\x91]/, '"\x8e" =~ /[\x89-\x91]/'; - ok "\xce" =~ /[\xc9-\xd1]/, '"\xce" =~ /[\xc9-\xd1]/'; - - skip "Not an EBCDIC platform", 2 unless ord ('i') == 0x89 && - ord ('J') == 0xd1; - - # In most places these tests would succeed since \x8e does not - # in most character sets match 'i' or 'j' nor would \xce match - # 'I' or 'J', but strictly speaking these tests are here for - # the good of EBCDIC, so let's test these only there. - unlike("\x8e", qr/[i-j]/, '"\x8e" !~ /[i-j]/'); - unlike("\xce", qr/[I-J]/, '"\xce" !~ /[I-J]/'); - } - - { - ok "\x{ab}" =~ /\x{ab}/, '"\x{ab}" =~ /\x{ab}/ '; - ok "\x{abcd}" =~ /\x{abcd}/, '"\x{abcd}" =~ /\x{abcd}/'; - } - - { - my $message = 'bug id 20001008.001'; - - my @x = ("stra\337e 138", "stra\337e 138"); - for (@x) { - ok(s/(\d+)\s*([\w\-]+)/$1 . uc $2/e, $message); - ok(my ($latin) = /^(.+)(?:\s+\d)/, $message); - is($latin, "stra\337e", $message); - ok($latin =~ s/stra\337e/straße/, $message); - # - # Previous code follows, but outcommented - there were no tests. - # - # $latin =~ s/stra\337e/straße/; # \303\237 after the 2nd a - # use utf8; # needed for the raw UTF-8 - # $latin =~ s!(s)tr(?:aß|s+e)!$1tr.!; # \303\237 after the a - } - } - - { - my $message = 'Test \x escapes'; - ok("ba\xd4c" =~ /([a\xd4]+)/ && $1 eq "a\xd4", $message); - ok("ba\xd4c" =~ /([a\xd4]+)/ && $1 eq "a\x{d4}", $message); - ok("ba\x{d4}c" =~ /([a\xd4]+)/ && $1 eq "a\x{d4}", $message); - ok("ba\x{d4}c" =~ /([a\xd4]+)/ && $1 eq "a\xd4", $message); - ok("ba\xd4c" =~ /([a\x{d4}]+)/ && $1 eq "a\xd4", $message); - ok("ba\xd4c" =~ /([a\x{d4}]+)/ && $1 eq "a\x{d4}", $message); - ok("ba\x{d4}c" =~ /([a\x{d4}]+)/ && $1 eq "a\x{d4}", $message); - ok("ba\x{d4}c" =~ /([a\x{d4}]+)/ && $1 eq "a\xd4", $message); - } - - { - my $message = 'Match code points > 255'; - $_ = "abc\x{100}\x{200}\x{300}\x{380}\x{400}defg"; - ok(/(.\x{300})./, $message); - ok($` eq "abc\x{100}" && length ($`) == 4, $message); - ok($& eq "\x{200}\x{300}\x{380}" && length ($&) == 3, $message); - ok($' eq "\x{400}defg" && length ($') == 5, $message); - ok($1 eq "\x{200}\x{300}" && length ($1) == 2, $message); - } - - { - my $x = "\x{10FFFD}"; - $x =~ s/(.)/$1/g; - ok ord($x) == 0x10FFFD && length($x) == 1, "From Robin Houston"; - } - - { - my %d = ( - "7f" => [0, 0, 0], - "80" => [1, 1, 0], - "ff" => [1, 1, 0], - "100" => [0, 1, 1], - ); - - while (my ($code, $match) = each %d) { - my $message = "Properties of \\x$code"; - my $char = eval qq ["\\x{$code}"]; - - is(0 + ($char =~ /[\x80-\xff]/), $$match[0], $message); - is(0 + ($char =~ /[\x80-\x{100}]/), $$match[1], $message); - is(0 + ($char =~ /[\x{100}]/), $$match[2], $message); - } - } - - { - # From Japhy - foreach (qw(c g o)) { - warning_like(sub {'' =~ "(?$_)"}, qr/^Useless \(\?$_\)/); - warning_like(sub {'' =~ "(?-$_)"}, qr/^Useless \(\?-$_\)/); - } - - # Now test multi-error regexes - foreach (['(?g-o)', qr/^Useless \(\?g\)/, qr/^Useless \(\?-o\)/], - ['(?g-c)', qr/^Useless \(\?g\)/, qr/^Useless \(\?-c\)/], - # (?c) means (?g) error won't be thrown - ['(?o-cg)', qr/^Useless \(\?o\)/, qr/^Useless \(\?-c\)/], - ['(?ogc)', qr/^Useless \(\?o\)/, qr/^Useless \(\?g\)/, - qr/^Useless \(\?c\)/], - ) { - my ($re, @warnings) = @$_; - warnings_like(sub {eval "qr/$re/"}, \@warnings, "qr/$re/ warns"); - } - } - - { - my $message = "/x tests"; - $_ = "foo"; - foreach my $pat (<<" --", <<" --") { - /f - o\r - o - \$ - /x - -- - /f - o - o - \$\r - /x - -- - is(eval $pat, 1, $message); - is($@, '', $message); - } - } - - { - my $message = "/o feature"; - sub test_o {$_ [0] =~ /$_[1]/o; return $1} - is(test_o ('abc', '(.)..'), 'a', $message); - is(test_o ('abc', '..(.)'), 'a', $message); - } - - { - # Test basic $^N usage outside of a regex - my $message = '$^N usage outside of a regex'; - my $x = "abcdef"; - ok(($x =~ /cde/ and !defined $^N), $message); - ok(($x =~ /(cde)/ and $^N eq "cde"), $message); - ok(($x =~ /(c)(d)(e)/ and $^N eq "e"), $message); - ok(($x =~ /(c(d)e)/ and $^N eq "cde"), $message); - ok(($x =~ /(foo)|(c(d)e)/ and $^N eq "cde"), $message); - ok(($x =~ /(c(d)e)|(foo)/ and $^N eq "cde"), $message); - ok(($x =~ /(c(d)e)|(abc)/ and $^N eq "abc"), $message); - ok(($x =~ /(c(d)e)|(abc)x/ and $^N eq "cde"), $message); - ok(($x =~ /(c(d)e)(abc)?/ and $^N eq "cde"), $message); - ok(($x =~ /(?:c(d)e)/ and $^N eq "d"), $message); - ok(($x =~ /(?:c(d)e)(?:f)/ and $^N eq "d"), $message); - ok(($x =~ /(?:([abc])|([def]))*/ and $^N eq "f"), $message); - ok(($x =~ /(?:([ace])|([bdf]))*/ and $^N eq "f"), $message); - ok(($x =~ /(([ace])|([bd]))*/ and $^N eq "e"), $message); - {ok(($x =~ /(([ace])|([bdf]))*/ and $^N eq "f"), $message);} - ## Test to see if $^N is automatically localized -- it should now - ## have the value set in the previous test. - is($^N, "e", '$^N is automatically localized'); - - # Now test inside (?{ ... }) - $message = '$^N usage inside (?{ ... })'; - our ($y, $z); - ok(($x =~ /a([abc])(?{$y=$^N})c/ and $y eq "b"), $message); - ok(($x =~ /a([abc]+)(?{$y=$^N})d/ and $y eq "bc"), $message); - ok(($x =~ /a([abcdefg]+)(?{$y=$^N})d/ and $y eq "bc"), $message); - ok(($x =~ /(a([abcdefg]+)(?{$y=$^N})d)(?{$z=$^N})e/ and $y eq "bc" - and $z eq "abcd"), $message); - ok(($x =~ /(a([abcdefg]+)(?{$y=$^N})de)(?{$z=$^N})/ and $y eq "bc" - and $z eq "abcde"), $message); - - } - - SKIP: - { - ## Should probably put in tests for all the POSIX stuff, - ## but not sure how to guarantee a specific locale...... - - skip "Not an ASCII platform", 2 unless $::IS_ASCII; - my $message = 'Test [[:cntrl:]]'; - my $AllBytes = join "" => map {chr} 0 .. 255; - (my $x = $AllBytes) =~ s/[[:cntrl:]]//g; - is($x, join("", map {chr} 0x20 .. 0x7E, 0x80 .. 0xFF), $message); - - ($x = $AllBytes) =~ s/[^[:cntrl:]]//g; - is($x, (join "", map {chr} 0x00 .. 0x1F, 0x7F), $message); - } - - { - # With /s modifier UTF8 chars were interpreted as bytes - my $message = "UTF-8 chars aren't bytes"; - my $a = "Hello \x{263A} World"; - my @a = ($a =~ /./gs); - is($#a, 12, $message); - } - - { - my $message = '. matches \n with /s'; - my $str1 = "foo\nbar"; - my $str2 = "foo\n\x{100}bar"; - my ($a, $b) = map {chr} $::IS_ASCII ? (0xc4, 0x80) : (0x8c, 0x41); - my @a; - @a = $str1 =~ /./g; is(@a, 6, $message); is("@a", "f o o b a r", $message); - @a = $str1 =~ /./gs; is(@a, 7, $message); is("@a", "f o o \n b a r", $message); - @a = $str1 =~ /\C/g; is(@a, 7, $message); is("@a", "f o o \n b a r", $message); - @a = $str1 =~ /\C/gs; is(@a, 7, $message); is("@a", "f o o \n b a r", $message); - @a = $str2 =~ /./g; is(@a, 7, $message); is("@a", "f o o \x{100} b a r", $message); - @a = $str2 =~ /./gs; is(@a, 8, $message); is("@a", "f o o \n \x{100} b a r", $message); - @a = $str2 =~ /\C/g; is(@a, 9, $message); is("@a", "f o o \n $a $b b a r", $message); - @a = $str2 =~ /\C/gs; is(@a, 9, $message); is("@a", "f o o \n $a $b b a r", $message); - } - - { - no warnings 'digit'; - # Check that \x## works. 5.6.1 and 5.005_03 fail some of these. - my $x; - $x = "\x4e" . "E"; - ok ($x =~ /^\x4EE$/, "Check only 2 bytes of hex are matched."); - - $x = "\x4e" . "i"; - ok ($x =~ /^\x4Ei$/, "Check that invalid hex digit stops it (2)"); - - $x = "\x4" . "j"; - ok ($x =~ /^\x4j$/, "Check that invalid hex digit stops it (1)"); - - $x = "\x0" . "k"; - ok ($x =~ /^\xk$/, "Check that invalid hex digit stops it (0)"); - - $x = "\x0" . "x"; - ok ($x =~ /^\xx$/, "\\xx isn't to be treated as \\0"); - - $x = "\x0" . "xa"; - ok ($x =~ /^\xxa$/, "\\xxa isn't to be treated as \\xa"); - - $x = "\x9" . "_b"; - ok ($x =~ /^\x9_b$/, "\\x9_b isn't to be treated as \\x9b"); - - # and now again in [] ranges - - $x = "\x4e" . "E"; - ok ($x =~ /^[\x4EE]{2}$/, "Check only 2 bytes of hex are matched."); - - $x = "\x4e" . "i"; - ok ($x =~ /^[\x4Ei]{2}$/, "Check that invalid hex digit stops it (2)"); - - $x = "\x4" . "j"; - ok ($x =~ /^[\x4j]{2}$/, "Check that invalid hex digit stops it (1)"); - - $x = "\x0" . "k"; - ok ($x =~ /^[\xk]{2}$/, "Check that invalid hex digit stops it (0)"); - - $x = "\x0" . "x"; - ok ($x =~ /^[\xx]{2}$/, "\\xx isn't to be treated as \\0"); - - $x = "\x0" . "xa"; - ok ($x =~ /^[\xxa]{3}$/, "\\xxa isn't to be treated as \\xa"); - - $x = "\x9" . "_b"; - ok ($x =~ /^[\x9_b]{3}$/, "\\x9_b isn't to be treated as \\x9b"); - - # Check that \x{##} works. 5.6.1 fails quite a few of these. - - $x = "\x9b"; - ok ($x =~ /^\x{9_b}$/, "\\x{9_b} is to be treated as \\x9b"); - - $x = "\x9b" . "y"; - ok ($x =~ /^\x{9_b}y$/, "\\x{9_b} is to be treated as \\x9b (again)"); - - $x = "\x9b" . "y"; - ok ($x =~ /^\x{9b_}y$/, "\\x{9b_} is to be treated as \\x9b"); - - $x = "\x9b" . "y"; - ok ($x =~ /^\x{9_bq}y$/, "\\x{9_bc} is to be treated as \\x9b"); - - $x = "\x0" . "y"; - ok ($x =~ /^\x{x9b}y$/, "\\x{x9b} is to be treated as \\x0"); - - $x = "\x0" . "y"; - ok ($x =~ /^\x{0x9b}y$/, "\\x{0x9b} is to be treated as \\x0"); - - $x = "\x9b" . "y"; - ok ($x =~ /^\x{09b}y$/, "\\x{09b} is to be treated as \\x9b"); - - $x = "\x9b"; - ok ($x =~ /^[\x{9_b}]$/, "\\x{9_b} is to be treated as \\x9b"); - - $x = "\x9b" . "y"; - ok ($x =~ /^[\x{9_b}y]{2}$/, - "\\x{9_b} is to be treated as \\x9b (again)"); - - $x = "\x9b" . "y"; - ok ($x =~ /^[\x{9b_}y]{2}$/, "\\x{9b_} is to be treated as \\x9b"); - - $x = "\x9b" . "y"; - ok ($x =~ /^[\x{9_bq}y]{2}$/, "\\x{9_bc} is to be treated as \\x9b"); - - $x = "\x0" . "y"; - ok ($x =~ /^[\x{x9b}y]{2}$/, "\\x{x9b} is to be treated as \\x0"); - - $x = "\x0" . "y"; - ok ($x =~ /^[\x{0x9b}y]{2}$/, "\\x{0x9b} is to be treated as \\x0"); - - $x = "\x9b" . "y"; - ok ($x =~ /^[\x{09b}y]{2}$/, "\\x{09b} is to be treated as \\x9b"); - - } - - { - # High bit bug -- japhy - my $x = "ab\200d"; - ok $x =~ /.*?\200/, "High bit fine"; - } - - { - # The basic character classes and Unicode - ok "\x{0100}" =~ /\w/, 'LATIN CAPITAL LETTER A WITH MACRON in /\w/'; - ok "\x{0660}" =~ /\d/, 'ARABIC-INDIC DIGIT ZERO in /\d/'; - ok "\x{1680}" =~ /\s/, 'OGHAM SPACE MARK in /\s/'; - } - - { - my $message = "Folding matches and Unicode"; - like("a\x{100}", qr/A/i, $message); - like("A\x{100}", qr/a/i, $message); - like("a\x{100}", qr/a/i, $message); - like("A\x{100}", qr/A/i, $message); - like("\x{101}a", qr/\x{100}/i, $message); - like("\x{100}a", qr/\x{100}/i, $message); - like("\x{101}a", qr/\x{101}/i, $message); - like("\x{100}a", qr/\x{101}/i, $message); - like("a\x{100}", qr/A\x{100}/i, $message); - like("A\x{100}", qr/a\x{100}/i, $message); - like("a\x{100}", qr/a\x{100}/i, $message); - like("A\x{100}", qr/A\x{100}/i, $message); - like("a\x{100}", qr/[A]/i, $message); - like("A\x{100}", qr/[a]/i, $message); - like("a\x{100}", qr/[a]/i, $message); - like("A\x{100}", qr/[A]/i, $message); - like("\x{101}a", qr/[\x{100}]/i, $message); - like("\x{100}a", qr/[\x{100}]/i, $message); - like("\x{101}a", qr/[\x{101}]/i, $message); - like("\x{100}a", qr/[\x{101}]/i, $message); - } - - { - use charnames ':full'; - my $message = "Folding 'LATIN LETTER A WITH GRAVE'"; - - my $lower = "\N{LATIN SMALL LETTER A WITH GRAVE}"; - my $UPPER = "\N{LATIN CAPITAL LETTER A WITH GRAVE}"; - - like($lower, qr/$UPPER/i, $message); - like($UPPER, qr/$lower/i, $message); - like($lower, qr/[$UPPER]/i, $message); - like($UPPER, qr/[$lower]/i, $message); - - $message = "Folding 'GREEK LETTER ALPHA WITH VRACHY'"; - - $lower = "\N{GREEK CAPITAL LETTER ALPHA WITH VRACHY}"; - $UPPER = "\N{GREEK SMALL LETTER ALPHA WITH VRACHY}"; - - like($lower, qr/$UPPER/i, $message); - like($UPPER, qr/$lower/i, $message); - like($lower, qr/[$UPPER]/i, $message); - like($UPPER, qr/[$lower]/i, $message); - - $message = "Folding 'LATIN LETTER Y WITH DIAERESIS'"; - - $lower = "\N{LATIN SMALL LETTER Y WITH DIAERESIS}"; - $UPPER = "\N{LATIN CAPITAL LETTER Y WITH DIAERESIS}"; - - like($lower, qr/$UPPER/i, $message); - like($UPPER, qr/$lower/i, $message); - like($lower, qr/[$UPPER]/i, $message); - like($UPPER, qr/[$lower]/i, $message); - } - - { - use charnames ':full'; - my $message = "GREEK CAPITAL LETTER SIGMA vs " . - "COMBINING GREEK PERISPOMENI"; - - my $SIGMA = "\N{GREEK CAPITAL LETTER SIGMA}"; - my $char = "\N{COMBINING GREEK PERISPOMENI}"; - - warning_is(sub {unlike("_:$char:_", qr/_:$SIGMA:_/i, $message)}, undef, - 'Did not warn [change a5961de5f4215b5c]'); - } - - { - my $message = '\X'; - use charnames ':full'; - - ok("a!" =~ /^(\X)!/ && $1 eq "a", $message); - ok("\xDF!" =~ /^(\X)!/ && $1 eq "\xDF", $message); - ok("\x{100}!" =~ /^(\X)!/ && $1 eq "\x{100}", $message); - ok("\x{100}\x{300}!" =~ /^(\X)!/ && $1 eq "\x{100}\x{300}", $message); - ok("\N{LATIN CAPITAL LETTER E}!" =~ /^(\X)!/ && - $1 eq "\N{LATIN CAPITAL LETTER E}", $message); - ok("\N{LATIN CAPITAL LETTER E}\N{COMBINING GRAVE ACCENT}!" - =~ /^(\X)!/ && - $1 eq "\N{LATIN CAPITAL LETTER E}\N{COMBINING GRAVE ACCENT}", $message); - - $message = '\C and \X'; - like("!abc!", qr/a\Cc/, $message); - like("!abc!", qr/a\Xc/, $message); - } - - { - my $message = "Final Sigma"; - - my $SIGMA = "\x{03A3}"; # CAPITAL - my $Sigma = "\x{03C2}"; # SMALL FINAL - my $sigma = "\x{03C3}"; # SMALL - - like($SIGMA, qr/$SIGMA/i, $message); - like($SIGMA, qr/$Sigma/i, $message); - like($SIGMA, qr/$sigma/i, $message); - - like($Sigma, qr/$SIGMA/i, $message); - like($Sigma, qr/$Sigma/i, $message); - like($Sigma, qr/$sigma/i, $message); - - like($sigma, qr/$SIGMA/i, $message); - like($sigma, qr/$Sigma/i, $message); - like($sigma, qr/$sigma/i, $message); - - like($SIGMA, qr/[$SIGMA]/i, $message); - like($SIGMA, qr/[$Sigma]/i, $message); - like($SIGMA, qr/[$sigma]/i, $message); - - like($Sigma, qr/[$SIGMA]/i, $message); - like($Sigma, qr/[$Sigma]/i, $message); - like($Sigma, qr/[$sigma]/i, $message); - - like($sigma, qr/[$SIGMA]/i, $message); - like($sigma, qr/[$Sigma]/i, $message); - like($sigma, qr/[$sigma]/i, $message); - - $message = "More final Sigma"; - - my $S3 = "$SIGMA$Sigma$sigma"; - - ok(":$S3:" =~ /:(($SIGMA)+):/i && $1 eq $S3 && $2 eq $sigma, $message); - ok(":$S3:" =~ /:(($Sigma)+):/i && $1 eq $S3 && $2 eq $sigma, $message); - ok(":$S3:" =~ /:(($sigma)+):/i && $1 eq $S3 && $2 eq $sigma, $message); - - ok(":$S3:" =~ /:(([$SIGMA])+):/i && $1 eq $S3 && $2 eq $sigma, $message); - ok(":$S3:" =~ /:(([$Sigma])+):/i && $1 eq $S3 && $2 eq $sigma, $message); - ok(":$S3:" =~ /:(([$sigma])+):/i && $1 eq $S3 && $2 eq $sigma, $message); - } - - { - use charnames ':full'; - my $message = "Parlez-Vous " . - "Fran\N{LATIN SMALL LETTER C WITH CEDILLA}ais?"; - - ok("Fran\N{LATIN SMALL LETTER C}ais" =~ /Fran.ais/ && - $& eq "Francais", $message); - ok("Fran\N{LATIN SMALL LETTER C WITH CEDILLA}ais" =~ /Fran.ais/ && - $& eq "Fran\N{LATIN SMALL LETTER C WITH CEDILLA}ais", $message); - ok("Fran\N{LATIN SMALL LETTER C}ais" =~ /Fran\Cais/ && - $& eq "Francais", $message); - # COMBINING CEDILLA is two bytes when encoded - like("Franc\N{COMBINING CEDILLA}ais", qr/Franc\C\Cais/, $message); - ok("Fran\N{LATIN SMALL LETTER C}ais" =~ /Fran\Xais/ && - $& eq "Francais", $message); - ok("Fran\N{LATIN SMALL LETTER C WITH CEDILLA}ais" =~ /Fran\Xais/ && - $& eq "Fran\N{LATIN SMALL LETTER C WITH CEDILLA}ais", $message); - ok("Franc\N{COMBINING CEDILLA}ais" =~ /Fran\Xais/ && - $& eq "Franc\N{COMBINING CEDILLA}ais", $message); - ok("Fran\N{LATIN SMALL LETTER C WITH CEDILLA}ais" =~ - /Fran\N{LATIN SMALL LETTER C WITH CEDILLA}ais/ && - $& eq "Fran\N{LATIN SMALL LETTER C WITH CEDILLA}ais", $message); - ok("Franc\N{COMBINING CEDILLA}ais" =~ /Franc\N{COMBINING CEDILLA}ais/ && - $& eq "Franc\N{COMBINING CEDILLA}ais", $message); - - my @f = ( - ["Fran\N{LATIN SMALL LETTER C}ais", "Francais"], - ["Fran\N{LATIN SMALL LETTER C WITH CEDILLA}ais", - "Fran\N{LATIN SMALL LETTER C WITH CEDILLA}ais"], - ["Franc\N{COMBINING CEDILLA}ais", "Franc\N{COMBINING CEDILLA}ais"], - ); - foreach my $entry (@f) { - my ($subject, $match) = @$entry; - ok($subject =~ /Fran(?:c\N{COMBINING CEDILLA}?| - \N{LATIN SMALL LETTER C WITH CEDILLA})ais/x && - $& eq $match, $message); - } - } - - { - my $message = "Lingering (and useless) UTF8 flag doesn't mess up /i"; - my $pat = "ABcde"; - my $str = "abcDE\x{100}"; - chop $str; - like($str, qr/$pat/i, $message); - - $pat = "ABcde\x{100}"; - $str = "abcDE"; - chop $pat; - like($str, qr/$pat/i, $message); - - $pat = "ABcde\x{100}"; - $str = "abcDE\x{100}"; - chop $pat; - chop $str; - like($str, qr/$pat/i, $message); - } - - { - use charnames ':full'; - my $message = "LATIN SMALL LETTER SHARP S " . - "(\N{LATIN SMALL LETTER SHARP S})"; - - like("\N{LATIN SMALL LETTER SHARP S}", - qr/\N{LATIN SMALL LETTER SHARP S}/, $message); - like("\N{LATIN SMALL LETTER SHARP S}", - qr/\N{LATIN SMALL LETTER SHARP S}/i, $message); - like("\N{LATIN SMALL LETTER SHARP S}", - qr/[\N{LATIN SMALL LETTER SHARP S}]/, $message); - like("\N{LATIN SMALL LETTER SHARP S}", - qr/[\N{LATIN SMALL LETTER SHARP S}]/i, $message); - - like("ss", qr /\N{LATIN SMALL LETTER SHARP S}/i, $message); - like("SS", qr /\N{LATIN SMALL LETTER SHARP S}/i, $message); - like("ss", qr/[\N{LATIN SMALL LETTER SHARP S}]/i, $message); - like("SS", qr/[\N{LATIN SMALL LETTER SHARP S}]/i, $message); - - like("\N{LATIN SMALL LETTER SHARP S}", qr/ss/i, $message); - like("\N{LATIN SMALL LETTER SHARP S}", qr/SS/i, $message); - - $message = "Unoptimized named sequence in class"; - like("ss", qr/[\N{LATIN SMALL LETTER SHARP S}x]/i, $message); - like("SS", qr/[\N{LATIN SMALL LETTER SHARP S}x]/i, $message); - like("\N{LATIN SMALL LETTER SHARP S}", - qr/[\N{LATIN SMALL LETTER SHARP S}x]/, $message); - like("\N{LATIN SMALL LETTER SHARP S}", - qr/[\N{LATIN SMALL LETTER SHARP S}x]/i, $message); - } - - { - # More whitespace: U+0085, U+2028, U+2029\n"; - - # U+0085, U+00A0 need to be forced to be Unicode, the \x{100} does that. - SKIP: { - skip "EBCDIC platform", 4 if $::IS_EBCDIC; - # Do \x{0015} and \x{0041} match \s in EBCDIC? - ok "<\x{100}\x{0085}>" =~ /<\x{100}\s>/, '\x{0085} in \s'; - ok "<\x{0085}>" =~ /<\v>/, '\x{0085} in \v'; - ok "<\x{100}\x{00A0}>" =~ /<\x{100}\s>/, '\x{00A0} in \s'; - ok "<\x{00A0}>" =~ /<\h>/, '\x{00A0} in \h'; - } - my @h = map {sprintf "%05x" => $_} 0x01680, 0x0180E, 0x02000 .. 0x0200A, - 0x0202F, 0x0205F, 0x03000; - my @v = map {sprintf "%05x" => $_} 0x02028, 0x02029; - - my @H = map {sprintf "%05x" => $_} 0x01361, 0x0200B, 0x02408, 0x02420, - 0x0303F, 0xE0020; - my @V = map {sprintf "%05x" => $_} 0x0008A .. 0x0008D, 0x00348, 0x10100, - 0xE005F, 0xE007C; - - for my $hex (@h) { - my $str = eval qq ["<\\x{$hex}>"]; - ok $str =~ /<\s>/, "\\x{$hex} in \\s"; - ok $str =~ /<\h>/, "\\x{$hex} in \\h"; - ok $str !~ /<\v>/, "\\x{$hex} not in \\v"; - } - - for my $hex (@v) { - my $str = eval qq ["<\\x{$hex}>"]; - ok $str =~ /<\s>/, "\\x{$hex} in \\s"; - ok $str =~ /<\v>/, "\\x{$hex} in \\v"; - ok $str !~ /<\h>/, "\\x{$hex} not in \\h"; - } - - for my $hex (@H) { - my $str = eval qq ["<\\x{$hex}>"]; - ok $str =~ /<\S>/, "\\x{$hex} in \\S"; - ok $str =~ /<\H>/, "\\x{$hex} in \\H"; - } - - for my $hex (@V) { - my $str = eval qq ["<\\x{$hex}>"]; - ok $str =~ /<\S>/, "\\x{$hex} in \\S"; - ok $str =~ /<\V>/, "\\x{$hex} in \\V"; - } - } - - { - # . with /s should work on characters, as opposed to bytes - my $message = ". with /s works on characters, not bytes"; - - my $s = "\x{e4}\x{100}"; - # This is not expected to match: the point is that - # neither should we get "Malformed UTF-8" warnings. - warning_is(sub {$s =~ /\G(.+?)\n/gcs}, undef, - "No 'Malformed UTF-8' warning"); - - my @c; - push @c => $1 while $s =~ /\G(.)/gs; - - local $" = ""; - is("@c", $s, $message); - - # Test only chars < 256 - my $t1 = "Q003\n\n\x{e4}\x{f6}\n\nQ004\n\n\x{e7}"; - my $r1 = ""; - while ($t1 =~ / \G ( .+? ) \n\s+ ( .+? ) ( $ | \n\s+ ) /xgcs) { - $r1 .= $1 . $2; - } - - my $t2 = $t1 . "\x{100}"; # Repeat with a larger char - my $r2 = ""; - while ($t2 =~ / \G ( .+? ) \n\s+ ( .+? ) ( $ | \n\s+ ) /xgcs) { - $r2 .= $1 . $2; - } - $r2 =~ s/\x{100}//; - - is($r1, $r2, $message); - } - - { - my $message = "Unicode lookbehind"; - like("A\x{100}B" , qr/(?<=A.)B/, $message); - like("A\x{200}\x{300}B", qr/(?<=A..)B/, $message); - like("\x{400}AB" , qr/(?<=\x{400}.)B/, $message); - like("\x{500}\x{600}B" , qr/(?<=\x{500}.)B/, $message); - - # Original code also contained: - # ok "\x{500\x{600}}B" =~ /(?<=\x{500}.)B/; - # but that looks like a typo. - } - - { - my $message = 'UTF-8 hash keys and /$/'; - # http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters - # /2002-01/msg01327.html - - my $u = "a\x{100}"; - my $v = substr ($u, 0, 1); - my $w = substr ($u, 1, 1); - my %u = ($u => $u, $v => $v, $w => $w); - for (keys %u) { - my $m1 = /^\w*$/ ? 1 : 0; - my $m2 = $u {$_} =~ /^\w*$/ ? 1 : 0; - is($m1, $m2, $message); - } - } - - { - my $message = "No SEGV in s/// and UTF-8"; - my $s = "s#\x{100}" x 4; - ok($s =~ s/[^\w]/ /g, $message); - if ( 1 or $ENV{PERL_TEST_LEGACY_POSIX_CC} ) { - is($s, "s \x{100}" x 4, $message); - } - else { - is($s, "s " x 4, $message); - } - } - - { - my $message = "UTF-8 bug (maybe already known?)"; - my $u = "foo"; - $u =~ s/./\x{100}/g; - is($u, "\x{100}\x{100}\x{100}", $message); - - $u = "foobar"; - $u =~ s/[ao]/\x{100}/g; - is($u, "f\x{100}\x{100}b\x{100}r", $message); - - $u =~ s/\x{100}/e/g; - is($u, "feeber", $message); - } - - { - my $message = "UTF-8 bug with s///"; - # check utf8/non-utf8 mixtures - # try to force all float/anchored check combinations - - my $c = "\x{100}"; - my $subst; - for my $re ("xx.*$c", "x.*$c$c", "$c.*xx", "$c$c.*x", - "xx.*(?=$c)", "(?=$c).*xx",) { - unlike("xxx", qr/$re/, $message); - ok(+($subst = "xxx") !~ s/$re//, $message); - } - for my $re ("xx.*$c*", "$c*.*xx") { - like("xxx", qr/$re/, $message); - ok(+($subst = "xxx") =~ s/$re//, $message); - is($subst, "", $message); - } - for my $re ("xxy*", "y*xx") { - like("xx$c", qr/$re/, $message); - ok(+($subst = "xx$c") =~ s/$re//, $message); - is($subst, $c, $message); - unlike("xy$c", qr/$re/, $message); - ok(+($subst = "xy$c") !~ s/$re//, $message); - } - for my $re ("xy$c*z", "x$c*yz") { - like("xyz", qr/$re/, $message); - ok(+($subst = "xyz") =~ s/$re//, $message); - is($subst, "", $message); - } - } - - { - my $message = "qr /.../x"; - my $R = qr / A B C # D E/x; - ok("ABCDE" =~ $R && $& eq "ABC", $message); - ok("ABCDE" =~ /$R/ && $& eq "ABC", $message); - ok("ABCDE" =~ m/$R/ && $& eq "ABC", $message); - ok("ABCDE" =~ /($R)/ && $1 eq "ABC", $message); - ok("ABCDE" =~ m/($R)/ && $1 eq "ABC", $message); - } - - { - local $\; - $_ = 'aaaaaaaaaa'; - utf8::upgrade($_); chop $_; $\="\n"; - ok /[^\s]+/, 'm/[^\s]/ utf8'; - ok /[^\d]+/, 'm/[^\d]/ utf8'; - ok +($a = $_, $_ =~ s/[^\s]+/./g), 's/[^\s]/ utf8'; - ok +($a = $_, $a =~ s/[^\d]+/./g), 's/[^\s]/ utf8'; - } - - { - # Subject: Odd regexp behavior - # From: Markus Kuhn - # Date: Wed, 26 Feb 2003 16:53:12 +0000 - # Message-Id: - # To: perl-unicode@perl.org - - my $message = 'Markus Kuhn 2003-02-26'; - - my $x = "\x{2019}\nk"; - ok($x =~ s/(\S)\n(\S)/$1 $2/sg, $message); - is($x, "\x{2019} k", $message); - - $x = "b\nk"; - ok($x =~ s/(\S)\n(\S)/$1 $2/sg, $message); - is($x, "b k", $message); - - like("\x{2019}", qr/\S/, $message); - } - - { - # XXX DAPM 13-Apr-06. Recursive split is still broken. It's only luck it - # hasn't been crashing. Disable this test until it is fixed properly. - # XXX also check what it returns rather than just doing ok(1,...) - # split /(?{ split "" })/, "abc"; - local $::TODO = "Recursive split is still broken"; - ok 0, 'cache_re & "(?{": it dumps core in 5.6.1 & 5.8.0'; - } - - { - ok "\x{100}\n" =~ /\x{100}\n$/, "UTF-8 length cache and fbm_compile"; - } - - { - package Str; - use overload q /""/ => sub {${$_ [0]};}; - sub new {my ($c, $v) = @_; bless \$v, $c;} - - package main; - $_ = Str -> new ("a\x{100}/\x{100}b"); - ok join (":", /\b(.)\x{100}/g) eq "a:/", "re_intuit_start and PL_bostr"; - } - - { - my $re = qq /^([^X]*)X/; - utf8::upgrade ($re); - ok "\x{100}X" =~ /$re/, "S_cl_and ANYOF_UNICODE & ANYOF_INVERTED"; - my $loc_re = qq /(?l:^([^X]*)X)/; - utf8::upgrade ($loc_re); - ok "\x{100}X" =~ /$loc_re/, "locale, S_cl_and ANYOF_UNICODE & ANYOF_INVERTED"; - } - - { - ok "123\x{100}" =~ /^.*1.*23\x{100}$/, - 'UTF-8 + multiple floating substr'; - } - - { - my $message = '<20030808193656.5109.1@llama.ni-s.u-net.com>'; - - # LATIN SMALL/CAPITAL LETTER A WITH MACRON - like(" \x{101}", qr/\x{100}/i, $message); - - # LATIN SMALL/CAPITAL LETTER A WITH RING BELOW - like(" \x{1E01}", qr/\x{1E00}/i, $message); - - # DESERET SMALL/CAPITAL LETTER LONG I - like(" \x{10428}", qr/\x{10400}/i, $message); - - # LATIN SMALL/CAPITAL LETTER A WITH RING BELOW + 'X' - like(" \x{1E01}x", qr/\x{1E00}X/i, $message); - } - - { - for (120 .. 130) { - my $head = 'x' x $_; - my $message = q [Don't misparse \x{...} in regexp ] . - q [near 127 char EXACT limit]; - for my $tail ('\x{0061}', '\x{1234}', '\x61') { - eval qq{like("$head$tail", qr/$head$tail/, \$message)}; - is($@, '', $message); - } - $message = q [Don't misparse \N{...} in regexp ] . - q [near 127 char EXACT limit]; - for my $tail ('\N{SNOWFLAKE}') { - eval qq {use charnames ':full'; - like("$head$tail", qr/$head$tail/, \$message)}; - is($@, '', $message); - } - } - } - - { # TRIE related - our @got = (); - "words" =~ /(word|word|word)(?{push @got, $1})s$/; - is(@got, 1, "TRIE optimisation"); - - @got = (); - "words" =~ /(word|word|word)(?{push @got,$1})s$/i; - is(@got, 1,"TRIEF optimisation"); - - my @nums = map {int rand 1000} 1 .. 100; - my $re = "(" . (join "|", @nums) . ")"; - $re = qr/\b$re\b/; - - foreach (@nums) { - ok $_ =~ /$re/, "Trie nums"; - } - - $_ = join " ", @nums; - @got = (); - push @got, $1 while /$re/g; - - my %count; - $count {$_} ++ for @got; - my $ok = 1; - for (@nums) { - $ok = 0 if --$count {$_} < 0; - } - ok $ok, "Trie min count matches"; - } - - { - # TRIE related - # LATIN SMALL/CAPITAL LETTER A WITH MACRON - ok "foba \x{101}foo" =~ qr/(foo|\x{100}foo|bar)/i && - $1 eq "\x{101}foo", - "TRIEF + LATIN SMALL/CAPITAL LETTER A WITH MACRON"; - - # LATIN SMALL/CAPITAL LETTER A WITH RING BELOW - ok "foba \x{1E01}foo" =~ qr/(foo|\x{1E00}foo|bar)/i && - $1 eq "\x{1E01}foo", - "TRIEF + LATIN SMALL/CAPITAL LETTER A WITH RING BELOW"; - - # DESERET SMALL/CAPITAL LETTER LONG I - ok "foba \x{10428}foo" =~ qr/(foo|\x{10400}foo|bar)/i && - $1 eq "\x{10428}foo", - "TRIEF + DESERET SMALL/CAPITAL LETTER LONG I"; - - # LATIN SMALL/CAPITAL LETTER A WITH RING BELOW + 'X' - ok "foba \x{1E01}xfoo" =~ qr/(foo|\x{1E00}Xfoo|bar)/i && - $1 eq "\x{1E01}xfoo", - "TRIEF + LATIN SMALL/CAPITAL LETTER A WITH RING BELOW + 'X'"; - - use charnames ':full'; - - my $s = "\N{LATIN SMALL LETTER SHARP S}"; - ok "foba ba$s" =~ qr/(foo|Ba$s|bar)/i && $1 eq "ba$s", - "TRIEF + LATIN SMALL LETTER SHARP S =~ ss"; - ok "foba ba$s" =~ qr/(Ba$s|foo|bar)/i && $1 eq "ba$s", - "TRIEF + LATIN SMALL LETTER SHARP S =~ ss"; - ok "foba ba$s" =~ qr/(foo|bar|Ba$s)/i && $1 eq "ba$s", - "TRIEF + LATIN SMALL LETTER SHARP S =~ ss"; - - ok "foba ba$s" =~ qr/(foo|Bass|bar)/i && $1 eq "ba$s", - "TRIEF + LATIN SMALL LETTER SHARP S =~ ss"; - - ok "foba ba$s" =~ qr/(foo|BaSS|bar)/i && $1 eq "ba$s", - "TRIEF + LATIN SMALL LETTER SHARP S =~ SS"; - - ok "foba ba${s}pxySS$s$s" =~ qr/(b(?:a${s}t|a${s}f|a${s}p)[xy]+$s*)/i - && $1 eq "ba${s}pxySS$s$s", - "COMMON PREFIX TRIEF + LATIN SMALL LETTER SHARP S"; - } - - { - BEGIN { - unshift @INC, 't/CORE/'; - } - use Cname; - - ok 'fooB' =~ /\N{foo}[\N{B}\N{b}]/, "Passthrough charname"; - # - # Why doesn't must_warn work here? - # - my $w; - local $SIG {__WARN__} = sub {$w .= "@_"}; - eval 'q(xxWxx) =~ /[\N{WARN}]/'; - ok $w && $w =~ /Using just the first character returned by \\N{} in character class/, - "single character in [\\N{}] warning"; - - undef $w; - eval q [ok "\0" !~ /[\N{EMPTY-STR}XY]/, - "Zerolength charname in charclass doesn't match \\\\0"]; - ok $w && $w =~ /Ignoring zero length/, - 'Ignoring zero length \N{} in character class warning'; - - ok 'AB' =~ /(\N{EVIL})/ && $1 eq 'A', 'Charname caching $1'; - ok 'ABC' =~ /(\N{EVIL})/, 'Charname caching $1'; - ok 'xy' =~ /x\N{EMPTY-STR}y/, - 'Empty string charname produces NOTHING node'; - ok '' =~ /\N{EMPTY-STR}/, - 'Empty string charname produces NOTHING node'; - ok "\N{LONG-STR}" =~ /^\N{LONG-STR}$/, 'Verify that long string works'; - ok "\N{LONG-STR}" =~ /^\N{LONG-STR}$/i, 'Verify under folding that long string works'; - - # If remove the limitation in regcomp code these should work - # differently - undef $w; - eval q [ok "\N{TOO-LONG-STR}" =~ /^\N{TOO-LONG-STR}$/, 'Verify that what once was too long a string works']; - eval 'q(syntax error) =~ /\N{MALFORMED}/'; - ok $@ && $@ =~ /Malformed/, 'Verify that malformed utf8 gives an error'; - undef $w; - eval 'q() =~ /\N{4F}/'; - ok $w && $w =~ /Deprecated/, 'Verify that leading digit in name gives warning'; - undef $w; - eval 'q() =~ /\N{COM,MA}/'; - ok $w && $w =~ /Deprecated/, 'Verify that comma in name gives warning'; - undef $w; - my $name = "A\x{D7}O"; - eval "q(W) =~ /\\N{$name}/"; - ok $w && $w =~ /Deprecated/, 'Verify that latin1 symbol in name gives warning'; - undef $w; - $name = "A\x{D1}O"; - eval "q(W) =~ /\\N{$name}/"; - ok ! $w, 'Verify that latin1 letter in name doesnt give warning'; - - } - - { - use charnames ':full'; - - ok 'aabc' !~ /a\N{PLUS SIGN}b/, '/a\N{PLUS SIGN}b/ against aabc'; - ok 'a+bc' =~ /a\N{PLUS SIGN}b/, '/a\N{PLUS SIGN}b/ against a+bc'; - - ok ' A B' =~ /\N{SPACE}\N{U+0041}\N{SPACE}\N{U+0042}/, - 'Intermixed named and unicode escapes'; - ok "\N{SPACE}\N{U+0041}\N{SPACE}\N{U+0042}" =~ - /\N{SPACE}\N{U+0041}\N{SPACE}\N{U+0042}/, - 'Intermixed named and unicode escapes'; - ok "\N{SPACE}\N{U+0041}\N{SPACE}\N{U+0042}" =~ - /[\N{SPACE}\N{U+0041}][\N{SPACE}\N{U+0042}]/, - 'Intermixed named and unicode escapes'; - ok "\0" =~ /^\N{NULL}$/, 'Verify that \N{NULL} works; is not confused with an error'; - } - - { - our $brackets; - $brackets = qr{ - { (?> [^{}]+ | (??{ $brackets }) )* } - }x; - - ok "{b{c}d" !~ m/^((??{ $brackets }))/, "Bracket mismatch"; - - SKIP: { - our @stack = (); - my @expect = qw( - stuff1 - stuff2 - and - right - - <> - <<>> - <and><<<>>> - ); - - local $_ = '<<and><<<>>>>'; - ok /^(<((?:(?>[^<>]+)|(?1))*)>(?{push @stack, $2 }))$/, - "Recursion matches"; - is(@stack, @expect, "Right amount of matches") - or skip "Won't test individual results as count isn't equal", - 0 + @expect; - my $idx = 0; - foreach my $expect (@expect) { - is($stack [$idx], $expect, - "Expecting '$expect' at stack pos #$idx"); - $idx ++; - } - } - } - - { - my $s = '123453456'; - $s =~ s/(?\d+)\k/$+{digits}/; - ok $s eq '123456', 'Named capture (angle brackets) s///'; - $s = '123453456'; - $s =~ s/(?'digits'\d+)\k'digits'/$+{digits}/; - ok $s eq '123456', 'Named capture (single quotes) s///'; - } - - { - my @ary = ( - pack('U', 0x00F1), # n-tilde - '_'.pack('U', 0x00F1), # _ + n-tilde - 'c'.pack('U', 0x0327), # c + cedilla - pack('U*', 0x00F1, 0x0327), # n-tilde + cedilla - pack('U', 0x0391), # ALPHA - pack('U', 0x0391).'2', # ALPHA + 2 - pack('U', 0x0391).'_', # ALPHA + _ - ); - - for my $uni (@ary) { - my ($r1, $c1, $r2, $c2) = eval qq { - use utf8; - scalar ("..foo foo.." =~ /(?'${uni}'foo) \\k'${uni}'/), - \$+{${uni}}, - scalar ("..bar bar.." =~ /(?<${uni}>bar) \\k<${uni}>/), - \$+{${uni}}; - }; - ok $r1, "Named capture UTF (?'')"; - ok defined $c1 && $c1 eq 'foo', "Named capture UTF \%+"; - ok $r2, "Named capture UTF (?<>)"; - ok defined $c2 && $c2 eq 'bar', "Named capture UTF \%+"; - } - } - - { - my $s = 'foo bar baz'; - my @res; - if ('1234' =~ /(?1)(?2)(?3)(?4)/) { - foreach my $name (sort keys(%-)) { - my $ary = $- {$name}; - foreach my $idx (0 .. $#$ary) { - push @res, "$name:$idx:$ary->[$idx]"; - } - } - } - my @expect = qw (A:0:1 A:1:3 B:0:2 B:1:4); - is("@res", "@expect", "Check %-"); - eval' - no warnings "uninitialized"; - print for $- {this_key_doesnt_exist}; - '; - ok !$@,'lvalue $- {...} should not throw an exception'; - } - - { - # \, breaks {3,4} - ok "xaaay" !~ /xa{3\,4}y/, '\, in a pattern'; - ok "xa{3,4}y" =~ /xa{3\,4}y/, '\, in a pattern'; - - # \c\ followed by _ - ok "x\c_y" !~ /x\c\_y/, '\_ in a pattern'; - ok "x\c\_y" =~ /x\c\_y/, '\_ in a pattern'; - - # \c\ followed by other characters - for my $c ("z", "\0", "!", chr(254), chr(256)) { - my $targ = "a\034$c"; - my $reg = "a\\c\\$c"; - ok eval ("qq/$targ/ =~ /$reg/"), "\\c\\ in pattern"; - } - } - - { # Test the (*PRUNE) pattern - our $count = 0; - 'aaab' =~ /a+b?(?{$count++})(*FAIL)/; - is($count, 9, "Expect 9 for no (*PRUNE)"); - $count = 0; - 'aaab' =~ /a+b?(*PRUNE)(?{$count++})(*FAIL)/; - is($count, 3, "Expect 3 with (*PRUNE)"); - local $_ = 'aaab'; - $count = 0; - 1 while /.(*PRUNE)(?{$count++})(*FAIL)/g; - is($count, 4, "/.(*PRUNE)/"); - $count = 0; - 'aaab' =~ /a+b?(??{'(*PRUNE)'})(?{$count++})(*FAIL)/; - is($count, 3, "Expect 3 with (*PRUNE)"); - local $_ = 'aaab'; - $count = 0; - 1 while /.(??{'(*PRUNE)'})(?{$count++})(*FAIL)/g; - is($count, 4, "/.(*PRUNE)/"); - } - - { # Test the (*SKIP) pattern - our $count = 0; - 'aaab' =~ /a+b?(*SKIP)(?{$count++})(*FAIL)/; - is($count, 1, "Expect 1 with (*SKIP)"); - local $_ = 'aaab'; - $count = 0; - 1 while /.(*SKIP)(?{$count++})(*FAIL)/g; - is($count, 4, "/.(*SKIP)/"); - $_ = 'aaabaaab'; - $count = 0; - our @res = (); - 1 while /(a+b?)(*SKIP)(?{$count++; push @res,$1})(*FAIL)/g; - is($count, 2, "Expect 2 with (*SKIP)"); - is("@res", "aaab aaab", "Adjacent (*SKIP) works as expected"); - } - - { # Test the (*SKIP) pattern - our $count = 0; - 'aaab' =~ /a+b?(*MARK:foo)(*SKIP)(?{$count++})(*FAIL)/; - is($count, 1, "Expect 1 with (*SKIP)"); - local $_ = 'aaab'; - $count = 0; - 1 while /.(*MARK:foo)(*SKIP)(?{$count++})(*FAIL)/g; - is($count, 4, "/.(*SKIP)/"); - $_ = 'aaabaaab'; - $count = 0; - our @res = (); - 1 while /(a+b?)(*MARK:foo)(*SKIP)(?{$count++; push @res,$1})(*FAIL)/g; - is($count, 2, "Expect 2 with (*SKIP)"); - is("@res", "aaab aaab", "Adjacent (*SKIP) works as expected"); - } - - { # Test the (*SKIP) pattern - our $count = 0; - 'aaab' =~ /a*(*MARK:a)b?(*MARK:b)(*SKIP:a)(?{$count++})(*FAIL)/; - is($count, 3, "Expect 3 with *MARK:a)b?(*MARK:b)(*SKIP:a)"); - local $_ = 'aaabaaab'; - $count = 0; - our @res = (); - 1 while - /(a*(*MARK:a)b?)(*MARK:x)(*SKIP:a)(?{$count++; push @res,$1})(*FAIL)/g; - is($count, 5, "Expect 5 with (*MARK:a)b?)(*MARK:x)(*SKIP:a)"); - is("@res", "aaab b aaab b ", - "Adjacent (*MARK:a)b?)(*MARK:x)(*SKIP:a) works as expected"); - } - - { # Test the (*COMMIT) pattern - our $count = 0; - 'aaabaaab' =~ /a+b?(*COMMIT)(?{$count++})(*FAIL)/; - is($count, 1, "Expect 1 with (*COMMIT)"); - local $_ = 'aaab'; - $count = 0; - 1 while /.(*COMMIT)(?{$count++})(*FAIL)/g; - is($count, 1, "/.(*COMMIT)/"); - $_ = 'aaabaaab'; - $count = 0; - our @res = (); - 1 while /(a+b?)(*COMMIT)(?{$count++; push @res,$1})(*FAIL)/g; - is($count, 1, "Expect 1 with (*COMMIT)"); - is("@res", "aaab", "Adjacent (*COMMIT) works as expected"); - } - - { - # Test named commits and the $REGERROR var - our $REGERROR; - for my $name ('', ':foo') { - for my $pat ("(*PRUNE$name)", - ($name ? "(*MARK$name)" : "") . "(*SKIP$name)", - "(*COMMIT$name)") { - for my $suffix ('(*FAIL)', '') { - 'aaaab' =~ /a+b$pat$suffix/; - is($REGERROR, - ($suffix ? ($name ? 'foo' : "1") : ""), - "Test $pat and \$REGERROR $suffix"); - } - } - } - } - - { - # Test named commits and the $REGERROR var - package Fnorble; - our $REGERROR; - for my $name ('', ':foo') { - for my $pat ("(*PRUNE$name)", - ($name ? "(*MARK$name)" : "") . "(*SKIP$name)", - "(*COMMIT$name)") { - for my $suffix ('(*FAIL)','') { - 'aaaab' =~ /a+b$pat$suffix/; - ::is($REGERROR, - ($suffix ? ($name ? 'foo' : "1") : ""), - "Test $pat and \$REGERROR $suffix"); - } - } - } - } - - { - # Test named commits and the $REGERROR var - my $message = '$REGERROR'; - our $REGERROR; - for my $word (qw (bar baz bop)) { - $REGERROR = ""; - "aaaaa$word" =~ - /a+(?:bar(*COMMIT:bar)|baz(*COMMIT:baz)|bop(*COMMIT:bop))(*FAIL)/; - is($REGERROR, $word, $message); - } - } - - { - #Mindnumbingly simple test of (*THEN) - for ("ABC","BAX") { - ok /A (*THEN) X | B (*THEN) C/x, "Simple (*THEN) test"; - } - } - - { - my $message = "Relative Recursion"; - my $parens = qr/(\((?:[^()]++|(?-1))*+\))/; - local $_ = 'foo((2*3)+4-3) + bar(2*(3+4)-1*(2-3))'; - my ($all, $one, $two) = ('', '', ''); - ok(m/foo $parens \s* \+ \s* bar $parens/x, $message); - is($1, '((2*3)+4-3)', $message); - is($2, '(2*(3+4)-1*(2-3))', $message); - is($&, 'foo((2*3)+4-3) + bar(2*(3+4)-1*(2-3))', $message); - is($&, $_, $message); - } - - { - my $spaces=" "; - local $_ = join 'bar', $spaces, $spaces; - our $count = 0; - s/(?>\s+bar)(?{$count++})//g; - is($_, $spaces, "SUSPEND final string"); - is($count, 1, "Optimiser should have prevented more than one match"); - } - - { - # From Message-ID: <877ixs6oa6.fsf@k75.linux.bogus> - my $dow_name = "nada"; - my $parser = "(\$dow_name) = \$time_string =~ /(D\x{e9}\\ " . - "C\x{e9}adaoin|D\x{e9}\\ Sathairn|\\w+|\x{100})/"; - my $time_string = "D\x{e9} C\x{e9}adaoin"; - eval $parser; - ok !$@, "Test Eval worked"; - is($dow_name, $time_string, "UTF-8 trie common prefix extraction"); - } - - { - my $v; - ($v = 'bar') =~ /(\w+)/g; - $v = 'foo'; - is("$1", 'bar', - '$1 is safe after /g - may fail due to specialized config in pp_hot.c'); - } - - { - my $message = "http://nntp.perl.org/group/perl.perl5.porters/118663"; - my $qr_barR1 = qr/(bar)\g-1/; - like("foobarbarxyz", $qr_barR1, $message); - like("foobarbarxyz", qr/foo${qr_barR1}xyz/, $message); - like("foobarbarxyz", qr/(foo)${qr_barR1}xyz/, $message); - like("foobarbarxyz", qr/(foo)(bar)\g{-1}xyz/, $message); - like("foobarbarxyz", qr/(foo${qr_barR1})xyz/, $message); - like("foobarbarxyz", qr/(foo(bar)\g{-1})xyz/, $message); - } - - { - my $message = '$REGMARK'; - our @r = (); - our ($REGMARK, $REGERROR); - like('foofoo', qr/foo (*MARK:foo) (?{push @r,$REGMARK}) /x, $message); - is("@r","foo", $message); - is($REGMARK, "foo", $message); - unlike('foofoo', qr/foo (*MARK:foo) (*FAIL) /x, $message); - is($REGMARK, '', $message); - is($REGERROR, 'foo', $message); - } - - { - my $message = '\K test'; - my $x; - $x = "abc.def.ghi.jkl"; - $x =~ s/.*\K\..*//; - is($x, "abc.def.ghi", $message); - - $x = "one two three four"; - $x =~ s/o+ \Kthree//g; - is($x, "one two four", $message); - - $x = "abcde"; - $x =~ s/(.)\K/$1/g; - is($x, "aabbccddee", $message); - } - - if (is_perlcc_compiled) { - SKIP: { - skip "perlcc wontfix re-eval using curpm #328, #330", 2; - } - } else { - - sub kt { - return '4' if $_[0] eq '09028623'; - } - # Nested EVAL using PL_curpm (via $1 or friends) - my $re; - our $grabit = qr/ ([0-6][0-9]{7}) (??{ kt $1 }) [890] /x; - $re = qr/^ ( (??{ $grabit }) ) $ /x; - my @res = '0902862349' =~ $re; - is(join ("-", @res), "0902862349", - 'PL_curpm is set properly on nested eval'); - our $qr = qr/ (o) (??{ $1 }) /x; - ok 'boob'=~/( b (??{ $qr }) b )/x && 1, "PL_curpm, nested eval"; - } - - { - use charnames ":full"; - ok "\N{ROMAN NUMERAL ONE}" =~ /\p{Alphabetic}/, "I =~ Alphabetic"; - ok "\N{ROMAN NUMERAL ONE}" =~ /\p{Uppercase}/, "I =~ Uppercase"; - ok "\N{ROMAN NUMERAL ONE}" !~ /\p{Lowercase}/, "I !~ Lowercase"; - ok "\N{ROMAN NUMERAL ONE}" =~ /\p{IDStart}/, "I =~ ID_Start"; - ok "\N{ROMAN NUMERAL ONE}" =~ /\p{IDContinue}/, "I =~ ID_Continue"; - ok "\N{SMALL ROMAN NUMERAL ONE}" =~ /\p{Alphabetic}/, "i =~ Alphabetic"; - ok "\N{SMALL ROMAN NUMERAL ONE}" !~ /\p{Uppercase}/, "i !~ Uppercase"; - ok "\N{SMALL ROMAN NUMERAL ONE}" =~ /\p{Uppercase}/i, "i =~ Uppercase under /i"; - ok "\N{SMALL ROMAN NUMERAL ONE}" !~ /\p{Titlecase}/, "i !~ Titlecase"; - ok "\N{SMALL ROMAN NUMERAL ONE}" =~ /\p{Titlecase}/i, "i =~ Titlecase under /i"; - ok "\N{ROMAN NUMERAL ONE}" =~ /\p{Lowercase}/i, "I =~ Lowercase under /i"; - - ok "\N{SMALL ROMAN NUMERAL ONE}" =~ /\p{Lowercase}/, "i =~ Lowercase"; - ok "\N{SMALL ROMAN NUMERAL ONE}" =~ /\p{IDStart}/, "i =~ ID_Start"; - ok "\N{SMALL ROMAN NUMERAL ONE}" =~ /\p{IDContinue}/, "i =~ ID_Continue" - } - - { # More checking that /i works on the few properties that it makes a - # difference. Uppercase, Lowercase, and Titlecase were done in the - # block above - ok "A" =~ /\p{PosixUpper}/, "A =~ PosixUpper"; - ok "A" =~ /\p{PosixUpper}/i, "A =~ PosixUpper under /i"; - ok "A" !~ /\p{PosixLower}/, "A !~ PosixLower"; - ok "A" =~ /\p{PosixLower}/i, "A =~ PosixLower under /i"; - ok "a" !~ /\p{PosixUpper}/, "a !~ PosixUpper"; - ok "a" =~ /\p{PosixUpper}/i, "a =~ PosixUpper under /i"; - ok "a" =~ /\p{PosixLower}/, "a =~ PosixLower"; - ok "a" =~ /\p{PosixLower}/i, "a =~ PosixLower under /i"; - - ok "\xC0" =~ /\p{XPosixUpper}/, "\\xC0 =~ XPosixUpper"; - ok "\xC0" =~ /\p{XPosixUpper}/i, "\\xC0 =~ XPosixUpper under /i"; - ok "\xC0" !~ /\p{XPosixLower}/, "\\xC0 !~ XPosixLower"; - ok "\xC0" =~ /\p{XPosixLower}/i, "\\xC0 =~ XPosixLower under /i"; - ok "\xE0" !~ /\p{XPosixUpper}/, "\\xE0 !~ XPosixUpper"; - ok "\xE0" =~ /\p{XPosixUpper}/i, "\\xE0 =~ XPosixUpper under /i"; - ok "\xE0" =~ /\p{XPosixLower}/, "\\xE0 =~ XPosixLower"; - ok "\xE0" =~ /\p{XPosixLower}/i, "\\xE0 =~ XPosixLower under /i"; - - ok "\xC0" =~ /\p{UppercaseLetter}/, "\\xC0 =~ UppercaseLetter"; - ok "\xC0" =~ /\p{UppercaseLetter}/i, "\\xC0 =~ UppercaseLetter under /i"; - ok "\xC0" !~ /\p{LowercaseLetter}/, "\\xC0 !~ LowercaseLetter"; - ok "\xC0" =~ /\p{LowercaseLetter}/i, "\\xC0 =~ LowercaseLetter under /i"; - ok "\xC0" !~ /\p{TitlecaseLetter}/, "\\xC0 !~ TitlecaseLetter"; - ok "\xC0" =~ /\p{TitlecaseLetter}/i, "\\xC0 =~ TitlecaseLetter under /i"; - ok "\xE0" !~ /\p{UppercaseLetter}/, "\\xE0 !~ UppercaseLetter"; - ok "\xE0" =~ /\p{UppercaseLetter}/i, "\\xE0 =~ UppercaseLetter under /i"; - ok "\xE0" =~ /\p{LowercaseLetter}/, "\\xE0 =~ LowercaseLetter"; - ok "\xE0" =~ /\p{LowercaseLetter}/i, "\\xE0 =~ LowercaseLetter under /i"; - ok "\xE0" !~ /\p{TitlecaseLetter}/, "\\xE0 !~ TitlecaseLetter"; - ok "\xE0" =~ /\p{TitlecaseLetter}/i, "\\xE0 =~ TitlecaseLetter under /i"; - ok "\x{1C5}" !~ /\p{UppercaseLetter}/, "\\x{1C5} !~ UppercaseLetter"; - ok "\x{1C5}" =~ /\p{UppercaseLetter}/i, "\\x{1C5} =~ UppercaseLetter under /i"; - ok "\x{1C5}" !~ /\p{LowercaseLetter}/, "\\x{1C5} !~ LowercaseLetter"; - ok "\x{1C5}" =~ /\p{LowercaseLetter}/i, "\\x{1C5} =~ LowercaseLetter under /i"; - ok "\x{1C5}" =~ /\p{TitlecaseLetter}/, "\\x{1C5} =~ TitlecaseLetter"; - ok "\x{1C5}" =~ /\p{TitlecaseLetter}/i, "\\x{1C5} =~ TitlecaseLetter under /i"; - } - - { - # requirement of Unicode Technical Standard #18, 1.7 Code Points - # cf. http://www.unicode.org/reports/tr18/#Supplementary_Characters - for my $u (0x7FF, 0x800, 0xFFFF, 0x10000) { - no warnings 'utf8'; # oops - my $c = chr $u; - my $x = sprintf '%04X', $u; - ok "A${c}B" =~ /A[\0-\x{10000}]B/, "Unicode range - $x"; - } - } - - { - my $res=""; - - if ('1' =~ /(?|(?1)|(?2))/) { - $res = "@{$- {digit}}"; - } - is($res, "1", - "Check that (?|...) doesnt cause dupe entries in the names array"); - - $res = ""; - if ('11' =~ /(?|(?1)|(?2))(?&digit)/) { - $res = "@{$- {digit}}"; - } - is($res, "1", - "Check that (?&..) to a buffer inside a (?|...) goes to the leftmost"); - } - - { - use warnings; - my $message = "ASCII pattern that really is UTF-8"; - my @w; - local $SIG {__WARN__} = sub {push @w, "@_"}; - my $c = qq (\x{DF}); - like($c, qr/${c}|\x{100}/, $message); - is("@w", '', $message); - } - - { - my $message = "Corruption of match results of qr// across scopes"; - my $qr = qr/(fo+)(ba+r)/; - 'foobar' =~ /$qr/; - is("$1$2", "foobar", $message); - { - 'foooooobaaaaar' =~ /$qr/; - is("$1$2", 'foooooobaaaaar', $message); - } - is("$1$2", "foobar", $message); - } - - { - my $message = "HORIZWS"; - local $_ = "\t \r\n \n \t".chr(11)."\n"; - s/\H/H/g; - s/\h/h/g; - is($_, "hhHHhHhhHH", $message); - $_ = "\t \r\n \n \t" . chr (11) . "\n"; - utf8::upgrade ($_); - s/\H/H/g; - s/\h/h/g; - is($_, "hhHHhHhhHH", $message); - } - - { - # Various whitespace special patterns - my @h = map {chr $_} 0x09, 0x20, 0xa0, 0x1680, 0x180e, 0x2000, - 0x2001, 0x2002, 0x2003, 0x2004, 0x2005, 0x2006, - 0x2007, 0x2008, 0x2009, 0x200a, 0x202f, 0x205f, - 0x3000; - my @v = map {chr $_} 0x0a, 0x0b, 0x0c, 0x0d, 0x85, 0x2028, - 0x2029; - my @lb = ("\x0D\x0A", map {chr $_} 0x0A .. 0x0D, 0x85, 0x2028, 0x2029); - foreach my $t ([\@h, qr/\h/, qr/\h+/], - [\@v, qr/\v/, qr/\v+/], - [\@lb, qr/\R/, qr/\R+/],) { - my $ary = shift @$t; - foreach my $pat (@$t) { - foreach my $str (@$ary) { - ok $str =~ /($pat)/, $pat; - is($1, $str, $pat); - utf8::upgrade ($str); - ok $str =~ /($pat)/, "Upgraded string - $pat"; - is($1, $str, "Upgraded string - $pat"); - } - } - } - } - - { - # Check that \\xDF match properly in its various forms - # Test that \xDF matches properly. this is pretty hacky stuff, - # but its actually needed. The malarky with '-' is to prevent - # compilation caching from playing any role in the test. - my @df = (chr (0xDF), '-', chr (0xDF)); - utf8::upgrade ($df [2]); - my @strs = ('ss', 'sS', 'Ss', 'SS', chr (0xDF)); - my @ss = map {("$_", "$_")} @strs; - utf8::upgrade ($ss [$_ * 2 + 1]) for 0 .. $#strs; - - for my $ssi (0 .. $#ss) { - for my $dfi (0 .. $#df) { - my $pat = $df [$dfi]; - my $str = $ss [$ssi]; - my $utf_df = ($dfi > 1) ? 'utf8' : ''; - my $utf_ss = ($ssi % 2) ? 'utf8' : ''; - (my $sstr = $str) =~ s/\xDF/\\xDF/; - - if ($utf_df || $utf_ss || length ($ss [$ssi]) == 1) { - my $ret = $str =~ /$pat/i; - next if $pat eq '-'; - ok $ret, "\"$sstr\" =~ /\\xDF/i " . - "(str is @{[$utf_ss||'latin']}, pat is " . - "@{[$utf_df||'latin']})"; - } - else { - my $ret = $str !~ /$pat/i; - next if $pat eq '-'; - ok $ret, "\"$sstr\" !~ /\\xDF/i " . - "(str is @{[$utf_ss||'latin']}, pat is " . - "@{[$utf_df||'latin']})"; - } - } - } - } - - { - my $message = "BBC(Bleadperl Breaks CPAN) Today: String::Multibyte"; - my $re = qr/(?:[\x00-\xFF]{4})/; - my $hyp = "\0\0\0-"; - my $esc = "\0\0\0\\"; - - my $str = "$esc$hyp$hyp$esc$esc"; - my @a = ($str =~ /\G(?:\Q$esc$esc\E|\Q$esc$hyp\E|$re)/g); - - is(@a,3, $message); - local $" = "="; - is("@a","$esc$hyp=$hyp=$esc$esc", $message); - } - - { - # Test for keys in %+ and %- - my $message = 'Test keys in %+ and %-'; - no warnings 'uninitialized'; - my $_ = "abcdef"; - /(?a)|(?b)/; - is((join ",", sort keys %+), "foo", $message); - is((join ",", sort keys %-), "foo", $message); - is((join ",", sort values %+), "a", $message); - is((join ",", sort map "@$_", values %-), "a ", $message); - /(?a)(?b)(?.)/; - is((join ",", sort keys %+), "bar,quux", $message); - is((join ",", sort keys %-), "bar,quux", $message); - is((join ",", sort values %+), "a,c", $message); # leftmost - is((join ",", sort map "@$_", values %-), "a b,c", $message); - /(?a)(?c)?/; # second buffer won't capture - is((join ",", sort keys %+), "un", $message); - is((join ",", sort keys %-), "deux,un", $message); - is((join ",", sort values %+), "a", $message); - is((join ",", sort map "@$_", values %-), ",a", $message); - } - - { - # length() on captures, the numbered ones end up in Perl_magic_len - my $_ = "aoeu \xe6var ook"; - /^ \w+ \s (?\S+)/x; - - is(length $`, 0, q[length $`]); - is(length $', 4, q[length $']); - is(length $&, 9, q[length $&]); - is(length $1, 4, q[length $1]); - is(length $+{eek}, 4, q[length $+{eek} == length $1]); - } - - { - my $ok = -1; - - $ok = exists ($-{x}) ? 1 : 0 if 'bar' =~ /(?foo)|bar/; - is($ok, 1, '$-{x} exists after "bar"=~/(?foo)|bar/'); - is(scalar (%+), 0, 'scalar %+ == 0 after "bar"=~/(?foo)|bar/'); - is(scalar (%-), 1, 'scalar %- == 1 after "bar"=~/(?foo)|bar/'); - - $ok = -1; - $ok = exists ($+{x}) ? 1 : 0 if 'bar' =~ /(?foo)|bar/; - is($ok, 0, '$+{x} not exists after "bar"=~/(?foo)|bar/'); - is(scalar (%+), 0, 'scalar %+ == 0 after "bar"=~/(?foo)|bar/'); - is(scalar (%-), 1, 'scalar %- == 1 after "bar"=~/(?foo)|bar/'); - - $ok = -1; - $ok = exists ($-{x}) ? 1 : 0 if 'foo' =~ /(?foo)|bar/; - is($ok, 1, '$-{x} exists after "foo"=~/(?foo)|bar/'); - is(scalar (%+), 1, 'scalar %+ == 1 after "foo"=~/(?foo)|bar/'); - is(scalar (%-), 1, 'scalar %- == 1 after "foo"=~/(?foo)|bar/'); - - $ok = -1; - $ok = exists ($+{x}) ? 1 : 0 if 'foo'=~/(?foo)|bar/; - is($ok, 1, '$+{x} exists after "foo"=~/(?foo)|bar/'); - } - - { - local $_; - ($_ = 'abc') =~ /(abc)/g; - $_ = '123'; - is("$1", 'abc', "/g leads to unsafe match vars: $1"); - - fresh_perl_is(<<'EOP', ">abc<\n", {}, 'mention $&'); -$&; -my $x; -($x='abc')=~/(abc)/g; -$x='123'; -print ">$1<\n"; -EOP - - local $::TODO = 'RT #86042'; - fresh_perl_is(<<'EOP', ">abc<\n", {}, 'no mention of $&'); -my $x; -($x='abc')=~/(abc)/g; -$x='123'; -print ">$1<\n"; -EOP - } - - { - # Message-ID: <20070818091501.7eff4831@r2d2> - my $str = ""; - for (0 .. 5) { - my @x; - $str .= "@x"; # this should ALWAYS be the empty string - 'a' =~ /(a|)/; - push @x, 1; - } - is(length $str, 0, "Trie scope error, string should be empty"); - $str = ""; - my @foo = ('a') x 5; - for (@foo) { - my @bar; - $str .= "@bar"; - s/a|/push @bar, 1/e; - } - is(length $str, 0, "Trie scope error, string should be empty"); - } - - { -# more TRIE/AHOCORASICK problems with mixed utf8 / latin-1 and case folding - for my $chr (160 .. 255) { - my $chr_byte = chr($chr); - my $chr_utf8 = chr($chr); utf8::upgrade($chr_utf8); - my $rx = qr{$chr_byte|X}i; - ok($chr_utf8 =~ $rx, "utf8/latin, codepoint $chr"); - } - } - - { - our $a = 3; "" =~ /(??{ $a })/; - our $b = $a; - is($b, $a, "Copy of scalar used for postponed subexpression"); - } - - if (is_perlcc_compiled) { - SKIP: { - skip "perlcc wontfix re-eval lex/global mixup #328", 3; - } - } else { - - our @ctl_n = (); - our @plus = (); - our $nested_tags; - $nested_tags = qr{ - < - (\w+) - (?{ - push @ctl_n,$^N; - push @plus,$+; - }) - > - (??{$nested_tags})* - - }x; - - my $match = '' =~ m/^$nested_tags$/; - ok $match, 'nested construct matches'; - is("@ctl_n", "bla blubb", '$^N inside of (?{}) works as expected'); - is("@plus", "bla blubb", '$+ inside of (?{}) works as expected'); - } - - SKIP: { - # XXX: This set of tests is essentially broken, POSIX character classes - # should not have differing definitions under Unicode. - # There are property names for that. - skip "Tests assume ASCII", 4 unless $::IS_ASCII; - - my @notIsPunct = grep {/[[:punct:]]/ and not /\p{IsPunct}/} - map {chr} 0x20 .. 0x7f; - is(join ('', @notIsPunct), '$+<=>^`|~', - '[:punct:] disagrees with IsPunct on Symbols'); - - my @isPrint = grep {not /[[:print:]]/ and /\p{IsPrint}/} - map {chr} 0 .. 0x1f, 0x7f .. 0x9f; - is(join ('', @isPrint), "", - 'IsPrint agrees with [:print:] on control characters'); - - my @isPunct = grep {/[[:punct:]]/ != /\p{IsPunct}/} - map {chr} 0x80 .. 0xff; - is(join ('', @isPunct), "\xa1\xab\xb7\xbb\xbf", # ¡ « · » ¿ - 'IsPunct disagrees with [:punct:] outside ASCII'); - - my @isPunctLatin1 = eval q { - use encoding 'latin1'; - grep {/[[:punct:]]/ != /\p{IsPunct}/} map {chr} 0x80 .. 0xff; - }; - skip "Eval failed ($@)", 1 if $@; - skip "PERL_LEGACY_UNICODE_CHARCLASS_MAPPINGS set to 0", 1 - if !$ENV{PERL_TEST_LEGACY_POSIX_CC}; - is(join ('', @isPunctLatin1), '', - 'IsPunct agrees with [:punct:] with explicit Latin1'); - } - - { - # Tests for [#perl 71942] - our $count_a; - our $count_b; - - my $c = 0; - for my $re ( -# [ -# should match?, -# input string, -# re 1, -# re 2, -# expected values of count_a and count_b, -# ] - [ - 0, - "xababz", - qr/a+(?{$count_a++})b?(*COMMIT)(*FAIL)/, - qr/a+(?{$count_b++})b?(*COMMIT)z/, - 1, - ], - [ - 0, - "xababz", - qr/a+(?{$count_a++})b?(*COMMIT)\s*(*FAIL)/, - qr/a+(?{$count_b++})b?(*COMMIT)\s*z/, - 1, - ], - [ - 0, - "xababz", - qr/a+(?{$count_a++})(?:b|)?(*COMMIT)(*FAIL)/, - qr/a+(?{$count_b++})(?:b|)?(*COMMIT)z/, - 1, - ], - [ - 0, - "xababz", - qr/a+(?{$count_a++})b{0,6}(*COMMIT)(*FAIL)/, - qr/a+(?{$count_b++})b{0,6}(*COMMIT)z/, - 1, - ], - [ - 0, - "xabcabcz", - qr/a+(?{$count_a++})(bc){0,6}(*COMMIT)(*FAIL)/, - qr/a+(?{$count_b++})(bc){0,6}(*COMMIT)z/, - 1, - ], - [ - 0, - "xabcabcz", - qr/a+(?{$count_a++})(bc*){0,6}(*COMMIT)(*FAIL)/, - qr/a+(?{$count_b++})(bc*){0,6}(*COMMIT)z/, - 1, - ], - - - [ - 0, - "aaaabtz", - qr/a+(?{$count_a++})b?(*PRUNE)(*FAIL)/, - qr/a+(?{$count_b++})b?(*PRUNE)z/, - 4, - ], - [ - 0, - "aaaabtz", - qr/a+(?{$count_a++})b?(*PRUNE)\s*(*FAIL)/, - qr/a+(?{$count_b++})b?(*PRUNE)\s*z/, - 4, - ], - [ - 0, - "aaaabtz", - qr/a+(?{$count_a++})(?:b|)(*PRUNE)(*FAIL)/, - qr/a+(?{$count_b++})(?:b|)(*PRUNE)z/, - 4, - ], - [ - 0, - "aaaabtz", - qr/a+(?{$count_a++})b{0,6}(*PRUNE)(*FAIL)/, - qr/a+(?{$count_b++})b{0,6}(*PRUNE)z/, - 4, - ], - [ - 0, - "aaaabctz", - qr/a+(?{$count_a++})(bc){0,6}(*PRUNE)(*FAIL)/, - qr/a+(?{$count_b++})(bc){0,6}(*PRUNE)z/, - 4, - ], - [ - 0, - "aaaabctz", - qr/a+(?{$count_a++})(bc*){0,6}(*PRUNE)(*FAIL)/, - qr/a+(?{$count_b++})(bc*){0,6}(*PRUNE)z/, - 4, - ], - - [ - 0, - "aaabaaab", - qr/a+(?{$count_a++;})b?(*SKIP)(*FAIL)/, - qr/a+(?{$count_b++;})b?(*SKIP)z/, - 2, - ], - [ - 0, - "aaabaaab", - qr/a+(?{$count_a++;})b?(*SKIP)\s*(*FAIL)/, - qr/a+(?{$count_b++;})b?(*SKIP)\s*z/, - 2, - ], - [ - 0, - "aaabaaab", - qr/a+(?{$count_a++;})(?:b|)(*SKIP)(*FAIL)/, - qr/a+(?{$count_b++;})(?:b|)(*SKIP)z/, - 2, - ], - [ - 0, - "aaabaaab", - qr/a+(?{$count_a++;})b{0,6}(*SKIP)(*FAIL)/, - qr/a+(?{$count_b++;})b{0,6}(*SKIP)z/, - 2, - ], - [ - 0, - "aaabcaaabc", - qr/a+(?{$count_a++;})(bc){0,6}(*SKIP)(*FAIL)/, - qr/a+(?{$count_b++;})(bc){0,6}(*SKIP)z/, - 2, - ], - [ - 0, - "aaabcaaabc", - qr/a+(?{$count_a++;})(bc*){0,6}(*SKIP)(*FAIL)/, - qr/a+(?{$count_b++;})(bc*){0,6}(*SKIP)z/, - 2, - ], - - - [ - 0, - "aaddbdaabyzc", - qr/a (?{$count_a++;}) (*MARK:T1) (a*) .*? b? (*SKIP:T1) (*FAIL) \s* c \1 /x, - qr/a (?{$count_b++;}) (*MARK:T1) (a*) .*? b? (*SKIP:T1) z \s* c \1 /x, - 4, - ], - [ - 0, - "aaddbdaabyzc", - qr/a (?{$count_a++;}) (*MARK:T1) (a*) .*? b? (*SKIP:T1) \s* (*FAIL) \s* c \1 /x, - qr/a (?{$count_b++;}) (*MARK:T1) (a*) .*? b? (*SKIP:T1) \s* z \s* c \1 /x, - 4, - ], - [ - 0, - "aaddbdaabyzc", - qr/a (?{$count_a++;}) (*MARK:T1) (a*) .*? (?:b|) (*SKIP:T1) (*FAIL) \s* c \1 /x, - qr/a (?{$count_b++;}) (*MARK:T1) (a*) .*? (?:b|) (*SKIP:T1) z \s* c \1 /x, - 4, - ], - [ - 0, - "aaddbdaabyzc", - qr/a (?{$count_a++;}) (*MARK:T1) (a*) .*? b{0,6} (*SKIP:T1) (*FAIL) \s* c \1 /x, - qr/a (?{$count_b++;}) (*MARK:T1) (a*) .*? b{0,6} (*SKIP:T1) z \s* c \1 /x, - 4, - ], - [ - 0, - "aaddbcdaabcyzc", - qr/a (?{$count_a++;}) (*MARK:T1) (a*) .*? (bc){0,6} (*SKIP:T1) (*FAIL) \s* c \1 /x, - qr/a (?{$count_b++;}) (*MARK:T1) (a*) .*? (bc){0,6} (*SKIP:T1) z \s* c \1 /x, - 4, - ], - [ - 0, - "aaddbcdaabcyzc", - qr/a (?{$count_a++;}) (*MARK:T1) (a*) .*? (bc*){0,6} (*SKIP:T1) (*FAIL) \s* c \1 /x, - qr/a (?{$count_b++;}) (*MARK:T1) (a*) .*? (bc*){0,6} (*SKIP:T1) z \s* c \1 /x, - 4, - ], - - - [ - 0, - "aaaaddbdaabyzc", - qr/a (?{$count_a++;}) (a?) (*MARK:T1) (a*) .*? b? (*MARK:T1) (*SKIP:T1) (*FAIL) \s* c \1 /x, - qr/a (?{$count_b++;}) (a?) (*MARK:T1) (a*) .*? b? (*MARK:T1) (*SKIP:T1) z \s* c \1 /x, - 2, - ], - [ - 0, - "aaaaddbdaabyzc", - qr/a (?{$count_a++;}) (a?) (*MARK:T1) (a*) .*? b? (*MARK:T1) (*SKIP:T1) \s* (*FAIL) \s* c \1 /x, - qr/a (?{$count_b++;}) (a?) (*MARK:T1) (a*) .*? b? (*MARK:T1) (*SKIP:T1) \s* z \s* c \1 /x, - 2, - ], - [ - 0, - "aaaaddbdaabyzc", - qr/a (?{$count_a++;}) (a?) (*MARK:T1) (a*) .*? (?:b|) (*MARK:T1) (*SKIP:T1) (*FAIL) \s* c \1 /x, - qr/a (?{$count_b++;}) (a?) (*MARK:T1) (a*) .*? (?:b|) (*MARK:T1) (*SKIP:T1) z \s* c \1 /x, - 2, - ], - [ - 0, - "aaaaddbdaabyzc", - qr/a (?{$count_a++;}) (a?) (*MARK:T1) (a*) .*? b{0,6} (*MARK:T1) (*SKIP:T1) (*FAIL) \s* c \1 /x, - qr/a (?{$count_b++;}) (a?) (*MARK:T1) (a*) .*? b{0,6} (*MARK:T1) (*SKIP:T1) z \s* c \1 /x, - 2, - ], - [ - 0, - "aaaaddbcdaabcyzc", - qr/a (?{$count_a++;}) (a?) (*MARK:T1) (a*) .*? (bc){0,6} (*MARK:T1) (*SKIP:T1) (*FAIL) \s* c \1 /x, - qr/a (?{$count_b++;}) (a?) (*MARK:T1) (a*) .*? (bc){0,6} (*MARK:T1) (*SKIP:T1) z \s* c \1 /x, - 2, - ], - [ - 0, - "aaaaddbcdaabcyzc", - qr/a (?{$count_a++;}) (a?) (*MARK:T1) (a*) .*? (bc*){0,6} (*MARK:T1) (*SKIP:T1) (*FAIL) \s* c \1 /x, - qr/a (?{$count_b++;}) (a?) (*MARK:T1) (a*) .*? (bc*){0,6} (*MARK:T1) (*SKIP:T1) z \s* c \1 /x, - 2, - ], - - - [ - 0, - "AbcdCBefgBhiBqz", - qr/(A (.*) (?{ $count_a++ }) C? (*THEN) | A D) (*FAIL)/x, - qr/(A (.*) (?{ $count_b++ }) C? (*THEN) | A D) z/x, - 1, - ], - [ - 0, - "AbcdCBefgBhiBqz", - qr/(A (.*) (?{ $count_a++ }) C? (*THEN) | A D) \s* (*FAIL)/x, - qr/(A (.*) (?{ $count_b++ }) C? (*THEN) | A D) \s* z/x, - 1, - ], - [ - 0, - "AbcdCBefgBhiBqz", - qr/(A (.*) (?{ $count_a++ }) (?:C|) (*THEN) | A D) (*FAIL)/x, - qr/(A (.*) (?{ $count_b++ }) (?:C|) (*THEN) | A D) z/x, - 1, - ], - [ - 0, - "AbcdCBefgBhiBqz", - qr/(A (.*) (?{ $count_a++ }) C{0,6} (*THEN) | A D) (*FAIL)/x, - qr/(A (.*) (?{ $count_b++ }) C{0,6} (*THEN) | A D) z/x, - 1, - ], - [ - 0, - "AbcdCEBefgBhiBqz", - qr/(A (.*) (?{ $count_a++ }) (CE){0,6} (*THEN) | A D) (*FAIL)/x, - qr/(A (.*) (?{ $count_b++ }) (CE){0,6} (*THEN) | A D) z/x, - 1, - ], - [ - 0, - "AbcdCBefgBhiBqz", - qr/(A (.*) (?{ $count_a++ }) (CE*){0,6} (*THEN) | A D) (*FAIL)/x, - qr/(A (.*) (?{ $count_b++ }) (CE*){0,6} (*THEN) | A D) z/x, - 1, - ], - ) { - $c++; - $count_a = 0; - $count_b = 0; - - my $match_a = ($re->[1] =~ $re->[2]) || 0; - my $match_b = ($re->[1] =~ $re->[3]) || 0; - - is($match_a, $re->[0], "match a " . ($re->[0] ? "succeeded" : "failed") . " ($c)"); - is($match_b, $re->[0], "match b " . ($re->[0] ? "succeeded" : "failed") . " ($c)"); - is($count_a, $re->[4], "count a ($c)"); - is($count_b, $re->[4], "count b ($c)"); - } - } - - { # Bleadperl v5.13.8-292-gf56b639 breaks NEZUMI/Unicode-LineBreak-1.011 - # \xdf in lookbehind failed to compile as is multi-char fold - my $message = "Lookbehind with \\xdf matchable compiles"; - my $r = eval 'qr{ - (?u: (?<=^url:) | - (?<=[/]) (?=[^/]) | - (?<=[^-.]) (?=[-~.,_?\#%=&]) | - (?<=[=&]) (?=.) - )}iox'; - is($@, '', $message); - isa_ok($r, 'Regexp', $message); - } - - # RT #82610 - ok 'foo/file.fob' =~ m,^(?=[^\.])[^/]*/(?=[^\.])[^/]*\.fo[^/]$,; - - { # This was failing unless an explicit /d was added - my $p = qr/[\xE0_]/i; - utf8::upgrade($p); - like("\xC0", $p, "Verify \"\\xC0\" =~ /[\\xE0_]/i; pattern in utf8"); - } - - # - # Keep the following tests last -- they may crash perl - # - print "# Tests that follow may crash perl\n"; - { - eval '/\k/'; - ok $@ =~ /\QSequence \k... not terminated in regex;\E/, - 'Lone \k not allowed'; - } - - { - my $message = "Substitution with lookahead (possible segv)"; - $_ = "ns1ns1ns1"; - s/ns(?=\d)/ns_/g; - is($_, "ns_1ns_1ns_1", $message); - $_ = "ns1"; - s/ns(?=\d)/ns_/; - is($_, "ns_1", $message); - $_ = "123"; - s/(?=\d+)|(?<=\d)/!Bang!/g; - is($_, "!Bang!1!Bang!2!Bang!3!Bang!", $message); - } - - { - # Earlier versions of Perl said this was fatal. - my $message = "U+0FFFF shouldn't crash the regex engine"; - no warnings 'utf8'; - my $a = eval "chr(65535)"; - use warnings; - my $warning_message; - local $SIG{__WARN__} = sub { $warning_message = $_[0] }; - eval $a =~ /[a-z]/; - ok(1, $message); # If it didn't crash, it worked. - } - - TODO: { # Was looping - todo_skip('Triggers thread clone SEGV. See #86550') - if $::running_as_thread && $::running_as_thread; - watchdog(10); # Use a bigger value for busy systems - like("\x{00DF}", qr/[\x{1E9E}_]*/i, "\"\\x{00DF}\" =~ /[\\x{1E9E}_]*/i was looping"); - } - - { # Bug #90536, caused failed assertion - unlike("s\N{U+DF}", qr/^\x{00DF}/i, "\"s\\N{U+DF}\", qr/^\\x{00DF}/i"); - } - - # !!! NOTE that tests that aren't at all likely to crash perl should go - # a ways above, above these last ones. - - done_testing(); -} # End of sub run_tests - -1; diff --git a/t/CORE/re/pat_psycho.t b/t/CORE/re/pat_psycho.t deleted file mode 100644 index 633f190fd..000000000 --- a/t/CORE/re/pat_psycho.t +++ /dev/null @@ -1,161 +0,0 @@ -#!./perl -# -# This is a home for regular expression tests that don't fit into -# the format supported by re/regexp.t. If you want to add a test -# that does fit that format, add it to re/re_tests, not here. - -use strict; -use warnings; -use 5.010; - - -sub run_tests; - -$| = 1; - - -BEGIN { - require q(t/CORE/test.pl); -} - - -plan tests => 11; # Update this when adding/deleting tests. - -run_tests() unless caller; - -# -# Tests start here. -# -sub run_tests { - - SKIP: - { - print "# Set PERL_SKIP_PSYCHO_TEST to skip this test\n"; - my @normal = qw [the are some normal words]; - - skip "Skipped Psycho", 2 * @normal if $ENV {PERL_SKIP_PSYCHO_TEST}; - - local $" = "|"; - - my @psycho = (@normal, map chr $_, 255 .. 20000); - my $psycho1 = "@psycho"; - for (my $i = @psycho; -- $i;) { - my $j = int rand (1 + $i); - @psycho [$i, $j] = @psycho [$j, $i]; - } - my $psycho2 = "@psycho"; - - foreach my $word (@normal) { - ok $word =~ /($psycho1)/ && $1 eq $word, 'Psycho'; - ok $word =~ /($psycho2)/ && $1 eq $word, 'Psycho'; - } - } - - - SKIP: - { - # stress test CURLYX/WHILEM. - # - # This test includes varying levels of nesting, and according to - # profiling done against build 28905, exercises every code line in the - # CURLYX and WHILEM blocks, except those related to LONGJMP, the - # super-linear cache and warnings. It executes about 0.5M regexes - - skip "No psycho tests" if $ENV {PERL_SKIP_PSYCHO_TEST}; - print "# Set PERL_SKIP_PSYCHO_TEST to skip this test\n"; - my $r = qr/^ - (?: - ( (?:a|z+)+ ) - (?: - ( (?:b|z+){3,}? ) - ( - (?: - (?: - (?:c|z+){1,1}?z - )? - (?:c|z+){1,1} - )* - ) - (?:z*){2,} - ( (?:z+|d)+ ) - (?: - ( (?:e|z+)+ ) - )* - ( (?:f|z+)+ ) - )* - ( (?:z+|g)+ ) - (?: - ( (?:h|z+)+ ) - )* - ( (?:i|z+)+ ) - )+ - ( (?:j|z+)+ ) - (?: - ( (?:k|z+)+ ) - )* - ( (?:l|z+)+ ) - $/x; - - my $ok = 1; - my $msg = "CURLYX stress test"; - OUTER: - for my $a ("x","a","aa") { - for my $b ("x","bbb","bbbb") { - my $bs = $a.$b; - for my $c ("x","c","cc") { - my $cs = $bs.$c; - for my $d ("x","d","dd") { - my $ds = $cs.$d; - for my $e ("x","e","ee") { - my $es = $ds.$e; - for my $f ("x","f","ff") { - my $fs = $es.$f; - for my $g ("x","g","gg") { - my $gs = $fs.$g; - for my $h ("x","h","hh") { - my $hs = $gs.$h; - for my $i ("x","i","ii") { - my $is = $hs.$i; - for my $j ("x","j","jj") { - my $js = $is.$j; - for my $k ("x","k","kk") { - my $ks = $js.$k; - for my $l ("x","l","ll") { - my $ls = $ks.$l; - if ($ls =~ $r) { - if ($ls =~ /x/) { - $msg .= ": unexpected match for [$ls]"; - $ok = 0; - last OUTER; - } - my $cap = "$1$2$3$4$5$6$7$8$9$10$11$12"; - unless ($ls eq $cap) { - $msg .= ": capture: [$ls], got [$cap]"; - $ok = 0; - last OUTER; - } - } - else { - unless ($ls =~ /x/) { - $msg = ": failed for [$ls]"; - $ok = 0; - last OUTER; - } - } - } - } - } - } - } - } - } - } - } - } - } - } - ok($ok, $msg); - } -} # End of sub run_tests - -1; diff --git a/t/CORE/re/pat_re_eval.t b/t/CORE/re/pat_re_eval.t deleted file mode 100644 index deb9d0f3b..000000000 --- a/t/CORE/re/pat_re_eval.t +++ /dev/null @@ -1,344 +0,0 @@ -#!./perl -# -# This is a home for regular expression tests that don't fit into -# the format supported by re/regexp.t. If you want to add a test -# that does fit that format, add it to re/re_tests, not here. - -use strict; -use warnings; -use 5.010; - - -sub run_tests; - -$| = 1; - - -BEGIN { - require q(t/CORE/test.pl); -} - - -plan tests => 123; # Update this when adding/deleting tests. - -run_tests() unless caller; - -# -# Tests start here. -# -sub run_tests { - { - my $message = "Call code from qr //"; - local $_ = 'var="foo"'; - $a = qr/(?{++$b})/; - $b = 7; - ok(/$a$a/ && $b eq '9', $message); - - my $c="$a"; - ok(/$a$a/ && $b eq '11', $message); - - undef $@; - eval {/$c/}; - like($@, qr/not allowed at runtime/, $message); - - use re "eval"; - /$a$c$a/; - is($b, '14', $message); - - our $lex_a = 43; - our $lex_b = 17; - our $lex_c = 27; - my $lex_res = ($lex_b =~ qr/$lex_b(?{ $lex_c = $lex_a++ })/); - - is($lex_res, 1, $message); - is($lex_a, 44, $message); - is($lex_c, 43, $message); - - no re "eval"; - undef $@; - my $match = eval { /$a$c$a/ }; - ok($@ && $@ =~ /Eval-group not allowed/ && !$match, $message); - is($b, '14', $message); - - $lex_a = 2; - $lex_a = 43; - $lex_b = 17; - $lex_c = 27; - $lex_res = ($lex_b =~ qr/17(?{ $lex_c = $lex_a++ })/); - - is($lex_res, 1, $message); - is($lex_a, 44, $message); - is($lex_c, 43, $message); - - } - - { - our $a = bless qr /foo/ => 'Foo'; - ok 'goodfood' =~ $a, "Reblessed qr // matches"; - is($a, '(?^:foo)', "Reblessed qr // stringifies"); - my $x = "\x{3fe}"; - my $z = my $y = "\317\276"; # Byte representation of $x - $a = qr /$x/; - ok $x =~ $a, "UTF-8 interpolation in qr //"; - ok "a$a" =~ $x, "Stringified qr // preserves UTF-8"; - ok "a$x" =~ /^a$a\z/, "Interpolated qr // preserves UTF-8"; - ok "a$x" =~ /^a(??{$a})\z/, - "Postponed interpolation of qr // preserves UTF-8"; - - - is(length qr /##/x, 9, "## in qr // doesn't corrupt memory; Bug 17776"); - - { - use re 'eval'; - ok "$x$x" =~ /^$x(??{$x})\z/, - "Postponed UTF-8 string in UTF-8 re matches UTF-8"; - ok "$y$x" =~ /^$y(??{$x})\z/, - "Postponed UTF-8 string in non-UTF-8 re matches UTF-8"; - ok "$y$x" !~ /^$y(??{$y})\z/, - "Postponed non-UTF-8 string in non-UTF-8 re doesn't match UTF-8"; - ok "$x$x" !~ /^$x(??{$y})\z/, - "Postponed non-UTF-8 string in UTF-8 re doesn't match UTF-8"; - ok "$y$y" =~ /^$y(??{$y})\z/, - "Postponed non-UTF-8 string in non-UTF-8 re matches non-UTF8"; - ok "$x$y" =~ /^$x(??{$y})\z/, - "Postponed non-UTF-8 string in UTF-8 re matches non-UTF8"; - - $y = $z; # Reset $y after upgrade. - ok "$x$y" !~ /^$x(??{$x})\z/, - "Postponed UTF-8 string in UTF-8 re doesn't match non-UTF-8"; - ok "$y$y" !~ /^$y(??{$x})\z/, - "Postponed UTF-8 string in non-UTF-8 re doesn't match non-UTF-8"; - } - } - - - { - use re 'eval'; - # Test if $^N and $+ work in (?{{}) - our @ctl_n = (); - our @plus = (); - our $nested_tags; - $nested_tags = qr{ - < - ((\w)+) - (?{ - push @ctl_n, (defined $^N ? $^N : "undef"); - push @plus, (defined $+ ? $+ : "undef"); - }) - > - (??{$nested_tags})* - - }x; - - - my $c = 0; - for my $test ( - # Test structure: - # [ Expected result, Regex, Expected value(s) of $^N, Expected value(s) of $+ ] - [ 1, qr#^$nested_tags$#, "bla blubb bla", "a b a" ], - [ 1, qr#^($nested_tags)$#, "bla blubb ", "a b a" ], - [ 1, qr#^(|)$nested_tags$#, "bla blubb bla", "a b a" ], - [ 1, qr#^(?:|)$nested_tags$#, "bla blubb bla", "a b a" ], - [ 1, qr#^<(bl|bla)>$nested_tags<(/\1)>$#, "blubb /bla", "b /bla" ], - [ 1, qr#(??{"(|)"})$nested_tags$#, "bla blubb bla", "a b a" ], - [ 1, qr#^(??{"(bla|)"})$nested_tags$#, "bla blubb bla", "a b a" ], - [ 1, qr#^(??{"(|)"})(??{$nested_tags})$#, "bla blubb undef", "a b undef" ], - [ 1, qr#^(??{"(?:|)"})$nested_tags$#, "bla blubb bla", "a b a" ], - [ 1, qr#^((??{"(?:bla|)"}))((??{$nested_tags}))$#, "bla blubb ", "a b " ], - [ 1, qr#^((??{"(?!)?"}))((??{$nested_tags}))$#, "bla blubb ", "a b " ], - [ 1, qr#^((??{"(?:|<(/?bla)>)"}))((??{$nested_tags}))\1$#, "bla blubb ", "a b " ], - [ 0, qr#^((??{"(?!)"}))?((??{$nested_tags}))(?!)$#, "bla blubb undef", "a b undef" ], - - ) { #"#silence vim highlighting - $c++; - @ctl_n = (); - @plus = (); - my $match = (("" =~ $test->[1]) ? 1 : 0); - push @ctl_n, (defined $^N ? $^N : "undef"); - push @plus, (defined $+ ? $+ : "undef"); - ok($test->[0] == $match, "match $c"); - if ($test->[0] != $match) { - # unset @ctl_n and @plus - @ctl_n = @plus = (); - } - is("@ctl_n", $test->[2], "ctl_n $c"); - is("@plus", $test->[3], "plus $c"); - } - } - - { - use re 'eval'; - - - our $f; - local $f; - $f = sub { - defined $_[0] ? $_[0] : "undef"; - }; - - like("123", qr/^(\d)(((??{1 + $^N})))+$/, 'Bug 56194'); - - our @ctl_n; - our @plus; - - my $re = qr#(1)((??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1}))*(?{$^N})#; - my $re2 = qr#(1)((??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1}))*(?{$^N})(|a(b)c|def)(??{"$^R"})#; - my $re3 = qr#(1)((??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1})){2}(?{$^N})(|a(b)c|def)(??{"$^R"})#; - our $re5; - local $re5 = qr#(1)((??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1})){2}(?{$^N})#; - my $re6 = qr#(??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1})#; - my $re7 = qr#(??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1})#; - my $re8 = qr/(\d+)/; - my $c = 0; - for my $test ( - # Test structure: - # [ - # String to match - # Regex too match - # Expected values of $^N - # Expected values of $+ - # Expected values of $1, $2, $3, $4 and $5 - # ] - [ - "1233", - qr#^(1)((??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1}))+(??{$^N})$#, - "1 2 3 3", - "1 2 3 3", - "\$1 = 1, \$2 = 3, \$3 = undef, \$4 = undef, \$5 = undef", - ], - [ - "1233", - qr#^(1)((??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1}))+(abc|def|)?(??{$+})$#, - "1 2 3 3", - "1 2 3 3", - "\$1 = 1, \$2 = 3, \$3 = undef, \$4 = undef, \$5 = undef", - ], - [ - "1233", - qr#^(1)((??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1}))+(|abc|def)?(??{$+})$#, - "1 2 3 3", - "1 2 3 3", - "\$1 = 1, \$2 = 3, \$3 = undef, \$4 = undef, \$5 = undef", - ], - [ - "1233", - qr#^(1)((??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1}))+(abc|def|)?(??{$^N})$#, - "1 2 3 3", - "1 2 3 3", - "\$1 = 1, \$2 = 3, \$3 = undef, \$4 = undef, \$5 = undef", - ], - [ - "1233", - qr#^(1)((??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1}))+(|abc|def)?(??{$^N})$#, - "1 2 3 3", - "1 2 3 3", - "\$1 = 1, \$2 = 3, \$3 = undef, \$4 = undef, \$5 = undef", - ], - [ - "123abc3", - qr#^($re)(|a(b)c|def)(??{$^R})$#, - "1 2 3 abc", - "1 2 3 b", - "\$1 = 123, \$2 = 1, \$3 = 3, \$4 = abc, \$5 = b", - ], - [ - "123abc3", - qr#^($re2)$#, - "1 2 3 123abc3", - "1 2 3 b", - "\$1 = 123abc3, \$2 = 1, \$3 = 3, \$4 = abc, \$5 = b", - ], - [ - "123abc3", - qr#^($re3)$#, - "1 2 123abc3", - "1 2 b", - "\$1 = 123abc3, \$2 = 1, \$3 = 3, \$4 = abc, \$5 = b", - ], - [ - "123abc3", - qr#^(??{$re5})(|abc|def)(??{"$^R"})$#, - "1 2 abc", - "1 2 abc", - "\$1 = abc, \$2 = undef, \$3 = undef, \$4 = undef, \$5 = undef", - ], - [ - "123abc3", - qr#^(??{$re5})(|a(b)c|def)(??{"$^R"})$#, - "1 2 abc", - "1 2 b", - "\$1 = abc, \$2 = b, \$3 = undef, \$4 = undef, \$5 = undef", - ], - [ - "1234", - qr#^((\d+)((??{push @ctl_n, $f->($^N); push @plus, $f->($+);$^N + 1}))((??{push @ctl_n, $f->($^N); push @plus, $f->($+);$^N + 1}))((??{push @ctl_n, $f->($^N); push @plus, $f->($+);$^N + 1})))$#, - "1234 123 12 1 2 3 1234", - "1234 123 12 1 2 3 4", - "\$1 = 1234, \$2 = 1, \$3 = 2, \$4 = 3, \$5 = 4", - ], - [ - "1234556", - qr#^(\d+)($re6)($re6)($re6)$re6(($re6)$re6)$#, - "1234556 123455 12345 1234 123 12 1 2 3 4 4 5 56", - "1234556 123455 12345 1234 123 12 1 2 3 4 4 5 5", - "\$1 = 1, \$2 = 2, \$3 = 3, \$4 = 4, \$5 = 56", - ], - [ - "12345562", - qr#^((??{$re8}))($re7)($re7)($re7)$re7($re7)($re7(\2))$#, - "12345562 1234556 123455 12345 1234 123 12 1 2 3 4 4 5 62", - "12345562 1234556 123455 12345 1234 123 12 1 2 3 4 4 5 2", - "\$1 = 1, \$2 = 2, \$3 = 3, \$4 = 4, \$5 = 5", - ], - ) { - $c++; - @ctl_n = (); - @plus = (); - undef $^R; - my $match = $test->[0] =~ $test->[1]; - my $str = join(", ", '$1 = '.$f->($1), '$2 = '.$f->($2), '$3 = '.$f->($3), '$4 = '.$f->($4),'$5 = '.$f->($5)); - push @ctl_n, $f->($^N); - push @plus, $f->($+); - ok($match, "match $c; Bug 56194"); - if (not $match) { - # unset $str, @ctl_n and @plus - $str = ""; - @ctl_n = @plus = (); - } - is("@ctl_n", $test->[2], "ctl_n $c; Bug 56194"); - is("@plus", $test->[3], "plus $c; Bug 56194"); - is($str, $test->[4], "str $c; Bug 56194"); - } - SKIP: { - if ($] le '5.010') { - skip "test segfaults on perl < 5.10", 4; - } - - @ctl_n = (); - @plus = (); - - our $re4; - local $re4 = qr#(1)((??{push @ctl_n, $f->($^N); push @plus, $f->($+);$^N + 1})){2}(?{$^N})(|abc|def)(??{"$^R"})#; - undef $^R; - my $match = "123abc3" =~ m/^(??{$re4})$/; - my $str = join(", ", '$1 = '.$f->($1), '$2 = '.$f->($2), '$3 = '.$f->($3), '$4 = '.$f->($4),'$5 = '.$f->($5),'$^R = '.$f->($^R)); - push @ctl_n, $f->($^N); - push @plus, $f->($+); - ok($match, 'Bug 56194'); - if (not $match) { - # unset $str - @ctl_n = (); - @plus = (); - $str = ""; - } - is("@ctl_n", "1 2 undef", 'Bug 56194'); - is("@plus", "1 2 undef", 'Bug 56194'); - is($str, - "\$1 = undef, \$2 = undef, \$3 = undef, \$4 = undef, \$5 = undef, \$^R = undef", - 'Bug 56194'); - } - } - -} # End of sub run_tests - -1; diff --git a/t/CORE/re/pat_rt_report.t b/t/CORE/re/pat_rt_report.t deleted file mode 100644 index 675606ad9..000000000 --- a/t/CORE/re/pat_rt_report.t +++ /dev/null @@ -1,1145 +0,0 @@ -#!./perl -# -# This is a home for regular expression tests that don't fit into -# the format supported by re/regexp.t. If you want to add a test -# that does fit that format, add it to re/re_tests, not here. - -use strict; -use warnings; -use 5.010; -use Config; - -sub run_tests; - -$| = 1; - - -BEGIN { - require q(t/CORE/test.pl); -} - - -plan tests => 2521; # Update this when adding/deleting tests. - -run_tests() unless caller; - -# -# Tests start here. -# -sub run_tests { - - like("A \x{263a} B z C", qr/A . B (??{ "z" }) C/, - "Match UTF-8 char in presence of (??{ }); Bug 20000731.001"); - - { - no warnings 'uninitialized'; - ok(undef =~ /^([^\/]*)(.*)$/, "Used to cause a SEGV; Bug 20001021.005"); - } - - { - my $message = 'bug id 20001008.001'; - - my @x = ("stra\337e 138", "stra\337e 138"); - for (@x) { - ok(s/(\d+)\s*([\w\-]+)/$1 . uc $2/e, $message); - ok(my ($latin) = /^(.+)(?:\s+\d)/, $message); - is($latin, "stra\337e", $message); - ok($latin =~ s/stra\337e/straße/, $message); - # - # Previous code follows, but outcommented - there were no tests. - # - # $latin =~ s/stra\337e/straße/; # \303\237 after the 2nd a - # use utf8; # needed for the raw UTF-8 - # $latin =~ s!(s)tr(?:aß|s+e)!$1tr.!; # \303\237 after the a - } - } - - { - # Fist half of the bug. - my $message = 'HEBREW ACCENT QADMA matched by .*; Bug 20001028.003'; - my $X = chr (1448); - ok(my ($Y) = $X =~ /(.*)/, $message); - is($Y, v1448, $message); - is(length $Y, 1, $message); - - # Second half of the bug. - $message = 'HEBREW ACCENT QADMA in replacement; Bug 20001028.003'; - $X = ''; - $X =~ s/^/chr(1488)/e; - is(length $X, 1, $message); - is(ord $X, 1488, $message); - } - - { - my $message = 'Repeated s///; Bug 20001108.001'; - my $X = "Szab\x{f3},Bal\x{e1}zs"; - my $Y = $X; - $Y =~ s/(B)/$1/ for 0 .. 3; - is($Y, $X, $message); - is($X, "Szab\x{f3},Bal\x{e1}zs", $message); - } - - { - my $message = 's/// on UTF-8 string; Bug 20000517.001'; - my $x = "\x{100}A"; - $x =~ s/A/B/; - is($x, "\x{100}B", $message); - is(length $x, 2, $message); - } - - { - my $message = '\C and É; Bug 20001230.002'; - ok("École" =~ /^\C\C(.)/ && $1 eq 'c', $message); - like("École", qr/^\C\C(c)/, $message); - } - - { - # The original bug report had 'no utf8' here but that was irrelevant. - - my $message = "Don't dump core; Bug 20010306.008"; - my $a = "a\x{1234}"; - like($a, qr/\w/, $message); # used to core dump. - } - - { - my $message = '/g in scalar context; Bug 20010410.006'; - for my $rx ('/(.*?)\{(.*?)\}/csg', - '/(.*?)\{(.*?)\}/cg', - '/(.*?)\{(.*?)\}/sg', - '/(.*?)\{(.*?)\}/g', - '/(.+?)\{(.+?)\}/csg',) { - my $i = 0; - my $input = "a{b}c{d}"; - eval <<" --"; - while (eval \$input =~ $rx) { - \$i ++; - } - -- - is($i, 2, $message); - } - } - - { - # Amazingly vertical tabulator is the same in ASCII and EBCDIC. - for ("\n", "\t", "\014", "\r") { - unlike($_, qr/[[:print:]]/, sprintf "\\%03o not in [[:print:]]; Bug 20010619.003", ord $_); - } - for (" ") { - like($_, qr/[[:print:]]/, "'$_' in [[:print:]]; Bug 20010619.003"); - } - } - - { - # [ID 20010814.004] pos() doesn't work when using =~m// in list context - - $_ = "ababacadaea"; - my $a = join ":", /b./gc; - my $b = join ":", /a./gc; - my $c = pos; - is("$a $b $c", 'ba:ba ad:ae 10', "pos() works with () = m//; Bug 20010814.004"); - } - - { - # [ID 20010407.006] matching utf8 return values from - # functions does not work - - my $message = 'UTF-8 return values from functions; Bug 20010407.006'; - package ID_20010407_006; - sub x {"a\x{1234}"} - my $x = x; - my $y; - ::ok($x =~ /(..)/, $message); - $y = $1; - ::ok(length ($y) == 2 && $y eq $x, $message); - ::ok(x =~ /(..)/, $message); - $y = $1; - ::ok(length ($y) == 2 && $y eq $x, $message); - } - - { - # High bit bug -- japhy - my $x = "ab\200d"; - ok $x =~ /.*?\200/, "High bit fine"; - } - - { - my $message = 'UTF-8 hash keys and /$/'; - # http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters - # /2002-01/msg01327.html - - my $u = "a\x{100}"; - my $v = substr ($u, 0, 1); - my $w = substr ($u, 1, 1); - my %u = ($u => $u, $v => $v, $w => $w); - for (keys %u) { - my $m1 = /^\w*$/ ? 1 : 0; - my $m2 = $u {$_} =~ /^\w*$/ ? 1 : 0; - is($m1, $m2, $message); - } - } - - { - my $message = "s///eg [change 13f46d054db22cf4]; Bug 20020124.005"; - - for my $char ("a", "\x{df}", "\x{100}") { - my $x = "$char b $char"; - $x =~ s{($char)}{ - "c" =~ /c/; - "x"; - }ge; - is(substr ($x, 0, 1), substr ($x, -1, 1), $message); - } - } - - { - my $message = "Correct pmop flags checked when empty pattern; Bug 20020412.005"; - - # Requires reuse of last successful pattern. - my $num = 123; - $num =~ /\d/; - for (0 .. 1) { - my $match = m?? + 0; - ok($match != $_, $message) - or diag(sprintf "'match one' %s on %s iteration" => - $match ? 'succeeded' : 'failed', - $_ ? 'second' : 'first'); - } - $num =~ /(\d)/; - my $result = join "" => $num =~ //g; - is($result, $num, $message); - } - - { - my $message = 'UTF-8 regex matches above 32k; Bug 20020630.002'; - for (['byte', "\x{ff}"], ['utf8', "\x{1ff}"]) { - my ($type, $char) = @$_; - for my $len (32000, 32768, 33000) { - my $s = $char . "f" x $len; - my $r = $s =~ /$char([f]*)/gc; - ok($r, $message) or diag("<$type x $len>"); - ok(!$r || pos ($s) == $len + 1, $message) - or diag("<$type x $len>; pos = @{[pos $s]}"); - } - } - } - - { - my $s = "\x{100}" x 5; - my $ok = $s =~ /(\x{100}{4})/; - my ($ord, $len) = (ord $1, length $1); - ok $ok && $ord == 0x100 && $len == 4, "No panic: end_shift [change 0e933229fa758625]"; - } - - { - our $a = "x\x{100}"; - chop $a; # Leaves the UTF-8 flag - $a .= "y"; # 1 byte before 'y'. - - like($a, qr/^\C/, 'match one \C on 1-byte UTF-8; Bug 15763'); - like($a, qr/^\C{1}/, 'match \C{1}; Bug 15763'); - - like($a, qr/^\Cy/, 'match \Cy; Bug 15763'); - like($a, qr/^\C{1}y/, 'match \C{1}y; Bug 15763'); - - unlike($a, qr/^\C\Cy/, q {don't match two \Cy; Bug 15763}); - unlike($a, qr/^\C{2}y/, q {don't match \C{2}y; Bug 15763}); - - $a = "\x{100}y"; # 2 bytes before "y" - - like($a, qr/^\C/, 'match one \C on 2-byte UTF-8; Bug 15763'); - like($a, qr/^\C{1}/, 'match \C{1}; Bug 15763'); - like($a, qr/^\C\C/, 'match two \C; Bug 15763'); - like($a, qr/^\C{2}/, 'match \C{2}; Bug 15763'); - - like($a, qr/^\C\C\C/, 'match three \C on 2-byte UTF-8 and a byte; Bug 15763'); - like($a, qr/^\C{3}/, 'match \C{3}; Bug 15763'); - - like($a, qr/^\C\Cy/, 'match two \C; Bug 15763'); - like($a, qr/^\C{2}y/, 'match \C{2}; Bug 15763'); - - unlike($a, qr/^\C\C\Cy/, q {don't match three \Cy; Bug 15763}); - unlike($a, qr/^\C{2}\Cy/, q {don't match \C{2}\Cy; Bug 15763}); - unlike($a, qr/^\C{3}y/, q {don't match \C{3}y; Bug 15763}); - - $a = "\x{1000}y"; # 3 bytes before "y" - - like($a, qr/^\C/, 'match one \C on three-byte UTF-8; Bug 15763'); - like($a, qr/^\C{1}/, 'match \C{1}; Bug 15763'); - like($a, qr/^\C\C/, 'match two \C; Bug 15763'); - like($a, qr/^\C{2}/, 'match \C{2}; Bug 15763'); - like($a, qr/^\C\C\C/, 'match three \C; Bug 15763'); - like($a, qr/^\C{3}/, 'match \C{3}; Bug 15763'); - - like($a, qr/^\C\C\C\C/, 'match four \C on three-byte UTF-8 and a byte; Bug 15763'); - like($a, qr/^\C{4}/, 'match \C{4}; Bug 15763'); - - like($a, qr/^\C\C\Cy/, 'match three \Cy; Bug 15763'); - like($a, qr/^\C{3}y/, 'match \C{3}y; Bug 15763'); - - unlike($a, qr/^\C\C\C\Cy/, q {don't match four \Cy; Bug 15763}); - unlike($a, qr/^\C{4}y/, q {don't match \C{4}y; Bug 15763}); - } - - - { - my $message = 'UTF-8 matching; Bug 15397'; - like("\x{100}", qr/\x{100}/, $message); - like("\x{100}", qr/(\x{100})/, $message); - like("\x{100}", qr/(\x{100}){1}/, $message); - like("\x{100}\x{100}", qr/(\x{100}){2}/, $message); - like("\x{100}\x{100}", qr/(\x{100})(\x{100})/, $message); - } - - { - my $message = 'Neither ()* nor ()*? sets $1 when matched 0 times; Bug 7471'; - local $_ = 'CD'; - ok(/(AB)*?CD/ && !defined $1, $message); - ok(/(AB)*CD/ && !defined $1, $message); - } - - { - my $message = "Caching shouldn't prevent match; Bug 3547"; - my $pattern = "^(b+?|a){1,2}c"; - ok("bac" =~ /$pattern/ && $1 eq 'a', $message); - ok("bbac" =~ /$pattern/ && $1 eq 'a', $message); - ok("bbbac" =~ /$pattern/ && $1 eq 'a', $message); - ok("bbbbac" =~ /$pattern/ && $1 eq 'a', $message); - } - - { - ok("\x{100}" =~ /(.)/, '$1 should keep UTF-8 ness; Bug 18232'); - is($1, "\x{100}", '$1 is UTF-8; Bug 18232'); - { 'a' =~ /./; } - is($1, "\x{100}", '$1 is still UTF-8; Bug 18232'); - isnt($1, "\xC4\x80", '$1 is not non-UTF-8; Bug 18232'); - } - - { - my $message = "Optimizer doesn't prematurely reject match; Bug 19767"; - use utf8; - - my $attr = 'Name-1'; - my $NormalChar = qr /[\p{IsDigit}\p{IsLower}\p{IsUpper}]/; - my $NormalWord = qr /${NormalChar}+?/; - my $PredNameHyphen = qr /^${NormalWord}(\-${NormalWord})*?$/; - - $attr =~ /^$/; - like($attr, $PredNameHyphen, $message); # Original test. - - "a" =~ m/[b]/; - like("0", qr/\p{N}+\z/, $message); # Variant. - } - - { - my $message = "(??{ }) doesn't return stale values; Bug 20683"; - our $p = 1; - foreach (1, 2, 3, 4) { - $p ++ if /(??{ $p })/ - } - is($p, 5, $message); - - { - package P; - $a = 1; - sub TIESCALAR {bless []} - sub FETCH {$a ++} - } - tie $p, "P"; - foreach (1, 2, 3, 4) { - /(??{ $p })/ - } - is($p, 5, $message); - } - - { - # Subject: Odd regexp behavior - # From: Markus Kuhn - # Date: Wed, 26 Feb 2003 16:53:12 +0000 - # Message-Id: - # To: perl-unicode@perl.org - - my $message = 'Markus Kuhn 2003-02-26'; - - my $x = "\x{2019}\nk"; - ok($x =~ s/(\S)\n(\S)/$1 $2/sg, $message); - is($x, "\x{2019} k", $message); - - $x = "b\nk"; - ok($x =~ s/(\S)\n(\S)/$1 $2/sg, $message); - is($x, "b k", $message); - - like("\x{2019}", qr/\S/, $message); - } - - { - my $message = "(??{ .. }) in split doesn't corrupt its stack; Bug 21411"; - our $i; - is('-1-3-5-', join('', split /((??{$i++}))/, '-1-3-5-'), $message); - no warnings 'syntax'; - @_ = split /(?{'WOW'})/, 'abc'; - local $" = "|"; - is("@_", "a|b|c", $message); - } - - { - # XXX DAPM 13-Apr-06. Recursive split is still broken. It's only luck it - # hasn't been crashing. Disable this test until it is fixed properly. - # XXX also check what it returns rather than just doing ok(1,...) - # split /(?{ split "" })/, "abc"; - local $::TODO = "Recursive split is still broken"; - ok 0, 'cache_re & "(?{": it dumps core in 5.6.1 & 5.8.0'; - } - - { - $_ = "code: 'x' { '...' }\n"; study; - my @x; push @x, $& while m/'[^\']*'/gx; - local $" = ":"; - is("@x", "'x':'...'", "Parse::RecDescent triggered infinite loop; Bug 17757"); - } - - { - sub func ($) { - ok("a\nb" !~ /^b/, "Propagated modifier; $_[0]; Bug 22354"); - ok("a\nb" =~ /^b/m, "Propagated modifier; $_[0] - with /m; Bug 22354"); - } - func "standalone"; - $_ = "x"; s/x/func "in subst"/e; - $_ = "x"; s/x/func "in multiline subst"/em; - $_ = "x"; /x(?{func "in regexp"})/; - SKIP: { - if (is_perlcc_compiled()) { - skip "re-eval func() miscompiled via perlcc", 2; - } else { - $_ = "x"; /x(?{func "in multiline regexp"})/m; - } - } - } - - { - $_ = "abcdef\n"; - my @x = m/./g; - is("abcde", $`, 'Global match sets $`; Bug 19049'); - } - - { - # [perl #23769] Unicode regex broken on simple example - # regrepeat() didn't handle UTF-8 EXACT case right. - - my $Mess = 'regrepeat() handles UTF-8 EXACT case right'; - my $message = "$Mess; Bug 23769"; - - my $s = "\x{a0}\x{a0}\x{a0}\x{100}"; chop $s; - - like($s, qr/\x{a0}/, $message); - like($s, qr/\x{a0}+/, $message); - like($s, qr/\x{a0}\x{a0}/, $message); - - $message = "$Mess (easy variant); Bug 23769"; - ok("aaa\x{100}" =~ /(a+)/, $message); - is($1, "aaa", $message); - - $message = "$Mess (easy invariant); Bug 23769"; - ok("aaa\x{100} " =~ /(a+?)/, $message); - is($1, "a", $message); - - $message = "$Mess (regrepeat variant); Bug 23769"; - ok("\xa0\xa0\xa0\x{100} " =~ /(\xa0+?)/, $message); - is($1, "\xa0", $message); - - $message = "$Mess (regrepeat invariant); Bug 23769"; - ok("\xa0\xa0\xa0\x{100}" =~ /(\xa0+)/, $message); - is($1, "\xa0\xa0\xa0", $message); - - $message = "$Mess (hard variant); Bug 23769"; - ok("\xa0\xa1\xa0\xa1\xa0\xa1\x{100}" =~ /((?:\xa0\xa1)+?)/, $message); - is($1, "\xa0\xa1", $message); - - $message = "$Mess (hard invariant); Bug 23769"; - ok("ababab\x{100} " =~ /((?:ab)+)/, $message); - is($1, 'ababab', $message); - - ok("\xa0\xa1\xa0\xa1\xa0\xa1\x{100}" =~ /((?:\xa0\xa1)+)/, $message); - is($1, "\xa0\xa1\xa0\xa1\xa0\xa1", $message); - - ok("ababab\x{100} " =~ /((?:ab)+?)/, $message); - is($1, "ab", $message); - - $message = "Don't match first byte of UTF-8 representation; Bug 23769"; - unlike("\xc4\xc4\xc4", qr/(\x{100}+)/, $message); - unlike("\xc4\xc4\xc4", qr/(\x{100}+?)/, $message); - unlike("\xc4\xc4\xc4", qr/(\x{100}++)/, $message); - } - - { - # perl panic: pp_match start/end pointers - - is(eval {my ($x, $y) = "bca" =~ /^(?=.*(a)).*(bc)/; "$x-$y"}, "a-bc", - 'Captures can move backwards in string; Bug 25269'); - } - - { - # \cA not recognized in character classes - like("a\cAb", qr/\cA/, '\cA in pattern; Bug 27940'); - like("a\cAb", qr/[\cA]/, '\cA in character class; Bug 27940'); - like("a\cAb", qr/[\cA-\cB]/, '\cA in character class range; Bug 27940'); - like("abc", qr/[^\cA-\cB]/, '\cA in negated character class range; Bug 27940'); - like("a\cBb", qr/[\cA-\cC]/, '\cB in character class range; Bug 27940'); - like("a\cCbc", qr/[^\cA-\cB]/, '\cC in negated character class range; Bug 27940'); - like("a\cAb", qr/(??{"\cA"})/, '\cA in ??{} pattern; Bug 27940'); - unlike("ab", qr/a\cIb/x, '\cI in pattern; Bug 27940'); - } - - { - # perl #28532: optional zero-width match at end of string is ignored - - ok("abc" =~ /^abc(\z)?/ && defined($1), - 'Optional zero-width match at end of string; Bug 28532'); - ok("abc" =~ /^abc(\z)??/ && !defined($1), - 'Optional zero-width match at end of string; Bug 28532'); - } - - { - my $utf8 = "\xe9\x{100}"; chop $utf8; - my $latin1 = "\xe9"; - - like($utf8, qr/\xe9/i, "utf8/latin; Bug 36207"); - like($utf8, qr/$latin1/i, "utf8/latin runtime; Bug 36207"); - like($utf8, qr/(abc|\xe9)/i, "utf8/latin trie; Bug 36207"); - like($utf8, qr/(abc|$latin1)/i, "utf8/latin trie runtime; Bug 36207"); - - like("\xe9", qr/$utf8/i, "latin/utf8; Bug 36207"); - like("\xe9", qr/(abc|$utf8)/i, "latin/utf8 trie; Bug 36207"); - like($latin1, qr/$utf8/i, "latin/utf8 runtime; Bug 36207"); - like($latin1, qr/(abc|$utf8)/i, "latin/utf8 trie runtime; Bug 36207"); - } - - { - my $s = "abcd"; - $s =~ /(..)(..)/g; - $s = $1; - $s = $2; - is($2, 'cd', - "Assigning to original string does not corrupt match vars; Bug 37038"); - } - - { - { - package wooosh; - sub gloople {"!"} - } - my $aeek = bless {} => 'wooosh'; - is(do {$aeek -> gloople () =~ /(.)/g}, 1, - "//g match against return value of sub [change e26a497577f3ce7b]"); - - sub gloople {"!"} - is(do{gloople () =~ /(.)/g}, 1, - "change e26a497577f3ce7b didn't affect sub calls for some reason"); - } - - { - local $::TODO = "See changes 26925-26928, which reverted change 26410"; - { - package lv; - our $var = "abc"; - sub variable : lvalue {$var} - } - my $o = bless [] => 'lv'; - my $f = ""; - my $r = eval { - for (1 .. 2) { - $f .= $1 if $o -> variable =~ /(.)/g; - } - 1; - }; - if ($r) { - is($f, "ab", "pos() retained between calls"); - } - else { - local $::TODO; - ok 0, "Code failed: $@"; - } - - our $var = "abc"; - sub variable : lvalue {$var} - my $g = ""; - my $s = eval { - for (1 .. 2) { - $g .= $1 if variable =~ /(.)/g; - } - 1; - }; - if ($s) { - is($g, "ab", "pos() retained between calls"); - } - else { - local $::TODO; - ok 0, "Code failed: $@"; - } - } - - SKIP: - { - skip "In EBCDIC" if $::IS_EBCDIC; - no warnings 'utf8'; - $_ = pack 'U0C2', 0xa2, 0xf8; # Ill-formed UTF-8 - my $ret = 0; - is(do {!($ret = s/[\0]+//g)}, 1, - "Ill-formed UTF-8 doesn't match NUL in class; Bug 37836"); - } - - { - # chr(65535) should be allowed in regexes - - no warnings 'utf8'; # To allow non-characters - my ($c, $r, $s); - - $c = chr 0xffff; - $c =~ s/$c//g; - is($c, "", "U+FFFF, parsed as atom; Bug 38293"); - - $c = chr 0xffff; - $r = "\\$c"; - $c =~ s/$r//g; - is($c, "", "U+FFFF backslashed, parsed as atom; Bug 38293"); - - $c = chr 0xffff; - $c =~ s/[$c]//g; - is($c, "", "U+FFFF, parsed in class; Bug 38293"); - - $c = chr 0xffff; - $r = "[\\$c]"; - $c =~ s/$r//g; - is($c, "", "U+FFFF backslashed, parsed in class; Bug 38293"); - - $s = "A\x{ffff}B"; - $s =~ s/\x{ffff}//i; - is($s, "AB", "U+FFFF, EXACTF; Bug 38293"); - - $s = "\x{ffff}A"; - $s =~ s/\bA//; - is($s, "\x{ffff}", "U+FFFF, BOUND; Bug 38293"); - - $s = "\x{ffff}!"; - $s =~ s/\B!//; - is($s, "\x{ffff}", "U+FFFF, NBOUND; Bug 38293"); - } - - { - - # The printing characters - my @chars = ("A" .. "Z"); - my $delim = ","; - my $size = 32771 - 4; - my $str = ''; - - # Create some random junk. Inefficient, but it works. - for (my $i = 0; $i < $size; $ i++) { - $str .= $chars [rand @chars]; - } - - $str .= ($delim x 4); - my $res; - my $matched; - ok($str =~ s/^(.*?)${delim}{4}//s, "Pattern matches; Bug 39583"); - is($str, "", "Empty string; Bug 39583"); - ok(defined $1 && length ($1) == $size, '$1 is correct size; Bug 39583'); - } - - { - like("\0-A", qr/\c@-A/, '@- should not be interpolated in a pattern; Bug 27940'); - like("\0\0A", qr/\c@+A/, '@+ should not be interpolated in a pattern; Bug 27940'); - like("X\@-A", qr/X@-A/, '@- should not be interpolated in a pattern; Bug 27940'); - like("X\@\@A", qr/X@+A/, '@+ should not be interpolated in a pattern; Bug 27940'); - - like("X\0A", qr/X\c@?A/, '\c@?; Bug 27940'); - like("X\0A", qr/X\c@*A/, '\c@*; Bug 27940'); - like("X\0A", qr/X\c@(A)/, '\c@(; Bug 27940'); - like("X\0A", qr/X(\c@)A/, '\c@); Bug 27940'); - like("X\0A", qr/X\c@|ZA/, '\c@|; Bug 27940'); - - like("X\@A", qr/X@?A/, '@?; Bug 27940'); - like("X\@A", qr/X@*A/, '@*; Bug 27940'); - like("X\@A", qr/X@(A)/, '@(; Bug 27940'); - like("X\@A", qr/X(@)A/, '@); Bug 27940'); - like("X\@A", qr/X@|ZA/, '@|; Bug 27940'); - - local $" = ','; # non-whitespace and non-RE-specific - like('abc', qr/(.)(.)(.)/, 'The last successful match is bogus; Bug 27940'); - like("A@+B", qr/A@{+}B/, 'Interpolation of @+ in /@{+}/; Bug 27940'); - like("A@-B", qr/A@{-}B/, 'Interpolation of @- in /@{-}/; Bug 27940'); - like("A@+B", qr/A@{+}B/x, 'Interpolation of @+ in /@{+}/x; Bug 27940'); - like("A@-B", qr/A@{-}B/x, 'Interpolation of @- in /@{-}/x; Bug 27940'); - } - - { - my $s = 'foo bar baz'; - my (@k, @v, @fetch, $res); - my $count = 0; - my @names = qw ($+{A} $+{B} $+{C}); - if ($s =~ /(?foo)\s+(?bar)?\s+(?baz)/) { - while (my ($k, $v) = each (%+)) { - $count++; - } - @k = sort keys (%+); - @v = sort values (%+); - $res = 1; - push @fetch, - ["$+{A}", "$1"], - ["$+{B}", "$2"], - ["$+{C}", "$3"], - ; - } - foreach (0 .. 2) { - if ($fetch [$_]) { - is($fetch[$_][0], $fetch[$_][1], "$names[$_]; Bug 50496"); - } else { - ok 0, $names[$_]; - } - } - is($res, 1, "'$s' =~ /(?foo)\\s+(?bar)?\\s+(?baz)/; Bug 50496"); - is($count, 3, "Got 3 keys in %+ via each; Bug 50496"); - is(0 + @k, 3, "Got 3 keys in %+ via keys; Bug 50496"); - is("@k", "A B C", "Got expected keys; Bug 50496"); - is("@v", "bar baz foo", "Got expected values; Bug 50496"); - eval ' - no warnings "uninitialized"; - print for $+ {this_key_doesnt_exist}; - '; - is($@, '', 'lvalue $+ {...} should not throw an exception; Bug 50496'); - } - - { - # - # Almost the same as the block above, except that the capture is nested. - # - - my $s = 'foo bar baz'; - my (@k, @v, @fetch, $res); - my $count = 0; - my @names = qw ($+{A} $+{B} $+{C} $+{D}); - if ($s =~ /(?(?foo)\s+(?bar)?\s+(?baz))/) { - while (my ($k,$v) = each(%+)) { - $count++; - } - @k = sort keys (%+); - @v = sort values (%+); - $res = 1; - push @fetch, - ["$+{A}", "$2"], - ["$+{B}", "$3"], - ["$+{C}", "$4"], - ["$+{D}", "$1"], - ; - } - foreach (0 .. 3) { - if ($fetch [$_]) { - is($fetch[$_][0], $fetch[$_][1], "$names[$_]; Bug 50496"); - } else { - ok 0, $names [$_]; - } - } - is($res, 1, "'$s' =~ /(?(?foo)\\s+(?bar)?\\s+(?baz))/; Bug 50496"); - is($count, 4, "Got 4 keys in %+ via each; Bug 50496"); - is(@k, 4, "Got 4 keys in %+ via keys; Bug 50496"); - is("@k", "A B C D", "Got expected keys; Bug 50496"); - is("@v", "bar baz foo foo bar baz", "Got expected values; Bug 50496"); - eval ' - no warnings "uninitialized"; - print for $+ {this_key_doesnt_exist}; - '; - is($@, '', 'lvalue $+ {...} should not throw an exception; Bug 50496'); - } - - { - my $str = 'abc'; - my $count = 0; - my $mval = 0; - my $pval = 0; - while ($str =~ /b/g) {$mval = $#-; $pval = $#+; $count ++} - is($mval, 0, '@- should be empty; Bug 36046'); - is($pval, 0, '@+ should be empty; Bug 36046'); - is($count, 1, 'Should have matched once only; Bug 36046'); - } - - { - my $message = '/m in precompiled regexp; Bug 40684'; - my $s = "abc\ndef"; - my $rex = qr'^abc$'m; - ok($s =~ m/$rex/, $message); - ok($s =~ m/^abc$/m, $message); - } - - { - my $message = '(?: ... )? should not lose $^R; Bug 36909'; - $^R = 'Nothing'; - { - local $^R = "Bad"; - ok('x foofoo y' =~ m { - (foo) # $^R correctly set - (?{ "last regexp code result" }) - }x, $message); - is($^R, 'last regexp code result', $message); - } - is($^R, 'Nothing', $message); - - { - local $^R = "Bad"; - - ok('x foofoo y' =~ m { - (?:foo|bar)+ # $^R correctly set - (?{ "last regexp code result" }) - }x, $message); - is($^R, 'last regexp code result', $message); - } - is($^R, 'Nothing', $message); - - { - local $^R = "Bad"; - ok('x foofoo y' =~ m { - (foo|bar)\1+ # $^R undefined - (?{ "last regexp code result" }) - }x, $message); - is($^R, 'last regexp code result', $message); - } - is($^R, 'Nothing', $message); - - { - local $^R = "Bad"; - ok('x foofoo y' =~ m { - (foo|bar)\1 # This time without the + - (?{"last regexp code result"}) - }x, $message); - is($^R, 'last regexp code result', $message); - } - is($^R, 'Nothing', $message); - } - - { - my $message = 'Match is linear, not quadratic; Bug 22395'; - our $count; - for my $l (10, 100, 1000) { - $count = 0; - ('a' x $l) =~ /(.*)(?{$count++})[bc]/; - local $::TODO = "Should be L+1 not L*(L+3)/2 (L=$l)"; - is($count, $l + 1, $message); - } - } - - { - my $message = '@-/@+ should not have undefined values; Bug 22614'; - local $_ = 'ab'; - our @len = (); - /(.){1,}(?{push @len,0+@-})(.){1,}(?{})^/; - is("@len", "2 2 2", $message); - } - - { - my $message = '$& set on s///; Bug 18209'; - my $text = ' word1 word2 word3 word4 word5 word6 '; - - my @words = ('word1', 'word3', 'word5'); - my $count; - foreach my $word (@words) { - $text =~ s/$word\s//gi; # Leave a space to separate words - # in the resultant str. - # The following block is not working. - if ($&) { - $count ++; - } - # End bad block - } - is($count, 3, $message); - is($text, ' word2 word4 word6 ', $message); - } - - { - # RT#6893 - - local $_ = qq (A\nB\nC\n); - my @res; - while (m#(\G|\n)([^\n]*)\n#gsx) { - push @res, "$2"; - last if @res > 3; - } - is("@res", "A B C", "/g pattern shouldn't infinite loop; Bug 6893"); - } - - { - # No optimizer bug - my @tails = ('', '(?(1))', '(|)', '()?'); - my @quants = ('*','+'); - my $doit = sub { - my $pats = shift; - for (@_) { - for my $pat (@$pats) { - for my $quant (@quants) { - for my $tail (@tails) { - my $re = "($pat$quant\$)$tail"; - ok(/$re/ && $1 eq $_, "'$_' =~ /$re/; Bug 41010"); - ok(/$re/m && $1 eq $_, "'$_' =~ /$re/m; Bug 41010"); - } - } - } - } - }; - - my @dpats = ('\d', - '[1234567890]', - '(1|[23]|4|[56]|[78]|[90])', - '(?:1|[23]|4|[56]|[78]|[90])', - '(1|2|3|4|5|6|7|8|9|0)', - '(?:1|2|3|4|5|6|7|8|9|0)'); - my @spats = ('[ ]', ' ', '( |\t)', '(?: |\t)', '[ \t]', '\s'); - my @sstrs = (' '); - my @dstrs = ('12345'); - $doit -> (\@spats, @sstrs); - $doit -> (\@dpats, @dstrs); - } - - { - # [perl #45605] Regexp failure with utf8-flagged and byte-flagged string - - my $utf_8 = "\xd6schel"; - utf8::upgrade ($utf_8); - $utf_8 =~ m {(\xd6|Ö)schel}; - is($1, "\xd6", "Upgrade error; Bug 45605"); - } - - { - # Regardless of utf8ness any character matches itself when - # doing a case insensitive match. See also [perl #36207] - - for my $o (0 .. 255) { - my @ch = (chr ($o), chr ($o)); - utf8::upgrade ($ch [1]); - for my $u_str (0, 1) { - for my $u_pat (0, 1) { - like($ch[$u_str], qr/\Q$ch[$u_pat]\E/i, - "\$c =~ /\$c/i : chr ($o) : u_str = $u_str u_pat = $u_pat; Bug 36207"); - like($ch[$u_str], qr/\Q$ch[$u_pat]\E|xyz/i, - "\$c=~/\$c|xyz/i : chr($o) : u_str = $u_str u_pat = $u_pat; Bug 36207"); - } - } - } - } - - { - my $message = '$REGMARK in replacement; Bug 49190'; - our $REGMARK; - my $_ = "A"; - ok(s/(*:B)A/$REGMARK/, $message); - is($_, "B", $message); - $_ = "CCCCBAA"; - ok(s/(*:X)A+|(*:Y)B+|(*:Z)C+/$REGMARK/g, $message); - is($_, "ZYX", $message); - } - - { - my $message = 'Substitution evaluation in list context; Bug 52658'; - my $reg = '../xxx/'; - my @te = ($reg =~ m{^(/?(?:\.\./)*)}, - $reg =~ s/(x)/'b'/eg > 1 ? '##' : '++'); - is($reg, '../bbb/', $message); - is($te [0], '../', $message); - } - - { - my $a = "xyzt" x 8192; - like($a, qr/\A(?>[a-z])*\z/, - '(?>) does not cause wrongness on long string; Bug 60034'); - my $b = $a . chr 256; - chop $b; - is($a, $b, 'Bug 60034'); - like($b, qr/\A(?>[a-z])*\z/, - '(?>) does not cause wrongness on long string with UTF-8; Bug 60034'); - } - - # - # Keep the following tests last -- they may crash perl - # - print "# Tests that follow may crash perl\n"; - { - - my $message = 'Pattern in a loop, failure should not ' . - 'affect previous success; Bug 19049/38869'; - my @list = ( - 'ab cdef', # Matches regex - ('e' x 40000 ) .'ab c' # Matches not, but 'ab c' matches part of it - ); - my $y; - my $x; - foreach (@list) { - m/ab(.+)cd/i; # The ignore-case seems to be important - $y = $1; # Use $1, which might not be from the last match! - $x = substr ($list [0], $- [0], $+ [0] - $- [0]); - } - is($y, ' ', $message); - is($x, 'ab cd', $message); - } - - { - ok (("a" x (2 ** 15 - 10)) =~ /^()(a|bb)*$/, "Recursive stack cracker; Bug 24274"); - ok ((q(a)x 100) =~ /^(??{'(.)'x 100})/, - "Regexp /^(??{'(.)'x 100})/ crashes older perls; Bug 24274"); - } - - { - # [perl #45337] utf8 + "[a]a{2}" + /$.../ = panic: sv_len_utf8 cache - - local ${^UTF8CACHE} = -1; - my $message = "Shouldn't panic; Bug 45337"; - my $s = "[a]a{2}"; - utf8::upgrade $s; - like("aaa", qr/$s/, $message); - } - { - my $message = "Check if tree logic breaks \$^R; Bug 57042"; - my $cond_re = qr/\s* - \s* (?: - \( \s* A (?{1}) - | \( \s* B (?{2}) - ) - /x; - my @res; - for my $line ("(A)","(B)") { - if ($line =~ m/$cond_re/) { - push @res, $^R ? "#$^R" : "UNDEF"; - } - } - is("@res","#1 #2", $message); - } - { - no warnings 'closure'; - local $::TODO = "pmop 0x0 inside re-eval not found, issue #274" if is_perlcc_compiled(); - my $re = qr/A(??{"1"})/; - ok "A1B" =~ m/^((??{ $re }))((??{"B"}))$/; - ok $1 eq "A1"; - ok $2 eq "B"; - } - - # This only works under -DEBUGGING because it relies on an assert(). - { - # Check capture offset re-entrancy of utf8 code. - - sub fswash { $_[0] =~ s/([>X])//g; } - - my $k1 = "." x 4 . ">>"; - fswash($k1); - - my $k2 = "\x{f1}\x{2022}"; - $k2 =~ s/([\360-\362])/>/g; - fswash($k2); - - is($k2, "\x{2022}", "utf8::SWASHNEW doesn't cause capture leaks; Bug 60508"); - } - - { - # minimal CURLYM limited to 32767 matches - my @pat = ( - qr{a(x|y)*b}, # CURLYM - qr{a(x|y)*?b}, # .. with minmod - qr{a([wx]|[yz])*b}, # .. and without tries - qr{a([wx]|[yz])*?b}, - ); - my $len = 32768; - my $s = join '', 'a', 'x' x $len, 'b'; - for my $pat (@pat) { - like($s, $pat, "$pat; Bug 65372"); - } - } - - { - local $::TODO = "[perl #38133]"; - - "A" =~ /(((?:A))?)+/; - my $first = $2; - - "A" =~ /(((A))?)+/; - my $second = $2; - - is($first, $second); - } - - { - my $message - = 'utf8 =~ /trie/ where trie matches a continuation octet; Bug 70998'; - - # Catch warnings: - my $w; - local $SIG{__WARN__} = sub { $w .= shift }; - - # This bug can be reduced to - qq{\x{30ab}} =~ /\xab|\xa9/; - # but it's nice to have a more 'real-world' test. The original test - # case from the RT ticket follows: - - my %conv = ( - "\xab" => "<", - "\xa9" => "(c)", - ); - my $conv_rx = '(' . join('|', map { quotemeta } keys %conv) . ')'; - $conv_rx = qr{$conv_rx}; - - my $x - = qq{\x{3042}\x{304b}\x{3055}\x{305f}\x{306a}\x{306f}\x{307e}} - . qq{\x{3084}\x{3089}\x{308f}\x{3093}\x{3042}\x{304b}\x{3055}} - . qq{\x{305f}\x{306a}\x{306f}\x{307e}\x{3084}\x{3089}\x{308f}} - . qq{\x{3093}\x{30a2}\x{30ab}\x{30b5}\x{30bf}\x{30ca}\x{30cf}} - . qq{\x{30de}\x{30e4}\x{30e9}\x{30ef}\x{30f3}\x{30a2}\x{30ab}} - . qq{\x{30b5}\x{30bf}\x{30ca}\x{30cf}\x{30de}\x{30e4}\x{30e9}} - . qq{\x{30ef}\x{30f3}\x{30a2}\x{30ab}\x{30b5}\x{30bf}\x{30ca}} - . qq{\x{30cf}\x{30de}\x{30e4}\x{30e9}\x{30ef}\x{30f3}}; - - $x =~ s{$conv_rx}{$conv{$1}}eg; - - is($w, undef, $message); - } - - { - # minimal CURLYM limited to 32767 matches - - is(join("-", " abc def " =~ /(?=(\S+))/g), "abc-bc-c-def-ef-f", - 'stclass optimisation does not break + inside (?=); Bug 68564'); - } - - { - use charnames ":full"; - # Delayed interpolation of \N' - my $r1 = qr/\N{THAI CHARACTER SARA I}/; - my $s1 = "\x{E34}\x{E34}\x{E34}\x{E34}"; - - # Bug #56444 - ok $s1 =~ /$r1+/, 'my $r1 = qr/\N{THAI CHARACTER SARA I}/; my $s1 = "\x{E34}\x{E34}\x{E34}\x{E34}; $s1 =~ /$r1+/'; - - # Bug #62056 - ok "${s1}A" =~ m/$s1\N{LATIN CAPITAL LETTER A}/, '"${s1}A" =~ m/$s1\N{LATIN CAPITAL LETTER A}/'; - - ok "abbbbc" =~ m/\N{1}/ && $& eq "a", '"abbbbc" =~ m/\N{1}/ && $& eq "a"'; - ok "abbbbc" =~ m/\N{3,4}/ && $& eq "abbb", '"abbbbc" =~ m/\N{3,4}/ && $& eq "abbb"'; - } - - { - use charnames ":full"; - my $message = '[perl #74982] Period coming after \N{}'; - ok("\x{ff08}." =~ m/\N{FULLWIDTH LEFT PARENTHESIS}./ && $& eq "\x{ff08}.", $message); - ok("\x{ff08}." =~ m/[\N{FULLWIDTH LEFT PARENTHESIS}]./ && $& eq "\x{ff08}.", $message); - } - -SKIP: { - ######## "Segfault using HTML::Entities", Richard Jolly , in perl-unicode@perl.org - - skip('Perl configured without Encode module', 1) - unless $Config{extensions} =~ / Encode /; - - # Test case cut down by jhi - fresh_perl_like(<<'EOP', qr!Malformed UTF-8 character \(unexpected end of string\) in substitution \(s///\) at!, 'Segfault using HTML::Entities'); -use Encode; -my $t = ord('A') == 193 ? "\xEA" : "\xE9"; -Encode::_utf8_on($t); -$t =~ s/([^a])//ge; -EOP - } - -} # End of sub run_tests - -1; diff --git a/t/CORE/re/pat_special_cc.t b/t/CORE/re/pat_special_cc.t deleted file mode 100644 index 0f622271e..000000000 --- a/t/CORE/re/pat_special_cc.t +++ /dev/null @@ -1,55 +0,0 @@ -#!./perl -# -# This test file is used to bulk check that /\s/ and /[\s]/ -# test the same and that /\s/ and /\S/ are opposites, and that -# /[\s]/ and /[\S]/ are also opposites, for \s/\S and \d/\D and -# \w/\W. -use strict; -use warnings; -use 5.010; - - -sub run_tests; - -$| = 1; - - -BEGIN { - require q(t/CORE/test.pl); -} - - -plan tests => 9; # Update this when adding/deleting tests. - -run_tests() unless caller; - -# -# Tests start here. -# -sub run_tests { - my $upper_bound= 10_000; - for my $special (qw(\s \w \d)) { - my $upper= uc($special); - my @cc_plain_failed; - my @cc_complement_failed; - my @plain_complement_failed; - for my $ord (0 .. $upper_bound) { - my $ch= chr $ord; - my $ord = sprintf "U+%04X", $ord; # For display in Unicode terms - my $plain= $ch=~/$special/ ? 1 : 0; - my $plain_u= $ch=~/$upper/ ? 1 : 0; - push @plain_complement_failed, "$ord-$plain-$plain_u" if $plain == $plain_u; - - my $cc= $ch=~/[$special]/ ? 1 : 0; - my $cc_u= $ch=~/[$upper]/ ? 1 : 0; - push @cc_complement_failed, "$ord-$cc-$cc_u" if $cc == $cc_u; - - push @cc_plain_failed, "$ord-$plain-$cc" if $plain != $cc; - } - is(join(" | ",@cc_plain_failed),"", "Check that /$special/ and /[$special]/ match same things (ord-plain-cc)"); - is(join(" | ",@plain_complement_failed),"", "Check that /$special/ and /$upper/ are complements (ord-plain-plain_u)"); - is(join(" | ",@cc_complement_failed),"", "Check that /[$special]/ and /[$upper]/ are complements (ord-cc-cc_u)"); - } -} # End of sub run_tests - -1; diff --git a/t/CORE/re/qr-72922.t b/t/CORE/re/qr-72922.t deleted file mode 100644 index bbb531d32..000000000 --- a/t/CORE/re/qr-72922.t +++ /dev/null @@ -1,37 +0,0 @@ -#!perl -w -use strict; - -BEGIN { - require q(t/CORE/test.pl); -} -plan(tests => 14); - -# [perl 72922]: A 'copy' of a Regex object which has magic should not crash -# When a Regex object was copied and the copy weaken then the original regex object -# could no longer be 'copied' with qr// - -use Scalar::Util 'weaken'; -sub s1 { - my $re = qr/abcdef/; - my $re_copy1 = $re; - my $re_weak_copy = $re;; - weaken($re_weak_copy); - my $re_copy2 = qr/$re/; - - my $str_re = "$re"; - is("$$re_weak_copy", $str_re, "weak copy equals original"); - is("$re_copy1", $str_re, "copy1 equals original"); - is("$re_copy2", $str_re, "copy2 equals original"); - - my $refcnt_start = Internals::SvREFCNT($$re_weak_copy); - - undef $re; - is(Internals::SvREFCNT($$re_weak_copy), $refcnt_start - 1, "refcnt decreased"); - is("$re_weak_copy", $str_re, "weak copy still equals original"); - - undef $re_copy2; - is(Internals::SvREFCNT($$re_weak_copy), $refcnt_start - 1, "refcnt not decreased"); - is("$re_weak_copy", $str_re, "weak copy still equals original"); -} -s1(); -s1(); diff --git a/t/CORE/re/qr.t b/t/CORE/re/qr.t deleted file mode 100644 index a02cc3797..000000000 --- a/t/CORE/re/qr.t +++ /dev/null @@ -1,81 +0,0 @@ -#!./perl -w - -BEGIN { - require q(t/CORE/test.pl); -} - -plan tests => 5; - -my $rx = qr//; - -is(ref $rx, "Regexp", "qr// blessed into `Regexp' by default"); - - -# Make sure /$qr/ doesn’t clobber match vars before the match (bug 70764). -{ - my $output = ''; - my $rx = qr/o/; - my $a = "ooaoaoao"; - - my $foo = 0; - $foo += () = ($a =~ /$rx/g); - $output .= "$foo\n"; # correct - - $foo = 0; - for ($foo += ($a =~ /o/); $' && ($' =~ /o/) && ($foo++) ; ) { ; } - $output .= "1: $foo\n"; # No error - - $foo = 0; - for ($foo += ($a =~ /$rx/); $' && ($' =~ /$rx/) && ($foo++) ; ) { ; } - $output .= "2: $foo\n"; # initialization warning, incorrect results - - is $output, "5\n1: 5\n2: 5\n", '$a_match_var =~ /$qr/'; -} -for my $_($'){ - my $output = ''; - my $rx = qr/o/; - my $a = "ooaoaoao"; - - my $foo = 0; - $foo += () = ($a =~ /$rx/g); - $output .= "$foo\n"; # correct - - $foo = 0; - for ($foo += ($a =~ /o/); $' && /o/ && ($foo++) ; ) { ; } - $output .= "1: $foo\n"; # No error - - $foo = 0; - for ($foo += ($a =~ /$rx/); $' && /$rx/ && ($foo++) ; ) { ; } - $output .= "2: $foo\n"; # initialization warning, incorrect results - - is $output, "5\n1: 5\n2: 5\n", '/$qr/ with my $_ aliased to a match var'; -} -for($'){ - my $output = ''; - my $rx = qr/o/; - my $a = "ooaoaoao"; - - my $foo = 0; - $foo += () = ($a =~ /$rx/g); - $output .= "$foo\n"; # correct - - $foo = 0; - for ($foo += ($a =~ /o/); $' && /o/ && ($foo++) ; ) { ; } - $output .= "1: $foo\n"; # No error - - $foo = 0; - for ($foo += ($a =~ /$rx/); $' && /$rx/ && ($foo++) ; ) { ; } - $output .= "2: $foo\n"; # initialization warning, incorrect results - - is $output, "5\n1: 5\n2: 5\n", q|/$qr/ with $'_ aliased to a match var|; -} - -# Make sure /$qr/ calls get-magic on its LHS (bug 71470). -{ - my $scratch; - sub qrBug::TIESCALAR{bless[], 'qrBug'} - sub qrBug::FETCH { $scratch .= "[fetching]"; 'glat' } - tie my $flile, "qrBug"; - $flile =~ qr/(?:)/; - is $scratch, "[fetching]", '/$qr/ with magical LHS'; -} diff --git a/t/CORE/re/qr_gc.t b/t/CORE/re/qr_gc.t deleted file mode 100644 index 515f412fa..000000000 --- a/t/CORE/re/qr_gc.t +++ /dev/null @@ -1,30 +0,0 @@ -#!./perl -w - -BEGIN { - require q(t/CORE/test.pl); - undef &Regexp::DESTROY; -} - -skip_all "perlcc re-eval doesnt call Regexp::DESTROY #328" if is_perlcc_compiled; -plan tests => 2; - -my $destroyed; -{ - sub Regexp::DESTROY { $destroyed++ } -} - -{ - my $rx = qr//; -} - -is( $destroyed, 1, "destroyed regexp" ); - -undef $destroyed; - -{ - my $var = bless {}, "Foo"; - my $rx = qr/(?{ $var })/; -} - -is( $destroyed, 1, "destroyed regexp with closure capture" ); - diff --git a/t/CORE/re/qrstack.t b/t/CORE/re/qrstack.t deleted file mode 100644 index 7d4ff335b..000000000 --- a/t/CORE/re/qrstack.t +++ /dev/null @@ -1,9 +0,0 @@ -#!./perl -w - -BEGIN { - require q(t/CORE/test.pl); -} - -plan tests => 1; - -ok(defined [(1)x127,qr//,1]->[127], "qr// should extend the stack properly"); diff --git a/t/CORE/re/re_tests b/t/CORE/re/re_tests deleted file mode 100644 index 144cf1e8c..000000000 --- a/t/CORE/re/re_tests +++ /dev/null @@ -1,1535 +0,0 @@ -# This stops me getting screenfulls of syntax errors every time I accidentally -# run this file via a shell glob. Format of this file is given in regexp.t -# Can't use \N{VALID NAME TEST} here because need 'use charnames'; but can use -# \N{U+valid} here. -__END__ -abc abc y $& abc -abc abc y $-[0] 0 -abc abc y $+[0] 3 -abc xbc n - - -abc axc n - - -abc abx n - - -abc xabcy y $& abc -abc xabcy y $-[0] 1 -abc xabcy y $+[0] 4 -abc ababc y $& abc -abc ababc y $-[0] 2 -abc ababc y $+[0] 5 -ab*c abc y $& abc -ab*c abc y $-[0] 0 -ab*c abc y $+[0] 3 -ab*bc abc y $& abc -ab*bc abc y $-[0] 0 -ab*bc abc y $+[0] 3 -ab*bc abbc y $& abbc -ab*bc abbc y $-[0] 0 -ab*bc abbc y $+[0] 4 -ab*bc abbbbc y $& abbbbc -ab*bc abbbbc y $-[0] 0 -ab*bc abbbbc y $+[0] 6 -.{1} abbbbc y $& a -.{1} abbbbc y $-[0] 0 -.{1} abbbbc y $+[0] 1 -.{3,4} abbbbc y $& abbb -.{3,4} abbbbc y $-[0] 0 -.{3,4} abbbbc y $+[0] 4 -\N{1} abbbbc y $& a -\N{1} abbbbc y $-[0] 0 -\N{1} abbbbc y $+[0] 1 -/\N {1}/x abbbbc y $& a -/\N {1}/x abbbbc y $-[0] 0 -/\N {1}/x abbbbc y $+[0] 1 -\N{3,4} abbbbc y $& abbb -\N{3,4} abbbbc y $-[0] 0 -\N{3,4} abbbbc y $+[0] 4 -/\N {3,4}/x abbbbc y $& abbb -/\N {3,4}/x abbbbc y $-[0] 0 -/\N {3,4}/x abbbbc y $+[0] 4 -ab{0,}bc abbbbc y $& abbbbc -ab{0,}bc abbbbc y $-[0] 0 -ab{0,}bc abbbbc y $+[0] 6 -ab+bc abbc y $& abbc -ab+bc abbc y $-[0] 0 -ab+bc abbc y $+[0] 4 -ab+bc abc n - - -ab+bc abq n - - -ab{1,}bc abq n - - -ab+bc abbbbc y $& abbbbc -ab+bc abbbbc y $-[0] 0 -ab+bc abbbbc y $+[0] 6 -ab{1,}bc abbbbc y $& abbbbc -ab{1,}bc abbbbc y $-[0] 0 -ab{1,}bc abbbbc y $+[0] 6 -ab{1,3}bc abbbbc y $& abbbbc -ab{1,3}bc abbbbc y $-[0] 0 -ab{1,3}bc abbbbc y $+[0] 6 -ab{3,4}bc abbbbc y $& abbbbc -ab{3,4}bc abbbbc y $-[0] 0 -ab{3,4}bc abbbbc y $+[0] 6 -ab{4,5}bc abbbbc n - - -ab?bc abbc y $& abbc -ab?bc abc y $& abc -ab{0,1}bc abc y $& abc -ab?bc abbbbc n - - -ab?c abc y $& abc -ab{0,1}c abc y $& abc -^abc$ abc y $& abc -^abc$ abcc n - - -^abc abcc y $& abc -^abc$ aabc n - - -abc$ aabc y $& abc -abc$ aabcd n - - -^ abc y $& -$ abc y $& -a.c abc y $& abc -a.c axc y $& axc -a\Nc abc y $& abc -/a\N c/x abc y $& abc -a.*c axyzc y $& axyzc -a\N*c axyzc y $& axyzc -/a\N *c/x axyzc y $& axyzc -a.*c axyzd n - - -a\N*c axyzd n - - -/a\N *c/x axyzd n - - -a[bc]d abc n - - -a[bc]d abd y $& abd -a[b]d abd y $& abd -[a][b][d] abd y $& abd -.[b]. abd y $& abd -.[b]. aBd n - - -(?i:.[b].) abd y $& abd -(?i:\N[b]\N) abd y $& abd -a[b-d]e abd n - - -a[b-d]e ace y $& ace -a[b-d] aac y $& ac -a[-b] a- y $& a- -a[b-] a- y $& a- -a[b-a] - c - Invalid [] range \"b-a\" -a[]b - c - Unmatched [ -a[ - c - Unmatched [ -a] a] y $& a] -a[]]b a]b y $& a]b -a[^bc]d aed y $& aed -a[^bc]d abd n - - -a[^-b]c adc y $& adc -a[^-b]c a-c n - - -a[^]b]c a]c n - - -a[^]b]c adc y $& adc -\ba\b a- y - - -\ba\b -a y - - -\ba\b -a- y - - -\by\b xy n - - -\by\b yz n - - -\by\b xyz n - - -\Ba\B a- n - - -\Ba\B -a n - - -\Ba\B -a- n - - -\By\b xy y - - -\By\b xy y $-[0] 1 -\By\b xy y $+[0] 2 -\By\b xy y - - -\by\B yz y - - -\By\B xyz y - - -\w a y - - -\w - n - - -\W a n - - -\W - y - - -a\sb a b y - - -a\sb a-b n - - -a\Sb a b n - - -a\Sb a-b y - - -\d 1 y - - -\d - n - - -\D 1 n - - -\D - y - - -[\w] a y - - -[\w] - n - - -[\W] a n - - -[\W] - y - - -a[\s]b a b y - - -a[\s]b a-b n - - -a[\S]b a b n - - -a[\S]b a-b y - - -[\d] 1 y - - -[\d] - n - - -[\D] 1 n - - -[\D] - y - - -ab|cd abc y $& ab -ab|cd abcd y $& ab -()ef def y $&-$1 ef- -()ef def y $-[0] 1 -()ef def y $+[0] 3 -()ef def y $-[1] 1 -()ef def y $+[1] 1 -*a - c - Quantifier follows nothing -(|*)b - c - Quantifier follows nothing -(*)b - c - Unknown verb -$b b n - - -a\ - c - Search pattern not terminated -a\(b a(b y $&-$1 a(b- -a\(*b ab y $& ab -a\(*b a((b y $& a((b -a\\b a\\b y $& a\\b -abc) - c - Unmatched ) -(abc - c - Unmatched ( -((a)) abc y $&-$1-$2 a-a-a -((a)) abc y $-[0]-$-[1]-$-[2] 0-0-0 -((a)) abc y $+[0]-$+[1]-$+[2] 1-1-1 -((a)) abc b @- 0 0 0 -((a)) abc b @+ 1 1 1 -(a)b(c) abc y $&-$1-$2 abc-a-c -(a)b(c) abc y $-[0]-$-[1]-$-[2] 0-0-2 -(a)b(c) abc y $+[0]-$+[1]-$+[2] 3-1-3 -a+b+c aabbabc y $& abc -a{1,}b{1,}c aabbabc y $& abc -a** - c - Nested quantifiers -a.+?c abcabc y $& abc -(a+|b)* ab y $&-$1 ab-b -(a+|b)* ab y $-[0] 0 -(a+|b)* ab y $+[0] 2 -(a+|b)* ab y $-[1] 1 -(a+|b)* ab y $+[1] 2 -(a+|b){0,} ab y $&-$1 ab-b -(a+|b)+ ab y $&-$1 ab-b -(a+|b){1,} ab y $&-$1 ab-b -(a+|b)? ab y $&-$1 a-a -(a+|b){0,1} ab y $&-$1 a-a -)( - c - Unmatched ) -[^ab]* cde y $& cde -abc n - - -a* y $& -([abc])*d abbbcd y $&-$1 abbbcd-c -([abc])*bcd abcd y $&-$1 abcd-a -a|b|c|d|e e y $& e -(a|b|c|d|e)f ef y $&-$1 ef-e -(a|b|c|d|e)f ef y $-[0] 0 -(a|b|c|d|e)f ef y $+[0] 2 -(a|b|c|d|e)f ef y $-[1] 0 -(a|b|c|d|e)f ef y $+[1] 1 -abcd*efg abcdefg y $& abcdefg -ab* xabyabbbz y $& ab -ab* xayabbbz y $& a -(ab|cd)e abcde y $&-$1 cde-cd -[abhgefdc]ij hij y $& hij -^(ab|cd)e abcde n x$1y xy -(abc|)ef abcdef y $&-$1 ef- -(a|b)c*d abcd y $&-$1 bcd-b -(ab|ab*)bc abc y $&-$1 abc-a -a([bc]*)c* abc y $&-$1 abc-bc -a([bc]*)(c*d) abcd y $&-$1-$2 abcd-bc-d -a([bc]*)(c*d) abcd y $-[0] 0 -a([bc]*)(c*d) abcd y $+[0] 4 -a([bc]*)(c*d) abcd y $-[1] 1 -a([bc]*)(c*d) abcd y $+[1] 3 -a([bc]*)(c*d) abcd y $-[2] 3 -a([bc]*)(c*d) abcd y $+[2] 4 -a([bc]+)(c*d) abcd y $&-$1-$2 abcd-bc-d -a([bc]*)(c+d) abcd y $&-$1-$2 abcd-b-cd -a([bc]*)(c+d) abcd y $-[0] 0 -a([bc]*)(c+d) abcd y $+[0] 4 -a([bc]*)(c+d) abcd y $-[1] 1 -a([bc]*)(c+d) abcd y $+[1] 2 -a([bc]*)(c+d) abcd y $-[2] 2 -a([bc]*)(c+d) abcd y $+[2] 4 -a[bcd]*dcdcde adcdcde y $& adcdcde -a[bcd]+dcdcde adcdcde n - - -(ab|a)b*c abc y $&-$1 abc-ab -(ab|a)b*c abc y $-[0] 0 -(ab|a)b*c abc y $+[0] 3 -(ab|a)b*c abc y $-[1] 0 -(ab|a)b*c abc y $+[1] 2 -((a)(b)c)(d) abcd y $1-$2-$3-$4 abc-a-b-d -((a)(b)c)(d) abcd y $-[0] 0 -((a)(b)c)(d) abcd y $+[0] 4 -((a)(b)c)(d) abcd y $-[1] 0 -((a)(b)c)(d) abcd y $+[1] 3 -((a)(b)c)(d) abcd y $-[2] 0 -((a)(b)c)(d) abcd y $+[2] 1 -((a)(b)c)(d) abcd y $-[3] 1 -((a)(b)c)(d) abcd y $+[3] 2 -((a)(b)c)(d) abcd y $-[4] 3 -((a)(b)c)(d) abcd y $+[4] 4 -[a-zA-Z_][a-zA-Z0-9_]* alpha y $& alpha -^a(bc+|b[eh])g|.h$ abh y $&-$1 bh- -(bc+d$|ef*g.|h?i(j|k)) effgz y $&-$1-$2 effgz-effgz- -(bc+d$|ef*g.|h?i(j|k)) ij y $&-$1-$2 ij-ij-j -(bc+d$|ef*g.|h?i(j|k)) effg n - - -(bc+d$|ef*g.|h?i(j|k)) bcdd n - - -(bc+d$|ef*g.|h?i(j|k)) reffgz y $&-$1-$2 effgz-effgz- -((((((((((a)))))))))) a y $10 a -((((((((((a)))))))))) a y $-[0] 0 -((((((((((a)))))))))) a y $+[0] 1 -((((((((((a)))))))))) a y $-[10] 0 -((((((((((a)))))))))) a y $+[10] 1 -((((((((((a))))))))))\10 aa y $& aa -((((((((((a))))))))))${bang} aa n - - -((((((((((a))))))))))${bang} a! y $& a! -(((((((((a))))))))) a y $& a -multiple words of text uh-uh n - - -multiple words multiple words, yeah y $& multiple words -(.*)c(.*) abcde y $&-$1-$2 abcde-ab-de -\((.*), (.*)\) (a, b) y ($2, $1) (b, a) -[k] ab n - - -abcd abcd y $&-\$&-\\$& abcd-\$&-\\abcd -a(bc)d abcd y $1-\$1-\\$1 bc-\$1-\\bc -a[-]?c ac y $& ac -(abc)\1 abcabc y $1 abc -([a-c]*)\1 abcabc y $1 abc -\1 - c - Reference to nonexistent group -\2 - c - Reference to nonexistent group -\g1 - c - Reference to nonexistent group -\g-1 - c - Reference to nonexistent or unclosed group -\g{1} - c - Reference to nonexistent group -\g{-1} - c - Reference to nonexistent or unclosed group -\g0 - c - Reference to invalid group 0 -\g-0 - c - Reference to invalid group 0 -\g{0} - c - Reference to invalid group 0 -\g{-0} - c - Reference to invalid group 0 -(a)|\1 a y - - -(a)|\1 x n - Reference to group in different branch -(?:(b)?a)\1 a n - Reference to group that did not match -(a)|\2 - c - Reference to nonexistent group -(([a-c])b*?\2)* ababbbcbc y $&-$1-$2 ababb-bb-b -(([a-c])b*?\2){3} ababbbcbc y $&-$1-$2 ababbbcbc-cbc-c -((\3|b)\2(a)x)+ aaxabxbaxbbx n - - -((\3|b)\2(a)x)+ aaaxabaxbaaxbbax y $&-$1-$2-$3 bbax-bbax-b-a -((\3|b)\2(a)){2,} bbaababbabaaaaabbaaaabba y $&-$1-$2-$3 bbaaaabba-bba-b-a -#Bug #3589 - up to perl-5.6.0 matches incorrectly, from 5.6.1 not anymore -^((.)?a\2)+$ babadad n - - -(a)|(b) b y $-[0] 0 -(a)|(b) b y $+[0] 1 -(a)|(b) b y x$-[1] x -(a)|(b) b y x$+[1] x -(a)|(b) b y $-[2] 0 -(a)|(b) b y $+[2] 1 -'abc'i ABC y $& ABC -'abc'i XBC n - - -'abc'i AXC n - - -'abc'i ABX n - - -'abc'i XABCY y $& ABC -'abc'i ABABC y $& ABC -'ab*c'i ABC y $& ABC -'ab*bc'i ABC y $& ABC -'ab*bc'i ABBC y $& ABBC -'ab*?bc'i ABBBBC y $& ABBBBC -'ab{0,}?bc'i ABBBBC y $& ABBBBC -'ab+?bc'i ABBC y $& ABBC -'ab+bc'i ABC n - - -'ab+bc'i ABQ n - - -'ab{1,}bc'i ABQ n - - -'ab+bc'i ABBBBC y $& ABBBBC -'ab{1,}?bc'i ABBBBC y $& ABBBBC -'ab{1,3}?bc'i ABBBBC y $& ABBBBC -'ab{3,4}?bc'i ABBBBC y $& ABBBBC -'ab{4,5}?bc'i ABBBBC n - - -'ab??bc'i ABBC y $& ABBC -'ab??bc'i ABC y $& ABC -'ab{0,1}?bc'i ABC y $& ABC -'ab??bc'i ABBBBC n - - -'ab??c'i ABC y $& ABC -'ab{0,1}?c'i ABC y $& ABC -'^abc$'i ABC y $& ABC -'^abc$'i ABCC n - - -'^abc'i ABCC y $& ABC -'^abc$'i AABC n - - -'abc$'i AABC y $& ABC -'^'i ABC y $& -'$'i ABC y $& -'a.c'i ABC y $& ABC -'a.c'i AXC y $& AXC -'a\Nc'i ABC y $& ABC -'a.*?c'i AXYZC y $& AXYZC -'a.*c'i AXYZD n - - -'a[bc]d'i ABC n - - -'a[bc]d'i ABD y $& ABD -'a[b-d]e'i ABD n - - -'a[b-d]e'i ACE y $& ACE -'a[b-d]'i AAC y $& AC -'a[-b]'i A- y $& A- -'a[b-]'i A- y $& A- -'a[b-a]'i - c - Invalid [] range \"b-a\" -'a[]b'i - c - Unmatched [ -'a['i - c - Unmatched [ -'a]'i A] y $& A] -'a[]]b'i A]B y $& A]B -'a[^bc]d'i AED y $& AED -'a[^bc]d'i ABD n - - -'a[^-b]c'i ADC y $& ADC -'a[^-b]c'i A-C n - - -'a[^]b]c'i A]C n - - -'a[^]b]c'i ADC y $& ADC -'ab|cd'i ABC y $& AB -'ab|cd'i ABCD y $& AB -'()ef'i DEF y $&-$1 EF- -'*a'i - c - Quantifier follows nothing -'(|*)b'i - c - Quantifier follows nothing -'(*)b'i - c - Unknown verb -'$b'i B n - - -'a\'i - c - Search pattern not terminated -'a\(b'i A(B y $&-$1 A(B- -'a\(*b'i AB y $& AB -'a\(*b'i A((B y $& A((B -'a\\b'i A\\B y $& A\\B -'abc)'i - c - Unmatched ) -'(abc'i - c - Unmatched ( -'((a))'i ABC y $&-$1-$2 A-A-A -'(a)b(c)'i ABC y $&-$1-$2 ABC-A-C -'a+b+c'i AABBABC y $& ABC -'a{1,}b{1,}c'i AABBABC y $& ABC -'a**'i - c - Nested quantifiers -'a.+?c'i ABCABC y $& ABC -'a.*?c'i ABCABC y $& ABC -'a.{0,5}?c'i ABCABC y $& ABC -'(a+|b)*'i AB y $&-$1 AB-B -'(a+|b){0,}'i AB y $&-$1 AB-B -'(a+|b)+'i AB y $&-$1 AB-B -'(a+|b){1,}'i AB y $&-$1 AB-B -'(a+|b)?'i AB y $&-$1 A-A -'(a+|b){0,1}'i AB y $&-$1 A-A -'(a+|b){0,1}?'i AB y $&-$1 - -')('i - c - Unmatched ) -'[^ab]*'i CDE y $& CDE -'abc'i n - - -'a*'i y $& -'([abc])*d'i ABBBCD y $&-$1 ABBBCD-C -'([abc])*bcd'i ABCD y $&-$1 ABCD-A -'a|b|c|d|e'i E y $& E -'(a|b|c|d|e)f'i EF y $&-$1 EF-E -'abcd*efg'i ABCDEFG y $& ABCDEFG -'ab*'i XABYABBBZ y $& AB -'ab*'i XAYABBBZ y $& A -'(ab|cd)e'i ABCDE y $&-$1 CDE-CD -'[abhgefdc]ij'i HIJ y $& HIJ -'^(ab|cd)e'i ABCDE n x$1y XY -'(abc|)ef'i ABCDEF y $&-$1 EF- -'(a|b)c*d'i ABCD y $&-$1 BCD-B -'(ab|ab*)bc'i ABC y $&-$1 ABC-A -'a([bc]*)c*'i ABC y $&-$1 ABC-BC -'a([bc]*)(c*d)'i ABCD y $&-$1-$2 ABCD-BC-D -'a([bc]+)(c*d)'i ABCD y $&-$1-$2 ABCD-BC-D -'a([bc]*)(c+d)'i ABCD y $&-$1-$2 ABCD-B-CD -'a[bcd]*dcdcde'i ADCDCDE y $& ADCDCDE -'a[bcd]+dcdcde'i ADCDCDE n - - -'(ab|a)b*c'i ABC y $&-$1 ABC-AB -'((a)(b)c)(d)'i ABCD y $1-$2-$3-$4 ABC-A-B-D -'[a-zA-Z_][a-zA-Z0-9_]*'i ALPHA y $& ALPHA -'^a(bc+|b[eh])g|.h$'i ABH y $&-$1 BH- -'(bc+d$|ef*g.|h?i(j|k))'i EFFGZ y $&-$1-$2 EFFGZ-EFFGZ- -'(bc+d$|ef*g.|h?i(j|k))'i IJ y $&-$1-$2 IJ-IJ-J -'(bc+d$|ef*g.|h?i(j|k))'i EFFG n - - -'(bc+d$|ef*g.|h?i(j|k))'i BCDD n - - -'(bc+d$|ef*g.|h?i(j|k))'i REFFGZ y $&-$1-$2 EFFGZ-EFFGZ- -'((((((((((a))))))))))'i A y $10 A -'((((((((((a))))))))))\10'i AA y $& AA -'((((((((((a))))))))))${bang}'i AA n - - -'((((((((((a))))))))))${bang}'i A! y $& A! -'(((((((((a)))))))))'i A y $& A -'(?:(?:(?:(?:(?:(?:(?:(?:(?:(a))))))))))'i A y $1 A -'(?:(?:(?:(?:(?:(?:(?:(?:(?:(a|b|c))))))))))'i C y $1 C -'multiple words of text'i UH-UH n - - -'multiple words'i MULTIPLE WORDS, YEAH y $& MULTIPLE WORDS -'(.*)c(.*)'i ABCDE y $&-$1-$2 ABCDE-AB-DE -'\((.*), (.*)\)'i (A, B) y ($2, $1) (B, A) -'[k]'i AB n - - -'abcd'i ABCD y $&-\$&-\\$& ABCD-\$&-\\ABCD -'a(bc)d'i ABCD y $1-\$1-\\$1 BC-\$1-\\BC -'a[-]?c'i AC y $& AC -'(abc)\1'i ABCABC y $1 ABC -'([a-c]*)\1'i ABCABC y $1 ABC -a(?!b). abad y $& ad -(?=)a a y $& a -a(?=d). abad y $& ad -a(?=c|d). abad y $& ad -a(?:b|c|d)(.) ace y $1 e -a(?:b|c|d)*(.) ace y $1 e -a(?:b|c|d)+?(.) ace y $1 e -a(?:b|c|d)+?(.) acdbcdbe y $1 d -a(?:b|c|d)+(.) acdbcdbe y $1 e -a(?:b|c|d){2}(.) acdbcdbe y $1 b -a(?:b|c|d){4,5}(.) acdbcdbe y $1 b -a(?:b|c|d){4,5}?(.) acdbcdbe y $1 d -((foo)|(bar))* foobar y $1-$2-$3 bar-foo-bar -:(?: - c - Sequence (? incomplete -a(?:b|c|d){6,7}(.) acdbcdbe y $1 e -a(?:b|c|d){6,7}?(.) acdbcdbe y $1 e -a(?:b|c|d){5,6}(.) acdbcdbe y $1 e -a(?:b|c|d){5,6}?(.) acdbcdbe y $1 b -a(?:b|c|d){5,7}(.) acdbcdbe y $1 e -a(?:b|c|d){5,7}?(.) acdbcdbe y $1 b -a(?:b|(c|e){1,2}?|d)+?(.) ace y $1$2 ce -^(.+)?B AB y $1 A -^([^a-z])|(\^)$ . y $1 . -^[<>]& <&OUT y $& <& -^(a\1?){4}$ aaaaaaaaaa y $1 aaaa -^(a\1?){4}$ aaaaaaaaa n - - -^(a\1?){4}$ aaaaaaaaaaa n - - -^(a(?(1)\1)){4}$ aaaaaaaaaa y $1 aaaa -^(a(?(1)\1)){4}$ aaaaaaaaa n - - -^(a(?(1)\1)){4}$ aaaaaaaaaaa n - - -((a{4})+) aaaaaaaaa y $1 aaaaaaaa -(((aa){2})+) aaaaaaaaaa y $1 aaaaaaaa -(((a{2}){2})+) aaaaaaaaaa y $1 aaaaaaaa -(?:(f)(o)(o)|(b)(a)(r))* foobar y $1:$2:$3:$4:$5:$6 f:o:o:b:a:r -(?<=a)b ab y $& b -(?<=a)b cb n - - -(?<=a)b b n - - -(?a+)ab aaab n - - -(?>a+)b aaab y - - -([[:]+) a:[b]: y $1 :[ -([[=]+) a=[b]= y $1 =[ -([[.]+) a.[b]. y $1 .[ -[a[:xyz: - c - Unmatched [ -[a[:xyz:] - c - POSIX class [:xyz:] unknown -[a[:]b[:c] abc y $& abc -([a[:xyz:]b]+) pbaq c - POSIX class [:xyz:] unknown -[a[:]b[:c] abc y $& abc -([[:alpha:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 ABcd -([[:alnum:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 ABcd01Xy -([[:ascii:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 ABcd01Xy__-- ${nulnul} -([[:cntrl:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 ${nulnul} -([[:digit:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 01 -([[:graph:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 ABcd01Xy__-- -([[:lower:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 cd -([[:print:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 ABcd01Xy__-- -([[:punct:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 __-- -([[:space:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 -([[:word:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 ABcd01Xy__ -([[:upper:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 AB -([[:xdigit:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 ABcd01 -([[:^alpha:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 01 -((?a)[[:^alnum:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 __-- ${nulnul}${ffff} -([[:^ascii:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 ${ffff} -([[:^cntrl:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 ABcd01Xy__-- -([[:^digit:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 ABcd -([[:^lower:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 AB -((?a)[[:^print:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 ${nulnul}${ffff} -([[:^punct:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 ABcd01Xy -([[:^space:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 ABcd01Xy__-- -((?a)[[:^word:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 -- ${nulnul}${ffff} -([[:^upper:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 cd01 -([[:^xdigit:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 Xy__-- ${nulnul}${ffff} -[[:foo:]] - c - POSIX class [:foo:] unknown -[[:^foo:]] - c - POSIX class [:^foo:] unknown -((?>a+)b) aaab y $1 aaab -(?>(a+))b aaab y $1 aaa -((?>[^()]+)|\([^()]*\))+ ((abc(ade)ufh()()x y $& abc(ade)ufh()()x -(?<=x+)y - c - Variable length lookbehind not implemented -a{37,17} - c - Can't do {n,m} with n > m -a{37,0} - c - Can't do {n,m} with n > m -\Z a\nb\n y $-[0] 3 -\z a\nb\n y $-[0] 4 -$ a\nb\n y $-[0] 3 -\Z b\na\n y $-[0] 3 -\z b\na\n y $-[0] 4 -$ b\na\n y $-[0] 3 -\Z b\na y $-[0] 3 -\z b\na y $-[0] 3 -$ b\na y $-[0] 3 -'\Z'm a\nb\n y $-[0] 3 -'\z'm a\nb\n y $-[0] 4 -'$'m a\nb\n y $-[0] 1 -'\Z'm b\na\n y $-[0] 3 -'\z'm b\na\n y $-[0] 4 -'$'m b\na\n y $-[0] 1 -'\Z'm b\na y $-[0] 3 -'\z'm b\na y $-[0] 3 -'$'m b\na y $-[0] 1 -a\Z a\nb\n n - - -a\z a\nb\n n - - -a$ a\nb\n n - - -a\Z b\na\n y $-[0] 2 -a\z b\na\n n - - -a$ b\na\n y $-[0] 2 -a\Z b\na y $-[0] 2 -a\z b\na y $-[0] 2 -a$ b\na y $-[0] 2 -'a\Z'm a\nb\n n - - -'a\z'm a\nb\n n - - -'a$'m a\nb\n y $-[0] 0 -'a\Z'm b\na\n y $-[0] 2 -'a\z'm b\na\n n - - -'a$'m b\na\n y $-[0] 2 -'a\Z'm b\na y $-[0] 2 -'a\z'm b\na y $-[0] 2 -'a$'m b\na y $-[0] 2 -aa\Z aa\nb\n n - - -aa\z aa\nb\n n - - -aa$ aa\nb\n n - - -aa\Z b\naa\n y $-[0] 2 -aa\z b\naa\n n - - -aa$ b\naa\n y $-[0] 2 -aa\Z b\naa y $-[0] 2 -aa\z b\naa y $-[0] 2 -aa$ b\naa y $-[0] 2 -'aa\Z'm aa\nb\n n - - -'aa\z'm aa\nb\n n - - -'aa$'m aa\nb\n y $-[0] 0 -'aa\Z'm b\naa\n y $-[0] 2 -'aa\z'm b\naa\n n - - -'aa$'m b\naa\n y $-[0] 2 -'aa\Z'm b\naa y $-[0] 2 -'aa\z'm b\naa y $-[0] 2 -'aa$'m b\naa y $-[0] 2 -aa\Z ac\nb\n n - - -aa\z ac\nb\n n - - -aa$ ac\nb\n n - - -aa\Z b\nac\n n - - -aa\z b\nac\n n - - -aa$ b\nac\n n - - -aa\Z b\nac n - - -aa\z b\nac n - - -aa$ b\nac n - - -'aa\Z'm ac\nb\n n - - -'aa\z'm ac\nb\n n - - -'aa$'m ac\nb\n n - - -'aa\Z'm b\nac\n n - - -'aa\z'm b\nac\n n - - -'aa$'m b\nac\n n - - -'aa\Z'm b\nac n - - -'aa\z'm b\nac n - - -'aa$'m b\nac n - - -aa\Z ca\nb\n n - - -aa\z ca\nb\n n - - -aa$ ca\nb\n n - - -aa\Z b\nca\n n - - -aa\z b\nca\n n - - -aa$ b\nca\n n - - -aa\Z b\nca n - - -aa\z b\nca n - - -aa$ b\nca n - - -'aa\Z'm ca\nb\n n - - -'aa\z'm ca\nb\n n - - -'aa$'m ca\nb\n n - - -'aa\Z'm b\nca\n n - - -'aa\z'm b\nca\n n - - -'aa$'m b\nca\n n - - -'aa\Z'm b\nca n - - -'aa\z'm b\nca n - - -'aa$'m b\nca n - - -ab\Z ab\nb\n n - - -ab\z ab\nb\n n - - -ab$ ab\nb\n n - - -ab\Z b\nab\n y $-[0] 2 -ab\z b\nab\n n - - -ab$ b\nab\n y $-[0] 2 -ab\Z b\nab y $-[0] 2 -ab\z b\nab y $-[0] 2 -ab$ b\nab y $-[0] 2 -'ab\Z'm ab\nb\n n - - -'ab\z'm ab\nb\n n - - -'ab$'m ab\nb\n y $-[0] 0 -'ab\Z'm b\nab\n y $-[0] 2 -'ab\z'm b\nab\n n - - -'ab$'m b\nab\n y $-[0] 2 -'ab\Z'm b\nab y $-[0] 2 -'ab\z'm b\nab y $-[0] 2 -'ab$'m b\nab y $-[0] 2 -ab\Z ac\nb\n n - - -ab\z ac\nb\n n - - -ab$ ac\nb\n n - - -ab\Z b\nac\n n - - -ab\z b\nac\n n - - -ab$ b\nac\n n - - -ab\Z b\nac n - - -ab\z b\nac n - - -ab$ b\nac n - - -'ab\Z'm ac\nb\n n - - -'ab\z'm ac\nb\n n - - -'ab$'m ac\nb\n n - - -'ab\Z'm b\nac\n n - - -'ab\z'm b\nac\n n - - -'ab$'m b\nac\n n - - -'ab\Z'm b\nac n - - -'ab\z'm b\nac n - - -'ab$'m b\nac n - - -ab\Z ca\nb\n n - - -ab\z ca\nb\n n - - -ab$ ca\nb\n n - - -ab\Z b\nca\n n - - -ab\z b\nca\n n - - -ab$ b\nca\n n - - -ab\Z b\nca n - - -ab\z b\nca n - - -ab$ b\nca n - - -'ab\Z'm ca\nb\n n - - -'ab\z'm ca\nb\n n - - -'ab$'m ca\nb\n n - - -'ab\Z'm b\nca\n n - - -'ab\z'm b\nca\n n - - -'ab$'m b\nca\n n - - -'ab\Z'm b\nca n - - -'ab\z'm b\nca n - - -'ab$'m b\nca n - - -abb\Z abb\nb\n n - - -abb\z abb\nb\n n - - -abb$ abb\nb\n n - - -abb\Z b\nabb\n y $-[0] 2 -abb\z b\nabb\n n - - -abb$ b\nabb\n y $-[0] 2 -abb\Z b\nabb y $-[0] 2 -abb\z b\nabb y $-[0] 2 -abb$ b\nabb y $-[0] 2 -'abb\Z'm abb\nb\n n - - -'abb\z'm abb\nb\n n - - -'abb$'m abb\nb\n y $-[0] 0 -'abb\Z'm b\nabb\n y $-[0] 2 -'abb\z'm b\nabb\n n - - -'abb$'m b\nabb\n y $-[0] 2 -'abb\Z'm b\nabb y $-[0] 2 -'abb\z'm b\nabb y $-[0] 2 -'abb$'m b\nabb y $-[0] 2 -abb\Z ac\nb\n n - - -abb\z ac\nb\n n - - -abb$ ac\nb\n n - - -abb\Z b\nac\n n - - -abb\z b\nac\n n - - -abb$ b\nac\n n - - -abb\Z b\nac n - - -abb\z b\nac n - - -abb$ b\nac n - - -'abb\Z'm ac\nb\n n - - -'abb\z'm ac\nb\n n - - -'abb$'m ac\nb\n n - - -'abb\Z'm b\nac\n n - - -'abb\z'm b\nac\n n - - -'abb$'m b\nac\n n - - -'abb\Z'm b\nac n - - -'abb\z'm b\nac n - - -'abb$'m b\nac n - - -abb\Z ca\nb\n n - - -abb\z ca\nb\n n - - -abb$ ca\nb\n n - - -abb\Z b\nca\n n - - -abb\z b\nca\n n - - -abb$ b\nca\n n - - -abb\Z b\nca n - - -abb\z b\nca n - - -abb$ b\nca n - - -'abb\Z'm ca\nb\n n - - -'abb\z'm ca\nb\n n - - -'abb$'m ca\nb\n n - - -'abb\Z'm b\nca\n n - - -'abb\z'm b\nca\n n - - -'abb$'m b\nca\n n - - -'abb\Z'm b\nca n - - -'abb\z'm b\nca n - - -'abb$'m b\nca n - - -(^|x)(c) ca y $2 c -a*abc?xyz+pqr{3}ab{2,}xy{4,5}pq{0,6}AB{0,}zz x n - - -a(?{$a=2;$b=3;($b)=$a})b yabz y $b 2 -round\(((?>[^()]+))\) _I(round(xs * sz),1) y $1 xs * sz -'((?x:.) )' x y $1- x - -'((?-x:.) )'x x y $1- x- -foo.bart foo.bart y - - -'^d[x][x][x]'m abcd\ndxxx y - - -.X(.+)+X bbbbXcXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa y - - -.X(.+)+XX bbbbXcXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa y - - -.XX(.+)+X bbbbXXcXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa y - - -.X(.+)+X bbbbXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa n - - -.X(.+)+XX bbbbXXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa n - - -.XX(.+)+X bbbbXXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa n - - -.X(.+)+[X] bbbbXcXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa y - - -.X(.+)+[X][X] bbbbXcXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa y - - -.XX(.+)+[X] bbbbXXcXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa y - - -.X(.+)+[X] bbbbXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa n - - -.X(.+)+[X][X] bbbbXXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa n - - -.XX(.+)+[X] bbbbXXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa n - - -.[X](.+)+[X] bbbbXcXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa y - - -.[X](.+)+[X][X] bbbbXcXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa y - - -.[X][X](.+)+[X] bbbbXXcXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa y - - -.[X](.+)+[X] bbbbXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa n - - -.[X](.+)+[X][X] bbbbXXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa n - - -.[X][X](.+)+[X] bbbbXXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa n - - -tt+$ xxxtt y - - -([a-\d]+) za-9z y $1 a-9 -([\d-z]+) a0-za y $1 0-z -([\d-\s]+) a0- z y $1 0- -([a-[:digit:]]+) za-9z y $1 a-9 -([[:digit:]-z]+) =0-z= y $1 0-z -([[:digit:]-[:alpha:]]+) =0-z= y $1 0-z -\GX.*X aaaXbX n - - -(\d+\.\d+) 3.1415926 y $1 3.1415926 -(\ba.{0,10}br) have a web browser y $1 a web br -'\.c(pp|xx|c)?$'i Changes n - - -'\.c(pp|xx|c)?$'i IO.c y - - -'(\.c(pp|xx|c)?$)'i IO.c y $1 .c -^([a-z]:) C:/ n - - -'^\S\s+aa$'m \nx aa y - - -(^|a)b ab y - - -^([ab]*?)(b)?(c)$ abac y -$2- -- -(\w)?(abc)\1b abcab n - - -^(?:.,){2}c a,b,c y - - -^(.,){2}c a,b,c y $1 b, -^(?:[^,]*,){2}c a,b,c y - - -^([^,]*,){2}c a,b,c y $1 b, -^([^,]*,){3}d aaa,b,c,d y $1 c, -^([^,]*,){3,}d aaa,b,c,d y $1 c, -^([^,]*,){0,3}d aaa,b,c,d y $1 c, -^([^,]{1,3},){3}d aaa,b,c,d y $1 c, -^([^,]{1,3},){3,}d aaa,b,c,d y $1 c, -^([^,]{1,3},){0,3}d aaa,b,c,d y $1 c, -^([^,]{1,},){3}d aaa,b,c,d y $1 c, -^([^,]{1,},){3,}d aaa,b,c,d y $1 c, -^([^,]{1,},){0,3}d aaa,b,c,d y $1 c, -^([^,]{0,3},){3}d aaa,b,c,d y $1 c, -^([^,]{0,3},){3,}d aaa,b,c,d y $1 c, -^([^,]{0,3},){0,3}d aaa,b,c,d y $1 c, -(?i) y - - -(?a:((?u)\w)\W) \xC0\xC0 y $& \xC0\xC0 -'(?!\A)x'm a\nxb\n y - - -^(a(b)?)+$ aba y -$1-$2- -a-- -^(aa(bb)?)+$ aabbaa y -$1-$2- -aa-- -'^.{9}abc.*\n'm 123\nabcabcabcabc\n y - - -^(a)?a$ a y -$1- -- -^(a)?(?(1)a|b)+$ a n - - -^(a\1?)(a\1?)(a\2?)(a\3?)$ aaaaaa y $1,$2,$3,$4 a,aa,a,aa -^(a\1?){4}$ aaaaaa y $1 aa -^(0+)?(?:x(1))? x1 y - - -^([0-9a-fA-F]+)(?:x([0-9a-fA-F]+)?)(?:x([0-9a-fA-F]+))? 012cxx0190 y - - -^(b+?|a){1,2}c bbbac y $1 a -^(b+?|a){1,2}c bbbbac y $1 a -\((\w\. \w+)\) cd. (A. Tw) y -$1- -A. Tw- -((?:aaaa|bbbb)cccc)? aaaacccc y - - -((?:aaaa|bbbb)cccc)? bbbbcccc y - - -(a)?(a)+ a y $1:$2 :a - -(ab)?(ab)+ ab y $1:$2 :ab - -(abc)?(abc)+ abc y $1:$2 :abc - -'b\s^'m a\nb\n n - - -\ba a y - - -^(a(??{"(?!)"})|(a)(?{1}))b ab y $2 a # [ID 20010811.006] -ab(?i)cd AbCd n - - # [ID 20010809.023] -ab(?i)cd abCd y - - -(A|B)*(?(1)(CD)|(CD)) CD y $2-$3 -CD -(A|B)*(?(1)(CD)|(CD)) ABCD y $2-$3 CD- -(A|B)*?(?(1)(CD)|(CD)) CD y $2-$3 -CD # [ID 20010803.016] -(A|B)*?(?(1)(CD)|(CD)) ABCD y $2-$3 CD- -'^(o)(?!.*\1)'i Oo n - - -(.*)\d+\1 abc12bc y $1 bc -(?m:(foo\s*$)) foo\n bar y $1 foo -(.*)c abcd y $1 ab -(.*)(?=c) abcd y $1 ab -(.*)(?=c)c abcd yB $1 ab -(.*)(?=b|c) abcd y $1 ab -(.*)(?=b|c)c abcd y $1 ab -(.*)(?=c|b) abcd y $1 ab -(.*)(?=c|b)c abcd y $1 ab -(.*)(?=[bc]) abcd y $1 ab -(.*)(?=[bc])c abcd yB $1 ab -(.*)(?<=b) abcd y $1 ab -(.*)(?<=b)c abcd y $1 ab -(.*)(?<=b|c) abcd y $1 abc -(.*)(?<=b|c)c abcd y $1 ab -(.*)(?<=c|b) abcd y $1 abc -(.*)(?<=c|b)c abcd y $1 ab -(.*)(?<=[bc]) abcd y $1 abc -(.*)(?<=[bc])c abcd y $1 ab -(.*?)c abcd y $1 ab -(.*?)(?=c) abcd y $1 ab -(.*?)(?=c)c abcd yB $1 ab -(.*?)(?=b|c) abcd y $1 a -(.*?)(?=b|c)c abcd y $1 ab -(.*?)(?=c|b) abcd y $1 a -(.*?)(?=c|b)c abcd y $1 ab -(.*?)(?=[bc]) abcd y $1 a -(.*?)(?=[bc])c abcd yB $1 ab -(.*?)(?<=b) abcd y $1 ab -(.*?)(?<=b)c abcd y $1 ab -(.*?)(?<=b|c) abcd y $1 ab -(.*?)(?<=b|c)c abcd y $1 ab -(.*?)(?<=c|b) abcd y $1 ab -(.*?)(?<=c|b)c abcd y $1 ab -(.*?)(?<=[bc]) abcd y $1 ab -(.*?)(?<=[bc])c abcd y $1 ab -2(]*)?$\1 2 y $& 2 -(??{}) x y - - -a(b)?? abc y <$1> <> # undef [perl #16773] -(\d{1,3}\.){3,} 128.134.142.8 y <$1> <142.> # [perl #18019] -^.{3,4}(.+)\1\z foobarbar y $1 bar # 16 tests for [perl #23171] -^(?:f|o|b){3,4}(.+)\1\z foobarbar y $1 bar -^.{3,4}((?:b|a|r)+)\1\z foobarbar y $1 bar -^(?:f|o|b){3,4}((?:b|a|r)+)\1\z foobarbar y $1 bar -^.{3,4}(.+?)\1\z foobarbar y $1 bar -^(?:f|o|b){3,4}(.+?)\1\z foobarbar y $1 bar -^.{3,4}((?:b|a|r)+?)\1\z foobarbar y $1 bar -^(?:f|o|b){3,4}((?:b|a|r)+?)\1\z foobarbar y $1 bar -^.{2,3}?(.+)\1\z foobarbar y $1 bar -^(?:f|o|b){2,3}?(.+)\1\z foobarbar y $1 bar -^.{2,3}?((?:b|a|r)+)\1\z foobarbar y $1 bar -^(?:f|o|b){2,3}?((?:b|a|r)+)\1\z foobarbar y $1 bar -^.{2,3}?(.+?)\1\z foobarbar y $1 bar -^(?:f|o|b){2,3}?(.+?)\1\z foobarbar y $1 bar -^.{2,3}?((?:b|a|r)+?)\1\z foobarbar y $1 bar -^(?:f|o|b){2,3}?((?:b|a|r)+?)\1\z foobarbar y $1 bar -.*a(?!(b|cd)*e).*f ......abef n - - # [perl #23030] -x(?# x c - Sequence (?#... not terminated -:x(?#: x c - Sequence (?#... not terminated -(WORDS|WORD)S WORDS y $1 WORD -(X.|WORDS|X.|WORD)S WORDS y $1 WORD -(WORDS|WORLD|WORD)S WORDS y $1 WORD -(X.|WORDS|WORD|Y.)S WORDS y $1 WORD -(foo|fool|x.|money|parted)$ fool y $1 fool -(x.|foo|fool|x.|money|parted|y.)$ fool y $1 fool -(foo|fool|money|parted)$ fool y $1 fool -(foo|fool|x.|money|parted)$ fools n - - -(x.|foo|fool|x.|money|parted|y.)$ fools n - - -(foo|fool|money|parted)$ fools n - - -(a|aa|aaa||aaaa|aaaaa|aaaaaa)(b|c) aaaaaaaaaaaaaaab y $1$2 aaaaaab -(a|aa|aaa||aaaa|aaaaa|aaaaaa)(??{$1&&""})(b|c) aaaaaaaaaaaaaaab y $1$2 aaaaaab -(a|aa|aaa|aaaa|aaaaa|aaaaaa)(??{$1&&"foo"})(b|c) aaaaaaaaaaaaaaab n - - -^(a*?)(?!(aa|aaaa)*$) aaaaaaaaaaaaaaaaaaaa y $1 a # [perl #34195] -^(a*?)(?!(aa|aaaa)*$)(?=a\z) aaaaaaaa y $1 aaaaaaa -^(.)\s+.$(?(1)) A B y $1 A # [perl #37688] -(?:r?)*?r|(.{2,4}) abcde y $1 abcd -(?!)+?|(.{2,4}) abcde y $1 abcd -^(a*?)(?!(a{6}|a{5})*$) aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa y $+[1] 12 # super-linear cache bug may return 18 -^((?>(?:aa)?b)?) aab y $1 aab -^((?:aa)*)(?:X+((?:\d+|-)(?:X+(.+))?))?$ aaaaX5 y $1 aaaa -X(A|B||C|D)Y XXXYYY y $& XY # Trie w/ NOTHING -(?i:X([A]|[B]|y[Y]y|[D]|)Y) XXXYYYB y $& XY # Trie w/ NOTHING -^([a]{1})*$ aa y $1 a -a(?!b(?!c))(..) abababc y $1 bc # test nested negatives -a(?!b(?=a))(..) abababc y $1 bc # test nested lookaheads -a(?!b(?!c(?!d(?!e))))...(.) abxabcdxabcde y $1 e -X(?!b+(?!(c+)*(?!(c+)*d))).*X aXbbbbbbbcccccccccccccaaaX y - - -^(XXXXXXXXXX|YYYYYYYYYY|Z.Q*X|Z[TE]Q*P): ZEQQQQQQQQQQQQQQQQQQP: y $1 ZEQQQQQQQQQQQQQQQQQQP -^(XXXXXXXXXX|YYYYYYYYYY|Z.Q*X|Z[TE]Q*P): ZEQQQX: y $1 ZEQQQX -^([TUV]+|XXXXXXXXXX|YYYYYYYYYY|Z.Q*X|Z[TE]Q*P): ZEQQQQQQQQQQQQQQQQQQP: y $1 ZEQQQQQQQQQQQQQQQQQQP -^([TUV]+|XXXXXXXXXX|YYYYYYYYYY|Z.Q*X|Z[TE]Q*P): ZEQQQX: y $1 ZEQQQX -^([TUV]+|XXXXXXXXXX|YYYYYYYYYY|Z.Q*X|Z[TE]Q*P|[MKJ]): ZEQQQQQQQQQQQQQQQQQQP: y $1 ZEQQQQQQQQQQQQQQQQQQP -^([TUV]+|XXXXXXXXXX|YYYYYYYYYY|Z.Q*X|Z[TE]Q*P|[MKJ]): ZEQQQX: y $1 ZEQQQX -^(XXX|YYY|Z.Q*X|Z[TE]Q*P): ZEQQQQQQQQQQQQQQQQQQP: y $1 ZEQQQQQQQQQQQQQQQQQQP -^(XXX|YYY|Z.Q*X|Z[TE]Q*P): ZEQQQX: y $1 ZEQQQX -^([TUV]+|XXX|YYY|Z.Q*X|Z[TE]Q*P): ZEQQQQQQQQQQQQQQQQQQP: y $1 ZEQQQQQQQQQQQQQQQQQQP -^([TUV]+|XXX|YYY|Z.Q*X|Z[TE]Q*P): ZEQQQX: y $1 ZEQQQX -^([TUV]+|XXX|YYY|Z.Q*X|Z[TE]Q*P|[MKJ]): ZEQQQQQQQQQQQQQQQQQQP: y $1 ZEQQQQQQQQQQQQQQQQQQP -^([TUV]+|XXX|YYY|Z.Q*X|Z[TE]Q*P|[MKJ]): ZEQQQX: y $1 ZEQQQX -X(?:ABCF[cC]x*|ABCD|ABCF):(?:DIT|DID|DIM) XABCFCxxxxxxxxxx:DIM y $& XABCFCxxxxxxxxxx:DIM -(((ABCD|ABCE|ABCF)))(A|B|C[xy]*): ABCFCxxxxxxxxxx:DIM y $& ABCFCxxxxxxxxxx: -(?=foo) foo y pos 0 -(?=foo) XfooY y pos 1 -.*(?=foo) XfooY y pos 1 -(?<=foo) foo y pos 3 -(?<=foo) XfooY y pos 4 -.*(?<=foo) foo y pos 3 -.*(?<=foo) XfooY y pos 4 -(?<=foo)Y XfooY y pos 5 -o(?<=foo)Y ..XfooY.. y pos 7 -X(?=foo)f ..XfooY.. y pos 4 -X(?=foo) ..XfooY.. y pos 3 -X(?<=foo.)[YZ] ..XfooXY.. y pos 8 -(?=XY*foo) Xfoo y pos 0 -^(?=XY*foo) Xfoo y pos 0 -^(??{"a+"})a aa y $& aa -^(?:(??{"a+"})|b)a aa y $& aa -^(??{chr 0x100}).$ \x{100}\x{100} y $& \x{100}\x{100} -^(??{q(\x{100})}). \x{100}\x{100} y $& \x{100}\x{100} -^(??{q(.+)})\x{100} \x{100}\x{100} y $& \x{100}\x{100} -^(??{q(.)})\x{100} \x{100}\x{100} y $& \x{100}\x{100} -^(??{chr 0x100})\xbb \x{100}\x{bb} y $& \x{100}\x{bb} -^(.)(??{"(.)(.)"})(.)$ abcd y $1-$2 a-d -^(.)(??{"(bz+|.)(.)"})(.)$ abcd y $1-$2 a-d -^(.)((??{"(.)(cz+)"})|.) abcd y $1-$2 a-b -^a(?>(??{q(b)}))(??{q(c)})d abcd y - - -^x(??{""})+$ x y $& x -^(<(?:[^<>]+|(?3)|(?1))*>)()(!>!>!>)$ <!>!>><>>!>!>!> y $1 <!>!>><>> -^(<(?:[^<>]+|(?1))*>)$ <<><<<><>>>> y $1 <<><<<><>>>> -((?2)*)([fF]o+) fooFoFoo y $1-$2 fooFo-Foo -(<(?:[^<>]+|(?R))*>) <<><<<><>>>> y $1 <<><<<><>>>> -(?foo|bar|baz) snofooewa y $1 foo -(?foo|bar|baz) snofooewa yM $+{n} foo miniperl cannot load Tie::Hash::NamedCapture -(?foo|bar|baz)(?[ew]+) snofooewa yM $+{n} foo miniperl cannot load Tie::Hash::NamedCapture -(?foo|bar|baz)(?[ew]+) snofooewa yM $+{m} ew miniperl cannot load Tie::Hash::NamedCapture -(?foo)|(?bar)|(?baz) snofooewa yM $+{n} foo miniperl cannot load Tie::Hash::NamedCapture -(?foo)(??{ $+{n} }) snofooefoofoowaa yM $+{n} foo miniperl cannot load Tie::Hash::NamedCapture -(?Pfoo|bar|baz) snofooewa y $1 foo -(?Pfoo|bar|baz) snofooewa yM $+{n} foo miniperl cannot load Tie::Hash::NamedCapture -(?Pfoo|bar|baz)(?P[ew]+) snofooewa yM $+{n} foo miniperl cannot load Tie::Hash::NamedCapture -(?Pfoo|bar|baz)(?P[ew]+) snofooewa yM $+{m} ew miniperl cannot load Tie::Hash::NamedCapture -(?Pfoo)|(?Pbar)|(?Pbaz) snofooewa yM $+{n} foo miniperl cannot load Tie::Hash::NamedCapture -(?Pfoo)(??{ $+{n} }) snofooefoofoowaa yM $+{n} foo miniperl cannot load Tie::Hash::NamedCapture -(?P<=n>foo|bar|baz) snofooewa c - Sequence (?P<=...) not recognized -(?Pfoo|bar|baz) snofooewa c - Sequence (?Pfoo|bar|baz) snofooewa c - Sequence (?PX<...) not recognized -/(?'n'foo|bar|baz)/ snofooewa y $1 foo -/(?'n'foo|bar|baz)/ snofooewa yM $+{n} foo miniperl cannot load Tie::Hash::NamedCapture -/(?'n'foo|bar|baz)(?'m'[ew]+)/ snofooewa yM $+{n} foo miniperl cannot load Tie::Hash::NamedCapture -/(?'n'foo|bar|baz)(?'m'[ew]+)/ snofooewa yM $+{m} ew miniperl cannot load Tie::Hash::NamedCapture -/(?'n'foo)|(?'n'bar)|(?baz)/ snobazewa yM $+{n} baz miniperl cannot load Tie::Hash::NamedCapture -/(?'n'foo)(??{ $+{n} })/ snofooefoofoowaa yM $+{n} foo miniperl cannot load Tie::Hash::NamedCapture -/(?'n'foo)\k/ ..foofoo.. y $1 foo -/(?'n'foo)\k/ ..foofoo.. yM $+{n} foo miniperl cannot load Tie::Hash::NamedCapture -/(?foo)\k'n'/ ..foofoo.. y $1 foo -/(?foo)\k'n'/ ..foofoo.. yM $+{n} foo miniperl cannot load Tie::Hash::NamedCapture -/(?:(?foo)|(?bar))\k/ ..barbar.. yM $+{n} bar miniperl cannot load Tie::Hash::NamedCapture -/^(?'main'<(?:[^<>]+|(?&crap)|(?&main))*>)(?'empty')(?'crap'!>!>!>)$/ <!>!>><>>!>!>!> yM $+{main} <!>!>><>> miniperl cannot load Tie::Hash::NamedCapture -/^(?'main'<(?:[^<>]+|(?&main))*>)$/ <<><<<><>>>> y $1 <<><<<><>>>> -/(?'first'(?&second)*)(?'second'[fF]o+)/ fooFoFoo yM $+{first}-$+{second} fooFo-Foo miniperl cannot load Tie::Hash::NamedCapture -(?foo)?(?()bar|nada) foobar yM $+{A} foo miniperl cannot load Tie::Hash::NamedCapture -(?foo)?(?()bar|nada) foo-barnada y $& nada -(?foo)?(?(1)bar|nada) foo-barnada y $& nada -(?foo(?(R)bar))?(?1) foofoobar y $1 foo -(?foo(?(R)bar))?(?1) foofoobar y $& foofoobar -(x)(?foo(?(R&A)bar))?(?&A) xfoofoobar y $2 foo -(x)(?foo(?(R&A)bar))?(?&A) xfoofoobar y $& xfoofoobar -(x)(?foo(?(R2)bar))?(?&A) xfoofoobar y $2 foo -(x)(?foo(?(R2)bar))?(?&A) xfoofoobar y $& xfoofoobar -(?1)(?(DEFINE)(blah)) blah y $& blah -/^(?(?.)((?&PAL)|.?)\k)$/ madamimadam y $& madamimadam -/^(?(?.)((?&PAL)|.?)\k)$/ madamiamadam n - - -/(a)?((?1))(fox)/ aafox y $1-$2-$3 a-a-fox -/(a)*((?1))(fox)/ aafox y $1-$2-$3 a-a-fox -/(a)+((?1))(fox)/ aafox y $1-$2-$3 a-a-fox -/(a){1,100}((?1))(fox)/ aafox y $1-$2-$3 a-a-fox -/(a){0,100}((?1))(fox)/ aafox y $1-$2-$3 a-a-fox -/(ab)?((?1))(fox)/ ababfox y $1-$2-$3 ab-ab-fox -/(ab)*((?1))(fox)/ ababfox y $1-$2-$3 ab-ab-fox -/(ab)+((?1))(fox)/ ababfox y $1-$2-$3 ab-ab-fox -/(ab){1,100}((?1))(fox)/ ababfox y $1-$2-$3 ab-ab-fox -/(ab){0,100}((?1))(fox)/ ababfox y $1-$2-$3 ab-ab-fox -# possessive captures -a++a aaaaa n - - -a*+a aaaaa n - - -a{1,5}+a aaaaa n - - -a?+a ab n - - -a++b aaaaab y $& aaaaab -a*+b aaaaab y $& aaaaab -a{1,5}+b aaaaab y $& aaaaab -a?+b ab y $& ab -fooa++a fooaaaaa n - - -fooa*+a fooaaaaa n - - -fooa{1,5}+a fooaaaaa n - - -fooa?+a fooab n - - -fooa++b fooaaaaab y $& fooaaaaab -fooa*+b fooaaaaab y $& fooaaaaab -fooa{1,5}+b fooaaaaab y $& fooaaaaab -fooa?+b fooab y $& fooab -(?:aA)++(?:aA) aAaAaAaAaA n - aAaAaAaAaA -(aA)++(aA) aAaAaAaAaA n - aAaAaAaAaA -(aA|bB)++(aA|bB) aAaAbBaAbB n - aAaAbBaAbB -(?:aA|bB)++(?:aA|bB) aAbBbBbBaA n - aAbBbBbBaA -(?:aA)*+(?:aA) aAaAaAaAaA n - aAaAaAaAaA -(aA)*+(aA) aAaAaAaAaA n - aAaAaAaAaA -(aA|bB)*+(aA|bB) aAaAbBaAaA n - aAaAbBaAaA -(?:aA|bB)*+(?:aA|bB) aAaAaAbBaA n - aAaAaAbBaA -(?:aA){1,5}+(?:aA) aAaAaAaAaA n - aAaAaAaAaA -(aA){1,5}+(aA) aAaAaAaAaA n - aAaAaAaAaA -(aA|bB){1,5}+(aA|bB) aAaAbBaAaA n - aAaAbBaAaA -(?:aA|bB){1,5}+(?:aA|bB) bBbBbBbBbB n - bBbBbBbBbB -(?:aA)?+(?:aA) aAb n - aAb -(aA)?+(aA) aAb n - aAb -(aA|bB)?+(aA|bB) bBb n - bBb -(?:aA|bB)?+(?:aA|bB) aAb n - aAb -(?:aA)++b aAaAaAaAaAb y $& aAaAaAaAaAb -(aA)++b aAaAaAaAaAb y $& aAaAaAaAaAb -(aA|bB)++b aAbBaAaAbBb y $& aAbBaAaAbBb -(?:aA|bB)++b aAbBbBaAaAb y $& aAbBbBaAaAb -(?:aA)*+b aAaAaAaAaAb y $& aAaAaAaAaAb -(aA)*+b aAaAaAaAaAb y $& aAaAaAaAaAb -(aA|bB)*+b bBbBbBbBbBb y $& bBbBbBbBbBb -(?:aA|bB)*+b bBaAbBbBaAb y $& bBaAbBbBaAb -(?:aA){1,5}+b aAaAaAaAaAb y $& aAaAaAaAaAb -(aA){1,5}+b aAaAaAaAaAb y $& aAaAaAaAaAb -(aA|bB){1,5}+b bBaAbBaAbBb y $& bBaAbBaAbBb -(?:aA|bB){1,5}+b aAbBaAbBbBb y $& aAbBaAbBbBb -(?:aA)?+b aAb y $& aAb -(aA)?+b aAb y $& aAb -(aA|bB)?+b bBb y $& bBb -(?:aA|bB)?+b bBb y $& bBb -foo(?:aA)++(?:aA) fooaAaAaAaAaA n - fooaAaAaAaAaA -foo(aA)++(aA) fooaAaAaAaAaA n - fooaAaAaAaAaA -foo(aA|bB)++(aA|bB) foobBbBbBaAaA n - foobBbBbBaAaA -foo(?:aA|bB)++(?:aA|bB) fooaAaAaAaAaA n - fooaAaAaAaAaA -foo(?:aA)*+(?:aA) fooaAaAaAaAaA n - fooaAaAaAaAaA -foo(aA)*+(aA) fooaAaAaAaAaA n - fooaAaAaAaAaA -foo(aA|bB)*+(aA|bB) foobBaAbBaAaA n - foobBaAbBaAaA -foo(?:aA|bB)*+(?:aA|bB) fooaAaAbBbBaA n - fooaAaAbBbBaA -foo(?:aA){1,5}+(?:aA) fooaAaAaAaAaA n - fooaAaAaAaAaA -foo(aA){1,5}+(aA) fooaAaAaAaAaA n - fooaAaAaAaAaA -foo(aA|bB){1,5}+(aA|bB) fooaAbBbBaAaA n - fooaAbBbBaAaA -foo(?:aA|bB){1,5}+(?:aA|bB) fooaAbBbBaAbB n - fooaAbBbBaAbB -foo(?:aA)?+(?:aA) fooaAb n - fooaAb -foo(aA)?+(aA) fooaAb n - fooaAb -foo(aA|bB)?+(aA|bB) foobBb n - foobBb -foo(?:aA|bB)?+(?:aA|bB) fooaAb n - fooaAb -foo(?:aA)++b fooaAaAaAaAaAb y $& fooaAaAaAaAaAb -foo(aA)++b fooaAaAaAaAaAb y $& fooaAaAaAaAaAb -foo(aA|bB)++b foobBaAbBaAbBb y $& foobBaAbBaAbBb -foo(?:aA|bB)++b fooaAaAbBaAaAb y $& fooaAaAbBaAaAb -foo(?:aA)*+b fooaAaAaAaAaAb y $& fooaAaAaAaAaAb -foo(aA)*+b fooaAaAaAaAaAb y $& fooaAaAaAaAaAb -foo(aA|bB)*+b foobBbBaAaAaAb y $& foobBbBaAaAaAb -foo(?:aA|bB)*+b foobBaAaAbBaAb y $& foobBaAaAbBaAb -foo(?:aA){1,5}+b fooaAaAaAaAaAb y $& fooaAaAaAaAaAb -foo(aA){1,5}+b fooaAaAaAaAaAb y $& fooaAaAaAaAaAb -foo(aA|bB){1,5}+b foobBaAaAaAaAb y $& foobBaAaAaAaAb -foo(?:aA|bB){1,5}+b fooaAbBaAbBbBb y $& fooaAbBaAbBbBb -foo(?:aA)?+b fooaAb y $& fooaAb -foo(aA)?+b fooaAb y $& fooaAb -foo(aA|bB)?+b foobBb y $& foobBb -foo(?:aA|bB)?+b foobBb y $& foobBb - -([^()]++|\([^()]*\))+ ((abc(ade)ufh()()x y $& abc(ade)ufh()()x -round\(([^()]++)\) _I(round(xs * sz),1) y $1 xs * sz - -(foo[1x]|bar[2x]|baz[3x])+y foo1bar2baz3y y $1 baz3 -(foo[1x]|bar[2x]|baz[3x])+y foo1bar2baz3y y $& foo1bar2baz3y -(foo[1x]|bar[2x]|baz[3x])*y foo1bar2baz3y y $1 baz3 -(foo[1x]|bar[2x]|baz[3x])*y foo1bar2baz3y y $& foo1bar2baz3y - -([yX].|WORDS|[yX].|WORD)S WORDS y $1 WORD -(WORDS|WORLD|WORD)S WORDS y $1 WORD -([yX].|WORDS|WORD|[xY].)S WORDS y $1 WORD -(foo|fool|[zx].|money|parted)$ fool y $1 fool -([zx].|foo|fool|[zq].|money|parted|[yx].)$ fool y $1 fool -(foo|fool|[zx].|money|parted)$ fools n - - -([zx].|foo|fool|[qx].|money|parted|[py].)$ fools n - - - -([yX].|WORDS|[yX].|WORD)+S WORDS y $1 WORD -(WORDS|WORLD|WORD)+S WORDS y $1 WORD -([yX].|WORDS|WORD|[xY].)+S WORDS y $1 WORD -(foo|fool|[zx].|money|parted)+$ fool y $1 fool -([zx].|foo|fool|[zq].|money|parted|[yx].)+$ fool y $1 fool -(foo|fool|[zx].|money|parted)+$ fools n - - -([zx].|foo|fool|[qx].|money|parted|[py].)+$ fools n - - - -(x|y|z[QW])+(longish|loquatious|excessive|overblown[QW])+ xyzQzWlongishoverblownW y $1-$2 zW-overblownW -(x|y|z[QW])*(longish|loquatious|excessive|overblown[QW])* xyzQzWlongishoverblownW y $1-$2 zW-overblownW -(x|y|z[QW]){1,5}(longish|loquatious|excessive|overblown[QW]){1,5} xyzQzWlongishoverblownW y $1-$2 zW-overblownW - -(x|y|z[QW])++(longish|loquatious|excessive|overblown[QW])++ xyzQzWlongishoverblownW y $1-$2 zW-overblownW -(x|y|z[QW])*+(longish|loquatious|excessive|overblown[QW])*+ xyzQzWlongishoverblownW y $1-$2 zW-overblownW -(x|y|z[QW]){1,5}+(longish|loquatious|excessive|overblown[QW]){1,5}+ xyzQzWlongishoverblownW y $1-$2 zW-overblownW - -a*(?!) aaaab n - - -a*(*FAIL) aaaab n - - -a*(*F) aaaab n - - - -(A(A|B(*ACCEPT)|C)D)(E) AB y $1 AB -(A(A|B(*ACCEPT)|C)D)(E) ACDE y $1$2$3 ACDCE - -(a)(?:(?-1)|(?+1))(b) aab y $&-$1-$2 aab-a-b -(a)(?:(?-1)|(?+1))(b) abb y $1-$2 a-b -(a)(?:(?-1)|(?+1))(b) acb n - - - -(foo)(\g-2) foofoo y $1-$2 foo-foo -(foo)(\g-2)(foo)(\g-2) foofoofoofoo y $1-$2-$3-$4 foo-foo-foo-foo -(([abc]+) \g-1)(([abc]+) \g{-1}) abc abccba cba y $2-$4 abc-cba -(a)(b)(c)\g1\g2\g3 abcabc y $1$2$3 abc - -# \k preceded by a literal -/(?'n'foo) \k/ ..foo foo.. y $1 foo -/(?'n'foo) \k/ ..foo foo.. yM $+{n} foo miniperl cannot load Tie::Hash::NamedCapture -/(?foo) \k'n'/ ..foo foo.. y $1 foo -/(?foo) \k'n'/ ..foo foo.. yM $+{n} foo miniperl cannot load Tie::Hash::NamedCapture -/(?'a1'foo) \k'a1'/ ..foo foo.. yM $+{a1} foo miniperl cannot load Tie::Hash::NamedCapture -/(?foo) \k/ ..foo foo.. yM $+{a1} foo miniperl cannot load Tie::Hash::NamedCapture -/(?'_'foo) \k'_'/ ..foo foo.. yM $+{_} foo miniperl cannot load Tie::Hash::NamedCapture -/(?<_>foo) \k<_>/ ..foo foo.. yM $+{_} foo miniperl cannot load Tie::Hash::NamedCapture -/(?'_0_'foo) \k'_0_'/ ..foo foo.. yM $+{_0_} foo miniperl cannot load Tie::Hash::NamedCapture -/(?<_0_>foo) \k<_0_>/ ..foo foo.. yM $+{_0_} foo miniperl cannot load Tie::Hash::NamedCapture -/(?'0'foo) bar/ ..foo bar.. c - Sequence (?' -/(?<0>foo) bar/ ..foo bar.. c - Sequence (?< -/(?'12'foo) bar/ ..foo bar.. c - Sequence (?' -/(?<12>foo) bar/ ..foo bar.. c - Sequence (?< -/(?'1a'foo) bar/ ..foo bar.. c - Sequence (?' -/(?<1a>foo) bar/ ..foo bar.. c - Sequence (?< -/(?''foo) bar/ ..foo bar.. c - Sequence (?'' -/(?<>foo) bar/ ..foo bar.. c - Sequence (?<> -/foo \k'n'/ foo foo c - Reference to nonexistent named group -/foo \k/ foo foo c - Reference to nonexistent named group -/foo \k'a1'/ foo foo c - Reference to nonexistent named group -/foo \k/ foo foo c - Reference to nonexistent named group -/foo \k'_'/ foo foo c - Reference to nonexistent named group -/foo \k<_>/ foo foo c - Reference to nonexistent named group -/foo \k'_0_'/ foo foo c - Reference to nonexistent named group -/foo \k<_0_>/ foo foo c - Reference to nonexistent named group -/foo \k'0'/ foo foo c - Sequence \\k' -/foo \k<0>/ foo foo c - Sequence \\k< -/foo \k'12'/ foo foo c - Sequence \\k' -/foo \k<12>/ foo foo c - Sequence \\k< -/foo \k'1a'/ foo foo c - Sequence \\k' -/foo \k<1a>/ foo foo c - Sequence \\k< -/foo \k''/ foo foo c - Sequence \\k' -/foo \k<>/ foo foo c - Sequence \\k< -/(?as) (\w+) \k (\w+)/ as easy as pie y $1-$2-$3 as-easy-pie - -# \g{...} with a name as the argument -/(?'n'foo) \g{n}/ ..foo foo.. y $1 foo -/(?'n'foo) \g{n}/ ..foo foo.. yM $+{n} foo miniperl cannot load Tie::Hash::NamedCapture -/(?foo) \g{n}/ ..foo foo.. y $1 foo -/(?foo) \g{n}/ ..foo foo.. yM $+{n} foo miniperl cannot load Tie::Hash::NamedCapture -/(?as) (\w+) \g{as} (\w+)/ as easy as pie y $1-$2-$3 as-easy-pie - -# Python style named capture buffer stuff -/(?Pfoo)(?P=n)/ ..foofoo.. y $1 foo -/(?Pfoo)(?P=n)/ ..foofoo.. yM $+{n} foo miniperl cannot load Tie::Hash::NamedCapture -/(?:(?Pfoo)|(?Pbar))(?P=n)/ ..barbar.. yM $+{n} bar miniperl cannot load Tie::Hash::NamedCapture -/^(?P(?P.)((?P>PAL)|.?)(?P=CHAR))$/ madamimadam y $& madamimadam -/^(?P(?P.)((?P>PAL)|.?)(?P=CHAR))$/ madamiamadam n - - -/(?Pfoo) (?P=n)/ ..foo foo.. y $1 foo -/(?Pfoo) (?P=n)/ ..foo foo.. yM $+{n} foo miniperl cannot load Tie::Hash::NamedCapture -/(?Pas) (\w+) (?P=as) (\w+)/ as easy as pie y $1-$2-$3 as-easy-pie - -#check that non identifiers as names are treated as the appropriate lookaround -(?<=bar>)foo bar>foo y $& foo -(?)foo bar>foo n - - -(?<=bar>ABC)foo bar>ABCfoo y $& foo -(?ABC)foo bar>ABCfoo n - - -(?)foo bar>ABCfoo y $& foo -(?ABC)foo bar>ABCfoo y $& ABCfoo - -(?<=abcd(?<=(aaaabcd))) ..aaaabcd.. y $1 aaaabcd -(?=xy(?<=(aaxy))) ..aaxy.. y $1 aaxy - -X(\w+)(?=\s)|X(\w+) Xab y [$1-$2] [-ab] - -#check that branch reset works ok. -(?|(a)) a y $1-$+-$^N a-a-a -(?|a(.)b|d(.(o).)d|i(.)(.)j)(.) d!o!da y $1-$2-$3 !o!-o-a -(?|a(.)b|d(.(o).)d|i(.)(.)j)(.) aabc y $1-$2-$3 a--c -(?|a(.)b|d(.(o).)d|i(.)(.)j)(.) ixyjp y $1-$2-$3 x-y-p -(?|(?|(a)|(b))|(?|(c)|(d))) a y $1 a -(?|(?|(a)|(b))|(?|(c)|(d))) b y $1 b -(?|(?|(a)|(b))|(?|(c)|(d))) c y $1 c -(?|(?|(a)|(b))|(?|(c)|(d))) d y $1 d -(.)(?|(.)(.)x|(.)d)(.) abcde y $1-$2-$3-$4-$5- b-c--e-- -(\N)(?|(\N)(\N)x|(\N)d)(\N) abcde y $1-$2-$3-$4-$5- b-c--e-- -(?|(?x)) x yM $+{foo} x miniperl cannot load Tie::Hash::NamedCapture -(?|(?x)|(?y)) x yM $+{foo} x miniperl cannot load Tie::Hash::NamedCapture -(?|(?y)|(?x)) x yM $+{foo} x miniperl cannot load Tie::Hash::NamedCapture -(?)(?|(?x)) x yM $+{foo} x miniperl cannot load Tie::Hash::NamedCapture -# Used to crash, because the last branch was ignored when the parens -# were counted: -(?|(b)|()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()(a)) a y $& a - -#Bug #41492 -(?(DEFINE)(?(?&B)+)(?a))(?&A) a y $& a -(?(DEFINE)(?(?&B)+)(?a))(?&A) aa y $& aa -\x{100}?(??{""})xxx xxx y $& xxx - -foo(\R)bar foo\r\nbar y $1 \r\n -foo(\R)bar foo\nbar y $1 \n -foo(\R)bar foo\rbar y $1 \r - -foo(\R+)bar foo\r\n\x{85}\r\n\nbar y $1 \r\n\x{85}\r\n\n -(\V+)(\R) foo\r\n\x{85}\r\n\nbar y $1-$2 foo-\r\n -(\R+)(\V) foo\r\n\x{85}\r\n\nbar y $1-$2 \r\n\x{85}\r\n\n-b -foo(\R)bar foo\x{85}bar y $1 \x{85} -(\V)(\R) foo\x{85}bar y $1-$2 o-\x{85} -(\R)(\V) foo\x{85}bar y $1-$2 \x{85}-b -foo(\R)bar foo\r\nbar y $1 \r\n -(\V)(\R) foo\r\nbar y $1-$2 o-\r\n -(\R)(\V) foo\r\nbar y $1-$2 \r\n-b -foo(\R)bar foo\r\nbar y $1 \r\n -(\V)(\R) foo\r\nbar y $1-$2 o-\r\n -(\R)(\V) foo\r\nbar y $1-$2 \r\n-b -foo(\R)bar foo\rbar y $1 \r -(\V)(\R) foo\rbar y $1-$2 o-\r -(\R)(\V) foo\rbar y $1-$2 \r-b - -foo(\v+)bar foo\r\n\x{85}\r\n\nbar y $1 \r\n\x{85}\r\n\n -(\V+)(\v) foo\r\n\x{85}\r\n\nbar y $1-$2 foo-\r -(\v+)(\V) foo\r\n\x{85}\r\n\nbar y $1-$2 \r\n\x{85}\r\n\n-b -foo(\v)bar foo\x{85}bar y $1 \x{85} -(\V)(\v) foo\x{85}bar y $1-$2 o-\x{85} -(\v)(\V) foo\x{85}bar y $1-$2 \x{85}-b -foo(\v)bar foo\rbar y $1 \r -(\V)(\v) foo\rbar y $1-$2 o-\r -(\v)(\V) foo\rbar y $1-$2 \r-b - - -foo(\h+)bar foo\t\x{A0}bar y $1 \t\x{A0} -(\H+)(\h) foo\t\x{A0}bar y $1-$2 foo-\t -(\h+)(\H) foo\t\x{A0}bar y $1-$2 \t\x{A0}-b -foo(\h)bar foo\x{A0}bar y $1 \x{A0} -(\H)(\h) foo\x{A0}bar y $1-$2 o-\x{A0} -(\h)(\H) foo\x{A0}bar y $1-$2 \x{A0}-b -foo(\h)bar foo\tbar y $1 \t -(\H)(\h) foo\tbar y $1-$2 o-\t -(\h)(\H) foo\tbar y $1-$2 \t-b - -.*\z foo\n y -$&- -- -\N*\z foo\n y -$&- -- -.*\Z foo\n y -$&- -foo- -\N*\Z foo\n y -$&- -foo- -^(?:(\d)x)?\d$ 1 y ${\(defined($1)?1:0)} 0 -.*?(?:(\w)|(\w))x abx y $1-$2 b- - -0{50} 000000000000000000000000000000000000000000000000000 y - - -^a?(?=b)b ab y $& ab # Bug #56690 -^a*(?=b)b ab y $& ab # Bug #56690 -/>\d+$ \n/ix >10\n y $& >10 -/>\d+$ \n/ix >1\n y $& >1 -/\d+$ \n/ix >10\n y $& 10 -/>\d\d$ \n/ix >10\n y $& >10 -/>\d+$ \n/x >10\n y $& >10 - -# Two regressions in 5.8.x (only) introduced by change 30638 -# Simplification of the test failure in XML::LibXML::Simple: -/^\s*i.*?o\s*$/s io\n io y - - -# As reported in #59168 by Father Chrysostomos: -/(.*?)a(?!(a+)b\2c)/ baaabaac y $&-$1 baa-ba -# [perl #60344] Regex lookbehind failure after an (if)then|else in perl 5.10 -/\A(?(?=db2)db2|\D+)(? 1; - -{ - my $expect = <<"EXPECT"; -k1 = .... -k2.1 = >\x{2022} -k2.2 = \x{2022} -EXPECT - utf8::encode($expect); - - #local $TODO = "[perl #60508]"; - - fresh_perl_is(<<'CODE', $expect, {}); -binmode STDOUT, ":utf8"; -sub f { $_[0] =~ s/([>X])//g; } - -$k1 = "." x 4 . ">>"; -f($k1); -print "k1 = $k1\n"; - -$k2 = "\x{f1}\x{2022}"; -$k2 =~ s/([\360-\362])/>/g; -print "k2.1 = $k2\n"; -f($k2); -print "k2.2 = $k2\n"; -CODE -} diff --git a/t/CORE/re/reg_email.t b/t/CORE/re/reg_email.t deleted file mode 100644 index 896c2ab0c..000000000 --- a/t/CORE/re/reg_email.t +++ /dev/null @@ -1,102 +0,0 @@ -#!./perl -w -# -# Tests to make sure the regexp engine doesn't run into limits too soon. -# - -BEGIN { - require q(t/CORE/test.pl); -} - -use strict; - -my $email = qr { - (?(DEFINE) - (?
(?&mailbox) | (?&group)) - (? (?&name_addr) | (?&addr_spec)) - (? (?&display_name)? (?&angle_addr)) - (? (?&CFWS)? < (?&addr_spec) > (?&CFWS)?) - (? (?&display_name) : (?:(?&mailbox_list) | (?&CFWS))? ; - (?&CFWS)?) - (? (?&phrase)) - (? (?&mailbox) (?: , (?&mailbox))*) - - (? (?&local_part) \@ (?&domain)) - (? (?&dot_atom) | (?"ed_string)) - (? (?&dot_atom) | (?&domain_literal)) - (? (?&CFWS)? \[ (?: (?&FWS)? (?&dcontent))* (?&FWS)? - \] (?&CFWS)?) - (? (?&dtext) | (?"ed_pair)) - (? (?&NO_WS_CTL) | [\x21-\x5a\x5e-\x7e]) - - (? (?&ALPHA) | (?&DIGIT) | [!#\$%&'*+-/=?^_`{|}~]) - (? (?&CFWS)? (?&atext)+ (?&CFWS)?) - (? (?&CFWS)? (?&dot_atom_text) (?&CFWS)?) - (? (?&atext)+ (?: \. (?&atext)+)*) - - (? [\x01-\x09\x0b\x0c\x0e-\x7f]) - (? \\ (?&text)) - - (? (?&NO_WS_CTL) | [\x21\x23-\x5b\x5d-\x7e]) - (? (?&qtext) | (?"ed_pair)) - (? (?&CFWS)? (?&DQUOTE) (?:(?&FWS)? (?&qcontent))* - (?&FWS)? (?&DQUOTE) (?&CFWS)?) - - (? (?&atom) | (?"ed_string)) - (? (?&word)+) - - # Folding white space - (? (?: (?&WSP)* (?&CRLF))? (?&WSP)+) - (? (?&NO_WS_CTL) | [\x21-\x27\x2a-\x5b\x5d-\x7e]) - (? (?&ctext) | (?"ed_pair) | (?&comment)) - (? \( (?: (?&FWS)? (?&ccontent))* (?&FWS)? \) ) - (? (?: (?&FWS)? (?&comment))* - (?: (?:(?&FWS)? (?&comment)) | (?&FWS))) - - # No whitespace control - (? [\x01-\x08\x0b\x0c\x0e-\x1f\x7f]) - - (? [A-Za-z]) - (? [0-9]) - (? \x0d \x0a) - (? ") - (? [\x20\x09]) - ) - - (?&address) -}x; - -run_tests() unless caller; - -sub run_tests { - # rewinding DATA is necessary with PERLIO=stdio when this - # test is run from another thread - seek *DATA, 0, 0; - while () { last if /^__DATA__/ } - while () { - chomp; - next if /^#/; - like($_, qr/^$email$/, $_); - } - - done_testing(); -} - -1; # Because reg_email_thr.t will (indirectly) require this script. - -# -# Acme::MetaSyntactic ++ -# -__DATA__ -Jeff_Tracy@thunderbirds.org -"Lady Penelope"@thunderbirds.org -"The\ Hood"@thunderbirds.org -fred @ flintstones.net -barney (rubble) @ flintstones.org -bammbamm (bam! bam! (bam! bam! (bam!)) bam!) @ flintstones.org -Michelangelo@[127.0.0.1] -Donatello @ [127.0.0.1] -Raphael (He as well) @ [127.0.0.1] -"Leonardo" @ [127.0.0.1] -Barbapapa -"Barba Mama" -Barbalala (lalalalalalalala) diff --git a/t/CORE/re/reg_eval.t b/t/CORE/re/reg_eval.t deleted file mode 100644 index 59bf6cbaf..000000000 --- a/t/CORE/re/reg_eval.t +++ /dev/null @@ -1,85 +0,0 @@ -#!./perl - -# This is a test for bugs in (?{ }) and (??{ }) caused by corrupting the regex -# engine state within the eval-ed code -# --rafl - -BEGIN { - require q(t/CORE/test.pl); -} - -fresh_perl_is(<<'CODE', 'ok', {}); -'42' =~ /4(?{ 'foo' =~ m{(foo)} })2/ - and print 'ok'; -CODE - -fresh_perl_is(<<'CODE', 'ok', {}, 'RT#33936'); -'aba' =~ /(??{join('',split(qr{(?=)},'aba'))})/ - and print 'ok'; -CODE - -fresh_perl_is(<<'CODE', 'ok', {}, 'match vars are localized'); -my $x = 'aba'; -$x =~ s/(a)(?{ 'moo' =~ m{(o)} })/uc($1)/e; -print 'ok' if $x eq 'Aba'; -CODE - -my $preamble = <<'CODE'; -sub build_obj { - # In the real world we would die on validation fails, but RT#27838 - # is still unresolved, so don't tempt fate. - $hash->{name} =~ /^[A-Z][a-z]+ [A-Z][a-z]+$/ or return "name error"; - $hash->{age} =~ /^[1-9][0-9]*$/ or return "age error"; - - # Add another layer of (?{...}) to try really hard to break things - $hash->{square} =~ - /^(\d+)(?(?{my $sqrt = sprintf "%.0f", sqrt($^N); $sqrt**2==$^N })|(?!))$/ - or return "squareness error"; - - return bless { %$hash }, "Foo"; -} - -sub match { - my $str = shift; - our ($hash, $obj); - # Do something like Regexp::Grammars does building an object. - my $matched = $str =~ / - () - ([A-Za-z][A-Za-z ]*)(?{ local $hash->{name} = $^N }),[ ] - (\d+)(?{ local $hash->{age} = $^N })[ ]years[ ]old,[ ] - secret[ ]number[ ](\d+)(?{ local $hash->{square} = $^N }). - (?{ $obj = build_obj(); }) - /x; - - if ($matched) { - print "match "; - if (ref($obj)) { - print ref($obj), ":$obj->{name}:$obj->{age}:$obj->{square}"; - } else { - print $obj, ":$hash->{name}:$hash->{age}:$hash->{square}"; - } - } else { - print "no match $hash->{name}:$hash->{age}:$hash->{square}"; - } - -} -CODE - -fresh_perl_is($preamble . <<'CODE', 'match Foo:John Smith:42:36', {}, 'regex distillation 1'); -match("John Smith, 42 years old, secret number 36."); -CODE - -fresh_perl_is($preamble . <<'CODE', 'match Foo:John Smith:42:36', {}, 'regex distillation 2'); -match("Jim Jones, 35 years old, secret wombat 007." - ." John Smith, 42 years old, secret number 36."); -CODE - -fresh_perl_is($preamble . <<'CODE', 'match squareness error:::', {}, 'regex distillation 3'); -match("John Smith, 54 years old, secret number 7."); -CODE - -fresh_perl_is($preamble . <<'CODE', 'no match ::', {}, 'regex distillation 4'); -match("Jim Jones, 35 years old, secret wombat 007."); -CODE - -done_testing; diff --git a/t/CORE/re/reg_eval_scope.t b/t/CORE/re/reg_eval_scope.t deleted file mode 100644 index bdbd0fd63..000000000 --- a/t/CORE/re/reg_eval_scope.t +++ /dev/null @@ -1,155 +0,0 @@ -#!perl - -# Test scoping issues with embedded code in regexps. - -BEGIN { - require q(t/CORE/test.pl); -} - -plan 17; - -# Functions for turning to-do-ness on and off (as there are so many -# to-do tests) -sub on { $::TODO = "(?{}) implementation is screwy" } -sub off { undef $::TODO } - -on; - -fresh_perl_is <<'CODE', '781745', {}, '(?{}) has its own lexical scope'; - my $x = 7; my $a = 4; my $b = 5; - print "a" =~ /(?{ print $x; my $x = 8; print $x; my $y })a/; - print $x,$a,$b; -CODE - -fresh_perl_is <<'CODE', - for my $x("a".."c") { - $y = 1; - print scalar - "abcabc" =~ - / - ( - a (?{ print $y; local $y = $y+1; print $x; my $x = 8; print $x }) - b (?{ print $y; local $y = $y+1; print $x; my $x = 9; print $x }) - c (?{ print $y; local $y = $y+1; print $x; my $x = 10; print $x }) - ){2} - /x; - print "$x "; - } -CODE - '1a82a93a104a85a96a101a 1b82b93b104b85b96b101b 1c82c93c104c85c96c101c ', - {}, - 'multiple (?{})s in loop with lexicals'; - -fresh_perl_is <<'CODE', '781745', {}, 'run-time re-eval has its own scope'; - use re qw(eval); - my $x = 7; my $a = 4; my $b = 5; - my $rest = 'a'; - print "a" =~ /(?{ print $x; my $x = 8; print $x; my $y })$rest/; - print $x,$a,$b; -CODE - -fresh_perl_is <<'CODE', '178279371047857967101745', {}, - use re "eval"; - my $x = 7; $y = 1; - my $a = 4; my $b = 5; - print scalar - "abcabc" - =~ ${\'(?x) - ( - a (?{ print $y; local $y = $y+1; print $x; my $x = 8; print $x }) - b (?{ print $y; local $y = $y+1; print $x; my $x = 9; print $x }) - c (?{ print $y; local $y = $y+1; print $x; my $x = 10; print $x }) - ){2} - '}; - print $x,$a,$b -CODE - 'multiple (?{})s in "foo" =~ $string'; - -fresh_perl_is <<'CODE', '178279371047857967101745', {}, - use re "eval"; - my $x = 7; $y = 1; - my $a = 4; my $b = 5; - print scalar - "abcabc" =~ - /${\' - ( - a (?{ print $y; local $y = $y+1; print $x; my $x = 8; print $x }) - b (?{ print $y; local $y = $y+1; print $x; my $x = 9; print $x }) - c (?{ print $y; local $y = $y+1; print $x; my $x = 10; print $x }) - ){2} - '}/x; - print $x,$a,$b -CODE - 'multiple (?{})s in "foo" =~ /$string/x'; - -fresh_perl_is <<'CODE', '123123', {}, - for my $x(1..3) { - push @regexps = qr/(?{ print $x })a/; - } - "a" =~ $_ for @regexps; - "ba" =~ /b$_/ for @regexps; -CODE - 'qr/(?{})/ is a closure'; - -off; - -{ - local $::TODO = "re-eval #328" if is_perlcc_compiled; - "a" =~ do { package foo; qr/(?{ $::pack = __PACKAGE__ })a/ }; - is $pack, 'foo', 'qr// inherits package'; - "a" =~ do { use re "/x"; qr/(?{ $::re = qr-- })a/ }; - is $re, '(?^x:)', 'qr// inherits pragmata'; -} - -on; - -"ba" =~ /b${\do { package baz; qr|(?{ $::pack = __PACKAGE__ })a| }}/; -is $pack, 'baz', '/text$qr/ inherits package'; -"ba" =~ m+b${\do { use re "/i"; qr|(?{ $::re = qr-- })a| }}+; -is $re, '(?^i:)', '/text$qr/ inherits pragmata'; - -off; -{ - use re 'eval'; - package bar; - "ba" =~ /${\'(?{ $::pack = __PACKAGE__ })a'}/; -} -is $pack, 'bar', '/$text/ containing (?{}) inherits package'; -{ - use re 'eval', "/m"; - "ba" =~ /${\'(?{ $::re = qr -- })a'}/; -} -{ - local $::TODO = "re-eval #328" if is_perlcc_compiled; - is $re, '(?^m:)', '/$text/ containing (?{}) inherits pragmata'; -} - -on; - -fresh_perl_is <<'CODE', '45', { stderr => 1 }, '(?{die})'; - eval { my $a=4; my $b=5; "a" =~ /(?{die})a/ }; print $a,$b" -CODE - -SKIP: { - # The remaining TODO tests crash, which will display an error dialog - # on Windows that has to be manually dismissed. We don't want this - # to happen for release builds: 5.14.x, 5.16.x etc. - # On UNIX, they produce ugly 'Aborted' shell output mixed in with the - # test harness output, so skip on all platforms. - skip "Don't run crashing TODO test on release build", 3 - if $::TODO && (int($]*1000) & 1) == 0; - - fresh_perl_is <<'CODE', '45', { stderr => 1 }, '(?{last})'; - { my $a=4; my $b=5; "a" =~ /(?{last})a/ }; print $a,$b -CODE - fresh_perl_is <<'CODE', '45', { stderr => 1 }, '(?{next})'; - { my $a=4; my $b=5; "a" =~ /(?{last})a/ }; print $a,$b -CODE - fresh_perl_is <<'CODE', '45', { stderr => 1 }, '(?{return})'; - print sub { my $a=4; my $b=5; "a" =~ /(?{return $a.$b})a/ }->(); -CODE -} - -fresh_perl_is <<'CODE', '45', { stderr => 1 }, '(?{goto})'; - my $a=4; my $b=5; "a" =~ /(?{goto _})a/; die; _: print $a,$b -CODE diff --git a/t/CORE/re/reg_fold.t b/t/CORE/re/reg_fold.t deleted file mode 100644 index 4e56d2a36..000000000 --- a/t/CORE/re/reg_fold.t +++ /dev/null @@ -1,127 +0,0 @@ -#!perl - -BEGIN { - require q(t/CORE/test.pl); -} - -use strict; -use warnings; -my @tests; - -my %todo_pass = map { $_ => 1 } - qw(00DF 1E9E FB00 FB01 FB02 FB03 FB04 FB05 FB06); - -my $file="t/CORE/CaseFolding.txt"; -open my $fh,"<",$file or die "Failed to read '$file': $!"; -while (<$fh>) { - chomp; - my ($line,$comment)= split/\s+#\s+/, $_; - my ($cp,$type,@folded)=split/[\s;]+/,$line||''; - next unless $type and ($type eq 'F' or $type eq 'C'); - next if $type eq 'C'; # 'C' tests now done by fold_grind.t - my $fold_above_latin1 = grep { hex("0x$_") > 255 } @folded; - $_="\\x{$_}" for @folded; - my $cpv=hex("0x$cp"); - my $chr="\\x{$cp}"; - my @str; - foreach my $swap (0, 1) { # swap lhs and rhs, or not. - foreach my $charclass (0) { # Put rhs in [...], or not - my $lhs; - my $rhs; - if ($swap) { - $lhs = join "", @folded; - $rhs = $chr; - $rhs = "[$rhs]" if $charclass; - } else { - $lhs = $chr; - $rhs = ""; - foreach my $rhs_char (@folded) { - $rhs .= '[' if $charclass; - $rhs .= $rhs_char; - $rhs .= ']' if $charclass; - } - } - $lhs = "\"$lhs\""; - $rhs = "/^$rhs\$/i"; - - # Try both Latin1 and Unicode for code points below 256 - foreach my $upgrade ("", 'utf8::upgrade($c); ') { - if ($upgrade) { - next if $swap && $fold_above_latin1; - next if !$swap && $cpv > 255; - } - my $eval = "my \$c = $lhs; $upgrade\$c =~ $rhs"; - #print __LINE__, ": $eval\n"; - push @tests, qq[ok(eval '$eval', '$eval - $comment')]; - if ($charclass && @folded > 1 && $swap && ! $upgrade && ! $fold_above_latin1) { - $tests[-1]="TODO: { local \$::TODO='Multi-char, non-utf8 folded inside character class [ ] doesnt work';\n$tests[-1] }" - } elsif (! $upgrade && $cpv >= 128 && $cpv <= 255 && $cpv != 0xb5) { - $tests[-1]="TODO: { local \$::TODO='Most non-utf8 latin1 doesnt work';\n$tests[-1] }" - } elsif (! $swap && $charclass && @folded > 1 - && ! $todo_pass{$cp}) - { - # There are a few of these that pass; most fail. - $tests[-1]="TODO: { local \$::TODO='Some multi-char, f8 folded inside character class [ ] doesnt work';\n$tests[-1] }" - } - } - } - } -} - -# Now verify the case folding tables. First compute the mappings without -# resorting to the functions we're testing. - -# Initialize the array so each $i maps to itself. -my @fold_ascii; -for my $i (0 .. 255) { - $fold_ascii[$i] = $i; -} -my @fold_latin1 = @fold_ascii; - -# Override the uppercase elements to fold to their lower case equivalents, -# using the fact that 'A' in ASCII is 0x41, 'a' is 0x41+32, 'B' is 0x42, and -# so on. The same paradigm applies for most of the Latin1 range cased -# characters, but in posix anything outside ASCII maps to itself, as we've -# already set up. -for my $i (0x41 .. 0x5A, 0xC0 .. 0xD6, 0xD8 .. 0xDE) { - my $upper_ord = ord_latin1_to_native($i); - my $lower_ord = ord_latin1_to_native($i + 32); - - $fold_latin1[$upper_ord] = $lower_ord; - - next if $i > 127; - $fold_ascii[$upper_ord] = $lower_ord; -} - -# Same for folding lower to the upper equivalents -for my $i (0x61 .. 0x7A, 0xE0 .. 0xF6, 0xF8 .. 0xFE) { - my $lower_ord = ord_latin1_to_native($i); - my $upper_ord = ord_latin1_to_native($i - 32); - - $fold_latin1[$lower_ord] = $upper_ord; - - next if $i > 127; - $fold_ascii[$lower_ord] = $upper_ord; -} - -# Test every latin1 character that the correct values in both /u and /d -for my $i (0 .. 255) { - my $chr = sprintf "\\x%02X", $i; - my $hex_fold_ascii = sprintf "0x%02X", $fold_ascii[$i]; - my $hex_fold_latin1 = sprintf "0x%02X", $fold_latin1[$i]; - push @tests, qq[like chr($hex_fold_ascii), qr/(?d:$chr)/i, 'chr($hex_fold_ascii) =~ qr/(?d:$chr)/i']; - push @tests, qq[like chr($hex_fold_latin1), qr/(?u:$chr)/i, 'chr($hex_fold_latin1) =~ qr/(?u:$chr)/i']; -} - - -push @tests, qq[like chr(0x0430), qr/[=\x{0410}-\x{0411}]/i, 'Bug #71752 Unicode /i char in a range']; -push @tests, qq[like 'a', qr/\\p{Upper}/i, "'a' =~ /\\\\p{Upper}/i"]; -push @tests, q[my $c = "\x{212A}"; my $p = qr/(?:^[\x{004B}_]+$)/i; utf8::upgrade($p); like $c, $p, 'Bug #78994: my $c = "\x{212A}"; my $p = qr/(?:^[\x{004B}_]+$)/i; utf8::upgrade($p); $c =~ $p']; - -use charnames ":full"; -push @tests, q[my $re1 = "\N{WHITE SMILING FACE}";like "\xE8", qr/[\w$re1]/, 'my $re = "\N{WHITE SMILING FACE}"; "\xE8" =~ qr/[\w$re]/']; -push @tests, q[my $re2 = "\N{WHITE SMILING FACE}";like "\xE8", qr/\w|$re2/, 'my $re = "\N{WHITE SMILING FACE}"; "\xE8" =~ qr/\w|$re/']; - -eval join ";\n","plan tests=>". (scalar @tests), @tests, "1" - or die $@; -__DATA__ diff --git a/t/CORE/re/reg_mesg.t b/t/CORE/re/reg_mesg.t deleted file mode 100644 index c20c890d5..000000000 --- a/t/CORE/re/reg_mesg.t +++ /dev/null @@ -1,147 +0,0 @@ -#!./perl -w - -BEGIN { - require q(t/CORE/test.pl); - use Config; -} - -use strict; - -## -## If the markers used are changed (search for "MARKER1" in regcomp.c), -## update only these two regexs, and leave the {#} in the @death/@warning -## arrays below. The {#} is a meta-marker -- it marks where the marker should -## go. -## -sub fixup_expect { - my $expect = shift; - $expect =~ s/{\#}/<-- HERE/; - $expect =~ s/{\#}/ <-- HERE /; - $expect .= " at "; - return $expect; -} - -my $inf_m1 = ($Config::Config{reg_infty} || 32767) - 1; -my $inf_p1 = $inf_m1 + 2; - -## -## Key-value pairs of code/error of code that should have fatal errors. -## -my @death = -( - '/[[=foo=]]/' => 'POSIX syntax [= =] is reserved for future extensions in regex; marked by {#} in m/[[=foo=]{#}]/', - - '/(?<= .*)/' => 'Variable length lookbehind not implemented in regex m/(?<= .*)/', - - '/(?<= x{1000})/' => 'Lookbehind longer than 255 not implemented in regex m/(?<= x{1000})/', - - '/(?@)/' => 'Sequence (?@...) not implemented in regex; marked by {#} in m/(?@{#})/', - - '/(?{ 1/' => 'Sequence (?{...}) not terminated or not {}-balanced in regex; marked by {#} in m/(?{{#} 1/', - - '/(?(1x))/' => 'Switch condition not recognized in regex; marked by {#} in m/(?(1x{#}))/', - - '/(?(1)x|y|z)/' => 'Switch (?(condition)... contains too many branches in regex; marked by {#} in m/(?(1)x|y|{#}z)/', - - '/(?(x)y|x)/' => 'Unknown switch condition (?(x) in regex; marked by {#} in m/(?({#}x)y|x)/', - - '/(?/' => 'Sequence (? incomplete in regex; marked by {#} in m/(?{#}/', - - '/(?;x/' => 'Sequence (?;...) not recognized in regex; marked by {#} in m/(?;{#}x/', - '/(?<;x/' => 'Sequence (?<;...) not recognized in regex; marked by {#} in m/(?<;{#}x/', - - '/(?\ix/' => 'Sequence (?\...) not recognized in regex; marked by {#} in m/(?\{#}ix/', - '/(?\mx/' => 'Sequence (?\...) not recognized in regex; marked by {#} in m/(?\{#}mx/', - '/(?\:x/' => 'Sequence (?\...) not recognized in regex; marked by {#} in m/(?\{#}:x/', - '/(?\=x/' => 'Sequence (?\...) not recognized in regex; marked by {#} in m/(?\{#}=x/', - '/(?\!x/' => 'Sequence (?\...) not recognized in regex; marked by {#} in m/(?\{#}!x/', - '/(?\<=x/' => 'Sequence (?\...) not recognized in regex; marked by {#} in m/(?\{#}<=x/', - '/(?\ 'Sequence (?\...) not recognized in regex; marked by {#} in m/(?\{#}x/' => 'Sequence (?\...) not recognized in regex; marked by {#} in m/(?\{#}>x/', - '/(?^-i:foo)/' => 'Sequence (?^-...) not recognized in regex; marked by {#} in m/(?^-{#}i:foo)/', - '/(?^-i)foo/' => 'Sequence (?^-...) not recognized in regex; marked by {#} in m/(?^-{#}i)foo/', - '/(?^d:foo)/' => 'Sequence (?^d...) not recognized in regex; marked by {#} in m/(?^d{#}:foo)/', - '/(?^d)foo/' => 'Sequence (?^d...) not recognized in regex; marked by {#} in m/(?^d{#})foo/', - '/(?^lu:foo)/' => 'Regexp modifiers "l" and "u" are mutually exclusive in regex; marked by {#} in m/(?^lu{#}:foo)/', - '/(?^lu)foo/' => 'Regexp modifiers "l" and "u" are mutually exclusive in regex; marked by {#} in m/(?^lu{#})foo/', -'/(?da:foo)/' => 'Regexp modifiers "d" and "a" are mutually exclusive in regex; marked by {#} in m/(?da{#}:foo)/', -'/(?lil:foo)/' => 'Regexp modifier "l" may not appear twice in regex; marked by {#} in m/(?lil{#}:foo)/', -'/(?aaia:foo)/' => 'Regexp modifier "a" may appear a maximum of twice in regex; marked by {#} in m/(?aaia{#}:foo)/', -'/(?i-l:foo)/' => 'Regexp modifier "l" may not appear after the "-" in regex; marked by {#} in m/(?i-l{#}:foo)/', - - '/((x)/' => 'Unmatched ( in regex; marked by {#} in m/({#}(x)/', - - "/x{$inf_p1}/" => "Quantifier in {,} bigger than $inf_m1 in regex; marked by {#} in m/x{{#}$inf_p1}/", - - '/x{3,1}/' => 'Can\'t do {n,m} with n > m in regex; marked by {#} in m/x{3,1}{#}/', - - '/x**/' => 'Nested quantifiers in regex; marked by {#} in m/x**{#}/', - - '/x[/' => 'Unmatched [ in regex; marked by {#} in m/x[{#}/', - - '/*/', => 'Quantifier follows nothing in regex; marked by {#} in m/*{#}/', - - '/\p{x/' => 'Missing right brace on \p{} in regex; marked by {#} in m/\p{{#}x/', - - '/[\p{x]/' => 'Missing right brace on \p{} in regex; marked by {#} in m/[\p{{#}x]/', - - '/(x)\2/' => 'Reference to nonexistent group in regex; marked by {#} in m/(x)\2{#}/', - - 'my $m = "\\\"; $m =~ $m', => 'Trailing \ in regex m/\/', - - '/\x{1/' => 'Missing right brace on \x{} in regex; marked by {#} in m/\x{{#}1/', - - '/[\x{X]/' => 'Missing right brace on \x{} in regex; marked by {#} in m/[\x{{#}X]/', - - '/[[:barf:]]/' => 'POSIX class [:barf:] unknown in regex; marked by {#} in m/[[:barf:]{#}]/', - - '/[[=barf=]]/' => 'POSIX syntax [= =] is reserved for future extensions in regex; marked by {#} in m/[[=barf=]{#}]/', - - '/[[.barf.]]/' => 'POSIX syntax [. .] is reserved for future extensions in regex; marked by {#} in m/[[.barf.]{#}]/', - - '/[z-a]/' => 'Invalid [] range "z-a" in regex; marked by {#} in m/[z-a{#}]/', - - '/\p/' => 'Empty \p{} in regex; marked by {#} in m/\p{#}/', - - '/\P{}/' => 'Empty \P{} in regex; marked by {#} in m/\P{{#}}/', -); - -## -## Key-value pairs of code/error of code that should have non-fatal warnings. -## -my @warning = ( - 'm/\b*/' => '\b* matches null string many times in regex; marked by {#} in m/\b*{#}/', - - 'm/[:blank:]/' => 'POSIX syntax [: :] belongs inside character classes in regex; marked by {#} in m/[:blank:]{#}/', - - "m'[\\y]'" => 'Unrecognized escape \y in character class passed through in regex; marked by {#} in m/[\y{#}]/', - - 'm/[a-\d]/' => 'False [] range "a-\d" in regex; marked by {#} in m/[a-\d{#}]/', - 'm/[\w-x]/' => 'False [] range "\w-" in regex; marked by {#} in m/[\w-{#}x]/', - 'm/[a-\pM]/' => 'False [] range "a-\pM" in regex; marked by {#} in m/[a-\pM{#}]/', - 'm/[\pM-x]/' => 'False [] range "\pM-" in regex; marked by {#} in m/[\pM-{#}x]/', - "m'\\y'" => 'Unrecognized escape \y passed through in regex; marked by {#} in m/\y{#}/', -); - -while (my ($regex, $expect) = splice @death, 0, 2) { - my $expect = fixup_expect($expect); - # skip the utf8 test on EBCDIC since they do not die - next if $::IS_EBCDIC && $regex =~ /utf8/; - - warning_is(sub { - $_ = "x"; - eval $regex; - like($@, qr/\Q$expect/); - }, undef, "$regex died without any other warnings"); -} - -while (my ($regex, $expect) = splice @warning, 0, 2) { - my $expect = fixup_expect($expect); - warning_like(sub { - $_ = "x"; - eval $regex; - is($@, '', "$regex did not die"); - }, qr/\Q$expect/); -} - -done_testing(); diff --git a/t/CORE/re/reg_namedcapture.t b/t/CORE/re/reg_namedcapture.t deleted file mode 100644 index 2402530d3..000000000 --- a/t/CORE/re/reg_namedcapture.t +++ /dev/null @@ -1,21 +0,0 @@ -#!./perl - -BEGIN { - require q(t/CORE/test.pl); -} - -# WARNING: Do not directly use any modules as part of this test code. -# We could get action at a distance that would invalidate the tests. - -print "1..2\n"; - -# This tests whether glob assignment fails to load the tie. -*X = *-; -'X'=~/(?X)/; -print eval '*X{HASH}{X} || 1' ? "" :"not ","ok ",++$test,"\n"; - -# And since it's a similar case we check %! as well. Note that -# this can't be done until ../lib/Errno.pm is in place, as the -# glob hits $!, which needs that module. -*Y = *!; -print 0 37); - -# PL_curpm->paren_names can be a null pointer. See that this succeeds anyway. -'x' =~ /(.)/; -() = %+; -pass( 'still alive' ); - -"hlagh" =~ / - (?.) - (?.) - (?.) - .* - (?$) -/x; - -# FETCH -is($+{a}, "h", "FETCH"); -is($+{b}, "l", "FETCH"); -is($-{a}[0], "h", "FETCH"); -is($-{a}[1], "a", "FETCH"); - -# STORE -eval { $+{a} = "yon" }; -like($@, qr/read-only/, "STORE"); - -# DELETE -eval { delete $+{a} }; -like($@, qr/read-only/, "DELETE"); - -# CLEAR -eval { %+ = () }; -like($@, qr/read-only/, "CLEAR"); - -# EXISTS -ok(exists $+{e}, "EXISTS"); -ok(!exists $+{d}, "EXISTS"); - -# FIRSTKEY/NEXTKEY -is(join('|', sort keys %+), "a|b|e", "FIRSTKEY/NEXTKEY"); - -# SCALAR -is(scalar(%+), 3, "SCALAR"); -is(scalar(%-), 3, "SCALAR"); - -# Abuse all methods with undef as the first argument (RT #71828 and then some): - -is(Tie::Hash::NamedCapture::FETCH(undef, undef), undef, 'FETCH with undef'); -eval {Tie::Hash::NamedCapture::STORE(undef, undef, undef)}; -like($@, qr/Modification of a read-only value attempted/, 'STORE with undef'); -eval {Tie::Hash::NamedCapture::DELETE(undef, undef)}; -like($@, , qr/Modification of a read-only value attempted/, - 'DELETE with undef'); -eval {Tie::Hash::NamedCapture::CLEAR(undef)}; -like($@, qr/Modification of a read-only value attempted/, 'CLEAR with undef'); -is(Tie::Hash::NamedCapture::EXISTS(undef, undef), undef, 'EXISTS with undef'); -is(Tie::Hash::NamedCapture::FIRSTKEY(undef), undef, 'FIRSTKEY with undef'); -is(Tie::Hash::NamedCapture::NEXTKEY(undef, undef), undef, 'NEXTKEY with undef'); -is(Tie::Hash::NamedCapture::SCALAR(undef), undef, 'SCALAR with undef'); - -my $obj = tied %+; -foreach ([FETCH => '$key'], - [STORE => '$key, $value'], - [DELETE => '$key'], - [CLEAR => ''], - [EXISTS => '$key'], - [FIRSTKEY => ''], - [NEXTKEY => '$lastkey'], - [SCALAR => ''], - ) { - my ($method, $error) = @$_; - - is(eval {$obj->$method(0..3); 1}, undef, "$method with undef"); - like($@, qr/Usage: Tie::Hash::NamedCapture::$method\(\Q$error\E\)/, - "usage method for $method"); -} diff --git a/t/CORE/re/reg_pmod.t b/t/CORE/re/reg_pmod.t deleted file mode 100644 index fa0b2d6c3..000000000 --- a/t/CORE/re/reg_pmod.t +++ /dev/null @@ -1,47 +0,0 @@ -#!./perl - -BEGIN { - require q(t/CORE/test.pl); -} - -use strict; -use warnings; - -our @tests = ( - # /p Pattern PRE MATCH POST - [ '/p', "456", "123-", "456", "-789"], - [ '(?p)', "456", "123-", "456", "-789"], - [ '', "(456)", "123-", "456", "-789"], - [ '', "456", undef, undef, undef ], -); - -plan tests => 4 * @tests + 2; -my $W = ""; - -$SIG{__WARN__} = sub { $W.=join("",@_); }; -sub _u($$) { "$_[0] is ".(defined $_[1] ? "'$_[1]'" : "undef") } - -$_ = '123-456-789'; -foreach my $test (@tests) { - my ($p, $pat,$l,$m,$r) = @$test; - my $test_name = $p eq '/p' ? "/$pat/p" - : $p eq '(?p)' ? "/(?p)$pat/" - : "/$pat/"; - - # - # Cannot use if/else due to the scope invalidating ${^MATCH} and friends. - # - my $ok = ok $p eq '/p' ? /$pat/p - : $p eq '(?p)' ? /(?p)$pat/ - : /$pat/ - => $test_name; - SKIP: { - skip "/$pat/$p failed to match", 3 - unless $ok; - is(${^PREMATCH}, $l,_u "$test_name: ^PREMATCH",$l); - is(${^MATCH}, $m,_u "$test_name: ^MATCH",$m ); - is(${^POSTMATCH}, $r,_u "$test_name: ^POSTMATCH",$r ); - } -} -is($W,"","No warnings should be produced"); -ok(!defined ${^MATCH}, "No /p in scope so ^MATCH is undef"); diff --git a/t/CORE/re/reg_posixcc.t b/t/CORE/re/reg_posixcc.t deleted file mode 100644 index 61b27d1d1..000000000 --- a/t/CORE/re/reg_posixcc.t +++ /dev/null @@ -1,149 +0,0 @@ -#!perl - -BEGIN { - require q(t/CORE/test.pl); -} - -use strict; -use warnings; -plan "no_plan"; - -my @pats=( - "\\w", - "\\W", - "\\s", - "\\S", - "\\d", - "\\D", - "[:alnum:]", - "[:^alnum:]", - "[:alpha:]", - "[:^alpha:]", - "[:ascii:]", - "[:^ascii:]", - "[:cntrl:]", - "[:^cntrl:]", - "[:graph:]", - "[:^graph:]", - "[:lower:]", - "[:^lower:]", - "[:print:]", - "[:^print:]", - "[:punct:]", - "[:^punct:]", - "[:upper:]", - "[:^upper:]", - "[:xdigit:]", - "[:^xdigit:]", - "[:space:]", - "[:^space:]", - "[:blank:]", - "[:^blank:]" ); - -sub rangify { - my $ary= shift; - my $fmt= shift || '%d'; - my $sep= shift || ' '; - my $rng= shift || '..'; - - - my $first= $ary->[0]; - my $last= $ary->[0]; - my $ret= sprintf $fmt, $first; - for my $idx (1..$#$ary) { - if ( $ary->[$idx] != $last + 1) { - if ($last!=$first) { - $ret.=sprintf "%s$fmt",$rng, $last; - } - $first= $last= $ary->[$idx]; - $ret.=sprintf "%s$fmt",$sep,$first; - } else { - $last= $ary->[$idx]; - } - } - if ( $last != $first) { - $ret.=sprintf "%s$fmt",$rng, $last; - } - return $ret; -} - -# The bug is only fixed for /u -use feature 'unicode_strings'; - -my $description = ""; -while (@pats) { - my ($yes,$no)= splice @pats,0,2; - - my %err_by_type; - my %singles; - my %complements; - foreach my $b (0..255) { - my %got; - my $display_b = sprintf("\\x%02X", $b); - for my $type ('unicode','not-unicode') { - my $str=chr($b).chr($b); - if ($type eq 'unicode') { - $str.=chr(256); - chop $str; - } - if ($str=~/[$yes][$no]/){ - unlike($str,qr/[$yes][$no]/, - "chr($display_b) X 2 =~/[$yes][$no]/ should not match under $type"); - push @{$err_by_type{$type}},$b; - } - $got{"[$yes]"}{$type} = $str=~/[$yes]/ ? 1 : 0; - $got{"[$no]"}{$type} = $str=~/[$no]/ ? 1 : 0; - $got{"[^$yes]"}{$type} = $str=~/[^$yes]/ ? 1 : 0; - $got{"[^$no]"}{$type} = $str=~/[^$no]/ ? 1 : 0; - } - foreach my $which ("[$yes]","[$no]","[^$yes]","[^$no]") { - if ($got{$which}{'unicode'} != $got{$which}{'not-unicode'}){ - is($got{$which}{'unicode'},$got{$which}{'not-unicode'}, - "chr($display_b) X 2=~ /$which/ should have the same results regardless of internal string encoding"); - push @{$singles{$which}},$b; - } - } - foreach my $which ($yes,$no) { - foreach my $strtype ('unicode','not-unicode') { - if ($got{"[$which]"}{$strtype} == $got{"[^$which]"}{$strtype}) { - isnt($got{"[$which]"}{$strtype},$got{"[^$which]"}{$strtype}, - "chr($display_b) X 2 =~ /[$which]/ should not have the same result as chr($display_b)=~/[^$which]/"); - push @{$complements{$which}{$strtype}},$b; - } - } - } - } - - - if (%err_by_type || %singles || %complements) { - $description||=" Error:\n"; - $description .= "/[$yes][$no]/\n"; - if (%err_by_type) { - foreach my $type (sort keys %err_by_type) { - $description .= "\tmatches $type codepoints:\t"; - $description .= rangify($err_by_type{$type}); - $description .= "\n"; - } - $description .= "\n"; - } - if (%singles) { - $description .= "Unicode/Nonunicode mismatches:\n"; - foreach my $type (sort keys %singles) { - $description .= "\t$type:\t"; - $description .= rangify($singles{$type}); - $description .= "\n"; - } - $description .= "\n"; - } - if (%complements) { - foreach my $class (sort keys %complements) { - foreach my $strtype (sort keys %{$complements{$class}}) { - $description .= "\t$class has complement failures under $strtype for:\t"; - $description .= rangify($complements{$class}{$strtype}); - $description .= "\n"; - } - } - } - } -} -__DATA__ diff --git a/t/CORE/re/regexp_unicode_prop.t b/t/CORE/re/regexp_unicode_prop.t deleted file mode 100644 index 2454f2023..000000000 --- a/t/CORE/re/regexp_unicode_prop.t +++ /dev/null @@ -1,355 +0,0 @@ -#!./perl -# -# Tests that have to do with checking whether characters have (or not have) -# certain Unicode properties; belong (or not belong) to blocks, scripts, etc. -# - -use strict; -use warnings; -use 5.010; - -BEGIN { - require q(t/CORE/test.pl); -} - -sub run_tests; - -# -# This is the data to test. -# -# This is a hash; keys are the property to test. -# Values are arrays containing characters to test. The characters can -# have the following formats: -# '\N{CHARACTER NAME}' - Use character with that name -# '\x{1234}' - Use character with that hex escape -# '0x1234' - Use chr() to get that character -# "a" - Character to use -# -# If a character entry starts with ! the character does not belong to the class -# -# If the class is just single letter, we use both \pL and \p{L} -# - -use charnames ':full'; - -my @CLASSES = ( - L => ["a", "A"], - Ll => ["b", "!B"], - Lu => ["!c", "C"], - IsLl => ["d", "!D"], - IsLu => ["!e", "E"], - LC => ["f", "!1"], - 'L&' => ["g", "!2"], - 'Lowercase Letter' => ["h", "!H"], - - Common => ["!i", "3"], - Inherited => ["!j", '\x{300}'], - - InBasicLatin => ['\N{LATIN CAPITAL LETTER A}'], - InLatin1Supplement => ['\N{LATIN CAPITAL LETTER A WITH GRAVE}'], - InLatinExtendedA => ['\N{LATIN CAPITAL LETTER A WITH MACRON}'], - InLatinExtendedB => ['\N{LATIN SMALL LETTER B WITH STROKE}'], - InKatakana => ['\N{KATAKANA LETTER SMALL A}'], - IsLatin => ["0x100", "0x212b"], - IsHebrew => ["0x5d0", "0xfb4f"], - IsGreek => ["0x37a", "0x386", "!0x387", "0x388", - "0x38a", "!0x38b", "0x38c"], - HangulSyllables => ['\x{AC00}'], - 'Script=Latin' => ['\x{0100}'], - 'Block=LatinExtendedA' => ['\x{0100}'], - 'Category=UppercaseLetter' => ['\x{0100}'], - - # - # It's ok to repeat class names. - # - InLatin1Supplement => - $::IS_EBCDIC ? ['!\x{7f}', '\x{80}', '!\x{100}'] - : ['!\x{7f}', '\x{80}', '\x{ff}', '!\x{100}'], - InLatinExtendedA => - ['!\x{7f}', '!\x{80}', '!\x{ff}', '\x{100}'], - - # - # Properties are case-insensitive, and may have whitespace, - # dashes and underscores. - # - 'in-latin1_SUPPLEMENT' => ['\x{80}', - '\N{LATIN SMALL LETTER Y WITH DIAERESIS}'], - ' ^ In Latin 1 Supplement ' - => ['!\x{80}', '\N{COFFIN}'], - 'latin-1 supplement' => ['\x{80}', "0xDF"], - -); - -my @USER_DEFINED_PROPERTIES = ( - # - # User defined properties - # - InKana1 => ['\x{3040}', '!\x{303F}'], - InKana2 => ['\x{3040}', '!\x{303F}'], - InKana3 => ['\x{3041}', '!\x{3040}'], - InNotKana => ['\x{3040}', '!\x{3041}'], - InConsonant => ['d', '!e'], - IsSyriac1 => ['\x{0712}', '!\x{072F}'], - '# User-defined character properties may lack \n at the end', - InGreekSmall => ['\N{GREEK SMALL LETTER PI}', - '\N{GREEK SMALL LETTER FINAL SIGMA}'], - InGreekCapital => ['\N{GREEK CAPITAL LETTER PI}', '!\x{03A2}'], - Dash => ['-'], - ASCII_Hex_Digit => ['!-', 'A'], - IsAsciiHexAndDash => ['-', 'A'], -); - -my @USER_CASELESS_PROPERTIES = ( - # - # User defined properties which differ depending on /i. Second entry is - # false regularly, true under /i - # - 'IsMyUpper' => ["M", "!m" ], -); - - -# -# From the short properties we populate POSIX-like classes. -# -my %SHORT_PROPERTIES = ( - 'Ll' => ['m', '\N{CYRILLIC SMALL LETTER A}'], - 'Lu' => ['M', '\N{GREEK CAPITAL LETTER ALPHA}'], - 'Lo' => ['\N{HIRAGANA LETTER SMALL A}'], - # is also in other alphabetic - 'Mn' => ['\N{HEBREW POINT RAFE}'], - 'Nd' => ["0", '\N{ARABIC-INDIC DIGIT ZERO}'], - 'Pc' => ["_"], - 'Po' => ["!"], - 'Zs' => [" "], - 'Cc' => ['\x{00}'], -); - -# -# Illegal properties -# -my @ILLEGAL_PROPERTIES = - qw[q qrst f foo isfoo infoo ISfoo INfoo Is::foo In::foo]; - -my %d; - -while (my ($class, $chars) = each %SHORT_PROPERTIES) { - push @{$d {IsAlpha}} => map {$class =~ /^[LM]/ ? $_ : "!$_"} @$chars; - push @{$d {IsAlnum}} => map {$class =~ /^[LMN]./ ? $_ : "!$_"} @$chars; - push @{$d {IsASCII}} => map {length ($_) == 1 || $_ eq '\x{00}' - ? $_ : "!$_"} @$chars; - push @{$d {IsCntrl}} => map {$class =~ /^C/ ? $_ : "!$_"} @$chars; - push @{$d {IsBlank}} => map {$class =~ /^Z[lps]/ ? $_ : "!$_"} @$chars; - push @{$d {IsDigit}} => map {$class =~ /^Nd$/ ? $_ : "!$_"} @$chars; - push @{$d {IsGraph}} => map {$class =~ /^([LMNPS]|Co)/ - ? $_ : "!$_"} @$chars; - push @{$d {IsPrint}} => map {$class =~ /^([LMNPS]|Co|Zs)/ - ? $_ : "!$_"} @$chars; - push @{$d {IsLower}} => map {$class =~ /^Ll$/ ? $_ : "!$_"} @$chars; - push @{$d {IsUpper}} => map {$class =~ /^L[ut]/ ? $_ : "!$_"} @$chars; - push @{$d {IsPunct}} => map {$class =~ /^P/ ? $_ : "!$_"} @$chars; - push @{$d {IsWord}} => map {$class =~ /^[LMN]/ || $_ eq "_" - ? $_ : "!$_"} @$chars; - push @{$d {IsSpace}} => map {$class =~ /^Z/ || - length ($_) == 1 && ord ($_) >= 0x09 - && ord ($_) <= 0x0D - ? $_ : "!$_"} @$chars; -} - -delete $d {IsASCII} if $::IS_EBCDIC; - -push @CLASSES => "# Short properties" => %SHORT_PROPERTIES, - "# POSIX like properties" => %d, - "# User defined properties" => @USER_DEFINED_PROPERTIES; - - -# -# Calculate the number of tests. -# -my $count = 0; -for (my $i = 0; $i < @CLASSES; $i += 2) { - $i ++, redo if $CLASSES [$i] =~ /^\h*#\h*(.*)/; - $count += 2 * (length $CLASSES [$i] == 1 ? 4 : 2) * @{$CLASSES [$i + 1]}; -} -$count += 4 * @ILLEGAL_PROPERTIES; -$count += 4 * grep {length $_ == 1} @ILLEGAL_PROPERTIES; -$count += 8 * @USER_CASELESS_PROPERTIES; - -plan(tests => $count); - -run_tests unless caller (); - -sub match { - my ($char, $match, $nomatch, $caseless) = @_; - $caseless = "" unless defined $caseless; - $caseless = 'i' if $caseless; - - my ($str, $name); - - given ($char) { - when (/^\\/) { - $str = eval qq ["$char"]; - $name = qq ["$char"]; - } - when (/^0x([0-9A-Fa-f]+)$/) { - $str = chr hex $1; - $name = "chr ($char)"; - } - default { - $str = $char; - $name = qq ["$char"]; - } - } - - undef $@; - my $match_pat = eval "qr/$match/$caseless"; - is($@, '', "$name compiled correctly to a regexp"); - like($str, $match_pat, "$name correctly matched"); - - undef $@; - my $nomatch_pat = eval "qr/$nomatch/$caseless"; - is($@, '', "$name compiled correctly to a regexp"); - unlike($str, $nomatch_pat, "$name correctly did not match"); -} - -sub run_tests { - - while (@CLASSES) { - my $class = shift @CLASSES; - if ($class =~ /^\h*#\h*(.*)/) { - print "# $1\n"; - next; - } - last unless @CLASSES; - my $chars = shift @CLASSES; - my @in = grep {!/^!./} @$chars; - my @out = map {s/^!(?=.)//; $_} grep { /^!./} @$chars; - my $in_pat = eval qq ['\\p{$class}']; - my $out_pat = eval qq ['\\P{$class}']; - - match $_, $in_pat, $out_pat for @in; - match $_, $out_pat, $in_pat for @out; - - if (1 == length $class) { # Repeat without braces if name length 1 - my $in_pat = eval qq ['\\p$class']; - my $out_pat = eval qq ['\\P$class']; - - match $_, $in_pat, $out_pat for @in; - match $_, $out_pat, $in_pat for @out; - } - } - - - my $pat = qr /^Can't find Unicode property definition/; - print "# Illegal properties\n"; - foreach my $p (@ILLEGAL_PROPERTIES) { - undef $@; - my $r = eval "'a' =~ /\\p{$p}/; 1"; - is($r, undef, "Unknown Unicode property \\p{$p}"); - like($@, $pat, "Unknown Unicode property \\p{$p}"); - undef $@; - my $s = eval "'a' =~ /\\P{$p}/; 1"; - is($s, undef, "Unknown Unicode property \\p{$p}"); - like($@, $pat, "Unknown Unicode property \\p{$p}"); - if (length $p == 1) { - undef $@; - my $r = eval "'a' =~ /\\p$p/; 1"; - is($r, undef, "Unknown Unicode property \\p$p"); - like($@, $pat, "Unknown Unicode property \\p$p"); - undef $@; - my $s = eval "'a' =~ /\\P$p/; 1"; - is($r, undef, "Unknown Unicode property \\P$p"); - like($@, $pat, "Unknown Unicode property \\P$p"); - } - } - - print "# User-defined properties with /i differences\n"; - foreach my $class (shift @USER_CASELESS_PROPERTIES) { - my $chars_ref = shift @USER_CASELESS_PROPERTIES; - my @in = grep {!/^!./} @$chars_ref; - my @out = map {s/^!(?=.)//; $_} grep { /^!./} @$chars_ref; - my $in_pat = eval qq ['\\p{$class}']; - my $out_pat = eval qq ['\\P{$class}']; - - # Verify works as regularly for not /i - match $_, $in_pat, $out_pat for @in; - match $_, $out_pat, $in_pat for @out; - - # Verify that adding /i doesn't change the in set. - match $_, $in_pat, $out_pat, 'i' for @in; - - # Verify that adding /i does change the out set to match. - match $_, $in_pat, $out_pat, 'i' for @out; - } -} - - -# -# User defined properties -# - -sub InKana1 {<<'--'} -3040 309F -30A0 30FF --- - -sub InKana2 {<<'--'} -+utf8::InHiragana -+utf8::InKatakana --- - -sub InKana3 {<<'--'} -+utf8::InHiragana -+utf8::InKatakana --utf8::IsCn --- - -sub InNotKana {<<'--'} -!utf8::InHiragana --utf8::InKatakana -+utf8::IsCn --- - -sub InConsonant {<<'--'} # Not EBCDIC-aware. -0061 007f --0061 --0065 --0069 --006f --0075 --- - -sub IsSyriac1 {<<'--'} -0712 072C -0730 074A --- - -sub InGreekSmall {return "03B1\t03C9"} -sub InGreekCapital {return "0391\t03A9\n-03A2"} - -sub IsAsciiHexAndDash {<<'--'} -+utf8::ASCII_Hex_Digit -+utf8::Dash --- - -sub IsMyUpper { - my $caseless = shift; - if ($caseless) { - return "0041\t005A\n0061\t007A" - } - else { - return "0041\t005A" - } -} - -# fake user-defined properties; these subs shouldn't be called, because -# their names don't start with In or Is - -sub f { die } -sub foo { die } -sub isfoo { die } -sub infoo { die } -sub ISfoo { die } -sub INfoo { die } -sub Is::foo { die } -sub In::foo { die } -__END__ diff --git a/t/CORE/re/rxcode.t b/t/CORE/re/rxcode.t deleted file mode 100644 index fafa5aa19..000000000 --- a/t/CORE/re/rxcode.t +++ /dev/null @@ -1,87 +0,0 @@ -#!./perl - -BEGIN { - require q(t/CORE/test.pl); -} - -plan tests => 38; - -$^R = undef; -like( 'a', qr/^a(?{1})(?:b(?{2}))?/, 'a =~ ab?' ); -cmp_ok( $^R, '==', 1, '..$^R after a =~ ab?' ); - -$^R = undef; -unlike( 'abc', qr/^a(?{3})(?:b(?{4}))$/, 'abc !~ a(?:b)$' ); -ok( !defined $^R, '..$^R after abc !~ a(?:b)$' ); - -$^R = undef; -like( 'ab', qr/^a(?{5})b(?{6})/, 'ab =~ ab' ); -cmp_ok( $^R, '==', 6, '..$^R after ab =~ ab' ); - -$^R = undef; -like( 'ab', qr/^a(?{7})(?:b(?{8}))?/, 'ab =~ ab?' ); - -cmp_ok( $^R, '==', 8, '..$^R after ab =~ ab?' ); - -$^R = undef; -like( 'ab', qr/^a(?{9})b?(?{10})/, 'ab =~ ab? (2)' ); -cmp_ok( $^R, '==', 10, '..$^R after ab =~ ab? (2)' ); - -$^R = undef; -like( 'ab', qr/^(a(?{11})(?:b(?{12})))?/, 'ab =~ (ab)? (3)' ); -cmp_ok( $^R, '==', 12, '..$^R after ab =~ ab? (3)' ); - -$^R = undef; -unlike( 'ac', qr/^a(?{13})b(?{14})/, 'ac !~ ab' ); -ok( !defined $^R, '..$^R after ac !~ ab' ); - -$^R = undef; -like( 'ac', qr/^a(?{15})(?:b(?{16}))?/, 'ac =~ ab?' ); -cmp_ok( $^R, '==', 15, '..$^R after ac =~ ab?' ); - -my @ar; -like( 'ab', qr/^a(?{push @ar,101})(?:b(?{push @ar,102}))?/, 'ab =~ ab? with code push' ); -{ - local $::TODO = "re-eval lex/global miscompiled #328" if is_perlcc_compiled; - cmp_ok( scalar(@ar), '==', 2, '..@ar pushed' ); - cmp_ok( $ar[0], '==', 101, '..first element pushed' ); - cmp_ok( $ar[1], '==', 102, '..second element pushed' ); -} - -$^R = undef; -unlike( 'a', qr/^a(?{103})b(?{104})/, 'a !~ ab with code push' ); -ok( !defined $^R, '..$^R after a !~ ab with code push' ); - -@ar = (); -unlike( 'a', qr/^a(?{push @ar,105})b(?{push @ar,106})/, 'a !~ ab (push)' ); -cmp_ok( scalar(@ar), '==', 0, '..nothing pushed' ); - -@ar = (); -unlike( 'abc', qr/^a(?{push @ar,107})b(?{push @ar,108})$/, 'abc !~ ab$ (push)' ); -cmp_ok( scalar(@ar), '==', 0, '..still nothing pushed' ); - -use vars '@var'; - -like( 'ab', qr/^a(?{push @var,109})(?:b(?{push @var,110}))?/, 'ab =~ ab? push to package var' ); -cmp_ok( scalar(@var), '==', 2, '..@var pushed' ); -cmp_ok( $var[0], '==', 109, '..first element pushed (package)' ); -cmp_ok( $var[1], '==', 110, '..second element pushed (package)' ); - -@var = (); -unlike( 'a', qr/^a(?{push @var,111})b(?{push @var,112})/, 'a !~ ab (push package var)' ); -cmp_ok( scalar(@var), '==', 0, '..nothing pushed (package)' ); - -@var = (); -unlike( 'abc', qr/^a(?{push @var,113})b(?{push @var,114})$/, 'abc !~ ab$ (push package var)' ); -cmp_ok( scalar(@var), '==', 0, '..still nothing pushed (package)' ); - -{ - local $^R = undef; - ok( 'ac' =~ /^a(?{30})(?:b(?{31})|c(?{32}))?/, 'ac =~ a(?:b|c)?' ); - ok( $^R == 32, '$^R == 32' ); -} -{ - local $^R = undef; - ok( 'abbb' =~ /^a(?{36})(?:b(?{37})|c(?{38}))+/, 'abbbb =~ a(?:b|c)+' ); - ok( $^R == 37, '$^R == 37' ) or print "# \$^R=$^R\n"; -} diff --git a/t/CORE/re/subst.t b/t/CORE/re/subst.t deleted file mode 100644 index 238901bfd..000000000 --- a/t/CORE/re/subst.t +++ /dev/null @@ -1,758 +0,0 @@ -#!./perl -w - -BEGIN { - require q(t/CORE/test.pl); - use Config; -} - -plan( tests => 176 ); - -$_ = 'david'; -$a = s/david/rules/r; # fix for poor editors / -ok( $_ eq 'david' && $a eq 'rules', 'non-destructive substitute' ); - -$a = "david" =~ s/david/rules/r; # fix for poor editors / -ok( $a eq 'rules', 's///r with constant' ); - -$a = "david" =~ s/david/"is"."great"/er; # fix for poor editors / -ok( $a eq 'isgreat', 's///er' ); - -$a = "daviddavid" =~ s/david/cool/gr; # fix for poor editors / -ok( $a eq 'coolcool', 's///gr' ); - -$a = 'david'; -$b = $a =~ s/david/sucks/r =~ s/sucks/rules/r; # fix for poor editors / -ok( $a eq 'david' && $b eq 'rules', 'chained s///r' ); - -$a = 'david'; -$b = $a =~ s/xxx/sucks/r; # fix for poor editors / -ok( $a eq 'david' && $b eq 'david', 'non matching s///r' ); - -$a = 'david'; -for (0..2) { - ok( 'david' =~ s/$a/rules/ro eq 'rules', 's///ro '.$_ ); # fix for poor editors / -} - -$a = 'david'; -eval '$b = $a !~ s/david/is great/r'; -like( $@, qr{Using !~ with s///r doesn't make sense}, 's///r !~ operator gives error' ); - -{ - no warnings 'uninitialized'; - $a = undef; - $b = $a =~ s/left/right/r; # fix for poor editors / - ok ( !defined $a && !defined $b, 's///r with undef input' ); - - use warnings; - warning_like(sub { $b = $a =~ s/left/right/r }, # fix for poor editors / - qr/^Use of uninitialized value/, - 's///r Uninitialized warning'); - - $a = 'david'; - warning_like(sub {eval 's/david/sucks/r; 1'}, - qr/^Useless use of non-destructive substitution/, - 's///r void context warning'); -} - -$a = ''; -$b = $a =~ s/david/rules/r; # fix for poor editors / -ok( $a eq '' && $b eq '', 's///r on empty string' ); - -$_ = 'david'; -@b = s/david/rules/r; # fix for poor editors / -ok( $_ eq 'david' && $b[0] eq 'rules', 's///r in list context' ); - -# Magic value and s///r -require Tie::Scalar; -tie $m, 'Tie::StdScalar'; # makes $a magical -$m = "david"; -$b = $m =~ s/david/rules/r; # fix for poor editors / -ok( $m eq 'david' && $b eq 'rules', 's///r with magic input' ); - -$m = $b =~ s/rules/david/r; # fix for poor editors / -ok( defined tied($m), 's///r magic isn\'t lost' ); - -$b = $m =~ s/xxx/yyy/r; # fix for poor editors / -ok( ! defined tied($b), 's///r magic isn\'t contagious' ); - -my $ref = \("aaa" =~ s/aaa/bbb/r); # fix for poor editors / -is (Internals::SvREFCNT($$ref), 1, 's///r does not leak'); -$ref = \("aaa" =~ s/aaa/bbb/rg); # fix for poor editors / -is (Internals::SvREFCNT($$ref), 1, 's///rg does not leak'); - -$x = 'foo'; -$_ = "x"; -s/x/\$x/; -ok( $_ eq '$x', ":$_: eq :\$x:" ); - -$_ = "x"; -s/x/$x/; -ok( $_ eq 'foo', ":$_: eq :foo:" ); - -$_ = "x"; -s/x/\$x $x/; -ok( $_ eq '$x foo', ":$_: eq :\$x foo:" ); - -$b = 'cd'; -($a = 'abcdef') =~ s<(b${b}e)>'\n$1'; -ok( $1 eq 'bcde' && $a eq 'a\n$1f', ":$1: eq :bcde: ; :$a: eq :a\\n\$1f:" ); - -$a = 'abacada'; -ok( ($a =~ s/a/x/g) == 4 && $a eq 'xbxcxdx' ); - -ok( ($a =~ s/a/y/g) == 0 && $a eq 'xbxcxdx' ); - -ok( ($a =~ s/b/y/g) == 1 && $a eq 'xyxcxdx' ); - -$_ = 'ABACADA'; -ok( /a/i && s///gi && $_ eq 'BCD' ); - -$_ = '\\' x 4; -ok( length($_) == 4 ); -$snum = s/\\/\\\\/g; -ok( $_ eq '\\' x 8 && $snum == 4 ); - -$_ = '\/' x 4; -ok( length($_) == 8 ); -$snum = s/\//\/\//g; -ok( $_ eq '\\//' x 4 && $snum == 4 ); -ok( length($_) == 12 ); - -$_ = 'aaaXXXXbbb'; -s/^a//; -ok( $_ eq 'aaXXXXbbb' ); - -$_ = 'aaaXXXXbbb'; -s/a//; -ok( $_ eq 'aaXXXXbbb' ); - -$_ = 'aaaXXXXbbb'; -s/^a/b/; -ok( $_ eq 'baaXXXXbbb' ); - -$_ = 'aaaXXXXbbb'; -s/a/b/; -ok( $_ eq 'baaXXXXbbb' ); - -$_ = 'aaaXXXXbbb'; -s/aa//; -ok( $_ eq 'aXXXXbbb' ); - -$_ = 'aaaXXXXbbb'; -s/aa/b/; -ok( $_ eq 'baXXXXbbb' ); - -$_ = 'aaaXXXXbbb'; -s/b$//; -ok( $_ eq 'aaaXXXXbb' ); - -$_ = 'aaaXXXXbbb'; -s/b//; -ok( $_ eq 'aaaXXXXbb' ); - -$_ = 'aaaXXXXbbb'; -s/bb//; -ok( $_ eq 'aaaXXXXb' ); - -$_ = 'aaaXXXXbbb'; -s/aX/y/; -ok( $_ eq 'aayXXXbbb' ); - -$_ = 'aaaXXXXbbb'; -s/Xb/z/; -ok( $_ eq 'aaaXXXzbb' ); - -$_ = 'aaaXXXXbbb'; -s/aaX.*Xbb//; -ok( $_ eq 'ab' ); - -$_ = 'aaaXXXXbbb'; -s/bb/x/; -ok( $_ eq 'aaaXXXXxb' ); - -# now for some unoptimized versions of the same. - -$_ = 'aaaXXXXbbb'; -$x ne $x || s/^a//; -ok( $_ eq 'aaXXXXbbb' ); - -$_ = 'aaaXXXXbbb'; -$x ne $x || s/a//; -ok( $_ eq 'aaXXXXbbb' ); - -$_ = 'aaaXXXXbbb'; -$x ne $x || s/^a/b/; -ok( $_ eq 'baaXXXXbbb' ); - -$_ = 'aaaXXXXbbb'; -$x ne $x || s/a/b/; -ok( $_ eq 'baaXXXXbbb' ); - -$_ = 'aaaXXXXbbb'; -$x ne $x || s/aa//; -ok( $_ eq 'aXXXXbbb' ); - -$_ = 'aaaXXXXbbb'; -$x ne $x || s/aa/b/; -ok( $_ eq 'baXXXXbbb' ); - -$_ = 'aaaXXXXbbb'; -$x ne $x || s/b$//; -ok( $_ eq 'aaaXXXXbb' ); - -$_ = 'aaaXXXXbbb'; -$x ne $x || s/b//; -ok( $_ eq 'aaaXXXXbb' ); - -$_ = 'aaaXXXXbbb'; -$x ne $x || s/bb//; -ok( $_ eq 'aaaXXXXb' ); - -$_ = 'aaaXXXXbbb'; -$x ne $x || s/aX/y/; -ok( $_ eq 'aayXXXbbb' ); - -$_ = 'aaaXXXXbbb'; -$x ne $x || s/Xb/z/; -ok( $_ eq 'aaaXXXzbb' ); - -$_ = 'aaaXXXXbbb'; -$x ne $x || s/aaX.*Xbb//; -ok( $_ eq 'ab' ); - -$_ = 'aaaXXXXbbb'; -$x ne $x || s/bb/x/; -ok( $_ eq 'aaaXXXXxb' ); - -$_ = 'abc123xyz'; -s/(\d+)/$1*2/e; # yields 'abc246xyz' -ok( $_ eq 'abc246xyz' ); -s/(\d+)/sprintf("%5d",$1)/e; # yields 'abc 246xyz' -ok( $_ eq 'abc 246xyz' ); -s/(\w)/$1 x 2/eg; # yields 'aabbcc 224466xxyyzz' -ok( $_ eq 'aabbcc 224466xxyyzz' ); - -$_ = "aaaaa"; -ok( y/a/b/ == 5 ); -ok( y/a/b/ == 0 ); -ok( y/b// == 5 ); -ok( y/b/c/s == 5 ); -ok( y/c// == 1 ); -ok( y/c//d == 1 ); -ok( $_ eq "" ); - -$_ = "Now is the %#*! time for all good men..."; -ok( ($x=(y/a-zA-Z //cd)) == 7 ); -ok( y/ / /s == 8 ); - -$_ = 'abcdefghijklmnopqrstuvwxyz0123456789'; -tr/a-z/A-Z/; - -ok( $_ eq 'ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789' ); - -# same as tr/A-Z/a-z/; -if (defined $Config{ebcdic} && $Config{ebcdic} eq 'define') { # EBCDIC. - no utf8; - y[\301-\351][\201-\251]; -} else { # Ye Olde ASCII. Or something like it. - y[\101-\132][\141-\172]; -} - -ok( $_ eq 'abcdefghijklmnopqrstuvwxyz0123456789' ); - -SKIP: { - skip("not ASCII",1) unless (ord("+") == ord(",") - 1 - && ord(",") == ord("-") - 1 - && ord("a") == ord("b") - 1 - && ord("b") == ord("c") - 1); - $_ = '+,-'; - tr/+--/a-c/; - ok( $_ eq 'abc' ); -} - -$_ = '+,-'; -tr/+\--/a\/c/; -ok( $_ eq 'a,/' ); - -$_ = '+,-'; -tr/-+,/ab\-/; -ok( $_ eq 'b-a' ); - - -# test recursive substitutions -# code based on the recursive expansion of makefile variables - -my %MK = ( - AAAAA => '$(B)', B=>'$(C)', C => 'D', # long->short - E => '$(F)', F=>'p $(G) q', G => 'HHHHH', # short->long - DIR => '$(UNDEFINEDNAME)/xxx', -); -sub var { - my($var,$level) = @_; - return "\$($var)" unless exists $MK{$var}; - return exp_vars($MK{$var}, $level+1); # can recurse -} -sub exp_vars { - my($str,$level) = @_; - $str =~ s/\$\((\w+)\)/var($1, $level+1)/ge; # can recurse - #warn "exp_vars $level = '$str'\n"; - $str; -} - -ok( exp_vars('$(AAAAA)',0) eq 'D' ); -ok( exp_vars('$(E)',0) eq 'p HHHHH q' ); -ok( exp_vars('$(DIR)',0) eq '$(UNDEFINEDNAME)/xxx' ); -ok( exp_vars('foo $(DIR)/yyy bar',0) eq 'foo $(UNDEFINEDNAME)/xxx/yyy bar' ); - -$_ = "abcd"; -s/(..)/$x = $1, m#.#/eg; -ok( $x eq "cd", 'a match nested in the RHS of a substitution' ); - -# Subst and lookbehind - -$_="ccccc"; -$snum = s/(?/g; -$foo = '<>' . ('<>' x 20) ; -ok( $_ eq $foo && $snum == 41 ); - -$t = 'aaaaaaaaa'; - -$_ = $t; -pos = 6; -$snum = s/\Ga/xx/g; -ok( $_ eq 'aaaaaaxxxxxx' && $snum == 3 ); - -$_ = $t; -pos = 6; -$snum = s/\Ga/x/g; -ok( $_ eq 'aaaaaaxxx' && $snum == 3 ); - -$_ = $t; -pos = 6; -s/\Ga/xx/; -ok( $_ eq 'aaaaaaxxaa' ); - -$_ = $t; -pos = 6; -s/\Ga/x/; -ok( $_ eq 'aaaaaaxaa' ); - -$_ = $t; -$snum = s/\Ga/xx/g; -ok( $_ eq 'xxxxxxxxxxxxxxxxxx' && $snum == 9 ); - -$_ = $t; -$snum = s/\Ga/x/g; -ok( $_ eq 'xxxxxxxxx' && $snum == 9 ); - -$_ = $t; -s/\Ga/xx/; -ok( $_ eq 'xxaaaaaaaa' ); - -$_ = $t; -s/\Ga/x/; -ok( $_ eq 'xaaaaaaaa' ); - -$_ = 'aaaa'; -$snum = s/\ba/./g; -ok( $_ eq '.aaa' && $snum == 1 ); - -eval q% s/a/"b"}/e %; -ok( $@ =~ /Bad evalled substitution/ ); -eval q% ($_ = "x") =~ s/(.)/"$1 "/e %; -ok( $_ eq "x " and !length $@ ); -$x = $x = 'interp'; -eval q% ($_ = "x") =~ s/x(($x)*)/"$1"/e %; -ok( $_ eq '' and !length $@ ); - -$_ = "C:/"; -ok( !s/^([a-z]:)/\u$1/ ); - -$_ = "Charles Bronson"; -$snum = s/\B\w//g; -ok( $_ eq "C B" && $snum == 12 ); - -{ - use utf8; - my $s = "H\303\266he"; - my $l = my $r = $s; - $l =~ s/[^\w]//g; - $r =~ s/[^\w\.]//g; - is($l, $r, "use utf8 \\w"); -} - -my $pv1 = my $pv2 = "Andreas J. K\303\266nig"; -$pv1 =~ s/A/\x{100}/; -substr($pv2,0,1) = "\x{100}"; -is($pv1, $pv2); - -SKIP: { - skip("EBCDIC", 3) if ord("A") == 193; - - { - # Gregor Chrupala - use utf8; - $a = 'España'; - $a =~ s/ñ/ñ/; - like($a, qr/ñ/, "use utf8 RHS"); - } - - { - use utf8; - $a = 'España España'; - $a =~ s/ñ/ñ/; - like($a, qr/ñ/, "use utf8 LHS"); - } - - { - use utf8; - $a = 'España'; - $a =~ s/ñ/ñ/; - like($a, qr/ñ/, "use utf8 LHS and RHS"); - } -} - -{ - # SADAHIRO Tomoyuki - - $a = "\x{100}\x{101}"; - $a =~ s/\x{101}/\xFF/; - like($a, qr/\xFF/); - is(length($a), 2, "SADAHIRO utf8 s///"); - - $a = "\x{100}\x{101}"; - $a =~ s/\x{101}/"\xFF"/e; - like($a, qr/\xFF/); - is(length($a), 2); - - $a = "\x{100}\x{101}"; - $a =~ s/\x{101}/\xFF\xFF\xFF/; - like($a, qr/\xFF\xFF\xFF/); - is(length($a), 4); - - $a = "\x{100}\x{101}"; - $a =~ s/\x{101}/"\xFF\xFF\xFF"/e; - like($a, qr/\xFF\xFF\xFF/); - is(length($a), 4); - - $a = "\xFF\x{101}"; - $a =~ s/\xFF/\x{100}/; - like($a, qr/\x{100}/); - is(length($a), 2); - - $a = "\xFF\x{101}"; - $a =~ s/\xFF/"\x{100}"/e; - like($a, qr/\x{100}/); - is(length($a), 2); - - $a = "\xFF"; - $a =~ s/\xFF/\x{100}/; - like($a, qr/\x{100}/); - is(length($a), 1); - - $a = "\xFF"; - $a =~ s/\xFF/"\x{100}"/e; - like($a, qr/\x{100}/); - is(length($a), 1); -} - -{ - # subst with mixed utf8/non-utf8 type - my($ua, $ub, $uc, $ud) = ("\x{101}", "\x{102}", "\x{103}", "\x{104}"); - my($na, $nb) = ("\x{ff}", "\x{fe}"); - my $a = "$ua--$ub"; - my $b; - ($b = $a) =~ s/--/$na/; - is($b, "$ua$na$ub", "s///: replace non-utf8 into utf8"); - ($b = $a) =~ s/--/--$na--/; - is($b, "$ua--$na--$ub", "s///: replace long non-utf8 into utf8"); - ($b = $a) =~ s/--/$uc/; - is($b, "$ua$uc$ub", "s///: replace utf8 into utf8"); - ($b = $a) =~ s/--/--$uc--/; - is($b, "$ua--$uc--$ub", "s///: replace long utf8 into utf8"); - $a = "$na--$nb"; - ($b = $a) =~ s/--/$ua/; - is($b, "$na$ua$nb", "s///: replace utf8 into non-utf8"); - ($b = $a) =~ s/--/--$ua--/; - is($b, "$na--$ua--$nb", "s///: replace long utf8 into non-utf8"); - - # now with utf8 pattern - $a = "$ua--$ub"; - ($b = $a) =~ s/-($ud)?-/$na/; - is($b, "$ua$na$ub", "s///: replace non-utf8 into utf8 (utf8 pattern)"); - ($b = $a) =~ s/-($ud)?-/--$na--/; - is($b, "$ua--$na--$ub", "s///: replace long non-utf8 into utf8 (utf8 pattern)"); - ($b = $a) =~ s/-($ud)?-/$uc/; - is($b, "$ua$uc$ub", "s///: replace utf8 into utf8 (utf8 pattern)"); - ($b = $a) =~ s/-($ud)?-/--$uc--/; - is($b, "$ua--$uc--$ub", "s///: replace long utf8 into utf8 (utf8 pattern)"); - $a = "$na--$nb"; - ($b = $a) =~ s/-($ud)?-/$ua/; - is($b, "$na$ua$nb", "s///: replace utf8 into non-utf8 (utf8 pattern)"); - ($b = $a) =~ s/-($ud)?-/--$ua--/; - is($b, "$na--$ua--$nb", "s///: replace long utf8 into non-utf8 (utf8 pattern)"); - ($b = $a) =~ s/-($ud)?-/$na/; - is($b, "$na$na$nb", "s///: replace non-utf8 into non-utf8 (utf8 pattern)"); - ($b = $a) =~ s/-($ud)?-/--$na--/; - is($b, "$na--$na--$nb", "s///: replace long non-utf8 into non-utf8 (utf8 pattern)"); -} - -$_ = 'aaaa'; -$r = 'x'; -$s = s/a(?{})/$r/g; -is("<$_> <$s>", " <4>", "[perl #7806]"); - -$_ = 'aaaa'; -$s = s/a(?{})//g; -is("<$_> <$s>", "<> <4>", "[perl #7806]"); - -# [perl #19048] Coredump in silly replacement -{ - local $^W = 0; - $_="abcdef\n"; - s!.!!eg; - is($_, "\n", "[perl #19048]"); -} - -# [perl #17757] interaction between saw_ampersand and study -{ - my $f = eval q{ $& }; - $f = "xx"; - study $f; - $f =~ s/x/y/g; - is($f, "yy", "[perl #17757]"); -} - -# [perl #20684] returned a zero count -$_ = "1111"; -is(s/(??{1})/2/eg, 4, '#20684 s/// with (??{..}) inside'); - -# [perl #20682] @- not visible in replacement -$_ = "123"; -/(2)/; # seed @- with something else -s/(1)(2)(3)/$#- (@-)/; -is($_, "3 (0 0 1 2)", '#20682 @- not visible in replacement'); - -# [perl #20682] $^N not visible in replacement -$_ = "abc"; -/(a)/; s/(b)|(c)/-$^N/g; -is($_,'a-b-c','#20682 $^N not visible in replacement'); - -# [perl #22351] perl bug with 'e' substitution modifier -my $name = "chris"; -{ - no warnings 'uninitialized'; - $name =~ s/hr//e; -} -is($name, "cis", q[#22351 bug with 'e' substitution modifier]); - - -# [perl #34171] $1 didn't honour 'use bytes' in s//e -{ - my $s="\x{100}"; - my $x; - { - use bytes; - $s=~ s/(..)/$x=$1/e - } - is(length($x), 2, '[perl #34171]'); -} - - -{ # [perl #27940] perlbug: [\x00-\x1f] works, [\c@-\c_] does not - my $c; - - ($c = "\x20\c@\x30\cA\x40\cZ\x50\c_\x60") =~ s/[\c@-\c_]//g; - is($c, "\x20\x30\x40\x50\x60", "s/[\\c\@-\\c_]//g"); - - ($c = "\x20\x00\x30\x01\x40\x1A\x50\x1F\x60") =~ s/[\x00-\x1f]//g; - is($c, "\x20\x30\x40\x50\x60", "s/[\\x00-\\x1f]//g"); -} -{ - $_ = "xy"; - no warnings 'uninitialized'; - /(((((((((x)))))))))(z)/; # clear $10 - s/(((((((((x)))))))))(y)/${10}/; - is($_,"y","RT#6006: \$_ eq '$_'"); - $_ = "xr"; - s/(((((((((x)))))))))(r)/fooba${10}/; - is($_,"foobar","RT#6006: \$_ eq '$_'"); -} -{ - my $want=("\n" x 11).("B\n" x 11)."B"; - $_="B"; - our $i; - for $i(1..11){ - s/^.*$/$&/gm; - $_="\n$_\n$&"; - } - is($want,$_,"RT#17542"); -} - -{ - my @tests = ('ABC', "\xA3\xA4\xA5", "\x{410}\x{411}\x{412}"); - foreach (@tests) { - my $id = ord $_; - s/./pos/ge; - is($_, "012", "RT#52104: $id"); - } -} - -fresh_perl_is( '$_=q(foo);s/(.)\G//g;print' => 'foo', '[perl #69056] positive GPOS regex segfault' ); -fresh_perl_is( '$_="abcef"; s/bc|(.)\G(.)/$1 ? "[$1-$2]" : "XX"/ge; print' => 'aXX[c-e][e-f]f', 'positive GPOS regex substitution failure' ); - -# [perl #71470] $var =~ s/$qr//e calling get-magic on $_ as well as $var -{ - local *_; - my $scratch; - sub qrBug::TIESCALAR { bless[pop], 'qrBug' } - sub qrBug::FETCH { $scratch .= "[fetching $_[0][0]]"; 'prew' } - sub qrBug::STORE{} - tie my $kror, qrBug => '$kror'; - tie $_, qrBug => '$_'; - my $qr = qr/(?:)/; - $kror =~ s/$qr/""/e; - is( - $scratch, '[fetching $kror]', - 'bug: $var =~ s/$qr//e calling get-magic on $_ as well as $var', - ); -} - -{ # Bug #41530; replacing non-utf8 with a utf8 causes problems - my $string = "a\x{a0}a"; - my $sub_string = $string; - ok(! utf8::is_utf8($sub_string), "Verify that string isn't initially utf8"); - $sub_string =~ s/a/\x{100}/g; - ok(utf8::is_utf8($sub_string), - 'Verify replace of non-utf8 with utf8 upgrades to utf8'); - is($sub_string, "\x{100}\x{A0}\x{100}", - 'Verify #41530 fixed: replace of non-utf8 with utf8'); - - my $non_sub_string = $string; - ok(! utf8::is_utf8($non_sub_string), - "Verify that string isn't initially utf8"); - $non_sub_string =~ s/b/\x{100}/g; - ok(! utf8::is_utf8($non_sub_string), - "Verify that failed substitute doesn't change string's utf8ness"); - is($non_sub_string, $string, - "Verify that failed substitute doesn't change string"); -} - -{ # Verify largish octal in replacement pattern - - my $string = "a"; - $string =~ s/a/\400/; - is($string, chr 0x100, "Verify that handles s/foo/\\400/"); - $string =~ s/./\600/; - is($string, chr 0x180, "Verify that handles s/foo/\\600/"); - $string =~ s/./\777/; - is($string, chr 0x1FF, "Verify that handles s/foo/\\777/"); -} - -# Scoping of s//the RHS/ when there is no /e -# Tests based on [perl #19078] -{ - local *_; - my $output = ''; my %a; - no warnings 'uninitialized'; - - $_="CCCGGG"; - s!.!<@a{$output .= ("$&"),/[$&]/g}>!g; - $output .= $_; - is( - $output, "CCCGGG< >< >< >< >< >< >", - 's/// sets PL_curpm for each iteration even when the RHS has set it' - ); - - s/C/$a{m\G\}/; - is( - "$&", G => - 'Match vars reflect the last match after s/pat/$a{m|pat|}/ without /e' - ); -} - -{ - # a tied scalar that returned a plain string, got messed up - # when substituted with a UTF8 replacement string, due to - # magic getting called multiple times, and pointers now pointing - # to stale/freed strings - package FOO; - my $fc; - sub TIESCALAR { bless [ "abcdefgh" ] } - sub FETCH { $fc++; $_[0][0] } - sub STORE { $_[0][0] = $_[1] } - - my $s; - tie $s, 'FOO'; - $s =~ s/..../\x{101}/; - ::is($fc, 1, "tied UTF8 stuff FETCH count"); - ::is("$s", "\x{101}efgh", "tied UTF8 stuff"); -} diff --git a/t/CORE/re/subst_amp.t b/t/CORE/re/subst_amp.t deleted file mode 100644 index 91fd8f102..000000000 --- a/t/CORE/re/subst_amp.t +++ /dev/null @@ -1,96 +0,0 @@ -#!./perl -w - -BEGIN { - require q(t/CORE/test.pl); -} - -if (is_perlcc_compiled()) { - skip_all "re-eval lex/global miscompiled #328"; -} else { - -use strict; - -$_ = 'x' x 20; -s/\d*|x/<$&>/g; -my $foo = '<>' . ('<>' x 20) ; -is($_, $foo); - -my $t = 'aaa'; - -$_ = $t; -my @res; -pos = 1; -s/\Ga(?{push @res, $_, $`})/xx/g; -is("$_ @res", 'axxxx aaa a aaa aa'); - -$_ = $t; -@res = (); -pos = 1; -s/\Ga(?{push @res, $_, $`})/x/g; -is("$_ @res", 'axx aaa a aaa aa'); - -$_ = $t; -@res = (); -pos = 1; -s/\Ga(?{push @res, $_, $`})/xx/; -is("$_ @res", 'axxa aaa a'); - -$_ = $t; -@res = (); -pos = 1; -s/\Ga(?{push @res, $_, $`})/x/; -is("$_ @res", 'axa aaa a'); - -$a = $t; -@res = (); -pos ($a) = 1; -$a =~ s/\Ga(?{push @res, $_, $`})/xx/g; -is("$a @res", 'axxxx aaa a aaa aa'); - -$a = $t; -@res = (); -pos ($a) = 1; -$a =~ s/\Ga(?{push @res, $_, $`})/x/g; -is("$a @res", 'axx aaa a aaa aa'); - -$a = $t; -@res = (); -pos ($a) = 1; -$a =~ s/\Ga(?{push @res, $_, $`})/xx/; -is("$a @res", 'axxa aaa a'); - -$a = $t; -@res = (); -pos ($a) = 1; -$a =~ s/\Ga(?{push @res, $_, $`})/x/; -is("$a @res", 'axa aaa a'); - -sub x2 {'xx'} -sub x1 {'x'} - -$a = $t; -@res = (); -pos ($a) = 1; -$a =~ s/\Ga(?{push @res, $_, $`})/x2/ge; -is("$a @res", 'axxxx aaa a aaa aa'); - -$a = $t; -@res = (); -pos ($a) = 1; -$a =~ s/\Ga(?{push @res, $_, $`})/x1/ge; -is("$a @res", 'axx aaa a aaa aa'); - -$a = $t; -@res = (); -pos ($a) = 1; -$a =~ s/\Ga(?{push @res, $_, $`})/x2/e; -is("$a @res", 'axxa aaa a'); - -$a = $t; -@res = (); -pos ($a) = 1; -$a =~ s/\Ga(?{push @res, $_, $`})/x1/e; -is("$a @res", 'axa aaa a'); - -} -done_testing(); diff --git a/t/CORE/re/substr.t b/t/CORE/re/substr.t deleted file mode 100644 index 3546accca..000000000 --- a/t/CORE/re/substr.t +++ /dev/null @@ -1,748 +0,0 @@ -#!./perl - -#P = start of string Q = start of substr R = end of substr S = end of string - -BEGIN { -require q(t/CORE/test.pl); - -} -use warnings ; -no warnings 'deprecated'; - -$a = 'abcdefxyz'; -$SIG{__WARN__} = sub { - if ($_[0] =~ /^substr outside of string/) { - $w++; - } elsif ($_[0] =~ /^Attempt to use reference as lvalue in substr/) { - $w += 2; - } elsif ($_[0] =~ /^Use of uninitialized value/) { - $w += 3; - } else { - warn $_[0]; - } -}; - -plan(355); - -run_tests() unless caller; - -my $krunch = "a"; - -sub run_tests { - -$FATAL_MSG = qr/^substr outside of string/; - -is(substr($a,0,3), 'abc'); # P=Q R S -is(substr($a,3,3), 'def'); # P Q R S -is(substr($a,6,999), 'xyz'); # P Q S R -$b = substr($a,999,999) ; # warn # P R Q S -is ($w--, 1); -eval{substr($a,999,999) = "" ; };# P R Q S -like ($@, $FATAL_MSG); -is(substr($a,0,-6), 'abc'); # P=Q R S -is(substr($a,-3,1), 'x'); # P Q R S - -# unsupported $[ -=pod -$[ = 1; - -is(substr($a,1,3), 'abc' ); # P=Q R S -is(substr($a,4,3), 'def' ); # P Q R S -is(substr($a,7,999), 'xyz');# P Q S R -$b = substr($a,999,999) ; # warn # P R Q S -is($w--, 1); -eval{substr($a,999,999) = "" ; } ; # P R Q S -like ($@, $FATAL_MSG); -is(substr($a,1,-6), 'abc' );# P=Q R S -is(substr($a,-3,1), 'x' ); # P Q R S - -$[ = 0; -=cut - -substr($a,3,3) = 'XYZ'; -is($a, 'abcXYZxyz' ); -substr($a,0,2) = ''; -is($a, 'cXYZxyz' ); -substr($a,0,0) = 'ab'; -is($a, 'abcXYZxyz' ); -substr($a,0,0) = '12345678'; -is($a, '12345678abcXYZxyz' ); -substr($a,-3,3) = 'def'; -is($a, '12345678abcXYZdef'); -substr($a,-3,3) = '<'; -is($a, '12345678abcXYZ<' ); -substr($a,-1,1) = '12345678'; -is($a, '12345678abcXYZ12345678' ); - -$a = 'abcdefxyz'; - -is(substr($a,6), 'xyz' ); # P Q R=S -is(substr($a,-3), 'xyz' ); # P Q R=S -$b = substr($a,999,999) ; # warning # P R=S Q -is($w--, 1); -eval{substr($a,999,999) = "" ; } ; # P R=S Q -like($@, $FATAL_MSG); -is(substr($a,0), 'abcdefxyz'); # P=Q R=S -is(substr($a,9), ''); # P Q=R=S -is(substr($a,-11), 'abcdefxyz'); # Q P R=S -is(substr($a,-9), 'abcdefxyz'); # P=Q R=S - -$a = '54321'; - -$b = substr($a,-7, 1) ; # warn # Q R P S -is($w--, 1); -eval{substr($a,-7, 1) = "" ; }; # Q R P S -like($@, $FATAL_MSG); -$b = substr($a,-7,-6) ; # warn # Q R P S -is($w--, 1); -eval{substr($a,-7,-6) = "" ; }; # Q R P S -like($@, $FATAL_MSG); -is(substr($a,-5,-7), ''); # R P=Q S -is(substr($a, 2,-7), ''); # R P Q S -is(substr($a,-3,-7), ''); # R P Q S -is(substr($a, 2,-5), ''); # P=R Q S -is(substr($a,-3,-5), ''); # P=R Q S -is(substr($a, 2,-4), ''); # P R Q S -is(substr($a,-3,-4), ''); # P R Q S -is(substr($a, 5,-6), ''); # R P Q=S -is(substr($a, 5,-5), ''); # P=R Q S -is(substr($a, 5,-3), ''); # P R Q=S -$b = substr($a, 7,-7) ; # warn # R P S Q -is($w--, 1); -eval{substr($a, 7,-7) = "" ; }; # R P S Q -like($@, $FATAL_MSG); -$b = substr($a, 7,-5) ; # warn # P=R S Q -is($w--, 1); -eval{substr($a, 7,-5) = "" ; }; # P=R S Q -like($@, $FATAL_MSG); -$b = substr($a, 7,-3) ; # warn # P Q S Q -is($w--, 1); -eval{substr($a, 7,-3) = "" ; }; # P Q S Q -like($@, $FATAL_MSG); -$b = substr($a, 7, 0) ; # warn # P S Q=R -is($w--, 1); -eval{substr($a, 7, 0) = "" ; }; # P S Q=R -like($@, $FATAL_MSG); - -is(substr($a,-7,2), ''); # Q P=R S -is(substr($a,-7,4), '54'); # Q P R S -is(substr($a,-7,7), '54321');# Q P R=S -is(substr($a,-7,9), '54321');# Q P S R -is(substr($a,-5,0), ''); # P=Q=R S -is(substr($a,-5,3), '543');# P=Q R S -is(substr($a,-5,5), '54321');# P=Q R=S -is(substr($a,-5,7), '54321');# P=Q S R -is(substr($a,-3,0), ''); # P Q=R S -is(substr($a,-3,3), '321');# P Q R=S -is(substr($a,-2,3), '21'); # P Q S R -is(substr($a,0,-5), ''); # P=Q=R S -is(substr($a,2,-3), ''); # P Q=R S -is(substr($a,0,0), ''); # P=Q=R S -is(substr($a,0,5), '54321');# P=Q R=S -is(substr($a,0,7), '54321');# P=Q S R -is(substr($a,2,0), ''); # P Q=R S -is(substr($a,2,3), '321'); # P Q R=S -is(substr($a,5,0), ''); # P Q=R=S -is(substr($a,5,2), ''); # P Q=S R -is(substr($a,-7,-5), ''); # Q P=R S -is(substr($a,-7,-2), '543');# Q P R S -is(substr($a,-5,-5), ''); # P=Q=R S -is(substr($a,-5,-2), '543');# P=Q R S -is(substr($a,-3,-3), ''); # P Q=R S -is(substr($a,-3,-1), '32');# P Q R S - -$a = ''; - -is(substr($a,-2,2), ''); # Q P=R=S -is(substr($a,0,0), ''); # P=Q=R=S -is(substr($a,0,1), ''); # P=Q=S R -is(substr($a,-2,3), ''); # Q P=S R -is(substr($a,-2), ''); # Q P=R=S -is(substr($a,0), ''); # P=Q=R=S - - -is(substr($a,0,-1), ''); # R P=Q=S -$b = substr($a,-2, 0) ; # warn # Q=R P=S -is($w--, 1); -eval{substr($a,-2, 0) = "" ; }; # Q=R P=S -like($@, $FATAL_MSG); - -$b = substr($a,-2, 1) ; # warn # Q R P=S -is($w--, 1); -eval{substr($a,-2, 1) = "" ; }; # Q R P=S -like($@, $FATAL_MSG); - -$b = substr($a,-2,-1) ; # warn # Q R P=S -is($w--, 1); -eval{substr($a,-2,-1) = "" ; }; # Q R P=S -like($@, $FATAL_MSG); - -$b = substr($a,-2,-2) ; # warn # Q=R P=S -is($w--, 1); -eval{substr($a,-2,-2) = "" ; }; # Q=R P=S -like($@, $FATAL_MSG); - -$b = substr($a, 1,-2) ; # warn # R P=S Q -is($w--, 1); -eval{substr($a, 1,-2) = "" ; }; # R P=S Q -like($@, $FATAL_MSG); - -$b = substr($a, 1, 1) ; # warn # P=S Q R -is($w--, 1); -eval{substr($a, 1, 1) = "" ; }; # P=S Q R -like($@, $FATAL_MSG); - -$b = substr($a, 1, 0) ;# warn # P=S Q=R -is($w--, 1); -eval{substr($a, 1, 0) = "" ; }; # P=S Q=R -like($@, $FATAL_MSG); - -$b = substr($a,1) ; # warning # P=R=S Q -is($w--, 1); -eval{substr($a,1) = "" ; }; # P=R=S Q -like($@, $FATAL_MSG); - -$b = substr($a,-7,-6) ; # warn # Q R P S -is($w--, 1); -eval{substr($a,-7,-6) = "" ; }; # Q R P S -like($@, $FATAL_MSG); - -my $a = 'zxcvbnm'; -substr($a,2,0) = ''; -is($a, 'zxcvbnm'); -substr($a,7,0) = ''; -is($a, 'zxcvbnm'); -substr($a,5,0) = ''; -is($a, 'zxcvbnm'); -substr($a,0,2) = 'pq'; -is($a, 'pqcvbnm'); -substr($a,2,0) = 'r'; -is($a, 'pqrcvbnm'); -substr($a,8,0) = 'asd'; -is($a, 'pqrcvbnmasd'); -substr($a,0,2) = 'iop'; -is($a, 'ioprcvbnmasd'); -substr($a,0,5) = 'fgh'; -is($a, 'fghvbnmasd'); -substr($a,3,5) = 'jkl'; -is($a, 'fghjklsd'); -substr($a,3,2) = '1234'; -is($a, 'fgh1234lsd'); - - -# with lexicals (and in re-entered scopes) -for (0,1) { - my $txt; - unless ($_) { - $txt = "Foo"; - substr($txt, -1) = "X"; - is($txt, "FoX"); - } - else { - substr($txt, 0, 1) = "X"; - is($txt, "X"); - } -} - -$w = 0 ; -# coercion of references -{ - my $s = []; - substr($s, 0, 1) = 'Foo'; - is (substr($s,0,7), "FooRRAY"); - is ($w,2); - $w = 0; -} - -# check no spurious warnings -is($w, 0); - -# check new 4 arg replacement syntax -$a = "abcxyz"; -$w = 0; -is(substr($a, 0, 3, ""), "abc"); -is($a, "xyz"); -is(substr($a, 0, 0, "abc"), ""); -is($a, "abcxyz"); -is(substr($a, 3, -1, ""), "xy"); -is($a, "abcz"); - -is(substr($a, 3, undef, "xy"), ""); -is($a, "abcxyz"); -is($w, 3); - -$w = 0; - -is(substr($a, 3, 9999999, ""), "xyz"); -is($a, "abc"); -eval{substr($a, -99, 0, "") }; -like($@, $FATAL_MSG); -eval{substr($a, 99, 3, "") }; -like($@, $FATAL_MSG); - -substr($a, 0, length($a), "foo"); -is ($a, "foo"); -is ($w, 0); - -# using 4 arg substr as lvalue is a compile time error -eval 'substr($a,0,0,"") = "abc"'; -like ($@, qr/Can't modify substr/); -is ($a, "foo"); - -$a = "abcdefgh"; -is(sub { shift }->(substr($a, 0, 4, "xxxx")), 'abcd'); -is($a, 'xxxxefgh'); - -{ - my $y = 10; - $y = "2" . $y; - is ($y, 210); -} - -# utf8 sanity -{ - my $x = substr("a\x{263a}b",0); - is(length($x), 3); - $x = substr($x,1,1); - is($x, "\x{263a}"); - $x = $x x 2; - is(length($x), 2); - substr($x,0,1) = "abcd"; - is($x, "abcd\x{263a}"); - is(length($x), 5); - $x = reverse $x; - is(length($x), 5); - is($x, "\x{263a}dcba"); - - my $z = 10; - $z = "21\x{263a}" . $z; - is(length($z), 5); - is($z, "21\x{263a}10"); -} - -# replacement should work on magical values -require Tie::Scalar; -my %data; -tie $data{'a'}, 'Tie::StdScalar'; # makes $data{'a'} magical -$data{a} = "firstlast"; -is(substr($data{'a'}, 0, 5, ""), "first"); -is($data{'a'}, "last"); - -# more utf8 - -# The following two originally from Ignasi Roca. - -$x = "\xF1\xF2\xF3"; -substr($x, 0, 1) = "\x{100}"; # Ignasi had \x{FF} -is(length($x), 3); -is($x, "\x{100}\xF2\xF3"); -is(substr($x, 0, 1), "\x{100}"); -is(substr($x, 1, 1), "\x{F2}"); -is(substr($x, 2, 1), "\x{F3}"); - -$x = "\xF1\xF2\xF3"; -substr($x, 0, 1) = "\x{100}\x{FF}"; # Ignasi had \x{FF} -is(length($x), 4); -is($x, "\x{100}\x{FF}\xF2\xF3"); -is(substr($x, 0, 1), "\x{100}"); -is(substr($x, 1, 1), "\x{FF}"); -is(substr($x, 2, 1), "\x{F2}"); -is(substr($x, 3, 1), "\x{F3}"); - -# more utf8 lval exercise - -$x = "\xF1\xF2\xF3"; -substr($x, 0, 2) = "\x{100}\xFF"; -is(length($x), 3); -is($x, "\x{100}\xFF\xF3"); -is(substr($x, 0, 1), "\x{100}"); -is(substr($x, 1, 1), "\x{FF}"); -is(substr($x, 2, 1), "\x{F3}"); - -$x = "\xF1\xF2\xF3"; -substr($x, 1, 1) = "\x{100}\xFF"; -is(length($x), 4); -is($x, "\xF1\x{100}\xFF\xF3"); -is(substr($x, 0, 1), "\x{F1}"); -is(substr($x, 1, 1), "\x{100}"); -is(substr($x, 2, 1), "\x{FF}"); -is(substr($x, 3, 1), "\x{F3}"); - -$x = "\xF1\xF2\xF3"; -substr($x, 2, 1) = "\x{100}\xFF"; -is(length($x), 4); -is($x, "\xF1\xF2\x{100}\xFF"); -is(substr($x, 0, 1), "\x{F1}"); -is(substr($x, 1, 1), "\x{F2}"); -is(substr($x, 2, 1), "\x{100}"); -is(substr($x, 3, 1), "\x{FF}"); - -$x = "\xF1\xF2\xF3"; -substr($x, 3, 1) = "\x{100}\xFF"; -is(length($x), 5); -is($x, "\xF1\xF2\xF3\x{100}\xFF"); -is(substr($x, 0, 1), "\x{F1}"); -is(substr($x, 1, 1), "\x{F2}"); -is(substr($x, 2, 1), "\x{F3}"); -is(substr($x, 3, 1), "\x{100}"); -is(substr($x, 4, 1), "\x{FF}"); - -$x = "\xF1\xF2\xF3"; -substr($x, -1, 1) = "\x{100}\xFF"; -is(length($x), 4); -is($x, "\xF1\xF2\x{100}\xFF"); -is(substr($x, 0, 1), "\x{F1}"); -is(substr($x, 1, 1), "\x{F2}"); -is(substr($x, 2, 1), "\x{100}"); -is(substr($x, 3, 1), "\x{FF}"); - -$x = "\xF1\xF2\xF3"; -substr($x, -1, 0) = "\x{100}\xFF"; -is(length($x), 5); -is($x, "\xF1\xF2\x{100}\xFF\xF3"); -is(substr($x, 0, 1), "\x{F1}"); -is(substr($x, 1, 1), "\x{F2}"); -is(substr($x, 2, 1), "\x{100}"); -is(substr($x, 3, 1), "\x{FF}"); -is(substr($x, 4, 1), "\x{F3}"); - -$x = "\xF1\xF2\xF3"; -substr($x, 0, -1) = "\x{100}\xFF"; -is(length($x), 3); -is($x, "\x{100}\xFF\xF3"); -is(substr($x, 0, 1), "\x{100}"); -is(substr($x, 1, 1), "\x{FF}"); -is(substr($x, 2, 1), "\x{F3}"); - -$x = "\xF1\xF2\xF3"; -substr($x, 0, -2) = "\x{100}\xFF"; -is(length($x), 4); -is($x, "\x{100}\xFF\xF2\xF3"); -is(substr($x, 0, 1), "\x{100}"); -is(substr($x, 1, 1), "\x{FF}"); -is(substr($x, 2, 1), "\x{F2}"); -is(substr($x, 3, 1), "\x{F3}"); - -$x = "\xF1\xF2\xF3"; -substr($x, 0, -3) = "\x{100}\xFF"; -is(length($x), 5); -is($x, "\x{100}\xFF\xF1\xF2\xF3"); -is(substr($x, 0, 1), "\x{100}"); -is(substr($x, 1, 1), "\x{FF}"); -is(substr($x, 2, 1), "\x{F1}"); -is(substr($x, 3, 1), "\x{F2}"); -is(substr($x, 4, 1), "\x{F3}"); - -$x = "\xF1\xF2\xF3"; -substr($x, 1, -1) = "\x{100}\xFF"; -is(length($x), 4); -is($x, "\xF1\x{100}\xFF\xF3"); -is(substr($x, 0, 1), "\x{F1}"); -is(substr($x, 1, 1), "\x{100}"); -is(substr($x, 2, 1), "\x{FF}"); -is(substr($x, 3, 1), "\x{F3}"); - -$x = "\xF1\xF2\xF3"; -substr($x, -1, -1) = "\x{100}\xFF"; -is(length($x), 5); -is($x, "\xF1\xF2\x{100}\xFF\xF3"); -is(substr($x, 0, 1), "\x{F1}"); -is(substr($x, 1, 1), "\x{F2}"); -is(substr($x, 2, 1), "\x{100}"); -is(substr($x, 3, 1), "\x{FF}"); -is(substr($x, 4, 1), "\x{F3}"); - -# And tests for already-UTF8 one - -$x = "\x{101}\x{F2}\x{F3}"; -substr($x, 0, 1) = "\x{100}"; -is(length($x), 3); -is($x, "\x{100}\xF2\xF3"); -is(substr($x, 0, 1), "\x{100}"); -is(substr($x, 1, 1), "\x{F2}"); -is(substr($x, 2, 1), "\x{F3}"); - -$x = "\x{101}\x{F2}\x{F3}"; -substr($x, 0, 1) = "\x{100}\x{FF}"; -is(length($x), 4); -is($x, "\x{100}\x{FF}\xF2\xF3"); -is(substr($x, 0, 1), "\x{100}"); -is(substr($x, 1, 1), "\x{FF}"); -is(substr($x, 2, 1), "\x{F2}"); -is(substr($x, 3, 1), "\x{F3}"); - -$x = "\x{101}\x{F2}\x{F3}"; -substr($x, 0, 2) = "\x{100}\xFF"; -is(length($x), 3); -is($x, "\x{100}\xFF\xF3"); -is(substr($x, 0, 1), "\x{100}"); -is(substr($x, 1, 1), "\x{FF}"); -is(substr($x, 2, 1), "\x{F3}"); - -$x = "\x{101}\x{F2}\x{F3}"; -substr($x, 1, 1) = "\x{100}\xFF"; -is(length($x), 4); -is($x, "\x{101}\x{100}\xFF\xF3"); -is(substr($x, 0, 1), "\x{101}"); -is(substr($x, 1, 1), "\x{100}"); -is(substr($x, 2, 1), "\x{FF}"); -is(substr($x, 3, 1), "\x{F3}"); - -$x = "\x{101}\x{F2}\x{F3}"; -substr($x, 2, 1) = "\x{100}\xFF"; -is(length($x), 4); -is($x, "\x{101}\xF2\x{100}\xFF"); -is(substr($x, 0, 1), "\x{101}"); -is(substr($x, 1, 1), "\x{F2}"); -is(substr($x, 2, 1), "\x{100}"); -is(substr($x, 3, 1), "\x{FF}"); - -$x = "\x{101}\x{F2}\x{F3}"; -substr($x, 3, 1) = "\x{100}\xFF"; -is(length($x), 5); -is($x, "\x{101}\x{F2}\x{F3}\x{100}\xFF"); -is(substr($x, 0, 1), "\x{101}"); -is(substr($x, 1, 1), "\x{F2}"); -is(substr($x, 2, 1), "\x{F3}"); -is(substr($x, 3, 1), "\x{100}"); -is(substr($x, 4, 1), "\x{FF}"); - -$x = "\x{101}\x{F2}\x{F3}"; -substr($x, -1, 1) = "\x{100}\xFF"; -is(length($x), 4); -is($x, "\x{101}\xF2\x{100}\xFF"); -is(substr($x, 0, 1), "\x{101}"); -is(substr($x, 1, 1), "\x{F2}"); -is(substr($x, 2, 1), "\x{100}"); -is(substr($x, 3, 1), "\x{FF}"); - -$x = "\x{101}\x{F2}\x{F3}"; -substr($x, -1, 0) = "\x{100}\xFF"; -is(length($x), 5); -is($x, "\x{101}\xF2\x{100}\xFF\xF3"); -is(substr($x, 0, 1), "\x{101}"); -is(substr($x, 1, 1), "\x{F2}"); -is(substr($x, 2, 1), "\x{100}"); -is(substr($x, 3, 1), "\x{FF}"); -is(substr($x, 4, 1), "\x{F3}"); - -$x = "\x{101}\x{F2}\x{F3}"; -substr($x, 0, -1) = "\x{100}\xFF"; -is(length($x), 3); -is($x, "\x{100}\xFF\xF3"); -is(substr($x, 0, 1), "\x{100}"); -is(substr($x, 1, 1), "\x{FF}"); -is(substr($x, 2, 1), "\x{F3}"); - -$x = "\x{101}\x{F2}\x{F3}"; -substr($x, 0, -2) = "\x{100}\xFF"; -is(length($x), 4); -is($x, "\x{100}\xFF\xF2\xF3"); -is(substr($x, 0, 1), "\x{100}"); -is(substr($x, 1, 1), "\x{FF}"); -is(substr($x, 2, 1), "\x{F2}"); -is(substr($x, 3, 1), "\x{F3}"); - -$x = "\x{101}\x{F2}\x{F3}"; -substr($x, 0, -3) = "\x{100}\xFF"; -is(length($x), 5); -is($x, "\x{100}\xFF\x{101}\x{F2}\x{F3}"); -is(substr($x, 0, 1), "\x{100}"); -is(substr($x, 1, 1), "\x{FF}"); -is(substr($x, 2, 1), "\x{101}"); -is(substr($x, 3, 1), "\x{F2}"); -is(substr($x, 4, 1), "\x{F3}"); - -$x = "\x{101}\x{F2}\x{F3}"; -substr($x, 1, -1) = "\x{100}\xFF"; -is(length($x), 4); -is($x, "\x{101}\x{100}\xFF\xF3"); -is(substr($x, 0, 1), "\x{101}"); -is(substr($x, 1, 1), "\x{100}"); -is(substr($x, 2, 1), "\x{FF}"); -is(substr($x, 3, 1), "\x{F3}"); - -$x = "\x{101}\x{F2}\x{F3}"; -substr($x, -1, -1) = "\x{100}\xFF"; -is(length($x), 5); -is($x, "\x{101}\xF2\x{100}\xFF\xF3"); -is(substr($x, 0, 1), "\x{101}"); -is(substr($x, 1, 1), "\x{F2}"); -is(substr($x, 2, 1), "\x{100}"); -is(substr($x, 3, 1), "\x{FF}"); -is(substr($x, 4, 1), "\x{F3}"); - -substr($x = "ab", 0, 0, "\x{100}\x{200}"); -is($x, "\x{100}\x{200}ab"); - -substr($x = "\x{100}\x{200}", 0, 0, "ab"); -is($x, "ab\x{100}\x{200}"); - -substr($x = "ab", 1, 0, "\x{100}\x{200}"); -is($x, "a\x{100}\x{200}b"); - -substr($x = "\x{100}\x{200}", 1, 0, "ab"); -is($x, "\x{100}ab\x{200}"); - -substr($x = "ab", 2, 0, "\x{100}\x{200}"); -is($x, "ab\x{100}\x{200}"); - -substr($x = "\x{100}\x{200}", 2, 0, "ab"); -is($x, "\x{100}\x{200}ab"); - -substr($x = "\xFFb", 0, 0, "\x{100}\x{200}"); -is($x, "\x{100}\x{200}\xFFb"); - -substr($x = "\x{100}\x{200}", 0, 0, "\xFFb"); -is($x, "\xFFb\x{100}\x{200}"); - -substr($x = "\xFFb", 1, 0, "\x{100}\x{200}"); -is($x, "\xFF\x{100}\x{200}b"); - -substr($x = "\x{100}\x{200}", 1, 0, "\xFFb"); -is($x, "\x{100}\xFFb\x{200}"); - -substr($x = "\xFFb", 2, 0, "\x{100}\x{200}"); -is($x, "\xFFb\x{100}\x{200}"); - -substr($x = "\x{100}\x{200}", 2, 0, "\xFFb"); -is($x, "\x{100}\x{200}\xFFb"); - -# [perl #20933] -{ - my $s = "ab"; - my @r; - $r[$_] = \ substr $s, $_, 1 for (0, 1); - is(join("", map { $$_ } @r), "ab"); -} - -# [perl #23207] -{ - sub ss { - substr($_[0],0,1) ^= substr($_[0],1,1) ^= - substr($_[0],0,1) ^= substr($_[0],1,1); - } - my $x = my $y = 'AB'; ss $x; ss $y; - is($x, $y); -} - -# [perl #24605] -{ - my $x = "0123456789\x{500}"; - my $y = substr $x, 4; - is(substr($x, 7, 1), "7"); -} - -# multiple assignments to lvalue [perl #24346] -{ - my $x = "abcdef"; - for (substr($x,1,3)) { - is($_, 'bcd'); - $_ = 'XX'; - is($_, 'XX'); - is($x, 'aXXef'); - $_ = "\xFF"; - is($_, "\xFF"); - is($x, "a\xFFef"); - $_ = "\xF1\xF2\xF3\xF4\xF5\xF6"; - is($_, "\xF1\xF2\xF3\xF4\xF5\xF6"); - is($x, "a\xF1\xF2\xF3\xF4\xF5\xF6ef"); - $_ = 'YYYY'; - is($_, 'YYYY'); - is($x, 'aYYYYef'); - } -} - -# [perl #24200] string corruption with lvalue sub - -{ - sub bar: lvalue { substr $krunch, 0 } - bar = "XXX"; - is(bar, 'XXX'); - $krunch = '123456789'; - is(bar, '123456789'); -} - -# [perl #29149] -{ - my $text = "0123456789\xED "; - utf8::upgrade($text); - my $pos = 5; - pos($text) = $pos; - my $a = substr($text, $pos, $pos); - is(substr($text,$pos,1), $pos); - -} - -# [perl #23765] -{ - my $a = pack("C", 0xbf); - substr($a, -1) &= chr(0xfeff); - is($a, "\xbf"); -} - -# [perl #34976] incorrect caching of utf8 substr length -{ - my $a = "abcd\x{100}"; - is(substr($a,1,2), 'bc'); - is(substr($a,1,1), 'b'); -} - -# [perl #62646] offsets exceeding 32 bits on 64-bit system -SKIP: { - skip("32-bit system", 24) unless ~0 > 0xffffffff; - my $a = "abc"; - my $s; - my $r; - - utf8::downgrade($a); - for (1..2) { - $w = 0; - $r = substr($a, 0xffffffff, 1); - is($r, undef); - is($w, 1); - - $w = 0; - $r = substr($a, 0xffffffff+1, 1); - is($r, undef); - is($w, 1); - - $w = 0; - ok( !eval { $r = substr($s=$a, 0xffffffff, 1, "_"); 1 } ); - is($r, undef); - is($s, $a); - is($w, 0); - - $w = 0; - ok( !eval { $r = substr($s=$a, 0xffffffff+1, 1, "_"); 1 } ); - is($r, undef); - is($s, $a); - is($w, 0); - - utf8::upgrade($a); - } -} - -} - - -my $destroyed; -{ package Class; DESTROY { ++$destroyed; } } - -$destroyed = 0; -{ - my $x = ''; - substr($x,0,1) = ""; - $x = bless({}, 'Class'); -} -is($destroyed, 1, 'Timely scalar destruction with lvalue substr'); - -# [perl #77692] UTF8 cache not being reset when TARG is reused -ok eval { - local ${^UTF8CACHE} = -1; - for my $i (0..1) - { - my $dummy = length(substr("\x{100}",0,$i)); - } - 1 -}, 'UTF8 cache is reset when TARG is reused [perl #77692]'; diff --git a/t/CORE/test.pl b/t/CORE/test.pl deleted file mode 100644 index c9a04c9db..000000000 --- a/t/CORE/test.pl +++ /dev/null @@ -1,1534 +0,0 @@ -# -# t/test.pl - most of Test::More functionality without the fuss, plus -# has mappings native_to_latin1 and latin1_to_native so that fewer tests -# on non ASCII-ish platforms need to be skipped - -# NOTE: -# -# Increment ($x++) has a certain amount of cleverness for things like -# -# $x = 'zz'; -# $x++; # $x eq 'aaa'; -# -# stands more chance of breaking than just a simple -# -# $x = $x + 1 -# -# In this file, we use the latter "Baby Perl" approach, and increment -# will be worked over by t/op/inc.t - -$Level = 1; -my $test = 1; -my $planned; -my $noplan; -my $Perl; # Safer version of $^X set by which_perl() - -# This defines ASCII/UTF-8 vs EBCDIC/UTF-EBCDIC -$::IS_ASCII = ord 'A' == 65; -$::IS_EBCDIC = ord 'A' == 193; - -$TODO = 0; -$NO_ENDING = 0; -$Tests_Are_Passing = 1; - -# Use this instead of print to avoid interference while testing globals. -sub _print { - local ( $\, $", $, ) = ( undef, ' ', '' ); - print STDOUT @_; -} - -sub _print_stderr { - local ( $\, $", $, ) = ( undef, ' ', '' ); - print STDERR @_; -} - -sub plan { - my $n; - if ( @_ == 1 ) { - $n = shift; - if ( $n eq 'no_plan' ) { - undef $n; - $noplan = 1; - } - } - else { - my %plan = @_; - $n = $plan{tests}; - } - _print "1..$n\n" unless $noplan; - $planned = $n; -} - -# Set the plan at the end. See Test::More::done_testing. -sub done_testing { - my $n = $test - 1; - $n = shift if @_; - - _print "1..$n\n"; - $planned = $n; -} - -END { - my $ran = $test - 1; - if ( !$NO_ENDING ) { - if ( defined $planned && $planned != $ran ) { - _print_stderr "# Looks like you planned $planned tests but ran $ran.\n"; - } - elsif ($noplan) { - _print "1..$ran\n"; - } - } -} - -sub _diag { - return unless @_; - my @mess = _comment(@_); - $TODO ? _print(@mess) : _print_stderr(@mess); -} - -# Use this instead of "print STDERR" when outputting failure diagnostic -# messages -sub diag { - _diag(@_); -} - -# Use this instead of "print" when outputting informational messages -sub note { - return unless @_; - _print( _comment(@_) ); -} - -sub _comment { - return map { /^#/ ? "$_\n" : "# $_\n" } - map { split /\n/ } @_; -} - -sub skip_all { - my $total = $planned || 0; - my $reason = join ' ', @_; - - _print "1..$total # Skip $reason\n"; - for ( 1 .. $total ) { - _print "ok $_ # skip $reason\n"; - } - - exit(0); -} - -sub _ok { - my ( $pass, $where, $name, @mess ) = @_; - - # Do not try to microoptimize by factoring out the "not ". - # VMS will avenge. - my $out; - if ($name) { - - # escape out '#' or it will interfere with '# skip' and such - $name =~ s/#/\\#/g; - $out = $pass ? "ok $test - $name" : "not ok $test - $name"; - } - else { - $out = $pass ? "ok $test" : "not ok $test"; - } - - if ($TODO) { - $out = $out . " # TODO $TODO"; - } - else { - $Tests_Are_Passing = 0 unless $pass; - } - - _print "$out\n"; - - if ($pass) { - note @mess; # Ensure that the message is properly escaped. - } - else { - _diag "# Failed $where\n"; - _diag @mess; - } - - $test = $test + 1; # don't use ++ - - return $pass; -} - -sub _where { - my @caller = caller($Level); - return "at $caller[1] line $caller[2]"; -} - -# DON'T use this for matches. Use like() instead. -sub ok ($@) { - my ( $pass, $name, @mess ) = @_; - _ok( $pass, _where(), $name, @mess ); -} - -sub _q { - my $x = shift; - return 'undef' unless defined $x; - my $q = $x; - $q =~ s/\\/\\\\/g; - $q =~ s/'/\\'/g; - return "'$q'"; -} - -sub _qq { - my $x = shift; - return defined $x ? '"' . display($x) . '"' : 'undef'; -} - -# keys are the codes \n etc map to, values are 2 char strings such as \n -my %backslash_escape; -foreach my $x ( split //, 'nrtfa\\\'"' ) { - $backslash_escape{ ord eval "\"\\$x\"" } = "\\$x"; -} - -# A way to display scalars containing control characters and Unicode. -# Trying to avoid setting $_, or relying on local $_ to work. -sub display { - my @result; - foreach my $x (@_) { - if ( defined $x and not ref $x ) { - my $y = ''; - foreach my $c ( unpack( "U*", $x ) ) { - if ( $c > 255 ) { - $y = $y . sprintf "\\x{%x}", $c; - } - elsif ( $backslash_escape{$c} ) { - $y = $y . $backslash_escape{$c}; - } - else { - my $z = chr $c; # Maybe we can get away with a literal... - if ( $z =~ /[[:^print:]]/ ) { - - # Use octal for characters traditionally expressed as - # such: the low controls - if ( $c <= 037 ) { - $z = sprintf "\\%03o", $c; - } - else { - $z = sprintf "\\x{%x}", $c; - } - } - $y = $y . $z; - } - } - $x = $y; - } - return $x unless wantarray; - push @result, $x; - } - return @result; -} - -sub is ($$@) { - my ( $got, $expected, $name, @mess ) = @_; - - my $pass; - if ( !defined $got || !defined $expected ) { - - # undef only matches undef - $pass = !defined $got && !defined $expected; - } - else { - $pass = $got eq $expected; - } - - unless ($pass) { - unshift( - @mess, "# got " . _qq($got) . "\n", - "# expected " . _qq($expected) . "\n" - ); - } - _ok( $pass, _where(), $name, @mess ); -} - -sub isnt ($$@) { - my ( $got, $isnt, $name, @mess ) = @_; - - my $pass; - if ( !defined $got || !defined $isnt ) { - - # undef only matches undef - $pass = defined $got || defined $isnt; - } - else { - $pass = $got ne $isnt; - } - - unless ($pass) { - unshift( - @mess, "# it should not be " . _qq($got) . "\n", - "# but it is.\n" - ); - } - _ok( $pass, _where(), $name, @mess ); -} - -sub cmp_ok ($$$@) { - my ( $got, $type, $expected, $name, @mess ) = @_; - - my $pass; - { - local $^W = 0; - local ( $@, $! ); # don't interfere with $@ - # eval() sometimes resets $! - $pass = eval "\$got $type \$expected"; - } - unless ($pass) { - - # It seems Irix long doubles can have 2147483648 and 2147483648 - # that stringify to the same thing but are actually numerically - # different. Display the numbers if $type isn't a string operator, - # and the numbers are stringwise the same. - # (all string operators have alphabetic names, so tr/a-z// is true) - # This will also show numbers for some unneeded cases, but will - # definitely be helpful for things such as == and <= that fail - if ( $got eq $expected and $type !~ tr/a-z// ) { - unshift @mess, "# $got - $expected = " . ( $got - $expected ) . "\n"; - } - unshift( - @mess, "# got " . _qq($got) . "\n", - "# expected $type " . _qq($expected) . "\n" - ); - } - _ok( $pass, _where(), $name, @mess ); -} - -# Check that $got is within $range of $expected -# if $range is 0, then check it's exact -# else if $expected is 0, then $range is an absolute value -# otherwise $range is a fractional error. -# Here $range must be numeric, >= 0 -# Non numeric ranges might be a useful future extension. (eg %) -sub within ($$$@) { - my ( $got, $expected, $range, $name, @mess ) = @_; - my $pass; - if ( !defined $got or !defined $expected or !defined $range ) { - - # This is a fail, but doesn't need extra diagnostics - } - elsif ( $got !~ tr/0-9// or $expected !~ tr/0-9// or $range !~ tr/0-9// ) { - - # This is a fail - unshift @mess, "# got, expected and range must be numeric\n"; - } - elsif ( $range < 0 ) { - - # This is also a fail - unshift @mess, "# range must not be negative\n"; - } - elsif ( $range == 0 ) { - - # Within 0 is == - $pass = $got == $expected; - } - elsif ( $expected == 0 ) { - - # If expected is 0, treat range as absolute - $pass = ( $got <= $range ) && ( $got >= -$range ); - } - else { - my $diff = $got - $expected; - $pass = abs( $diff / $expected ) < $range; - } - unless ($pass) { - if ( $got eq $expected ) { - unshift @mess, "# $got - $expected = " . ( $got - $expected ) . "\n"; - } - unshift @mess, "# got " . _qq($got) . "\n", "# expected " . _qq($expected) . " (within " . _qq($range) . ")\n"; - } - _ok( $pass, _where(), $name, @mess ); -} - -# Note: this isn't quite as fancy as Test::More::like(). - -sub like ($$@) { like_yn( 0, @_ ) }; # 0 for - -sub unlike ($$@) { like_yn( 1, @_ ) }; # 1 for un- - -sub like_yn ($$$@) { - my ( $flip, undef, $expected, $name, @mess ) = @_; - my $pass; - $pass = $_[1] =~ /$expected/ if !$flip; - $pass = $_[1] !~ /$expected/ if $flip; - unless ($pass) { - unshift( - @mess, "# got '$_[1]'\n", - $flip ? "# expected !~ /$expected/\n" : "# expected /$expected/\n" - ); - } - local $Level = $Level + 1; - _ok( $pass, _where(), $name, @mess ); -} - -sub pass { - _ok( 1, '', @_ ); -} - -sub fail { - _ok( 0, _where(), @_ ); -} - -sub curr_test { - $test = shift if @_; - return $test; -} - -sub next_test { - my $retval = $test; - $test = $test + 1; # don't use ++ - $retval; -} - -# Note: can't pass multipart messages since we try to -# be compatible with Test::More::skip(). -sub skip { - my $why = shift; - my $n = @_ ? shift : 1; - for ( 1 .. $n ) { - _print "ok $test # skip $why\n"; - $test = $test + 1; - } - local $^W = 0; - last SKIP; -} - -sub todo_skip { - my $why = shift; - my $n = @_ ? shift : 1; - - for ( 1 .. $n ) { - _print "not ok $test # TODO & SKIP $why\n"; - $test = $test + 1; - } - local $^W = 0; - last TODO; -} - -sub eq_array { - my ( $ra, $rb ) = @_; - return 0 unless $#$ra == $#$rb; - for my $i ( 0 .. $#$ra ) { - next if !defined $ra->[$i] && !defined $rb->[$i]; - return 0 if !defined $ra->[$i]; - return 0 if !defined $rb->[$i]; - return 0 unless $ra->[$i] eq $rb->[$i]; - } - return 1; -} - -sub eq_hash { - my ( $orig, $suspect ) = @_; - my $fail; - while ( my ( $key, $value ) = each %$suspect ) { - - # Force a hash recompute if this perl's internals can cache the hash key. - $key = "" . $key; - if ( exists $orig->{$key} ) { - if ( $orig->{$key} ne $value ) { - _print "# key ", _qq($key), " was ", _qq( $orig->{$key} ), " now ", _qq($value), "\n"; - $fail = 1; - } - } - else { - _print "# key ", _qq($key), " is ", _qq($value), ", not in original.\n"; - $fail = 1; - } - } - foreach ( keys %$orig ) { - - # Force a hash recompute if this perl's internals can cache the hash key. - $_ = "" . $_; - next if ( exists $suspect->{$_} ); - _print "# key ", _qq($_), " was ", _qq( $orig->{$_} ), " now missing.\n"; - $fail = 1; - } - !$fail; -} - -# We only provide a subset of the Test::More functionality. -sub require_ok ($) { - my ($require) = @_; - if ( $require =~ tr/[A-Za-z0-9:.]//c ) { - fail("Invalid character in \"$require\", passed to require_ok"); - } - else { - eval < [ command-line switches ] -# nolib => 1 # don't use -I../lib (included by default) -# non_portable => Don't warn if a one liner contains quotes -# prog => one-liner (avoid quotes) -# progs => [ multi-liner (avoid quotes) ] -# progfile => perl script -# stdin => string to feed the stdin -# stderr => redirect stderr to stdout -# args => [ command-line arguments to the perl program ] -# verbose => print the command line - -my $is_mswin = $^O eq 'MSWin32'; -my $is_netware = $^O eq 'NetWare'; -my $is_vms = $^O eq 'VMS'; -my $is_cygwin = $^O eq 'cygwin'; - -sub _quote_args { - my ( $runperl, $args ) = @_; - - foreach (@$args) { - - # In VMS protect with doublequotes because otherwise - # DCL will lowercase -- unless already doublequoted. - $_ = q(") . $_ . q(") if $is_vms && !/^\"/ && length($_) > 0; - $runperl = $runperl . ' ' . $_; - } - return $runperl; -} - -sub _create_runperl { # Create the string to qx in runperl(). - my %args = @_; - my $runperl = which_perl(); - if ( $runperl =~ m/\s/ ) { - $runperl = qq{"$runperl"}; - } - - #- this allows, for example, to set PERL_RUNPERL_DEBUG=/usr/bin/valgrind - if ( $ENV{PERL_RUNPERL_DEBUG} ) { - $runperl = "$ENV{PERL_RUNPERL_DEBUG} $runperl"; - } - unless ( $args{nolib} ) { - $runperl = $runperl . ' "-I../lib"'; # doublequotes because of VMS - } - if ( $args{switches} ) { - local $Level = 2; - die "test.pl:runperl(): 'switches' must be an ARRAYREF " . _where() - unless ref $args{switches} eq "ARRAY"; - $runperl = _quote_args( $runperl, $args{switches} ); - } - if ( defined $args{prog} ) { - die "test.pl:runperl(): both 'prog' and 'progs' cannot be used " . _where() - if defined $args{progs}; - $args{progs} = [ $args{prog} ]; - } - if ( defined $args{progs} ) { - die "test.pl:runperl(): 'progs' must be an ARRAYREF " . _where() - unless ref $args{progs} eq "ARRAY"; - foreach my $prog ( @{ $args{progs} } ) { - if ( $prog =~ tr/'"// && !$args{non_portable} ) { - warn "quotes in prog >>$prog<< are not portable"; - } - if ( $is_mswin || $is_netware || $is_vms ) { - $runperl = $runperl . qq ( -e "$prog" ); - } - else { - $runperl = $runperl . qq ( -e '$prog' ); - } - } - } - elsif ( defined $args{progfile} ) { - $runperl = $runperl . qq( "$args{progfile}"); - } - else { - # You probably didn't want to be sucking in from the upstream stdin - die "test.pl:runperl(): none of prog, progs, progfile, args, " . " switches or stdin specified" - unless defined $args{args} - or defined $args{switches} - or defined $args{stdin}; - } - if ( defined $args{stdin} ) { - - # so we don't try to put literal newlines and crs onto the - # command line. - $args{stdin} =~ s/\n/\\n/g; - $args{stdin} =~ s/\r/\\r/g; - - if ( $is_mswin || $is_netware || $is_vms ) { - $runperl = qq{$Perl -e "print qq(} . $args{stdin} . q{)" | } . $runperl; - } - else { - $runperl = qq{$Perl -e 'print qq(} . $args{stdin} . q{)' | } . $runperl; - } - } - if ( defined $args{args} ) { - $runperl = _quote_args( $runperl, $args{args} ); - } - $runperl = $runperl . ' 2>&1' if $args{stderr}; - if ( $args{verbose} ) { - my $runperldisplay = $runperl; - $runperldisplay =~ s/\n/\n\#/g; - _print_stderr "# $runperldisplay\n"; - } - return $runperl; -} - -sub runperl { - die "test.pl:runperl() does not take a hashref" - if ref $_[0] and ref $_[0] eq 'HASH'; - my $runperl = &_create_runperl; - my $result; - - my $tainted = ${^TAINT}; - my %args = @_; - exists $args{switches} && grep m/^-T$/, @{ $args{switches} } and $tainted = $tainted + 1; - - if ($tainted) { - - # We will assume that if you're running under -T, you really mean to - # run a fresh perl, so we'll brute force launder everything for you - my $sep; - - if ( !eval { require Config; 1 } ) { - warn "test.pl had problems loading Config: $@"; - $sep = ':'; - } - else { - $sep = $Config::Config{path_sep}; - } - - my @keys = grep { exists $ENV{$_} } qw(CDPATH IFS ENV BASH_ENV); - local @ENV{@keys} = (); - - # Untaint, plus take out . and empty string: - local $ENV{'DCL$PATH'} = $1 if $is_vms && exists( $ENV{'DCL$PATH'} ) && ( $ENV{'DCL$PATH'} =~ /(.*)/s ); - $ENV{PATH} =~ /(.*)/s; - local $ENV{PATH} = join $sep, grep { $_ ne "" and $_ ne "." and -d $_ and ( $is_mswin or $is_vms or !( stat && ( stat _ )[2] & 0022 ) ) } - split quotemeta($sep), $1; - if ($is_cygwin) { # Must have /bin under Cygwin - if ( length $ENV{PATH} ) { - $ENV{PATH} = $ENV{PATH} . $sep; - } - $ENV{PATH} = $ENV{PATH} . '/bin'; - } - $runperl =~ /(.*)/s; - $runperl = $1; - - $result = `$runperl`; - } - else { - $result = `$runperl`; - } - $result =~ s/\n\n/\n/ if $is_vms; # XXX pipes sometimes double these - return $result; -} - -# Nice alias -*run_perl = *run_perl = \&runperl; # shut up "used only once" warning - -sub DIE { - _print_stderr "# @_\n"; - exit 1; -} - -# A somewhat safer version of the sometimes wrong $^X. -sub which_perl { - unless ( defined $Perl ) { - $Perl = $^X; - - # VMS should have 'perl' aliased properly - return $Perl if $is_vms; - - my $exe; - if ( !eval { require Config; 1 } ) { - warn "test.pl had problems loading Config: $@"; - $exe = ''; - } - else { - $exe = $Config::Config{_exe}; - } - $exe = '' unless defined $exe; - - # This doesn't absolutize the path: beware of future chdirs(). - # We could do File::Spec->abs2rel() but that does getcwd()s, - # which is a bit heavyweight to do here. - - if ( $Perl =~ /^perl\Q$exe\E$/i ) { - my $perl = "perl$exe"; - if ( !eval { require File::Spec; 1 } ) { - warn "test.pl had problems loading File::Spec: $@"; - $Perl = "./$perl"; - } - else { - $Perl = File::Spec->catfile( File::Spec->curdir(), $perl ); - } - } - - # Build up the name of the executable file from the name of - # the command. - - if ( $Perl !~ /\Q$exe\E$/i ) { - $Perl = $Perl . $exe; - } - - warn "which_perl: cannot find $Perl from $^X" unless -f $Perl; - - # For subcommands to use. - $ENV{PERLEXE} = $Perl; - } - return $Perl; -} - -sub unlink_all { - my $count = 0; - foreach my $file (@_) { - 1 while unlink $file; - if ( -f $file ) { - _print_stderr "# Couldn't unlink '$file': $!\n"; - } - else { - ++$count; - } - } - $count; -} - -my %tmpfiles; -END { unlink_all keys %tmpfiles unless $ENV{BC_DEVELOPING}} - -# A regexp that matches the tempfile names -$::tempfile_regexp = 'tmp\d+[A-Z][A-Z]?'; - -# Avoid ++, avoid ranges, avoid split // -my @letters = qw(A B C D E F G H I J K L M N O P Q R S T U V W X Y Z); - -sub tempfile { - my $count = 0; - do { - my $temp = $count; - my $try = "tmp$$"; - do { - $try = $try . $letters[ $temp % 26 ]; - $temp = int( $temp / 26 ); - } while $temp; - - # Need to note all the file names we allocated, as a second request may - # come before the first is created. - if ( !-e $try && !$tmpfiles{$try} ) { - - # We have a winner - $tmpfiles{$try} = 1; - return $try; - } - $count = $count + 1; - } while $count < 26 * 26; - die "Can't find temporary file name starting 'tmp$$'"; -} - -# This is the temporary file for _fresh_perl -my $tmpfile = tempfile(); - -sub _fresh_perl { - my ( $prog, $action, $expect, $runperl_args, $name ) = @_; - - my $is_binary; - if ( $0 =~ m/\.bin$/ ) { - $is_binary = 1; - - # let makefile do the job - $tmpfile = $0; - ($tmpfile) = $tmpfile =~ m/(.*)/; - $tmpfile =~ s/\.bin$/.subtest.$test.t/; - $tmpfiles{$tmpfile} = 1; - unlink $tmpfile if -e $tmpfile and !$ENV{BC_DEVELOPING}; - } - - # Given the choice of the mis-parsable {} - # (we want an anon hash, but a borked lexer might think that it's a block) - # or relying on taking a reference to a lexical - # (\ might be mis-parsed, and the reference counting on the pad may go - # awry) - # it feels like the least-worse thing is to assume that auto-vivification - # works. At least, this is only going to be a run-time failure, so won't - # affect tests using this file but not this function. - $runperl_args->{progfile} = $tmpfile; - $runperl_args->{stderr} = 1; - - # ($tmpfile) = $tmpfile =~ m/(.*)/; - open( my $TEST, '>', $tmpfile ) or die "Cannot open $tmpfile: $!"; - - # VMS adjustments - if ($is_vms) { - $prog =~ s#/dev/null#NL:#; - - # VMS file locking - $prog =~ s{if \(-e _ and -f _ and -r _\)} - {if (-e _ and -f _)} - } - - print {$TEST} $prog; - close $TEST or die "Cannot close $tmpfile: $!"; - - my $results; - if ($is_binary) { - $results = runperl_binary( $tmpfile, $runperl_args ); - } - else { - $results = runperl(%$runperl_args); - } - - my $status = $?; - - # Clean up the results into something a bit more predictable. - $results =~ s/\n+$//; - $results =~ s/at\s+$::tempfile_regexp\s+line/at - line/g; - $results =~ s/of\s+$::tempfile_regexp\s+aborted/of - aborted/g; - - # bison says 'parse error' instead of 'syntax error', - # various yaccs may or may not capitalize 'syntax'. - $results =~ s/^(syntax|parse) error/syntax error/mig; - - if ($is_vms) { - - # some tests will trigger VMS messages that won't be expected - $results =~ s/\n?%[A-Z]+-[SIWEF]-[A-Z]+,.*//; - - # pipes double these sometimes - $results =~ s/\n\n/\n/g; - } - - # Use the first line of the program as a name if none was given - unless ($name) { - ( $first_line, $name ) = $prog =~ /^((.{1,50}).*)/; - $name = $name . '...' if length $first_line > length $name; - } - - # Historically this was implemented using a closure, but then that means - # that the tests for closures avoid using this code. Given that there - # are exactly two callers, doing exactly two things, the simpler approach - # feels like a better trade off. - my $pass; - if ( $action eq 'eq' ) { - $pass = is( $results, $expect, $name ); - } - elsif ( $action eq '=~' ) { - $pass = like( $results, $expect, $name ); - } - else { - die "_fresh_perl can't process action '$action'"; - } - - unless ($pass) { - _diag "# PROG: \n$prog\n"; - _diag "# STATUS: $status\n"; - } - - return $pass; -} - -sub runperl_binary { - my ( $test, $opts ) = @_; - - $opts ||= {}; - #print STDERR @{$opts->{'switches'}},"\n"; - my $error = $opts->{'stderr'} ? '2>&1' : ''; - my $taint = $opts->{'switches'} ? join(' ',grep /-[tT]/, @{$opts->{'switches'}}) : ''; - my $bin = $test; - my $opt = $ENV{BC_OPT}; - $bin =~ s/\.t$/\.bin/; - unlink $bin if -e $bin; - ( $ENV{PATH} ) = $ENV{PATH} =~ m/(.*)/; - my $cmd = "$^X -Iblib/arch -Iblib/lib script/perlcc $taint $opt -o $bin $test $error"; - ( $cmd ) = $cmd =~ m/(.*)/; - print STDERR "# running: make $bin\n"; - print STDERR "# $cmd\n" if $ENV{TEST_VERBOSE}; - my $make = `$cmd`; - map { print STDERR "# $_\n" } split /\n/, $make; - return $make if $? || $opts->{perlcc_only}; - - # now execute the binary - my $foo = $opts->{'stdin'} || ''; - print STDERR "# running: ./$bin $foo\n"; - my $output; - if ($foo) { - $output = `echo "$foo" | ./$bin $error`; - } - else { - $output = `./$bin $error`; - } - unlink $bin unless $ENV{BC_DEVELOPING}; - return $output; -} - -# -# fresh_perl_is -# -# Combination of run_perl() and is(). -# - -sub fresh_perl_is { - my ( $prog, $expected, $runperl_args, $name ) = @_; - - # _fresh_perl() is going to clip the trailing newlines off the result. - # This will make it so the test author doesn't have to know that. - $expected =~ s/\n+$//; - - local $Level = 2; - _fresh_perl( $prog, 'eq', $expected, $runperl_args, $name ); -} - -# -# fresh_perl_like -# -# Combination of run_perl() and like(). -# - -sub fresh_perl_like { - my ( $prog, $expected, $runperl_args, $name ) = @_; - local $Level = 2; - _fresh_perl( $prog, '=~', $expected, $runperl_args, $name ); -} - -# Many tests use the same format in __DATA__ or external files to specify a -# sequence of (fresh) tests to run, extra files they may temporarily need, and -# what the expected output is. So have excatly one copy of the code to run that - -sub run_multiple_progs { - my $up = shift; - my @prgs; - if ($up) { - - # The tests in lib run in a temporary subdirectory of t, and always - # pass in a list of "programs" to run - @prgs = @_; - } - else { - # The tests below t run in t and pass in a file handle. - my $fh = shift; - local $/; - @prgs = split "\n########\n", <$fh>; - } - - my $tmpfile = tempfile(); - - for (@prgs) { - unless (/\n/) { - print "# From $_\n"; - next; - } - my $switch = ""; - my @temps; - my @temp_path; - if (s/^(\s*-\w+)//) { - $switch = $1; - } - my ( $prog, $expected ) = split( /\nEXPECT(?:\n|$)/, $_, 2 ); - - my %reason; - foreach my $what (qw(skip todo)) { - $prog =~ s/^#\s*\U$what\E\s*(.*)\n//m and $reason{$what} = $1; - - # If the SKIP reason starts ? then it's taken as a code snippet to - # evaluate. This provides the flexibility to have conditional SKIPs - if ( $reason{$what} && $reason{$what} =~ s/^\?// ) { - my $temp = eval $reason{$what}; - if ($@) { - die "# In \U$what\E code reason:\n# $reason{$what}\n$@"; - } - $reason{$what} = $temp; - } - } - - if ( $prog =~ /--FILE--/ ) { - my @files = split( /\n--FILE--\s*([^\s\n]*)\s*\n/, $prog ); - shift @files; - die "Internal error: test $_ didn't split into pairs, got " . scalar(@files) . "[" . join( "%%%%", @files ) . "]\n" - if @files % 2; - while ( @files > 2 ) { - my $filename = shift @files; - my $code = shift @files; - push @temps, $filename; - if ( $filename =~ m#(.*)/# && $filename !~ m#^\.\./# ) { - require File::Path; - File::Path::mkpath($1); - push( @temp_path, $1 ); - } - open my $fh, '>', $filename or die "Cannot open $filename: $!\n"; - print $fh $code; - close $fh or die "Cannot close $filename: $!\n"; - } - shift @files; - $prog = shift @files; - } - - open my $fh, '>', $tmpfile or die "Cannot open >$tmpfile: $!"; - print $fh q{ - BEGIN { - open STDERR, '>&', STDOUT - or die "Can't dup STDOUT->STDERR: $!;"; - } - }; - print $fh "\n#line 1\n"; # So the line numbers don't get messed up. - print $fh $prog, "\n"; - close $fh or die "Cannot close $tmpfile: $!"; - my $results = runperl( - stderr => 1, progfile => $tmpfile, $up - ? ( switches => [ "-I$up/lib", $switch ], nolib => 1 ) - : ( switches => [$switch] ) - ); - my $status = $?; - $results =~ s/\n+$//; - - # allow expected output to be written as if $prog is on STDIN - $results =~ s/$::tempfile_regexp/-/g; - if ( $^O eq 'VMS' ) { - - # some tests will trigger VMS messages that won't be expected - $results =~ s/\n?%[A-Z]+-[SIWEF]-[A-Z]+,.*//; - - # pipes double these sometimes - $results =~ s/\n\n/\n/g; - } - - # bison says 'parse error' instead of 'syntax error', - # various yaccs may or may not capitalize 'syntax'. - $results =~ s/^(syntax|parse) error/syntax error/mig; - - # allow all tests to run when there are leaks - $results =~ s/Scalars leaked: \d+\n//g; - - $expected =~ s/\n+$//; - my $prefix = ( $results =~ s#^PREFIX(\n|$)## ); - - # any special options? (OPTIONS foo bar zap) - my $option_regex = 0; - my $option_random = 0; - if ( $expected =~ s/^OPTIONS? (.+)\n// ) { - foreach my $option ( split( ' ', $1 ) ) { - if ( $option eq 'regex' ) { # allow regular expressions - $option_regex = 1; - } - elsif ( $option eq 'random' ) { # all lines match, but in any order - $option_random = 1; - } - else { - die "$0: Unknown OPTION '$option'\n"; - } - } - } - die "$0: can't have OPTION regex and random\n" - if $option_regex + $option_random > 1; - my $ok = 0; - if ( $results =~ s/^SKIPPED\n// ) { - print "$results\n"; - $ok = 1; - } - elsif ($option_random) { - my @got = sort split "\n", $results; - my @expected = sort split "\n", $expected; - - $ok = "@got" eq "@expected"; - } - elsif ($option_regex) { - $ok = $results =~ /^$expected/; - } - elsif ($prefix) { - $ok = $results =~ /^\Q$expected/; - } - else { - $ok = $results eq $expected; - } - - local $::TODO = $reason{todo}; - - unless ($ok) { - my $err_line = "PROG: $switch\n$prog\n" . "EXPECTED:\n$expected\n" . "GOT:\n$results\n"; - if ($::TODO) { - $err_line =~ s/^/# /mg; - print $err_line; # Harness can't filter it out from STDERR. - } - else { - print STDERR $err_line; - } - } - - ok($ok); - - if (!$ENV{BC_DEVELOPING}) { - foreach (@temps) { - unlink $_ if $_; - } - foreach (@temp_path) { - File::Path::rmtree $_ if -d $_; - } - } - } -} - -sub can_ok ($@) { - my ( $proto, @methods ) = @_; - my $class = ref $proto || $proto; - - unless (@methods) { - return _ok( 0, _where(), "$class->can(...)" ); - } - - my @nok = (); - foreach my $method (@methods) { - local ( $!, $@ ); # don't interfere with caller's $@ - # eval sometimes resets $! - eval { $proto->can($method) } || push @nok, $method; - } - - my $name; - $name = - @methods == 1 - ? "$class->can('$methods[0]')" - : "$class->can(...)"; - - _ok( !@nok, _where(), $name ); -} - -# Call $class->new( @$args ); and run the result through isa_ok. -# See Test::More::new_ok -sub new_ok { - my ( $class, $args, $obj_name ) = @_; - $args ||= []; - $object_name = "The object" unless defined $obj_name; - - local $Level = $Level + 1; - - my $obj; - my $ok = eval { $obj = $class->new(@$args); 1 }; - my $error = $@; - - if ($ok) { - isa_ok( $obj, $class, $object_name ); - } - else { - ok( 0, "new() died" ); - diag("Error was: $@"); - } - - return $obj; - -} - -sub isa_ok ($$;$) { - my ( $object, $class, $obj_name ) = @_; - - my $diag; - $obj_name = 'The object' unless defined $obj_name; - my $name = "$obj_name isa $class"; - if ( !defined $object ) { - $diag = "$obj_name isn't defined"; - } - elsif ( !ref $object ) { - $diag = "$obj_name isn't a reference"; - } - else { - # We can't use UNIVERSAL::isa because we want to honor isa() overrides - local ( $@, $! ); # eval sometimes resets $! - my $rslt = eval { $object->isa($class) }; - if ($@) { - if ( $@ =~ /^Can't call method "isa" on unblessed reference/ ) { - if ( !UNIVERSAL::isa( $object, $class ) ) { - my $ref = ref $object; - $diag = "$obj_name isn't a '$class' it's a '$ref'"; - } - } - else { - die <isa on your object and got some weird error. -This should never happen. Please contact the author immediately. -Here's the error. -$@ -WHOA - } - } - elsif ( !$rslt ) { - my $ref = ref $object; - $diag = "$obj_name isn't a '$class' it's a '$ref'"; - } - } - - _ok( !$diag, _where(), $name ); -} - -# Purposefully avoiding a closure. -sub __capture { - push @::__capture, join "", @_; -} - -sub capture_warnings { - my $code = shift; - - local @::__capture; - local $SIG{__WARN__} = \&__capture; - &$code; - return @::__capture; -} - -# This will generate a variable number of tests. -# Use done_testing() instead of a fixed plan. -sub warnings_like { - my ( $code, $expect, $name ) = @_; - local $Level = $Level + 1; - - my @w = capture_warnings($code); - - cmp_ok( scalar @w, '==', scalar @$expect, $name ); - foreach my $e (@$expect) { - if ( ref $e ) { - like( shift @w, $e, $name ); - } - else { - is( shift @w, $e, $name ); - } - } - if (@w) { - diag("Saw these additional warnings:"); - diag($_) foreach @w; - } -} - -sub _fail_excess_warnings { - my ( $expect, $got, $name ) = @_; - local $Level = $Level + 1; - - # This will fail, and produce diagnostics - is( $expect, scalar @$got, $name ); - diag("Saw these warnings:"); - diag($_) foreach @$got; -} - -sub warning_is { - my ( $code, $expect, $name ) = @_; - die sprintf "Expect must be a string or undef, not a %s reference", ref $expect - if ref $expect; - local $Level = $Level + 1; - my @w = capture_warnings($code); - if ( @w > 1 ) { - _fail_excess_warnings( 0 + defined $expect, \@w, $name ); - } - else { - is( $w[0], $expect, $name ); - } -} - -sub warning_like { - my ( $code, $expect, $name ) = @_; - die sprintf "Expect must be a regexp object" - unless ref $expect eq 'Regexp'; - local $Level = $Level + 1; - my @w = capture_warnings($code); - if ( @w > 1 ) { - _fail_excess_warnings( 0 + defined $expect, \@w, $name ); - } - else { - like( $w[0], $expect, $name ); - } -} - -# Set a watchdog to timeout the entire test file -# NOTE: If the test file uses 'threads', then call the watchdog() function -# _AFTER_ the 'threads' module is loaded. -sub watchdog ($;$) { - my $timeout = shift; - my $method = shift || ""; - my $timeout_msg = 'Test process timed out - terminating'; - - # Valgrind slows perl way down so give it more time before dying. - $timeout *= 10 if $ENV{PERL_VALGRIND}; - - my $pid_to_kill = $$; # PID for this process - - if ( $method eq "alarm" ) { - goto WATCHDOG_VIA_ALARM; - } - - # shut up use only once warning - my $threads_on = $threads::threads && $threads::threads; - - # Don't use a watchdog process if 'threads' is loaded - - # use a watchdog thread instead - if ( !$threads_on ) { - - # On Windows and VMS, try launching a watchdog process - # using system(1, ...) (see perlport.pod) - if ( $is_mswin || $is_vms ) { - - # On Windows, try to get the 'real' PID - if ($is_mswin) { - eval { require Win32; }; - if ( defined(&Win32::GetCurrentProcessId) ) { - $pid_to_kill = Win32::GetCurrentProcessId(); - } - } - - # If we still have a fake PID, we can't use this method at all - return if ( $pid_to_kill <= 0 ); - - # Launch watchdog process - my $watchdog; - eval { - local $SIG{'__WARN__'} = sub { - _diag("Watchdog warning: $_[0]"); - }; - my $sig = $is_vms ? 'TERM' : 'KILL'; - my $cmd = _create_runperl( prog => "sleep($timeout);" . "warn qq/# $timeout_msg" . '\n/;' . "kill($sig, $pid_to_kill);" ); - $watchdog = system( 1, $cmd ); - }; - if ( $@ || ( $watchdog <= 0 ) ) { - _diag('Failed to start watchdog'); - _diag($@) if $@; - undef($watchdog); - return; - } - - # Add END block to parent to terminate and - # clean up watchdog process - eval "END { local \$! = 0; local \$? = 0; - wait() if kill('KILL', $watchdog); };"; - return; - } - - # Try using fork() to generate a watchdog process - my $watchdog; - eval { $watchdog = fork() }; - if ( defined($watchdog) ) { - if ($watchdog) { # Parent process - # Add END block to parent to terminate and - # clean up watchdog process - eval "END { local \$! = 0; local \$? = 0; - wait() if kill('KILL', $watchdog); };"; - return; - } - - ### Watchdog process code - - # Load POSIX if available - eval { require POSIX; }; - - # Execute the timeout - sleep( $timeout - 2 ) if ( $timeout > 2 ); # Workaround for perlbug #49073 - sleep(2); - - # Kill test process if still running - if ( kill( 0, $pid_to_kill ) ) { - _diag($timeout_msg); - kill( 'KILL', $pid_to_kill ); - } - - # Don't execute END block (added at beginning of this file) - $NO_ENDING = 1; - - # Terminate ourself (i.e., the watchdog) - POSIX::_exit(1) if ( defined(&POSIX::_exit) ); - exit(1); - } - - # fork() failed - fall through and try using a thread - } - - # Use a watchdog thread because either 'threads' is loaded, - # or fork() failed - if ( eval { require threads; 1 } ) { - 'threads'->create( - sub { - # Load POSIX if available - eval { require POSIX; }; - - # Execute the timeout - my $time_left = $timeout; - do { - $time_left = $time_left - sleep($time_left); - } while ( $time_left > 0 ); - - # Kill the parent (and ourself) - select(STDERR); - $| = 1; - _diag($timeout_msg); - POSIX::_exit(1) if ( defined(&POSIX::_exit) ); - my $sig = $is_vms ? 'TERM' : 'KILL'; - kill( $sig, $pid_to_kill ); - } - )->detach(); - return; - } - - # If everything above fails, then just use an alarm timeout - WATCHDOG_VIA_ALARM: - if ( eval { alarm($timeout); 1; } ) { - - # Load POSIX if available - eval { require POSIX; }; - - # Alarm handler will do the actual 'killing' - $SIG{'ALRM'} = sub { - select(STDERR); - $| = 1; - _diag($timeout_msg); - POSIX::_exit(1) if ( defined(&POSIX::_exit) ); - my $sig = $is_vms ? 'TERM' : 'KILL'; - kill( $sig, $pid_to_kill ); - }; - } -} - -my $cp_0037 = # EBCDIC code page 0037 - '\x00\x01\x02\x03\x37\x2D\x2E\x2F\x16\x05\x25\x0B\x0C\x0D\x0E\x0F' - . '\x10\x11\x12\x13\x3C\x3D\x32\x26\x18\x19\x3F\x27\x1C\x1D\x1E\x1F' - . '\x40\x5A\x7F\x7B\x5B\x6C\x50\x7D\x4D\x5D\x5C\x4E\x6B\x60\x4B\x61' - . '\xF0\xF1\xF2\xF3\xF4\xF5\xF6\xF7\xF8\xF9\x7A\x5E\x4C\x7E\x6E\x6F' - . '\x7C\xC1\xC2\xC3\xC4\xC5\xC6\xC7\xC8\xC9\xD1\xD2\xD3\xD4\xD5\xD6' - . '\xD7\xD8\xD9\xE2\xE3\xE4\xE5\xE6\xE7\xE8\xE9\xBA\xE0\xBB\xB0\x6D' - . '\x79\x81\x82\x83\x84\x85\x86\x87\x88\x89\x91\x92\x93\x94\x95\x96' - . '\x97\x98\x99\xA2\xA3\xA4\xA5\xA6\xA7\xA8\xA9\xC0\x4F\xD0\xA1\x07' - . '\x20\x21\x22\x23\x24\x15\x06\x17\x28\x29\x2A\x2B\x2C\x09\x0A\x1B' - . '\x30\x31\x1A\x33\x34\x35\x36\x08\x38\x39\x3A\x3B\x04\x14\x3E\xFF' - . '\x41\xAA\x4A\xB1\x9F\xB2\x6A\xB5\xBD\xB4\x9A\x8A\x5F\xCA\xAF\xBC' - . '\x90\x8F\xEA\xFA\xBE\xA0\xB6\xB3\x9D\xDA\x9B\x8B\xB7\xB8\xB9\xAB' - . '\x64\x65\x62\x66\x63\x67\x9E\x68\x74\x71\x72\x73\x78\x75\x76\x77' - . '\xAC\x69\xED\xEE\xEB\xEF\xEC\xBF\x80\xFD\xFE\xFB\xFC\xAD\xAE\x59' - . '\x44\x45\x42\x46\x43\x47\x9C\x48\x54\x51\x52\x53\x58\x55\x56\x57' - . '\x8C\x49\xCD\xCE\xCB\xCF\xCC\xE1\x70\xDD\xDE\xDB\xDC\x8D\x8E\xDF'; - -my $cp_1047 = # EBCDIC code page 1047 - '\x00\x01\x02\x03\x37\x2D\x2E\x2F\x16\x05\x15\x0B\x0C\x0D\x0E\x0F' - . '\x10\x11\x12\x13\x3C\x3D\x32\x26\x18\x19\x3F\x27\x1C\x1D\x1E\x1F' - . '\x40\x5A\x7F\x7B\x5B\x6C\x50\x7D\x4D\x5D\x5C\x4E\x6B\x60\x4B\x61' - . '\xF0\xF1\xF2\xF3\xF4\xF5\xF6\xF7\xF8\xF9\x7A\x5E\x4C\x7E\x6E\x6F' - . '\x7C\xC1\xC2\xC3\xC4\xC5\xC6\xC7\xC8\xC9\xD1\xD2\xD3\xD4\xD5\xD6' - . '\xD7\xD8\xD9\xE2\xE3\xE4\xE5\xE6\xE7\xE8\xE9\xAD\xE0\xBD\x5F\x6D' - . '\x79\x81\x82\x83\x84\x85\x86\x87\x88\x89\x91\x92\x93\x94\x95\x96' - . '\x97\x98\x99\xA2\xA3\xA4\xA5\xA6\xA7\xA8\xA9\xC0\x4F\xD0\xA1\x07' - . '\x20\x21\x22\x23\x24\x25\x06\x17\x28\x29\x2A\x2B\x2C\x09\x0A\x1B' - . '\x30\x31\x1A\x33\x34\x35\x36\x08\x38\x39\x3A\x3B\x04\x14\x3E\xFF' - . '\x41\xAA\x4A\xB1\x9F\xB2\x6A\xB5\xBB\xB4\x9A\x8A\xB0\xCA\xAF\xBC' - . '\x90\x8F\xEA\xFA\xBE\xA0\xB6\xB3\x9D\xDA\x9B\x8B\xB7\xB8\xB9\xAB' - . '\x64\x65\x62\x66\x63\x67\x9E\x68\x74\x71\x72\x73\x78\x75\x76\x77' - . '\xAC\x69\xED\xEE\xEB\xEF\xEC\xBF\x80\xFD\xFE\xFB\xFC\xBA\xAE\x59' - . '\x44\x45\x42\x46\x43\x47\x9C\x48\x54\x51\x52\x53\x58\x55\x56\x57' - . '\x8C\x49\xCD\xCE\xCB\xCF\xCC\xE1\x70\xDD\xDE\xDB\xDC\x8D\x8E\xDF'; - -my $cp_bc = # EBCDIC code page POSiX-BC - '\x00\x01\x02\x03\x37\x2D\x2E\x2F\x16\x05\x15\x0B\x0C\x0D\x0E\x0F' - . '\x10\x11\x12\x13\x3C\x3D\x32\x26\x18\x19\x3F\x27\x1C\x1D\x1E\x1F' - . '\x40\x5A\x7F\x7B\x5B\x6C\x50\x7D\x4D\x5D\x5C\x4E\x6B\x60\x4B\x61' - . '\xF0\xF1\xF2\xF3\xF4\xF5\xF6\xF7\xF8\xF9\x7A\x5E\x4C\x7E\x6E\x6F' - . '\x7C\xC1\xC2\xC3\xC4\xC5\xC6\xC7\xC8\xC9\xD1\xD2\xD3\xD4\xD5\xD6' - . '\xD7\xD8\xD9\xE2\xE3\xE4\xE5\xE6\xE7\xE8\xE9\xBB\xBC\xBD\x6A\x6D' - . '\x4A\x81\x82\x83\x84\x85\x86\x87\x88\x89\x91\x92\x93\x94\x95\x96' - . '\x97\x98\x99\xA2\xA3\xA4\xA5\xA6\xA7\xA8\xA9\xFB\x4F\xFD\xFF\x07' - . '\x20\x21\x22\x23\x24\x25\x06\x17\x28\x29\x2A\x2B\x2C\x09\x0A\x1B' - . '\x30\x31\x1A\x33\x34\x35\x36\x08\x38\x39\x3A\x3B\x04\x14\x3E\x5F' - . '\x41\xAA\xB0\xB1\x9F\xB2\xD0\xB5\x79\xB4\x9A\x8A\xBA\xCA\xAF\xA1' - . '\x90\x8F\xEA\xFA\xBE\xA0\xB6\xB3\x9D\xDA\x9B\x8B\xB7\xB8\xB9\xAB' - . '\x64\x65\x62\x66\x63\x67\x9E\x68\x74\x71\x72\x73\x78\x75\x76\x77' - . '\xAC\x69\xED\xEE\xEB\xEF\xEC\xBF\x80\xE0\xFE\xDD\xFC\xAD\xAE\x59' - . '\x44\x45\x42\x46\x43\x47\x9C\x48\x54\x51\x52\x53\x58\x55\x56\x57' - . '\x8C\x49\xCD\xCE\xCB\xCF\xCC\xE1\x70\xC0\xDE\xDB\xDC\x8D\x8E\xDF'; - -my $straight = # Avoid ranges - '\x00\x01\x02\x03\x04\x05\x06\x07\x08\x09\x0A\x0B\x0C\x0D\x0E\x0F' - . '\x10\x11\x12\x13\x14\x15\x16\x17\x18\x19\x1A\x1B\x1C\x1D\x1E\x1F' - . '\x20\x21\x22\x23\x24\x25\x26\x27\x28\x29\x2A\x2B\x2C\x2D\x2E\x2F' - . '\x30\x31\x32\x33\x34\x35\x36\x37\x38\x39\x3A\x3B\x3C\x3D\x3E\x3F' - . '\x40\x41\x42\x43\x44\x45\x46\x47\x48\x49\x4A\x4B\x4C\x4D\x4E\x4F' - . '\x50\x51\x52\x53\x54\x55\x56\x57\x58\x59\x5A\x5B\x5C\x5D\x5E\x5F' - . '\x60\x61\x62\x63\x64\x65\x66\x67\x68\x69\x6A\x6B\x6C\x6D\x6E\x6F' - . '\x70\x71\x72\x73\x74\x75\x76\x77\x78\x79\x7A\x7B\x7C\x7D\x7E\x7F' - . '\x80\x81\x82\x83\x84\x85\x86\x87\x88\x89\x8A\x8B\x8C\x8D\x8E\x8F' - . '\x90\x91\x92\x93\x94\x95\x96\x97\x98\x99\x9A\x9B\x9C\x9D\x9E\x9F' - . '\xA0\xA1\xA2\xA3\xA4\xA5\xA6\xA7\xA8\xA9\xAA\xAB\xAC\xAD\xAE\xAF' - . '\xB0\xB1\xB2\xB3\xB4\xB5\xB6\xB7\xB8\xB9\xBA\xBB\xBC\xBD\xBE\xBF' - . '\xC0\xC1\xC2\xC3\xC4\xC5\xC6\xC7\xC8\xC9\xCA\xCB\xCC\xCD\xCE\xCF' - . '\xD0\xD1\xD2\xD3\xD4\xD5\xD6\xD7\xD8\xD9\xDA\xDB\xDC\xDD\xDE\xDF' - . '\xE0\xE1\xE2\xE3\xE4\xE5\xE6\xE7\xE8\xE9\xEA\xEB\xEC\xED\xEE\xEF' - . '\xF0\xF1\xF2\xF3\xF4\xF5\xF6\xF7\xF8\xF9\xFA\xFB\xFC\xFD\xFE\xFF'; - -# The following 2 functions allow tests to work on both EBCDIC and -# ASCII-ish platforms. They convert string scalars between the native -# character set and the set of 256 characters which is usually called -# Latin1. -# -# These routines don't work on UTF-EBCDIC and UTF-8. - -sub native_to_latin1($) { - my $string = shift; - - return $string if ord('^') == 94; # ASCII, Latin1 - my $cp; - if ( ord('^') == 95 ) { # EBCDIC 1047 - $cp = \$cp_1047; - } - elsif ( ord('^') == 106 ) { # EBCDIC POSIX-BC - $cp = \$cp_bc; - } - elsif ( ord('^') == 176 ) { # EBCDIC 037 */ - $cp = \$cp_0037; - } - else { - die "Unknown native character set"; - } - - eval '$string =~ tr/' . $$cp . '/' . $straight . '/'; - return $string; -} - -sub latin1_to_native($) { - my $string = shift; - - return $string if ord('^') == 94; # ASCII, Latin1 - my $cp; - if ( ord('^') == 95 ) { # EBCDIC 1047 - $cp = \$cp_1047; - } - elsif ( ord('^') == 106 ) { # EBCDIC POSIX-BC - $cp = \$cp_bc; - } - elsif ( ord('^') == 176 ) { # EBCDIC 037 */ - $cp = \$cp_0037; - } - else { - die "Unknown native character set"; - } - - eval '$string =~ tr/' . $straight . '/' . $$cp . '/'; - return $string; -} - -sub ord_latin1_to_native { - - # given an input code point, return the platform's native - # equivalent value. Anything above latin1 is itself. - - my $ord = shift; - return $ord if $ord > 255; - return ord latin1_to_native( chr $ord ); -} - -sub ord_native_to_latin1 { - - # given an input platform code point, return the latin1 equivalent value. - # Anything above latin1 is itself. - - my $ord = shift; - return $ord if $ord > 255; - return ord native_to_latin1( chr $ord ); -} - -sub is_perlcc_compiled { - return grep /^B::C$/, @DynaLoader::dl_modules; -} - -1; diff --git a/t/core-init.sh b/t/core-init.sh new file mode 100755 index 000000000..2afd7854b --- /dev/null +++ b/t/core-init.sh @@ -0,0 +1,25 @@ +#!/bin/sh + +if [ ! -f Makefile.PL -a -f ../Makefile.PL ]; then + chdir .. +fi +if [ ! -f Makefile.PL ]; then + echo wrong basedir, missing Makefile.PL + exit +fi +if [ ! -d t/CORE ]; then + if [ ! -d .git ]; then + echo git clone p5-coretests.git t/CORE + git clone https://github.com/perl11/p5-coretests.git t/CORE + else + if [ ! -f .gitmodules ]; then + echo git submodule add p5-coretests.git t/CORE + git submodule add https://github.com/perl11/p5-coretests.git t/CORE + fi + echo git submodule update --remote + git submodule update --remote + fi +else + echo git submodule update --remote + git submodule update --remote +fi diff --git a/t/coreall.sh b/t/coreall.sh index c46a33431..a1762d3bb 100755 --- a/t/coreall.sh +++ b/t/coreall.sh @@ -1,4 +1,5 @@ #!/bin/sh -t=${1:-t/CORE/comp/proto.t} +# run all perls on a single core test +t=${1:-t/CORE/v5.22/comp/proto.t} echo perlall='5.*-nt' perlall -m --nolog do $t perlall='5.*-nt' perlall -m --nolog do $t 2>&1 | egrep '(^not ok|/perl5.)' diff --git a/t/testc.sh b/t/testc.sh index 84cea1855..e4b2d4e4f 100755 --- a/t/testc.sh +++ b/t/testc.sh @@ -30,7 +30,7 @@ PERL=`echo $PERL|sed -e's,^",,; s,"$,,'` v510=`$PERL -e'print (($] < 5.010)?0:1)'` v518=`$PERL -e'print (($] < 5.018)?0:1)'` PERLV=v5.`$PERL -e'print substr($],3,2)'` -XTESTC="t/C-COMPILED/xtestc" +XTESTC="t/CORE/$PERLV/C-COMPILED/xtestc" function init { BASE=`basename $0` @@ -132,14 +132,15 @@ function make_t_symlink { CONTENT="${tests[${n}]}" if [ "x$CONTENT" != "x" ]; then FILE_NUM=$(printf "%04d" $n) - FILE="$XTESTC--${FILE_NUM}.t" - unlink $FILE - ln -s testc.pl $FILE + FILE="$XTESTC/${FILE_NUM}.t" + test -e $FILE && unlink $FILE + ln -s ../testc.pl $FILE fi } function make_symlinks { MAX=9999 + test -d $XTESTC || mkdir $XTESTC rm -f $XTESTC/*.t ||: for b in $(seq $MAX); do make_t_symlink $b