diff options
author | Todd C. Miller <millert@cvs.openbsd.org> | 2005-01-15 21:18:29 +0000 |
---|---|---|
committer | Todd C. Miller <millert@cvs.openbsd.org> | 2005-01-15 21:18:29 +0000 |
commit | 900aea5fee6e7e0e7e6e8c4f0192f99befa3a927 (patch) | |
tree | 79ecffc72620d46df9fe0d71286e0e466415b7f5 /gnu | |
parent | a529bb51c131f3975e0a7daa8eb3d2c865f3fc52 (diff) |
perl 5.8.6 from CPAN
Diffstat (limited to 'gnu')
188 files changed, 25573 insertions, 537 deletions
diff --git a/gnu/usr.bin/perl/AUTHORS b/gnu/usr.bin/perl/AUTHORS index 7eea705af8c..0a5005d022b 100644 --- a/gnu/usr.bin/perl/AUTHORS +++ b/gnu/usr.bin/perl/AUTHORS @@ -137,7 +137,7 @@ Chris Wick <cwick@lmc.com> Christian Kirsch <ck@held.mind.de> Christopher Chan-Nui <channui@austin.ibm.com> Christopher Davis <ckd@loiosh.kei.com> -chromatic <chromatic@rmci.net> +chromatic <chromatic@wgz.org> Chuck D. Phillips <cdp@hpescdp.fc.hp.com> Chuck Phillips <cdp@fc.hp.com> Chunhui Teng <cteng@nortel.ca> @@ -710,7 +710,7 @@ Slaven Rezic <slaven@rezic.de> Solar Designer <solar@openwall.com> Spider Boardman <spider@orb.nashua.nh.us> Stas Bekman <stas@stason.org> -Steffen Mueller <xyey9001@sneakemail.com> +Steffen Müller <7k8lrvf02@sneakemail.com> Stéphane Payrard <stef@mongueurs.net> Stephanie Beals <bealzy@us.ibm.com> Stephen Clouse <stephenc@theiqgroup.com> diff --git a/gnu/usr.bin/perl/Changes5.8.5 b/gnu/usr.bin/perl/Changes5.8.5 new file mode 100644 index 00000000000..59b5bfa588f --- /dev/null +++ b/gnu/usr.bin/perl/Changes5.8.5 @@ -0,0 +1,1795 @@ +Please note: This file provides a complete, temporally ordered log of +changes that went into every version of Perl. If you'd like more +detailed information, please consult the comments in the individual +patches posted to the perl5-porters mailing list. Patches for each +individual change may also be obtained through ftp and rsync--see +pod/perlhack.pod for the details. + +For information on what's new in this release, see pod/perldelta.pod. + +[The "CAST AND CREW" list has been moved to AUTHORS.] + +NOTE: Each change entry shows the change number; who checked it into the +repository; when; description of the change; which branch the change +happened in; and the affected files. The file lists have a short symbolic +indicator: + + ! modified + + added + - deleted + +> branched (from elsewhere) + !> merged changes (from elsewhere) + +The Message-Ids in the change entries refer to the email messages sent +to the perl5-porters mailing list. You can retrieve the messages for +example from http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/ + +-------------- +Version v5.8.5 Maintenance release working toward v5.8.5 +-------------- +____________________________________________________________________________ +[ 23139] By: nicholas on 2004/07/19 13:43:44 + Log: Oops. Forgot to mention the threads fix. + Branch: maint-5.8/perl + ! pod/perl585delta.pod +____________________________________________________________________________ +[ 23138] By: nicholas on 2004/07/19 13:01:47 + Log: Update the perldelta. + Branch: maint-5.8/perl + ! pod/perl585delta.pod +____________________________________________________________________________ +[ 23137] By: nicholas on 2004/07/19 12:43:07 + Log: Update Changes + Branch: maint-5.8/perl + ! Changes patchlevel.h +____________________________________________________________________________ +[ 23136] By: nicholas on 2004/07/19 12:27:41 + Log: Integrate: + [ 23042] + Bump $B::Deparse::VERSION + Branch: maint-5.8/perl + !> ext/B/B/Deparse.pm +____________________________________________________________________________ +[ 23134] By: nicholas on 2004/07/17 09:40:46 + Log: New sample config files. + Branch: maint-5.8/perl + ! Porting/config.sh Porting/config_H +____________________________________________________________________________ +[ 23133] By: nicholas on 2004/07/17 09:36:41 + Log: Integrate: + [ 23120] + threads.xs doesn't check the return value of the thread creation + call. D'oh! This gives SEGVs if the OS fails to create another thread. + Cause of problem located by Nigel Sandever + Branch: maint-5.8/perl + !> ext/threads/threads.pm ext/threads/threads.xs +____________________________________________________________________________ +[ 23132] By: nicholas on 2004/07/16 14:31:01 + Log: Integrate: + [ 23072] + dor and // fulfil a TODO + Correct a deviation from the Nicholas Clark style guide. + + [ 23073] + A more honest TODO + + [ 23077] + Resurrect the TODO items about Unicode filenames and Unicode %ENV + Rant a bit more about POD -> HTML + + [ 23078] + Dual lifing and dists is a TODO + + [ 23081] + Finding a way to put "I'm MAINT" in perl -v is a TODO + + [ 23082] + A decent benchmark would be useful. But it is vague. + + [ 23094] + Generalised "how many in list context" would be useful + + [ 23103] + s/sort/split/; - my mistake spotted by Dave. + + [ 23104] + Some thoughts on foreach reverse + + [ 23107] + Subject: [PATCH] split doc clarification + From: Yitzchak Scott-Thoennes <sthoenna@efn.org> + Date: Wed, 14 Jul 2004 10:19:36 -0700 + Message-Id: <20040714171936.GA1092@efn.org> + + [ 23115] + for (reverse @foo) now iterates in reverse in place. + (Just the TODO change) + + [ 23116] + Abigail notes that a re-entrant regexp engine is a todo + + [ 23129] + Typo fix from Julian Gilbey, forwarded upstream from Debian by + Brendan O'Dea + + [ 23130] + Clarify that it's only Mac OS *Classic* that uses 1904 - OS X uses + 1970 + Branch: maint-5.8/perl + !> pod/perlfunc.pod pod/perltodo.pod pod/perluniintro.pod +____________________________________________________________________________ +[ 23131] By: nicholas on 2004/07/16 14:11:52 + Log: Integrate: + [ 23051] + Add some missing authors and remove 1 duplicate + + [ 23127] + glob('*.c') to find documentation is dangerous when run in unclean + trees, so isntead use MANIFEST to only scan the legitimate source + files. + Branch: maint-5.8/perl + !> AUTHORS autodoc.pl +____________________________________________________________________________ +[ 23119] By: nicholas on 2004/07/15 16:38:38 + Log: Integrate: + [ 23118] + Assimilate Cwd 2.19 + Branch: maint-5.8/perl + !> ext/Cwd/Changes ext/Cwd/t/cwd.t lib/Cwd.pm +____________________________________________________________________________ +[ 23110] By: nicholas on 2004/07/14 23:36:17 + Log: Integrate: + [ 23071] + Subject: [PATCH] prime_env_iter and zero-length values on VMS + From: "Craig A. Berry" <craigberry@mac.com> + Date: Thu, 08 Jul 2004 23:19:05 -0500 + Message-ID: <40EE1CB9.8030407@mac.com> + Branch: maint-5.8/perl + !> vms/vms.c +____________________________________________________________________________ +[ 23087] By: nicholas on 2004/07/12 21:36:51 + Log: Integrate: + [ 23076] + Perl_mode_from_discipline must update len. (else SEGV) + Diagnosis and patch from clkao + + [ 23083] + Perl_is_utf8_string(pTHX_ U8 *s, STRLEN len) + Can now handle the case + is_utf8_string(NULL,0) + again. + Why do we have code dup for Perl_is_utf8_string_loc() ? + + [ 23084] + NI-S: IMHO utf8_upgrade is just changing representation not the value + so it has no business calling SvSETMAGIC. + + [ 23085] + Bodge to make Tk work - like the UTF8 flag, the READONLY flag has too + many meanings. const const vs mutable in this case. + Branch: maint-5.8/perl + ! sv.c + !> doio.c utf8.c +____________________________________________________________________________ +[ 23086] By: nicholas on 2004/07/12 21:19:15 + Log: Disarm the release candidate + Branch: maint-5.8/perl + ! patchlevel.h +____________________________________________________________________________ +[ 23080] By: nicholas on 2004/07/11 16:07:49 + Log: Remove the Safe $VERSION FIXME. + Comment on the rearrangement of lib/unicore + Branch: maint-5.8/perl + ! pod/perl585delta.pod +____________________________________________________________________________ +[ 23070] By: nicholas on 2004/07/08 16:21:29 + Log: Need to copy the correct perldelta. + Also need to fix Makefile.SH to work out what to copy using pod.lst + (Spotted by Randal) + Branch: maint-5.8/perl + ! Makefile.SH +____________________________________________________________________________ +[ 23069] By: nicholas on 2004/07/08 13:53:43 + Log: This is RC2. Maybe this one will last longer. + Branch: maint-5.8/perl + ! patchlevel.h pod/perlhist.pod +____________________________________________________________________________ +[ 23068] By: nicholas on 2004/07/08 13:38:14 + Log: Update Changes + Branch: maint-5.8/perl + ! Changes patchlevel.h +____________________________________________________________________________ +[ 23067] By: nicholas on 2004/07/08 13:25:33 + Log: Rebuild toc. Resort MANIFEST + Branch: maint-5.8/perl + ! MANIFEST pod/perltoc.pod +____________________________________________________________________________ +[ 23066] By: nicholas on 2004/07/08 13:10:35 + Log: Integrate: + [ 23062] + First stab at explaining that CLONE may get more parameters in future. + More eloquent rewording desired. Patches welcome. + + [ 23065] + Randal notes: + + "perldoc perldelta" still says 5.8.3 to 5.8.4, even though there + *is* a "perldoc perl583delta" properly. + + This is because perl584delta still thinks it's the perldelta + Branch: maint-5.8/perl + !> pod/perl584delta.pod pod/perlmod.pod +____________________________________________________________________________ +[ 23064] By: nicholas on 2004/07/08 13:06:35 + Log: Integrate: + [ 23063] + Make Perl_sv_utf8_upgrade_flags tolerate PL_sv_undef + as an argument. + Branch: maint-5.8/perl + !> sv.c +____________________________________________________________________________ +[ 23057] By: nicholas on 2004/07/06 13:00:52 + Log: This is RC1 + Branch: maint-5.8/perl + ! patchlevel.h pod/perlhist.pod +____________________________________________________________________________ +[ 23056] By: nicholas on 2004/07/06 12:45:46 + Log: Update Changes + Branch: maint-5.8/perl + ! Changes patchlevel.h +____________________________________________________________________________ +[ 23055] By: nicholas on 2004/07/06 11:35:31 + Log: Cargo cult 5.8.5 upgrade + Branch: maint-5.8/perl + ! Cross/config.sh-arm-linux META.yml NetWare/Makefile README.os2 + ! README.vms epoc/createpkg.pl ext/List/Util/t/lln.t + ! patchlevel.h plan9/config.plan9 pod/perl585delta.pod + ! vos/build.cm vos/config.alpha.def vos/config.alpha.h + ! vos/config.ga.def vos/config.ga.h vos/install_perl.cm + ! win32/Makefile win32/config_H.bc win32/config_H.gc + ! win32/config_H.vc win32/config_H.vc64 win32/makefile.mk + ! wince/Makefile.ce +____________________________________________________________________________ +[ 23054] By: nicholas on 2004/07/06 09:54:16 + Log: Another tweak + Branch: maint-5.8/perl + ! pod/perl585delta.pod +____________________________________________________________________________ +[ 23053] By: nicholas on 2004/07/06 09:52:45 + Log: Improvements suggested by Jarkko + Branch: maint-5.8/perl + ! pod/perl585delta.pod +____________________________________________________________________________ +[ 23050] By: nicholas on 2004/07/06 09:13:11 + Log: Fixup change 22979 in the ChangeLog *properly* (so that tools parse + it) + Branch: maint-5.8/perl + ! Changes +____________________________________________________________________________ +[ 23049] By: nicholas on 2004/07/05 17:46:57 + Log: Back out 22997 as it causes Net::DNS to spin forever in 05-rr-txt.t + Branch: maint-5.8/perl + ! lib/Text/ParseWords.pm lib/Text/ParseWords.t +____________________________________________________________________________ +[ 23045] By: nicholas on 2004/07/05 15:13:40 + Log: Change 23035 wasn't meant to integrate t/op/threads.t to maint + Branch: maint-5.8/perl + - t/op/threads.t +____________________________________________________________________________ +[ 23044] By: nicholas on 2004/07/05 15:00:22 + Log: I missed the libnet upgrade. I almost missed Steve Hay reminding me of + this. + Branch: maint-5.8/perl + ! pod/perl585delta.pod +____________________________________________________________________________ +[ 23043] By: nicholas on 2004/07/05 14:58:20 + Log: Things noticed by Ronald J Kimball and Steve Hay + Branch: maint-5.8/perl + ! pod/perl585delta.pod +____________________________________________________________________________ +[ 23041] By: nicholas on 2004/07/05 13:15:04 + Log: Integrate: + [ 23029] + Subject: [PATCH Cwd 2.18] _vms_abs_path on non-directories + From: "Craig A. Berry" <craigberry@mac.com> + Message-ID: <40E704AA.4090801@mac.com> + Date: Sat, 03 Jul 2004 14:10:34 -0500 + Branch: maint-5.8/perl + !> ext/Cwd/t/cwd.t lib/Cwd.pm +____________________________________________________________________________ +[ 23039] By: nicholas on 2004/07/04 21:32:40 + Log: Integrate: + [ 23022] + The microperl config didn't know about usemallocwrap yet. + + [ 23027] + More microperl tweaks. + Branch: maint-5.8/perl + !> Makefile.micro README.micro uconfig.h uconfig.sh +____________________________________________________________________________ +[ 23038] By: nicholas on 2004/07/04 21:22:18 + Log: Integrate: + [ 23019] + Bump version numbers + + [ 23025] + Bump version number of Safe for CPAN release + Branch: maint-5.8/perl + !> ext/File/Glob/Glob.pm ext/Opcode/Safe.pm + !> ext/XS/APItest/APItest.pm ext/threads/threads.pm lib/Carp.pm + !> lib/File/Copy.pm lib/Text/ParseWords.pm lib/Text/Wrap.pm + !> lib/autouse.pm lib/charnames.pm lib/diagnostics.pm lib/utf8.pm +____________________________________________________________________________ +[ 23037] By: nicholas on 2004/07/04 21:12:06 + Log: Integrate: + [ 23010] + More caveats in B::Deparse's documentation + (suggested by Yves Orton) + + [ 23011] + Note that sv_2mortal isn't just "increase reference count by 1, and + mark that it needs a deferred recount" + + [ 23014] + Subject: [PATCH pod/perlop.pod] Documenting undefined behaviour of $i = $i ++. + From: Abigail <abigail@abigail.nl> + Date: Wed, 30 Jun 2004 12:00:21 +0200 + Message-ID: <20040630100021.GA23752@abigail.nl> + + [ 23026] + Maintainer change for Safe + Branch: maint-5.8/perl + !> Porting/Maintainers.pl ext/B/B/Deparse.pm pod/perlop.pod sv.c +____________________________________________________________________________ +[ 23036] By: nicholas on 2004/07/04 20:59:30 + Log: Integrate: + [ 22995] + Subject: [PATCH] regcomp.c, t/op/regmesg.t -- False range with \p and \P + From: Jeff 'japhy' Pinyan <japhy@perlmonk.org> + Date: Thu, 24 Jun 2004 16:42:54 -0400 (EDT) + Message-ID: <Pine.LNX.4.44.0406241636340.8774-200000@perlmonk.org> + Branch: maint-5.8/perl + !> regcomp.c t/op/regmesg.t +____________________________________________________________________________ +[ 23035] By: nicholas on 2004/07/04 20:49:10 + Log: Integrate: + [ 22994] + More @INC test fixes + + [ 22998] + Correct detection of absent modules. Based on + + Subject: [PATCH] Config{extensions} uses filesystem names as extensions + From: Andy Dougherty <doughera@lafayette.edu> + Message-ID: <Pine.SOL.4.58.0406241505530.14039@maxwell.phys.lafayette.edu> + Date: Thu, 24 Jun 2004 15:09:47 -0400 (EDT) + + with improvements from Marcus Holland-Moritz + + [ 23028] + /usr/bin/locale steadfastly delivers 8 bit output independent of + LC_ALL. So when perl's expecting utf8, things don't quite work right. + This has become visible since fix 22842 + Branch: maint-5.8/perl + +> t/op/threads.t + !> ext/Devel/PPPort/t/test.t ext/PerlIO/t/scalar.t + !> ext/PerlIO/t/via.t ext/threads/shared/t/disabled.t lib/DB.t + !> lib/Dumpvalue.t lib/PerlIO/via/t/QuotedPrint.t + !> lib/Tie/RefHash.t lib/autouse.t lib/dumpvar.t lib/h2xs.t + !> lib/locale.t lib/overload.t t/io/crlf.t t/uni/chomp.t + !> t/uni/tr_7jis.t t/uni/tr_eucjp.t t/uni/tr_sjis.t + !> t/uni/tr_utf8.t +____________________________________________________________________________ +[ 23034] By: nicholas on 2004/07/04 20:23:50 + Log: Integrate: + [ 22992] + Fix for: [perl #30442] Text::ParseWords does not handle backslashed newline inside quoted text + Use the suggested regex fix, plus some tests. + + [ 22997] + Cleanup the main regex in Text::ParseWords and make the + parse_line() routine faster. Add a Unicode test case. + Branch: maint-5.8/perl + !> lib/Text/ParseWords.pm lib/Text/ParseWords.t +____________________________________________________________________________ +[ 23033] By: nicholas on 2004/07/04 20:12:51 + Log: Integrate: + [ 22990] + Fix for: [perl #2738] perl segfautls on input + The parser was incorrectly accepting <> as a subroutine prototype and + newATTRSUB didn't validate the proto argument before accessing op_sv. + + [ 23006] + [perl #30509] use encoding and "eq" cause memory leak + Perl_sv_eq() was creating a temp and not always freeing it + Branch: maint-5.8/perl + ! t/comp/parser.t + !> op.c pod/perldiag.pod sv.c toke.c +____________________________________________________________________________ +[ 23032] By: nicholas on 2004/07/04 19:46:34 + Log: Integrate: + [ 22942] + Upgrade to Locale::Maketext 1.09 + Branch: maint-5.8/perl + +> lib/Locale/Maketext/t/01_about_verbose.t + +> lib/Locale/Maketext/t/10_make.t lib/Locale/Maketext/t/20_get.t + +> lib/Locale/Maketext/t/40_super.t + +> lib/Locale/Maketext/t/50_super.t + +> lib/Locale/Maketext/t/60_super.t + +> lib/Locale/Maketext/t/90_utf8.t + - lib/Locale/Maketext/t/00about.t lib/Locale/Maketext/t/01make.t + - lib/Locale/Maketext/t/02get.t lib/Locale/Maketext/t/03http.t + - lib/Locale/Maketext/t/04super.t + - lib/Locale/Maketext/t/05super.t + - lib/Locale/Maketext/t/06super.t lib/Locale/Maketext/t/90utf8.t + !> MANIFEST lib/Locale/Maketext.pm lib/Locale/Maketext/ChangeLog + !> lib/Locale/Maketext/README +____________________________________________________________________________ +[ 23031] By: nicholas on 2004/07/04 19:35:48 + Log: Integrate: + [ 22946] + Upgrade to I18N::LangTags 0.31. + + [ 22964] + Upgrade to I18N::LangTags 0.32 + + [ 23001] + Stop 80_all_env.t failing when LC_ALL is set + + [ 23024] + Upgrade to I18N::LangTags 0.33 + + (this would have all been part of the previous change but + http://www.google.com/search?btnI=again&q=perforce+fails+bah ) + Branch: maint-5.8/perl + !> lib/I18N/LangTags.pm lib/I18N/LangTags/ChangeLog + !> lib/I18N/LangTags/Detect.pm lib/I18N/LangTags/t/10_http.t + !> lib/I18N/LangTags/t/80_all_env.t +____________________________________________________________________________ +[ 23030] By: nicholas on 2004/07/04 19:22:15 + Log: Integrate: + [ 22941] + Upgrade to I18N::LangTags 0.30. + Branch: maint-5.8/perl + +> lib/I18N/LangTags/Detect.pm + +> lib/I18N/LangTags/t/01_about_verbose.t + +> lib/I18N/LangTags/t/05_main.t lib/I18N/LangTags/t/07_listy.t + +> lib/I18N/LangTags/t/10_http.t lib/I18N/LangTags/t/50_super.t + +> lib/I18N/LangTags/t/55_supers_strict.t + +> lib/I18N/LangTags/t/80_all_env.t + - lib/I18N/LangTags/t/01test.t lib/I18N/LangTags/t/02decency.t + !> MANIFEST lib/I18N/LangTags.pm lib/I18N/LangTags/ChangeLog + !> lib/I18N/LangTags/List.pm +____________________________________________________________________________ +[ 23020] By: nicholas on 2004/07/01 13:35:17 + Log: Integrate: + [ 23016] + Sync to libnet-1.19 + Branch: maint-5.8/perl + !> lib/Net/Changes.libnet lib/Net/Cmd.pm lib/Net/FTP.pm + !> lib/Net/POP3.pm lib/Net/SMTP.pm lib/Net/t/datasend.t +____________________________________________________________________________ +[ 23017] By: nicholas on 2004/06/30 20:28:29 + Log: Back 22969 out of maint. (reinstate the "Tied variable freed while + still in use" error for the moment, as my change causes interesting + bugs under utf8 locales) + Branch: maint-5.8/perl + ! mg.c pod/perldiag.pod t/op/tie.t +____________________________________________________________________________ +[ 23015] By: nicholas on 2004/06/30 12:17:35 + Log: Integrate: + [ 23002] + Assimilate Locale-Codes-2.07 + Branch: maint-5.8/perl + !> lib/Locale/Codes/ChangeLog lib/Locale/Codes/README + !> lib/Locale/Codes/t/all.t lib/Locale/Codes/t/constants.t + !> lib/Locale/Codes/t/country.t lib/Locale/Codes/t/currency.t + !> lib/Locale/Codes/t/uk.t lib/Locale/Constants.pm + !> lib/Locale/Constants.pod lib/Locale/Country.pm + !> lib/Locale/Country.pod lib/Locale/Currency.pm + !> lib/Locale/Currency.pod lib/Locale/Language.pm + !> lib/Locale/Language.pod lib/Locale/Script.pm + !> lib/Locale/Script.pod +____________________________________________________________________________ +[ 23013] By: nicholas on 2004/06/30 11:25:27 + Log: Integrate: + [ 22988] + Upgrade to Cwd 2.17_03 + + [ 22991] + Upgrade to Cwd 2.18 + (with local changes to cwd.t, to adapt it to the core) + + [ 22993] + Fix the Cwd tests for the core. + Branch: maint-5.8/perl + !> ext/Cwd/Changes ext/Cwd/Cwd.xs ext/Cwd/t/cwd.t + !> ext/Cwd/t/taint.t lib/Cwd.pm +____________________________________________________________________________ +[ 23012] By: nicholas on 2004/06/30 11:11:43 + Log: Integrate: + [ 22935] + Assert SvTYPE is at least PGMV whenever accessing SvSTASH + (the Storable.xs part) + + [ 22943] + Storable should cope if the string to thaw happens to be utf8 encoded + And anything with bytes >=256 is corrupt + + [ 22944] + Change 22516 forgot to add make_overload.pl to generate test data + (submitted from the pub via wireless, bluetooth and then GPRS out + to the Internet) + + [ 22968] + Subject: [PATCH] Storable signedness nit + From: "Craig A. Berry" <craigberry@mac.com> + Message-ID: <40D3AAC7.6030407@mac.com> + Date: Fri, 18 Jun 2004 21:53:59 -0500 + Branch: maint-5.8/perl + +> ext/Storable/t/make_overload.pl + !> MANIFEST ext/Storable/ChangeLog ext/Storable/README + !> ext/Storable/Storable.pm ext/Storable/Storable.xs + !> ext/Storable/t/utf8.t +____________________________________________________________________________ +[ 23009] By: nicholas on 2004/06/29 11:09:36 + Log: Integrate: + [ 22996] + Subject: [perl #30450] perl 5.8.4: enhancement to hints/solaris_2.sh + From: Nicholas Gianniotis (via RT) <perlbug-followup@perl.org> + Date: 25 Jun 2004 09:39:51 -0000 + Message-ID: <rt-3.0.9-30450-91340.10.3279898804255@perl.org> + and + From: Andy Dougherty <doughera@lafayette.edu> + Date: Fri, 25 Jun 2004 11:30:11 -0400 (EDT) + Message-ID: <Pine.SOL.4.58.0406251113420.15961@maxwell.phys.lafayette.edu> + + [ 23007] + HP-UX 10.20 still *needs* -Ae for HP C-ANSI-C to be ANSI + 11.00 and on are ANSI by default for /opt/ansic/bin + Error was introduced by #22975 in re-enabling 10.01 + Branch: maint-5.8/perl + !> hints/hpux.sh hints/solaris_2.sh +____________________________________________________________________________ +[ 23005] By: nicholas on 2004/06/28 17:03:14 + Log: Draft 1 of perl585delta. + Branch: maint-5.8/perl + ! pod/perl585delta.pod +____________________________________________________________________________ +[ 23004] By: rgs on 2004/06/28 16:29:21 + Log: Document h2ph changes in perldelta + Branch: maint-5.8/perl + ! pod/perl585delta.pod +____________________________________________________________________________ +[ 23003] By: nicholas on 2004/06/28 12:16:52 + Log: Correct the changelog entry for 22979 + Branch: maint-5.8/perl + ! Changes +____________________________________________________________________________ +[ 23000] By: nicholas on 2004/06/27 15:19:21 + Log: Update Changes. Almost time for 5.8.5 + Branch: maint-5.8/perl + ! Changes patchlevel.h +____________________________________________________________________________ +[ 22999] By: nicholas on 2004/06/27 12:18:13 + Log: Integrate: + [ 21936] + fix [perl #24660], [perl #24663]. + + [ 22106] + still problems with backreferences + reverse cloning + after #21936 - the weak reference may live on the pad. + Branch: maint-5.8/perl + !> mg.c sv.c +____________________________________________________________________________ +[ 22989] By: nicholas on 2004/06/24 15:09:34 + Log: Integrate: + [ 22872] + First step to generating Unicode files for the regexp engine at build + time - targets in the Makefile + + [ 22873] + Convert to using File::Spec, so that we can build Unicode files + on all platforms + + [ 22879] + Run mktables as part of the build process. + Don't ship any of the files that it generates in lib/unicore + + [ 22880] + Don't need to require utf8_pva.pl at top of file + + [ 22881] + replace the run time code in lib/utf8_pva.pl with data generated + at build by mktables, stored in lib/unicore/PVA.pl + + [ 22887] + Subject: Re: Smoke [5.9.2] 22881 FAIL(M) MSWin32 WinXP/.Net SP1 (x86/1 cpu) + From: Steve Hay <steve.hay@uk.radan.com> + Date: Tue, 01 Jun 2004 15:30:37 +0100 + Message-ID: <40BC930D.90701@uk.radan.com> + + [ 22899] + Workaround a dmake oddity. + Subject: Re: Smoke [5.9.2] 22881 FAIL(M) MSWin32 WinXP/.Net SP1 (x86/1 cpu) + From: Steve Hay <steve.hay@uk.radan.com> + Date: Thu, 03 Jun 2004 12:16:13 +0100 + Message-ID: <40BF087D.8030005@uk.radan.com> + + [ 22924] + Subject: Change 22872 breaks shared miniperl invocation + From: Alexey Tourbin <at@altlinux.ru> + Date: Fri, 4 Jun 2004 13:24:17 +0400 + Message-ID: <20040604092417.GA13447@solemn.turbinal.org> + + [ 22961] + 'make test' without preceeding 'make' fails. + Change #22872 added a target to run mktables, but this was + skipped if 'make test' was run first, causing the build of + Unicode::Normalize to fail. + + [ 22963] + make mktables always update modifed time to play better with make + Branch: maint-5.8/perl + - (delete 420 files) + !> MANIFEST Makefile.SH lib/unicore/mktables lib/utf8_heavy.pl + !> vms/descrip_mms.template win32/Makefile win32/makefile.mk +____________________________________________________________________________ +[ 22987] By: nicholas on 2004/06/23 15:54:27 + Log: Integrate: + [ 22960] + When expecting an error, it's best to check the text you got, rather + than blindly assuming that it's correct. + Branch: maint-5.8/perl + !> t/op/write.t +____________________________________________________________________________ +[ 22986] By: nicholas on 2004/06/23 15:30:36 + Log: Integrate: + [ 22928] + t/comp/utf.t failed when configuring with -Dnoextensions=Encode + + [ 22947] + Need to skip test 7 if perl built without the PerlIO::scalar extension + + [ 22948] + Can't test the B modules if we didn't build 'em + + [ 22949] + Unicode::UCD uses Storable, so we can't test if Storable isn't built. + + [ 22950] + D'oh. Don't turn on warnings on the #! line without actually testing + the full code in case it warns. + + [ 22951] + If we don't build B, we should skip all its tests. + + [ 22952] + Skip re tests if re not built. + + [ 22953] + Skip test if Devel::PPPort not built + + [ 22954] + Skip test if perl configured without threads::shared + + [ 22955] + Not ideal, but skip all of IO's tests if Socket is not built. + + [ 22956] + Skip tests when PerlIO::scalar and PerlIO::via aren't built + + [ 22957] + Also needs skipping if PerlIO::via not built + + [ 22958] + This needs POSIX, so skip if no POSIX + + [ 22959] + Case insensitive file systems are bad, m'kay + + [ 22965] + Skip test if Devel::PPPort is not built. + Probably should fix h2xs to work without it. + + [ 22966] + Skip test if Data::Dumper not built + + [ 22967] + Skip tests if List::Util not built + Branch: maint-5.8/perl + !> (integrate 31 files) +____________________________________________________________________________ +[ 22985] By: nicholas on 2004/06/23 15:15:37 + Log: Integrate: + [ 22907] + Upgrade to Test::Harness 2.42 + + [ 22908] + Upgrade to Time::Local 1.10. + + [ 22909] + Upgrade to Unicode::Collate 0.40 + + [ 22912] + Upgrade to Pod::LaTeX 0.57 + + [ 22914] + Upgrade to CGI.pm 3.05 + + [ 22915] + Upgrade to Digest 1.08. + + [ 22916] + Upgrade to Pod::Perldoc 3.13 + + [ 22920] + Upgrade to Pod::Parser 1.28 + (except Pod::Find, which has local patches not yet on CPAN) + + [ 22931] + Reapply change #20983, rolled back by change #22920, + as noticed by Craig Berry. + Branch: maint-5.8/perl + +> lib/Pod/Perldoc/t/01_about_verbose.t lib/Pod/t/user.t + !> MANIFEST lib/CGI.pm lib/CGI/Carp.pm lib/CGI/Util.pm + !> lib/CGI/t/html.t lib/Digest.pm lib/Pod/Checker.pm + !> lib/Pod/LaTeX.pm lib/Pod/ParseUtils.pm lib/Pod/Parser.pm + !> lib/Pod/Perldoc.pm lib/Pod/Perldoc/ToMan.pm + !> lib/Test/Harness.pm lib/Test/Harness/Changes + !> lib/Test/Harness/bin/prove lib/Test/Harness/t/prove-switches.t + !> lib/Time/Local.pm lib/Time/Local.t lib/Unicode/Collate.pm + !> lib/Unicode/Collate/t/hangul.t pod/pod2latex.PL + !> pod/pod2usage.PL pod/podchecker.PL pod/podselect.PL + !> t/pod/find.t +____________________________________________________________________________ +[ 22984] By: nicholas on 2004/06/23 14:38:51 + Log: Integrate: + [ 22906] + Patch 22835 Failed to upgrade all the new files in Encode 2.01 + As spotted by Jerry D. Hedden + + [ 22911] + Upgrade to Unicode::Normalize 0.30. + + [ 22970] + Subject: [PATCH] DB_File 1.809 was RE: [perl #30237] DB_File methods and substr don't mix + From: "Paul Marquess" <Paul.Marquess@btinternet.com> + Date: Tue, 22 Jun 2004 21:29:12 +0100 + Message-Id: <20040622202910.WBSU21846.mta08-svc.ntlworld.com@MARQUESSPT21> + Branch: maint-5.8/perl + !> ext/DB_File/Changes ext/DB_File/DB_File.pm + !> ext/DB_File/DB_File.xs ext/DB_File/t/db-btree.t + !> ext/DB_File/t/db-hash.t ext/DB_File/t/db-recno.t + !> ext/DB_File/typemap ext/Encode/Changes ext/Encode/Encode.pm + !> ext/Encode/META.yml ext/Unicode/Normalize/Changes + !> ext/Unicode/Normalize/Normalize.pm + !> ext/Unicode/Normalize/Normalize.xs + !> ext/Unicode/Normalize/t/illegal.t + !> ext/Unicode/Normalize/t/short.t + !> ext/Unicode/Normalize/t/split.t +____________________________________________________________________________ +[ 22983] By: nicholas on 2004/06/23 13:41:45 + Log: Integrate: + [ 22902] + Subject: Re: [PATCH] [perl #29841] utf8::decode doesn't work under -T + From: SADAHIRO Tomoyuki <bqw10602@nifty.com> + Date: Sun, 06 Jun 2004 00:37:21 +0900 + Message-Id: <20040606003344.57B2.BQW10602@nifty.com> + + [ 22976] + Add a regression test for bug #23765 (by Jarkko) + Branch: maint-5.8/perl + ! t/op/substr.t + !> lib/utf8.pm pod/perlapi.pod sv.c t/op/utftaint.t +____________________________________________________________________________ +[ 22982] By: nicholas on 2004/06/23 13:22:41 + Log: Integrate: + [ 22904] + Subject: Re: [PATCH] Re: Lack of error for large string on Solaris + From: Jarkko Hietaniemi <jhi@iki.fi> + Date: Mon, 07 Jun 2004 20:09:42 +0300 + Message-ID: <40C4A156.5030205@iki.fi> + + [ 22922] + Remove the "malloc wrappage" tests, due to their unportability + (as suggested by Jarkko.) + Branch: maint-5.8/perl + !> av.c pod/perldiag.pod pp.c pp_hot.c t/op/array.t t/op/repeat.t +____________________________________________________________________________ +[ 22981] By: nicholas on 2004/06/23 13:08:18 + Log: Integrate: + [ 22876] + Subject: [PATCH] Fix anomalies in Carp functions + From: Steve Hay <steve.hay@uk.radan.com> + Date: Tue, 25 May 2004 16:05:02 +0100 + Message-ID: <40B3609E.5060502@uk.radan.com> + + [ 22883] + Subject: [PATCH] Shell.pm: pod rewrite and new mini-feature $Shell::raw + From: LAUN Wolfgang <wolfgang.laun@alcatel.at> + Date: Tue, 1 Jun 2004 07:52:58 +0200 + Message-ID: <DF27CDCBD2581D4B88431901094E4B4D02B0C744@attmsx1.aut.alcatel.at> + + [ 22886] + Subject: [Fwd: [PATCH] Pod::Find should ignore SCM files and dirs] + From: Alan Burlison <Alan.Burlison@sun.com> + Date: Fri, 28 May 2004 23:28:44 +0100 + Message-ID: <40B7BD1C.40309@sun.com> + + [ 22888] + Subject: [PATCH] Remove redundant %SIG assignments from FileCache + From: Alan Burlison <Alan.Burlison@Sun.COM> + Date: Fri, 28 May 2004 12:27:06 +0100 + Message-ID: <40B7220A.4040305@sun.com> + + [ 22898] + Carp was mostly unusable with Safe because it may require + Carp::Heavy at run-time (while require() is forbidden.) + Have Safe load Carp::Heavy. + + [ 22921] + Subject: [PATCH] Re: [perl #24081] invalid regexp in perl -V + From: Robin Barker <Robin.Barker@npl.co.uk> + Date: Wed, 9 Jun 2004 12:02:01 +0100 + Message-ID: <533D273D4014D411AB1D00062938C4D9040468F1@hotel.npl.co.uk> + with further adjustements for bleadperl + + [ 22938] + Subject: [PATCH] File::Basename docs + From: Boris Zentner <bzm@2bz.de> + Date: Sat, 12 Jun 2004 16:29:42 +0200 + Message-Id: <200406121629.42595.bzm@2bz.de> + + [ 22940] + More forgiving version comparison in perlivp. + + [ 22971] + Adjust array index in FileCache.pm. + + Subject: [perl #30291] Use of uninitialized value (array index reference) in FileCache.pm module at line 140 + From: bbucklan@jpl-devvax.jpl.nasa.gov (via RT) <perlbug-followup@perl.org> + Date: 15 Jun 2004 16:55:22 -0000 + Message-ID: <rt-3.0.9-30291-90552.18.5392299690759@perl.org> + + [ 22972] + Proposed patch + test case. + + Subject: [perl #30409] charnames.pm clobbers default variable + From: Marcel "Grünauer" (via RT) <perlbug-followup@perl.org> + Date: 22 Jun 2004 16:43:50 -0000 + Message-ID: <rt-3.0.9-30409-91174.12.8617678524438@perl.org> + Branch: maint-5.8/perl + !> configpm ext/Opcode/Safe.pm lib/Carp.pm lib/Carp.t + !> lib/Carp/Heavy.pm lib/Config.t lib/File/Basename.pm + !> lib/FileCache.pm lib/Pod/Find.pm lib/Shell.pm lib/autouse.t + !> lib/charnames.pm lib/charnames.t utils/perlivp.PL +____________________________________________________________________________ +[ 22980] By: nicholas on 2004/06/23 12:44:49 + Log: Integrate: + [ 22870] + [perl #29708] Problem with autouse (causing Perl to crash) + @_ sometimes wasn't getting created right + + [ 22913] + [perl #30061] double DESTROY in for loop + pp_iter decremented the ref count of the previous iterant before + unaliasing it. This could lead to DESTROY being called with the + loop variable still aliased to the freed value. If the DESTROY + also contained a for loop with the same iterator variable, the + freed value would get resurrected then freed for a second time. + + [ 22945] + As 2/3rds (or 3/4s) of the SV head structure is rewritten, it doesn't + seem that memzero() of everything is the most efficient idea. + + [ 22962] + fix typo in gp_free + + [ 22969] + Abolish the "Tied variable freed while still in use" error - I have + a way to cleanly avoid the coredump. + Branch: maint-5.8/perl + !> gv.c mg.c pad.c pod/perldiag.pod pp_ctl.c pp_hot.c sv.c + !> t/cmd/for.t t/op/goto.t t/op/tie.t +____________________________________________________________________________ +[ 22979] By: nicholas on 2004/06/23 10:32:34 + Log: Integrate: + [ 22884] + Subject: [PATCH] configure.com and PERL_API_REVISION + From: "Craig A. Berry" <craigberry@mac.com> + Date: Mon, 31 May 2004 21:04:07 -0500 + Message-ID: <40BBE417.2090001@mac.com> + + [ 22892] + Subject: Re: [PATCH] [perl #29612] ndbm failure in make test + From: Alexey Tourbin <at@altlinux.ru> + Date: Sat, 22 May 2004 02:22:22 +0400 + Message-ID: <20040521222222.GJ2030@solemn.turbinal.org> + + [ 22893] + Subject: [PATCH] on VMS, always exit with failure in my_failure_exit + From: "Craig A. Berry" <craigberry@mac.com> + Date: Tue, 01 Jun 2004 23:16:58 -0500 + Message-ID: <40BD54BA.9040708@mac.com> + + [ 22901] + Subject: [PATCH] Have win32/makefile.mk default to gcc, and update docs + From: Steve Hay <steve.hay@uk.radan.com> + Date: Thu, 03 Jun 2004 15:46:17 +0100 + Message-ID: <40BF39B9.3060207@uk.radan.com> + + [ 22918] + Subject: [patch] Windows/Win32 thread handle leak with threads join + From: "Kevin Chase" <kevincha99@hotmail.com> + Date: Sun, 06 Jun 2004 09:44:44 -0700 + Message-ID: <BAY2-F172Ih5h5xf4rJ0001a3a6@hotmail.com> + + [ 22939] + Improve the substitution to cc_r for threading so that compilers + specified with a full path or as a parameter to ccache are changed + + [ 22975] + Backward compatibility issues for HP-UX 10.01 and older + Yes, it is still actively used in production environment + One more patch expected for toke.c optimization level + Branch: maint-5.8/perl + !> README.win32 configure.com ext/NDBM_File/hints/linux.pl + !> ext/threads/threads.xs hints/aix.sh hints/hpux.sh perl.c + !> win32/makefile.mk +____________________________________________________________________________ +[ 22978] By: nicholas on 2004/06/23 10:07:41 + Log: Integrate: + [ 22877] + Subject: [PATCH] Re: [perl #29969] h2ph not correctly processing glibc sys/sysmacros.ph + From: <wolfgang.laun@chello.at> + Date: Sun, 30 May 2004 17:27:07 +0200 + Message-Id: <20040530152707.ZLWL22856.viefep16-int.chello.at@localhost> + + [ 22925] + Make h2ph able to understand a limited set of inline functions. + The glibc apparently now ships headers that use inline functions + instead of plain old macros. + + [ 22929] + More h2ph tweaking for gcc __inline functions + + [ 22930] + More h2ph tweaks: recognition of C types + + [ 22933] + More h2ph voodoo. + Branch: maint-5.8/perl + !> utils/h2ph.PL +____________________________________________________________________________ +[ 22974] By: nicholas on 2004/06/22 21:59:24 + Log: Integrate: + [ 22882] + Subject: [PATCH] perlhack.pod - working with the Perl source + From: Dave Rolsky <autarch@urth.org> + Date: Mon, 31 May 2004 12:52:43 -0500 (CDT) + Message-ID: <Pine.LNX.4.58.0405311250520.7714@urth.org> + + [ 22885] + Subject: Re: [PATCH] UPDATE - Grammatical fixes and explanations in perlfunc.pod (sysopen) + From: Paul Fenwick <pjf@perltraining.com.au> + Date: Tue, 1 Jun 2004 11:31:34 +1000 + Message-ID: <20040601013134.GA11005@perltraining.com.au> + + [ 22890] + Subject: [PATCH] Re: [perl #29765] PERL-5.8.4 INSTALL + From: Andrew Dougherty <doughera@lafayette.edu> + Date: Tue, 1 Jun 2004 16:25:48 -0400 (EDT) + Message-ID: <Pine.SOL.4.58.0406011619090.4066@maxwell.phys.lafayette.edu> + + [ 22891] + Detypo. + + [ 22895] + Fix apidoc entries for PUSHMARK and newXSproto. + + [ 22900] + perlpodspec uses 'nonbreaking' and 'non-breaking'. + Normalize on the hyphenated spelling. + + [ 22903] + Subject: [perl #30073] Misleading docs of Text::Wrap + From: perl-5.8.0@ton.iguana.be (via RT) <perlbug-followup@perl.org> + Date: 6 Jun 2004 21:50:19 -0000 + Message-ID: <rt-3.0.9-30073-89834.19.0927626986204@perl.org> + + [ 22905] + Subject: Re: newSVpvn(NULL, 0); doesn't work as advertised + From: Marcus Holland-Moritz <mhx-perl@gmx.net> + Date: Fri, 4 Jun 2004 16:29:44 +0200 + Message-Id: <20040604162944.4011f1c6@r2d2> + + [ 22910] + Remove a spurious \n in a perltie example, + noticed by Geoffrey Young. + + [ 22917] + Several updates, major, and minor corrections, model updates, + explained the model numbering of HP-UX servers. + + [ 22919] + s/64bit/64-bit/g for consistency in the READMEs. + + [ 22923] + Subject: Re: [perl #30045] Transliteration replacement not terminated message obscure + From: Yitzchak Scott-Thoennes <sthoenna@efn.org> + Date: Mon, 7 Jun 2004 00:28:55 -0700 + Message-ID: <20040607072854.GB1028@efn.org> + + [ 22927] + Remove a warning against unsafe signals in perlipc.pod, + now that we have "safe signals". + + [ 22936] + Subject: [PATCH] perlop.pod: add an example to the .. and ... operators + From: Shlomi Fish <shlomif@vipe.technion.ac.il> + Date: Tue, 15 Jun 2004 10:15:15 +0300 (IDT) + Message-ID: <Pine.LNX.4.56.0406151013140.14618@vipe.technion.ac.il> + Branch: maint-5.8/perl + !> INSTALL README README.aix README.hpux XSUB.h lib/Text/Wrap.pm + !> pod/perlapi.pod pod/perldiag.pod pod/perlfunc.pod + !> pod/perlhack.pod pod/perlintern.pod pod/perlipc.pod + !> pod/perlop.pod pod/perlpodspec.pod pod/perltie.pod pp.h + !> pp_ctl.c sv.c +____________________________________________________________________________ +[ 22973] By: nicholas on 2004/06/22 21:35:46 + Log: Integrate: + [ 22824] + Fix new B::Concise test output + Subject: Re: Smoke [5.9.2] 22820 FAIL(F) openbsd 3.5 (i386/1 cpu) + From: Jim Cromie <jcromie@divsol.com> + Date: Mon, 17 May 2004 09:19:00 -0600 + Message-ID: <40A8D7E4.1020007@divsol.com> + + (the t/TEST part) + + [ 22875] + Subject: [PATCH] Fix generation of perlapi.pod + From: Steve Hay <steve.hay@uk.radan.com> + Date: Fri, 28 May 2004 11:46:41 +0100 + Message-ID: <40B71891.6090806@uk.radan.com> + + [ 22878] + Subject: [perl #29937] Entries missing from .packlist + From: jdhedden@1979.usna.com (via RT) <perlbug-followup@perl.org> + Date: 28 May 2004 19:23:48 -0000 + Message-ID: <rt-3.0.9-29937-88315.2.18472609678159@perl.org> + + [ 22894] + Document embed.fnc 'U' and 's' flags. + + [ 22932] + Subject: [PATCH] t/TEST + From: Abe Timmerman <abe@ztreet.demon.nl> + Date: Sun, 13 Jun 2004 11:41:49 +0200 + Message-Id: <200406131141.50361.abe@ztreet.demon.nl> + Branch: maint-5.8/perl + !> autodoc.pl embed.fnc installman installperl pod/perlapi.pod + !> t/TEST +____________________________________________________________________________ +[ 22871] By: nicholas on 2004/05/30 15:36:14 + Log: Update Changes + Branch: maint-5.8/perl + ! Changes patchlevel.h +____________________________________________________________________________ +[ 22869] By: nicholas on 2004/05/30 14:26:17 + Log: Integrate: + [ 22835] + Upgrade to Encode 2.00. + + [ 22842] + Subject: Re: utf-8 and taint don't work together + From: SADAHIRO Tomoyuki <bqw10602@nifty.com> + Date: Sat, 22 May 2004 21:38:33 +0900 + Message-Id: <20040522212704.C068.BQW10602@nifty.com> + + Date: Sun, 23 May 2004 09:56:15 +0900 + Message-Id: <20040523095609.E404.BQW10602@nifty.com> + + [ 22843] + Tests for change #22842, by SADAHIRO Tomoyuki + (adapted to the core) + + [ 22866] + Skip in minitest + + [ 22868] + Upgrade to Encode 2.01. + Branch: maint-5.8/perl + +> t/op/utftaint.t + !> (integrate 150 files) +____________________________________________________________________________ +[ 22867] By: nicholas on 2004/05/30 13:24:02 + Log: Integrate: + [ 22817] + Subject: [perl #29527] Perl 5.8.4 build problems on LynxOS + From: Olli Savia (via RT) <perlbug-followup@perl.org> + Date: 12 May 2004 13:02:41 -0000 + Message-ID: <rt-3.0.9-29527-87290.17.3367022021997@perl.org> + + [ 22841] + Subject: [PATCH] win32_chsize is not exported on Win32 + From: Steve Hay <steve.hay@uk.radan.com> + Date: Mon, 24 May 2004 12:52:48 +0100 + Message-ID: <40B1E210.4050202@uk.radan.com> + Branch: maint-5.8/perl + !> makedef.pl sv.c +____________________________________________________________________________ +[ 22865] By: nicholas on 2004/05/30 13:01:21 + Log: Integrate: + [ 22822] + David Manura is the new maintainer of Text::Balanced. + + [ 22840] + Subject: [PATCH] Re: [perl #29765] PERL-5.8.4 INSTALL + From: Yitzchak Scott-Thoennes <sthoenna@efn.org> + Date: Fri, 21 May 2004 11:35:34 -0700 + Message-ID: <20040521183533.GA5108@efn.org> + (plus whitespace removal) + + [ 22852] + Subject: TEST needs to ignore SCM files + From: Alan Burlison <Alan.Burlison@sun.com> + Date: Thu, 27 May 2004 23:32:28 +0100 + Message-ID: <40B66C7C.8030303@sun.com> + Branch: maint-5.8/perl + !> INSTALL Porting/Maintainers.pl t/TEST +____________________________________________________________________________ +[ 22864] By: nicholas on 2004/05/30 12:38:30 + Log: Integrate: + [ 22769] + Subject: [perl #29073] Reference to incorrect method in documentation of + From: "bob@starlabs.net (via RT)" <perlbug-followup@perl.org> + Message-ID: <rt-3.0.8-29073-85903.18.1381766820328@perl.org> + Date: 22 Apr 2004 10:49:22 -0000 + + [ 22829] + perlrun.pod minor fixes : + - the parameter to -x is optional + - pod nit + + [ 22837] + Subject: Proposed doc patch for getsockopt + From: perl5-porters@ton.iguana.be (Ton Hospel) + Date: Sun, 16 May 2004 13:35:20 +0000 (UTC) + Message-Id: <c87qmo$u9b$1@post.home.lunix> + + [ 22853] + Subject: [PATCH doc] Re: undef loses it magicness when assigned to a variable? + From: Stas Bekman <stas@stason.org> + Date: Thu, 27 May 2004 11:25:08 -0700 + Message-ID: <40B63284.5040203@stason.org> + Branch: maint-5.8/perl + !> lib/Text/ParseWords.pm pod/perlapi.pod pod/perlfunc.pod + !> pod/perlguts.pod pod/perlrun.pod sv.h +____________________________________________________________________________ +[ 22863] By: nicholas on 2004/05/30 11:38:17 + Log: Integrate: + [ 22756] + Subject: [PATCH] Document limitations in PUSHi et al macros and add new mPUSHi et al macros + From: Steve Hay <steve.hay@uk.radan.com> + Date: Fri, 30 Apr 2004 10:07:21 +0100 + Message-ID: <40921749.3050600@uk.radan.com> + + [ 22757] + Follow-up to previous patch: the mX?PUSH[inup] macros + should handle 'set' magic, just like the X?PUSH[inup] + counterparts. + + [ 22779] + Fix mX?PUSH[inup] macros. (Follow-up to #22756 and #22757) + + Subject: Re: [PATCH] Document limitations in PUSHi et al macros and add new mPUSHi et al macros + From: Marcus Holland-Moritz <mhx-perl@gmx.net> + Date: Mon, 3 May 2004 20:03:28 +0200 + Message-Id: <20040503200328.24efcda5@r2d2> + + [ 22783] + Add tests for mX?PUSH[inup] macros. + + Subject: Re: [PATCH] Document limitations in PUSHi et al macros and add new mPUSHi et al macros + From: Steve Hay <steve.hay@uk.radan.com> + Date: Wed, 05 May 2004 15:34:45 +0100 + Message-ID: <4098FB85.1060602@uk.radan.com> + Branch: maint-5.8/perl + +> ext/XS/APItest/t/push.t + !> MANIFEST ext/XS/APItest/APItest.pm ext/XS/APItest/APItest.xs + !> ext/XS/APItest/MANIFEST pod/perlapi.pod pod/perlguts.pod pp.h +____________________________________________________________________________ +[ 22862] By: nicholas on 2004/05/30 10:09:57 + Log: Integrate: + [ 22662] + C<undef> doesn't look like a number. See also: + + Subject: Re: [perl #27606] undef "looks like" a number + From: Marcus Holland-Moritz <mhx-perl@gmx.net> + Date: Mon, 15 Mar 2004 22:16:26 +0100 + Message-Id: <20040315221626.48061c67@r2d2> + + [ 22798] + [perl #29395] Scalar::Util::refaddr falsely returns false + Add mg_get() to refaddr() when SV is magical. + Fix the non-xs version of looks_like_number(). + + [ 22838] + Update to Scalar-List-Utils-1.14 + Branch: maint-5.8/perl + +> ext/List/Util/Changes + - ext/List/Util/ChangeLog + ! ext/List/Util/t/lln.t pod/perl585delta.pod + !> MANIFEST ext/List/Util/README ext/List/Util/Util.xs + !> ext/List/Util/lib/List/Util.pm + !> ext/List/Util/lib/Scalar/Util.pm ext/List/Util/t/refaddr.t + !> pp_ctl.c sv.c +____________________________________________________________________________ +[ 22861] By: nicholas on 2004/05/30 09:43:49 + Log: Integrate: + [ 22816] + Make XSLoader update @DynaLoader::dl_shared_objects. + + [ 22823] + Subject: [PATCH] Re: [perl #29581] glob() misses a lot of matches + From: LAUN Wolfgang <wolfgang.laun@alcatel.at> + Date: Mon, 17 May 2004 07:38:19 +0200 + Message-ID: <DF27CDCBD2581D4B88431901094E4B4D02B0C71E@attmsx1.aut.alcatel.at> + + [ 22828] + Subject: [perl #29623] Patch for h2xs.t in Perl 5.8.4 + From: mats@sm5sxl.net (via RT) <perlbug-followup@perl.org> + Date: 16 May 2004 13:33:32 -0000 + Message-ID: <rt-3.0.9-29623-87522.10.1965589695082@perl.org> + + [ 22836] + Subject: [PATCH] h2xs doesn't recognize indented enums + From: Tassilo von Parseval <tassilo.parseval@post.rwth-aachen.de> + Date: Fri, 21 May 2004 10:51:58 +0200 + Message-id: <20040521085158.GA10660@ethan> + (modified regexp) + + [ 22848] + Subject: [PATCH] correctly handle C<< >> and C<<< >>> in diagnostics + From: Yitzchak Scott-Thoennes <sthoenna@efn.org> + Date: Tue, 25 May 2004 02:29:37 -0700 + Message-ID: <20040525092937.GA2332@efn.org> + + [ 22850] + Subject: [PATCH] 'perl -v' fails if local_patches contains code snippets + From: Alan Burlison <Alan.Burlison@sun.com> + Date: Wed, 26 May 2004 16:24:03 +0100 + Message-ID: <40B4B693.9090905@sun.com> + (using \0 as a separator for q//) + Branch: maint-5.8/perl + !> ext/DynaLoader/DynaLoader_pm.PL ext/DynaLoader/XSLoader_pm.PL + !> ext/File/Glob/Glob.xs lib/diagnostics.pm lib/h2xs.t perl.c + !> utils/h2xs.PL +____________________________________________________________________________ +[ 22860] By: nicholas on 2004/05/29 22:13:46 + Log: Integrate: + [ 22830] + [perl #29637] Thread creation time is hypersensitive + + Due to a logic error, the dup ptr table sometimes wans't being + grown, leading to extremely slow cloning. + + [ 22831] + improve hashing algorithm for ptr tables in perl_clone: + the bottom few bits of a pointer are usually zero + Branch: maint-5.8/perl + !> sv.c +____________________________________________________________________________ +[ 22859] By: nicholas on 2004/05/29 21:52:37 + Log: Integrate: + [ 22771] + ensure that utf8 Perl code magically called from a regex localizes $. + + [ 22772] + remove spurious intentation in utf8_pva.pl + Branch: maint-5.8/perl + !> lib/utf8_pva.pl +____________________________________________________________________________ +[ 22858] By: nicholas on 2004/05/29 21:04:22 + Log: Integrate 22744, 22760, 22761, 22762, 22763, 22765 redux + + http://www.google.com/search?btnI=again&q=perforce+fails+bah + Branch: maint-5.8/perl + - lib/unicore/lib/gc_sc/Sterm.pl + !> lib/unicore/lib/gc_sc/Dash.pl lib/unicore/lib/gc_sc/Hyphen.pl + !> lib/unicore/lib/gc_sc/Radical.pl +____________________________________________________________________________ +[ 22857] By: nicholas on 2004/05/29 20:48:27 + Log: Integrate: + [ 22744] + Subject: [PATCH utf8_heavy.pl, mktables, et. al.] candidate for TR18 compliance + From: Jeff 'japhy' Pinyan <japhy@perlmonk.org> + Date: Thu, 22 Apr 2004 14:31:30 -0400 (EDT) + Message-ID: <Pine.LNX.4.44.0404221429040.10466-101000@perlmonk.org> + + Date: Mon, 26 Apr 2004 12:37:21 -0400 (EDT) + Message-ID: <Pine.LNX.4.44.0404261222320.7154-400000@perlmonk.org> + + [ 22760] + Remove the no-longer autogenerated Unicode files + + [ 22761] + Avoid mktables generating Sterm.pl and Sterm.pl in the same directory + by making the %BaseName check global + + [ 22762] + Some fool removed lib/unicore/ArabicShaping.txt in change 22760 + + [ 22763] + And that same fool forgot to add the not-really-needed "fuzzy" versions + of some binary property files + + [ 22765] + Make t/uni/class.t pass on case insensitive file systems + Branch: maint-5.8/perl + +> (branch 410 files) + - (delete 322 files) + !> MANIFEST lib/unicore/Canonical.pl + !> lib/unicore/CombiningClass.pl lib/unicore/Decomposition.pl + !> lib/unicore/Exact.pl lib/unicore/Name.pl + !> lib/unicore/Properties lib/unicore/To/Digit.pl + !> lib/unicore/To/Fold.pl lib/unicore/To/Lower.pl + !> lib/unicore/To/Title.pl lib/unicore/To/Upper.pl + !> lib/unicore/mktables lib/utf8_heavy.pl pod/perlunicode.pod + !> t/op/pat.t t/uni/class.t +____________________________________________________________________________ +[ 22856] By: nicholas on 2004/05/29 20:04:40 + Log: Integrate: + [ 22693] + Subject: [PATCH] lib/utf8_heavy.pl -- cascading classes and '&' support + From: Jeff 'japhy' Pinyan <japhy@perlmonk.org> + Date: Mon, 12 Apr 2004 20:24:48 -0400 (EDT) + Message-ID: <Pine.LNX.4.44.0404122011160.3038-200000@perlmonk.org> + + [ 22713] + Subject: Re: [PATCH] lib/utf8_heavy.pl -- cascading classes and '&' support + From: "Jeff 'japhy' Pinyan" <japhy@perlmonk.org> + Date: Wed, 14 Apr 2004 17:01:38 -0400 (EDT) + Message-ID: <Pine.LNX.4.44.0404141659480.11423-301000@perlmonk.org> + + [ 22714] + New file left out of the last commit. + Branch: maint-5.8/perl + +> t/uni/class.t + !> MANIFEST lib/utf8_heavy.pl pod/perlunicode.pod +____________________________________________________________________________ +[ 22855] By: nicholas on 2004/05/29 19:39:53 + Log: Integrate: + [ 22806] + Subject: Re: a little extra cmdline help. [PATCH] + From: Jim Cromie <jcromie@divsol.com> + Date: Mon, 10 May 2004 15:25:07 -0600 + Message-Id: <409FF333.4020104@divsol.com> + + [ 22810] + Subject: various -V: searches [PATCH] + From: Jim Cromie <jcromie@divsol.com> + Date: Tue, 11 May 2004 00:15:46 -0600 + Message-ID: <40A06F92.1070607@divsol.com> + + [ 22826] + Error message too wide. + Branch: maint-5.8/perl + ! lib/Config.t + !> configpm perl.c pod/perlrun.pod +____________________________________________________________________________ +[ 22854] By: nicholas on 2004/05/29 18:22:58 + Log: Revert 22849 and 22851, except for the t/test.pl improvement. + [blead patches 22664 and 22669] + + http://www.perforce.com/perforce/technotes/note014.html + "How do you back out a change?" + + Let me summarise their answer: + With difficulty. + (We find it easier to write a manual about how to kludge it than + to improve our software to make it simple) + Branch: maint-5.8/perl + - ext/B/t/OptreeCheck.pm ext/B/t/optree_check.t + - ext/B/t/optree_concise.t ext/B/t/optree_samples.t + - ext/B/t/optree_sort.t ext/B/t/optree_varinit.t + ! MANIFEST ext/B/t/concise.t +____________________________________________________________________________ +[ 22851] By: nicholas on 2004/05/27 10:22:23 + Log: Integrate: + [ 22669] + Fix command-line quoting under Windows for the new optree tests + Subject: Re: Smoke [5.9.2] 22666 FAIL(F) MSWin32 WinXP/.Net SP1 (x86/1 cpu) + From: Steve Hay <steve.hay@uk.radan.com> + Date: Wed, 07 Apr 2004 09:46:01 +0100 + Message-ID: <4073BFC9.10707@uk.radan.com> + Branch: maint-5.8/perl + !> ext/B/t/optree_samples.t +____________________________________________________________________________ +[ 22849] By: nicholas on 2004/05/26 10:12:38 + Log: Integrate: + [ 22664] + Subject: Re: tests for change #22539 + From: Jim Cromie <jcromie@divsol.com> + Date: Tue, 30 Mar 2004 14:39:31 -0700 + Message-ID: <4069E913.5040906@divsol.com> + (with some spelling tweaks) + + [I'd do this and the next 2 as one, but perforce is hateful: + http://nick.hates-software.com/2003/12/30/9729c0ac.html + ] + Branch: maint-5.8/perl + +> ext/B/t/OptreeCheck.pm ext/B/t/optree_check.t + +> ext/B/t/optree_concise.t ext/B/t/optree_samples.t + +> ext/B/t/optree_sort.t ext/B/t/optree_varinit.t + ! ext/B/t/concise.t + !> MANIFEST ext/B/B/Concise.pm t/test.pl +____________________________________________________________________________ +[ 22847] By: nicholas on 2004/05/25 21:27:12 + Log: Integrate: + [ 22839] + [perl #29790] Optimization busted: '@a = "b", sort @a' drops "b" + Fix the sort-in-place optimization of change #22349. + Branch: maint-5.8/perl + !> op.c t/op/sort.t +____________________________________________________________________________ +[ 22846] By: nicholas on 2004/05/25 20:56:06 + Log: Integrate: + [ 22808] + Subject: [PATCH] debugger (step backwards) + From: Richard.Foley@t-online.de (Richard Foley) + Date: Tue, 11 May 2004 11:04:11 +0200 + Message-Id: <200405111104.11484.richard.foley@rfi.net> + + [ 22809] + More pod names in the debugger for the runman command + Branch: maint-5.8/perl + !> lib/perl5db.pl +____________________________________________________________________________ +[ 22845] By: nicholas on 2004/05/25 20:54:05 + Log: Integrate: + [ 22788] + add -pipe to gcc's default flags + it has shown a compile time speed increase of about 40% on + Linux and HP-UX, and also works on cygwin-1.5.9. On failing + OS/gcc combo's remove it in the hints + + [ 22815] + Subject: [PATCH] Configure shouldn't unconditionally add in -pipe + From: Andy Dougherty <doughera@lafayette.edu> + Date: Tue, 11 May 2004 13:14:42 -0400 (EDT) + Message-ID: <Pine.SOL.4.58.0405111313210.14279@maxwell.phys.lafayette.edu> + Branch: maint-5.8/perl + !> Configure hints/darwin.sh hints/rhapsody.sh +____________________________________________________________________________ +[ 22844] By: nicholas on 2004/05/24 16:42:34 + Log: Update changes + Branch: maint-5.8/perl + ! Changes patchlevel.h +____________________________________________________________________________ +[ 22834] By: nicholas on 2004/05/20 13:13:45 + Log: Integrate: + [ 22827] + Subject: [PATCH] Re: Smoke [5.9.2] 22818 FAIL(F) MSWin32 WinXP/.Net SP1 (x86/1 cpu) + From: Steve Hay <steve.hay@uk.radan.com> + Date: Fri, 14 May 2004 17:33:17 +0100 + Message-ID: <40A4F4CD.2000003@uk.radan.com> + Branch: maint-5.8/perl + !> t/comp/utf.t +____________________________________________________________________________ +[ 22832] By: nicholas on 2004/05/20 08:18:58 + Log: Integrate: + [ 22818] + Subject: BOM-marked and (BOMless) UTF-16 scripts not working + From: Jarkko Hietaniemi <jhi@iki.fi> + Message-ID: <40A26D75.8080406@iki.fi> + Date: Wed, 12 May 2004 21:31:17 +0300 + Branch: maint-5.8/perl + +> t/comp/utf.t + !> MANIFEST pod/perldiag.pod pod/perlunicode.pod toke.c +____________________________________________________________________________ +[ 22813] By: nicholas on 2004/05/12 10:16:45 + Log: (only the fix, not the tests, as they incorporate the variable names) + + Integrate: + [ 22796] + [perl #29346] Double warning for int(undef) and abs(undef) + Remove the duplicate warnings and update tests. + Branch: maint-5.8/perl + !> pp.c +____________________________________________________________________________ +[ 22805] By: nicholas on 2004/05/10 21:22:15 + Log: Integrate: + [ 22797] + Document that select() on Windows doesn't work on non-socket filehandles. + + [ 22799] + Subject: [perl #29397] Change in pod2man arguments + From: Thorsten Glaser (via RT) <perlbug-followup@perl.org> + Date: 6 May 2004 22:08:10 -0000 + Message-Id: <rt-3.0.9-29397-86929.5.37563386041974@perl.org> + + [ 22800] + Windows issues with select() are already documented in perlport. + + [ 22803] + Subject: [PATCH] File::Copy Pod + From: slaven@rezic.de + Date: Mon, 10 May 2004 09:57:37 +0000 + Message-Id: <1084183057.10822@devpc01.iconmobile.de> + + [ 22804] + Remove stray '. + Branch: maint-5.8/perl + !> lib/File/Copy.pm pod/perlfunc.pod pod/pod2man.PL +____________________________________________________________________________ +[ 22795] By: nicholas on 2004/05/06 16:06:17 + Log: Integrate: + [ 22696] + #24121: Configure under turkish locale fails + toupper (i) != I in turkish, but U+0130 + \N{LATIN CAPITAL LETTER I WITH DOT ABOVE} + Patch supplied by Rafael + + [ 22743] + usemallocwrap works on AIX, but not with vac-5 + Date: Mon, 26 Apr 2004 15:35:23 +0200 + From: "H.Merijn Brand" <h.m.brand@hccnet.nl> + Subject: Re: Perl 5.8.4 "panic: memory wrap" in miniperl on AIX 5.1 + Message-Id: <20040426152951.A6C4.H.M.BRAND@hccnet.nl> + + [ 22750] + When configuring for 64-bit support, check that the + C library functions for casting floating point values + to 64-bit integer values are not broken. + + [ 22752] + The openbsd 64-bit test should use $uquadtype rather + than hardcoding unsigned long long. + + [ 22753] + CXUX_BROKEN_CONSTANT_CONVERT isn't used anymore. + Remove all associated code. + + [ 22759] + mktables requires post 5.005 + + [ 22773] + Subject: Re: "fuzzy" in mktables + From: Jarkko Hietaniemi <jhi@iki.fi> + Message-ID: <4093A82B.6040609@iki.fi> + Date: Sat, 01 May 2004 16:37:47 +0300 + Branch: maint-5.8/perl + !> Configure hints/aix.sh hints/aix_4.sh hints/cxux.sh + !> hints/openbsd.sh lib/unicore/mktables pp_pack.c +____________________________________________________________________________ +[ 22794] By: nicholas on 2004/05/06 15:43:41 + Log: Integrate: + [ 22681] + find2perl should not default to -print when -eval is specified. + Noticed by David Dyck. + + [ 22733] + Missing copyright in the README. + + [ 22735] + Subject: [PATCH] Where to find nmake for windows + From: Abe Timmerman <abe@ztreet.demon.nl> + Date: Thu, 22 Apr 2004 23:57:40 +0200 + Message-Id: <200404222357.40508.abe@ztreet.demon.nl> + Changed download URL references for nmake + + [ 22747] + Subject: [perl #29033] typo in description of sleep in documentation of POSIX module + Date: 21 Apr 2004 11:07:22 -0000 + From: "bob@starlabs.net (via RT)" <perlbug-followup@perl.org> + Message-ID: <rt-3.0.8-29033-85811.17.0452776199501@perl.org> + + [ 22748] + Subject: [PATCH] Add diagnostics section to base.pm + From: "Jos I. Boumans" <kane@dwim.org> + Date: Wed, 28 Apr 2004 13:04:47 +0200 + Message-Id: <DC9B4A9C-9903-11D8-BA95-000A956B0E06@dwim.org> + + [ 22749] + Fix for [perl #28963]: find2perl was sometimes generating + invalid code. + + [ 22768] + It seems daft to me that we have a synopis example that will fail if + gcc happened to be invoked via the name cc, and completely ignores + the far more reliable 'gccversion' variable + So here's one using 'usethreads' that ought to work everywhere. + + [ 22782] + Subject: Problem with h2xs + From: David Cannings <lists@edeca.net> + Date: Mon, 3 May 2004 13:44:33 +0100 + Message-Id: <200405031344.33723.lists@edeca.net> + (Second patch only) + + [ 22789] + Subject: Problem with system() on Win9x and command.com (perl 5.8.x-5.9.x) + From: bilbo@ua.fm + Date: Wed, 28 Apr 2004 00:19:55 +0300 + Message-ID: <611491036.20040428001955@ua.fm> + + [ 22793] + Add a small script to check whether a perl source tree + (with or without generated files) is friendly with + case-insensitive filesystems. + Adapted from : + Subject: Re: STerm.pl vs Sterm.pl + From: James Mastros <james@mastros.biz> + Date: Thu, 06 May 2004 14:45:53 +0200 + Message-ID: <20040506124556.2402.qmail@onion.perl.org> + Branch: maint-5.8/perl + +> Porting/checkcase.pl + !> MANIFEST README README.win32 configpm ext/POSIX/POSIX.pod + !> lib/base.pm pod/perlmodinstall.pod utils/h2xs.PL win32/win32.c + !> x2p/find2perl.PL +____________________________________________________________________________ +[ 22792] By: nicholas on 2004/05/06 14:15:56 + Log: Integrate: + [ 22715] + Upgrade to FileCache 1.04. + + [ 22717] + Subject: [PATCH] Sync Term::Cap with CPAN version + From: Jonathan Stowe <jns@gellyfish.com> + Date: Tue, 20 Apr 2004 12:37:28 +0100 + Message-Id: <1082461047.2736.96.camel@localhost> + + [ 22751] + Update to Test.pm 1.25 (from SBURKE). + Branch: maint-5.8/perl + +> lib/Test/t/05_about_verbose.t lib/Test/t/multiline.t + !> MANIFEST lib/FileCache.pm lib/Term/Cap.pm lib/Test.pm +____________________________________________________________________________ +[ 22791] By: nicholas on 2004/05/06 13:55:34 + Log: Integrate: + [ 21935] + Upgrade to Time::Local 1.07_94 + + [ 22670] + Disable the edge case tests for timegm and timelocal on + AIX-4.3 since the OS is obsoleted, and fixes are not to + be expected + + [ 22671] + Integrated Time-Local-1.09 from Dave Rolsky + Corrected a wrap error from the CPAN version to match #22670 + Tested on AIX to make sure the skip is still needed + Branch: maint-5.8/perl + !> lib/Time/Local.pm lib/Time/Local.t +____________________________________________________________________________ +[ 22790] By: nicholas on 2004/05/06 13:36:23 + Log: Integrate: + [ 22686] + Sync with libnet 1.18 + + (plus revert the relevant parts of 22643) + Branch: maint-5.8/perl + +> lib/Net/Changes.libnet lib/Net/t/datasend.t + - lib/Net/ChangeLog.libnet + ! lib/Net/NNTP.pm lib/Net/POP3.pm lib/Net/SMTP.pm + !> MANIFEST lib/Net/Cmd.pm lib/Net/FTP.pm lib/Net/README.libnet + !> lib/Net/Time.pm lib/Net/t/hostname.t +____________________________________________________________________________ +[ 22785] By: nicholas on 2004/05/06 08:16:42 + Log: Fix typo + Branch: maint-5.8/perl + ! MANIFEST +____________________________________________________________________________ +[ 22784] By: nicholas on 2004/05/05 21:43:32 + Log: Integrate: + [ 22641] + Fix bug #27940 : \cX escapes weren't working correctly in regular + expression ranges. + + [ 22652] + Subject: sv_pvutf8n_force and sv_pvbyten_force + From: SADAHIRO Tomoyuki <bqw10602@nifty.com> + Date: Wed, 24 Mar 2004 00:16:52 +0900 + Message-Id: <20040324001126.098F.BQW10602@nifty.com> + + [ 22667] + The optree builder was looping when constructing the ops + for a map/grep block containing a while(1). + (Bug reported by Pixel.) + + [ 22687] + Make global cleanup fractionally faster by giving S_visit() + flags/mask to compare SVs against. + + [ 22712] + Subject: Re: [perl #28532] optional match of an anchor gets ignored + From: hv@crypt.org + Date: Wed, 14 Apr 2004 19:30:46 +0100 + Message-Id: <200404141830.i3EIUko03728@zen.crypt.org> + + [ 22721] + Subject: [patch] log the interpreter id in warnings + From: Stas Bekman <stas@stason.org> + Date: Mon, 19 Apr 2004 18:10:01 -0700 + Message-ID: <40847869.1000906@stason.org> + + [ 22746] + fix a coredump caused by rv2gv not fully converting a PV to an RV + + [ 22755] + Fix 29149 - another UTF8 cache bug hit by substr. + Regression test from: + + Subject: Re: [perl #29149] substr/UTF8 related problem with perl 5.8.3 on linux + From: SADAHIRO Tomoyuki <bqw10602@nifty.com> + Message-Id: <20040429103926.5BA6.BQW10602@nifty.com> + Date: Thu, 29 Apr 2004 10:53:17 +0900 + + [ 22764] + Save some repeated strlen()s in Perl_swash_init + + [ 22774] + [perl #28938] split could leave an array without &PL_sv_undef + in the unused elements + + [ 22775] + [perl #29127] scalar delete of empty slice returned garbage + + [ 22776] + [perl #28986] perl -e "open m" crashes Perl + + [ 22777] + add test for change #22776 ("open m" crashes Perl) + + [ 22778] + add test for change #22746 ([perl #29102] Crash on assign to lex fh) + + [ 22781] + [perl #29340] Bizarre copy of ARRAY + make sure a pad op's flags are updated after optimising away + the assignment in my @a = () (see change 22520). + Branch: maint-5.8/perl + ! t/op/substr.t + !> embed.fnc embed.h gv.c handy.h hv.c op.c perl.c pp.c proto.h + !> regcomp.c regexec.c sv.c t/io/open.t t/op/delete.t t/op/grep.t + !> t/op/my.t t/op/pat.t t/op/split.t toke.c utf8.c +____________________________________________________________________________ +[ 22766] By: nicholas on 2004/05/02 20:26:29 + Log: Ready for more Changes + Branch: maint-5.8/perl + +> Changes5.8.4 + ! Changes MANIFEST +____________________________________________________________________________ +[ 22740] By: nicholas on 2004/04/23 14:14:11 + Log: Subject: [PATCH] unfork the debugger (patch for 5.8.4) + From: Richard.Foley@t-online.de (Richard Foley) + Message-Id: <200404230633.29186.richard.foley@rfi.net> + Date: Fri, 23 Apr 2004 06:33:29 +0200 + Branch: maint-5.8/perl + ! lib/perl5db.pl +____________________________________________________________________________ +[ 22738] By: nicholas on 2004/04/23 13:13:24 + Log: Create perl585delta.pod + Branch: maint-5.8/perl + + pod/perl585delta.pod + ! MANIFEST pod.lst pod/perl.pod pod/perltoc.pod + ! vms/descrip_mms.template win32/Makefile win32/makefile.mk + ! win32/pod.mak +____________________________________________________________________________ +[ 22732] By: nicholas on 2004/04/22 09:21:28 + Log: That was 5.8.4 + Branch: maint-5.8/perl + ! patchlevel.h +____________________________________________________________________________ +[ 22731] By: nicholas on 2004/04/21 19:37:51 + Log: Oink, oink, flap, flap! + Branch: maint-5.8/perl + ! patchlevel.h pod/perlhist.pod +____________________________________________________________________________ +[ 22730] By: nicholas on 2004/04/21 18:55:58 + Log: Update Changes + Branch: maint-5.8/perl + ! Changes patchlevel.h diff --git a/gnu/usr.bin/perl/Cross/config.sh-arm-linux b/gnu/usr.bin/perl/Cross/config.sh-arm-linux index 1a009b6476e..edb594a2590 100644 --- a/gnu/usr.bin/perl/Cross/config.sh-arm-linux +++ b/gnu/usr.bin/perl/Cross/config.sh-arm-linux @@ -36,8 +36,8 @@ api_subversion='0' api_version='8' api_versionstring='5.8.0' ar='ar' -archlib='/usr/lib/perl5/5.8.5/armv4l-linux' -archlibexp='/usr/lib/perl5/5.8.5/armv4l-linux' +archlib='/usr/lib/perl5/5.8.6/armv4l-linux' +archlibexp='/usr/lib/perl5/5.8.6/armv4l-linux' archname64='' archname='armv4l-linux' archobjs='' @@ -55,7 +55,7 @@ castflags='0' cat='cat' cc='cc' cccdlflags='-fpic' -ccdlflags='-rdynamic -Wl,-rpath,/usr/lib/perl5/5.8.5/armv4l-linux/CORE' +ccdlflags='-rdynamic -Wl,-rpath,/usr/lib/perl5/5.8.6/armv4l-linux/CORE' ccflags='-fno-strict-aliasing -I/usr/local/include -D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64' ccflags_uselargefiles='-D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64' ccname='gcc' @@ -668,7 +668,7 @@ inc_version_list=' ' inc_version_list_init='0' incpath='' inews='' -installarchlib='./install_me_here/usr/lib/perl5/5.8.5/armv4l-linux' +installarchlib='./install_me_here/usr/lib/perl5/5.8.6/armv4l-linux' installbin='./install_me_here/usr/bin' installhtml1dir='' installhtml3dir='' @@ -676,13 +676,13 @@ installman1dir='./install_me_here/usr/share/man/man1' installman3dir='./install_me_here/usr/share/man/man3' installprefix='./install_me_here/usr' installprefixexp='./install_me_here/usr' -installprivlib='./install_me_here/usr/lib/perl5/5.8.5' +installprivlib='./install_me_here/usr/lib/perl5/5.8.6' installscript='./install_me_here/usr/bin' -installsitearch='./install_me_here/usr/lib/perl5/site_perl/5.8.5/armv4l-linux' +installsitearch='./install_me_here/usr/lib/perl5/site_perl/5.8.6/armv4l-linux' installsitebin='./install_me_here/usr/bin' installsitehtml1dir='' installsitehtml3dir='' -installsitelib='./install_me_here/usr/lib/perl5/site_perl/5.8.5' +installsitelib='./install_me_here/usr/lib/perl5/site_perl/5.8.6' installsiteman1dir='./install_me_here/usr/share/man/man1' installsiteman3dir='./install_me_here/usr/share/man/man3' installsitescript='./install_me_here/usr/bin' @@ -808,8 +808,8 @@ pmake='' pr='' prefix='/usr' prefixexp='/usr' -privlib='/usr/lib/perl5/5.8.5' -privlibexp='/usr/lib/perl5/5.8.5' +privlib='/usr/lib/perl5/5.8.6' +privlibexp='/usr/lib/perl5/5.8.6' procselfexe='"/proc/self/exe"' prototype='define' ptrsize='4' @@ -870,17 +870,17 @@ sig_num='0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 sig_num_init='0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 6, 17, 29, 31, 0' sig_size='68' signal_t='void' -sitearch='/usr/lib/perl5/site_perl/5.8.5/armv4l-linux' -sitearchexp='/usr/lib/perl5/site_perl/5.8.5/armv4l-linux' +sitearch='/usr/lib/perl5/site_perl/5.8.6/armv4l-linux' +sitearchexp='/usr/lib/perl5/site_perl/5.8.6/armv4l-linux' sitebin='/usr/bin' sitebinexp='/usr/bin' sitehtml1dir='' sitehtml1direxp='' sitehtml3dir='' sitehtml3direxp='' -sitelib='/usr/lib/perl5/site_perl/5.8.5' +sitelib='/usr/lib/perl5/site_perl/5.8.6' sitelib_stem='/usr/lib/perl5/site_perl' -sitelibexp='/usr/lib/perl5/site_perl/5.8.5' +sitelibexp='/usr/lib/perl5/site_perl/5.8.6' siteman1dir='/usr/share/man/man1' siteman1direxp='/usr/share/man/man1' siteman3dir='/usr/share/man/man3' @@ -917,7 +917,7 @@ stdio_stream_array='' strerror_r_proto='0' strings='/usr/include/string.h' submit='' -subversion='5' +subversion='4' sysman='/usr/share/man/man1' tail='' tar='' @@ -1000,7 +1000,7 @@ vendorprefix='' vendorprefixexp='' vendorscript='' vendorscriptexp='' -version='5.8.5' +version='5.8.6' version_patchlevel_string='version 8 subversion 3' versiononly='undef' vi='' diff --git a/gnu/usr.bin/perl/META.yml b/gnu/usr.bin/perl/META.yml index 537cbefea9d..e0f8f3c1278 100644 --- a/gnu/usr.bin/perl/META.yml +++ b/gnu/usr.bin/perl/META.yml @@ -1,5 +1,5 @@ name: perl -version: 5.008005 +version: 5.008006 abstract: Practical Extraction and Reporting Language author: perl5-porters@perl.org license: perl @@ -20,7 +20,6 @@ private: - ext/Time/HiRes - ext/Unicode/Normalize - lib/Attribute/Handlers - - lib/base - lib/bignum - lib/CGI - lib/Class/ISA @@ -60,7 +59,6 @@ private: file: - ext/Filter/t/call.t - lib/Attribute/Handlers.pm - - lib/base.pm - lib/bigint.pm - lib/bignum.pm - lib/bigrat.pm @@ -96,7 +94,6 @@ private: - lib/ExtUtils/MY.pm - lib/ExtUtils/Packlist.pm - lib/ExtUtils/testlib.pm - - lib/fields.pm - lib/File/Spec.pm - lib/File/Temp.pm - lib/Filter/Simple.pm diff --git a/gnu/usr.bin/perl/NetWare/Makefile b/gnu/usr.bin/perl/NetWare/Makefile index 5bbc4565ef6..9d4fe795131 100644 --- a/gnu/usr.bin/perl/NetWare/Makefile +++ b/gnu/usr.bin/perl/NetWare/Makefile @@ -86,7 +86,7 @@ NLM_VERSION = 3,20,0 # Here comes the CW tools - TO BE FILLED TO BUILD WITH CW - -MODULE_DESC = "Perl 5.8.5 for NetWare" +MODULE_DESC = "Perl 5.8.6 for NetWare" CCTYPE = CodeWarrior C_COMPILER = mwccnlm -c CPP_COMPILER = mwccnlm @@ -467,7 +467,7 @@ INST_NW_TOP2 = $(INST_NW_DRV)\perl # versioned installation can be obtained by setting INST_TOP above to a # path that includes an arbitrary version string. # -INST_VER = \5.8.5 +INST_VER = \5.8.6 # # Comment this out if you DON'T want your perl installation to have diff --git a/gnu/usr.bin/perl/Porting/checkAUTHORS.pl b/gnu/usr.bin/perl/Porting/checkAUTHORS.pl new file mode 100755 index 00000000000..293b6cc2c5b --- /dev/null +++ b/gnu/usr.bin/perl/Porting/checkAUTHORS.pl @@ -0,0 +1,191 @@ +#!/usr/bin/perl -w +use strict; +use Text::Wrap; +$Text::Wrap::columns = 80; +my ($committer, $patch, $log); +use Getopt::Long; + +my ($rank, @authors, %authors, %untraced, %patchers); +my $result = GetOptions ("rank" => \$rank, # rank authors + "acknowledged=s" => \@authors); # authors files + +if (!$result or !($rank xor @authors) or !@ARGV) { + die <<"EOS"; +$0 --rank Changelogs # rank authors by patches +$0 --acknowledged <authors file> Changelogs # Display unacknowledged authors +Specify stdin as - if needs be. Remember that option names can be abbreviated. +EOS +} + +my %map = reverse ( + # "Correct" => "Alias" + adi => "enache\100rdslink.ro", + alanbur => "alan.burlison\100sun.com", + ams => "ams\100wiw.org", + chip => "chip\100pobox.com", + davem => "davem\100fdgroup.com", + doughera => " doughera\100lafayette.edu", + gbarr => "gbarr\100pobox.com", + gsar => "gsar\100activestate.com", + hv => "hv\100crypt.compulink.co.uk", + jhi => "jhi\100iki.fi", + merijn => "h.m.brand\100hccnet.nl", + mhx => "mhx-perl\100gmx.net", + nicholas => "nick\100unfortu.net", + nick => "nick\100ing-simmons.net", + pudge => "pudge\100pobox.com", + rgs => "rgarciasuarez\100free.fr", + sky => "sky\100nanisky.com", + "abigail\100abigail.nl"=> "abigail\100foad.org", + "chromatic\100wgz.org" => "chromatic\100rmci.net", + "slaven\100rezic.de" => "slaven.rezic\100berlin.de", + "mjtg\100cam.ac.uk" => "mjtg\100cus.cam.ac.uk", + "robin.barker\100npl.co.uk" => "rmb1\100cise.npl.co.uk", + "paul.marquess\100btinternet.com" + => "paul_marquess\100yahoo.co.uk", + "wolfgang.laun\100chello.at" => + "wolfgang.laun\100alcatel.at", + "t.jenness\100jach.hawaii.edu" => "timj\100jach.hawaii.edu", + "abe\100ztreet.demon.nl" => "abeltje\100cpan.org", + "perl_dummy\100bloodgate.com" => "tels\100bloodgate.com", + "jfriedl\100yahoo.com" => "jfriedl\100yahoo-inc.com", + "japhy\100pobox.com" => "japhy\100pobox.org", + "gellyfish\100gellyfish.com" => "jns\100gellyfish.com", + ); + +# Make sure these are all lower case. + +$map{"alan.burlison\100uk.sun.com"} = "alanbur"; +$map{"artur\100contiller.se"} = $map{"arthur\100contiller.se"} = "sky"; +$map{"autrijus\100egb.elixus.org"} = $map{"autrijus\100geb.elixus.org"} + = "autrijus\100autrijus.org"; +$map{"craig.berry\100psinetcs.com"} = $map{"craig.berry\100metamorgs.com"} + = $map{"craig.berry\100signaltreesolutions.com"} = "craigberry\100mac.com"; +$map{"davem\100fdgroup.co.uk"} = "davem"; +$map{"ilya\100math.ohio-state.edu"} = $map{"ilya\100math.berkeley.edu"} + = $map{"ilya\100math.berkeley.edu"} = "nospam-abuse\100ilyaz.org"; +$map{"jhi\100kosh.hut.fi"} = $map{"jhi\100cc.hut.fi"} = "jhi"; +$map{"nick\100ccl4.org"} = $map{"nick\100talking.bollo.cx"} + = $map{"nick\100plum.flirble.org"} = $map{"nick\100babyhippo.co.uk"} + = $map{"nick\100bagpuss.unfortu.net"} = "nicholas"; +$map{"philip.newton\100gmx.net"} = $map{"philip.newton\100datenrevision.de"} + = "pnewton\100gmx.de", +$map{"raphel.garcia-suarez\100hexaflux.com"} = "rgs"; +$map{"simon\100pembro4.pmb.ox.ac.uk"} = $map{"simon\100brecon.co.uk"} + = $map{"simon\100othersideofthe.earth.li"} = $map{"simon\100cozens.net"} + = $map{"simon\100netthink.co.uk"} = "simon\100simon-cozens.org"; +$map{"spider\100web.zk3.dec.com"} = $map{"spider\100leggy.zk3.dec.com"} + = $map{"spider-perl\100orb.nashua.nh.us"} + = $map{"spider\100peano.zk3.dec.com"} + = "spider\100orb.nashua.nh.us"; +$map{"nik\100tiuk.ti.com"} = "nick"; + +$map{"a.koenig\100mind.de"} = "andreas.koenig\100anima.de"; +$map{"japhy\100perlmonk.org"} = $map{"japhy\100cpan.org"} + = "japhy\100pobox.com"; +$map{"rmbarker\100cpan.org"} = "robin.barker\100npl.co.uk"; + +if (@authors) { + my %raw; + foreach my $filename (@authors) { + open FH, "<$filename" or die "Can't open $filename: $!"; + while (<FH>) { + next if /^\#/; + next if /^-- /; + if (/<([^>]+)>/) { + # Easy line. + $raw{$1}++; + } elsif (/^([-A-Za-z0-9 .\'À-ÖØöø-ÿ]+)[\t\n]/) { + # Name only + $untraced{$1}++; + } else { + chomp; + warn "Can't parse line '$_'"; + } + } + } + foreach (keys %raw) { + print "E-mail $_ occurs $raw{$_} times\n" if $raw{$_} > 1; + $_ = lc $_; + $authors{$map{$_} || $_}++; + } +} + +while (<>) { + next if /^-+/; + if (m!^\[\s+(\d+)\]\s+By:\s+(\S+)\s+on!) { + # new patch + my @new = ($1, $2); + &process ($committer, $patch, $log); + ($patch, $committer) = @new; + undef $log; + } elsif (s/^(\s+Log: )//) { + die "Duplicate Log:" if $log; + $log = $_; + my $prefix = " " x length $1; + LOG: while (<>) { + if (s/^$prefix//) { + $log .= $_; + } elsif (/^\s+Branch:/) { + last LOG; + } else { + die "Malformed log end with $_"; + } + } + } +} + +&process ($committer, $patch, $log); + +if ($rank) { + &display_ordered; +} elsif (%authors) { + my %missing; + foreach (sort keys %patchers) { + next if $authors{$_}; + # Sort by number of patches, then name. + $missing{$patchers{$_}}->{$_}++; + } + foreach my $patches (sort {$b <=> $a} keys %missing) { + print "$patches patch(es)\n"; + foreach my $author (sort keys %{$missing{$patches}}) { + print " $author\n"; + } + } +} + +sub display_ordered { + my @sorted; + while (my ($name, $count) = each %patchers) { + push @{$sorted[$count]}, $name; + } + + my $i = @sorted; + while (--$i) { + next unless $sorted[$i]; + print wrap ("$i:\t", "\t", join (" ", sort @{$sorted[$i]}), "\n"); + } +} + +sub process { + my ($committer, $patch, $log) = @_; + return unless $committer; + my @authors = $log =~ /From:.+\s+([^\@ \t\n]+\@[^\@ \t\n]+)/gm; + + if (@authors) { + foreach (@authors) { + s/^<//; + s/>$//; + $_ = lc $_; + $patchers{$map{$_} || $_}++; + } + # print "$patch: @authors\n"; + } else { + # print "$patch: $committer\n"; + # Not entirely fair as this means that the maint pumpking scores for + # everything intergrated that wasn't a third party patch in blead + $patchers{$committer}++; + } +} + + diff --git a/gnu/usr.bin/perl/README.epoc b/gnu/usr.bin/perl/README.epoc index aa744e389e9..5cfa4dfadf0 100644 --- a/gnu/usr.bin/perl/README.epoc +++ b/gnu/usr.bin/perl/README.epoc @@ -21,7 +21,7 @@ look alike environment for the EPOC OS. For more information look at: http://epocemx.sourceforge.net/ perl and epocemx runs on Epoc Release 5 machines: Psion 5mx, 5mx Pro, -Psion Revo, Psion Netbook and on the Ericson M128. It may run on Epoc +Psion Revo, Psion Netbook and on the Ericsson M128. It may run on Epoc Release 3 Hardware (Series 5 classic), too. For more information about this hardware please refer to http://www.psion.com/ diff --git a/gnu/usr.bin/perl/README.hpux b/gnu/usr.bin/perl/README.hpux index 29c2a98cb30..8f870067e81 100644 --- a/gnu/usr.bin/perl/README.hpux +++ b/gnu/usr.bin/perl/README.hpux @@ -18,19 +18,19 @@ As of application release September 2001, HP-UX 11.00 is shipped with perl-5.6.1 in /opt/perl. The first occurrence is on CD 5012-7954 and can be installed using - swinstall -s /cdrom perl + swinstall -s /cdrom perl assuming you have mounted that CD on /cdrom. In this version the following modules are installed: - ActivePerl::DocTools-0.04 HTML::Parser-3.19 XML::DOM-1.25 - Archive::Tar-0.072 HTML::Tagset-3.03 XML::Parser-2.27 - Compress::Zlib-1.08 MIME::Base64-2.11 XML::Simple-1.05 - Convert::ASN1-0.10 Net-1.07 XML::XPath-1.09 - Digest::MD5-2.11 PPM-2.1.5 XML::XSLT-0.32 - File::CounterFile-0.12 SOAP::Lite-0.46 libwww-perl-5.51 - Font::AFM-1.18 Storable-1.011 libxml-perl-0.07 - HTML-Tree-3.11 URI-1.11 perl-ldap-0.23 + ActivePerl::DocTools-0.04 HTML::Parser-3.19 XML::DOM-1.25 + Archive::Tar-0.072 HTML::Tagset-3.03 XML::Parser-2.27 + Compress::Zlib-1.08 MIME::Base64-2.11 XML::Simple-1.05 + Convert::ASN1-0.10 Net-1.07 XML::XPath-1.09 + Digest::MD5-2.11 PPM-2.1.5 XML::XSLT-0.32 + File::CounterFile-0.12 SOAP::Lite-0.46 libwww-perl-5.51 + Font::AFM-1.18 Storable-1.011 libxml-perl-0.07 + HTML-Tree-3.11 URI-1.11 perl-ldap-0.23 The build is a portable hppa-1.1 multithread build that supports large files compiled with gcc-2.9-hppa-991112 @@ -88,10 +88,23 @@ part of the output of the "model" command. The second column is the PA-RISC version and the third column is the exact chip type used. (Start browsing at the bottom to prevent confusion ;-) - # model - 9000/800/L1000-44 - # grep L1000-44 /usr/sam/lib/mo/sched.models - L1000-44 2.0 PA8500 + # model + 9000/800/L1000-44 + # grep L1000-44 /usr/sam/lib/mo/sched.models + L1000-44 2.0 PA8500 + +=head2 Portability Between PA-RISC Versions + +An executable compiled on a PA-RISC 2.0 platform will not execute on a +PA-RISC 1.1 platform, even if they are running the same version of +HP-UX. If you are building Perl on a PA-RISC 2.0 platform and want that +Perl to also run on a PA-RISC 1.1, the compiler flags +DAportable and ++DS32 should be used. + +It is no longer possible to compile PA-RISC 1.0 executables on either +the PA-RISC 1.1 or 2.0 platforms. The command-line flags are accepted, +but the resulting executable will not run when transferred to a PA-RISC +1.0 system. =head2 PA-RISC 1.0 @@ -99,8 +112,8 @@ The original version of PA-RISC, HP no longer sells any system with this chip. The following systems contained PA-RISC 1.0 chips: - 600, 635, 645, 808, 815, 822, 825, 832, 834, 835, 840, 842, 845, 850, - 852, 855, 860, 865, 870, 890 + 600, 635, 645, 808, 815, 822, 825, 832, 834, 835, 840, 842, 845, 850, + 852, 855, 860, 865, 870, 890 =head2 PA-RISC 1.1 @@ -109,16 +122,16 @@ system. The following systems contain with PA-RISC 1.1 chips: - 705, 710, 712, 715, 720, 722, 725, 728, 730, 735, 742, 743, 744, 745, - 747, 750, 755, 770, 777, 778, 779, 800, 801, 803, 806, 807, 809, 811, - 813, 816, 817, 819, 821, 826, 827, 829, 831, 837, 839, 841, 847, 849, - 851, 856, 857, 859, 867, 869, 877, 887, 891, 892, 897, A180, A180C, - B115, B120, B132L, B132L+, B160L, B180L, C100, C110, C115, C120, - C160L, D200, D210, D220, D230, D250, D260, D310, D320, D330, D350, - D360, D410, DX0, DX5, DXO, E25, E35, E45, E55, F10, F20, F30, G30, - G40, G50, G60, G70, H20, H30, H40, H50, H60, H70, I30, I40, I50, I60, - I70, J200, J210, J210XC, K100, K200, K210, K220, K230, K400, K410, - K420, S700i, S715, S744, S760, T500, T520 + 705, 710, 712, 715, 720, 722, 725, 728, 730, 735, 742, 743, 744, 745, + 747, 750, 755, 770, 777, 778, 779, 800, 801, 803, 806, 807, 809, 811, + 813, 816, 817, 819, 821, 826, 827, 829, 831, 837, 839, 841, 847, 849, + 851, 856, 857, 859, 867, 869, 877, 887, 891, 892, 897, A180, A180C, + B115, B120, B132L, B132L+, B160L, B180L, C100, C110, C115, C120, + C160L, D200, D210, D220, D230, D250, D260, D310, D320, D330, D350, + D360, D410, DX0, DX5, DXO, E25, E35, E45, E55, F10, F20, F30, G30, + G40, G50, G60, G70, H20, H30, H40, H50, H60, H70, I30, I40, I50, I60, + I70, J200, J210, J210XC, K100, K200, K210, K220, K230, K400, K410, + K420, S700i, S715, S744, S760, T500, T520 =head2 PA-RISC 2.0 @@ -128,72 +141,44 @@ The most recent upgrade to the PA-RISC design, it added support for As of the date of this document's last update, the following systems contain PA-RISC 2.0 chips: - 700, 780, 781, 782, 783, 785, 802, 804, 810, 820, 861, 871, 879, 889, - 893, 895, 896, 898, 899, A400, A500, B1000, B2000, C130, C140, C160, - C180, C180+, C180-XP, C200+, C400+, C3000, C360, C3600, CB260, D270, - D280, D370, D380, D390, D650, J220, J2240, J280, J282, J400, J410, - J5000, J5500XM, J5600, J7000, J7600, K250, K260, K260-EG, K270, K360, - K370, K380, K450, K460, K460-EG, K460-XP, K470, K570, K580, L1000, - L2000, L3000, N4000, R380, R390, SD16000, SD32000, SD64000, T540, - T600, V2000, V2200, V2250, V2500, V2600 + 700, 780, 781, 782, 783, 785, 802, 804, 810, 820, 861, 871, 879, 889, + 893, 895, 896, 898, 899, A400, A500, B1000, B2000, C130, C140, C160, + C180, C180+, C180-XP, C200+, C400+, C3000, C360, C3600, CB260, D270, + D280, D370, D380, D390, D650, J220, J2240, J280, J282, J400, J410, + J5000, J5500XM, J5600, J7000, J7600, K250, K260, K260-EG, K270, K360, + K370, K380, K450, K460, K460-EG, K460-XP, K470, K570, K580, L1000, + L2000, L3000, N4000, R380, R390, SD16000, SD32000, SD64000, T540, + T600, V2000, V2200, V2250, V2500, V2600 Just before HP took over Compaq, some systems were renamed. the link that contained the explanation is dead, so here's a short summary: - HP 9000 A-Class servers, now renamed HP Server rp2400 series. - HP 9000 L-Class servers, now renamed HP Server rp5400 series. - HP 9000 N-Class servers, now renamed HP Server rp7400. + HP 9000 A-Class servers, now renamed HP Server rp2400 series. + HP 9000 L-Class servers, now renamed HP Server rp5400 series. + HP 9000 N-Class servers, now renamed HP Server rp7400. - rp2400, rp2405, rp2430, rp2450, rp2470, rp3410, rp3440, rp5400, - rp5405, rp5430, rp5450, rp5470, rp7400, rp7405, rp7410, rp7420, - rp8400, rp8420, Superdome + rp2400, rp2405, rp2430, rp2450, rp2470, rp3410, rp3440, rp4440, + rp5400, rp5405, rp5430, rp5450, rp5470, rp7400, rp7405, rp7410, + rp7420, rp8400, rp8420, Superdome The current naming convention is: - aadddd - ||||`+- 00 - 99 relative capacity & newness (upgrades, etc.) - |||`--- unique number for each architecture to ensure different - ||| systems do not have the same numbering across - ||| architectures - ||`---- 1 - 9 identifies family and/or relative positioning - || - |`----- c = ia32 (cisc) - | p = pa-risc - | x = ia-64 (Itanium & Itanium 2) - | h = housing - `------ t = tower - r = rack optimized - s = super scalable - b = blade - sa = appliance - -=head2 Itanium & Itanium 2 - -HP also ships servers with the 128-bit Itanium processor(s). As of the -date of this document's last update, the following systems contain -Itanium or Itanium 2 chips (this is very likely to be out of date): - - rx1600, rx2600, rx2600hptc, rx4610, rx4640, rx5670, rx7620, rx8620, - rx9610 - -To see all about your machine, type - - # model - ia64 hp server rx2600 - # /usr/contrib/bin/machinfo - -=head2 Portability Between PA-RISC Versions - -An executable compiled on a PA-RISC 2.0 platform will not execute on a -PA-RISC 1.1 platform, even if they are running the same version of -HP-UX. If you are building Perl on a PA-RISC 2.0 platform and want that -Perl to also run on a PA-RISC 1.1, the compiler flags +DAportable and -+DS32 should be used. - -It is no longer possible to compile PA-RISC 1.0 executables on either -the PA-RISC 1.1 or 2.0 platforms. The command-line flags are accepted, -but the resulting executable will not run when transferred to a PA-RISC -1.0 system. + aadddd + ||||`+- 00 - 99 relative capacity & newness (upgrades, etc.) + |||`--- unique number for each architecture to ensure different + ||| systems do not have the same numbering across + ||| architectures + ||`---- 1 - 9 identifies family and/or relative positioning + || + |`----- c = ia32 (cisc) + | p = pa-risc + | x = ia-64 (Itanium & Itanium 2) + | h = housing + `------ t = tower + r = rack optimized + s = super scalable + b = blade + sa = appliance =head2 Itanium Processor Family and HP-UX @@ -207,6 +192,21 @@ attempt to use a PA-RISC version of Perl on an Itanium system. This is because shared libraries created on an Itanium system cannot be loaded while running a PA-RISC executable. +=head2 Itanium & Itanium 2 + +HP also ships servers with the 128-bit Itanium processor(s). As of the +date of this document's last update, the following systems contain +Itanium or Itanium 2 chips (this is very likely to be out of date): + + rx1600, rx2600, rx2600hptc, rx4610, rx4640, rx5670, rx7620, rx8620, + rx9610 + +To see all about your machine, type + + # model + ia64 hp server rx2600 + # /usr/contrib/bin/machinfo + =head2 Building Dynamic Extensions on HP-UX HP-UX supports dynamically loadable libraries (shared libraries). @@ -227,14 +227,14 @@ library cannot be loaded into an Itanium executable nor vice-versa. To create a shared library, the following steps must be performed: - 1. Compile source modules with +z or +Z flag to create a .o module - which contains Position-Independent Code (PIC). The linker will - tell you in the next step if +Z was needed. - (For gcc, the appropriate flag is -fpic or -fPIC.) + 1. Compile source modules with +z or +Z flag to create a .o module + which contains Position-Independent Code (PIC). The linker will + tell you in the next step if +Z was needed. + (For gcc, the appropriate flag is -fpic or -fPIC.) - 2. Link the shared library using the -b flag. If the code calls - any functions in other system libraries (e.g., libm), it must - be included on this line. + 2. Link the shared library using the -b flag. If the code calls + any functions in other system libraries (e.g., libm), it must + be included on this line. (Note that these steps are usually handled automatically by the extension's Makefile). @@ -273,32 +273,40 @@ error message should tell the name of the offending object file. A more general approach is to intervene manually, as with an example for the DB_File module, which requires SleepyCat's libdb.sl: - # cd .../db-3.2.9/build_unix - # vi Makefile - ... add +Z to all cflags to create shared objects - CFLAGS= -c $(CPPFLAGS) +Z -Ae +O2 +Onolimit \ - -I/usr/local/include -I/usr/include/X11R6 - CXXFLAGS= -c $(CPPFLAGS) +Z -Ae +O2 +Onolimit \ - -I/usr/local/include -I/usr/include/X11R6 - - # make clean - # make - # mkdir tmp - # cd tmp - # ar x ../libdb.a - # ld -b -o libdb-3.2.sl *.o - # mv libdb-3.2.sl /usr/local/lib - # rm *.o - # cd /usr/local/lib - # rm -f libdb.sl - # ln -s libdb-3.2.sl libdb.sl - - # cd .../DB_File-1.76 - # make distclean - # perl Makefile.PL - # make - # make test - # make install + # cd .../db-3.2.9/build_unix + # vi Makefile + ... add +Z to all cflags to create shared objects + CFLAGS= -c $(CPPFLAGS) +Z -Ae +O2 +Onolimit \ + -I/usr/local/include -I/usr/include/X11R6 + CXXFLAGS= -c $(CPPFLAGS) +Z -Ae +O2 +Onolimit \ + -I/usr/local/include -I/usr/include/X11R6 + + # make clean + # make + # mkdir tmp + # cd tmp + # ar x ../libdb.a + # ld -b -o libdb-3.2.sl *.o + # mv libdb-3.2.sl /usr/local/lib + # rm *.o + # cd /usr/local/lib + # rm -f libdb.sl + # ln -s libdb-3.2.sl libdb.sl + + # cd .../DB_File-1.76 + # make distclean + # perl Makefile.PL + # make + # make test + # make install + +As of db-4.2.x it is no longer needed to do this by hand. Sleepycat +has changed the configuration process to add +z on HP-UX automatically. + + # cd .../db-4.2.25/build_unix + # env CFLAGS=+DA2.0w LDFLAGS=+DA2.0w ../dist/configure + +should work to generate 64bit shared libraries for HP-UX 11.00 and 11i. It is no longer possible to link PA-RISC 1.0 shared libraries (even though the command-line flags are still present). @@ -497,16 +505,16 @@ perl sees it) is used. The problem is that C<//>, being a C++-style until-end-of-line comment, will disappear along with the remainder of the line. This means that common Perl constructs like - s/foo//; + s/foo//; will turn into illegal code - s/foo + s/foo The workaround is to use some other quoting separator than C<"/">, like for example C<"!">: - s!foo!!; + s!foo!!; =head2 HP-UX Kernel Parameters (maxdsiz) for Compiling Perl @@ -561,6 +569,6 @@ With much assistance regarding shared libraries from Marc Sabatella. =head1 DATE -Version 0.7.0: 2004-06-09 +Version 0.7.1: 2004-10-08 =cut diff --git a/gnu/usr.bin/perl/autodoc.pl b/gnu/usr.bin/perl/autodoc.pl index c87f114fc84..5e7b3c289d5 100644 --- a/gnu/usr.bin/perl/autodoc.pl +++ b/gnu/usr.bin/perl/autodoc.pl @@ -33,6 +33,7 @@ sub walk_table (&@) { else { safer_unlink $filename; open F, ">$filename" or die "Can't open $filename: $!"; + binmode F; $F = \*F; } print $F $leader if $leader; @@ -158,6 +159,7 @@ for $file (($MANIFEST =~ /^(\S+\.c)\t/gm), ($MANIFEST =~ /^(\S+\.h)\t/gm)) { safer_unlink "pod/perlapi.pod"; open (DOC, ">pod/perlapi.pod") or die "Can't create pod/perlapi.pod: $!\n"; +binmode DOC; walk_table { # load documented functions into approriate hash if (@_ > 1) { @@ -251,6 +253,7 @@ close(DOC) or die "Error closing pod/perlapi.pod: $!"; safer_unlink "pod/perlintern.pod"; open(GUTS, ">pod/perlintern.pod") or die "Unable to create pod/perlintern.pod: $!\n"; +binmode GUTS; print GUTS <<'END'; =head1 NAME diff --git a/gnu/usr.bin/perl/configure.com b/gnu/usr.bin/perl/configure.com index 24d3344589e..b01dca9268c 100644 --- a/gnu/usr.bin/perl/configure.com +++ b/gnu/usr.bin/perl/configure.com @@ -44,6 +44,7 @@ $ extra_flags = "" $ user_c_flags = "" $ use_ieee_math = "y" $ be_case_sensitive = "n" +$ unlink_all_versions = "n" $ use_vmsdebug_perl = "n" $ use64bitall = "n" $ use64bitint = "n" @@ -880,7 +881,7 @@ $ config_symbols0 ="|archlib|archlibexp|bin|binexp|builddir|cf_email|config_sh $ config_symbols1 ="|installprivlib|installscript|installsitearch|installsitelib|most|oldarchlib|oldarchlibexp|osname|pager|perl_symbol|perl_verb|" $ config_symbols2 ="|prefix|privlib|privlibexp|scriptdir|sitearch|sitearchexp|sitebin|sitelib|sitelib_stem|sitelibexp|try_cxx|use64bitall|use64bitint|" $ config_symbols3 ="|usecasesensitive|usedefaulttypes|usedevel|useieee|useithreads|usemultiplicity|usemymalloc|usedebugging_perl|useperlio|usesecurelog|" -$ config_symbols4 ="|usethreads|usevmsdebug|usefaststdio|usemallocwrap|" +$ config_symbols4 ="|usethreads|usevmsdebug|usefaststdio|usemallocwrap|unlink_all_versions|" $! $ open/read CONFIG 'config_sh' $ rd_conf_loop: @@ -2445,6 +2446,30 @@ $ useieee = "undef" $ usecasesensitive = "undef" $ if (use_ieee_math) then useieee = "define" $ if (be_case_sensitive) then usecasesensitive = "define" +$! Unlink all versions? +$ echo "" +$ echo "By default, Perl's unlink() provides VMS-like behavior and only" +$ echo "deletes the latest version of a file. Enabling this option builds" +$ echo "Perl so that unlink() deletes all versions of a file." +$ bool_dflt = unlink_all_versions +$ if f$type(unlink_all_versions) .nes. "" +$ then +$ if unlink_all_versions .or. unlink_all_versions .eqs. "define" +$ then +$ bool_dflt="y" +$ else +$ bool_dflt="n" +$ endif +$ endif +$ rp = "Make unlink() delete all versions of a file? [''bool_dflt'] " +$ GOSUB myread +$ unlink_all_versions = ans +$ IF unlink_all_versions +$ THEN +$ d_unlink_all_versions = "define" +$ ELSE +$ d_unlink_all_versions = "undef" +$ ENDIF $! CC Flags $ echo "" $ echo "Your compiler may want other flags. For this question you should include" @@ -5594,7 +5619,7 @@ $ WC "d_ualarm='" + d_ualarm + "'" $ WC "d_umask='define'" $ WC "d_uname='" + d_uname + "'" $ WC "d_union_semun='undef'" -$ WC "d_unlink_all_versions='undef'" +$ WC "d_unlink_all_versions='" + d_unlink_all_versions + "'" ! VMS-specific $ WC "d_unordered='undef'" $ WC "d_usleep='" + d_usleep + "'" $ WC "d_usleepproto='" + d_usleep + "'" @@ -6166,6 +6191,8 @@ $! Alas this does not help to build Fcntl $! WC "#define PERL_IGNORE_FPUSIG SIGFPE" $ ENDIF $ IF kill_by_sigprc .EQS. "define" then WC "#define KILL_BY_SIGPRC" +$ IF unlink_all_versions .OR. unlink_all_versions .EQS. "define" THEN - + WC "#define UNLINK_ALL_VERSIONS" $ CLOSE CONFIG $! $ echo4 "Doing variable substitutions on .SH files..." diff --git a/gnu/usr.bin/perl/embed.fnc b/gnu/usr.bin/perl/embed.fnc index 0e60a2928e7..0f7d0f05a65 100644 --- a/gnu/usr.bin/perl/embed.fnc +++ b/gnu/usr.bin/perl/embed.fnc @@ -731,7 +731,7 @@ pd |void |sv_add_arena |char* ptr|U32 size|U32 flags Apd |int |sv_backoff |SV* sv Apd |SV* |sv_bless |SV* sv|HV* stash Afpd |void |sv_catpvf |SV* sv|const char* pat|... -Ap |void |sv_vcatpvf |SV* sv|const char* pat|va_list* args +Apd |void |sv_vcatpvf |SV* sv|const char* pat|va_list* args Apd |void |sv_catpv |SV* sv|const char* ptr Amdb |void |sv_catpvn |SV* sv|const char* ptr|STRLEN len Amdb |void |sv_catsv |SV* dsv|SV* ssv @@ -782,7 +782,7 @@ Apd |void |sv_replace |SV* sv|SV* nsv Apd |void |sv_report_used Apd |void |sv_reset |char* s|HV* stash Afpd |void |sv_setpvf |SV* sv|const char* pat|... -Ap |void |sv_vsetpvf |SV* sv|const char* pat|va_list* args +Apd |void |sv_vsetpvf |SV* sv|const char* pat|va_list* args Apd |void |sv_setiv |SV* sv|IV num Apdb |void |sv_setpviv |SV* sv|IV num Apd |void |sv_setuv |SV* sv|UV num @@ -891,12 +891,12 @@ Ap |int |runops_debug Ap |SV* |sv_lock |SV *sv #endif Afpd |void |sv_catpvf_mg |SV *sv|const char* pat|... -Ap |void |sv_vcatpvf_mg |SV* sv|const char* pat|va_list* args +Apd |void |sv_vcatpvf_mg |SV* sv|const char* pat|va_list* args Apd |void |sv_catpv_mg |SV *sv|const char *ptr Apd |void |sv_catpvn_mg |SV *sv|const char *ptr|STRLEN len Apd |void |sv_catsv_mg |SV *dstr|SV *sstr Afpd |void |sv_setpvf_mg |SV *sv|const char* pat|... -Ap |void |sv_vsetpvf_mg |SV* sv|const char* pat|va_list* args +Apd |void |sv_vsetpvf_mg |SV* sv|const char* pat|va_list* args Apd |void |sv_setiv_mg |SV *sv|IV i Apdb |void |sv_setpviv_mg |SV *sv|IV iv Apd |void |sv_setuv_mg |SV *sv|UV u @@ -1422,4 +1422,7 @@ sM |HE* |hv_fetch_common|HV* tb|SV* key_sv|const char* key|STRLEN klen|int flags Apd |SV* |hv_scalar |HV* hv| p |SV* |magic_scalarpack|HV* hv|MAGIC* mg +#if defined(DEBUGGING) +p |int |get_debug_opts_flags |char **s|int flags +#endif END_EXTERN_C diff --git a/gnu/usr.bin/perl/embedvar.h b/gnu/usr.bin/perl/embedvar.h index bf2f58acbe1..8f485933fe7 100644 --- a/gnu/usr.bin/perl/embedvar.h +++ b/gnu/usr.bin/perl/embedvar.h @@ -1445,6 +1445,7 @@ #define PL_sigfpe_saved (PL_Vars.Gsigfpe_saved) #define PL_sv_placeholder (PL_Vars.Gsv_placeholder) #define PL_thr_key (PL_Vars.Gthr_key) +#define PL_use_safe_putenv (PL_Vars.Guse_safe_putenv) #else /* !PERL_GLOBAL_STRUCT */ @@ -1462,6 +1463,7 @@ #define PL_Gsigfpe_saved PL_sigfpe_saved #define PL_Gsv_placeholder PL_sv_placeholder #define PL_Gthr_key PL_thr_key +#define PL_Guse_safe_putenv PL_use_safe_putenv #endif /* PERL_GLOBAL_STRUCT */ diff --git a/gnu/usr.bin/perl/epoc/createpkg.pl b/gnu/usr.bin/perl/epoc/createpkg.pl index ce96115af62..90718e158e0 100644 --- a/gnu/usr.bin/perl/epoc/createpkg.pl +++ b/gnu/usr.bin/perl/epoc/createpkg.pl @@ -3,7 +3,7 @@ use File::Find; use Cwd; -$VERSION="5.8.5"; +$VERSION="5.8.6"; $EPOC_VERSION=1; diff --git a/gnu/usr.bin/perl/ext/B/B.pm b/gnu/usr.bin/perl/ext/B/B.pm index 8a1a2fe821d..bd6a60ad076 100644 --- a/gnu/usr.bin/perl/ext/B/B.pm +++ b/gnu/usr.bin/perl/ext/B/B.pm @@ -7,7 +7,7 @@ # package B; -our $VERSION = '1.02'; +our $VERSION = '1.07'; use XSLoader (); require Exporter; @@ -36,7 +36,8 @@ use strict; @B::PVIV::ISA = qw(B::PV B::IV); @B::PVNV::ISA = qw(B::PV B::NV); @B::PVMG::ISA = 'B::PVNV'; -@B::PVLV::ISA = 'B::PVMG'; +# Change in the inheritance hierarchy post 5.8 +@B::PVLV::ISA = $] > 5.009 ? 'B::GV' : 'B::PVMG'; @B::BM::ISA = 'B::PVMG'; @B::AV::ISA = 'B::PVMG'; @B::GV::ISA = 'B::PVMG'; @@ -177,7 +178,7 @@ sub walkoptree_exec { $op->$method($level); $ppname = $op->name; if ($ppname =~ - /^(or(assign)?|and(assign)?|mapwhile|grepwhile|entertry|range|cond_expr)$/) + /^(d?or(assign)?|and(assign)?|mapwhile|grepwhile|entertry|range|cond_expr)$/) { print $prefix, uc($1), " => {\n"; walkoptree_exec($op->other, $method, $level + 1); @@ -341,7 +342,7 @@ get an initial "handle" on an internal object. =head2 Functions Returning C<B::SV>, C<B::AV>, C<B::HV>, and C<B::CV> objects -For descriptions of the class hierachy of these objects and the +For descriptions of the class hierarchy of these objects and the methods that can be called on them, see below, L<"OVERVIEW OF CLASSES"> and L<"SV-RELATED CLASSES">. @@ -429,7 +430,7 @@ Methods">, below. =head2 Functions Returning C<B::OP> objects or for walking op trees -For descriptions of the class hierachy of these objects and the +For descriptions of the class hierarchy of these objects and the methods that can be called on them, see below, L<"OVERVIEW OF CLASSES"> and L<"OP-RELATED CLASSES">. @@ -529,7 +530,8 @@ using this module. B::IV, B::NV, B::RV, B::PV, B::PVIV, B::PVNV, B::PVMG, B::BM, B::PVLV, B::AV, B::HV, B::CV, B::GV, B::FM, B::IO. These classes correspond in the obvious way to the underlying C structures of similar names. The -inheritance hierarchy mimics the underlying C "inheritance": +inheritance hierarchy mimics the underlying C "inheritance". For 5.9 and +later this is: B::SV | @@ -547,6 +549,20 @@ inheritance hierarchy mimics the underlying C "inheritance": | B::PVMG | + +-----+----+------+-----+-----+ + | | | | | | + B::BM B::AV B::GV B::HV B::CV B::IO + | | + B::PVLV | + B::FM + + +For 5.8 and earlier, PVLV is a direct subclass of PVMG, so the base of this +diagram is + + | + B::PVMG + | +------+-----+----+------+-----+-----+ | | | | | | | B::PVLV B::BM B::AV B::GV B::HV B::CV B::IO @@ -920,6 +936,9 @@ with the leading "class indication" prefix (C<"op_">) removed. =head2 B::OP Methods +These methods get the values of similarly named fields within the OP +data structure. See top of C<op.h> for more info. + =over 4 =item next @@ -944,12 +963,16 @@ This returns the op description from the global C PL_op_desc array =item type -=item seq +=item opt + +=item static =item flags =item private +=item spare + =back =head2 B::UNOP METHOD diff --git a/gnu/usr.bin/perl/ext/B/B.xs b/gnu/usr.bin/perl/ext/B/B.xs index 1dad6c083d4..63f5a99fa3c 100644 --- a/gnu/usr.bin/perl/ext/B/B.xs +++ b/gnu/usr.bin/perl/ext/B/B.xs @@ -29,11 +29,16 @@ static char *svclassnames[] = { "B::PVNV", "B::PVMG", "B::BM", +#if PERL_VERSION >= 9 + "B::GV", +#endif "B::PVLV", "B::AV", "B::HV", "B::CV", +#if PERL_VERSION <= 8 "B::GV", +#endif "B::FM", "B::IO", }; @@ -416,9 +421,15 @@ oplist(pTHX_ OP *o, SV **SP) { for(; o; o = o->op_next) { SV *opsv; - if (o->op_seq == 0) +#if PERL_VERSION >= 9 + if (o->op_opt == 0) + break; + o->op_opt = 0; +#else + if (o->op_seq == 0) break; o->op_seq = 0; +#endif opsv = sv_newmortal(); sv_setiv(newSVrv(opsv, cc_opclassname(aTHX_ (OP*)o)), PTR2IV(o)); XPUSHs(opsv); @@ -494,6 +505,9 @@ BOOT: specialsv_list[4] = pWARN_ALL; specialsv_list[5] = pWARN_NONE; specialsv_list[6] = pWARN_STD; +#if PERL_VERSION <= 8 +# define CVf_ASSERTION 0 +#endif #include "defsubs.h" } @@ -707,24 +721,31 @@ cchar(sv) void threadsv_names() PPCODE: -#ifdef USE_5005THREADS +#if PERL_VERSION <= 8 +# ifdef USE_5005THREADS int i; STRLEN len = strlen(PL_threadsv_names); EXTEND(sp, len); for (i = 0; i < len; i++) PUSHs(sv_2mortal(newSVpvn(&PL_threadsv_names[i], 1))); +# endif #endif - #define OP_next(o) o->op_next #define OP_sibling(o) o->op_sibling #define OP_desc(o) PL_op_desc[o->op_type] #define OP_targ(o) o->op_targ #define OP_type(o) o->op_type -#define OP_seq(o) o->op_seq +#if PERL_VERSION >= 9 +# define OP_opt(o) o->op_opt +# define OP_static(o) o->op_static +#else +# define OP_seq(o) o->op_seq +#endif #define OP_flags(o) o->op_flags #define OP_private(o) o->op_private +#define OP_spare(o) o->op_spare MODULE = B PACKAGE = B::OP PREFIX = OP_ @@ -779,10 +800,24 @@ U16 OP_type(o) B::OP o +#if PERL_VERSION >= 9 + +U8 +OP_opt(o) + B::OP o + +U8 +OP_static(o) + B::OP o + +#else + U16 OP_seq(o) B::OP o +#endif + U8 OP_flags(o) B::OP o @@ -791,6 +826,14 @@ U8 OP_private(o) B::OP o +#if PERL_VERSION >= 9 + +U8 +OP_spare(o) + B::OP o + +#endif + void OP_oplist(o) B::OP o diff --git a/gnu/usr.bin/perl/ext/B/B/Showlex.pm b/gnu/usr.bin/perl/ext/B/B/Showlex.pm index 0140c8ac519..3b261a337df 100644 --- a/gnu/usr.bin/perl/ext/B/B/Showlex.pm +++ b/gnu/usr.bin/perl/ext/B/B/Showlex.pm @@ -1,10 +1,11 @@ package B::Showlex; -our $VERSION = '1.00'; +our $VERSION = '1.02'; use strict; use B qw(svref_2object comppadlist class); use B::Terse (); +use B::Concise (); # # Invoke as @@ -13,21 +14,32 @@ use B::Terse (); # or as # perl -MO=Showlex bar.pl # to see the names of file scope lexicals used by bar.pl -# +# + + +# borrowed from B::Concise +our $walkHandle = \*STDOUT; + +sub walk_output { # updates $walkHandle + $walkHandle = B::Concise::walk_output(@_); + #print "got $walkHandle"; + #print $walkHandle "using it"; + $walkHandle; +} sub shownamearray { my ($name, $av) = @_; my @els = $av->ARRAY; my $count = @els; my $i; - print "$name has $count entries\n"; + print $walkHandle "$name has $count entries\n"; for ($i = 0; $i < $count; $i++) { - print "$i: "; my $sv = $els[$i]; if (class($sv) ne "SPECIAL") { - printf "%s (0x%lx) %s\n", class($sv), $$sv, $sv->PVX; + printf $walkHandle "$i: %s (0x%lx) %s\n", class($sv), $$sv, $sv->PVX; } else { - $sv->terse; + printf $walkHandle "$i: %s\n", $sv->terse; + #printf $walkHandle "$i: %s\n", B::Concise::concise_sv($sv); } } } @@ -37,10 +49,10 @@ sub showvaluearray { my @els = $av->ARRAY; my $count = @els; my $i; - print "$name has $count entries\n"; + print $walkHandle "$name has $count entries\n"; for ($i = 0; $i < $count; $i++) { - print "$i: "; - $els[$i]->terse; + printf $walkHandle "$i: %s\n", $els[$i]->terse; + #print $walkHandle "$i: %s\n", B::Concise::concise_sv($els[$i]); } } @@ -50,28 +62,60 @@ sub showlex { showvaluearray("Pad of lexical values for $objname", $valsav); } +my ($newlex, $nosp1); # rendering state vars + +sub newlex { # drop-in for showlex + my ($objname, $names, $vals) = @_; + my @names = $names->ARRAY; + my @vals = $vals->ARRAY; + my $count = @names; + print $walkHandle "$objname Pad has $count entries\n"; + printf $walkHandle "0: %s\n", $names[0]->terse unless $nosp1; + for (my $i = 1; $i < $count; $i++) { + printf $walkHandle "$i: %s = %s\n", $names[$i]->terse, $vals[$i]->terse + unless $nosp1 and $names[$i]->terse =~ /SPECIAL/; + } +} + sub showlex_obj { my ($objname, $obj) = @_; $objname =~ s/^&main::/&/; - showlex($objname, svref_2object($obj)->PADLIST->ARRAY); + showlex($objname, svref_2object($obj)->PADLIST->ARRAY) if !$newlex; + newlex ($objname, svref_2object($obj)->PADLIST->ARRAY) if $newlex; } sub showlex_main { - showlex("comppadlist", comppadlist->ARRAY); + showlex("comppadlist", comppadlist->ARRAY) if !$newlex; + newlex ("main", comppadlist->ARRAY) if $newlex; } sub compile { - my @options = @_; - if (@options) { - return sub { - my $objname; - foreach $objname (@options) { + my @options = grep(/^-/, @_); + my @args = grep(!/^-/, @_); + for my $o (@options) { + $newlex = 1 if $o eq "-newlex"; + $nosp1 = 1 if $o eq "-nosp"; + } + + return \&showlex_main unless @args; + return sub { + my $objref; + foreach my $objname (@args) { + next unless $objname; # skip nulls w/o carping + + if (ref $objname) { + print $walkHandle "B::Showlex::compile($objname)\n"; + $objref = $objname; + } else { $objname = "main::$objname" unless $objname =~ /::/; - eval "showlex_obj('&$objname', \\&$objname)"; + print $walkHandle "$objname:\n"; + no strict 'refs'; + die "err: unknown function ($objname)\n" + unless *{$objname}{CODE}; + $objref = \&$objname; } + showlex_obj($objname, $objref); } - } else { - return \&showlex_main; } } @@ -85,13 +129,74 @@ B::Showlex - Show lexical variables used in functions or files =head1 SYNOPSIS - perl -MO=Showlex[,SUBROUTINE] foo.pl + perl -MO=Showlex[,-OPTIONS][,SUBROUTINE] foo.pl =head1 DESCRIPTION -When a subroutine name is provided in OPTIONS, prints the lexical -variables used in that subroutine. Otherwise, prints the file-scope -lexicals in the file. +When a comma-separated list of subroutine names is given as options, Showlex +prints the lexical variables used in those subroutines. Otherwise, it prints +the file-scope lexicals in the file. + +=head1 EXAMPLES + +Traditional form: + + $ perl -MO=Showlex -e 'my ($i,$j,$k)=(1,"foo")' + Pad of lexical names for comppadlist has 4 entries + 0: SPECIAL #1 &PL_sv_undef + 1: PVNV (0x9db0fb0) $i + 2: PVNV (0x9db0f38) $j + 3: PVNV (0x9db0f50) $k + Pad of lexical values for comppadlist has 5 entries + 0: SPECIAL #1 &PL_sv_undef + 1: NULL (0x9da4234) + 2: NULL (0x9db0f2c) + 3: NULL (0x9db0f44) + 4: NULL (0x9da4264) + -e syntax OK + +New-style form: + + $ perl -MO=Showlex,-newlex -e 'my ($i,$j,$k)=(1,"foo")' + main Pad has 4 entries + 0: SPECIAL #1 &PL_sv_undef + 1: PVNV (0xa0c4fb8) "$i" = NULL (0xa0b8234) + 2: PVNV (0xa0c4f40) "$j" = NULL (0xa0c4f34) + 3: PVNV (0xa0c4f58) "$k" = NULL (0xa0c4f4c) + -e syntax OK + +New form, no specials, outside O framework: + + $ perl -MB::Showlex -e \ + 'my ($i,$j,$k)=(1,"foo"); B::Showlex::compile(-newlex,-nosp)->()' + main Pad has 4 entries + 1: PVNV (0x998ffb0) "$i" = IV (0x9983234) 1 + 2: PVNV (0x998ff68) "$j" = PV (0x998ff5c) "foo" + 3: PVNV (0x998ff80) "$k" = NULL (0x998ff74) + +Note that this example shows the values of the lexicals, whereas the other +examples did not (as they're compile-time only). + +=head2 OPTIONS + +The C<-newlex> option produces a more readable C<< name => value >> format, +and is shown in the second example above. + +The C<-nosp> option eliminates reporting of SPECIALs, such as C<0: SPECIAL +#1 &PL_sv_undef> above. Reporting of SPECIALs can sometimes overwhelm +your declared lexicals. + +=head1 SEE ALSO + +C<B::Showlex> can also be used outside of the O framework, as in the third +example. See C<B::Concise> for a fuller explanation of reasons. + +=head1 TODO + +Some of the reported info, such as hex addresses, is not particularly +valuable. Other information would be more useful for the typical +programmer, such as line-numbers, pad-slot reuses, etc.. Given this, +-newlex isnt a particularly good flag-name. =head1 AUTHOR diff --git a/gnu/usr.bin/perl/ext/B/B/Terse.pm b/gnu/usr.bin/perl/ext/B/B/Terse.pm index 401dfc2668c..8d295cdd714 100644 --- a/gnu/usr.bin/perl/ext/B/B/Terse.pm +++ b/gnu/usr.bin/perl/ext/B/B/Terse.pm @@ -16,7 +16,6 @@ sub terse { } else { concise_subref('basic', $subref); } - } sub compile { @@ -28,7 +27,7 @@ sub compile { } sub indent { - my $level = @_ ? shift : 0; + my ($level) = @_ ? shift : 0; return " " x $level; } @@ -43,20 +42,27 @@ sub B::SV::terse { my($sv, $level) = (@_, 0); my %info; B::Concise::concise_sv($sv, \%info); - my $s = B::Concise::fmt_line(\%info, "#svclass~(?((#svaddr))?)~#svval", 0); - print indent($level), $s, "\n"; + my $s = indent($level) + . B::Concise::fmt_line(\%info, $sv, + "#svclass~(?((#svaddr))?)~#svval", 0); + chomp $s; + print "$s\n" unless defined wantarray; + $s; } sub B::NULL::terse { my ($sv, $level) = @_; - print indent($level); - printf "%s (0x%lx)\n", class($sv), $$sv; + my $s = indent($level) . sprintf "%s (0x%lx)", class($sv), $$sv; + print "$s\n" unless defined wantarray; + $s; } sub B::SPECIAL::terse { my ($sv, $level) = @_; - print indent($level); - printf "%s #%d %s\n", class($sv), $$sv, $specialsv_name[$$sv]; + my $s = indent($level) + . sprintf( "%s #%d %s", class($sv), $$sv, $specialsv_name[$$sv]); + print "$s\n" unless defined wantarray; + $s; } 1; diff --git a/gnu/usr.bin/perl/ext/B/defsubs_h.PL b/gnu/usr.bin/perl/ext/B/defsubs_h.PL index 46b91072dbd..6e9f3062960 100644 --- a/gnu/usr.bin/perl/ext/B/defsubs_h.PL +++ b/gnu/usr.bin/perl/ext/B/defsubs_h.PL @@ -15,6 +15,7 @@ END foreach my $const (qw( AVf_REAL CVf_ANON + CVf_ASSERTION CVf_CLONE CVf_CLONED CVf_CONST diff --git a/gnu/usr.bin/perl/ext/B/t/OptreeCheck.pm b/gnu/usr.bin/perl/ext/B/t/OptreeCheck.pm new file mode 100644 index 00000000000..f8e2995346a --- /dev/null +++ b/gnu/usr.bin/perl/ext/B/t/OptreeCheck.pm @@ -0,0 +1,777 @@ +# non-package OptreeCheck.pm +# pm allows 'use OptreeCheck', which also imports +# no package decl means all functions defined into main +# otherwise, it's like "require './test.pl'" + +=head1 NAME + +OptreeCheck - check optrees as rendered by B::Concise + +=head1 SYNOPSIS + +OptreeCheck supports regression testing of perl's parser, optimizer, +bytecode generator, via a single function: checkOptree(%args). It +invokes B::Concise upon sample code, and checks that it 'agrees' with +reference renderings. + + checkOptree ( + name => "test-name', # optional, (synth from others) + + # 2 kinds of code-under-test: must provide 1 + code => sub {my $a}, # coderef, or source (wrapped and evald) + prog => 'sort @a', # run in subprocess, aka -MO=Concise + + bcopts => '-exec', # $opt or \@opts, passed to BC::compile + # errs => '.*', # match against any emitted errs, -w warnings + # skip => 1, # skips test + # todo => 'excuse', # anticipated failures + # fail => 1 # force fail (by redirecting result) + # debug => 1, # turns on regex debug for match test !! + # retry => 1 # retry with debug on test failure + + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT' ); + # 1 <;> nextstate(main 45 optree.t:23) v + # 2 <0> padsv[$a:45,46] M/LVINTRO + # 3 <1> leavesub[1 ref] K/REFC,1 + EOT_EOT + # 1 <;> nextstate(main 45 optree.t:23) v + # 2 <0> padsv[$a:45,46] M/LVINTRO + # 3 <1> leavesub[1 ref] K/REFC,1 + EONT_EONT + +=head1 checkOptree(%in) Overview + +optreeCheck() calls getRendering(), which runs code or prog through +B::Concise, and captures its rendering. + +It then calls mkCheckRex() to produce a regex which will match the +expected rendering, and fail when it doesn't match. + +Finally, it compares the 2; like($rendering,/$regex/,$testname). + + +=head1 checkOptree(%Args) API + +Accepts %Args, with following requirements and actions: + +Either code or prog must be present. prog is some source code, and is +passed through via test.pl:runperl, to B::Concise like this: (bcopts +are fixed up for cmdline) + + './perl -w -MO=Concise,$bcopts_massaged -e $src' + +code is a subref, or $src, like above. If it's not a subref, it's +treated like source-code, is wrapped as a subroutine, and is passed to +B::Concise::compile(). + + $subref = eval "sub{$src}"; + B::Concise::compile($subref). + +expect and expect_nt are the reference optree renderings. Theyre +required, except when the code/prog compilation fails. + +I suppose I should also explain these more, but they seem obvious. + + # prog => 'sort @a', # run in subprocess, aka -MO=Concise + # noanchors => 1, # no /^$/. needed for 1-liners like above + + # skip => 1, # skips test + # todo => 'excuse', # anticipated failures + # fail => 1 # fails (by redirecting result) + # debug => 1, # turns on regex debug for match test !! + # retry => 1 # retry with debug on test failure + +=head1 Test Philosophy + +2 platforms --> 2 reftexts: You want an accurate test, independent of +which platform you're on. So, two refdata properties, 'expect' and +'expect_nt', carry renderings taken from threaded and non-threaded +builds. This has several benefits: + + 1. native reference data allows closer matching by regex. + 2. samples can be eyeballed to grok t-nt differences. + 3. data can help to validate mkCheckRex() operation. + 4. can develop regexes which accomodate t-nt differences. + 5. can test with both native and cross+converted regexes. + +Cross-testing (expect_nt on threaded, expect on non-threaded) exposes +differences in B::Concise output, so mkCheckRex has code to do some +cross-test manipulations. This area needs more work. + +=head1 Test Modes + +One consequence of a single-function API is difficulty controlling +test-mode. Ive chosen for now to use a package hash, %gOpts, to store +test-state. These properties alter checkOptree() function, either +short-circuiting to selftest, or running a loop that runs the testcase +2^N times, varying conditions each time. (current N is 2 only). + +So Test-mode is controlled with cmdline args, also called options below. +Run with 'help' to see the test-state, and how to change it. + +=head2 selftest + +This argument invokes runSelftest(), which tests a regex against the +reference renderings that they're made from. Failure of a regex match +its 'mold' is a strong indicator that mkCheckRex is buggy. + +That said, selftest mode currently runs a cross-test too, they're not +completely orthogonal yet. See below. + +=head2 testmode=cross + +Cross-testing is purposely creating a T-NT mismatch, looking at the +fallout, and tweaking the regex to deal with it. Thus tests lead to +'provably' complete understanding of the differences. + +The tweaking appears contrary to the 2-refs philosophy, but the tweaks +will be made in conversion-specific code, which (will) handles T->NT +and NT->T separately. The tweaking is incomplete. + +A reasonable 1st step is to add tags to indicate when TonNT or NTonT +is known to fail. This needs an option to force failure, so the +test.pl reporting mechanics show results to aid the user. + +=head2 testmode=native + +This is normal mode. Other valid values are: native, cross, both. + +=head2 checkOptree Notes + +Accepts test code, renders its optree using B::Concise, and matches that +rendering against a regex built from one of 2 reference-renderings %in data. + +The regex is built by mkCheckRex(\%in), which scrubs %in data to +remove match-irrelevancies, such as (args) and [args]. For example, +it strips leading '# ', making it easy to cut-paste new tests into +your test-file, run it, and cut-paste actual results into place. You +then retest and reedit until all 'errors' are gone. (now make sure you +haven't 'enshrined' a bug). + +name: The test name. May be augmented by a label, which is built from +important params, and which helps keep names in sync with whats being +tested.' + +=cut + +use Config; +use Carp; +use B::Concise qw(walk_output); +use Data::Dumper; +$Data::Dumper::Sortkeys = 1; + +BEGIN { + $SIG{__WARN__} = sub { + my $err = shift; + $err =~ m/Subroutine re::(un)?install redefined/ and return; + }; +} + +# but wait - more skullduggery ! +sub OptreeCheck::import { &getCmdLine; } # process @ARGV + +# %gOpts params comprise a global test-state. Initial values here are +# HELP strings, they MUST BE REPLACED by runtime values before use, as +# is done by getCmdLine(), via import + +our %gOpts = # values are replaced at runtime !! + ( + # scalar values are help string + rextract => 'writes src-code todo same Optree matching', + vbasic => 'prints $str and $rex', + retry => 'retry failures after turning on re debug', + retrydbg => 'retry failures after turning on re debug', + selftest => 'self-tests mkCheckRex vs the reference rendering', + selfdbg => 'redo failing selftests with re debug', + xtest => 'extended thread/non-thread testing', + fail => 'force all test to fail, print to stdout', + dump => 'dump cmdline arg prcessing', + rexpedant => 'try tighter regex, still buggy', + noanchors => 'dont anchor match rex', + help => 0, # 1 ends in die + + # array values are one-of selections, with 1st value as default + testmode => [qw/ native cross both /], + + # fixup for VMS, cygwin, which dont have stderr b4 stdout + # 2nd value is used as help-str, 1st val (still) default + + rxnoorder => [1, 'if 1, dont req match on -e lines, and -banner',0], + strip => [1, 'if 1, catch errs and remove from renderings',0], + stripv => 'if strip&&1, be verbose about it', + errs => 'expected compile errs', + ); + + +# Not sure if this is too much cheating. Officially we say that +# $Config::Config{usethreads} is true if some sort of threading is in use, +# in which case we ought to be able to use it in place of the || below. +# However, it is now possible to Configure perl with "threads" but neither +# ithreads or 5005threads, which forces the re-entrant APIs, but no perl +# user visible threading. This seems to have the side effect that most of perl +# doesn't think that it's threaded, hence the ops aren't threaded either. +# Not sure if this is actually a "supported" configuration, but given that +# ponie uses it, it's going to be used by something official at least in the +# interim. So it's nice for tests to all pass. +our $threaded = 1 + if $Config::Config{useithreads} || $Config::Config{use5005threads}; +our $platform = ($threaded) ? "threaded" : "plain"; +our $thrstat = ($threaded) ? "threaded" : "nonthreaded"; + +our ($MatchRetry,$MatchRetryDebug); # let mylike be generic +# test.pl-ish hack +*MatchRetry = \$gOpts{retry}; # but alias it into %gOpts +*MatchRetryDebug = \$gOpts{retrydbg}; # but alias it into %gOpts + +our %modes = ( + both => [ 'expect', 'expect_nt'], + native => [ ($threaded) ? 'expect' : 'expect_nt'], + cross => [ !($threaded) ? 'expect' : 'expect_nt'], + expect => [ 'expect' ], + expect_nt => [ 'expect_nt' ], + ); + +our %msgs # announce cross-testing. + = ( + # cross-platform + 'expect_nt-threaded' => " (Non-threaded-ref on Threaded-build)", + 'expect-nonthreaded' => " (Threaded-ref on Non-threaded-build)", + # native - nothing to say + 'expect_nt-nonthreaded' => '', + 'expect-threaded' => '', + ); + +####### +sub getCmdLine { # import assistant + # offer help + print(qq{\n$0 accepts args to update these state-vars: + turn on a flag by typing its name, + select a value from list by typing name=val.\n }, + Dumper \%gOpts) + if grep /help/, @ARGV; + + # replace values for each key !! MUST MARK UP %gOpts + foreach my $opt (keys %gOpts) { + + # scan ARGV for known params + if (ref $gOpts{$opt} eq 'ARRAY') { + + # $opt is a One-Of construct + # replace with valid selection from the list + + # uhh this WORKS. but it's inscrutable + # grep s/$opt=(\w+)/grep {$_ eq $1} @ARGV and $gOpts{$opt}=$1/e, @ARGV; + my $tval; # temp + if (grep s/$opt=(\w+)/$tval=$1/e, @ARGV) { + # check val before accepting + my @allowed = @{$gOpts{$opt}}; + if (grep { $_ eq $tval } @allowed) { + $gOpts{$opt} = $tval; + } + else {die "invalid value: '$tval' for $opt\n"} + } + + # take 1st val as default + $gOpts{$opt} = ${$gOpts{$opt}}[0] + if ref $gOpts{$opt} eq 'ARRAY'; + } + else { # handle scalars + + # if 'opt' is present, true + $gOpts{$opt} = (grep /$opt/, @ARGV) ? 1 : 0; + + # override with 'foo' if 'opt=foo' appears + grep s/$opt=(.*)/$gOpts{$opt}=$1/e, @ARGV; + } + } + print("$0 heres current state:\n", Dumper \%gOpts) + if $gOpts{help} or $gOpts{dump}; + + exit if $gOpts{help}; +} +# the above arg-handling cruft should be replaced by a Getopt call + +################################## +# API + +sub checkOptree { + my %in = @_; + my ($in, $res) = (\%in,0); # set up privates. + + print "checkOptree args: ",Dumper \%in if $in{dump}; + SKIP: { + label(\%in); + skip($in{name}, 1) if $in{skip}; + + # cpy globals into each test + foreach $k (keys %gOpts) { + if ($gOpts{$k}) { + $in{$k} = $gOpts{$k} unless $in{$k}; + } + } + #die "no reftext found for $want: $in->{name}" unless $str; + + return runSelftest(\%in) if $gOpts{selftest}; + + my ($rendering,@errs) = getRendering(\%in); # get the actual output + + if ($in->{errs}) { + if (@errs) { + like ("@errs", qr/$in->{errs}\s*/, "$in->{name} - matched expected errs"); + next; + } + } + fail("FORCED: $in{name}:\n$rendering") if $gOpts{fail}; # silly ? + + # Test rendering against .. + TODO: + foreach $want (@{$modes{$gOpts{testmode}}}) { + local $TODO = $in{todo} if $in{todo}; + + my ($rex,$txt,$rexstr) = mkCheckRex(\%in,$want); + my $cross = $msgs{"$want-$thrstat"}; + + # bad is anticipated failure on cross testing ONLY + my $bad = (0 or ( $cross && $in{crossfail}) + or (!$cross && $in{fail}) + or 0); # no undefs! pedant + + # couldn't bear to pass \%in to likeyn + $res = mylike ( # custom test mode stuff + [ !$bad, + $in{retry} || $gOpts{retry}, + $in{debug} || $gOpts{retrydbg}, + $rexstr, + ], + # remaining is std API + $rendering, qr/$rex/ms, "$cross $in{name} $in{label}") + || 0; + printhelp(\%in, $rendering, $rex); + } + } + $res; +} + +################# +# helpers + +sub label { + # may help get/keep test output consistent + my ($in) = @_; + return if $in->{name}; + + my $buf = (ref $in->{bcopts}) + ? join(',', @{$in->{bcopts}}) : $in->{bcopts}; + + foreach (qw( note prog code )) { + $buf .= " $_: $in->{$_}" if $in->{$_} and not ref $in->{$_}; + } + return $in->{label} = $buf; +} + +sub testCombo { + # generate a set of test-cases from the options + my $in = @_; + my @cases; + foreach $want (@{$modes{$gOpts{testmode}}}) { + push @cases, [ %in ] + } + return @cases; +} + +sub runSelftest { + # tests the test-cases offered (expect, expect_nt) + # needs Unification with above. + my ($in) = @_; + my $ok; + foreach $want (@{$modes{$gOpts{testmode}}}) {} + + for my $provenance (qw/ expect expect_nt /) { + next unless $in->{$provenance}; + my ($rex,$gospel) = mkCheckRex($in, $provenance); + return unless $gospel; + + my $cross = $msgs{"$provenance-$thrstat"}; + my $bad = (0 or ( $cross && $in->{crossfail}) + or (!$cross && $in->{fail}) + or 0); + # couldn't bear to pass \%in to likeyn + $res = mylike ( [ !$bad, + $in->{retry} || $gOpts{retry}, + $in->{debug} || $gOpts{retrydbg}, + #label($in) + ], + $rendering, qr/$rex/ms, "$cross $in{name}") + || 0; + } + $ok; +} + +# use re; +sub mylike { + # note dependence on unlike() + my ($control) = shift; + my ($yes,$retry,$debug,$postmortem) = @$control; # or dies + my ($got, $expected, $name, @mess) = @_; # pass thru mostly + + die "unintended usage, expecting Regex". Dumper \@_ + unless ref $_[1] eq 'Regexp'; + + #ok($got=~/$expected/, "wow"); + + # same as A ^ B, but B has side effects + my $ok = ( (!$yes and unlike($got, $expected, $name, @mess)) + or ($yes and like($got, $expected, $name, @mess))); + + if (not $ok and $postmortem) { + # split rexstr into units that should eat leading lines. + my @rexs = map qr/^$_/, split (/\n/,$postmortem); + foreach my $rex (@rexs) { + #$got =~ s/($rex)/ate: $1/msg; # noisy + $got =~ s/($rex)\n//msg; # remove matches + } + print "these lines not matched:\n$got\n"; + } + + if (not $ok and $retry) { + # redo, perhaps with use re debug - NOT ROBUST + eval "use re 'debug'" if $debug; + $ok = (!$yes and unlike($got, $expected, "(RETRY) $name", @mess) + or $yes and like($got, $expected, "(RETRY) $name", @mess)); + + no re 'debug'; + } + return $ok; +} + +sub getRendering { + my ($in) = @_; + die "getRendering: code or prog is required\n" + unless $in->{code} or $in->{prog}; + + my @opts = get_bcopts($in); + my $rendering = ''; # suppress "Use of uninitialized value in open" + my @errs; # collect errs via + + + if ($in->{prog}) { + $rendering = runperl( switches => ['-w',join(',',"-MO=Concise",@opts)], + prog => $in->{prog}, stderr => 1, + ); # verbose => 1); + } else { + my $code = $in->{code}; + unless (ref $code eq 'CODE') { + # treat as source, and wrap + $code = eval "sub { $code }"; + # return errors + push @errs, $@ if $@; + } + # set walk-output b4 compiling, which writes 'announce' line + walk_output(\$rendering); + if ($in->{fail}) { + fail("forced failure: stdout follows"); + walk_output(\*STDOUT); + } + my $opwalker = B::Concise::compile(@opts, $code); + die "bad BC::compile retval" unless ref $opwalker eq 'CODE'; + + B::Concise::reset_sequence(); + $opwalker->(); + } + if ($in->{strip}) { + $rendering =~ s/(B::Concise::compile.*?\n)//; + print "stripped from rendering <$1>\n" if $1 and $in->{stripv}; + + while ($rendering =~ s/^(.*?-e line .*?\n)//g) { + print "stripped <$1>\n" if $in->{stripv}; + push @errs, $1; + } + $rendering =~ s/-e syntax OK\n//; + $rendering =~ s/-e had compilation errors\.\n//; + } + return $rendering, @errs; +} + +sub get_bcopts { + # collect concise passthru-options if any + my ($in) = shift; + my @opts = (); + if ($in->{bcopts}) { + @opts = (ref $in->{bcopts} eq 'ARRAY') + ? @{$in->{bcopts}} : ($in->{bcopts}); + } + return @opts; +} + +=head1 mkCheckRex + +mkCheckRex receives the full testcase object, and constructs a regex. +1st, it selects a reftxt from either the expect or expect_nt items. + +Once selected, the reftext is massaged & converted into a Regex that +accepts 'good' concise renderings, with appropriate input variations, +but is otherwise as strict as possible. For example, it should *not* +match when opcode flags change, or when optimizations convert an op to +an ex-op. + +selection is driven by platform mostly, but also by test-mode, which +rather complicates the code. this is worsened by the potential need +to make platform specific conversions on the reftext. + +=head2 match criteria + +Opcode arguments (text within braces) are disregarded for matching +purposes. This loses some info in 'add[t5]', but greatly simplifys +matching 'nextstate(main 22 (eval 10):1)'. Besides, we are testing +for regressions, not for complete accuracy. + +The regex is anchored by default, but can be suppressed with +'noanchors', allowing 1-liner tests to succeed if opcode is found. + +=cut + +# needless complexity due to 'too much info' from B::Concise v.60 +my $announce = 'B::Concise::compile\(CODE\(0x[0-9a-f]+\)\)';; + +sub mkCheckRex { + # converts expected text into Regexp which should match against + # unaltered version. also adjusts threaded => non-threaded + my ($in, $want) = @_; + eval "no re 'debug'"; + + my $str = $in->{expect} || $in->{expect_nt}; # standard bias + $str = $in->{$want} if $want; # stated pref + + #fail("rex-str is empty, won't allow false positives") unless $str; + + $str =~ s/^\# //mg; # ease cut-paste testcase authoring + my $reftxt = $str; # extra return val !! + + # convert all (args) and [args] to temp forms wo bracing + $str =~ s/\[(.*?)\]/__CAPSQR$1__/msg; + $str =~ s/\((.*?)\)/__CAPRND$1__/msg; + $str =~ s/\((.*?)\)/__CAPRND$1__/msg; # nested () in nextstate + + # escape bracing, etc.. manual \Q (doesnt escape '+') + $str =~ s/([\[\]()*.\$\@\#\|{}])/\\$1/msg; + + # now replace temp forms with original, preserving reference bracing + $str =~ s/__CAPSQR(.*?)__\b/\\[$1\\]/msg; # \b is important + $str =~ s/__CAPRND(.*?)__\b/\\($1\\)/msg; + $str =~ s/__CAPRND(.*?)__\b/\\($1\\)/msg; # nested () in nextstate + + # no 'invisible' failures in debugger + $str =~ s/(?:next|db)state(\\\(.*?\\\))/(?:next|db)state(.*?)/msg; + # widened for -terse mode + $str =~ s/(?:next|db)state/(?:next|db)state/msg; + + # don't care about: + $str =~ s/:-?\d+,-?\d+/:-?\\d+,-?\\d+/msg; # FAKE line numbers + $str =~ s/match\\\(.*?\\\)/match\(.*?\)/msg; # match args + $str =~ s/(0x[0-9A-Fa-f]+)/0x[0-9A-Fa-f]+/msg; # hexnum values + $str =~ s/".*?"/".*?"/msg; # quoted strings + + $str =~ s/(\d refs?)/\\d refs?/msg; + $str =~ s/leavesub \[\d\]/leavesub [\\d]/msg; # for -terse + + croak "no reftext found for $want: $in->{name}" + unless $str =~ /\w+/; # fail unless a real test + + # $str = '.*' if 1; # sanity test + # $str .= 'FAIL' if 1; # sanity test + + # allow -eval, banner at beginning of anchored matches + $str = "(-e .*?)?(B::Concise::compile.*?)?\n" . $str + unless $in->{noanchors} or $in->{rxnoorder}; + + eval "use re 'debug'" if $debug; + my $qr = ($in->{noanchors}) ? qr/$str/ms : qr/^$str$/ms ; + no re 'debug'; + + return ($qr, $reftxt, $str) if wantarray; + return $qr; +} + + +sub printhelp { + # crufty - may be still useful + my ($in, $rendering, $rex) = @_; + print "<$rendering>\nVS\n<$rex>\n" if $gOpts{vbasic}; + + # save this output to afile, edit out 'ok's and 1..N + # then perl -d afile, and add re 'debug' to suit. + print("\$str = q%$rendering%;\n". + "\$rex = qr%$rex%;\n\n". + #"print \"\$str =~ m%\$rex%ms \";\n". + "\$str =~ m{\$rex}ms or print \"doh\\n\";\n\n") + if $in{rextract} or $gOpts{rextract}; +} + + +######################### +# support for test writing + +sub preamble { + my $testct = shift || 1; + return <<EO_HEADER; +#!perl + +BEGIN { + chdir q(t); + \@INC = qw(../lib ../ext/B/t); + require q(./test.pl); +} +use OptreeCheck; +plan tests => $testct; + +EO_HEADER + +} + +sub OptreeCheck::wrap { + my $code = shift; + $code =~ s/(?:(\#.*?)\n)//gsm; + $code =~ s/\s+/ /mgs; + chomp $code; + return unless $code =~ /\S/; + my $comment = $1; + + my $testcode = qq{ + +checkOptree(note => q{$comment}, + bcopts => q{-exec}, + code => q{$code}, + expect => <<EOT_EOT, expect_nt => <<EONT_EONT); +ThreadedRef +EOT_EOT +NonThreadRef +EONT_EONT + +}; + return $testcode; +} + +sub OptreeCheck::gentest { + my ($code,$opts) = @_; + my $rendering = getRendering({code => $code}); + my $testcode = OptreeCheck::wrap($code); + return unless $testcode; + + # run the prog, capture 'reference' concise output + my $preamble = preamble(1); + my $got = runperl( prog => "$preamble $testcode", stderr => 1, + #switches => ["-I../ext/B/t", "-MOptreeCheck"], + ); #verbose => 1); + + # extract the 'reftext' ie the got 'block' + if ($got =~ m/got \'.*?\n(.*)\n\# \'\n\# expected/s) { + my $reftext = $1; + #and plug it into the test-src + if ($threaded) { + $testcode =~ s/ThreadedRef/$reftext/; + } else { + $testcode =~ s/NonThreadRef/$reftext/; + } + my $b4 = q{expect => <<EOT_EOT, expect_nt => <<EONT_EONT}; + my $af = q{expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'}; + $testcode =~ s/$b4/$af/; + + my $got; + if ($internal_retest) { + $got = runperl( prog => "$preamble $testcode", stderr => 1, + #switches => ["-I../ext/B/t", "-MOptreeCheck"], + verbose => 1); + print "got: $got\n"; + } + return $testcode; + } + return ''; +} + + +sub OptreeCheck::processExamples { + my @files = @_; + # gets array of paragraphs, which should be tests. + + foreach my $file (@files) { + open (my $fh, $file) or die "cant open $file: $!\n"; + $/ = ""; + my @chunks = <$fh>; + print preamble (scalar @chunks); + foreach $t (@chunks) { + print "\n\n=for gentest\n\n# chunk: $t=cut\n\n"; + print OptreeCheck::gentest ($t); + } + } +} + +# OK - now for the final insult to your good taste... + +if ($0 =~ /OptreeCheck\.pm/) { + + #use lib 't'; + require './t/test.pl'; + + # invoked as program. Work like former gentest.pl, + # ie read files given as cmdline args, + # convert them to usable test files. + + require Getopt::Std; + Getopt::Std::getopts('') or + die qq{ $0 sample-files* # no options + + expecting filenames as args. Each should have paragraphs, + these are converted to checkOptree() tests, and printed to + stdout. Redirect to file then edit for test. \n}; + + OptreeCheck::processExamples(@ARGV); +} + +1; + +__END__ + +=head1 TEST DEVELOPMENT SUPPORT + +This optree regression testing framework needs tests in order to find +bugs. To that end, OptreeCheck has support for developing new tests, +according to the following model: + + 1. write a set of sample code into a single file, one per + paragraph. f_map and f_sort in ext/B/t/ are examples. + + 2. run OptreeCheck as a program on the file + + ./perl -Ilib ext/B/t/OptreeCheck.pm -w ext/B/t/f_map + ./perl -Ilib ext/B/t/OptreeCheck.pm -w ext/B/t/f_sort + + gentest reads the sample code, runs each to generate a reference + rendering, folds this rendering into an optreeCheck() statement, + and prints it to stdout. + + 3. run the output file as above, redirect to files, then rerun on + same build (for sanity check), and on thread-opposite build. With + editor in 1 window, and cmd in other, it's fairly easy to cut-paste + the gots into the expects, easier than running step 2 on both + builds then trying to sdiff them together. + +=head1 TODO + +There's a considerable amount of cruft in the whole arg-handling setup. +I'll replace / strip it before 5.10 + +Treat %in as a test object, interwork better with Test::* + +Refactor mkCheckRex() and selfTest() to isolate the selftest, +crosstest, etc selection mechanics. + +improve retry, retrydbg, esp. it's control of eval "use re debug". +This seems to work part of the time, but isn't stable enough. + +=head1 CAVEATS + +This code is purely for testing core. While checkOptree feels flexible +enough to be stable, the whole selftest framework is subject to change +w/o notice. + +=cut diff --git a/gnu/usr.bin/perl/ext/B/t/b.t b/gnu/usr.bin/perl/ext/B/t/b.t index 5e7201e490c..0d2e8bc350d 100644 --- a/gnu/usr.bin/perl/ext/B/t/b.t +++ b/gnu/usr.bin/perl/ext/B/t/b.t @@ -18,7 +18,7 @@ BEGIN { $| = 1; use warnings; use strict; -use Test::More tests => 5; +use Test::More tests => 41; BEGIN { use_ok( 'B' ); } @@ -69,3 +69,77 @@ ok( B::svref_2object(\$.)->MAGIC->TYPE eq "\0", '$. has \0 magic' ); like( $e, qr/Can't call method "TYPE" on an undefined value/, '$. has no more magic' ); } + +my $iv = 1; +my $iv_ref = B::svref_2object(\$iv); +is(ref $iv_ref, "B::IV", "Test B:IV return from svref_2object"); +is($iv_ref->REFCNT, 1, "Test B::IV->REFCNT"); +# Flag tests are needed still +#diag $iv_ref->FLAGS(); +my $iv_ret = $iv_ref->object_2svref(); +is(ref $iv_ret, "SCALAR", "Test object_2svref() return is SCALAR"); +is($$iv_ret, $iv, "Test object_2svref()"); +is($iv_ref->int_value, $iv, "Test int_value()"); +is($iv_ref->IV, $iv, "Test IV()"); +is($iv_ref->IVX(), $iv, "Test IVX()"); +is($iv_ref->UVX(), $iv, "Test UVX()"); + +my $pv = "Foo"; +my $pv_ref = B::svref_2object(\$pv); +is(ref $pv_ref, "B::PV", "Test B::PV return from svref_2object"); +is($pv_ref->REFCNT, 1, "Test B::PV->REFCNT"); +# Flag tests are needed still +#diag $pv_ref->FLAGS(); +my $pv_ret = $pv_ref->object_2svref(); +is(ref $pv_ret, "SCALAR", "Test object_2svref() return is SCALAR"); +is($$pv_ret, $pv, "Test object_2svref()"); +is($pv_ref->PV(), $pv, "Test PV()"); +eval { is($pv_ref->RV(), $pv, "Test RV()"); }; +ok($@, "Test RV()"); +is($pv_ref->PVX(), $pv, "Test PVX()"); + +my $nv = 1.1; +my $nv_ref = B::svref_2object(\$nv); +is(ref $nv_ref, "B::NV", "Test B::NV return from svref_2object"); +is($nv_ref->REFCNT, 1, "Test B::NV->REFCNT"); +# Flag tests are needed still +#diag $nv_ref->FLAGS(); +my $nv_ret = $nv_ref->object_2svref(); +is(ref $nv_ret, "SCALAR", "Test object_2svref() return is SCALAR"); +is($$nv_ret, $nv, "Test object_2svref()"); +is($nv_ref->NV, $nv, "Test NV()"); +is($nv_ref->NVX(), $nv, "Test NVX()"); + +my $null = undef; +my $null_ref = B::svref_2object(\$null); +is(ref $null_ref, "B::NULL", "Test B::NULL return from svref_2object"); +is($null_ref->REFCNT, 1, "Test B::NULL->REFCNT"); +# Flag tests are needed still +#diag $null_ref->FLAGS(); +my $null_ret = $nv_ref->object_2svref(); +is(ref $null_ret, "SCALAR", "Test object_2svref() return is SCALAR"); +is($$null_ret, $nv, "Test object_2svref()"); + +my $cv = sub{ 1; }; +my $cv_ref = B::svref_2object(\$cv); +is($cv_ref->REFCNT, 1, "Test B::RV->REFCNT"); +is(ref $cv_ref, "B::RV", "Test B::RV return from svref_2object - code"); +my $cv_ret = $cv_ref->object_2svref(); +is(ref $cv_ret, "REF", "Test object_2svref() return is REF"); +is($$cv_ret, $cv, "Test object_2svref()"); + +my $av = []; +my $av_ref = B::svref_2object(\$av); +is(ref $av_ref, "B::RV", "Test B::RV return from svref_2object - array"); + +my $hv = []; +my $hv_ref = B::svref_2object(\$hv); +is(ref $hv_ref, "B::RV", "Test B::RV return from svref_2object - hash"); + +local *gv = *STDOUT; +my $gv_ref = B::svref_2object(\*gv); +is(ref $gv_ref, "B::GV", "Test B::GV return from svref_2object"); +ok(! $gv_ref->is_empty(), "Test is_empty()"); +is($gv_ref->NAME(), "gv", "Test NAME()"); +is($gv_ref->SAFENAME(), "gv", "Test SAFENAME()"); +like($gv_ref->FILE(), qr/b\.t$/, "Testing FILE()"); diff --git a/gnu/usr.bin/perl/ext/B/t/bytecode.t b/gnu/usr.bin/perl/ext/B/t/bytecode.t new file mode 100755 index 00000000000..831dae8e972 --- /dev/null +++ b/gnu/usr.bin/perl/ext/B/t/bytecode.t @@ -0,0 +1,155 @@ +#!./perl +my $keep_plc = 0; # set it to keep the bytecode files +my $keep_plc_fail = 1; # set it to keep the bytecode files on failures + +BEGIN { + if ($^O eq 'VMS') { + print "1..0 # skip - Bytecode/ByteLoader doesn't work on VMS\n"; + exit 0; + } + chdir 't' if -d 't'; + @INC = qw(../lib); + use Config; + if (($Config{'extensions'} !~ /\bB\b/) ){ + print "1..0 # Skip -- Perl configured without B module\n"; + exit 0; + } + if ($Config{ccflags} =~ /-DPERL_COPY_ON_WRITE/) { + print "1..0 # skip - no COW for now\n"; + exit 0; + } + require './test.pl'; # for run_perl() +} +use strict; + +undef $/; +my @tests = split /\n###+\n/, <DATA>; + +print "1..".($#tests+1)."\n"; + +my $cnt = 1; +my $test; + +for (@tests) { + my $got; + my ($script, $expect) = split />>>+\n/; + $expect =~ s/\n$//; + $test = "bytecode$cnt.pl"; + open T, ">$test"; print T $script; close T; + $got = run_perl(switches => [ "-MO=Bytecode,-H,-o${test}c" ], + verbose => 0, # for debugging + stderr => 1, # to capture the "bytecode.pl syntax ok" + progfile => $test); + unless ($?) { + $got = run_perl(progfile => "${test}c"); # run the .plc + unless ($?) { + if ($got =~ /^$expect$/) { + print "ok $cnt\n"; + next; + } else { + $keep_plc = $keep_plc_fail unless $keep_plc; + print <<"EOT"; next; +not ok $cnt +--------- SCRIPT +$script +--------- GOT +$got +--------- EXPECT +$expect +---------------- + +EOT + } + } + } + print <<"EOT"; +--------- SCRIPT +$script +--------- $? +$got +EOT +} continue { + 1 while unlink($test, $keep_plc ? () : "${test}c"); + $cnt++; +} + +__DATA__ + +print 'hi' +>>>> +hi +############################################################ +for (1,2,3) { print if /\d/ } +>>>> +123 +############################################################ +$_ = "xyxyx"; %j=(1,2); s/x/$j{print('z')}/ge; print $_ +>>>> +zzz2y2y2 +############################################################ +$_ = "xyxyx"; %j=(1,2); s/x/$j{print('z')}/g; print $_ +>>>> +z2y2y2 +############################################################ +split /a/,"bananarama"; print @_ +>>>> +bnnrm +############################################################ +{ package P; sub x { print 'ya' } x } +>>>> +ya +############################################################ +@z = split /:/,"b:r:n:f:g"; print @z +>>>> +brnfg +############################################################ +sub AUTOLOAD { print 1 } &{"a"}() +>>>> +1 +############################################################ +my $l = 3; $x = sub { print $l }; &$x +>>>> +3 +############################################################ +my $i = 1; +my $foo = sub {$i = shift if @_}; +&$foo(3); +############################################################ +$x="Cannot use"; print index $x, "Can" +>>>> +0 +############################################################ +my $i=6; eval "print \$i\n" +>>>> +6 +############################################################ +BEGIN { %h=(1=>2,3=>4) } print $h{3} +>>>> +4 +############################################################ +open our $T,"a" +############################################################ +print <DATA> +__DATA__ +a +b +>>>> +a +b +############################################################ +BEGIN { tie @a, __PACKAGE__; sub TIEARRAY { bless{} } sub FETCH { 1 } } +print $a[1] +>>>> +1 +############################################################ +my $i=3; print 1 .. $i +>>>> +123 +############################################################ +my $h = { a=>3, b=>1 }; print sort {$h->{$a} <=> $h->{$b}} keys %$h +>>>> +ba +############################################################ +print sort { my $p; $b <=> $a } 1,4,3 +>>>> +431 diff --git a/gnu/usr.bin/perl/ext/B/t/concise.t b/gnu/usr.bin/perl/ext/B/t/concise.t index cb095a60523..16c56121807 100644 --- a/gnu/usr.bin/perl/ext/B/t/concise.t +++ b/gnu/usr.bin/perl/ext/B/t/concise.t @@ -11,7 +11,7 @@ BEGIN { require './test.pl'; } -plan tests => 5; +plan tests => 142; require_ok("B::Concise"); @@ -35,8 +35,287 @@ is($cop_base, 1, "Smallest COP sequence number"); $out = runperl( switches => ["-MO=Concise,-exec"], - prog => q{$a||=$b && print q/foo/}, + prog => q{$a=$b && print q/foo/}, stderr => 1, ); -like($out, qr/print/, "-exec option with ||="); +like($out, qr/print/, "'-exec' option output has print opcode"); + +######## API tests v.60 + +use Config; # used for perlio check +B::Concise->import(qw( set_style set_style_standard add_callback + add_style walk_output reset_sequence )); + +## walk_output argument checking + +# test that walk_output rejects non-HANDLE args +foreach my $foo ("string", [], {}) { + eval { walk_output($foo) }; + isnt ($@, '', "walk_output() rejects arg '$foo'"); + $@=''; # clear the fail for next test +} +# test accessor mode when arg undefd or 0 +foreach my $foo (undef, 0) { + my $handle = walk_output($foo); + is ($handle, \*STDOUT, "walk_output set to STDOUT (default)"); +} + +{ # any object that can print should be ok for walk_output + package Hugo; + sub new { my $foo = bless {} }; + sub print { CORE::print @_ } +} +my $foo = new Hugo; # suggested this API fix +eval { walk_output($foo) }; +is ($@, '', "walk_output() accepts obj that can print"); + +# test that walk_output accepts a HANDLE arg +SKIP: { + skip("no perlio in this build", 4) + unless $Config::Config{useperlio}; + + foreach my $foo (\*STDOUT, \*STDERR) { + eval { walk_output($foo) }; + is ($@, '', "walk_output() accepts STD* " . ref $foo); + } + + # now test a ref to scalar + eval { walk_output(\my $junk) }; + is ($@, '', "walk_output() accepts ref-to-sprintf target"); + + $junk = "non-empty"; + eval { walk_output(\$junk) }; + is ($@, '', "walk_output() accepts ref-to-non-empty-scalar"); +} + +## add_style +my @stylespec; +$@=''; +eval { add_style ('junk_B' => @stylespec) }; +like ($@, 'expecting 3 style-format args', + "add_style rejects insufficient args"); + +@stylespec = (0,0,0); # right length, invalid values +$@=''; +eval { add_style ('junk' => @stylespec) }; +is ($@, '', "add_style accepts: stylename => 3-arg-array"); + +$@=''; +eval { add_style (junk => @stylespec) }; +like ($@, qr/style 'junk' already exists, choose a new name/, + "add_style correctly disallows re-adding same style-name" ); + +# test new arg-checks on set_style +$@=''; +eval { set_style (@stylespec) }; +is ($@, '', "set_style accepts 3 style-format args"); + +@stylespec = (); # bad style + +eval { set_style (@stylespec) }; +like ($@, qr/expecting 3 style-format args/, + "set_style rejects bad style-format args"); + +#### for content with doc'd options + +my $func = sub{ $a = $b+42 }; # canonical example asub + +SKIP: { + # tests output to GLOB, using perlio feature directly + skip "no perlio on this build", 122 + unless $Config::Config{useperlio}; + + set_style_standard('concise'); # MUST CALL before output needed + + @options = qw( + -basic -exec -tree -compact -loose -vt -ascii + -base10 -bigendian -littleendian + ); + foreach $opt (@options) { + walk_output(\my $out); + my $treegen = B::Concise::compile($opt, $func); + $treegen->(); + #print "foo:$out\n"; + isnt($out, '', "got output with option $opt"); + } + + ## test output control via walk_output + + my $treegen = B::Concise::compile('-basic', $func); # reused + + { # test output into a package global string (sprintf-ish) + our $thing; + walk_output(\$thing); + $treegen->(); + ok($thing, "walk_output to our SCALAR, output seen"); + } + + # test walkoutput acceptance of a scalar-bound IO handle + open (my $fh, '>', \my $buf); + walk_output($fh); + $treegen->(); + ok($buf, "walk_output to GLOB, output seen"); + + ## Test B::Concise::compile error checking + + # call compile on non-CODE ref items + if (0) { + # pending STASH splaying + + foreach my $ref ([], {}) { + my $typ = ref $ref; + walk_output(\my $out); + eval { B::Concise::compile('-basic', $ref)->() }; + like ($@, qr/^err: not a coderef: $typ/, + "compile detects $typ-ref where expecting subref"); + # is($out,'', "no output when errd"); # announcement prints + } + } + + # test against a bogus autovivified subref. + # in debugger, it should look like: + # 1 CODE(0x84840cc) + # -> &CODE(0x84840cc) in ??? + sub nosuchfunc; + eval { B::Concise::compile('-basic', \&nosuchfunc)->() }; + like ($@, qr/^err: coderef has no START/, + "compile detects CODE-ref w/o actual code"); + + foreach my $opt (qw( -concise -exec )) { + eval { B::Concise::compile($opt,'non_existent_function')->() }; + like ($@, qr/unknown function \(main::non_existent_function\)/, + "'$opt' reports non-existent-function properly"); + } + + # v.62 tests + + pass ("TEST POST-COMPILE OPTION-HANDLING IN WALKER SUBROUTINE"); + + my $sample; + + my $walker = B::Concise::compile('-basic', $func); + walk_output(\$sample); + $walker->('-exec'); + like($sample, qr/goto/m, "post-compile -exec"); + + walk_output(\$sample); + $walker->('-basic'); + unlike($sample, qr/goto/m, "post-compile -basic"); + + + # bang at it combinatorically + my %combos; + my @modes = qw( -basic -exec ); + my @styles = qw( -concise -debug -linenoise -terse ); + + # prep samples + for $style (@styles) { + for $mode (@modes) { + walk_output(\$sample); + reset_sequence(); + $walker->($style, $mode); + $combos{"$style$mode"} = $sample; + } + } + # crosscheck that samples are all text-different + @list = sort keys %combos; + for $i (0..$#list) { + for $j ($i+1..$#list) { + isnt ($combos{$list[$i]}, $combos{$list[$j]}, + "combos for $list[$i] and $list[$j] are different, as expected"); + } + } + + # add samples with styles in different order + for $mode (@modes) { + for $style (@styles) { + reset_sequence(); + walk_output(\$sample); + $walker->($mode, $style); + $combos{"$mode$style"} = $sample; + } + } + # test commutativity of flags, ie that AB == BA + for $mode (@modes) { + for $style (@styles) { + is ( $combos{"$style$mode"}, + $combos{"$mode$style"}, + "results for $style$mode vs $mode$style are the same" ); + } + } + + my %save = %combos; + my %combos; # outputs for $mode=any($order) and any($style) + + # add more samples with switching modes & sticky styles + for $style (@styles) { + walk_output(\$sample); + reset_sequence(); + $walker->($style); + for $mode (@modes) { + walk_output(\$sample); + reset_sequence(); + $walker->($mode); + $combos{"$style/$mode"} = $sample; + } + } + # crosscheck that samples are all text-different + @nm = sort keys %combos; + for $i (0..$#nm) { + for $j ($i+1..$#nm) { + isnt ($combos{$nm[$i]}, $combos{$nm[$j]}, + "results for $nm[$i] and $nm[$j] are different, as expected"); + } + } + + # add samples with switching styles & sticky modes + for $mode (@modes) { + walk_output(\$sample); + reset_sequence(); + $walker->($mode); + for $style (@styles) { + walk_output(\$sample); + reset_sequence(); + $walker->($style); + $combos{"$mode/$style"} = $sample; + } + } + # test commutativity of flags, ie that AB == BA + for $mode (@modes) { + for $style (@styles) { + is ( $combos{"$style/$mode"}, + $combos{"$mode/$style"}, + "results for $style/$mode vs $mode/$style are the same" ); + } + } + + + #now do double crosschecks: commutativity across stick / nostick + my %combos = (%combos, %save); + + # test commutativity of flags, ie that AB == BA + for $mode (@modes) { + for $style (@styles) { + + is ( $combos{"$style$mode"}, + $combos{"$style/$mode"}, + "$style$mode VS $style/$mode are the same" ); + + is ( $combos{"$mode$style"}, + $combos{"$mode/$style"}, + "$mode$style VS $mode/$style are the same" ); + + is ( $combos{"$style$mode"}, + $combos{"$mode/$style"}, + "$style$mode VS $mode/$style are the same" ); + + is ( $combos{"$mode$style"}, + $combos{"$style/$mode"}, + "$mode$style VS $style/$mode are the same" ); + } + } +} + +__END__ + diff --git a/gnu/usr.bin/perl/ext/B/t/f_map b/gnu/usr.bin/perl/ext/B/t/f_map new file mode 100644 index 00000000000..a0e1a0865c4 --- /dev/null +++ b/gnu/usr.bin/perl/ext/B/t/f_map @@ -0,0 +1,29 @@ +#!perl +# examples shamelessly snatched from perldoc -f map + +# translates a list of numbers to the corresponding characters. +@chars = map(chr, @nums); + +%hash = map { getkey($_) => $_ } @array; + +{ + %hash = (); + foreach $_ (@array) { + $hash{getkey($_)} = $_; + } +} + +#%hash = map { "\L$_", 1 } @array; # perl guesses EXPR. wrong +%hash = map { +"\L$_", 1 } @array; # perl guesses BLOCK. right + +%hash = map { ("\L$_", 1) } @array; # this also works + +%hash = map { lc($_), 1 } @array; # as does this. + +%hash = map +( lc($_), 1 ), @array; # this is EXPR and works! + +%hash = map ( lc($_), 1 ), @array; # evaluates to (1, @array) + +@hashes = map +{ lc($_), 1 }, @array # EXPR, so needs , at end + + diff --git a/gnu/usr.bin/perl/ext/B/t/f_map.t b/gnu/usr.bin/perl/ext/B/t/f_map.t new file mode 100755 index 00000000000..ff22dde8e3c --- /dev/null +++ b/gnu/usr.bin/perl/ext/B/t/f_map.t @@ -0,0 +1,530 @@ +#!perl + +BEGIN { + chdir q(t); + @INC = qw(../lib ../ext/B/t); + require Config; + if (($Config::Config{'extensions'} !~ /\bB\b/) ){ + print "1..0 # Skip -- Perl configured without B module\n"; + exit 0; + } + if (!$Config::Config{useperlio}) { + print "1..0 # Skip -- need perlio to walk the optree\n"; + exit 0; + } + if ($] < 5.009) { + print "1..0 # Skip -- TODO - provide golden result regexps for 5.8\n"; + exit 0; + } + require q(./test.pl); +} +use OptreeCheck; +plan tests => 9; + + +=for gentest + +# chunk: #!perl +# examples shamelessly snatched from perldoc -f map + +=cut + +=for gentest + +# chunk: # translates a list of numbers to the corresponding characters. +@chars = map(chr, @nums); + +=cut + +checkOptree(note => q{}, + bcopts => q{-exec}, + code => q{@chars = map(chr, @nums); }, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 1 <;> nextstate(main 475 (eval 10):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <#> gv[*nums] s +# 5 <1> rv2av[t7] lKM/1 +# 6 <@> mapstart lK +# 7 <|> mapwhile(other->8)[t8] lK +# 8 <#> gvsv[*_] s +# 9 <1> chr[t5] sK/1 +# goto 7 +# a <0> pushmark s +# b <#> gv[*chars] s +# c <1> rv2av[t2] lKRM*/1 +# d <2> aassign[t9] KS/COMMON +# e <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 559 (eval 15):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <$> gv(*nums) s +# 5 <1> rv2av[t4] lKM/1 +# 6 <@> mapstart lK +# 7 <|> mapwhile(other->8)[t5] lK +# 8 <$> gvsv(*_) s +# 9 <1> chr[t3] sK/1 +# goto 7 +# a <0> pushmark s +# b <$> gv(*chars) s +# c <1> rv2av[t1] lKRM*/1 +# d <2> aassign[t6] KS/COMMON +# e <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + + +=for gentest + +# chunk: %hash = map { getkey($_) => $_ } @array; + +=cut + +checkOptree(note => q{}, + bcopts => q{-exec}, + code => q{%hash = map { getkey($_) => $_ } @array; }, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 1 <;> nextstate(main 476 (eval 10):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <#> gv[*array] s +# 5 <1> rv2av[t8] lKM/1 +# 6 <@> mapstart lK* +# 7 <|> mapwhile(other->8)[t9] lK +# 8 <0> enter l +# 9 <;> nextstate(main 475 (eval 10):1) v +# a <0> pushmark s +# b <0> pushmark s +# c <#> gvsv[*_] s +# d <#> gv[*getkey] s/EARLYCV +# e <1> entersub[t5] lKS/TARG,1 +# f <#> gvsv[*_] s +# g <@> list lK +# h <@> leave lKP +# goto 7 +# i <0> pushmark s +# j <#> gv[*hash] s +# k <1> rv2hv[t2] lKRM*/1 +# l <2> aassign[t10] KS/COMMON +# m <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 560 (eval 15):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <$> gv(*array) s +# 5 <1> rv2av[t3] lKM/1 +# 6 <@> mapstart lK* +# 7 <|> mapwhile(other->8)[t4] lK +# 8 <0> enter l +# 9 <;> nextstate(main 559 (eval 15):1) v +# a <0> pushmark s +# b <0> pushmark s +# c <$> gvsv(*_) s +# d <$> gv(*getkey) s/EARLYCV +# e <1> entersub[t2] lKS/TARG,1 +# f <$> gvsv(*_) s +# g <@> list lK +# h <@> leave lKP +# goto 7 +# i <0> pushmark s +# j <$> gv(*hash) s +# k <1> rv2hv[t1] lKRM*/1 +# l <2> aassign[t5] KS/COMMON +# m <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + + +=for gentest + +# chunk: { + %hash = (); + foreach $_ (@array) { + $hash{getkey($_)} = $_; + } +} + +=cut + +checkOptree(note => q{}, + bcopts => q{-exec}, + code => q{{ %hash = (); foreach $_ (@array) { $hash{getkey($_)} = $_; } } }, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 1 <;> nextstate(main 478 (eval 10):1) v +# 2 <{> enterloop(next->u last->u redo->3) +# 3 <;> nextstate(main 475 (eval 10):1) v +# 4 <0> pushmark s +# 5 <0> pushmark s +# 6 <#> gv[*hash] s +# 7 <1> rv2hv[t2] lKRM*/1 +# 8 <2> aassign[t3] vKS +# 9 <;> nextstate(main 476 (eval 10):1) v +# a <0> pushmark sM +# b <#> gv[*array] s +# c <1> rv2av[t6] sKRM/1 +# d <#> gv[*_] s +# e <1> rv2gv sKRM/1 +# f <{> enteriter(next->q last->t redo->g) lKS +# r <0> iter s +# s <|> and(other->g) K/1 +# g <;> nextstate(main 475 (eval 10):1) v +# h <#> gvsv[*_] s +# i <#> gv[*hash] s +# j <1> rv2hv sKR/1 +# k <0> pushmark s +# l <#> gvsv[*_] s +# m <#> gv[*getkey] s/EARLYCV +# n <1> entersub[t10] sKS/TARG,1 +# o <2> helem sKRM*/2 +# p <2> sassign vKS/2 +# q <0> unstack s +# goto r +# t <2> leaveloop K/2 +# u <2> leaveloop K/2 +# v <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 562 (eval 15):1) v +# 2 <{> enterloop(next->u last->u redo->3) +# 3 <;> nextstate(main 559 (eval 15):1) v +# 4 <0> pushmark s +# 5 <0> pushmark s +# 6 <$> gv(*hash) s +# 7 <1> rv2hv[t1] lKRM*/1 +# 8 <2> aassign[t2] vKS +# 9 <;> nextstate(main 560 (eval 15):1) v +# a <0> pushmark sM +# b <$> gv(*array) s +# c <1> rv2av[t3] sKRM/1 +# d <$> gv(*_) s +# e <1> rv2gv sKRM/1 +# f <{> enteriter(next->q last->t redo->g) lKS +# r <0> iter s +# s <|> and(other->g) K/1 +# g <;> nextstate(main 559 (eval 15):1) v +# h <$> gvsv(*_) s +# i <$> gv(*hash) s +# j <1> rv2hv sKR/1 +# k <0> pushmark s +# l <$> gvsv(*_) s +# m <$> gv(*getkey) s/EARLYCV +# n <1> entersub[t4] sKS/TARG,1 +# o <2> helem sKRM*/2 +# p <2> sassign vKS/2 +# q <0> unstack s +# goto r +# t <2> leaveloop K/2 +# u <2> leaveloop K/2 +# v <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + + +=for gentest + +# chunk: #%hash = map { "\L$_", 1 } @array; # perl guesses EXPR. wrong +%hash = map { +"\L$_", 1 } @array; # perl guesses BLOCK. right + +=cut + +checkOptree(note => q{}, + bcopts => q{-exec}, + code => q{%hash = map { +"\L$_", 1 } @array; }, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 1 <;> nextstate(main 476 (eval 10):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <#> gv[*array] s +# 5 <1> rv2av[t7] lKM/1 +# 6 <@> mapstart lK* +# 7 <|> mapwhile(other->8)[t9] lK +# 8 <0> pushmark s +# 9 <#> gvsv[*_] s +# a <1> lc[t4] sK/1 +# b <@> stringify[t5] sK/1 +# c <$> const[IV 1] s +# d <@> list lK +# - <@> scope lK +# goto 7 +# e <0> pushmark s +# f <#> gv[*hash] s +# g <1> rv2hv[t2] lKRM*/1 +# h <2> aassign[t10] KS/COMMON +# i <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 560 (eval 15):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <$> gv(*array) s +# 5 <1> rv2av[t4] lKM/1 +# 6 <@> mapstart lK* +# 7 <|> mapwhile(other->8)[t5] lK +# 8 <0> pushmark s +# 9 <$> gvsv(*_) s +# a <1> lc[t2] sK/1 +# b <@> stringify[t3] sK/1 +# c <$> const(IV 1) s +# d <@> list lK +# - <@> scope lK +# goto 7 +# e <0> pushmark s +# f <$> gv(*hash) s +# g <1> rv2hv[t1] lKRM*/1 +# h <2> aassign[t6] KS/COMMON +# i <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + + +=for gentest + +# chunk: %hash = map { ("\L$_", 1) } @array; # this also works + +=cut + +checkOptree(note => q{}, + bcopts => q{-exec}, + code => q{%hash = map { ("\L$_", 1) } @array; }, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 1 <;> nextstate(main 476 (eval 10):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <#> gv[*array] s +# 5 <1> rv2av[t7] lKM/1 +# 6 <@> mapstart lK* +# 7 <|> mapwhile(other->8)[t9] lK +# 8 <0> pushmark s +# 9 <#> gvsv[*_] s +# a <1> lc[t4] sK/1 +# b <@> stringify[t5] sK/1 +# c <$> const[IV 1] s +# d <@> list lKP +# - <@> scope lK +# goto 7 +# e <0> pushmark s +# f <#> gv[*hash] s +# g <1> rv2hv[t2] lKRM*/1 +# h <2> aassign[t10] KS/COMMON +# i <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 560 (eval 15):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <$> gv(*array) s +# 5 <1> rv2av[t4] lKM/1 +# 6 <@> mapstart lK* +# 7 <|> mapwhile(other->8)[t5] lK +# 8 <0> pushmark s +# 9 <$> gvsv(*_) s +# a <1> lc[t2] sK/1 +# b <@> stringify[t3] sK/1 +# c <$> const(IV 1) s +# d <@> list lKP +# - <@> scope lK +# goto 7 +# e <0> pushmark s +# f <$> gv(*hash) s +# g <1> rv2hv[t1] lKRM*/1 +# h <2> aassign[t6] KS/COMMON +# i <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + + +=for gentest + +# chunk: %hash = map { lc($_), 1 } @array; # as does this. + +=cut + +checkOptree(note => q{}, + bcopts => q{-exec}, + code => q{%hash = map { lc($_), 1 } @array; }, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 1 <;> nextstate(main 476 (eval 10):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <#> gv[*array] s +# 5 <1> rv2av[t6] lKM/1 +# 6 <@> mapstart lK* +# 7 <|> mapwhile(other->8)[t8] lK +# 8 <0> pushmark s +# 9 <#> gvsv[*_] s +# a <1> lc[t4] sK/1 +# b <$> const[IV 1] s +# c <@> list lK +# - <@> scope lK +# goto 7 +# d <0> pushmark s +# e <#> gv[*hash] s +# f <1> rv2hv[t2] lKRM*/1 +# g <2> aassign[t9] KS/COMMON +# h <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 589 (eval 26):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <$> gv(*array) s +# 5 <1> rv2av[t3] lKM/1 +# 6 <@> mapstart lK* +# 7 <|> mapwhile(other->8)[t4] lK +# 8 <0> pushmark s +# 9 <$> gvsv(*_) s +# a <1> lc[t2] sK/1 +# b <$> const(IV 1) s +# c <@> list lK +# - <@> scope lK +# goto 7 +# d <0> pushmark s +# e <$> gv(*hash) s +# f <1> rv2hv[t1] lKRM*/1 +# g <2> aassign[t5] KS/COMMON +# h <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + + +=for gentest + +# chunk: %hash = map +( lc($_), 1 ), @array; # this is EXPR and works! + +=cut + +checkOptree(note => q{}, + bcopts => q{-exec}, + code => q{%hash = map +( lc($_), 1 ), @array; }, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 1 <;> nextstate(main 475 (eval 10):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <#> gv[*array] s +# 5 <1> rv2av[t6] lKM/1 +# 6 <@> mapstart lK +# 7 <|> mapwhile(other->8)[t7] lK +# 8 <0> pushmark s +# 9 <#> gvsv[*_] s +# a <1> lc[t4] sK/1 +# b <$> const[IV 1] s +# c <@> list lKP +# goto 7 +# d <0> pushmark s +# e <#> gv[*hash] s +# f <1> rv2hv[t2] lKRM*/1 +# g <2> aassign[t8] KS/COMMON +# h <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 593 (eval 28):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <$> gv(*array) s +# 5 <1> rv2av[t3] lKM/1 +# 6 <@> mapstart lK +# 7 <|> mapwhile(other->8)[t4] lK +# 8 <0> pushmark s +# 9 <$> gvsv(*_) s +# a <1> lc[t2] sK/1 +# b <$> const(IV 1) s +# c <@> list lKP +# goto 7 +# d <0> pushmark s +# e <$> gv(*hash) s +# f <1> rv2hv[t1] lKRM*/1 +# g <2> aassign[t5] KS/COMMON +# h <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + + +=for gentest + +# chunk: %hash = map ( lc($_), 1 ), @array; # evaluates to (1, @array) + +=cut + +checkOptree(note => q{}, + bcopts => q{-exec}, + code => q{%hash = map ( lc($_), 1 ), @array; }, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 1 <;> nextstate(main 475 (eval 10):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <0> pushmark s +# 5 <$> const[IV 1] sM +# 6 <@> mapstart lK +# 7 <|> mapwhile(other->8)[t5] lK +# 8 <#> gvsv[*_] s +# 9 <1> lc[t4] sK/1 +# goto 7 +# a <0> pushmark s +# b <#> gv[*hash] s +# c <1> rv2hv[t2] lKRM*/1 +# d <2> aassign[t6] KS/COMMON +# e <#> gv[*array] s +# f <1> rv2av[t8] K/1 +# g <@> list K +# h <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 597 (eval 30):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <0> pushmark s +# 5 <$> const(IV 1) sM +# 6 <@> mapstart lK +# 7 <|> mapwhile(other->8)[t3] lK +# 8 <$> gvsv(*_) s +# 9 <1> lc[t2] sK/1 +# goto 7 +# a <0> pushmark s +# b <$> gv(*hash) s +# c <1> rv2hv[t1] lKRM*/1 +# d <2> aassign[t4] KS/COMMON +# e <$> gv(*array) s +# f <1> rv2av[t5] K/1 +# g <@> list K +# h <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + + +=for gentest + +# chunk: @hashes = map +{ lc($_), 1 }, @array # EXPR, so needs , at end + +=cut + +checkOptree(note => q{}, + bcopts => q{-exec}, + code => q{@hashes = map +{ lc($_), 1 }, @array }, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 1 <;> nextstate(main 475 (eval 10):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <#> gv[*array] s +# 5 <1> rv2av[t6] lKM/1 +# 6 <@> mapstart lK +# 7 <|> mapwhile(other->8)[t7] lK +# 8 <0> pushmark s +# 9 <#> gvsv[*_] s +# a <1> lc[t4] sK/1 +# b <$> const[IV 1] s +# c <@> anonhash sKRM/1 +# d <1> srefgen sK/1 +# goto 7 +# e <0> pushmark s +# f <#> gv[*hashes] s +# g <1> rv2av[t2] lKRM*/1 +# h <2> aassign[t8] KS/COMMON +# i <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 601 (eval 32):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <$> gv(*array) s +# 5 <1> rv2av[t3] lKM/1 +# 6 <@> mapstart lK +# 7 <|> mapwhile(other->8)[t4] lK +# 8 <0> pushmark s +# 9 <$> gvsv(*_) s +# a <1> lc[t2] sK/1 +# b <$> const(IV 1) s +# c <@> anonhash sKRM/1 +# d <1> srefgen sK/1 +# goto 7 +# e <0> pushmark s +# f <$> gv(*hashes) s +# g <1> rv2av[t1] lKRM*/1 +# h <2> aassign[t5] KS/COMMON +# i <1> leavesub[1 ref] K/REFC,1 +EONT_EONT diff --git a/gnu/usr.bin/perl/ext/B/t/f_sort b/gnu/usr.bin/perl/ext/B/t/f_sort new file mode 100644 index 00000000000..759523bb70f --- /dev/null +++ b/gnu/usr.bin/perl/ext/B/t/f_sort @@ -0,0 +1,91 @@ +#!perl +#examples poached from perldoc -f sort + +# sort lexically +@articles = sort @files; + +# same thing, but with explicit sort routine +@articles = sort {$a cmp $b} @files; + +# now case-insensitively +@articles = sort {uc($a) cmp uc($b)} @files; + +# same thing in reversed order +@articles = sort {$b cmp $a} @files; + +# sort numerically ascending +@articles = sort {$a <=> $b} @files; + +# sort numerically descending +@articles = sort {$b <=> $a} @files; + +# this sorts the %age hash by value instead of key +# using an in-line function +@eldest = sort { $age{$b} <=> $age{$a} } keys %age; + +# sort using explicit subroutine name +sub byage { + $age{$a} <=> $age{$b}; # presuming numeric +} +@sortedclass = sort byage @class; + +sub backwards { $b cmp $a } +@harry = qw(dog cat x Cain Abel); +@george = qw(gone chased yz Punished Axed); +print sort @harry; +# prints AbelCaincatdogx +print sort backwards @harry; +# prints xdogcatCainAbel +print sort @george, 'to', @harry; +# prints AbelAxedCainPunishedcatchaseddoggonetoxyz + +# inefficiently sort by descending numeric compare using +# the first integer after the first = sign, or the +# whole record case-insensitively otherwise +@new = @old[ sort { + $nums[$b] <=> $nums[$a] + || $caps[$a] cmp $caps[$b] + } 0..$#old ]; + +# same thing, but without any temps +@new = map { $_->[0] } +sort { $b->[1] <=> $a->[1] + || $a->[2] cmp $b->[2] + } map { [$_, /=(\d+)/, uc($_)] } @old; + +# using a prototype allows you to use any comparison subroutine +# as a sort subroutine (including other package's subroutines) +package other; +sub backwards ($$) { $_[1] cmp $_[0]; } # $a and $b are not set here +package main; +@new = sort other::backwards @old; + +# repeat, condensed. $main::a and $b are unaffected +sub other::backwards ($$) { $_[1] cmp $_[0]; } +@new = sort other::backwards @old; + +# guarantee stability, regardless of algorithm +use sort 'stable'; +@new = sort { substr($a, 3, 5) cmp substr($b, 3, 5) } @old; + +# force use of mergesort (not portable outside Perl 5.8) +use sort '_mergesort'; +@new = sort { substr($a, 3, 5) cmp substr($b, 3, 5) } @old; + +# you should have a good reason to do this! +@articles = sort {$FooPack::b <=> $FooPack::a} @files; + +# fancy +@result = sort { $a <=> $b } grep { $_ == $_ } @input; + +# void return context sort +sort { $a <=> $b } @input; + +# more void context, propagating ? +sort { $a <=> $b } grep { $_ == $_ } @input; + +# scalar return context sort +$s = sort { $a <=> $b } @input; + +$s = sort { $a <=> $b } grep { $_ == $_ } @input; + diff --git a/gnu/usr.bin/perl/ext/B/t/f_sort.t b/gnu/usr.bin/perl/ext/B/t/f_sort.t new file mode 100755 index 00000000000..26dfbe4c54e --- /dev/null +++ b/gnu/usr.bin/perl/ext/B/t/f_sort.t @@ -0,0 +1,960 @@ +#!perl + +BEGIN { + chdir q(t); + @INC = qw(../lib ../ext/B/t); + require Config; + if (($Config::Config{'extensions'} !~ /\bB\b/) ){ + print "1..0 # Skip -- Perl configured without B module\n"; + exit 0; + } + if (!$Config::Config{useperlio}) { + print "1..0 # Skip -- need perlio to walk the optree\n"; + exit 0; + } + if ($] < 5.009) { + print "1..0 # Skip -- TODO - provide golden result regexps for 5.8\n"; + exit 0; + } + require q(./test.pl); +} +use OptreeCheck; +plan tests => 20; + + +=head1 Test Notes + +# chunk: #!perl +#examples poached from perldoc -f sort + +NOTE: name is no longer a required arg for checkOptree, as label is +synthesized out of others. HOWEVER, if the test-code has newlines in +it, the label must be overridden by an explicit name. + +This is because t/TEST is quite particular about the test output it +processes, and multi-line labels violate its 1-line-per-test +expectations. + +=for gentest + +# chunk: # sort lexically +@articles = sort @files; + +=cut + +checkOptree(note => q{}, + bcopts => q{-exec}, + code => q{@articles = sort @files; }, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 1 <;> nextstate(main 545 (eval 15):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <#> gv[*files] s +# 5 <1> rv2av[t4] lK/1 +# 6 <@> sort lK +# 7 <0> pushmark s +# 8 <#> gv[*articles] s +# 9 <1> rv2av[t2] lKRM*/1 +# a <2> aassign[t5] KS +# b <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 545 (eval 15):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <$> gv(*files) s +# 5 <1> rv2av[t2] lK/1 +# 6 <@> sort lK +# 7 <0> pushmark s +# 8 <$> gv(*articles) s +# 9 <1> rv2av[t1] lKRM*/1 +# a <2> aassign[t3] KS +# b <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + + +=for gentest + +# chunk: # same thing, but with explicit sort routine +@articles = sort {$a cmp $b} @files; + +=cut + +checkOptree(note => q{}, + bcopts => q{-exec}, + code => q{@articles = sort {$a cmp $b} @files; }, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 1 <;> nextstate(main 546 (eval 15):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <#> gv[*files] s +# 5 <1> rv2av[t7] lK/1 +# 6 <@> sort lK +# 7 <0> pushmark s +# 8 <#> gv[*articles] s +# 9 <1> rv2av[t2] lKRM*/1 +# a <2> aassign[t5] KS +# b <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 546 (eval 15):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <$> gv(*files) s +# 5 <1> rv2av[t3] lK/1 +# 6 <@> sort lK +# 7 <0> pushmark s +# 8 <$> gv(*articles) s +# 9 <1> rv2av[t1] lKRM*/1 +# a <2> aassign[t2] KS +# b <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + + +=for gentest + +# chunk: # now case-insensitively +@articles = sort {uc($a) cmp uc($b)} @files; + +=cut + +checkOptree(note => q{}, + bcopts => q{-exec}, + code => q{@articles = sort {uc($a) cmp uc($b)} @files; }, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 1 <;> nextstate(main 546 (eval 15):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <#> gv[*files] s +# 5 <1> rv2av[t9] lK/1 +# 6 <@> sort lKS* +# 7 <0> pushmark s +# 8 <#> gv[*articles] s +# 9 <1> rv2av[t2] lKRM*/1 +# a <2> aassign[t10] KS +# b <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 546 (eval 15):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <$> gv(*files) s +# 5 <1> rv2av[t5] lK/1 +# 6 <@> sort lKS* +# 7 <0> pushmark s +# 8 <$> gv(*articles) s +# 9 <1> rv2av[t1] lKRM*/1 +# a <2> aassign[t6] KS +# b <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + + +=for gentest + +# chunk: # same thing in reversed order +@articles = sort {$b cmp $a} @files; + +=cut + +checkOptree(note => q{}, + bcopts => q{-exec}, + code => q{@articles = sort {$b cmp $a} @files; }, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 1 <;> nextstate(main 546 (eval 15):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <#> gv[*files] s +# 5 <1> rv2av[t7] lK/1 +# 6 <@> sort lK/DESC +# 7 <0> pushmark s +# 8 <#> gv[*articles] s +# 9 <1> rv2av[t2] lKRM*/1 +# a <2> aassign[t5] KS +# b <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 546 (eval 15):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <$> gv(*files) s +# 5 <1> rv2av[t3] lK/1 +# 6 <@> sort lK/DESC +# 7 <0> pushmark s +# 8 <$> gv(*articles) s +# 9 <1> rv2av[t1] lKRM*/1 +# a <2> aassign[t2] KS +# b <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + + +=for gentest + +# chunk: # sort numerically ascending +@articles = sort {$a <=> $b} @files; + +=cut + +checkOptree(note => q{}, + bcopts => q{-exec}, + code => q{@articles = sort {$a <=> $b} @files; }, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 1 <;> nextstate(main 546 (eval 15):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <#> gv[*files] s +# 5 <1> rv2av[t7] lK/1 +# 6 <@> sort lK/NUM +# 7 <0> pushmark s +# 8 <#> gv[*articles] s +# 9 <1> rv2av[t2] lKRM*/1 +# a <2> aassign[t5] KS +# b <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 546 (eval 15):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <$> gv(*files) s +# 5 <1> rv2av[t3] lK/1 +# 6 <@> sort lK/NUM +# 7 <0> pushmark s +# 8 <$> gv(*articles) s +# 9 <1> rv2av[t1] lKRM*/1 +# a <2> aassign[t2] KS +# b <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + + +=for gentest + +# chunk: # sort numerically descending +@articles = sort {$b <=> $a} @files; + +=cut + +checkOptree(note => q{}, + bcopts => q{-exec}, + code => q{@articles = sort {$b <=> $a} @files; }, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 1 <;> nextstate(main 587 (eval 26):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <#> gv[*files] s +# 5 <1> rv2av[t7] lK/1 +# 6 <@> sort lK/DESC,NUM +# 7 <0> pushmark s +# 8 <#> gv[*articles] s +# 9 <1> rv2av[t2] lKRM*/1 +# a <2> aassign[t5] KS +# b <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 546 (eval 15):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <$> gv(*files) s +# 5 <1> rv2av[t3] lK/1 +# 6 <@> sort lK/DESC,NUM +# 7 <0> pushmark s +# 8 <$> gv(*articles) s +# 9 <1> rv2av[t1] lKRM*/1 +# a <2> aassign[t2] KS +# b <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + + +=for gentest + +# chunk: # this sorts the %age hash by value instead of key +# using an in-line function +@eldest = sort { $age{$b} <=> $age{$a} } keys %age; + +=cut + +checkOptree(note => q{}, + bcopts => q{-exec}, + code => q{@eldest = sort { $age{$b} <=> $age{$a} } keys %age; }, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 1 <;> nextstate(main 592 (eval 28):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <#> gv[*age] s +# 5 <1> rv2hv[t9] lKRM/1 +# 6 <1> keys[t10] lK/1 +# 7 <@> sort lKS* +# 8 <0> pushmark s +# 9 <#> gv[*eldest] s +# a <1> rv2av[t2] lKRM*/1 +# b <2> aassign[t11] KS +# c <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 546 (eval 15):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <$> gv(*age) s +# 5 <1> rv2hv[t3] lKRM/1 +# 6 <1> keys[t4] lK/1 +# 7 <@> sort lKS* +# 8 <0> pushmark s +# 9 <$> gv(*eldest) s +# a <1> rv2av[t1] lKRM*/1 +# b <2> aassign[t5] KS +# c <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + + +=for gentest + +# chunk: # sort using explicit subroutine name +sub byage { + $age{$a} <=> $age{$b}; # presuming numeric +} +@sortedclass = sort byage @class; + +=cut + +checkOptree(note => q{}, + bcopts => q{-exec}, + code => q{sub byage { $age{$a} <=> $age{$b}; } @sortedclass = sort byage @class; }, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 1 <;> nextstate(main 597 (eval 30):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <$> const[PV "byage"] s/BARE +# 5 <#> gv[*class] s +# 6 <1> rv2av[t4] lK/1 +# 7 <@> sort lKS +# 8 <0> pushmark s +# 9 <#> gv[*sortedclass] s +# a <1> rv2av[t2] lKRM*/1 +# b <2> aassign[t5] KS +# c <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 546 (eval 15):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <$> const(PV "byage") s/BARE +# 5 <$> gv(*class) s +# 6 <1> rv2av[t2] lK/1 +# 7 <@> sort lKS +# 8 <0> pushmark s +# 9 <$> gv(*sortedclass) s +# a <1> rv2av[t1] lKRM*/1 +# b <2> aassign[t3] KS +# c <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + + +=for gentest + +# chunk: sub backwards { $b cmp $a } +@harry = qw(dog cat x Cain Abel); +@george = qw(gone chased yz Punished Axed); +print sort @harry; +# prints AbelCaincatdogx +print sort backwards @harry; +# prints xdogcatCainAbel +print sort @george, 'to', @harry; +# prints AbelAxedCainPunishedcatchaseddoggonetoxyz + +=cut + +checkOptree(name => q{sort USERSUB LIST }, + bcopts => q{-exec}, + code => q{sub backwards { $b cmp $a } + @harry = qw(dog cat x Cain Abel); + @george = qw(gone chased yz Punished Axed); + print sort @harry; print sort backwards @harry; + print sort @george, 'to', @harry; }, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 1 <;> nextstate(main 602 (eval 32):2) v +# 2 <0> pushmark s +# 3 <$> const[PV "dog"] s +# 4 <$> const[PV "cat"] s +# 5 <$> const[PV "x"] s +# 6 <$> const[PV "Cain"] s +# 7 <$> const[PV "Abel"] s +# 8 <0> pushmark s +# 9 <#> gv[*harry] s +# a <1> rv2av[t2] lKRM*/1 +# b <2> aassign[t3] vKS +# c <;> nextstate(main 602 (eval 32):3) v +# d <0> pushmark s +# e <$> const[PV "gone"] s +# f <$> const[PV "chased"] s +# g <$> const[PV "yz"] s +# h <$> const[PV "Punished"] s +# i <$> const[PV "Axed"] s +# j <0> pushmark s +# k <#> gv[*george] s +# l <1> rv2av[t5] lKRM*/1 +# m <2> aassign[t6] vKS +# n <;> nextstate(main 602 (eval 32):4) v +# o <0> pushmark s +# p <0> pushmark s +# q <#> gv[*harry] s +# r <1> rv2av[t8] lK/1 +# s <@> sort lK +# t <@> print vK +# u <;> nextstate(main 602 (eval 32):4) v +# v <0> pushmark s +# w <0> pushmark s +# x <$> const[PV "backwards"] s/BARE +# y <#> gv[*harry] s +# z <1> rv2av[t10] lK/1 +# 10 <@> sort lKS +# 11 <@> print vK +# 12 <;> nextstate(main 602 (eval 32):5) v +# 13 <0> pushmark s +# 14 <0> pushmark s +# 15 <#> gv[*george] s +# 16 <1> rv2av[t12] lK/1 +# 17 <$> const[PV "to"] s +# 18 <#> gv[*harry] s +# 19 <1> rv2av[t14] lK/1 +# 1a <@> sort lK +# 1b <@> print sK +# 1c <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 602 (eval 32):2) v +# 2 <0> pushmark s +# 3 <$> const(PV "dog") s +# 4 <$> const(PV "cat") s +# 5 <$> const(PV "x") s +# 6 <$> const(PV "Cain") s +# 7 <$> const(PV "Abel") s +# 8 <0> pushmark s +# 9 <$> gv(*harry) s +# a <1> rv2av[t1] lKRM*/1 +# b <2> aassign[t2] vKS +# c <;> nextstate(main 602 (eval 32):3) v +# d <0> pushmark s +# e <$> const(PV "gone") s +# f <$> const(PV "chased") s +# g <$> const(PV "yz") s +# h <$> const(PV "Punished") s +# i <$> const(PV "Axed") s +# j <0> pushmark s +# k <$> gv(*george) s +# l <1> rv2av[t3] lKRM*/1 +# m <2> aassign[t4] vKS +# n <;> nextstate(main 602 (eval 32):4) v +# o <0> pushmark s +# p <0> pushmark s +# q <$> gv(*harry) s +# r <1> rv2av[t5] lK/1 +# s <@> sort lK +# t <@> print vK +# u <;> nextstate(main 602 (eval 32):4) v +# v <0> pushmark s +# w <0> pushmark s +# x <$> const(PV "backwards") s/BARE +# y <$> gv(*harry) s +# z <1> rv2av[t6] lK/1 +# 10 <@> sort lKS +# 11 <@> print vK +# 12 <;> nextstate(main 602 (eval 32):5) v +# 13 <0> pushmark s +# 14 <0> pushmark s +# 15 <$> gv(*george) s +# 16 <1> rv2av[t7] lK/1 +# 17 <$> const(PV "to") s +# 18 <$> gv(*harry) s +# 19 <1> rv2av[t8] lK/1 +# 1a <@> sort lK +# 1b <@> print sK +# 1c <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + + +=for gentest + +# chunk: # inefficiently sort by descending numeric compare using +# the first integer after the first = sign, or the +# whole record case-insensitively otherwise +@new = @old[ sort { + $nums[$b] <=> $nums[$a] + || $caps[$a] cmp $caps[$b] + } 0..$#old ]; + +=cut +=for gentest + +# chunk: # same thing, but without any temps +@new = map { $_->[0] } +sort { $b->[1] <=> $a->[1] + || $a->[2] cmp $b->[2] + } map { [$_, /=(\d+)/, uc($_)] } @old; + +=cut + +checkOptree(name => q{Compound sort/map Expression }, + bcopts => q{-exec}, + code => q{ @new = map { $_->[0] } + sort { $b->[1] <=> $a->[1] || $a->[2] cmp $b->[2] } + map { [$_, /=(\d+)/, uc($_)] } @old; }, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 1 <;> nextstate(main 609 (eval 34):3) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <0> pushmark s +# 5 <0> pushmark s +# 6 <#> gv[*old] s +# 7 <1> rv2av[t19] lKM/1 +# 8 <@> mapstart lK* +# 9 <|> mapwhile(other->a)[t20] lK +# a <0> enter l +# b <;> nextstate(main 608 (eval 34):2) v +# c <0> pushmark s +# d <#> gvsv[*_] s +# e </> match(/"=(\\d+)"/) l/RTIME +# f <#> gvsv[*_] s +# g <1> uc[t17] sK/1 +# h <@> anonlist sKRM/1 +# i <1> srefgen sK/1 +# j <@> leave lKP +# goto 9 +# k <@> sort lKMS* +# l <@> mapstart lK* +# m <|> mapwhile(other->n)[t26] lK +# n <#> gv[*_] s +# o <1> rv2sv sKM/DREFAV,1 +# p <1> rv2av[t4] sKR/1 +# q <$> const[IV 0] s +# r <2> aelem sK/2 +# - <@> scope lK +# goto m +# s <0> pushmark s +# t <#> gv[*new] s +# u <1> rv2av[t2] lKRM*/1 +# v <2> aassign[t27] KS/COMMON +# w <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 609 (eval 34):3) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <0> pushmark s +# 5 <0> pushmark s +# 6 <$> gv(*old) s +# 7 <1> rv2av[t10] lKM/1 +# 8 <@> mapstart lK* +# 9 <|> mapwhile(other->a)[t11] lK +# a <0> enter l +# b <;> nextstate(main 608 (eval 34):2) v +# c <0> pushmark s +# d <$> gvsv(*_) s +# e </> match(/"=(\\d+)"/) l/RTIME +# f <$> gvsv(*_) s +# g <1> uc[t9] sK/1 +# h <@> anonlist sKRM/1 +# i <1> srefgen sK/1 +# j <@> leave lKP +# goto 9 +# k <@> sort lKMS* +# l <@> mapstart lK* +# m <|> mapwhile(other->n)[t12] lK +# n <$> gv(*_) s +# o <1> rv2sv sKM/DREFAV,1 +# p <1> rv2av[t2] sKR/1 +# q <$> const(IV 0) s +# r <2> aelem sK/2 +# - <@> scope lK +# goto m +# s <0> pushmark s +# t <$> gv(*new) s +# u <1> rv2av[t1] lKRM*/1 +# v <2> aassign[t13] KS/COMMON +# w <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + + +=for gentest + +# chunk: # using a prototype allows you to use any comparison subroutine +# as a sort subroutine (including other package's subroutines) +package other; +sub backwards ($$) { $_[1] cmp $_[0]; } # $a and $b are not set here +package main; +@new = sort other::backwards @old; + +=cut + +checkOptree(name => q{sort other::sub LIST }, + bcopts => q{-exec}, + code => q{package other; sub backwards ($$) { $_[1] cmp $_[0]; } + package main; @new = sort other::backwards @old; }, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 1 <;> nextstate(main 614 (eval 36):2) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <$> const[PV "other::backwards"] s/BARE +# 5 <#> gv[*old] s +# 6 <1> rv2av[t4] lK/1 +# 7 <@> sort lKS +# 8 <0> pushmark s +# 9 <#> gv[*new] s +# a <1> rv2av[t2] lKRM*/1 +# b <2> aassign[t5] KS +# c <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 614 (eval 36):2) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <$> const(PV "other::backwards") s/BARE +# 5 <$> gv(*old) s +# 6 <1> rv2av[t2] lK/1 +# 7 <@> sort lKS +# 8 <0> pushmark s +# 9 <$> gv(*new) s +# a <1> rv2av[t1] lKRM*/1 +# b <2> aassign[t3] KS +# c <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + + +=for gentest + +# chunk: # repeat, condensed. $main::a and $b are unaffected +sub other::backwards ($$) { $_[1] cmp $_[0]; } +@new = sort other::backwards @old; + +=cut + +checkOptree(note => q{}, + bcopts => q{-exec}, + code => q{sub other::backwards ($$) { $_[1] cmp $_[0]; } @new = sort other::backwards @old; }, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 1 <;> nextstate(main 619 (eval 38):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <$> const[PV "other::backwards"] s/BARE +# 5 <#> gv[*old] s +# 6 <1> rv2av[t4] lK/1 +# 7 <@> sort lKS +# 8 <0> pushmark s +# 9 <#> gv[*new] s +# a <1> rv2av[t2] lKRM*/1 +# b <2> aassign[t5] KS +# c <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 546 (eval 15):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <$> const(PV "other::backwards") s/BARE +# 5 <$> gv(*old) s +# 6 <1> rv2av[t2] lK/1 +# 7 <@> sort lKS +# 8 <0> pushmark s +# 9 <$> gv(*new) s +# a <1> rv2av[t1] lKRM*/1 +# b <2> aassign[t3] KS +# c <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + + +=for gentest + +# chunk: # guarantee stability, regardless of algorithm +use sort 'stable'; +@new = sort { substr($a, 3, 5) cmp substr($b, 3, 5) } @old; + +=cut + +checkOptree(note => q{}, + bcopts => q{-exec}, + code => q{use sort 'stable'; @new = sort { substr($a, 3, 5) cmp substr($b, 3, 5) } @old; }, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 1 <;> nextstate(main 656 (eval 40):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <#> gv[*old] s +# 5 <1> rv2av[t9] lK/1 +# 6 <@> sort lKS* +# 7 <0> pushmark s +# 8 <#> gv[*new] s +# 9 <1> rv2av[t2] lKRM*/1 +# a <2> aassign[t14] KS +# b <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 578 (eval 15):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <$> gv(*old) s +# 5 <1> rv2av[t5] lK/1 +# 6 <@> sort lKS* +# 7 <0> pushmark s +# 8 <$> gv(*new) s +# 9 <1> rv2av[t1] lKRM*/1 +# a <2> aassign[t6] KS +# b <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + + +=for gentest + +# chunk: # force use of mergesort (not portable outside Perl 5.8) +use sort '_mergesort'; +@new = sort { substr($a, 3, 5) cmp substr($b, 3, 5) } @old; + +=cut + +checkOptree(note => q{}, + bcopts => q{-exec}, + code => q{use sort '_mergesort'; @new = sort { substr($a, 3, 5) cmp substr($b, 3, 5) } @old; }, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 1 <;> nextstate(main 662 (eval 42):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <#> gv[*old] s +# 5 <1> rv2av[t9] lK/1 +# 6 <@> sort lKS* +# 7 <0> pushmark s +# 8 <#> gv[*new] s +# 9 <1> rv2av[t2] lKRM*/1 +# a <2> aassign[t14] KS +# b <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 578 (eval 15):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <$> gv(*old) s +# 5 <1> rv2av[t5] lK/1 +# 6 <@> sort lKS* +# 7 <0> pushmark s +# 8 <$> gv(*new) s +# 9 <1> rv2av[t1] lKRM*/1 +# a <2> aassign[t6] KS +# b <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + + +=for gentest + +# chunk: # you should have a good reason to do this! +@articles = sort {$FooPack::b <=> $FooPack::a} @files; + +=cut + +checkOptree(note => q{}, + bcopts => q{-exec}, + code => q{@articles = sort {$FooPack::b <=> $FooPack::a} @files; }, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 1 <;> nextstate(main 667 (eval 44):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <#> gv[*files] s +# 5 <1> rv2av[t7] lK/1 +# 6 <@> sort lKS* +# 7 <0> pushmark s +# 8 <#> gv[*articles] s +# 9 <1> rv2av[t2] lKRM*/1 +# a <2> aassign[t8] KS +# b <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 546 (eval 15):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <$> gv(*files) s +# 5 <1> rv2av[t3] lK/1 +# 6 <@> sort lKS* +# 7 <0> pushmark s +# 8 <$> gv(*articles) s +# 9 <1> rv2av[t1] lKRM*/1 +# a <2> aassign[t4] KS +# b <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + + +=for gentest + +# chunk: # fancy +@result = sort { $a <=> $b } grep { $_ == $_ } @input; + +=cut + +checkOptree(note => q{}, + bcopts => q{-exec}, + code => q{@result = sort { $a <=> $b } grep { $_ == $_ } @input; }, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 1 <;> nextstate(main 673 (eval 46):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <0> pushmark s +# 5 <#> gv[*input] s +# 6 <1> rv2av[t9] lKM/1 +# 7 <@> grepstart lK* +# 8 <|> grepwhile(other->9)[t10] lK +# 9 <#> gvsv[*_] s +# a <#> gvsv[*_] s +# b <2> eq sK/2 +# - <@> scope sK +# goto 8 +# c <@> sort lK/NUM +# d <0> pushmark s +# e <#> gv[*result] s +# f <1> rv2av[t2] lKRM*/1 +# g <2> aassign[t5] KS/COMMON +# h <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 547 (eval 15):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <0> pushmark s +# 5 <$> gv(*input) s +# 6 <1> rv2av[t3] lKM/1 +# 7 <@> grepstart lK* +# 8 <|> grepwhile(other->9)[t4] lK +# 9 <$> gvsv(*_) s +# a <$> gvsv(*_) s +# b <2> eq sK/2 +# - <@> scope sK +# goto 8 +# c <@> sort lK/NUM +# d <0> pushmark s +# e <$> gv(*result) s +# f <1> rv2av[t1] lKRM*/1 +# g <2> aassign[t2] KS/COMMON +# h <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + + +=for gentest + +# chunk: # void return context sort +sort { $a <=> $b } @input; + +=cut + +checkOptree(note => q{}, + bcopts => q{-exec}, + code => q{sort { $a <=> $b } @input; }, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 1 <;> nextstate(main 678 (eval 48):1) v +# 2 <0> pushmark s +# 3 <#> gv[*input] s +# 4 <1> rv2av[t5] lK/1 +# 5 <@> sort K/NUM +# 6 <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 546 (eval 15):1) v +# 2 <0> pushmark s +# 3 <$> gv(*input) s +# 4 <1> rv2av[t2] lK/1 +# 5 <@> sort K/NUM +# 6 <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + + +=for gentest + +# chunk: # more void context, propagating ? +sort { $a <=> $b } grep { $_ == $_ } @input; + +=cut + +checkOptree(note => q{}, + bcopts => q{-exec}, + code => q{sort { $a <=> $b } grep { $_ == $_ } @input; }, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 1 <;> nextstate(main 684 (eval 50):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <#> gv[*input] s +# 5 <1> rv2av[t7] lKM/1 +# 6 <@> grepstart lK* +# 7 <|> grepwhile(other->8)[t8] lK +# 8 <#> gvsv[*_] s +# 9 <#> gvsv[*_] s +# a <2> eq sK/2 +# - <@> scope sK +# goto 7 +# b <@> sort K/NUM +# c <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 547 (eval 15):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <$> gv(*input) s +# 5 <1> rv2av[t2] lKM/1 +# 6 <@> grepstart lK* +# 7 <|> grepwhile(other->8)[t3] lK +# 8 <$> gvsv(*_) s +# 9 <$> gvsv(*_) s +# a <2> eq sK/2 +# - <@> scope sK +# goto 7 +# b <@> sort K/NUM +# c <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + + +=for gentest + +# chunk: # scalar return context sort +$s = sort { $a <=> $b } @input; + +=cut + +checkOptree(note => q{}, + bcopts => q{-exec}, + code => q{$s = sort { $a <=> $b } @input; }, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 1 <;> nextstate(main 689 (eval 52):1) v +# 2 <0> pushmark s +# 3 <#> gv[*input] s +# 4 <1> rv2av[t6] lK/1 +# 5 <@> sort sK/NUM +# 6 <#> gvsv[*s] s +# 7 <2> sassign sKS/2 +# 8 <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 546 (eval 15):1) v +# 2 <0> pushmark s +# 3 <$> gv(*input) s +# 4 <1> rv2av[t2] lK/1 +# 5 <@> sort sK/NUM +# 6 <$> gvsv(*s) s +# 7 <2> sassign sKS/2 +# 8 <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + + +=for gentest + +# chunk: $s = sort { $a <=> $b } grep { $_ == $_ } @input; + +=cut + +checkOptree(note => q{}, + bcopts => q{-exec}, + code => q{$s = sort { $a <=> $b } grep { $_ == $_ } @input; }, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 1 <;> nextstate(main 695 (eval 54):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <#> gv[*input] s +# 5 <1> rv2av[t8] lKM/1 +# 6 <@> grepstart lK* +# 7 <|> grepwhile(other->8)[t9] lK +# 8 <#> gvsv[*_] s +# 9 <#> gvsv[*_] s +# a <2> eq sK/2 +# - <@> scope sK +# goto 7 +# b <@> sort sK/NUM +# c <#> gvsv[*s] s +# d <2> sassign sKS/2 +# e <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 547 (eval 15):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <$> gv(*input) s +# 5 <1> rv2av[t2] lKM/1 +# 6 <@> grepstart lK* +# 7 <|> grepwhile(other->8)[t3] lK +# 8 <$> gvsv(*_) s +# 9 <$> gvsv(*_) s +# a <2> eq sK/2 +# - <@> scope sK +# goto 7 +# b <@> sort sK/NUM +# c <$> gvsv(*s) s +# d <2> sassign sKS/2 +# e <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + diff --git a/gnu/usr.bin/perl/ext/B/t/optree_check.t b/gnu/usr.bin/perl/ext/B/t/optree_check.t new file mode 100755 index 00000000000..2e2ef9cf3db --- /dev/null +++ b/gnu/usr.bin/perl/ext/B/t/optree_check.t @@ -0,0 +1,239 @@ +#!perl + +BEGIN { + chdir 't'; + @INC = ('../lib', '../ext/B/t'); + require Config; + if (($Config::Config{'extensions'} !~ /\bB\b/) ){ + print "1..0 # Skip -- Perl configured without B module\n"; + exit 0; + } + require './test.pl'; +} + +use OptreeCheck; + +=head1 OptreeCheck selftest harness + +This file is primarily to test services of OptreeCheck itself, ie +checkOptree(). %gOpts provides test-state info, it is 'exported' into +main:: + +doing use OptreeCheck runs import(), which processes @ARGV to process +cmdline args in 'standard' way across all clients of OptreeCheck. + +=cut + +use Config; +plan tests => 5 + 18 + 14 * $gOpts{selftest}; # fudged + +SKIP: { + skip "no perlio in this build", 5 + 18 + 14 * $gOpts{selftest} + unless $Config::Config{useperlio}; + + +pass("REGEX TEST HARNESS SELFTEST"); + +checkOptree ( name => "bare minimum opcode search", + bcopts => '-exec', + code => sub {my $a}, + noanchors => 1, # unanchored match + expect => 'leavesub', + expect_nt => 'leavesub'); + +checkOptree ( name => "found print opcode", + bcopts => '-exec', + code => sub {print 1}, + noanchors => 1, # unanchored match + expect => 'print', + expect_nt => 'leavesub'); + +checkOptree ( name => 'test skip itself', + skip => 1, + bcopts => '-exec', + code => sub {print 1}, + expect => 'dont-care, skipping', + expect_nt => 'this insures failure'); + +# This test 'unexpectedly succeeds', but that is "expected". Theres +# no good way to expect a successful todo, and inducing a failure +# causes the harness to print verbose errors, which is NOT helpful. + +checkOptree ( name => 'test todo itself. suppressed, remove skip to test', + todo => "suppress todo test for now", + skip => 1, + bcopts => '-exec', + code => sub {print 1}, + noanchors => 1, # unanchored match + expect => 'print', + expect_nt => 'print'); + +checkOptree ( name => 'impossible match, remove skip to see failure', + todo => "see! it breaks!", + skip => 1, # but skip it 1st + code => sub {print 1}, + expect => 'look out ! Boy Wonder', + expect_nt => 'holy near earth asteroid Batman !'); + +pass ("TEST FATAL ERRS"); + +if (1) { + # test for fatal errors. Im unsettled on fail vs die. + # calling fail isnt good enough by itself. + eval { + + checkOptree ( name => 'empty code or prog', + todo => "your excuse here ;-)", + code => '', + prog => '', + ); + }; + like($@, 'code or prog is required', 'empty code or prog prevented'); + + $@=''; + eval { + checkOptree ( name => 'test against empty expectations', + bcopts => '-exec', + code => sub {print 1}, + expect => '', + expect_nt => ''); + }; + like($@, 'no reftext found for', "empty expectations prevented"); + + $@=''; + eval { + checkOptree ( name => 'prevent whitespace only expectations', + bcopts => '-exec', + code => sub {my $a}, + #skip => 1, + expect_nt => "\n", + expect => "\n"); + }; + like($@, 'no reftext found for', "just whitespace expectations prevented"); +} + +pass ("TEST -e \$srcCode"); + +checkOptree + ( name => '-w errors seen', + prog => 'sort our @a', + errs => 'Useless use of sort in void context at -e line 1.', + ); + +checkOptree + ( name => "self strict, catch err", + prog => 'use strict; bogus', + errs => 'Bareword "bogus" not allowed while "strict subs" in use at -e line 1.', + ); + +checkOptree ( name => "sort vK - flag specific search", + prog => 'sort our @a', + noanchors => 1, + expect => '<@> sort vK ', + expect_nt => '<@> sort vK '); + +checkOptree ( name => "'prog' => 'sort our \@a'", + prog => 'sort our @a', + noanchors => 1, + expect => '<@> sort vK', + expect_nt => '<@> sort vK'); + +checkOptree ( name => "'code' => 'sort our \@a'", + code => 'sort our @a', + noanchors => 1, + expect => '<@> sort K', + expect_nt => '<@> sort K'); + +pass ("REFTEXT FIXUP TESTS"); + +checkOptree ( name => 'fixup nextstate (in reftext)', + bcopts => '-exec', + code => sub {my $a}, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 1 <;> nextstate( NOTE THAT THIS CAN BE ANYTHING ) v +# 2 <0> padsv[$a:54,55] M/LVINTRO +# 3 <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 54 optree_concise.t:84) v +# 2 <0> padsv[$a:54,55] M/LVINTRO +# 3 <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + +checkOptree ( name => 'fixup opcode args', + bcopts => '-exec', + #fail => 1, # uncomment to see real padsv args: [$a:491,492] + code => sub {my $a}, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 1 <;> nextstate(main 56 optree_concise.t:96) v +# 2 <0> padsv[$a:56,57] M/LVINTRO +# 3 <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 56 optree_concise.t:96) v +# 2 <0> padsv[$a:56,57] M/LVINTRO +# 3 <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + +################################# +pass("CANONICAL B::Concise EXAMPLE"); + +checkOptree ( name => 'canonical example w -basic', + bcopts => '-basic', + code => sub{$a=$b+42}, + crossfail => 1, + debug => 1, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 7 <1> leavesub[1 ref] K/REFC,1 ->(end) +# - <@> lineseq KP ->7 +# 1 <;> nextstate(main 380 optree_selftest.t:139) v ->2 +# 6 <2> sassign sKS/2 ->7 +# 4 <2> add[t3] sK/2 ->5 +# - <1> ex-rv2sv sK/1 ->3 +# 2 <#> gvsv[*b] s ->3 +# 3 <$> const[IV 42] s ->4 +# - <1> ex-rv2sv sKRM*/1 ->6 +# 5 <#> gvsv[*a] s ->6 +EOT_EOT +# 7 <1> leavesub[1 ref] K/REFC,1 ->(end) +# - <@> lineseq KP ->7 +# 1 <;> nextstate(main 60 optree_concise.t:122) v ->2 +# 6 <2> sassign sKS/2 ->7 +# 4 <2> add[t1] sK/2 ->5 +# - <1> ex-rv2sv sK/1 ->3 +# 2 <$> gvsv(*b) s ->3 +# 3 <$> const(IV 42) s ->4 +# - <1> ex-rv2sv sKRM*/1 ->6 +# 5 <$> gvsv(*a) s ->6 +EONT_EONT + +checkOptree ( name => 'canonical example w -exec', + bcopts => '-exec', + code => sub{$a=$b+42}, + crossfail => 1, + retry => 1, + debug => 1, + xtestfail => 1, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 1 <;> nextstate(main 61 optree_concise.t:139) v +# 2 <#> gvsv[*b] s +# 3 <$> const[IV 42] s +# 4 <2> add[t3] sK/2 +# 5 <#> gvsv[*a] s +# 6 <2> sassign sKS/2 +# 7 <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 61 optree_concise.t:139) v +# 2 <$> gvsv(*b) s +# 3 <$> const(IV 42) s +# 4 <2> add[t1] sK/2 +# 5 <$> gvsv(*a) s +# 6 <2> sassign sKS/2 +# 7 <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + +checkOptree ( name => 'tree reftext is messy cut-paste', + skip => 1); + +} # skip + +__END__ + diff --git a/gnu/usr.bin/perl/ext/B/t/optree_concise.t b/gnu/usr.bin/perl/ext/B/t/optree_concise.t new file mode 100755 index 00000000000..97140c1d0d0 --- /dev/null +++ b/gnu/usr.bin/perl/ext/B/t/optree_concise.t @@ -0,0 +1,458 @@ +#!perl + +BEGIN { + chdir 't'; + @INC = ('../lib', '../ext/B/t'); + require Config; + if (($Config::Config{'extensions'} !~ /\bB\b/) ){ + print "1..0 # Skip -- Perl configured without B module\n"; + exit 0; + } + require './test.pl'; +} + +# import checkOptree(), and %gOpts (containing test state) +use OptreeCheck; # ALSO DOES @ARGV HANDLING !!!!!! +use Config; + +plan tests => 24; +SKIP: { +skip "no perlio in this build", 24 unless $Config::Config{useperlio}; + +$SIG{__WARN__} = sub { + my $err = shift; + $err =~ m/Subroutine re::(un)?install redefined/ and return; +}; +################################# +pass("CANONICAL B::Concise EXAMPLE"); + +checkOptree ( name => 'canonical example w -basic', + bcopts => '-basic', + code => sub{$a=$b+42}, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 7 <1> leavesub[\d+ refs?] K/REFC,1 ->(end) +# - <@> lineseq KP ->7 +# 1 <;> nextstate(foo bar) v ->2 +# 6 <2> sassign sKS/2 ->7 +# 4 <2> add[t\d+] sK/2 ->5 +# - <1> ex-rv2sv sK/1 ->3 +# 2 <#> gvsv[*b] s ->3 +# 3 <$> const[IV 42] s ->4 +# - <1> ex-rv2sv sKRM*/1 ->6 +# 5 <#> gvsv[*a] s ->6 +EOT_EOT +# 7 <1> leavesub[1 ref] K/REFC,1 ->(end) +# - <@> lineseq KP ->7 +# 1 <;> nextstate(main 60 optree_concise.t:122) v ->2 +# 6 <2> sassign sKS/2 ->7 +# 4 <2> add[t1] sK/2 ->5 +# - <1> ex-rv2sv sK/1 ->3 +# 2 <$> gvsv(*b) s ->3 +# 3 <$> const(IV 42) s ->4 +# - <1> ex-rv2sv sKRM*/1 ->6 +# 5 <$> gvsv(*a) s ->6 +EONT_EONT + +checkOptree ( name => 'canonical example w -exec', + bcopts => '-exec', + code => sub{$a=$b+42}, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 1 <;> nextstate(main 61 optree_concise.t:139) v +# 2 <#> gvsv[*b] s +# 3 <$> const[IV 42] s +# 4 <2> add[t3] sK/2 +# 5 <#> gvsv[*a] s +# 6 <2> sassign sKS/2 +# 7 <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 61 optree_concise.t:139) v +# 2 <$> gvsv(*b) s +# 3 <$> const(IV 42) s +# 4 <2> add[t1] sK/2 +# 5 <$> gvsv(*a) s +# 6 <2> sassign sKS/2 +# 7 <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + +################################# +pass("B::Concise OPTION TESTS"); + +checkOptree ( name => '-base3 sticky-exec', + bcopts => '-base3', + code => sub{$a=$b+42}, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +1 <;> dbstate(main 24 optree_concise.t:132) v +2 <#> gvsv[*b] s +10 <$> const[IV 42] s +11 <2> add[t3] sK/2 +12 <#> gvsv[*a] s +20 <2> sassign sKS/2 +21 <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 62 optree_concise.t:161) v +# 2 <$> gvsv(*b) s +# 10 <$> const(IV 42) s +# 11 <2> add[t1] sK/2 +# 12 <$> gvsv(*a) s +# 20 <2> sassign sKS/2 +# 21 <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + +checkOptree ( name => 'sticky-base3, -basic over sticky-exec', + bcopts => '-basic', + code => sub{$a=$b+42}, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +21 <1> leavesub[1 ref] K/REFC,1 ->(end) +- <@> lineseq KP ->21 +1 <;> nextstate(main 32 optree_concise.t:164) v ->2 +20 <2> sassign sKS/2 ->21 +11 <2> add[t3] sK/2 ->12 +- <1> ex-rv2sv sK/1 ->10 +2 <#> gvsv[*b] s ->10 +10 <$> const[IV 42] s ->11 +- <1> ex-rv2sv sKRM*/1 ->20 +12 <#> gvsv[*a] s ->20 +EOT_EOT +# 21 <1> leavesub[1 ref] K/REFC,1 ->(end) +# - <@> lineseq KP ->21 +# 1 <;> nextstate(main 63 optree_concise.t:186) v ->2 +# 20 <2> sassign sKS/2 ->21 +# 11 <2> add[t1] sK/2 ->12 +# - <1> ex-rv2sv sK/1 ->10 +# 2 <$> gvsv(*b) s ->10 +# 10 <$> const(IV 42) s ->11 +# - <1> ex-rv2sv sKRM*/1 ->20 +# 12 <$> gvsv(*a) s ->20 +EONT_EONT + +checkOptree ( name => '-base4', + bcopts => [qw/ -basic -base4 /], + code => sub{$a=$b+42}, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +13 <1> leavesub[1 ref] K/REFC,1 ->(end) +- <@> lineseq KP ->13 +1 <;> nextstate(main 26 optree_concise.t:145) v ->2 +12 <2> sassign sKS/2 ->13 +10 <2> add[t3] sK/2 ->11 +- <1> ex-rv2sv sK/1 ->3 +2 <#> gvsv[*b] s ->3 +3 <$> const[IV 42] s ->10 +- <1> ex-rv2sv sKRM*/1 ->12 +11 <#> gvsv[*a] s ->12 +EOT_EOT +# 13 <1> leavesub[1 ref] K/REFC,1 ->(end) +# - <@> lineseq KP ->13 +# 1 <;> nextstate(main 64 optree_concise.t:193) v ->2 +# 12 <2> sassign sKS/2 ->13 +# 10 <2> add[t1] sK/2 ->11 +# - <1> ex-rv2sv sK/1 ->3 +# 2 <$> gvsv(*b) s ->3 +# 3 <$> const(IV 42) s ->10 +# - <1> ex-rv2sv sKRM*/1 ->12 +# 11 <$> gvsv(*a) s ->12 +EONT_EONT + +checkOptree ( name => "restore -base36 default", + bcopts => [qw/ -basic -base36 /], + code => sub{$a}, + crossfail => 1, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +3 <1> leavesub[1 ref] K/REFC,1 ->(end) +- <@> lineseq KP ->3 +1 <;> nextstate(main 27 optree_concise.t:161) v ->2 +- <1> ex-rv2sv sK/1 ->- +2 <#> gvsv[*a] s ->3 +EOT_EOT +# 3 <1> leavesub[1 ref] K/REFC,1 ->(end) +# - <@> lineseq KP ->3 +# 1 <;> nextstate(main 65 optree_concise.t:210) v ->2 +# - <1> ex-rv2sv sK/1 ->- +# 2 <$> gvsv(*a) s ->3 +EONT_EONT + +checkOptree ( name => "terse basic", + bcopts => [qw/ -basic -terse /], + code => sub{$a}, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +UNOP (0x82b0918) leavesub [1] + LISTOP (0x82b08d8) lineseq + COP (0x82b0880) nextstate + UNOP (0x82b0860) null [15] + PADOP (0x82b0840) gvsv GV (0x82a818c) *a +EOT_EOT +# UNOP (0x8282310) leavesub [1] +# LISTOP (0x82822f0) lineseq +# COP (0x82822b8) nextstate +# UNOP (0x812fc20) null [15] +# SVOP (0x812fc00) gvsv GV (0x814692c) *a +EONT_EONT + +checkOptree ( name => "sticky-terse exec", + bcopts => [qw/ -exec /], + code => sub{$a}, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +COP (0x82b0d70) nextstate +PADOP (0x82b0d30) gvsv GV (0x82a818c) *a +UNOP (0x82b0e08) leavesub [1] +EOT_EOT +# COP (0x82828e0) nextstate +# SVOP (0x82828a0) gvsv GV (0x814692c) *a +# UNOP (0x8282938) leavesub [1] +EONT_EONT + +pass("OPTIONS IN CMDLINE MODE"); + +checkOptree ( name => 'cmdline invoke -basic works', + prog => 'sort @a', + #bcopts => '-basic', # default + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 7 <@> leave[1 ref] vKP/REFC ->(end) +# 1 <0> enter ->2 +# 2 <;> nextstate(main 1 -e:1) v ->3 +# 6 <@> sort vK ->7 +# 3 <0> pushmark s ->4 +# 5 <1> rv2av[t2] lK/1 ->6 +# 4 <#> gv[*a] s ->5 +EOT_EOT +# 7 <@> leave[1 ref] vKP/REFC ->(end) +# 1 <0> enter ->2 +# 2 <;> nextstate(main 1 -e:1) v ->3 +# 6 <@> sort vK ->7 +# 3 <0> pushmark s ->4 +# 5 <1> rv2av[t1] lK/1 ->6 +# 4 <$> gv(*a) s ->5 +EONT_EONT + +checkOptree ( name => 'cmdline invoke -exec works', + prog => 'sort @a', + bcopts => '-exec', + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +1 <0> enter +2 <;> nextstate(main 1 -e:1) v +3 <0> pushmark s +4 <#> gv[*a] s +5 <1> rv2av[t2] lK/1 +6 <@> sort vK +7 <@> leave[1 ref] vKP/REFC +EOT_EOT +# 1 <0> enter +# 2 <;> nextstate(main 1 -e:1) v +# 3 <0> pushmark s +# 4 <$> gv(*a) s +# 5 <1> rv2av[t1] lK/1 +# 6 <@> sort vK +# 7 <@> leave[1 ref] vKP/REFC +EONT_EONT + +; +$DB::single=1; +checkOptree + ( name => 'cmdline self-strict compile err using prog', + prog => 'use strict; sort @a', + bcopts => [qw/ -basic -concise -exec /], + errs => 'Global symbol "@a" requires explicit package name at .*? line 1.', + ); + +checkOptree + ( name => 'cmdline self-strict compile err using code', + code => 'use strict; sort @a', + bcopts => [qw/ -basic -concise -exec /], + #noanchors => 1, + errs => 'Global symbol "@a" requires explicit package name at .*? line 1.', + ); + +checkOptree + ( name => 'useless use of sort in void context', + prog => 'our @a; sort @a', + bcopts => [qw/ -basic -concise -exec /], + errs => 'Useless use of sort in void context at -e line 1.', + ); + +checkOptree + ( name => 'cmdline -basic -concise -exec works', + prog => 'our @a; sort @a', + bcopts => [qw/ -basic -concise -exec /], + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 1 <0> enter +# 2 <;> nextstate(main 1 -e:1) v +# 3 <#> gv[*a] s +# 4 <1> rv2av[t3] vK/OURINTR,1 +# 5 <;> nextstate(main 2 -e:1) v +# 6 <0> pushmark s +# 7 <#> gv[*a] s +# 8 <1> rv2av[t5] lK/1 +# 9 <@> sort vK +# a <@> leave[1 ref] vKP/REFC +EOT_EOT +# 1 <0> enter +# 2 <;> nextstate(main 1 -e:1) v +# 3 <$> gv(*a) s +# 4 <1> rv2av[t2] vK/OURINTR,1 +# 5 <;> nextstate(main 2 -e:1) v +# 6 <0> pushmark s +# 7 <$> gv(*a) s +# 8 <1> rv2av[t3] lK/1 +# 9 <@> sort vK +# a <@> leave[1 ref] vKP/REFC +EONT_EONT + + +################################# +pass("B::Concise STYLE/CALLBACK TESTS"); + +use B::Concise qw( walk_output add_style set_style_standard add_callback ); + +# new relative style, added by set_up_relative_test() +@stylespec = + ( "#hyphseq2 (*( (x( ;)x))*)<#classsym> " + . "#exname#arg(?([#targarglife])?)~#flags(?(/#privateb)?)(x(;~->#next)x) " + . "(x(;~=> #extra)x)\n" # new 'variable' used here + + , " (*( )*) goto #seq\n" + , "(?(<#seq>)?)#exname#arg(?([#targarglife])?)" + #. "(x(;~=> #extra)x)\n" # new 'variable' used here + ); + +sub set_up_relative_test { + # add a new style, and a callback which adds an 'extra' property + + add_style ( "relative" => @stylespec ); + #set_style_standard ( "relative" ); + + add_callback + ( sub { + my ($h, $op, $format, $level, $style) = @_; + + # callback marks up const ops + $h->{arg} .= ' CALLBACK' if $h->{name} eq 'const'; + $h->{extra} = ''; + + if ($lastnext and $$lastnext != $$op) { + $h->{goto} = ($h->{seq} eq '-') + ? 'unresolved' : $h->{seq}; + } + + # 2 style specific behaviors + if ($style eq 'relative') { + $h->{extra} = 'RELATIVE'; + $h->{arg} .= ' RELATIVE' if $h->{name} eq 'leavesub'; + } + elsif ($style eq 'scope') { + # supress printout entirely + $$format="" unless grep { $h->{name} eq $_ } @scopeops; + } + }); +} + +################################# +set_up_relative_test(); +pass("set_up_relative_test, new callback installed"); + +checkOptree ( name => 'callback used, independent of style', + bcopts => [qw/ -concise -exec /], + code => sub{$a=$b+42}, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +1 <;> nextstate(main 76 optree_concise.t:337) v +2 <#> gvsv[*b] s +3 <$> const[IV 42] CALLBACK s +4 <2> add[t3] sK/2 +5 <#> gvsv[*a] s +6 <2> sassign sKS/2 +7 <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 455 optree_concise.t:328) v +# 2 <$> gvsv(*b) s +# 3 <$> const(IV 42) CALLBACK s +# 4 <2> add[t1] sK/2 +# 5 <$> gvsv(*a) s +# 6 <2> sassign sKS/2 +# 7 <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + +checkOptree ( name => "new 'relative' style, -exec mode", + bcopts => [qw/ -basic -relative /], + code => sub{$a=$b+42}, + crossfail => 1, + #retry => 1, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +7 <1> leavesub RELATIVE[1 ref] K ->(end) => RELATIVE +- <@> lineseq KP ->7 => RELATIVE +1 <;> nextstate(main 49 optree_concise.t:309) v ->2 => RELATIVE +6 <2> sassign sKS ->7 => RELATIVE +4 <2> add[t3] sK ->5 => RELATIVE +- <1> ex-rv2sv sK ->3 => RELATIVE +2 <#> gvsv[*b] s ->3 => RELATIVE +3 <$> const[IV 42] CALLBACK s ->4 => RELATIVE +- <1> ex-rv2sv sKRM* ->6 => RELATIVE +5 <#> gvsv[*a] s ->6 => RELATIVE +EOT_EOT +# 7 <1> leavesub RELATIVE[1 ref] K ->(end) => RELATIVE +# - <@> lineseq KP ->7 => RELATIVE +# 1 <;> nextstate(main 77 optree_concise.t:353) v ->2 => RELATIVE +# 6 <2> sassign sKS ->7 => RELATIVE +# 4 <2> add[t1] sK ->5 => RELATIVE +# - <1> ex-rv2sv sK ->3 => RELATIVE +# 2 <$> gvsv(*b) s ->3 => RELATIVE +# 3 <$> const(IV 42) CALLBACK s ->4 => RELATIVE +# - <1> ex-rv2sv sKRM* ->6 => RELATIVE +# 5 <$> gvsv(*a) s ->6 => RELATIVE +EONT_EONT + +checkOptree ( name => "both -exec -relative", + bcopts => [qw/ -exec -relative /], + code => sub{$a=$b+42}, + crossfail => 1, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +1 <;> nextstate(main 50 optree_concise.t:326) v +2 <#> gvsv[*b] s +3 <$> const[IV 42] CALLBACK s +4 <2> add[t3] sK +5 <#> gvsv[*a] s +6 <2> sassign sKS +7 <1> leavesub RELATIVE[1 ref] K +EOT_EOT +# 1 <;> nextstate(main 78 optree_concise.t:371) v +# 2 <$> gvsv(*b) s +# 3 <$> const(IV 42) CALLBACK s +# 4 <2> add[t1] sK +# 5 <$> gvsv(*a) s +# 6 <2> sassign sKS +# 7 <1> leavesub RELATIVE[1 ref] K +EONT_EONT + +################################# + +@scopeops = qw( leavesub enter leave nextstate ); +add_style + ( 'scope' # concise copy + , "#hyphseq2 (*( (x( ;)x))*)<#classsym> " + . "#exname#arg(?([#targarglife])?)~#flags(?(/#private)?)(x(;~->#next)x) " + , " (*( )*) goto #seq\n" + , "(?(<#seq>)?)#exname#arg(?([#targarglife])?)" + ); + +checkOptree ( name => "both -exec -scope", + bcopts => [qw/ -exec -scope /], + code => sub{$a=$b+42}, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +1 <;> nextstate(main 50 optree_concise.t:337) v +7 <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +1 <;> nextstate(main 75 optree_concise.t:396) v +7 <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + + +checkOptree ( name => "both -basic -scope", + bcopts => [qw/ -basic -scope /], + code => sub{$a=$b+42}, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +7 <1> leavesub[1 ref] K/REFC,1 ->(end) +1 <;> nextstate(main 51 optree_concise.t:347) v ->2 +EOT_EOT +7 <1> leavesub[1 ref] K/REFC,1 ->(end) +1 <;> nextstate(main 76 optree_concise.t:407) v ->2 +EONT_EONT + +} #skip + diff --git a/gnu/usr.bin/perl/ext/B/t/optree_samples.t b/gnu/usr.bin/perl/ext/B/t/optree_samples.t new file mode 100755 index 00000000000..c51eeaeb353 --- /dev/null +++ b/gnu/usr.bin/perl/ext/B/t/optree_samples.t @@ -0,0 +1,664 @@ +#!perl + +BEGIN { + chdir 't'; + @INC = ('../lib', '../ext/B/t'); + require Config; + if (($Config::Config{'extensions'} !~ /\bB\b/) ){ + print "1..0 # Skip -- Perl configured without B module\n"; + exit 0; + } + if ($] < 5.009) { + print "1..0 # Skip -- TODO - provide golden result regexps for 5.8\n"; + exit 0; + } + require './test.pl'; +} +use OptreeCheck; +use Config; +plan tests => 20; +SKIP: { + skip "no perlio in this build", 20 unless $Config::Config{useperlio}; + +pass("GENERAL OPTREE EXAMPLES"); + +pass("IF,THEN,ELSE, ?:"); + +checkOptree ( name => '-basic sub {if shift print then,else}', + bcopts => '-basic', + code => sub { if (shift) { print "then" } + else { print "else" } + }, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 9 <1> leavesub[1 ref] K/REFC,1 ->(end) +# - <@> lineseq KP ->9 +# 1 <;> nextstate(main 426 optree.t:16) v ->2 +# - <1> null K/1 ->- +# 5 <|> cond_expr(other->6) K/1 ->a +# 4 <1> shift sK/1 ->5 +# 3 <1> rv2av[t2] sKRM/1 ->4 +# 2 <#> gv[*_] s ->3 +# - <@> scope K ->- +# - <0> ex-nextstate v ->6 +# 8 <@> print sK ->9 +# 6 <0> pushmark s ->7 +# 7 <$> const[PV "then"] s ->8 +# f <@> leave KP ->9 +# a <0> enter ->b +# b <;> nextstate(main 424 optree.t:17) v ->c +# e <@> print sK ->f +# c <0> pushmark s ->d +# d <$> const[PV "else"] s ->e +EOT_EOT +# 9 <1> leavesub[1 ref] K/REFC,1 ->(end) +# - <@> lineseq KP ->9 +# 1 <;> nextstate(main 427 optree_samples.t:18) v ->2 +# - <1> null K/1 ->- +# 5 <|> cond_expr(other->6) K/1 ->a +# 4 <1> shift sK/1 ->5 +# 3 <1> rv2av[t1] sKRM/1 ->4 +# 2 <$> gv(*_) s ->3 +# - <@> scope K ->- +# - <0> ex-nextstate v ->6 +# 8 <@> print sK ->9 +# 6 <0> pushmark s ->7 +# 7 <$> const(PV "then") s ->8 +# f <@> leave KP ->9 +# a <0> enter ->b +# b <;> nextstate(main 425 optree_samples.t:19) v ->c +# e <@> print sK ->f +# c <0> pushmark s ->d +# d <$> const(PV "else") s ->e +EONT_EONT + +checkOptree ( name => '-basic (see above, with my $a = shift)', + bcopts => '-basic', + code => sub { my $a = shift; + if ($a) { print "foo" } + else { print "bar" } + }, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# d <1> leavesub[1 ref] K/REFC,1 ->(end) +# - <@> lineseq KP ->d +# 1 <;> nextstate(main 431 optree.t:68) v ->2 +# 6 <2> sassign vKS/2 ->7 +# 4 <1> shift sK/1 ->5 +# 3 <1> rv2av[t3] sKRM/1 ->4 +# 2 <#> gv[*_] s ->3 +# 5 <0> padsv[$a:431,435] sRM*/LVINTRO ->6 +# 7 <;> nextstate(main 435 optree.t:69) v ->8 +# - <1> null K/1 ->- +# 9 <|> cond_expr(other->a) K/1 ->e +# 8 <0> padsv[$a:431,435] s ->9 +# - <@> scope K ->- +# - <0> ex-nextstate v ->a +# c <@> print sK ->d +# a <0> pushmark s ->b +# b <$> const[PV "foo"] s ->c +# j <@> leave KP ->d +# e <0> enter ->f +# f <;> nextstate(main 433 optree.t:70) v ->g +# i <@> print sK ->j +# g <0> pushmark s ->h +# h <$> const[PV "bar"] s ->i +EOT_EOT +# d <1> leavesub[1 ref] K/REFC,1 ->(end) +# - <@> lineseq KP ->d +# 1 <;> nextstate(main 428 optree_samples.t:48) v ->2 +# 6 <2> sassign vKS/2 ->7 +# 4 <1> shift sK/1 ->5 +# 3 <1> rv2av[t2] sKRM/1 ->4 +# 2 <$> gv(*_) s ->3 +# 5 <0> padsv[$a:428,432] sRM*/LVINTRO ->6 +# 7 <;> nextstate(main 432 optree_samples.t:49) v ->8 +# - <1> null K/1 ->- +# 9 <|> cond_expr(other->a) K/1 ->e +# 8 <0> padsv[$a:428,432] s ->9 +# - <@> scope K ->- +# - <0> ex-nextstate v ->a +# c <@> print sK ->d +# a <0> pushmark s ->b +# b <$> const(PV "foo") s ->c +# j <@> leave KP ->d +# e <0> enter ->f +# f <;> nextstate(main 430 optree_samples.t:50) v ->g +# i <@> print sK ->j +# g <0> pushmark s ->h +# h <$> const(PV "bar") s ->i +EONT_EONT + +checkOptree ( name => '-exec sub {if shift print then,else}', + bcopts => '-exec', + code => sub { if (shift) { print "then" } + else { print "else" } + }, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 1 <;> nextstate(main 426 optree.t:16) v +# 2 <#> gv[*_] s +# 3 <1> rv2av[t2] sKRM/1 +# 4 <1> shift sK/1 +# 5 <|> cond_expr(other->6) K/1 +# 6 <0> pushmark s +# 7 <$> const[PV "then"] s +# 8 <@> print sK +# goto 9 +# a <0> enter +# b <;> nextstate(main 424 optree.t:17) v +# c <0> pushmark s +# d <$> const[PV "else"] s +# e <@> print sK +# f <@> leave KP +# 9 <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 436 optree_samples.t:123) v +# 2 <$> gv(*_) s +# 3 <1> rv2av[t1] sKRM/1 +# 4 <1> shift sK/1 +# 5 <|> cond_expr(other->6) K/1 +# 6 <0> pushmark s +# 7 <$> const(PV "then") s +# 8 <@> print sK +# goto 9 +# a <0> enter +# b <;> nextstate(main 434 optree_samples.t:124) v +# c <0> pushmark s +# d <$> const(PV "else") s +# e <@> print sK +# f <@> leave KP +# 9 <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + +checkOptree ( name => '-exec (see above, with my $a = shift)', + bcopts => '-exec', + code => sub { my $a = shift; + if ($a) { print "foo" } + else { print "bar" } + }, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 1 <;> nextstate(main 423 optree.t:16) v +# 2 <#> gv[*_] s +# 3 <1> rv2av[t3] sKRM/1 +# 4 <1> shift sK/1 +# 5 <0> padsv[$a:423,427] sRM*/LVINTRO +# 6 <2> sassign vKS/2 +# 7 <;> nextstate(main 427 optree.t:17) v +# 8 <0> padsv[$a:423,427] s +# 9 <|> cond_expr(other->a) K/1 +# a <0> pushmark s +# b <$> const[PV "foo"] s +# c <@> print sK +# goto d +# e <0> enter +# f <;> nextstate(main 425 optree.t:18) v +# g <0> pushmark s +# h <$> const[PV "bar"] s +# i <@> print sK +# j <@> leave KP +# d <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 437 optree_samples.t:112) v +# 2 <$> gv(*_) s +# 3 <1> rv2av[t2] sKRM/1 +# 4 <1> shift sK/1 +# 5 <0> padsv[$a:437,441] sRM*/LVINTRO +# 6 <2> sassign vKS/2 +# 7 <;> nextstate(main 441 optree_samples.t:113) v +# 8 <0> padsv[$a:437,441] s +# 9 <|> cond_expr(other->a) K/1 +# a <0> pushmark s +# b <$> const(PV "foo") s +# c <@> print sK +# goto d +# e <0> enter +# f <;> nextstate(main 439 optree_samples.t:114) v +# g <0> pushmark s +# h <$> const(PV "bar") s +# i <@> print sK +# j <@> leave KP +# d <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + +checkOptree ( name => '-exec sub { print (shift) ? "foo" : "bar" }', + code => sub { print (shift) ? "foo" : "bar" }, + bcopts => '-exec', + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 1 <;> nextstate(main 428 optree.t:31) v +# 2 <0> pushmark s +# 3 <#> gv[*_] s +# 4 <1> rv2av[t2] sKRM/1 +# 5 <1> shift sK/1 +# 6 <@> print sK +# 7 <|> cond_expr(other->8) K/1 +# 8 <$> const[PV "foo"] s +# goto 9 +# a <$> const[PV "bar"] s +# 9 <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 442 optree_samples.t:144) v +# 2 <0> pushmark s +# 3 <$> gv(*_) s +# 4 <1> rv2av[t1] sKRM/1 +# 5 <1> shift sK/1 +# 6 <@> print sK +# 7 <|> cond_expr(other->8) K/1 +# 8 <$> const(PV "foo") s +# goto 9 +# a <$> const(PV "bar") s +# 9 <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + +pass ("FOREACH"); + +checkOptree ( name => '-exec sub { foreach (1..10) {print "foo $_"} }', + code => sub { foreach (1..10) {print "foo $_"} }, + bcopts => '-exec', + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 1 <;> nextstate(main 443 optree.t:158) v +# 2 <0> pushmark s +# 3 <$> const[IV 1] s +# 4 <$> const[IV 10] s +# 5 <#> gv[*_] s +# 6 <{> enteriter(next->d last->g redo->7) lKS +# e <0> iter s +# f <|> and(other->7) K/1 +# 7 <;> nextstate(main 442 optree.t:158) v +# 8 <0> pushmark s +# 9 <$> const[PV "foo "] s +# a <#> gvsv[*_] s +# b <2> concat[t4] sK/2 +# c <@> print vK +# d <0> unstack s +# goto e +# g <2> leaveloop K/2 +# h <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 444 optree_samples.t:182) v +# 2 <0> pushmark s +# 3 <$> const(IV 1) s +# 4 <$> const(IV 10) s +# 5 <$> gv(*_) s +# 6 <{> enteriter(next->d last->g redo->7) lKS +# e <0> iter s +# f <|> and(other->7) K/1 +# 7 <;> nextstate(main 443 optree_samples.t:182) v +# 8 <0> pushmark s +# 9 <$> const(PV "foo ") s +# a <$> gvsv(*_) s +# b <2> concat[t3] sK/2 +# c <@> print vK +# d <0> unstack s +# goto e +# g <2> leaveloop K/2 +# h <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + +checkOptree ( name => '-basic sub { print "foo $_" foreach (1..10) }', + code => sub { print "foo $_" foreach (1..10) }, + bcopts => '-basic', + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# h <1> leavesub[1 ref] K/REFC,1 ->(end) +# - <@> lineseq KP ->h +# 1 <;> nextstate(main 445 optree.t:167) v ->2 +# 2 <;> nextstate(main 445 optree.t:167) v ->3 +# g <2> leaveloop K/2 ->h +# 7 <{> enteriter(next->d last->g redo->8) lKS ->e +# - <0> ex-pushmark s ->3 +# - <1> ex-list lK ->6 +# 3 <0> pushmark s ->4 +# 4 <$> const[IV 1] s ->5 +# 5 <$> const[IV 10] s ->6 +# 6 <#> gv[*_] s ->7 +# - <1> null K/1 ->g +# f <|> and(other->8) K/1 ->g +# e <0> iter s ->f +# - <@> lineseq sK ->- +# c <@> print vK ->d +# 8 <0> pushmark s ->9 +# - <1> ex-stringify sK/1 ->c +# - <0> ex-pushmark s ->9 +# b <2> concat[t2] sK/2 ->c +# 9 <$> const[PV "foo "] s ->a +# - <1> ex-rv2sv sK/1 ->b +# a <#> gvsv[*_] s ->b +# d <0> unstack s ->e +EOT_EOT +# h <1> leavesub[1 ref] K/REFC,1 ->(end) +# - <@> lineseq KP ->h +# 1 <;> nextstate(main 446 optree_samples.t:192) v ->2 +# 2 <;> nextstate(main 446 optree_samples.t:192) v ->3 +# g <2> leaveloop K/2 ->h +# 7 <{> enteriter(next->d last->g redo->8) lKS ->e +# - <0> ex-pushmark s ->3 +# - <1> ex-list lK ->6 +# 3 <0> pushmark s ->4 +# 4 <$> const(IV 1) s ->5 +# 5 <$> const(IV 10) s ->6 +# 6 <$> gv(*_) s ->7 +# - <1> null K/1 ->g +# f <|> and(other->8) K/1 ->g +# e <0> iter s ->f +# - <@> lineseq sK ->- +# c <@> print vK ->d +# 8 <0> pushmark s ->9 +# - <1> ex-stringify sK/1 ->c +# - <0> ex-pushmark s ->9 +# b <2> concat[t1] sK/2 ->c +# 9 <$> const(PV "foo ") s ->a +# - <1> ex-rv2sv sK/1 ->b +# a <$> gvsv(*_) s ->b +# d <0> unstack s ->e +EONT_EONT + +checkOptree ( name => '-exec -e foreach (1..10) {print qq{foo $_}}', + prog => 'foreach (1..10) {print qq{foo $_}}', + bcopts => '-exec', + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 1 <0> enter +# 2 <;> nextstate(main 2 -e:1) v +# 3 <0> pushmark s +# 4 <$> const[IV 1] s +# 5 <$> const[IV 10] s +# 6 <#> gv[*_] s +# 7 <{> enteriter(next->e last->h redo->8) lKS +# f <0> iter s +# g <|> and(other->8) vK/1 +# 8 <;> nextstate(main 1 -e:1) v +# 9 <0> pushmark s +# a <$> const[PV "foo "] s +# b <#> gvsv[*_] s +# c <2> concat[t4] sK/2 +# d <@> print vK +# e <0> unstack v +# goto f +# h <2> leaveloop vK/2 +# i <@> leave[1 ref] vKP/REFC +EOT_EOT +# 1 <0> enter +# 2 <;> nextstate(main 2 -e:1) v +# 3 <0> pushmark s +# 4 <$> const(IV 1) s +# 5 <$> const(IV 10) s +# 6 <$> gv(*_) s +# 7 <{> enteriter(next->e last->h redo->8) lKS +# f <0> iter s +# g <|> and(other->8) vK/1 +# 8 <;> nextstate(main 1 -e:1) v +# 9 <0> pushmark s +# a <$> const(PV "foo ") s +# b <$> gvsv(*_) s +# c <2> concat[t3] sK/2 +# d <@> print vK +# e <0> unstack v +# goto f +# h <2> leaveloop vK/2 +# i <@> leave[1 ref] vKP/REFC +EONT_EONT + +checkOptree ( name => '-exec sub { print "foo $_" foreach (1..10) }', + code => sub { print "foo $_" foreach (1..10) }, + bcopts => '-exec', + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 1 <;> nextstate(main 445 optree.t:167) v +# 2 <;> nextstate(main 445 optree.t:167) v +# 3 <0> pushmark s +# 4 <$> const[IV 1] s +# 5 <$> const[IV 10] s +# 6 <#> gv[*_] s +# 7 <{> enteriter(next->d last->g redo->8) lKS +# e <0> iter s +# f <|> and(other->8) K/1 +# 8 <0> pushmark s +# 9 <$> const[PV "foo "] s +# a <#> gvsv[*_] s +# b <2> concat[t2] sK/2 +# c <@> print vK +# d <0> unstack s +# goto e +# g <2> leaveloop K/2 +# h <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 447 optree_samples.t:252) v +# 2 <;> nextstate(main 447 optree_samples.t:252) v +# 3 <0> pushmark s +# 4 <$> const(IV 1) s +# 5 <$> const(IV 10) s +# 6 <$> gv(*_) s +# 7 <{> enteriter(next->d last->g redo->8) lKS +# e <0> iter s +# f <|> and(other->8) K/1 +# 8 <0> pushmark s +# 9 <$> const(PV "foo ") s +# a <$> gvsv(*_) s +# b <2> concat[t1] sK/2 +# c <@> print vK +# d <0> unstack s +# goto e +# g <2> leaveloop K/2 +# h <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + +pass("GREP: SAMPLES FROM PERLDOC -F GREP"); + +checkOptree ( name => '@foo = grep(!/^\#/, @bar)', + code => '@foo = grep(!/^\#/, @bar)', + bcopts => '-exec', + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 1 <;> nextstate(main 496 (eval 20):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <#> gv[*bar] s +# 5 <1> rv2av[t4] lKM/1 +# 6 <@> grepstart lK +# 7 <|> grepwhile(other->8)[t5] lK +# 8 </> match(/"^#"/) s/RTIME +# 9 <1> not sK/1 +# goto 7 +# a <0> pushmark s +# b <#> gv[*foo] s +# c <1> rv2av[t2] lKRM*/1 +# d <2> aassign[t6] KS/COMMON +# e <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 496 (eval 20):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <$> gv(*bar) s +# 5 <1> rv2av[t2] lKM/1 +# 6 <@> grepstart lK +# 7 <|> grepwhile(other->8)[t3] lK +# 8 </> match(/"^\\#"/) s/RTIME +# 9 <1> not sK/1 +# goto 7 +# a <0> pushmark s +# b <$> gv(*foo) s +# c <1> rv2av[t1] lKRM*/1 +# d <2> aassign[t4] KS/COMMON +# e <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + + +pass("MAP: SAMPLES FROM PERLDOC -F MAP"); + +checkOptree ( name => '%h = map { getkey($_) => $_ } @a', + code => '%h = map { getkey($_) => $_ } @a', + bcopts => '-exec', + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 1 <;> nextstate(main 501 (eval 22):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <#> gv[*a] s +# 5 <1> rv2av[t8] lKM/1 +# 6 <@> mapstart lK* +# 7 <|> mapwhile(other->8)[t9] lK +# 8 <0> enter l +# 9 <;> nextstate(main 500 (eval 22):1) v +# a <0> pushmark s +# b <0> pushmark s +# c <#> gvsv[*_] s +# d <#> gv[*getkey] s/EARLYCV +# e <1> entersub[t5] lKS/TARG,1 +# f <#> gvsv[*_] s +# g <@> list lK +# h <@> leave lKP +# goto 7 +# i <0> pushmark s +# j <#> gv[*h] s +# k <1> rv2hv[t2] lKRM*/1 +# l <2> aassign[t10] KS/COMMON +# m <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 501 (eval 22):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <$> gv(*a) s +# 5 <1> rv2av[t3] lKM/1 +# 6 <@> mapstart lK* +# 7 <|> mapwhile(other->8)[t4] lK +# 8 <0> enter l +# 9 <;> nextstate(main 500 (eval 22):1) v +# a <0> pushmark s +# b <0> pushmark s +# c <$> gvsv(*_) s +# d <$> gv(*getkey) s/EARLYCV +# e <1> entersub[t2] lKS/TARG,1 +# f <$> gvsv(*_) s +# g <@> list lK +# h <@> leave lKP +# goto 7 +# i <0> pushmark s +# j <$> gv(*h) s +# k <1> rv2hv[t1] lKRM*/1 +# l <2> aassign[t5] KS/COMMON +# m <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + +checkOptree ( name => '%h=(); for $_(@a){$h{getkey($_)} = $_}', + code => '%h=(); for $_(@a){$h{getkey($_)} = $_}', + bcopts => '-exec', + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 1 <;> nextstate(main 505 (eval 24):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <#> gv[*h] s +# 5 <1> rv2hv[t2] lKRM*/1 +# 6 <2> aassign[t3] vKS +# 7 <;> nextstate(main 506 (eval 24):1) v +# 8 <0> pushmark sM +# 9 <#> gv[*a] s +# a <1> rv2av[t6] sKRM/1 +# b <#> gv[*_] s +# c <1> rv2gv sKRM/1 +# d <{> enteriter(next->o last->r redo->e) lKS +# p <0> iter s +# q <|> and(other->e) K/1 +# e <;> nextstate(main 505 (eval 24):1) v +# f <#> gvsv[*_] s +# g <#> gv[*h] s +# h <1> rv2hv sKR/1 +# i <0> pushmark s +# j <#> gvsv[*_] s +# k <#> gv[*getkey] s/EARLYCV +# l <1> entersub[t10] sKS/TARG,1 +# m <2> helem sKRM*/2 +# n <2> sassign vKS/2 +# o <0> unstack s +# goto p +# r <2> leaveloop K/2 +# s <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 505 (eval 24):1) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <$> gv(*h) s +# 5 <1> rv2hv[t1] lKRM*/1 +# 6 <2> aassign[t2] vKS +# 7 <;> nextstate(main 506 (eval 24):1) v +# 8 <0> pushmark sM +# 9 <$> gv(*a) s +# a <1> rv2av[t3] sKRM/1 +# b <$> gv(*_) s +# c <1> rv2gv sKRM/1 +# d <{> enteriter(next->o last->r redo->e) lKS +# p <0> iter s +# q <|> and(other->e) K/1 +# e <;> nextstate(main 505 (eval 24):1) v +# f <$> gvsv(*_) s +# g <$> gv(*h) s +# h <1> rv2hv sKR/1 +# i <0> pushmark s +# j <$> gvsv(*_) s +# k <$> gv(*getkey) s/EARLYCV +# l <1> entersub[t4] sKS/TARG,1 +# m <2> helem sKRM*/2 +# n <2> sassign vKS/2 +# o <0> unstack s +# goto p +# r <2> leaveloop K/2 +# s <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + +checkOptree ( name => 'map $_+42, 10..20', + code => 'map $_+42, 10..20', + bcopts => '-exec', + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 1 <;> nextstate(main 497 (eval 20):1) v +# 2 <0> pushmark s +# 3 <$> const[AV ] s +# 4 <1> rv2av lKPM/1 +# 5 <@> mapstart K +# 6 <|> mapwhile(other->7)[t7] K +# 7 <#> gvsv[*_] s +# 8 <$> const[IV 42] s +# 9 <2> add[t2] sK/2 +# goto 6 +# a <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 511 (eval 26):1) v +# 2 <0> pushmark s +# 3 <$> const(AV ) s +# 4 <1> rv2av lKPM/1 +# 5 <@> mapstart K +# 6 <|> mapwhile(other->7)[t4] K +# 7 <$> gvsv(*_) s +# 8 <$> const(IV 42) s +# 9 <2> add[t1] sK/2 +# goto 6 +# a <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + +pass("CONSTANTS"); + +checkOptree ( name => '-e use constant j => qq{junk}; print j', + prog => 'use constant j => qq{junk}; print j', + bcopts => '-exec', + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 1 <0> enter +# 2 <;> nextstate(main 71 -e:1) v +# 3 <0> pushmark s +# 4 <$> const[PV "junk"] s +# 5 <@> print vK +# 6 <@> leave[1 ref] vKP/REFC +EOT_EOT +# 1 <0> enter +# 2 <;> nextstate(main 71 -e:1) v +# 3 <0> pushmark s +# 4 <$> const(PV "junk") s +# 5 <@> print vK +# 6 <@> leave[1 ref] vKP/REFC +EONT_EONT + +} # skip + +__END__ + +####################################################################### + +checkOptree ( name => '-exec sub a { print (shift) ? "foo" : "bar" }', + code => sub { print (shift) ? "foo" : "bar" }, + bcopts => '-exec', + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); + insert threaded reference here +EOT_EOT + insert non-threaded reference here +EONT_EONT + diff --git a/gnu/usr.bin/perl/ext/B/t/optree_sort.t b/gnu/usr.bin/perl/ext/B/t/optree_sort.t new file mode 100755 index 00000000000..b7615d941fc --- /dev/null +++ b/gnu/usr.bin/perl/ext/B/t/optree_sort.t @@ -0,0 +1,297 @@ +#!perl + +BEGIN { + chdir 't'; + @INC = ('../lib', '../ext/B/t'); + require Config; + if (($Config::Config{'extensions'} !~ /\bB\b/) ){ + print "1..0 # Skip -- Perl configured without B module\n"; + exit 0; + } + require './test.pl'; +} +use OptreeCheck; +use Config; +plan tests => 11; + +SKIP: { +skip "no perlio in this build", 11 unless $Config::Config{useperlio}; + +pass("SORT OPTIMIZATION"); + +checkOptree ( name => 'sub {sort @a}', + code => sub {sort @a}, + bcopts => '-exec', + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 1 <;> nextstate(main 424 optree_sort.t:14) v +# 2 <0> pushmark s +# 3 <#> gv[*a] s +# 4 <1> rv2av[t2] lK/1 +# 5 <@> sort K +# 6 <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 424 optree_sort.t:14) v +# 2 <0> pushmark s +# 3 <$> gv(*a) s +# 4 <1> rv2av[t1] lK/1 +# 5 <@> sort K +# 6 <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + +checkOptree ( name => 'sort @a', + prog => 'sort @a', + bcopts => '-exec', + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +1 <0> enter +2 <;> nextstate(main 1 -e:1) v +3 <0> pushmark s +4 <#> gv[*a] s +5 <1> rv2av[t2] lK/1 +6 <@> sort vK +7 <@> leave[1 ref] vKP/REFC +EOT_EOT +# 1 <0> enter +# 2 <;> nextstate(main 1 -e:1) v +# 3 <0> pushmark s +# 4 <$> gv(*a) s +# 5 <1> rv2av[t1] lK/1 +# 6 <@> sort vK +# 7 <@> leave[1 ref] vKP/REFC +EONT_EONT + +checkOptree ( name => 'sub {@a = sort @a}', + code => sub {@a = sort @a}, + bcopts => '-exec', + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +1 <;> nextstate(main -438 optree.t:244) v +2 <0> pushmark s +3 <0> pushmark s +4 <#> gv[*a] s +5 <1> rv2av[t4] lK/1 +6 <@> sort lK +7 <0> pushmark s +8 <#> gv[*a] s +9 <1> rv2av[t2] lKRM*/1 +a <2> aassign[t\d+] KS/COMMON +b <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 65 optree.t:311) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <$> gv(*a) s +# 5 <1> rv2av[t2] lK/1 +# 6 <@> sort lK +# 7 <0> pushmark s +# 8 <$> gv(*a) s +# 9 <1> rv2av[t1] lKRM*/1 +# a <2> aassign[t3] KS/COMMON +# b <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + +checkOptree ( name => '@a = sort @a', + prog => '@a = sort @a', + bcopts => '-exec', + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +1 <0> enter +2 <;> nextstate(main 1 -e:1) v +3 <0> pushmark s +4 <0> pushmark s +5 <#> gv[*a] s +6 <1> rv2av[t4] lKRM*/1 +7 <@> sort lK/INPLACE +8 <@> leave[1 ref] vKP/REFC +EOT_EOT +# 1 <0> enter +# 2 <;> nextstate(main 1 -e:1) v +# 3 <0> pushmark s +# 4 <0> pushmark s +# 5 <$> gv(*a) s +# 6 <1> rv2av[t2] lKRM*/1 +# 7 <@> sort lK/INPLACE +# 8 <@> leave[1 ref] vKP/REFC +EONT_EONT + +checkOptree ( name => 'sub {@a = sort @a; reverse @a}', + code => sub {@a = sort @a; reverse @a}, + bcopts => '-exec', + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +1 <;> nextstate(main -438 optree.t:286) v +2 <0> pushmark s +3 <0> pushmark s +4 <#> gv[*a] s +5 <1> rv2av[t4] lKRM*/1 +6 <@> sort lK/INPLACE +7 <;> nextstate(main -438 optree.t:288) v +8 <0> pushmark s +9 <#> gv[*a] s +a <1> rv2av[t7] lK/1 +b <@> reverse[t8] K/1 +c <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 66 optree.t:345) v +# 2 <0> pushmark s +# 3 <0> pushmark s +# 4 <$> gv(*a) s +# 5 <1> rv2av[t2] lKRM*/1 +# 6 <@> sort lK/INPLACE +# 7 <;> nextstate(main 66 optree.t:346) v +# 8 <0> pushmark s +# 9 <$> gv(*a) s +# a <1> rv2av[t4] lK/1 +# b <@> reverse[t5] K/1 +# c <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + +checkOptree ( name => '@a = sort @a; reverse @a', + prog => '@a = sort @a; reverse @a', + bcopts => '-exec', + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +1 <0> enter +2 <;> nextstate(main 1 -e:1) v +3 <0> pushmark s +4 <0> pushmark s +5 <#> gv[*a] s +6 <1> rv2av[t4] lKRM*/1 +7 <@> sort lK/INPLACE +8 <;> nextstate(main 1 -e:1) v +9 <0> pushmark s +a <#> gv[*a] s +b <1> rv2av[t7] lK/1 +c <@> reverse[t8] vK/1 +d <@> leave[1 ref] vKP/REFC +EOT_EOT +# 1 <0> enter +# 2 <;> nextstate(main 1 -e:1) v +# 3 <0> pushmark s +# 4 <0> pushmark s +# 5 <$> gv(*a) s +# 6 <1> rv2av[t2] lKRM*/1 +# 7 <@> sort lK/INPLACE +# 8 <;> nextstate(main 1 -e:1) v +# 9 <0> pushmark s +# a <$> gv(*a) s +# b <1> rv2av[t4] lK/1 +# c <@> reverse[t5] vK/1 +# d <@> leave[1 ref] vKP/REFC +EONT_EONT + +checkOptree ( name => 'sub {my @a; @a = sort @a}', + code => sub {my @a; @a = sort @a}, + bcopts => '-exec', + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +1 <;> nextstate(main -437 optree.t:254) v +2 <0> padav[@a:-437,-436] vM/LVINTRO +3 <;> nextstate(main -436 optree.t:256) v +4 <0> pushmark s +5 <0> pushmark s +6 <0> padav[@a:-437,-436] l +7 <@> sort lK +8 <0> pushmark s +9 <0> padav[@a:-437,-436] lRM* +a <2> aassign[t\d+] KS/COMMON +b <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 427 optree_sort.t:172) v +# 2 <0> padav[@a:427,428] vM/LVINTRO +# 3 <;> nextstate(main 428 optree_sort.t:173) v +# 4 <0> pushmark s +# 5 <0> pushmark s +# 6 <0> padav[@a:427,428] l +# 7 <@> sort lK +# 8 <0> pushmark s +# 9 <0> padav[@a:427,428] lRM* +# a <2> aassign[t2] KS/COMMON +# b <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + +checkOptree ( name => 'my @a; @a = sort @a', + prog => 'my @a; @a = sort @a', + bcopts => '-exec', + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +1 <0> enter +2 <;> nextstate(main 1 -e:1) v +3 <0> padav[@a:1,2] vM/LVINTRO +4 <;> nextstate(main 2 -e:1) v +5 <0> pushmark s +6 <0> pushmark s +7 <0> padav[@a:1,2] lRM* +8 <@> sort lK/INPLACE +9 <@> leave[1 ref] vKP/REFC +EOT_EOT +# 1 <0> enter +# 2 <;> nextstate(main 1 -e:1) v +# 3 <0> padav[@a:1,2] vM/LVINTRO +# 4 <;> nextstate(main 2 -e:1) v +# 5 <0> pushmark s +# 6 <0> pushmark s +# 7 <0> padav[@a:1,2] lRM* +# 8 <@> sort lK/INPLACE +# 9 <@> leave[1 ref] vKP/REFC +EONT_EONT + +checkOptree ( name => 'sub {my @a; @a = sort @a; push @a, 1}', + code => sub {my @a; @a = sort @a; push @a, 1}, + bcopts => '-exec', + debug => 0, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +1 <;> nextstate(main -437 optree.t:325) v +2 <0> padav[@a:-437,-436] vM/LVINTRO +3 <;> nextstate(main -436 optree.t:325) v +4 <0> pushmark s +5 <0> pushmark s +6 <0> padav[@a:-437,-436] lRM* +7 <@> sort lK/INPLACE +8 <;> nextstate(main -436 optree.t:325) v +9 <0> pushmark s +a <0> padav[@a:-437,-436] lRM +b <$> const[IV 1] s +c <@> push[t3] sK/2 +d <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 429 optree_sort.t:219) v +# 2 <0> padav[@a:429,430] vM/LVINTRO +# 3 <;> nextstate(main 430 optree_sort.t:220) v +# 4 <0> pushmark s +# 5 <0> pushmark s +# 6 <0> padav[@a:429,430] lRM* +# 7 <@> sort lK/INPLACE +# 8 <;> nextstate(main 430 optree_sort.t:220) v +# 9 <0> pushmark s +# a <0> padav[@a:429,430] lRM +# b <$> const(IV 1) s +# c <@> push[t3] sK/2 +# d <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + +checkOptree ( name => 'sub {my @a; @a = sort @a; 1}', + code => sub {my @a; @a = sort @a; 1}, + bcopts => '-exec', + debug => 0, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +1 <;> nextstate(main -437 optree.t:325) v +2 <0> padav[@a:-437,-436] vM/LVINTRO +3 <;> nextstate(main -436 optree.t:325) v +4 <0> pushmark s +5 <0> pushmark s +6 <0> padav[@a:-437,-436] lRM* +7 <@> sort lK/INPLACE +8 <;> nextstate(main -436 optree.t:346) v +9 <$> const[IV 1] s +a <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 431 optree_sort.t:250) v +# 2 <0> padav[@a:431,432] vM/LVINTRO +# 3 <;> nextstate(main 432 optree_sort.t:251) v +# 4 <0> pushmark s +# 5 <0> pushmark s +# 6 <0> padav[@a:431,432] lRM* +# 7 <@> sort lK/INPLACE +# 8 <;> nextstate(main 432 optree_sort.t:251) v +# 9 <$> const(IV 1) s +# a <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + +} #skip + +__END__ + diff --git a/gnu/usr.bin/perl/ext/B/t/optree_specials.t b/gnu/usr.bin/perl/ext/B/t/optree_specials.t new file mode 100755 index 00000000000..75d2a8ab1a0 --- /dev/null +++ b/gnu/usr.bin/perl/ext/B/t/optree_specials.t @@ -0,0 +1,272 @@ +#!./perl + +BEGIN { + chdir 't'; + @INC = ('../lib', '../ext/B/t'); + require Config; + if (($Config::Config{'extensions'} !~ /\bB\b/) ){ + print "1..0 # Skip -- Perl configured without B module\n"; + exit 0; + } + require './test.pl'; +} + +# import checkOptree(), and %gOpts (containing test state) +use OptreeCheck; # ALSO DOES @ARGV HANDLING !!!!!! +use Config; + +plan tests => 6; + +require_ok("B::Concise"); + +my $out = runperl( + switches => ["-MO=Concise,BEGIN,CHECK,INIT,END,-exec"], + prog => q{$a=$b && print q/foo/}, + stderr => 1 ); + +#print "out:$out\n"; + +my $src = q[our ($beg, $chk, $init, $end) = qq{'foo'}; BEGIN { $beg++ } CHECK { $chk++ } INIT { $init++ } END { $end++ }]; + + + +checkOptree ( name => 'BEGIN', + bcopts => 'BEGIN', + prog => $src, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# BEGIN 1: +# b <1> leavesub[1 ref] K/REFC,1 ->(end) +# - <@> lineseq KP ->b +# 1 <;> nextstate(B::Concise -242 Concise.pm:304) v/2 ->2 +# 3 <1> require sK/1 ->4 +# 2 <$> const[PV "strict.pm"] s/BARE ->3 +# 4 <;> nextstate(B::Concise -242 Concise.pm:304) v/2 ->5 +# - <@> lineseq K ->- +# 5 <;> nextstate(B::Concise -242 Concise.pm:304) /2 ->6 +# a <1> entersub[t1] KS*/TARG,2 ->b +# 6 <0> pushmark s ->7 +# 7 <$> const[PV "strict"] sM ->8 +# 8 <$> const[PV "refs"] sM ->9 +# 9 <$> method_named[PVIV 1520340202] ->a +# BEGIN 2: +# m <1> leavesub[1 ref] K/REFC,1 ->(end) +# - <@> lineseq KP ->m +# c <;> nextstate(B::Concise -227 Concise.pm:327) v/2 ->d +# e <1> require sK/1 ->f +# d <$> const[PV "warnings.pm"] s/BARE ->e +# f <;> nextstate(B::Concise -227 Concise.pm:327) v/2 ->g +# - <@> lineseq K ->- +# g <;> nextstate(B::Concise -227 Concise.pm:327) /2 ->h +# l <1> entersub[t1] KS*/TARG,2 ->m +# h <0> pushmark s ->i +# i <$> const[PV "warnings"] sM ->j +# j <$> const[PV "qw"] sM ->k +# k <$> method_named[PVIV 1520340202] ->l +# BEGIN 3: +# q <1> leavesub[1 ref] K/REFC,1 ->(end) +# - <@> lineseq KP ->q +# n <;> nextstate(main 2 -e:3) v ->o +# p <1> postinc[t3] sK/1 ->q +# - <1> ex-rv2sv sKRM/1 ->p +# o <#> gvsv[*beg] s ->p +EOT_EOT +# BEGIN 1: +# b <1> leavesub[1 ref] K/REFC,1 ->(end) +# - <@> lineseq KP ->b +# 1 <;> nextstate(B::Concise -242 Concise.pm:304) v/2 ->2 +# 3 <1> require sK/1 ->4 +# 2 <$> const(PV "strict.pm") s/BARE ->3 +# 4 <;> nextstate(B::Concise -242 Concise.pm:304) v/2 ->5 +# - <@> lineseq K ->- +# 5 <;> nextstate(B::Concise -242 Concise.pm:304) /2 ->6 +# a <1> entersub[t1] KS*/TARG,2 ->b +# 6 <0> pushmark s ->7 +# 7 <$> const(PV "strict") sM ->8 +# 8 <$> const(PV "refs") sM ->9 +# 9 <$> method_named(PVIV 1520340202) ->a +# BEGIN 2: +# m <1> leavesub[1 ref] K/REFC,1 ->(end) +# - <@> lineseq KP ->m +# c <;> nextstate(B::Concise -227 Concise.pm:327) v/2 ->d +# e <1> require sK/1 ->f +# d <$> const(PV "warnings.pm") s/BARE ->e +# f <;> nextstate(B::Concise -227 Concise.pm:327) v/2 ->g +# - <@> lineseq K ->- +# g <;> nextstate(B::Concise -227 Concise.pm:327) /2 ->h +# l <1> entersub[t1] KS*/TARG,2 ->m +# h <0> pushmark s ->i +# i <$> const(PV "warnings") sM ->j +# j <$> const(PV "qw") sM ->k +# k <$> method_named(PVIV 1520340202) ->l +# BEGIN 3: +# q <1> leavesub[1 ref] K/REFC,1 ->(end) +# - <@> lineseq KP ->q +# n <;> nextstate(main 2 -e:3) v ->o +# p <1> postinc[t2] sK/1 ->q +# - <1> ex-rv2sv sKRM/1 ->p +# o <$> gvsv(*beg) s ->p +EONT_EONT + + +checkOptree ( name => 'END', + bcopts => 'END', + prog => $src, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# END 1: +# 4 <1> leavesub[1 ref] K/REFC,1 ->(end) +# - <@> lineseq KP ->4 +# 1 <;> nextstate(main 5 -e:6) v ->2 +# 3 <1> postinc[t3] sK/1 ->4 +# - <1> ex-rv2sv sKRM/1 ->3 +# 2 <#> gvsv[*end] s ->3 +EOT_EOT +# END 1: +# 4 <1> leavesub[1 ref] K/REFC,1 ->(end) +# - <@> lineseq KP ->4 +# 1 <;> nextstate(main 5 -e:6) v ->2 +# 3 <1> postinc[t2] sK/1 ->4 +# - <1> ex-rv2sv sKRM/1 ->3 +# 2 <$> gvsv(*end) s ->3 +EONT_EONT + + +checkOptree ( name => 'CHECK', + bcopts => 'CHECK', + prog => $src, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# CHECK 1: +# 4 <1> leavesub[1 ref] K/REFC,1 ->(end) +# - <@> lineseq KP ->4 +# 1 <;> nextstate(main 3 -e:4) v ->2 +# 3 <1> postinc[t3] sK/1 ->4 +# - <1> ex-rv2sv sKRM/1 ->3 +# 2 <#> gvsv[*chk] s ->3 +EOT_EOT +# CHECK 1: +# 4 <1> leavesub[1 ref] K/REFC,1 ->(end) +# - <@> lineseq KP ->4 +# 1 <;> nextstate(main 3 -e:4) v ->2 +# 3 <1> postinc[t2] sK/1 ->4 +# - <1> ex-rv2sv sKRM/1 ->3 +# 2 <$> gvsv(*chk) s ->3 +EONT_EONT + + +checkOptree ( name => 'INIT', + bcopts => 'INIT', + #todo => 'get working', + prog => $src, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# INIT 1: +# 4 <1> leavesub[1 ref] K/REFC,1 ->(end) +# - <@> lineseq KP ->4 +# 1 <;> nextstate(main 4 -e:5) v ->2 +# 3 <1> postinc[t3] sK/1 ->4 +# - <1> ex-rv2sv sKRM/1 ->3 +# 2 <#> gvsv[*init] s ->3 +EOT_EOT +# INIT 1: +# 4 <1> leavesub[1 ref] K/REFC,1 ->(end) +# - <@> lineseq KP ->4 +# 1 <;> nextstate(main 4 -e:5) v ->2 +# 3 <1> postinc[t2] sK/1 ->4 +# - <1> ex-rv2sv sKRM/1 ->3 +# 2 <$> gvsv(*init) s ->3 +EONT_EONT + + +checkOptree ( name => 'all of BEGIN END INIT CHECK -exec', + bcopts => [qw/ BEGIN END INIT CHECK -exec /], + #todo => 'get working', + prog => $src, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# BEGIN 1: +# 1 <;> nextstate(B::Concise -242 Concise.pm:304) v/2 +# 2 <$> const[PV "strict.pm"] s/BARE +# 3 <1> require sK/1 +# 4 <;> nextstate(B::Concise -242 Concise.pm:304) v/2 +# 5 <;> nextstate(B::Concise -242 Concise.pm:304) /2 +# 6 <0> pushmark s +# 7 <$> const[PV "strict"] sM +# 8 <$> const[PV "refs"] sM +# 9 <$> method_named[PVIV 1520340202] +# a <1> entersub[t1] KS*/TARG,2 +# b <1> leavesub[1 ref] K/REFC,1 +# BEGIN 2: +# c <;> nextstate(B::Concise -227 Concise.pm:327) v/2 +# d <$> const[PV "warnings.pm"] s/BARE +# e <1> require sK/1 +# f <;> nextstate(B::Concise -227 Concise.pm:327) v/2 +# g <;> nextstate(B::Concise -227 Concise.pm:327) /2 +# h <0> pushmark s +# i <$> const[PV "warnings"] sM +# j <$> const[PV "qw"] sM +# k <$> method_named[PVIV 1520340202] +# l <1> entersub[t1] KS*/TARG,2 +# m <1> leavesub[1 ref] K/REFC,1 +# BEGIN 3: +# n <;> nextstate(main 2 -e:3) v +# o <#> gvsv[*beg] s +# p <1> postinc[t3] sK/1 +# q <1> leavesub[1 ref] K/REFC,1 +# END 1: +# r <;> nextstate(main 5 -e:6) v +# s <#> gvsv[*end] s +# t <1> postinc[t3] sK/1 +# u <1> leavesub[1 ref] K/REFC,1 +# INIT 1: +# v <;> nextstate(main 4 -e:5) v +# w <#> gvsv[*init] s +# x <1> postinc[t3] sK/1 +# y <1> leavesub[1 ref] K/REFC,1 +# CHECK 1: +# z <;> nextstate(main 3 -e:4) v +# 10 <#> gvsv[*chk] s +# 11 <1> postinc[t3] sK/1 +# 12 <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# BEGIN 1: +# 1 <;> nextstate(B::Concise -242 Concise.pm:304) v/2 +# 2 <$> const(PV "strict.pm") s/BARE +# 3 <1> require sK/1 +# 4 <;> nextstate(B::Concise -242 Concise.pm:304) v/2 +# 5 <;> nextstate(B::Concise -242 Concise.pm:304) /2 +# 6 <0> pushmark s +# 7 <$> const(PV "strict") sM +# 8 <$> const(PV "refs") sM +# 9 <$> method_named(PVIV 1520340202) +# a <1> entersub[t1] KS*/TARG,2 +# b <1> leavesub[1 ref] K/REFC,1 +# BEGIN 2: +# c <;> nextstate(B::Concise -227 Concise.pm:327) v/2 +# d <$> const(PV "warnings.pm") s/BARE +# e <1> require sK/1 +# f <;> nextstate(B::Concise -227 Concise.pm:327) v/2 +# g <;> nextstate(B::Concise -227 Concise.pm:327) /2 +# h <0> pushmark s +# i <$> const(PV "warnings") sM +# j <$> const(PV "qw") sM +# k <$> method_named(PVIV 1520340202) +# l <1> entersub[t1] KS*/TARG,2 +# m <1> leavesub[1 ref] K/REFC,1 +# BEGIN 3: +# n <;> nextstate(main 2 -e:3) v +# o <$> gvsv(*beg) s +# p <1> postinc[t2] sK/1 +# q <1> leavesub[1 ref] K/REFC,1 +# END 1: +# r <;> nextstate(main 5 -e:6) v +# s <$> gvsv(*end) s +# t <1> postinc[t2] sK/1 +# u <1> leavesub[1 ref] K/REFC,1 +# INIT 1: +# v <;> nextstate(main 4 -e:5) v +# w <$> gvsv(*init) s +# x <1> postinc[t2] sK/1 +# y <1> leavesub[1 ref] K/REFC,1 +# CHECK 1: +# z <;> nextstate(main 3 -e:4) v +# 10 <$> gvsv(*chk) s +# 11 <1> postinc[t2] sK/1 +# 12 <1> leavesub[1 ref] K/REFC,1 +EONT_EONT diff --git a/gnu/usr.bin/perl/ext/B/t/optree_varinit.t b/gnu/usr.bin/perl/ext/B/t/optree_varinit.t new file mode 100755 index 00000000000..d58135bb231 --- /dev/null +++ b/gnu/usr.bin/perl/ext/B/t/optree_varinit.t @@ -0,0 +1,381 @@ +#!perl + +BEGIN { + chdir 't'; + @INC = ('../lib', '../ext/B/t'); + require Config; + if (($Config::Config{'extensions'} !~ /\bB\b/) ){ + print "1..0 # Skip -- Perl configured without B module\n"; + exit 0; + } + require './test.pl'; +} +use OptreeCheck; +use Config; +plan tests => 22; +SKIP: { +skip "no perlio in this build", 22 unless $Config::Config{useperlio}; + +pass("OPTIMIZER TESTS - VAR INITIALIZATION"); + +checkOptree ( name => 'sub {my $a}', + bcopts => '-exec', + code => sub {my $a}, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 1 <;> nextstate(main 45 optree.t:23) v +# 2 <0> padsv[$a:45,46] M/LVINTRO +# 3 <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 45 optree.t:23) v +# 2 <0> padsv[$a:45,46] M/LVINTRO +# 3 <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + +checkOptree ( name => '-exec sub {my $a}', + bcopts => '-exec', + code => sub {my $a}, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 1 <;> nextstate(main 49 optree.t:52) v +# 2 <0> padsv[$a:49,50] M/LVINTRO +# 3 <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 49 optree.t:45) v +# 2 <0> padsv[$a:49,50] M/LVINTRO +# 3 <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + +checkOptree ( name => 'sub {our $a}', + bcopts => '-exec', + code => sub {our $a}, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +1 <;> nextstate(main 21 optree.t:47) v +2 <#> gvsv[*a] s/OURINTR +3 <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 51 optree.t:56) v +# 2 <$> gvsv(*a) s/OURINTR +# 3 <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + +checkOptree ( name => 'sub {local $a}', + bcopts => '-exec', + code => sub {local $a}, + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +1 <;> nextstate(main 23 optree.t:57) v +2 <#> gvsv[*a] s/LVINTRO +3 <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 53 optree.t:67) v +# 2 <$> gvsv(*a) s/LVINTRO +# 3 <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + +checkOptree ( name => 'my $a', + prog => 'my $a', + bcopts => '-basic', + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 4 <@> leave[1 ref] vKP/REFC ->(end) +# 1 <0> enter ->2 +# 2 <;> nextstate(main 1 -e:1) v ->3 +# 3 <0> padsv[$a:1,2] vM/LVINTRO ->4 +EOT_EOT +# 4 <@> leave[1 ref] vKP/REFC ->(end) +# 1 <0> enter ->2 +# 2 <;> nextstate(main 1 -e:1) v ->3 +# 3 <0> padsv[$a:1,2] vM/LVINTRO ->4 +EONT_EONT + +checkOptree ( name => 'our $a', + prog => 'our $a', + bcopts => '-basic', + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +4 <@> leave[1 ref] vKP/REFC ->(end) +1 <0> enter ->2 +2 <;> nextstate(main 1 -e:1) v ->3 +- <1> ex-rv2sv vK/17 ->4 +3 <#> gvsv[*a] s/OURINTR ->4 +EOT_EOT +# 4 <@> leave[1 ref] vKP/REFC ->(end) +# 1 <0> enter ->2 +# 2 <;> nextstate(main 1 -e:1) v ->3 +# - <1> ex-rv2sv vK/17 ->4 +# 3 <$> gvsv(*a) s/OURINTR ->4 +EONT_EONT + +checkOptree ( name => 'local $a', + prog => 'local $a', + bcopts => '-basic', + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +4 <@> leave[1 ref] vKP/REFC ->(end) +1 <0> enter ->2 +2 <;> nextstate(main 1 -e:1) v ->3 +- <1> ex-rv2sv vKM/129 ->4 +3 <#> gvsv[*a] s/LVINTRO ->4 +EOT_EOT +# 4 <@> leave[1 ref] vKP/REFC ->(end) +# 1 <0> enter ->2 +# 2 <;> nextstate(main 1 -e:1) v ->3 +# - <1> ex-rv2sv vKM/129 ->4 +# 3 <$> gvsv(*a) s/LVINTRO ->4 +EONT_EONT + +pass("MY, OUR, LOCAL, BOTH SUB AND MAIN, = undef"); + +checkOptree ( name => 'sub {my $a=undef}', + code => sub {my $a=undef}, + bcopts => '-basic', + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +3 <1> leavesub[1 ref] K/REFC,1 ->(end) +- <@> lineseq KP ->3 +1 <;> nextstate(main 24 optree.t:99) v ->2 +2 <0> padsv[$a:24,25] sRM*/LVINTRO ->3 +EOT_EOT +# 3 <1> leavesub[1 ref] K/REFC,1 ->(end) +# - <@> lineseq KP ->3 +# 1 <;> nextstate(main 54 optree.t:149) v ->2 +# 2 <0> padsv[$a:54,55] sRM*/LVINTRO ->3 +EONT_EONT + +checkOptree ( name => 'sub {our $a=undef}', + code => sub {our $a=undef}, + note => 'the global must be reset', + bcopts => '-basic', + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +5 <1> leavesub[1 ref] K/REFC,1 ->(end) +- <@> lineseq KP ->5 +1 <;> nextstate(main 26 optree.t:109) v ->2 +4 <2> sassign sKS/2 ->5 +2 <0> undef s ->3 +- <1> ex-rv2sv sKRM*/17 ->4 +3 <#> gvsv[*a] s/OURINTR ->4 +EOT_EOT +# 5 <1> leavesub[1 ref] K/REFC,1 ->(end) +# - <@> lineseq KP ->5 +# 1 <;> nextstate(main 446 optree_varinit.t:137) v ->2 +# 4 <2> sassign sKS/2 ->5 +# 2 <0> undef s ->3 +# - <1> ex-rv2sv sKRM*/17 ->4 +# 3 <$> gvsv(*a) s/OURINTR ->4 +EONT_EONT + +checkOptree ( name => 'sub {local $a=undef}', + code => sub {local $a=undef}, + note => 'local not used enough to bother', + bcopts => '-basic', + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +5 <1> leavesub[1 ref] K/REFC,1 ->(end) +- <@> lineseq KP ->5 +1 <;> nextstate(main 28 optree.t:122) v ->2 +4 <2> sassign sKS/2 ->5 +2 <0> undef s ->3 +- <1> ex-rv2sv sKRM*/129 ->4 +3 <#> gvsv[*a] s/LVINTRO ->4 +EOT_EOT +# 5 <1> leavesub[1 ref] K/REFC,1 ->(end) +# - <@> lineseq KP ->5 +# 1 <;> nextstate(main 58 optree.t:141) v ->2 +# 4 <2> sassign sKS/2 ->5 +# 2 <0> undef s ->3 +# - <1> ex-rv2sv sKRM*/129 ->4 +# 3 <$> gvsv(*a) s/LVINTRO ->4 +EONT_EONT + +checkOptree ( name => 'my $a=undef', + prog => 'my $a=undef', + bcopts => '-basic', + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +4 <@> leave[1 ref] vKP/REFC ->(end) +1 <0> enter ->2 +2 <;> nextstate(main 1 -e:1) v ->3 +3 <0> padsv[$a:1,2] vRM*/LVINTRO ->4 +EOT_EOT +# 4 <@> leave[1 ref] vKP/REFC ->(end) +# 1 <0> enter ->2 +# 2 <;> nextstate(main 1 -e:1) v ->3 +# 3 <0> padsv[$a:1,2] vRM*/LVINTRO ->4 +EONT_EONT + +checkOptree ( name => 'our $a=undef', + prog => 'our $a=undef', + note => 'global must be reassigned', + bcopts => '-basic', + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +6 <@> leave[1 ref] vKP/REFC ->(end) +1 <0> enter ->2 +2 <;> nextstate(main 1 -e:1) v ->3 +5 <2> sassign vKS/2 ->6 +3 <0> undef s ->4 +- <1> ex-rv2sv sKRM*/17 ->5 +4 <#> gvsv[*a] s/OURINTR ->5 +EOT_EOT +# 6 <@> leave[1 ref] vKP/REFC ->(end) +# 1 <0> enter ->2 +# 2 <;> nextstate(main 1 -e:1) v ->3 +# 5 <2> sassign vKS/2 ->6 +# 3 <0> undef s ->4 +# - <1> ex-rv2sv sKRM*/17 ->5 +# 4 <$> gvsv(*a) s/OURINTR ->5 +EONT_EONT + +checkOptree ( name => 'local $a=undef', + prog => 'local $a=undef', + note => 'locals are rare, probly not worth doing', + bcopts => '-basic', + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +6 <@> leave[1 ref] vKP/REFC ->(end) +1 <0> enter ->2 +2 <;> nextstate(main 1 -e:1) v ->3 +5 <2> sassign vKS/2 ->6 +3 <0> undef s ->4 +- <1> ex-rv2sv sKRM*/129 ->5 +4 <#> gvsv[*a] s/LVINTRO ->5 +EOT_EOT +# 6 <@> leave[1 ref] vKP/REFC ->(end) +# 1 <0> enter ->2 +# 2 <;> nextstate(main 1 -e:1) v ->3 +# 5 <2> sassign vKS/2 ->6 +# 3 <0> undef s ->4 +# - <1> ex-rv2sv sKRM*/129 ->5 +# 4 <$> gvsv(*a) s/LVINTRO ->5 +EONT_EONT + +checkOptree ( name => 'sub {my $a=()}', + code => sub {my $a=()}, + bcopts => '-exec', + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +1 <;> nextstate(main -439 optree.t:105) v +2 <0> stub sP +3 <0> padsv[$a:-439,-438] sRM*/LVINTRO +4 <2> sassign sKS/2 +5 <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 438 optree_varinit.t:247) v +# 2 <0> stub sP +# 3 <0> padsv[$a:438,439] sRM*/LVINTRO +# 4 <2> sassign sKS/2 +# 5 <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + +checkOptree ( name => 'sub {our $a=()}', + code => sub {our $a=()}, + #todo => 'probly not worth doing', + bcopts => '-exec', + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +1 <;> nextstate(main 31 optree.t:177) v +2 <0> stub sP +3 <#> gvsv[*a] s/OURINTR +4 <2> sassign sKS/2 +5 <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 440 optree_varinit.t:262) v +# 2 <0> stub sP +# 3 <$> gvsv(*a) s/OURINTR +# 4 <2> sassign sKS/2 +# 5 <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + +checkOptree ( name => 'sub {local $a=()}', + code => sub {local $a=()}, + #todo => 'probly not worth doing', + bcopts => '-exec', + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +1 <;> nextstate(main 33 optree.t:190) v +2 <0> stub sP +3 <#> gvsv[*a] s/LVINTRO +4 <2> sassign sKS/2 +5 <1> leavesub[1 ref] K/REFC,1 +EOT_EOT +# 1 <;> nextstate(main 63 optree.t:225) v +# 2 <0> stub sP +# 3 <$> gvsv(*a) s/LVINTRO +# 4 <2> sassign sKS/2 +# 5 <1> leavesub[1 ref] K/REFC,1 +EONT_EONT + +checkOptree ( name => 'my $a=()', + prog => 'my $a=()', + bcopts => '-exec', + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +1 <0> enter +2 <;> nextstate(main 1 -e:1) v +3 <0> stub sP +4 <0> padsv[$a:1,2] sRM*/LVINTRO +5 <2> sassign vKS/2 +6 <@> leave[1 ref] vKP/REFC +EOT_EOT +# 1 <0> enter +# 2 <;> nextstate(main 1 -e:1) v +# 3 <0> stub sP +# 4 <0> padsv[$a:1,2] sRM*/LVINTRO +# 5 <2> sassign vKS/2 +# 6 <@> leave[1 ref] vKP/REFC +EONT_EONT + +checkOptree ( name => 'our $a=()', + prog => 'our $a=()', + #todo => 'probly not worth doing', + bcopts => '-exec', + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +1 <0> enter +2 <;> nextstate(main 1 -e:1) v +3 <0> stub sP +4 <#> gvsv[*a] s/OURINTR +5 <2> sassign vKS/2 +6 <@> leave[1 ref] vKP/REFC +EOT_EOT +# 1 <0> enter +# 2 <;> nextstate(main 1 -e:1) v +# 3 <0> stub sP +# 4 <$> gvsv(*a) s/OURINTR +# 5 <2> sassign vKS/2 +# 6 <@> leave[1 ref] vKP/REFC +EONT_EONT + +checkOptree ( name => 'local $a=()', + prog => 'local $a=()', + #todo => 'probly not worth doing', + bcopts => '-exec', + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +1 <0> enter +2 <;> nextstate(main 1 -e:1) v +3 <0> stub sP +4 <#> gvsv[*a] s/LVINTRO +5 <2> sassign vKS/2 +6 <@> leave[1 ref] vKP/REFC +EOT_EOT +# 1 <0> enter +# 2 <;> nextstate(main 1 -e:1) v +# 3 <0> stub sP +# 4 <$> gvsv(*a) s/LVINTRO +# 5 <2> sassign vKS/2 +# 6 <@> leave[1 ref] vKP/REFC +EONT_EONT + +checkOptree ( name => 'my ($a,$b)=()', + prog => 'my ($a,$b)=()', + #todo => 'probly not worth doing', + bcopts => '-exec', + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +# 1 <0> enter +# 2 <;> nextstate(main 1 -e:1) v +# 3 <0> pushmark s +# 4 <0> pushmark sRM*/128 +# 5 <0> padsv[$a:1,2] lRM*/LVINTRO +# 6 <0> padsv[$b:1,2] lRM*/LVINTRO +# 7 <2> aassign[t3] vKS +# 8 <@> leave[1 ref] vKP/REFC +EOT_EOT +# 1 <0> enter +# 2 <;> nextstate(main 1 -e:1) v +# 3 <0> pushmark s +# 4 <0> pushmark sRM*/128 +# 5 <0> padsv[$a:1,2] lRM*/LVINTRO +# 6 <0> padsv[$b:1,2] lRM*/LVINTRO +# 7 <2> aassign[t3] vKS +# 8 <@> leave[1 ref] vKP/REFC +EONT_EONT + +} #skip + +__END__ + diff --git a/gnu/usr.bin/perl/ext/B/t/showlex.t b/gnu/usr.bin/perl/ext/B/t/showlex.t index 501a00bf257..9ac528818e1 100644 --- a/gnu/usr.bin/perl/ext/B/t/showlex.t +++ b/gnu/usr.bin/perl/ext/B/t/showlex.t @@ -12,18 +12,18 @@ BEGIN { print "1..0 # Skip -- Perl configured without B module\n"; exit 0; } + require './test.pl'; } -$| = 1; +$| = 1; use warnings; use strict; use Config; +use B::Showlex (); -print "1..1\n"; +plan tests => 15; -my $test = 1; - -sub ok { print "ok $test\n"; $test++ } +my $verbose = @ARGV; # set if ANY ARGS my $a; my $Is_VMS = $^O eq 'VMS'; @@ -35,9 +35,87 @@ my $redir = $Is_MacOS ? "" : "2>&1"; my $is_thread = $Config{use5005threads} && $Config{use5005threads} eq 'define'; if ($is_thread) { - print "# use5005threads: test $test skipped\n"; + ok "# use5005threads: test skipped\n"; } else { $a = `$^X $path "-MO=Showlex" -e "my \@one" $redir`; - print "# [$a]\nnot " unless $a =~ /sv_undef.*PVNV.*\@one.*sv_undef.*AV/s; + like ($a, qr/sv_undef.*PVNV.*\@one.*sv_undef.*AV/s, + "canonical usage works"); +} + +# v1.01 tests + +my ($na,$nb,$nc); # holds regex-strs +my ($out, $newlex); # output, option-flag + +sub padrep { + my ($varname,$newlex) = @_; + return ($newlex) + ? 'PVNV \(0x[0-9a-fA-F]+\) "\\'.$varname.'" = ' + : "PVNV \\\(0x[0-9a-fA-F]+\\\) \\$varname\n"; +} + +for $newlex ('', '-newlex') { + + $out = runperl ( switches => ["-MO=Showlex,$newlex"], + prog => 'my ($a,$b)', stderr => 1 ); + $na = padrep('$a',$newlex); + $nb = padrep('$b',$newlex); + like ($out, qr/1: $na/ms, 'found $a in "my ($a,$b)"'); + like ($out, qr/2: $nb/ms, 'found $b in "my ($a,$b)"'); + + print $out if $verbose; + +SKIP: { + skip "no perlio in this build", 5 + unless $Config::Config{useperlio}; + + our $buf = 'arb startval'; + my $ak = B::Showlex::walk_output (\$buf); + + my $walker = B::Showlex::compile( $newlex, sub{my($foo,$bar)} ); + $walker->(); + $na = padrep('$foo',$newlex); + $nb = padrep('$bar',$newlex); + like ($buf, qr/1: $na/ms, 'found $foo in "sub { my ($foo,$bar) }"'); + like ($buf, qr/2: $nb/ms, 'found $bar in "sub { my ($foo,$bar) }"'); + + print $buf if $verbose; + + $ak = B::Showlex::walk_output (\$buf); + + my $src = 'sub { my ($scalar,@arr,%hash) }'; + my $sub = eval $src; + $walker = B::Showlex::compile($sub); + $walker->(); + $na = padrep('$scalar',$newlex); + $nb = padrep('@arr',$newlex); + $nc = padrep('%hash',$newlex); + like ($buf, qr/1: $na/ms, 'found $scalar in "'. $src .'"'); + like ($buf, qr/2: $nb/ms, 'found @arr in "'. $src .'"'); + like ($buf, qr/3: $nc/ms, 'found %hash in "'. $src .'"'); + + print $buf if $verbose; + + # fibonacci function under test + my $asub = sub { + my ($self,%props)=@_; + my $total; + { # inner block vars + my (@fib)=(1,2); + for (my $i=2; $i<10; $i++) { + $fib[$i] = $fib[$i-2] + $fib[$i-1]; + } + for my $i(0..10) { + $total += $i; + } + } + }; + $walker = B::Showlex::compile($asub, $newlex, -nosp); + $walker->(); + print $buf if $verbose; + + $walker = B::Concise::compile($asub, '-exec'); + $walker->(); + +} } -ok; diff --git a/gnu/usr.bin/perl/ext/Cwd/t/win32.t b/gnu/usr.bin/perl/ext/Cwd/t/win32.t new file mode 100755 index 00000000000..f5fa20e1022 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Cwd/t/win32.t @@ -0,0 +1,29 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + if ($ENV{PERL_CORE}) { + @INC = '../lib'; + } +} + +use Test::More; +if( $^O eq 'MSWin32' ) { + plan tests => 3; +} else { + plan skip_all => 'this is not win32'; +} + +use Cwd; +ok 1; + +my $cdir = getdcwd('C:'); +like $cdir, qr{^C:}; + +my $ddir = getdcwd('D:'); +if (defined $ddir) { + like $ddir, qr{^D:}; +} else { + # May not have a D: drive mounted + ok 1; +} diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/HACKERS b/gnu/usr.bin/perl/ext/Devel/PPPort/HACKERS new file mode 100644 index 00000000000..1eaa1abe559 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/HACKERS @@ -0,0 +1,234 @@ +=head1 NAME + +HACKERS - Devel::PPPort internals for hackers + +=head1 SYNOPSIS + +So you probably want to hack C<Devel::PPPort>? + +Well, here's some information to get you started with what's +lying around in this distribution. + +=head1 DESCRIPTION + +=head2 How to build 87 versions of Perl + +C<Devel::PPPort> supports Perl versions between 5.003 and bleadperl. +To guarantee this support, I need some of these versions on my +machine. I currently have 87 different Perl version/configuration +combinations installed on my laptop. + +As many of the old Perl distributions need patching to compile +cleanly on newer systems (and because building 87 Perls by hand +just isn't fun), I wrote a tool to build all the different +versions and configurations. You can find it in F<devel/buildperl.pl>. +It can currently build the following Perl releases: + + 5.003 + 5.004 - 5.004_05 + 5.005 - 5.005_04 + 5.6.x + 5.7.x + 5.8.x + 5.9.x + +=head2 Fully automatic API checks + +Knowing which parts of the API are not backwards compatible and +probably need C<Devel::PPPort> support is another problem that's +not easy to deal with manually. If you run + + perl Makefile.PL --with-apicheck + +a C file is generated by F<parts/apicheck.pl> that is compiled +and linked with C<Devel::PPPort>. This C file has the purpose of +using each of the public API functions/macros once. + +The required information is derived from C<parts/embed.fnc> (just +a copy of bleadperl's C<embed.fnc>) and C<parts/apidoc.fnc> (which +is generated by F<devel/mkapidoc.sh> and simply collects the rest +of the apidoc entries spread over the Perl source code). +The generated C file C<apicheck.c> is currently about 500k in size +and takes quite a while to compile. + +Usually, C<apicheck.c> won't compile with older perls. And even if +it compiles, there's still a good chance of the dynamic linker +failing at C<make test> time. But that's on purpose! + +We can use these failures to find changes in the API automatically. +The two Perl scripts F<devel/mktodo> and F<devel/mktodo.pl> +repeatedly run C<Devel::PPPort> with the apicheck code through +all different versions of perl. Scanning the output of the compiler +and the dynamic linker for errors, the files in F<parts/todo/> are +generated. These files list all parts of the public API that don't +work with less than a certain version of Perl. + +This information is in turn used by F<parts/apicheck.pl> to mask +API calls in the generated C file for these versions, so the +process can be stopped by the time F<apicheck.c> compiles cleanly +and the dynamic linker is happy. (Actually, this process generates +false positives, so each API call is checked once more afterwards.) + +Running C<devel/mktodo> takes a couple of hours. + +When running C<devel/mktodo> with the C<--base> option, it will +generate the I<baseline> todo files by disabling all functionality +provided by C<Devel::PPPort>. These are required for implementing +the C<--compat-version> option of the C<ppport.h> script. The +baseline todo files hold the information about which version of +Perl lacks a certain part of the API. + +However, only the documented public API can be checked this way. +And since C<Devel::PPPort> provides more macros, these would not be +affected by C<--compat-version>. It's the job of F<devel/scanprov> +to figure out the baseline information for all remaining provided +macros by scanning the include files in the F<CORE> directory of +various Perl versions. + +It's not very often that one has to regenerate the baseline and +todo files, and the process hasn't been automated yet, but it's +basically only the following steps: + +=over 4 + +=item * + +You need a whole bunch of different Perls. The more, the better. +You can use F<devel/buildperl.pl> to build them. I keep my perls +in F</tmp/perl>, so most of the tools take this as a default. + +=item * + +Remove all existing todo files in the F<parts/base> and +F<parts/todo> directories. + +=item * + +Update the API information. Copy the latest F<embed.fnc> file from +bleadperl to the F<parts> directory and run F<devel/mkapidoc.sh> to +collect the remaining information in F<parts/apidoc.fnc>. + +=item * + +Build the new baseline by running + + perl devel/mktodo --base + +in the root directory of the distribution. When it's finished, +move all files from the F<parts/todo> directory to F<parts/base>. + +=item * + +Build the new todo files by running + + perl devel/mktodo + +in the root directory of the distribution. + +=item * + +Finally, add the remaining baseline information by running + + perl devel/scanprov + +=back + +=head2 Implementation + +Residing in F<parts/inc/> is the "heart" of C<Devel::PPPort>. Each +of the files implements a part of the supported API, along with +hints, dependency information, XS code and tests. +The files are in a POD-like format that is parsed using the +functions in F<parts/ppptools.pl>. + +The scripts F<PPPort_pm.PL>, F<PPPort_xs.PL> and F<mktests.PL> all +use the information in F<parts/inc/> to generate the main module +F<PPPort.pm>, the XS code in F<PPPort.xs> and various test files +in F<t/>. + +All of these files could be generated on the fly while building +C<Devel::PPPort>, but not having the tests in C<t/> and not having +F<PPPort.xs> will confuse Configure and TEST/harness in the core. +Not having F<PPPort.pm> will be bad for viewing the docs on +C<search.cpan.org>. So unfortunately, it's unavoidable to put +some redundancy into the package. + +=head2 Adding stuff to Devel::PPPort + +First, check if the code you plan to add fits into one of the +existing files in F<parts/inc/>. If not, just start a new one and +remember to include it from within F<PPPort_pm.PL>. + +Each file holds all relevant data for implementing a certain part +of the API: + +=over 2 + +=item * + +A list of the provided API in the C<=provides> section. + +=item * + +The implementation to add to F<ppport.h> in the C<=implementation> +section. + +=item * + +The code required to add to PPPort.xs for testing the implementation. +This code goes into the C<=xshead>, C<=xsinit>, C<=xsmisc>, C<=xsboot> +and C<=xsubs> section. Have a look at the template in F<PPPort_xs.PL> +to see where the code ends up. + +=item * + +The tests in the C<=tests> section. Remember not to use any fancy +modules or syntax elements, as the test code should be able to run +with Perl 5.003, which, for example, doesn't support C<my> in +C<for>-loops: + + for my $x (1, 2, 3) { } # won't work + +You can use C<ok()> to report success or failure. + +=back + +It's usually the best approach to just copy an existing file and +use it as a template. + +=head2 Testing + +To automatically test C<Devel::PPPort> with lots of different Perl +versions, you can use the F<soak> script. Just pass it a list of +all Perl binaries you want to test. + +=head2 Special Makefile targets + +You can use + + make regen + +to regenerate all of the autogenerated files. To get rid of +all generated files (except for parts/todo/*), use + + make purge_all + +That's it. + +=head1 COPYRIGHT + +Version 3.x, Copyright (C) 2004, Marcus Holland-Moritz. + +Version 2.x, Copyright (C) 2001, Paul Marquess. + +Version 1.x, Copyright (C) 1999, Kenneth Albanowski. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=head1 SEE ALSO + +See L<ppport.h>. + +=cut + diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/MANIFEST.SKIP b/gnu/usr.bin/perl/ext/Devel/PPPort/MANIFEST.SKIP new file mode 100644 index 00000000000..a6d2883e265 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/MANIFEST.SKIP @@ -0,0 +1,16 @@ +^Makefile$ +~$ +\.old(?:\..*)?$ +\.swp$ +\.o$ +\.bs$ +\.bak$ +\.orig$ +\.cache\.cm$ +^blib +^pm_to_blib +^backup +^parts/todo- +^ppport\.h$ +^PPPort\.c$ +Devel-PPPort.*\.tar\.gz$ diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/META.yml b/gnu/usr.bin/perl/ext/Devel/PPPort/META.yml new file mode 100644 index 00000000000..c0e2f441901 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/META.yml @@ -0,0 +1,10 @@ +# http://module-build.sourceforge.net/META-spec.html +#XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX# +name: Devel-PPPort +version: 3.03 +version_from: PPPort_pm.PL +installdirs: perl +requires: + +distribution_type: module +generated_by: ExtUtils::MakeMaker version 6.17 diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/PPPort_pm.PL b/gnu/usr.bin/perl/ext/Devel/PPPort/PPPort_pm.PL new file mode 100644 index 00000000000..e057f2ac3c3 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/PPPort_pm.PL @@ -0,0 +1,580 @@ +################################################################################ +# +# PPPort_pm.PL -- generate PPPort.pm +# +################################################################################ +# +# $Revision: 1.1 $ +# $Author: millert $ +# $Date: 2005/01/15 21:16:45 $ +# +################################################################################ +# +# Version 3.x, Copyright (C) 2004, Marcus Holland-Moritz. +# Version 2.x, Copyright (C) 2001, Paul Marquess. +# Version 1.x, Copyright (C) 1999, Kenneth Albanowski. +# +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. +# +################################################################################ + +use strict; +$^W = 1; +require "parts/ppptools.pl"; + +my $INCLUDE = 'parts/inc'; +my $DPPP = 'DPPP_'; + +my %embed = map { ( $_->{name} => $_ ) } + parse_embed(qw(parts/embed.fnc parts/apidoc.fnc)); + +my(%provides, %prototypes, %explicit); + +my $data = do { local $/; <DATA> }; +$data =~ s{^\%(include)\s+(\w+)((?:[^\S\r\n]+.*?)?)\s*$} + {eval "$1('$2', $3)" or die $@}gem; + +$data = expand($data); + +my @api = sort { lc $a cmp lc $b } keys %provides; + +$data =~ s{^(.*)__PROVIDED_API__(\s*?)^} + {join '', map "$1$_\n", @api}gem; + +{ + my $len = 0; + for (keys %explicit) { + length > $len and $len = length; + } + my $format = sprintf "%%-%ds %%-%ds %%-%ds", $len+2, $len+5, $len+12; + $len = 3*$len + 23; + +$data =~ s/^(.*)__EXPLICIT_API__(\s*?)^/ + sprintf("$1$format\n", 'Function', 'Static Request', 'Global Request') . + $1 . '-'x$len . "\n" . + join('', map { sprintf "$1$format\n", "$_()", "NEED_$_", "NEED_${_}_GLOBAL" } + sort keys %explicit) + /gem; +} + +my %raw_base = %{&parse_todo('parts/base')}; +my %raw_todo = %{&parse_todo('parts/todo')}; + +my %todo; +for (keys %raw_todo) { + push @{$todo{$raw_todo{$_}}}, $_; +} + +# check consistency +for (@api) { + if (exists $raw_todo{$_}) { + if ($raw_base{$_} eq $raw_todo{$_}) { + warn "$INCLUDE/$provides{$_} provides $_, which is still marked " + . "todo for " . format_version($raw_todo{$_}) . "\n"; + } + else { + check(2, "$_ was ported back to " . format_version($raw_todo{$_}) . + " (baseline revision: " . format_version($raw_base{$_}) . ")."); + } + } +} + +my @perl_api; +for (keys %provides) { + next if exists $embed{$_}; + push @perl_api, $_; + check(2, "No API definition for provided element $_ found."); +} + +push @perl_api, keys %embed; + +for (@perl_api) { + if (exists $provides{$_} && !exists $raw_base{$_}) { + check(2, "Mmmh, $_ doesn't seem to need backporting."); + } + my $line = "$_|" . (exists $provides{$_} && exists $raw_base{$_} ? $raw_base{$_} : '') . '|'; + $line .= ($raw_todo{$_} || '') . '|'; + $line .= 'p' if exists $provides{$_}; + if (exists $embed{$_}) { + my $e = $embed{$_}; + if (exists $e->{flags}{p}) { + my $args = $e->{args}; + $line .= 'v' if @$args && $args->[-1][0] eq '...'; + } + $line .= 'n' if exists $e->{flags}{n}; + } + $_ = $line; +} + +$data =~ s/^([\t ]*)__PERL_API__(\s*?)$/ + join "\n", map "$1$_", sort @perl_api + /gem; + +my @todo; +for (reverse sort keys %todo) { + my $ver = format_version($_); + my $todo = "=item perl $ver\n\n"; + for (sort @{$todo{$_}}) { + $todo .= " $_\n"; + } + push @todo, $todo; +} + +$data =~ s{^__UNSUPPORTED_API__(\s*?)^} + {join "\n", @todo}gem; + +$data =~ s{__MIN_PERL__}{5.003}g; +$data =~ s{__MAX_PERL__}{5.9.2}g; + +open FH, ">PPPort.pm" or die "PPPort.pm: $!\n"; +print FH $data; +close FH; + +exit 0; + +sub include +{ + my($file, $opt) = @_; + + print "including $file\n"; + + my $data = parse_partspec("$INCLUDE/$file"); + + for (@{$data->{provides}}) { + if (exists $provides{$_}) { + if ($provides{$_} ne $file) { + warn "$file: $_ already provided by $provides{$_}\n"; + } + } + else { + $provides{$_} = $file; + } + } + + for (keys %{$data->{prototypes}}) { + $prototypes{$_} = $data->{prototypes}{$_}; + $data->{implementation} =~ s/^$_(?=\s*\()/$DPPP(my_$_)/mg; + } + + my $out = $data->{implementation}; + + if (exists $opt->{indent}) { + $out =~ s/^/$opt->{indent}/gm; + } + + return $out; +} + +sub expand +{ + my $code = shift; + $code =~ s{^(\s*#\s*(?:el)?if\s+)(.*)$}{$1.expand_pp_expressions($2)}gem; + $code =~ s{^\s* + __UNDEFINED__ + \s+ + ( + ( \w+ ) + (?: \( [^)]* \) )? + ) + [^\r\n\S]* + ( + (?:[^\r\n\\]|\\[^\r\n])* + (?: + \\ + (?:\r\n|[\r\n]) + (?:[^\r\n\\]|\\[^\r\n])* + )* + ) + \s*$} + {expand_undefined($2, $1, $3)}gemx; + return $code; +} + +sub expand_undefined +{ + my($macro, $withargs, $def) = @_; + my $rv = "#ifndef $macro\n# define "; + + if (defined $def) { + $rv .= sprintf "%-30s %s", $withargs, $def; + } + else { + $rv .= $withargs; + } + + $rv .= "\n#endif\n"; + + return $rv; +} + +sub expand_pp_expressions +{ + my $pp = shift; + $pp =~ s/\{([^\}]+)\}/expand_pp_expr($1)/ge; + return $pp; +} + +sub expand_pp_expr +{ + my $expr = shift; + + if ($expr =~ /^\s*need\s*(\w+)\s*$/i) { + my $func = $1; + my $e = $embed{$func} or die "unknown API function '$func' in NEED\n"; + my $proto = make_prototype($e); + if (exists $prototypes{$func}) { + if (compare_prototypes($proto, $prototypes{$func})) { + check(1, "differing prototypes for $func:\n API: $proto\n PPP: $prototypes{$func}"); + $proto = $prototypes{$func}; + } + } + else { + warn "found no prototype for $func\n";; + } + + $explicit{$func} = 1; + + $proto =~ s/\b$func(?=\s*\()/$DPPP(my_$func)/; + my $embed = make_embed($e); + + return "defined(NEED_$func)\n" + . "static $proto;\n" + . "static\n" + . "#else\n" + . "extern $proto;\n" + . "#endif\n" + . "\n" + . "$embed\n" + . "\n" + . "#if defined(NEED_$func) || defined(NEED_${func}_GLOBAL)"; + } + + die "cannot expand preprocessor expression '$expr'\n"; +} + +sub make_embed +{ + my $f = shift; + my $n = $f->{name}; + my $a = do { my $x = 'a'; join ',', map { $x++ } 1 .. @{$f->{args}} }; + + if ($f->{flags}{n}) { + if ($f->{flags}{p}) { + return "#define $n $DPPP(my_$n)\n" . + "#define Perl_$n $DPPP(my_$n)"; + } + else { + return "#define $n $DPPP(my_$n)"; + } + } + else { + my $undef = <<UNDEF; +#ifdef $n +# undef $n +#endif +UNDEF + if ($f->{flags}{p}) { + if ($f->{flags}{f}) { + return "#define Perl_$n $DPPP(my_$n)"; + } + else { + return $undef . "#define $n($a) $DPPP(my_$n)(aTHX_ $a)\n" . + "#define Perl_$n $DPPP(my_$n)"; + } + } + else { + return $undef . "#define $n($a) $DPPP(my_$n)(aTHX_ $a)"; + } + } +} + +sub check +{ + my $level = shift; + + if (exists $ENV{DPPP_CHECK_LEVEL} and $ENV{DPPP_CHECK_LEVEL} >= $level) { + print STDERR @_, "\n"; + } +} + +__DATA__ +################################################################################ +# +# !!!!! Do NOT edit this file directly! -- Edit PPPort_pm.PL instead. !!!!! +# +################################################################################ +# +# Perl/Pollution/Portability +# +################################################################################ +# +# $Revision: 1.1 $ +# $Author: millert $ +# $Date: 2005/01/15 21:16:45 $ +# +################################################################################ +# +# Version 3.x, Copyright (C) 2004, Marcus Holland-Moritz. +# Version 2.x, Copyright (C) 2001, Paul Marquess. +# Version 1.x, Copyright (C) 1999, Kenneth Albanowski. +# +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. +# +################################################################################ + +=head1 NAME + +Devel::PPPort - Perl/Pollution/Portability + +=head1 SYNOPSIS + + Devel::PPPort::WriteFile(); # defaults to ./ppport.h + Devel::PPPort::WriteFile('someheader.h'); + +=head1 DESCRIPTION + +Perl's API has changed over time, gaining new features, new functions, +increasing its flexibility, and reducing the impact on the C namespace +environment (reduced pollution). The header file written by this module, +typically F<ppport.h>, attempts to bring some of the newer Perl API +features to older versions of Perl, so that you can worry less about +keeping track of old releases, but users can still reap the benefit. + +C<Devel::PPPort> contains a single function, called C<WriteFile>. Its +only purpose is to write the F<ppport.h> C header file. This file +contains a series of macros and, if explicitly requested, functions that +allow XS modules to be built using older versions of Perl. Currently, +Perl versions from __MIN_PERL__ to __MAX_PERL__ are supported. + +This module is used by C<h2xs> to write the file F<ppport.h>. + +=head2 Why use ppport.h? + +You should use F<ppport.h> in modern code so that your code will work +with the widest range of Perl interpreters possible, without significant +additional work. + +You should attempt older code to fully use F<ppport.h>, because the +reduced pollution of newer Perl versions is an important thing. It's so +important that the old polluting ways of original Perl modules will not be +supported very far into the future, and your module will almost certainly +break! By adapting to it now, you'll gain compatibility and a sense of +having done the electronic ecology some good. + +=head2 How to use ppport.h + +Don't direct the users of your module to download C<Devel::PPPort>. +They are most probably no XS writers. Also, don't make F<ppport.h> +optional. Rather, just take the most recent copy of F<ppport.h> that +you can find (e.g. by generating it with the latest C<Devel::PPPort> +release from CPAN), copy it into your project, adjust your project to +use it, and distribute the header along with your module. + +=head2 Running ppport.h + +But F<ppport.h> is more than just a C header. It's also a Perl script +that can check your source code. It will suggest hints and portability +notes, and can even make suggestions on how to change your code. You +can run it like any other Perl program: + + perl ppport.h + +It also has embedded documentation, so you can use + + perldoc ppport.h + +to find out more about how to use it. + +=head1 FUNCTIONS + +=head2 WriteFile + +C<WriteFile> takes one optional argument. When called with one +argument, it expects to be passed a filename. When called with +no arguments, it defaults to the filename F<ppport.h>. + +The function returns a true value if the file was written successfully. +Otherwise it returns a false value. + +=head1 COMPATIBILITY + +F<ppport.h> supports Perl versions from __MIN_PERL__ to __MAX_PERL__ +in threaded and non-threaded configurations. + +=head2 Provided Perl compatibility API + +The header file written by this module, typically F<ppport.h>, provides +access to the following elements of the Perl API that is not available +in older Perl releases: + + __PROVIDED_API__ + +=head2 Perl API not supported by ppport.h + +There is still a big part of the API not supported by F<ppport.h>. +Either because it doesn't make sense to back-port that part of the API, +or simply because it hasn't been implemented yet. Patches welcome! + +Here's a list of the currently unsupported API, and also the version of +Perl below which it is unsupported: + +=over 4 + +__UNSUPPORTED_API__ + +=back + +=head1 BUGS + +If you find any bugs, C<Devel::PPPort> doesn't seem to build on your +system or any of its tests fail, please use the CPAN Request Tracker +at L<http://rt.cpan.org/> to create a ticket for the module. + +=head1 AUTHORS + +=over 2 + +=item * + +Version 1.x of Devel::PPPort was written by Kenneth Albanowski. + +=item * + +Version 2.x was ported to the Perl core by Paul Marquess. + +=item * + +Version 3.x was ported back to CPAN by Marcus Holland-Moritz. + +=back + +=head1 COPYRIGHT + +Version 3.x, Copyright (C) 2004, Marcus Holland-Moritz. + +Version 2.x, Copyright (C) 2001, Paul Marquess. + +Version 1.x, Copyright (C) 1999, Kenneth Albanowski. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=head1 SEE ALSO + +See L<h2xs>, L<ppport.h>. + +=cut + +package Devel::PPPort; + +require DynaLoader; +use strict; +use vars qw($VERSION @ISA $data); + +$VERSION = do { my @r = '$Snapshot: /Devel-PPPort/3.03 $' =~ /(\d+\.\d+(?:_\d+)?)/; @r ? $r[0] : '9.99' }; + +@ISA = qw(DynaLoader); + +bootstrap Devel::PPPort; + +{ + $data = do { local $/; <DATA> }; + my $now = localtime; + my $pkg = 'Devel::PPPort'; + $data =~ s/__PERL_VERSION__/$]/g; + $data =~ s/__VERSION__/$VERSION/g; + $data =~ s/__DATE__/$now/g; + $data =~ s/__PKG__/$pkg/g; + $data =~ s/^POD\s//gm; +} + +sub WriteFile +{ + my $file = shift || 'ppport.h'; + my $copy = $data; + $copy =~ s/\bppport\.h\b/$file/g; + + open F, ">$file" or return undef; + print F $copy; + close F; + + return 1; +} + +1; + +__DATA__ +#if 0 +<<'SKIP'; +#endif +/* +---------------------------------------------------------------------- + + ppport.h -- Perl/Pollution/Portability Version __VERSION__ + + Automatically created by __PKG__ running under + perl __PERL_VERSION__ on __DATE__. + + Do NOT edit this file directly! -- Edit PPPort_pm.PL and the + includes in parts/inc/ instead. + + Use 'perldoc ppport.h' to view the documentation below. + +---------------------------------------------------------------------- + +SKIP + +%include ppphdoc { indent => 'POD ' } + +%include ppphbin + +__DATA__ +*/ + +#ifndef _P_P_PORTABILITY_H_ +#define _P_P_PORTABILITY_H_ + +#ifndef DPPP_NAMESPACE +# define DPPP_NAMESPACE DPPP_ +#endif + +#define DPPP_CAT2(x,y) CAT2(x,y) +#define DPPP_(name) DPPP_CAT2(DPPP_NAMESPACE, name) + +%include version + +%include limits + +%include uv + +%include misc + +%include threads + +%include mPUSH + +%include call + +%include newRV + +%include newCONSTSUB + +%include MY_CXT + +%include format + +%include SvPV + +%include sv_xpvf + +%include magic + +%include cop + +%include grok + +#endif /* _P_P_PORTABILITY_H_ */ + +/* End of File ppport.h */ diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/PPPort_xs.PL b/gnu/usr.bin/perl/ext/Devel/PPPort/PPPort_xs.PL new file mode 100644 index 00000000000..66e570e8ae5 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/PPPort_xs.PL @@ -0,0 +1,132 @@ +################################################################################ +# +# PPPort_xs.PL -- generate PPPort.xs +# +################################################################################ +# +# $Revision: 1.1 $ +# $Author: millert $ +# $Date: 2005/01/15 21:16:45 $ +# +################################################################################ +# +# Version 3.x, Copyright (C) 2004, Marcus Holland-Moritz. +# Version 2.x, Copyright (C) 2001, Paul Marquess. +# Version 1.x, Copyright (C) 1999, Kenneth Albanowski. +# +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. +# +################################################################################ + +use strict; +$^W = 1; +require "parts/ppptools.pl"; + +my %SECTION = ( + xshead => { code => '', header => "/* ---- from __FILE__ ---- */" }, + xsinit => { code => '', header => "/* ---- from __FILE__ ---- */" }, + xsmisc => { code => '', header => "/* ---- from __FILE__ ---- */" }, + xsboot => { code => '', header => "/* ---- from __FILE__ ---- */", indent => "\t" }, + xsubs => { code => '', header => "##".('-' x 70)."\n## XSUBs from __FILE__\n##".('-' x 70)."\n" }, +); + +if (exists $ENV{PERL_NO_GET_CONTEXT} && $ENV{PERL_NO_GET_CONTEXT}) { +$SECTION{xshead}{code} .= <<END; +#define PERL_NO_GET_CONTEXT +END +} + +my $file; +my $sec; + +for $file (glob 'parts/inc/*') { + my $spec = parse_partspec($file); + + my $msg = 0; + for $sec (keys %SECTION) { + if (exists $spec->{$sec}) { + $msg++ or print "adding XS code from $file\n"; + if (exists $SECTION{$sec}{header}) { + my $header = $SECTION{$sec}{header}; + $header =~ s/__FILE__/$file/g; + $SECTION{$sec}{code} .= $header . "\n"; + } + $SECTION{$sec}{code} .= $spec->{$sec} . "\n"; + } + } +} + +my $data = do { local $/; <DATA> }; + +for $sec (keys %SECTION) { + my $code = $SECTION{$sec}{code}; + if (exists $SECTION{$sec}{indent}) { + $code =~ s/^/$SECTION{$sec}{indent}/gm; + } + $code =~ s/[\r\n]+$//; + $data =~ s/^__\U$sec\E__$/$code/m; +} + +open FH, ">PPPort.xs" or die "PPPort.xs: $!\n"; +print FH $data; +close FH; + +exit 0; + +__DATA__ +/******************************************************************************* +* +* !!!!! Do NOT edit this file directly! -- Edit PPPort_xs.PL instead. !!!!! +* +******************************************************************************** +* +* Perl/Pollution/Portability +* +******************************************************************************** +* +* $Revision: 1.1 $ +* $Author: millert $ +* $Date: 2005/01/15 21:16:45 $ +* +******************************************************************************** +* +* Version 3.x, Copyright (C) 2004, Marcus Holland-Moritz. +* Version 2.x, Copyright (C) 2001, Paul Marquess. +* Version 1.x, Copyright (C) 1999, Kenneth Albanowski. +* +* This program is free software; you can redistribute it and/or +* modify it under the same terms as Perl itself. +* +*******************************************************************************/ + +/* ========== BEGIN XSHEAD ================================================== */ + +__XSHEAD__ + +/* =========== END XSHEAD =================================================== */ + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +/* ========== BEGIN XSINIT ================================================== */ + +__XSINIT__ + +/* =========== END XSINIT =================================================== */ + +#include "ppport.h" + +/* ========== BEGIN XSMISC ================================================== */ + +__XSMISC__ + +/* =========== END XSMISC =================================================== */ + +MODULE = Devel::PPPort PACKAGE = Devel::PPPort + +BOOT: +__XSBOOT__ + +__XSUBS__ diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/apicheck_c.PL b/gnu/usr.bin/perl/ext/Devel/PPPort/apicheck_c.PL new file mode 100644 index 00000000000..0fde44da03f --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/apicheck_c.PL @@ -0,0 +1,25 @@ +################################################################################ +# +# apicheck_c.PL -- generate apicheck.c +# +################################################################################ +# +# $Revision: 1.1 $ +# $Author: millert $ +# $Date: 2005/01/15 21:16:45 $ +# +################################################################################ +# +# Version 3.x, Copyright (C) 2004, Marcus Holland-Moritz. +# Version 2.x, Copyright (C) 2001, Paul Marquess. +# Version 1.x, Copyright (C) 1999, Kenneth Albanowski. +# +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. +# +################################################################################ + +$out = 'apicheck.c'; +print "creating $out\n"; +system $^X, 'parts/apicheck.pl', $out + and die "couldn't create $out\n"; diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/devel/buildperl.pl b/gnu/usr.bin/perl/ext/Devel/PPPort/devel/buildperl.pl new file mode 100644 index 00000000000..34db953f89b --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/devel/buildperl.pl @@ -0,0 +1,317 @@ +#!/usr/bin/perl -w +################################################################################ +# +# buildperl.pl -- build various versions of perl automatically +# +################################################################################ +# +# $Revision: 1.1 $ +# $Author: millert $ +# $Date: 2005/01/15 21:16:45 $ +# +################################################################################ +# +# Version 3.x, Copyright (C) 2004, Marcus Holland-Moritz. +# Version 2.x, Copyright (C) 2001, Paul Marquess. +# Version 1.x, Copyright (C) 1999, Kenneth Albanowski. +# +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. +# +################################################################################ + +use strict; +use Getopt::Long; +use Pod::Usage; +use File::Find; +use File::Path; +use Data::Dumper; +use IO::File; +use Cwd; + +my %opt = ( + prefix => '/tmp/perl/install/<config>/<perl>', + build => '/tmp/perl/build/<config>', + source => '/tmp/perl/source', + force => 0, +); + +my %config = ( + default => { + config_args => '-des', + }, + thread => { + config_args => '-des -Dusethreads', + masked_versions => [ qr/^perl5\.00[01234]/ ], + }, + thread5005 => { + config_args => '-des -Duse5005threads', + masked_versions => [ qr/^perl5\.00[012345]|^perl-5.(9|\d\d)/ ], + }, + debug => { + config_args => '-des -Doptimize=-g', + }, +); + +my @patch = ( + { + perl => [ + qr/^perl5\.00[01234]/, + qw/ + perl5.005 + perl5.005_01 + perl5.005_02 + perl5.005_03 + /, + ], + subs => [ + [ \&patch_db, 1 ], + ], + }, + { + perl => [ + qw/ + perl-5.6.0 + perl-5.6.1 + perl-5.7.0 + perl-5.7.1 + perl-5.7.2 + perl-5.7.3 + perl-5.8.0 + /, + ], + subs => [ + [ \&patch_db, 3 ], + ], + }, + { + perl => [ + qr/^perl5\.004_0[1234]/, + ], + subs => [ + [ \&patch_doio ], + ], + }, +); + +my(%perl, @perls); + +GetOptions(\%opt, qw( + config=s@ + prefix=s + source=s + perl=s@ + force +)) or pod2usage(2); + +if (exists $opt{config}) { + for my $cfg (@{$opt{config}}) { + exists $config{$cfg} or die "Unknown configuration: $cfg\n"; + } +} +else { + $opt{config} = [sort keys %config]; +} + +find(sub { + /^(perl-?(5\..*))\.tar.gz$/ or return; + $perl{$1} = { version => $2, source => $File::Find::name }; +}, $opt{source}); + +if (exists $opt{perl}) { + for my $perl (@{$opt{perl}}) { + my $p = $perl; + exists $perl{$p} or $p = "perl$perl"; + exists $perl{$p} or $p = "perl-$perl"; + exists $perl{$p} or die "Cannot find perl: $perl\n"; + push @perls, $p; + } +} +else { + @perls = sort keys %perl; +} + +$ENV{PATH} = "~/bin:$ENV{PATH}"; # use ccache + +my %current; + +for my $cfg (@{$opt{config}}) { + for my $perl (@perls) { + my $config = $config{$cfg}; + %current = (config => $cfg, perl => $perl); + + if (is($config->{masked_versions}, $perl)) { + print STDERR "skipping $perl for configuration $cfg (masked)\n"; + next; + } + + if (-d expand($opt{prefix}) and !$opt{force}) { + print STDERR "skipping $perl for configuration $cfg (already installed)\n"; + next; + } + + my $cwd = cwd; + + my $build = expand($opt{build}); + -d $build or mkpath($build); + chdir $build or die "chdir $build: $!\n"; + + print STDERR "building $perl with configuration $cfg\n"; + buildperl($perl, $config); + + chdir $cwd or die "chdir $cwd: $!\n"; + } +} + +sub expand +{ + my $in = shift; + $in =~ s/(<(\w+)>)/exists $current{$2} ? $current{$2} : $1/eg; + return $in; +} + +sub is +{ + my($s1, $s2) = @_; + + defined $s1 != defined $s2 and return 0; + + ref $s2 and ($s1, $s2) = ($s2, $s1); + + if (ref $s1) { + if (ref $s1 eq 'ARRAY') { + is($_, $s2) and return 1 for @$s1; + return 0; + } + return $s2 =~ $s1; + } + + return $s1 eq $s2; +} + +sub buildperl +{ + my($perl, $cfg) = @_; + + my $d = extract_source($perl{$perl}); + chdir $d or die "chdir $d: $!\n"; + + patch_source($perl); + + build_and_install($perl{$perl}); +} + +sub extract_source +{ + my $perl = shift; + my $target = "perl-$perl->{version}"; + + for my $dir ("perl$perl->{version}", "perl-$perl->{version}") { + if (-d $dir) { + print "removing old build directory $dir\n"; + rmtree($dir); + } + } + + print "extracting $perl->{source}\n"; + + run_or_die("tar xzf $perl->{source}"); + + if ($perl->{version} !~ /^\d+\.\d+\.\d+/ && -d "perl-$perl->{version}") { + $target = "perl$perl->{version}"; + rename "perl-$perl->{version}", $target or die "rename: $!\n"; + } + + -d $target or die "$target not found\n"; + + return $target; +} + +sub patch_source +{ + my $perl = shift; + + for my $p (@patch) { + if (is($p->{perl}, $perl)) { + for my $s (@{$p->{subs}}) { + my($sub, @args) = @$s; + $sub->(@args); + } + } + } +} + +sub build_and_install +{ + my $perl = shift; + my $prefix = expand($opt{prefix}); + + print "building perl $perl->{version} ($current{config})\n"; + + run_or_die("./Configure $config{$current{config}}{config_args} -Dusedevel -Uinstallusrbinperl -Dprefix=$prefix"); + run_or_die("sed -i -e '/^.*<built-in>/d' -e '/^.*<command line>/d' makefile x2p/makefile"); + run_or_die("make all"); + # run("make test"); + run_or_die("make install"); +} + +sub patch_db +{ + my $ver = shift; + print "patching DB_File\n"; + run_or_die("sed -i -e 's/<db.h>/<db$ver\\/db.h>/' ext/DB_File/DB_File.xs"); +} + +sub patch_doio +{ + patch('doio.c', <<'END'); +--- doio.c.org 2004-06-07 23:14:45.000000000 +0200 ++++ doio.c 2003-11-04 08:03:03.000000000 +0100 +@@ -75,6 +75,16 @@ + # endif + #endif + ++#if _SEM_SEMUN_UNDEFINED ++union semun ++{ ++ int val; ++ struct semid_ds *buf; ++ unsigned short int *array; ++ struct seminfo *__buf; ++}; ++#endif ++ + bool + do_open(gv,name,len,as_raw,rawmode,rawperm,supplied_fp) + GV *gv; +END +} + +sub patch +{ + my($file, $patch) = @_; + print "patching $file\n"; + my $diff = "$file.diff"; + write_or_die($diff, $patch); + run_or_die("patch -s -p0 <$diff"); + unlink $diff or die "unlink $diff: $!\n"; +} + +sub write_or_die +{ + my($file, $data) = @_; + my $fh = new IO::File ">$file" or die "$file: $!\n"; + $fh->print($data); +} + +sub run_or_die +{ + # print "[running @_]\n"; + system "@_" and die "@_: $?\n"; +} + +sub run +{ + # print "[running @_]\n"; + system "@_" and warn "@_: $?\n"; +} diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/devel/mkapidoc.sh b/gnu/usr.bin/perl/ext/Devel/PPPort/devel/mkapidoc.sh new file mode 100644 index 00000000000..25d67a73dba --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/devel/mkapidoc.sh @@ -0,0 +1,70 @@ +#!/bin/bash +################################################################################ +# +# mkapidoc.sh -- generate apidoc.fnc from scanning the Perl source +# +################################################################################ +# +# $Revision: 1.1 $ +# $Author: millert $ +# $Date: 2005/01/15 21:16:45 $ +# +################################################################################ +# +# Version 3.x, Copyright (C) 2004, Marcus Holland-Moritz. +# Version 2.x, Copyright (C) 2001, Paul Marquess. +# Version 1.x, Copyright (C) 1999, Kenneth Albanowski. +# +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. +# +################################################################################ + +function isperlroot +{ + [ -f "$1/embed.fnc" ] && [ -f "$1/perl.h" ] +} + +function usage +{ + echo "USAGE: $0 [perlroot] [output-file] [embed.fnc]" + exit 0 +} + +if [ -z "$1" ]; then + if isperlroot "../../.."; then + PERLROOT=../../.. + else + PERLROOT=. + fi +else + PERLROOT=$1 +fi + +if [ -z "$2" ]; then + if [ -f "parts/apidoc.fnc" ]; then + OUTPUT="parts/apidoc.fnc" + else + usage + fi +else + OUTPUT=$2 +fi + +if [ -z "$3" ]; then + if [ -f "parts/embed.fnc" ]; then + EMBED="parts/embed.fnc" + else + usage + fi +else + EMBED=$3 +fi + +if isperlroot $PERLROOT; then + grep -hr '=for apidoc' $PERLROOT | sed -e 's/=for apidoc //' | grep '|' | sort | uniq \ + | perl -e'$f=pop;open(F,$f)||die"$f:$!";while(<F>){(split/\|/)[2]=~/(\w+)/;$h{$1}++} + while(<>){(split/\|/)[2]=~/(\w+)/;$h{$1}||print}' $EMBED >$OUTPUT +else + usage +fi diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/devel/mktodo b/gnu/usr.bin/perl/ext/Devel/PPPort/devel/mktodo new file mode 100644 index 00000000000..dbcdf9653e9 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/devel/mktodo @@ -0,0 +1,60 @@ +#!/usr/bin/perl -w +################################################################################ +# +# mktodo -- generate baseline and todo files by running mktodo.pl +# +################################################################################ +# +# $Revision: 1.1 $ +# $Author: millert $ +# $Date: 2005/01/15 21:16:45 $ +# +################################################################################ +# +# Version 3.x, Copyright (C) 2004, Marcus Holland-Moritz. +# Version 2.x, Copyright (C) 2001, Paul Marquess. +# Version 1.x, Copyright (C) 1999, Kenneth Albanowski. +# +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. +# +################################################################################ + +use strict; +use Getopt::Long; + +my %opt = ( + base => 0, +); + +GetOptions(\%opt, qw( + base + )) or die; + +# my $outdir = $opt{base} ? 'parts/base' : 'parts/todo'; +my $outdir = 'parts/todo'; + +# for (glob "$outdir/*") { +# unlink or die "$_: $!\n"; +# } + +my $install = '/tmp/perl/install/default'; +# my $install = '/tmp/perl/install/thread'; + +my @perls = sort { $b->{version} <=> $a->{version} } + map { { version => `$_ -e 'printf "%.6f", \$]'`, path => $_ } } + ('bleadperl', glob "$install/*/bin/perl5.*"); + +for (1 .. $#perls) { + $perls[$_]{todo} = $perls[$_-1]{version}; +} + +shift @perls; + +for (@perls) { + my $todo = do { my $v = $_->{todo}; $v =~ s/\D+//g; $v }; + -e "$outdir/$todo" and next; + my @args = ('--perl', $_->{path}, '--todo', "$outdir/$todo", '--version', "$_->{todo}"); + push @args, '--base' if $opt{base}; + system 'devel/mktodo.pl', @args and die "system(@args): [$!] [$?]\n"; +} diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/devel/mktodo.pl b/gnu/usr.bin/perl/ext/Devel/PPPort/devel/mktodo.pl new file mode 100644 index 00000000000..b3bb9f2d79d --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/devel/mktodo.pl @@ -0,0 +1,210 @@ +#!/usr/bin/perl -w +################################################################################ +# +# mktodo.pl -- generate baseline and todo files +# +################################################################################ +# +# $Revision: 1.1 $ +# $Author: millert $ +# $Date: 2005/01/15 21:16:45 $ +# +################################################################################ +# +# Version 3.x, Copyright (C) 2004, Marcus Holland-Moritz. +# Version 2.x, Copyright (C) 2001, Paul Marquess. +# Version 1.x, Copyright (C) 1999, Kenneth Albanowski. +# +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. +# +################################################################################ + +use strict; +use Getopt::Long; +use Data::Dumper; +use IO::File; +use IO::Select; + +my %opt = ( + debug => 0, + base => 0, +); + +print "\n$0 @ARGV\n\n"; + +GetOptions(\%opt, qw( + perl=s todo=s version=s debug base + )) or die; + +my $fullperl = `which $opt{perl}`; +chomp $fullperl; + +regen_all(); + +my %sym; +for (`nm $fullperl`) { + chomp; + /\s+T\s+(\w+)\s*$/ and $sym{$1}++; +} +keys %sym >= 50 or die "less than 50 symbols found in $fullperl\n"; + +my %all = %{load_todo($opt{todo}, $opt{version})}; +my @recheck; + +for (;;) { + my $retry = 1; + regen_apicheck(); +retry: + my $r = run(qw(make test)); + $r->{didnotrun} and die "couldn't run make test: $!\n"; + $r->{status} == 0 and last; + my(@new, @tmp, %seen); + for my $l (@{$r->{stderr}}) { + if ($l =~ /_DPPP_test_(\w+)/) { + if (!$seen{$1}++) { + my @s = grep { exists $sym{$_} } $1, "Perl_$1", "perl_$1"; + if (@s) { + push @tmp, [$1, "E (@s)"]; + } + else { + push @new, [$1, "E"]; + } + } + } + if ($l =~ /undefined symbol: (?:[Pp]erl_)?(\w+)/) { + if (!$seen{$1}++) { + my @s = grep { exists $sym{$_} } $1, "Perl_$1", "perl_$1"; + push @new, [$1, @s ? "U (@s)" : "U"]; + } + } + } + @new = grep !$all{$_->[0]}, @new; + unless (@new) { + @new = grep !$all{$_->[0]}, @tmp; + # TODO: @recheck was here, find a better way to get recheck syms + # * we definitely don't have to check (U) symbols + # * try to grep out warnings before making symlist ? + } + unless (@new) { + if ($retry > 0) { + $retry--; + regen_all(); + goto retry; + } + print Dumper($r); + die "no new TODO symbols found..."; + } + push @recheck, map { $_->[0] } @new; + for (@new) { + printf "[$opt{version}] new symbol: %-30s # %s\n", @$_; + $all{$_->[0]} = $_->[1]; + } + write_todo($opt{todo}, $opt{version}, \%all); +} + +for my $sym (@recheck) { + my $cur = delete $all{$sym}; + printf "[$opt{version}] chk symbol: %-30s # %s\n", $sym, $cur; + write_todo($opt{todo}, $opt{version}, \%all); + regen_all(); + my $r = run(qw(make test)); + $r->{didnotrun} and die "couldn't run make test: $!\n"; + if ($r->{status} == 0) { + printf "[$opt{version}] del symbol: %-30s # %s\n", $sym, $cur; + } + else { + $all{$sym} = $cur; + } +} + +write_todo($opt{todo}, $opt{version}, \%all); + +run(qw(make realclean)); + +exit 0; + +sub regen_all +{ + my @mf_arg = qw( --with-apicheck OPTIMIZE=-O0 ); + push @mf_arg, qw( DEFINE=-DDPPP_APICHECK_NO_PPPORT_H ) if $opt{base}; + + # just to be sure + run(qw(make realclean)); + run($fullperl, "Makefile.PL", @mf_arg)->{status} == 0 + or die "cannot run Makefile.PL: $!\n"; +} + +sub regen_apicheck +{ + unlink qw(apicheck.c apicheck.o); + system "$fullperl apicheck_c.PL >/dev/null"; +} + +sub load_todo +{ + my($file, $expver) = @_; + + if (-e $file) { + my $f = new IO::File $file or die "cannot open $file: $!\n"; + my $ver = <$f>; + chomp $ver; + if ($ver eq $expver) { + my %sym; + while (<$f>) { + chomp; + /^(\w+)\s+#\s+(.*)/ or goto nuke_file; + exists $sym{$1} and goto nuke_file; + $sym{$1} = $2; + } + return \%sym; + } + +nuke_file: + undef $f; + unlink $file or die "cannot remove $file: $!\n"; + } + + return {}; +} + +sub write_todo +{ + my($file, $ver, $sym) = @_; + my $f; + + $f = new IO::File ">$file" or die "cannot open $file: $!\n"; + $f->print("$ver\n"); + + for (sort keys %$sym) { + $f->print(sprintf "%-30s # %s\n", $_, $sym->{$_}); + } +} + +sub run +{ + my $prog = shift; + my @args = @_; + + # print "[$prog @args]\n"; + + system "$prog @args >tmp.out 2>tmp.err"; + + my $out = new IO::File "tmp.out" || die "tmp.out: $!\n"; + my $err = new IO::File "tmp.err" || die "tmp.err: $!\n"; + + my %rval = ( + status => $? >> 8, + stdout => [<$out>], + stderr => [<$err>], + didnotrun => 0, + ); + + unlink "tmp.out", "tmp.err"; + + $? & 128 and $rval{core} = 1; + $? & 127 and $rval{signal} = $? & 127; + + \%rval; +} + diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/devel/scanprov b/gnu/usr.bin/perl/ext/Devel/PPPort/devel/scanprov new file mode 100644 index 00000000000..d53fb60cd6f --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/devel/scanprov @@ -0,0 +1,77 @@ +#!/usr/bin/perl -w +################################################################################ +# +# scanprov -- scan Perl headers for provided macros +# +################################################################################ +# +# $Revision: 1.1 $ +# $Author: millert $ +# $Date: 2005/01/15 21:16:45 $ +# +################################################################################ +# +# Version 3.x, Copyright (C) 2004, Marcus Holland-Moritz. +# Version 2.x, Copyright (C) 2001, Paul Marquess. +# Version 1.x, Copyright (C) 1999, Kenneth Albanowski. +# +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. +# +################################################################################ + +use strict; +require 'parts/ppptools.pl'; + +die "Usage: $0 [check|write]\n" unless @ARGV && $ARGV[0] =~ /^(check|write)$/; +my $mode = $1; + +my %embed = map { ( $_->{name} => 1 ) } + parse_embed(qw(parts/embed.fnc parts/apidoc.fnc)); + +my @provided = grep { !exists $embed{$_} } + map { /^(\w+)/ ? $1 : () } + `$^X ppport.h --list-provided`; + +my $install = '/tmp/perl/install/default'; + +my @perls = sort { $b->{version} <=> $a->{version} } + map { { version => `$_ -e 'printf "%.6f", \$]'`, path => $_ } } + ('bleadperl', glob "$install/*/bin/perl5.*"); + +for (1 .. $#perls) { + $perls[$_]{todo} = $perls[$_-1]{version}; +} + +shift @perls; + +my %v; + +for my $p (@perls) { + print "checking perl $p->{version}...\n"; + my $archlib = `$p->{path} -MConfig -l -e 'print \$Config{archlib}'`; + chomp $archlib; + local @ARGV = glob "$archlib/CORE/*.h"; + my %sym; + while (<>) { $sym{$_}++ for /(\w+)/g; } + @provided = map { $sym{$_} or $v{$p->{todo}}{$_}++; $sym{$_} ? $_ : () } @provided; +} + +my $out = 'parts/base'; +my $todo = parse_todo($out); + +for my $v (keys %v) { + my @new = sort grep { !exists $todo->{$_} } keys %{$v{$v}}; + @new or next; + my $file = $v; + $file =~ s/\.//g; + $file = "$out/$file"; + -e $file or die "non-existent: $file\n"; + print "-- $file --\n"; + $mode eq 'write' and (open F, ">>$file" or die "$file: $!\n"); + for (@new) { + print "adding $_\n"; + $mode eq 'write' and printf F "%-30s # added by $0\n", $_; + } + $mode eq 'write' and close F; +} diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/mktests.PL b/gnu/usr.bin/perl/ext/Devel/PPPort/mktests.PL new file mode 100644 index 00000000000..7c7a5f163b2 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/mktests.PL @@ -0,0 +1,94 @@ +################################################################################ +# +# mktests.PL -- generate test files for Devel::PPPort +# +################################################################################ +# +# $Revision: 1.1 $ +# $Author: millert $ +# $Date: 2005/01/15 21:16:45 $ +# +################################################################################ +# +# Version 3.x, Copyright (C) 2004, Marcus Holland-Moritz. +# Version 2.x, Copyright (C) 2001, Paul Marquess. +# Version 1.x, Copyright (C) 1999, Kenneth Albanowski. +# +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. +# +################################################################################ + +use strict; +$^W = 1; +require "parts/ppptools.pl"; + +my $template = do { local $/; <DATA> }; + +my $file; +for $file (glob 'parts/inc/*') { + my($testfile) = $file =~ /(\w+)$/; + $testfile = "t/$testfile.t"; + + my $spec = parse_partspec($file); + my $plan = 0; + + if (exists $spec->{tests}) { + exists $spec->{OPTIONS}{tests} && + exists $spec->{OPTIONS}{tests}{plan} + or die "No plan for tests in $file\n"; + + print "generating $testfile\n"; + + my $tmpl = $template; + $tmpl =~ s/__SOURCE__/$file/mg; + $tmpl =~ s/__PLAN__/$spec->{OPTIONS}{tests}{plan}/mg; + $tmpl =~ s/^__TESTS__$/$spec->{tests}/mg; + + open FH, ">$testfile" or die "$testfile: $!\n"; + print FH $tmpl; + close FH; + } +} + +exit 0; + +__DATA__ +################################################################################ +# +# !!!!! Do NOT edit this file directly! !!!!! +# +# Edit mktests.PL and/or __SOURCE__ instead. +# +################################################################################ + +BEGIN { + if ($ENV{'PERL_CORE'}) { + chdir 't' if -d 't'; + @INC = ('../lib', '../ext/Devel/PPPort/t') if -d '../lib' && -d '../ext'; + require Config; import Config; + use vars '%Config'; + if (" $Config{'extensions'} " !~ m[ Devel/PPPort ]) { + print "1..0 # Skip -- Perl configured without Devel::PPPort module\n"; + exit 0; + } + } + else { + unshift @INC, 't'; + } + + eval "use Test"; + if ($@) { + require 'testutil.pl'; + print "1..__PLAN__\n"; + } + else { + plan(tests => __PLAN__); + } +} + +use Devel::PPPort; +use strict; +$^W = 1; + +__TESTS__ diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/apicheck.pl b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/apicheck.pl new file mode 100644 index 00000000000..9219805f7d7 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/apicheck.pl @@ -0,0 +1,299 @@ +#!/usr/bin/perl -w +################################################################################ +# +# apicheck.pl -- generate C source for automated API check +# +################################################################################ +# +# $Revision: 1.1 $ +# $Author: millert $ +# $Date: 2005/01/15 21:16:45 $ +# +################################################################################ +# +# Version 3.x, Copyright (C) 2004, Marcus Holland-Moritz. +# Version 2.x, Copyright (C) 2001, Paul Marquess. +# Version 1.x, Copyright (C) 1999, Kenneth Albanowski. +# +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. +# +################################################################################ + +use strict; +require 'parts/ppptools.pl'; + +if (@ARGV) { + open OUT, ">$ARGV[0]" or die "$ARGV[0]: $!\n"; +} +else { + *OUT = \*STDOUT; +} + +my @f = parse_embed(qw( parts/embed.fnc parts/apidoc.fnc )); + +my %todo = %{&parse_todo}; + +my %tmap = ( + void => 'int', +); + +my %amap = ( + SP => 'SP', + type => 'int', + cast => 'int', +); + +my %void = ( + void => 1, + Free_t => 1, + Signal_t => 1, +); + +my %castvoid = ( + map { ($_ => 1) } qw( + Nullav + Nullcv + Nullhv + Nullch + Nullsv + HEf_SVKEY + SP + MARK + SVt_PV + SVt_IV + SVt_NV + SVt_PVMG + SVt_PVAV + SVt_PVHV + SVt_PVCV + SvUOK + G_SCALAR + G_ARRAY + G_VOID + G_DISCARD + G_EVAL + G_NOARGS + XS_VERSION + ), +); + +my %ignorerv = ( + map { ($_ => 1) } qw( + newCONSTSUB + ), +); + +my %stack = ( + ORIGMARK => ['dORIGMARK;'], + POPpx => ['STRLEN n_a;'], + POPpbytex => ['STRLEN n_a;'], + PUSHp => ['dTARG;'], + PUSHn => ['dTARG;'], + PUSHi => ['dTARG;'], + PUSHu => ['dTARG;'], + XPUSHp => ['dTARG;'], + XPUSHn => ['dTARG;'], + XPUSHi => ['dTARG;'], + XPUSHu => ['dTARG;'], + UNDERBAR => ['dUNDERBAR;'], +); + +my %postcode = ( + dSP => "some_global_var = !sp;", + dMARK => "some_global_var = !mark;", + dORIGMARK => "some_global_var = !origmark;", + dAX => "some_global_var = !ax;", + dITEMS => "some_global_var = !items;", + dXSARGS => "some_global_var = ax && items;", + NEWSV => "some_global_var = !arg1;", + New => "some_global_var = !arg1;", + Newc => "some_global_var = !arg1;", + Newz => "some_global_var = !arg1;", + dUNDERBAR => "(void) UNDERBAR;", +); + +my %ignore = ( + map { ($_ => 1) } qw( + svtype + items + ix + dXSI32 + XS + CLASS + THIS + RETVAL + StructCopy + ), +); + +print OUT <<HEAD; +/* + * !!!!!!! DO NOT EDIT THIS FILE !!!!!!! + * This file is built by $0. + * Any changes made here will be lost! + */ + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#ifndef DPPP_APICHECK_NO_PPPORT_H + +#define NEED_eval_pv +#define NEED_grok_bin +#define NEED_grok_hex +#define NEED_grok_number +#define NEED_grok_numeric_radix +#define NEED_grok_oct +#define NEED_newCONSTSUB +#define NEED_newRV_noinc +#define NEED_sv_2pv_nolen +#define NEED_sv_2pvbyte +#define NEED_sv_catpvf_mg +#define NEED_sv_catpvf_mg_nocontext +#define NEED_sv_setpvf_mg +#define NEED_sv_setpvf_mg_nocontext +#define NEED_vnewSVpvf + + +#include "ppport.h" + +#endif + +static int some_global_var; + +static int VARarg1; +static char *VARarg2; +static double VARarg3; + +HEAD + +my $f; +for $f (@f) { + $ignore{$f->{name}} and next; + $f->{flags}{A} or next; # only public API members + + $ignore{$f->{name}} = 1; # ignore duplicates + + my $Perl_ = $f->{flags}{p} ? 'Perl_' : ''; + + my $stack = ''; + my @arg; + my $aTHX = ''; + + my $i = 1; + my $ca; + my $varargs = 0; + for $ca (@{$f->{args}}) { + my $a = $ca->[0]; + if ($a eq '...') { + $varargs = 1; + push @arg, qw(VARarg1 VARarg2 VARarg3); + last; + } + my($n, $p, $d) = $a =~ /^(\w+(?:\s+\w+)*)\s*(\**)((?:\[[^\]]*\])*)$/ or die; + if (exists $amap{$n}) { + push @arg, $amap{$n}; + next; + } + $n = $tmap{$n} || $n; + my $v = 'arg' . $i++; + push @arg, $v; + $stack .= " static $n $p$v$d;\n"; + } + + unless ($f->{flags}{n} || $f->{flags}{'m'}) { + $stack = " dTHX;\n$stack"; + $aTHX = @arg ? 'aTHX_ ' : 'aTHX'; + } + + if ($stack{$f->{name}}) { + my $s = ''; + for (@{$stack{$f->{name}}}) { + $s .= " $_\n"; + } + $stack = "$s$stack"; + } + + my $args = join ', ', @arg; + my $rvt = $f->{ret} || 'void'; + my $ret; + if ($void{$rvt}) { + $ret = $castvoid{$f->{name}} ? '(void) ' : ''; + } + else { + $ret = $ignorerv{$f->{name}} ? '(void) ' : "return "; + } + my $aTHX_args = "$aTHX$args"; + + my $post = ''; + if ($postcode{$f->{name}}) { + $post = $postcode{$f->{name}}; + $post =~ s/^/ /g; + $post = "\n$post"; + } + + unless ($f->{flags}{'m'} and @arg == 0) { + $args = "($args)"; + $aTHX_args = "($aTHX_args)"; + } + + print OUT <<HEAD; +/****************************************************************************** +* +* $f->{name} +* +******************************************************************************/ + +HEAD + + if ($todo{$f->{name}}) { + my($ver,$sub) = $todo{$f->{name}} =~ /^5\.(\d{3})(\d{3})$/ or die; + for ($ver, $sub) { + s/^0+(\d)/$1/ + } + if ($ver < 6 && $sub > 0) { + $sub =~ s/0$// or die; + } + print OUT "#if PERL_VERSION > $ver || (PERL_VERSION == $ver && PERL_SUBVERSION >= $sub) /* TODO */\n"; + } + + my $final = $varargs + ? "$Perl_$f->{name}$aTHX_args" + : "$f->{name}$args"; + + $f->{cond} and print OUT "#if $f->{cond}\n"; + + print OUT <<END; +$rvt _DPPP_test_$f->{name} (void) +{ + dXSARGS; +$stack +#ifdef $f->{name} + if (some_global_var) + { + $ret$f->{name}$args;$post + } +#endif + + some_global_var = items && ax; + + { +#ifdef $f->{name} + $ret$final;$post +#else + $ret$Perl_$f->{name}$aTHX_args;$post +#endif + } +} +END + + $f->{cond} and print OUT "#endif\n"; + $todo{$f->{name}} and print OUT "#endif\n"; + + print OUT "\n"; +} + +@ARGV and close OUT; + diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/apidoc.fnc b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/apidoc.fnc new file mode 100644 index 00000000000..0e67f047d41 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/apidoc.fnc @@ -0,0 +1,267 @@ +Am|bool|isALNUM|char ch +Am|bool|isALPHA|char ch +Am|bool|isDIGIT|char ch +Am|bool|isLOWER|char ch +Am|bool|isSPACE|char ch +Am|bool|isUPPER|char ch +Am|bool|strEQ|char* s1|char* s2 +Am|bool|strGE|char* s1|char* s2 +Am|bool|strGT|char* s1|char* s2 +Am|bool|strLE|char* s1|char* s2 +Am|bool|strLT|char* s1|char* s2 +Am|bool|strNE|char* s1|char* s2 +Am|bool|strnEQ|char* s1|char* s2|STRLEN len +Am|bool|strnNE|char* s1|char* s2|STRLEN len +Am|bool|SvIOK_notUV|SV* sv +Am|bool|SvIOKp|SV* sv +Am|bool|SvIOK|SV* sv +Am|bool|SvIOK_UV|SV* sv +Am|bool|SvIsCOW_shared_hash|SV* sv +Am|bool|SvIsCOW|SV* sv +Am|bool|SvNIOKp|SV* sv +Am|bool|SvNIOK|SV* sv +Am|bool|SvNOKp|SV* sv +Am|bool|SvNOK|SV* sv +Am|bool|SvOK|SV* sv +Am|bool|SvOOK|SV* sv +Am|bool|SvPOKp|SV* sv +Am|bool|SvPOK|SV* sv +Am|bool|SvROK|SV* sv +Am|bool|SvTAINTED|SV* sv +Am|bool|SvTRUE|SV* sv +Am|bool|SvUTF8|SV* sv +Am|bool|SvVOK|SV* sv +Am|char*|HePV|HE* he|STRLEN len +Am|char*|HvNAME|HV* stash +Am|char*|SvEND|SV* sv +Am|char *|SvGROW|SV* sv|STRLEN len +Am|char*|SvPVbyte_force|SV* sv|STRLEN len +Am|char*|SvPVbyte_nolen|SV* sv +Am|char*|SvPVbyte|SV* sv|STRLEN len +Am|char*|SvPVbytex_force|SV* sv|STRLEN len +Am|char*|SvPVbytex|SV* sv|STRLEN len +Am|char*|SvPV_force_nomg|SV* sv|STRLEN len +Am|char*|SvPV_force|SV* sv|STRLEN len +Am|char*|SvPV_nolen|SV* sv +Am|char*|SvPV_nomg|SV* sv|STRLEN len +Am|char*|SvPV|SV* sv|STRLEN len +Am|char*|SvPVutf8_force|SV* sv|STRLEN len +Am|char*|SvPVutf8_nolen|SV* sv +Am|char*|SvPVutf8|SV* sv|STRLEN len +Am|char*|SvPVutf8x_force|SV* sv|STRLEN len +Am|char*|SvPVutf8x|SV* sv|STRLEN len +Am|char*|SvPVX|SV* sv +Am|char*|SvPVx|SV* sv|STRLEN len +Am|char|toLOWER|char ch +Am|char|toUPPER|char ch +Am|HV*|CvSTASH|CV* cv +Am|HV*|SvSTASH|SV* sv +Am|int|AvFILL|AV* av +Am|IV|SvIV_nomg|SV* sv +Am|IV|SvIV|SV* sv +Am|IV|SvIVx|SV* sv +Am|IV|SvIVX|SV* sv +Amn|char*|CLASS +Amn|char*|POPp +Amn|char*|POPpbytex +Amn|char*|POPpx +Amn|HV*|PL_modglobal +Amn|I32|ax +Amn|I32|items +Amn|I32|ix +Amn|IV|POPi +Amn|long|POPl +Amn|NV|POPn +Amn|STRLEN|PL_na +Amn|SV|PL_sv_no +Amn|SV|PL_sv_undef +Amn|SV|PL_sv_yes +Amn|SV*|POPs +Amn|U32|GIMME +Amn|U32|GIMME_V +Am|NV|SvNV|SV* sv +Am|NV|SvNVx|SV* sv +Am|NV|SvNVX|SV* sv +Amn|(whatever)|RETVAL +Amn|(whatever)|THIS +Ams||dAX +Ams||dITEMS +Ams||dMARK +Ams||dORIGMARK +Ams||dSP +Ams||dUNDERBAR +Ams||dXSARGS +Ams||dXSI32 +Ams||ENTER +Ams||FREETMPS +Ams||LEAVE +Ams||PUTBACK +Ams||SAVETMPS +Ams||SPAGAIN +Am|STRLEN|HeKLEN|HE* he +Am|STRLEN|SvCUR|SV* sv +Am|STRLEN|SvLEN|SV* sv +Am|SV*|GvSV|GV* gv +Am|SV*|HeSVKEY_force|HE* he +Am|SV*|HeSVKEY|HE* he +Am|SV*|HeSVKEY_set|HE* he|SV* sv +Am|SV*|HeVAL|HE* he +Am|SV*|newRV_inc|SV* sv +Am|SV*|NEWSV|int id|STRLEN len +Am|SV*|ST|int ix +Am|SV*|SvREFCNT_inc|SV* sv +Am|SV*|SvRV|SV* sv +Am|svtype|SvTYPE|SV* sv +Ams||XSRETURN_EMPTY +Ams||XSRETURN_NO +Ams||XSRETURN_UNDEF +Ams||XSRETURN_YES +Ams||XS_VERSION_BOOTCHECK +Am|U32|HeHASH|HE* he +Am|U32|SvREFCNT|SV* sv +AmU||G_ARRAY +AmU||G_DISCARD +AmU||G_EVAL +AmU||G_NOARGS +AmU||G_SCALAR +AmU||G_VOID +AmU||HEf_SVKEY +AmU||MARK +AmU||newXSproto|char* name|XSUBADDR_t f|char* filename|const char *proto +AmU||Nullav +AmU||Nullch +AmU||Nullcv +AmU||Nullhv +AmU||Nullsv +AmU||ORIGMARK +AmU||SP +AmU||SVt_IV +AmU||SVt_NV +AmU||SVt_PV +AmU||SVt_PVAV +AmU||SVt_PVCV +AmU||SVt_PVHV +AmU||SVt_PVMG +AmU||svtype +AmU||UNDERBAR +Am|UV|SvUV_nomg|SV* sv +Am|UV|SvUV|SV* sv +Am|UV|SvUVx|SV* sv +Am|UV|SvUVX|SV* sv +AmU||XS +AmU||XS_VERSION +Am|void *|CopyD|void* src|void* dest|int nitems|type +Am|void|Copy|void* src|void* dest|int nitems|type +Am|void|EXTEND|SP|int nitems +Am|void*|HeKEY|HE* he +Am|void *|MoveD|void* src|void* dest|int nitems|type +Am|void|Move|void* src|void* dest|int nitems|type +Am|void|mPUSHi|IV iv +Am|void|mPUSHn|NV nv +Am|void|mPUSHp|char* str|STRLEN len +Am|void|mPUSHu|UV uv +Am|void|mXPUSHi|IV iv +Am|void|mXPUSHn|NV nv +Am|void|mXPUSHp|char* str|STRLEN len +Am|void|mXPUSHu|UV uv +Am|void|Newc|int id|void* ptr|int nitems|type|cast +Am|void|New|int id|void* ptr|int nitems|type +Am|void|Newz|int id|void* ptr|int nitems|type +Am|void|Poison|void* dest|int nitems|type +Am|void|PUSHi|IV iv +Am|void|PUSHMARK|SP +Am|void|PUSHmortal +Am|void|PUSHn|NV nv +Am|void|PUSHp|char* str|STRLEN len +Am|void|PUSHs|SV* sv +Am|void|PUSHu|UV uv +Am|void|Renewc|void* ptr|int nitems|type|cast +Am|void|Renew|void* ptr|int nitems|type +Am|void|Safefree|void* ptr +Am|void|StructCopy|type src|type dest|type +Am|void|sv_catpvn_nomg|SV* sv|const char* ptr|STRLEN len +Am|void|sv_catsv_nomg|SV* dsv|SV* ssv +Am|void|SvCUR_set|SV* sv|STRLEN len +Am|void|SvGETMAGIC|SV* sv +Am|void|SvIOK_off|SV* sv +Am|void|SvIOK_only|SV* sv +Am|void|SvIOK_only_UV|SV* sv +Am|void|SvIOK_on|SV* sv +Am|void|SvLOCK|SV* sv +Am|void|SvNIOK_off|SV* sv +Am|void|SvNOK_off|SV* sv +Am|void|SvNOK_only|SV* sv +Am|void|SvNOK_on|SV* sv +Am|void|SvPOK_off|SV* sv +Am|void|SvPOK_only|SV* sv +Am|void|SvPOK_only_UTF8|SV* sv +Am|void|SvPOK_on|SV* sv +Am|void|SvREFCNT_dec|SV* sv +Am|void|SvROK_off|SV* sv +Am|void|SvROK_on|SV* sv +Am|void|SvSetMagicSV_nosteal|SV* dsv|SV* ssv +Am|void|SvSETMAGIC|SV* sv +Am|void|SvSetMagicSV|SV* dsb|SV* ssv +Am|void|sv_setsv_nomg|SV* dsv|SV* ssv +Am|void|SvSetSV_nosteal|SV* dsv|SV* ssv +Am|void|SvSetSV|SV* dsb|SV* ssv +Am|void|SvSHARE|SV* sv +Am|void|SvTAINTED_off|SV* sv +Am|void|SvTAINTED_on|SV* sv +Am|void|SvTAINT|SV* sv +Am|void|SvUNLOCK|SV* sv +Am|void|SvUOK|SV* sv +Am|void|SvUPGRADE|SV* sv|svtype type +Am|void|SvUTF8_off|SV *sv +Am|void|SvUTF8_on|SV *sv +Am|void|XPUSHi|IV iv +Am|void|XPUSHmortal +Am|void|XPUSHn|NV nv +Am|void|XPUSHp|char* str|STRLEN len +Am|void|XPUSHs|SV* sv +Am|void|XPUSHu|UV uv +Am|void|XSRETURN|int nitems +Am|void|XSRETURN_IV|IV iv +Am|void|XSRETURN_NV|NV nv +Am|void|XSRETURN_PV|char* str +Am|void|XSRETURN_UV|IV uv +Am|void|XST_mIV|int pos|IV iv +Am|void|XST_mNO|int pos +Am|void|XST_mNV|int pos|NV nv +Am|void|XST_mPV|int pos|char* str +Am|void|XST_mUNDEF|int pos +Am|void|XST_mYES|int pos +Am|void *|ZeroD|void* dest|int nitems|type +Am|void|Zero|void* dest|int nitems|type +m|AV *|CvPADLIST|CV *cv +m|bool|CvWEAKOUTSIDE|CV *cv +m|char *|PAD_COMPNAME_PV|PADOFFSET po +m|HV *|PAD_COMPNAME_OURSTASH|PADOFFSET po +m|HV *|PAD_COMPNAME_TYPE|PADOFFSET po +mn|bool|PL_dowarn +mn|GV *|PL_DBsub +mn|GV*|PL_last_in_gv +mn|SV *|PL_DBsingle +mn|SV *|PL_DBtrace +mn|SV*|PL_ofs_sv +mn|SV*|PL_rs +ms||djSP +m|STRLEN|PAD_COMPNAME_GEN|PADOFFSET po +m|SV *|CX_CURPAD_SV|struct context|PADOFFSET po +m|SV *|PAD_BASE_SV |PADLIST padlist|PADOFFSET po +m|SV *|PAD_SETSV |PADOFFSET po|SV* sv +m|SV *|PAD_SVl |PADOFFSET po +m|U32|PAD_COMPNAME_FLAGS|PADOFFSET po +mU||LVRET +m|void|CX_CURPAD_SAVE|struct context +m|void|PAD_CLONE_VARS|PerlInterpreter *proto_perl \ +m|void|PAD_DUP|PADLIST dstpad|PADLIST srcpad|CLONE_PARAMS* param +m|void|PAD_RESTORE_LOCAL|PAD *opad +m|void|PAD_SAVE_LOCAL|PAD *opad|PAD *npad +m|void|PAD_SAVE_SETNULLPAD +m|void|PAD_SET_CUR_NOSAVE |PADLIST padlist|I32 n +m|void|PAD_SET_CUR |PADLIST padlist|I32 n +m|void|PAD_SV |PADOFFSET po +m|void|SAVECLEARSV |SV **svp +m|void|SAVECOMPPAD +m|void|SAVEPADSV |PADOFFSET po diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5004000 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5004000 new file mode 100644 index 00000000000..795d0cbc01c --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5004000 @@ -0,0 +1,48 @@ +5.004000 +GIMME_V # E +G_VOID # E +HEf_SVKEY # E +HeHASH # U +HeKEY # E +HeKLEN # U +HePV # E +HeSVKEY # E +HeSVKEY_force # E +HeSVKEY_set # E +HeVAL # E +PUSHu # U +SvSetMagicSV # U +SvSetMagicSV_nosteal # U +SvSetSV_nosteal # U +SvTAINTED # U +SvTAINTED_off # U +SvTAINTED_on # U +SvUV # U +SvUVX # U +SvUVx # U +XPUSHu # U +my_memcmp # U +newRV_inc # E +sv_2uv # U +PERL_INT_MAX # added by devel/scanprov +PERL_INT_MIN # added by devel/scanprov +PERL_LONG_MAX # added by devel/scanprov +PERL_LONG_MIN # added by devel/scanprov +PERL_QUAD_MAX # added by devel/scanprov +PERL_QUAD_MIN # added by devel/scanprov +PERL_SHORT_MAX # added by devel/scanprov +PERL_SHORT_MIN # added by devel/scanprov +PERL_UCHAR_MAX # added by devel/scanprov +PERL_UCHAR_MIN # added by devel/scanprov +PERL_UINT_MAX # added by devel/scanprov +PERL_UINT_MIN # added by devel/scanprov +PERL_ULONG_MAX # added by devel/scanprov +PERL_ULONG_MIN # added by devel/scanprov +PERL_UQUAD_MAX # added by devel/scanprov +PERL_UQUAD_MIN # added by devel/scanprov +PERL_USHORT_MAX # added by devel/scanprov +PERL_USHORT_MIN # added by devel/scanprov +SvUVXx # added by devel/scanprov +boolSV # added by devel/scanprov +memEQ # added by devel/scanprov +memNE # added by devel/scanprov diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5004010 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5004010 new file mode 100644 index 00000000000..8c298666039 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5004010 @@ -0,0 +1 @@ +5.004010 diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5004020 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5004020 new file mode 100644 index 00000000000..4b43fdf8e46 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5004020 @@ -0,0 +1 @@ +5.004020 diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5004030 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5004030 new file mode 100644 index 00000000000..e45facbb1f9 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5004030 @@ -0,0 +1 @@ +5.004030 diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5004040 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5004040 new file mode 100644 index 00000000000..69ccd5d62c5 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5004040 @@ -0,0 +1 @@ +5.004040 diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5004050 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5004050 new file mode 100644 index 00000000000..4b43177c8ca --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5004050 @@ -0,0 +1,29 @@ +5.004050 +PL_na # E +PL_sv_no # E +PL_sv_undef # E +PL_sv_yes # E +SvGETMAGIC # U +AvFILLp # added by devel/scanprov +DEFSV # added by devel/scanprov +ERRSV # added by devel/scanprov +PL_compiling # added by devel/scanprov +PL_curcop # added by devel/scanprov +PL_curstash # added by devel/scanprov +PL_defgv # added by devel/scanprov +PL_dirty # added by devel/scanprov +PL_perldb # added by devel/scanprov +PL_rsfp # added by devel/scanprov +PL_rsfp_filters # added by devel/scanprov +PL_stdingv # added by devel/scanprov +SAVE_DEFSV # added by devel/scanprov +dTHR # added by devel/scanprov +PL_debstash # added by devel/scanprov +PL_diehook # added by devel/scanprov +PL_errgv # added by devel/scanprov +PL_perl_destruct_level # added by devel/scanprov +PL_stack_base # added by devel/scanprov +PL_stack_sp # added by devel/scanprov +PL_sv_arenaroot # added by devel/scanprov +PL_tainted # added by devel/scanprov +PL_tainting # added by devel/scanprov diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5005000 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5005000 new file mode 100644 index 00000000000..f0bfeed5a2e --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5005000 @@ -0,0 +1,10 @@ +5.005000 +PL_modglobal # E +NOOP # added by devel/scanprov +PL_Sv # added by devel/scanprov +PL_copline # added by devel/scanprov +PL_hexdigit # added by devel/scanprov +PL_hints # added by devel/scanprov +END_EXTERN_C # added by devel/scanprov +EXTERN_C # added by devel/scanprov +START_EXTERN_C # added by devel/scanprov diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5005010 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5005010 new file mode 100644 index 00000000000..deebff5bf8a --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5005010 @@ -0,0 +1 @@ +5.005010 diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5005020 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5005020 new file mode 100644 index 00000000000..d19ff2ae09e --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5005020 @@ -0,0 +1 @@ +5.005020 diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5005030 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5005030 new file mode 100644 index 00000000000..3a7d375072b --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5005030 @@ -0,0 +1,2 @@ +5.005030 +POPpx # E diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5005040 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5005040 new file mode 100644 index 00000000000..8a165c20337 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5005040 @@ -0,0 +1 @@ +5.005040 diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5006000 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5006000 new file mode 100644 index 00000000000..6705683ed3a --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5006000 @@ -0,0 +1,504 @@ +5.006000 +Gv_AMupdate # E (Perl_Gv_AMupdate) +POPn # E +PUSHn # E +SvIOK_UV # U +SvIOK_notUV # U +SvIOK_only_UV # U +SvNV # E +SvNVX # E +SvNVx # E +SvPOK_only_UTF8 # U +SvPV_nolen # E +SvPVbyte # E +SvPVbyte_nolen # E +SvPVbytex # E +SvPVbytex_force # E +SvPVutf8 # E +SvPVutf8_force # E +SvPVutf8_nolen # E +SvPVutf8x # E +SvPVutf8x_force # E +SvUTF8 # U +SvUTF8_off # U +SvUTF8_on # U +XPUSHn # E +XSRETURN_NV # E +XST_mNV # E +amagic_call # E (Perl_amagic_call) +av_clear # E (Perl_av_clear) +av_delete # E +av_exists # E +av_extend # E (Perl_av_extend) +av_fetch # E (Perl_av_fetch) +av_fill # E (Perl_av_fill) +av_len # E (Perl_av_len) +av_make # E (Perl_av_make) +av_pop # E (Perl_av_pop) +av_push # E (Perl_av_push) +av_shift # E (Perl_av_shift) +av_store # E (Perl_av_store) +av_undef # E (Perl_av_undef) +av_unshift # E (Perl_av_unshift) +block_gimme # E (Perl_block_gimme) +call_argv # E (perl_call_argv) +call_atexit # E +call_list # E (Perl_call_list) +call_method # E (perl_call_method) +call_pv # E (perl_call_pv) +call_sv # E (perl_call_sv) +cast_i32 # E (cast_i32) +cast_iv # E (cast_iv) +cast_ulong # E +cast_uv # E (cast_uv) +croak # E (Perl_croak) +cv_const_sv # E (Perl_cv_const_sv) +cv_undef # E (Perl_cv_undef) +cx_dump # E (Perl_cx_dump) +debop # E (Perl_debop) +debprofdump # E (Perl_debprofdump) +delimcpy # E (Perl_delimcpy) +die # E (Perl_die) +do_binmode # E (Perl_do_binmode) +do_close # E (Perl_do_close) +do_gv_dump # E +do_gvgv_dump # E +do_hv_dump # E +do_join # E (Perl_do_join) +do_magic_dump # E +do_op_dump # E +do_open # E (Perl_do_open) +do_open9 # E +do_pmop_dump # E +do_sprintf # E (Perl_do_sprintf) +do_sv_dump # E +dounwind # E (Perl_dounwind) +dowantarray # E (Perl_dowantarray) +dump_all # E +dump_eval # E +dump_form # E +dump_indent # E +dump_packsubs # E +dump_sub # E +dump_vindent # E +eval_pv # E (perl_eval_pv) +eval_sv # E (perl_eval_sv) +fbm_compile # E (Perl_fbm_compile) +fbm_instr # E (Perl_fbm_instr) +filter_add # E (Perl_filter_add) +filter_del # E (Perl_filter_del) +filter_read # E (Perl_filter_read) +form # E (Perl_form) +free_tmps # E (Perl_free_tmps) +get_av # E (perl_get_av) +get_context # E +get_cv # E (perl_get_cv) +get_hv # E (perl_get_hv) +get_op_descs # E (Perl_get_op_descs) +get_op_names # E (Perl_get_op_names) +get_ppaddr # E +get_sv # E (perl_get_sv) +get_vtbl # E (Perl_get_vtbl) +gp_free # E (Perl_gp_free) +gp_ref # E (Perl_gp_ref) +gv_AVadd # E (Perl_gv_AVadd) +gv_HVadd # E (Perl_gv_HVadd) +gv_IOadd # E (Perl_gv_IOadd) +gv_autoload4 # E (Perl_gv_autoload4) +gv_check # E (Perl_gv_check) +gv_dump # E +gv_efullname # E (Perl_gv_efullname) +gv_efullname3 # E (Perl_gv_efullname3) +gv_fetchfile # E (Perl_gv_fetchfile) +gv_fetchmeth # E (Perl_gv_fetchmeth) +gv_fetchmethod # E (Perl_gv_fetchmethod) +gv_fetchmethod_autoload # E (Perl_gv_fetchmethod_autoload) +gv_fetchpv # E (Perl_gv_fetchpv) +gv_fullname # E (Perl_gv_fullname) +gv_fullname3 # E (Perl_gv_fullname3) +gv_init # E (Perl_gv_init) +gv_stashpv # E (Perl_gv_stashpv) +gv_stashpvn # E (Perl_gv_stashpvn) +gv_stashsv # E (Perl_gv_stashsv) +hv_clear # E (Perl_hv_clear) +hv_delayfree_ent # E (Perl_hv_delayfree_ent) +hv_delete # E (Perl_hv_delete) +hv_delete_ent # E (Perl_hv_delete_ent) +hv_exists # E (Perl_hv_exists) +hv_exists_ent # E (Perl_hv_exists_ent) +hv_fetch # E (Perl_hv_fetch) +hv_fetch_ent # E (Perl_hv_fetch_ent) +hv_free_ent # E (Perl_hv_free_ent) +hv_iterinit # E (Perl_hv_iterinit) +hv_iterkey # E (Perl_hv_iterkey) +hv_iterkeysv # E (Perl_hv_iterkeysv) +hv_iternext # E (Perl_hv_iternext) +hv_iternextsv # E (Perl_hv_iternextsv) +hv_iterval # E (Perl_hv_iterval) +hv_ksplit # E (Perl_hv_ksplit) +hv_magic # E (Perl_hv_magic) +hv_store # E (Perl_hv_store) +hv_store_ent # E (Perl_hv_store_ent) +hv_undef # E (Perl_hv_undef) +ibcmp # E (Perl_ibcmp) +ibcmp_locale # E (Perl_ibcmp_locale) +init_i18nl10n # E (perl_init_i18nl10n) +init_i18nl14n # E (perl_init_i18nl14n) +init_stacks # E (Perl_init_stacks) +instr # E (Perl_instr) +is_uni_alnum # E +is_uni_alnum_lc # E +is_uni_alnumc # E +is_uni_alnumc_lc # E +is_uni_alpha # E +is_uni_alpha_lc # E +is_uni_ascii # E +is_uni_ascii_lc # E +is_uni_cntrl # E +is_uni_cntrl_lc # E +is_uni_digit # E +is_uni_digit_lc # E +is_uni_graph # E +is_uni_graph_lc # E +is_uni_idfirst # E +is_uni_idfirst_lc # E +is_uni_lower # E +is_uni_lower_lc # E +is_uni_print # E +is_uni_print_lc # E +is_uni_punct # E +is_uni_punct_lc # E +is_uni_space # E +is_uni_space_lc # E +is_uni_upper # E +is_uni_upper_lc # E +is_uni_xdigit # E +is_uni_xdigit_lc # E +is_utf8_alnum # E +is_utf8_alnumc # E +is_utf8_alpha # E +is_utf8_ascii # E +is_utf8_char # E +is_utf8_cntrl # E +is_utf8_digit # E +is_utf8_graph # E +is_utf8_idfirst # E +is_utf8_lower # E +is_utf8_mark # E +is_utf8_print # E +is_utf8_punct # E +is_utf8_space # E +is_utf8_upper # E +is_utf8_xdigit # E +leave_scope # E (Perl_leave_scope) +load_module # E +looks_like_number # E (Perl_looks_like_number) +magic_dump # E +markstack_grow # E (Perl_markstack_grow) +mess # E (Perl_mess) +mg_clear # E (Perl_mg_clear) +mg_copy # E (Perl_mg_copy) +mg_find # E (Perl_mg_find) +mg_free # E (Perl_mg_free) +mg_get # E (Perl_mg_get) +mg_length # E (Perl_mg_length) +mg_magical # E (Perl_mg_magical) +mg_set # E (Perl_mg_set) +mg_size # E (Perl_mg_size) +moreswitches # E (Perl_moreswitches) +my_atof # E +my_exit # E (Perl_my_exit) +my_failure_exit # E (Perl_my_failure_exit) +my_fflush_all # E +my_lstat # E (Perl_my_lstat) +my_pclose # E (Perl_my_pclose) +my_popen # E (Perl_my_popen) +my_setenv # E (Perl_my_setenv) +my_stat # E (Perl_my_stat) +newANONATTRSUB # E +newANONHASH # E (Perl_newANONHASH) +newANONLIST # E (Perl_newANONLIST) +newANONSUB # E (Perl_newANONSUB) +newASSIGNOP # E (Perl_newASSIGNOP) +newATTRSUB # E +newAV # E (Perl_newAV) +newAVREF # E (Perl_newAVREF) +newBINOP # E (Perl_newBINOP) +newCONDOP # E (Perl_newCONDOP) +newCONSTSUB # E (Perl_newCONSTSUB) +newCVREF # E (Perl_newCVREF) +newFORM # E (Perl_newFORM) +newFOROP # E (Perl_newFOROP) +newGVOP # E (Perl_newGVOP) +newGVREF # E (Perl_newGVREF) +newGVgen # E (Perl_newGVgen) +newHV # E (Perl_newHV) +newHVREF # E (Perl_newHVREF) +newHVhv # E (Perl_newHVhv) +newIO # E (Perl_newIO) +newLISTOP # E (Perl_newLISTOP) +newLOGOP # E (Perl_newLOGOP) +newLOOPEX # E (Perl_newLOOPEX) +newLOOPOP # E (Perl_newLOOPOP) +newMYSUB # E +newNULLLIST # E (Perl_newNULLLIST) +newOP # E (Perl_newOP) +newPADOP # E +newPMOP # E (Perl_newPMOP) +newPROG # E (Perl_newPROG) +newPVOP # E (Perl_newPVOP) +newRANGE # E (Perl_newRANGE) +newRV # E (Perl_newRV) +newRV_noinc # E (Perl_newRV_noinc) +newSLICEOP # E (Perl_newSLICEOP) +newSTATEOP # E (Perl_newSTATEOP) +newSUB # E (Perl_newSUB) +newSV # E (Perl_newSV) +newSVOP # E (Perl_newSVOP) +newSVREF # E (Perl_newSVREF) +newSViv # E (Perl_newSViv) +newSVnv # E (Perl_newSVnv) +newSVpv # E (Perl_newSVpv) +newSVpvf # E (Perl_newSVpvf) +newSVpvn # E (Perl_newSVpvn) +newSVrv # E (Perl_newSVrv) +newSVsv # E (Perl_newSVsv) +newSVuv # E +newUNOP # E (Perl_newUNOP) +newWHILEOP # E (Perl_newWHILEOP) +newXS # E (Perl_newXS) +newXSproto # E +new_collate # E (perl_new_collate) +new_ctype # E (perl_new_ctype) +new_numeric # E (perl_new_numeric) +new_stackinfo # E (Perl_new_stackinfo) +ninstr # E (Perl_ninstr) +op_dump # E +op_free # E (Perl_op_free) +pad_sv # E (Perl_pad_sv) +perl_parse # E (perl_parse) +pmflag # E (Perl_pmflag) +pmop_dump # E +pop_scope # E (Perl_pop_scope) +pregcomp # E (Perl_pregcomp) +pregexec # E (Perl_pregexec) +pregfree # E (Perl_pregfree) +push_scope # E (Perl_push_scope) +pv_display # E +re_intuit_start # E +re_intuit_string # E +regdump # E (Perl_regdump) +regexec_flags # E (Perl_regexec_flags) +reginitcolors # E +regnext # E (Perl_regnext) +repeatcpy # E (Perl_repeatcpy) +require_pv # E (perl_require_pv) +rninstr # E (Perl_rninstr) +rsignal # E (Perl_rsignal) +rsignal_state # E (Perl_rsignal_state) +runops_debug # E (Perl_runops_debug) +runops_standard # E (Perl_runops_standard) +safesyscalloc # E +safesysfree # U +safesysmalloc # E +safesysrealloc # E +save_I16 # E (Perl_save_I16) +save_I32 # E (Perl_save_I32) +save_I8 # E +save_aelem # E (Perl_save_aelem) +save_alloc # E +save_aptr # E (Perl_save_aptr) +save_ary # E (Perl_save_ary) +save_clearsv # E (Perl_save_clearsv) +save_delete # E (Perl_save_delete) +save_destructor # E (Perl_save_destructor) +save_destructor_x # E +save_freepv # E (Perl_save_freepv) +save_freesv # E (Perl_save_freesv) +save_generic_svref # E (Perl_save_generic_svref) +save_gp # E (Perl_save_gp) +save_hash # E (Perl_save_hash) +save_helem # E (Perl_save_helem) +save_hints # E (Perl_save_hints) +save_hptr # E (Perl_save_hptr) +save_int # E (Perl_save_int) +save_item # E (Perl_save_item) +save_iv # E (Perl_save_iv) +save_list # E (Perl_save_list) +save_long # E (Perl_save_long) +save_nogv # E (Perl_save_nogv) +save_pptr # E (Perl_save_pptr) +save_re_context # E +save_scalar # E (Perl_save_scalar) +save_sptr # E (Perl_save_sptr) +save_svref # E (Perl_save_svref) +save_threadsv # E (Perl_save_threadsv) +save_vptr # E +savepv # E (Perl_savepv) +savepvn # E (Perl_savepvn) +savestack_grow # E (Perl_savestack_grow) +scan_bin # E +scan_hex # E (Perl_scan_hex) +scan_oct # E (Perl_scan_oct) +screaminstr # E (Perl_screaminstr) +set_context # U +set_numeric_local # E (perl_set_numeric_local) +set_numeric_radix # E +set_numeric_standard # E (perl_set_numeric_standard) +stack_grow # E (Perl_stack_grow) +start_subparse # E (Perl_start_subparse) +str_to_version # E +sv_2bool # E (Perl_sv_2bool) +sv_2cv # E (Perl_sv_2cv) +sv_2io # E (Perl_sv_2io) +sv_2mortal # E (Perl_sv_2mortal) +sv_2nv # E (Perl_sv_2nv) +sv_2pv_nolen # E +sv_2pvbyte # E +sv_2pvbyte_nolen # E +sv_2pvutf8 # E +sv_2pvutf8_nolen # E +sv_backoff # E (Perl_sv_backoff) +sv_bless # E (Perl_sv_bless) +sv_catpv # E (Perl_sv_catpv) +sv_catpv_mg # E (Perl_sv_catpv_mg) +sv_catpvf # E (Perl_sv_catpvf) +sv_catpvf_mg # E (Perl_sv_catpvf_mg) +sv_catpvn_mg # E (Perl_sv_catpvn_mg) +sv_catsv_mg # E (Perl_sv_catsv_mg) +sv_chop # E (Perl_sv_chop) +sv_clear # E (Perl_sv_clear) +sv_cmp # E (Perl_sv_cmp) +sv_cmp_locale # E (Perl_sv_cmp_locale) +sv_collxfrm # E (Perl_sv_collxfrm) +sv_dec # E (Perl_sv_dec) +sv_derived_from # E (Perl_sv_derived_from) +sv_dump # E (Perl_sv_dump) +sv_eq # E (Perl_sv_eq) +sv_force_normal # E +sv_free # E (Perl_sv_free) +sv_gets # E (Perl_sv_gets) +sv_grow # E (Perl_sv_grow) +sv_inc # E (Perl_sv_inc) +sv_insert # E (Perl_sv_insert) +sv_isa # E (Perl_sv_isa) +sv_isobject # E (Perl_sv_isobject) +sv_iv # E (Perl_sv_iv) +sv_len # E (Perl_sv_len) +sv_len_utf8 # E +sv_magic # E (Perl_sv_magic) +sv_mortalcopy # E (Perl_sv_mortalcopy) +sv_newmortal # E (Perl_sv_newmortal) +sv_newref # E (Perl_sv_newref) +sv_nv # E (Perl_sv_nv) +sv_peek # E (Perl_sv_peek) +sv_pos_b2u # E +sv_pos_u2b # E +sv_pv # E +sv_pvbyte # E +sv_pvbyten # E +sv_pvbyten_force # E +sv_pvn # E (Perl_sv_pvn) +sv_pvutf8 # E +sv_pvutf8n # E +sv_pvutf8n_force # E +sv_reftype # E (Perl_sv_reftype) +sv_replace # E (Perl_sv_replace) +sv_report_used # E (Perl_sv_report_used) +sv_reset # E (Perl_sv_reset) +sv_rvweaken # E +sv_setiv # E (Perl_sv_setiv) +sv_setiv_mg # E (Perl_sv_setiv_mg) +sv_setnv # E (Perl_sv_setnv) +sv_setnv_mg # E (Perl_sv_setnv_mg) +sv_setpv # E (Perl_sv_setpv) +sv_setpv_mg # E (Perl_sv_setpv_mg) +sv_setpvf # E (Perl_sv_setpvf) +sv_setpvf_mg # E (Perl_sv_setpvf_mg) +sv_setpvn # E (Perl_sv_setpvn) +sv_setpvn_mg # E (Perl_sv_setpvn_mg) +sv_setref_iv # E (Perl_sv_setref_iv) +sv_setref_nv # E (Perl_sv_setref_nv) +sv_setref_pv # E (Perl_sv_setref_pv) +sv_setref_pvn # E (Perl_sv_setref_pvn) +sv_setsv_mg # E (Perl_sv_setsv_mg) +sv_setuv # E (Perl_sv_setuv) +sv_setuv_mg # E (Perl_sv_setuv_mg) +sv_taint # E (Perl_sv_taint) +sv_tainted # E (Perl_sv_tainted) +sv_true # E (Perl_sv_true) +sv_unmagic # E (Perl_sv_unmagic) +sv_unref # E (Perl_sv_unref) +sv_untaint # E (Perl_sv_untaint) +sv_upgrade # E (Perl_sv_upgrade) +sv_usepvn # E (Perl_sv_usepvn) +sv_usepvn_mg # E (Perl_sv_usepvn_mg) +sv_utf8_decode # E +sv_utf8_downgrade # E +sv_utf8_encode # E +sv_uv # E (Perl_sv_uv) +sv_vcatpvf # E +sv_vcatpvf_mg # E +sv_vcatpvfn # E (Perl_sv_vcatpvfn) +sv_vsetpvf # E +sv_vsetpvf_mg # E +sv_vsetpvfn # E (Perl_sv_vsetpvfn) +swash_init # E +taint_env # E (Perl_taint_env) +taint_proper # E (Perl_taint_proper) +tmps_grow # E +to_uni_lower_lc # E +to_uni_title_lc # E +to_uni_upper_lc # E +unsharepvn # E (Perl_unsharepvn) +utf8_distance # E +utf8_hop # E +vcroak # E +vform # E +vload_module # E +vmess # E +vnewSVpvf # E +vwarn # E +vwarner # E +warn # E (Perl_warn) +warner # E +whichsig # E (Perl_whichsig) +CopFILE # added by devel/scanprov +CopFILEAV # added by devel/scanprov +CopFILEGV # added by devel/scanprov +CopFILEGV_set # added by devel/scanprov +CopFILESV # added by devel/scanprov +CopFILE_set # added by devel/scanprov +CopSTASH # added by devel/scanprov +CopSTASHPV # added by devel/scanprov +CopSTASHPV_set # added by devel/scanprov +CopSTASH_eq # added by devel/scanprov +CopSTASH_set # added by devel/scanprov +INT2PTR # added by devel/scanprov +IVSIZE # added by devel/scanprov +IVTYPE # added by devel/scanprov +IVdf # added by devel/scanprov +NUM2PTR # added by devel/scanprov +NVTYPE # added by devel/scanprov +PERL_REVISION # added by devel/scanprov +PERL_SUBVERSION # added by devel/scanprov +PERL_VERSION # added by devel/scanprov +PTR2IV # added by devel/scanprov +PTR2NV # added by devel/scanprov +PTR2UV # added by devel/scanprov +PTRV # added by devel/scanprov +UVSIZE # added by devel/scanprov +UVTYPE # added by devel/scanprov +UVof # added by devel/scanprov +UVuf # added by devel/scanprov +UVxf # added by devel/scanprov +aTHX # added by devel/scanprov +aTHX_ # added by devel/scanprov +dNOOP # added by devel/scanprov +dTHX # added by devel/scanprov +dTHXa # added by devel/scanprov +dTHXoa # added by devel/scanprov +pTHX # added by devel/scanprov +pTHX_ # added by devel/scanprov +PL_no_modify # added by devel/scanprov +PL_ppaddr # added by devel/scanprov diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5006001 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5006001 new file mode 100644 index 00000000000..eaebd5662a2 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5006001 @@ -0,0 +1,13 @@ +5.006001 +apply_attrs_string # U +bytes_to_utf8 # E +gv_efullname4 # U +gv_fullname4 # U +is_utf8_string # U +save_generic_pvref # U +utf16_to_utf8 # E (Perl_utf16_to_utf8) +utf16_to_utf8_reversed # E (Perl_utf16_to_utf8_reversed) +utf8_to_bytes # E +NVef # added by devel/scanprov +NVff # added by devel/scanprov +NVgf # added by devel/scanprov diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5006002 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5006002 new file mode 100644 index 00000000000..dfe09ce2c59 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5006002 @@ -0,0 +1 @@ +5.006002 diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5007000 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5007000 new file mode 100644 index 00000000000..49d08465db8 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5007000 @@ -0,0 +1 @@ +5.007000 diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5007001 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5007001 new file mode 100644 index 00000000000..4c436af970d --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5007001 @@ -0,0 +1,27 @@ +5.007001 +POPpbytex # E +SvUOK # U +bytes_from_utf8 # E +csighandler # U +despatch_signals # U +do_openn # U +gv_handler # E +is_lvalue_sub # U +my_popen_list # E +newSVpvn_share # E +save_mortalizesv # U +save_padsv # U +scan_num # E (Perl_scan_num) +sv_force_normal_flags # U +sv_setref_uv # E +sv_unref_flags # U +sv_utf8_upgrade # E (Perl_sv_utf8_upgrade) +utf8_length # U +utf8_to_uvchr # U +utf8_to_uvuni # U +utf8n_to_uvchr # U +utf8n_to_uvuni # U +uvchr_to_utf8 # E +uvuni_to_utf8 # E +PTR2ul # added by devel/scanprov +UVXf # added by devel/scanprov diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5007002 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5007002 new file mode 100644 index 00000000000..8efc9784ef5 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5007002 @@ -0,0 +1,71 @@ +5.007002 +SvPV_force_nomg # E +SvPV_nomg # E +calloc # E +dAX # E +dITEMS # E +getcwd_sv # U +grok_number # U +grok_numeric_radix # U +init_tm # U +malloc # E +mfree # U +mini_mktime # U +my_atof2 # E +my_strftime # E +op_null # U +realloc # E +sv_2pv_flags # E +sv_catpvn_flags # U +sv_catpvn_nomg # U +sv_catsv_flags # U +sv_catsv_nomg # U +sv_pvn_force_flags # E +sv_setsv_flags # U +sv_setsv_nomg # U +sv_utf8_upgrade_flags # U +swash_fetch # E (Perl_swash_fetch) +GROK_NUMERIC_RADIX # added by devel/scanprov +IN_LOCALE # added by devel/scanprov +IN_LOCALE_COMPILETIME # added by devel/scanprov +IN_LOCALE_RUNTIME # added by devel/scanprov +IS_NUMBER_GREATER_THAN_UV_MAX # added by devel/scanprov +IS_NUMBER_INFINITY # added by devel/scanprov +IS_NUMBER_IN_UV # added by devel/scanprov +IS_NUMBER_NEG # added by devel/scanprov +IS_NUMBER_NOT_INT # added by devel/scanprov +PERL_MAGIC_arylen # added by devel/scanprov +PERL_MAGIC_backref # added by devel/scanprov +PERL_MAGIC_bm # added by devel/scanprov +PERL_MAGIC_collxfrm # added by devel/scanprov +PERL_MAGIC_dbfile # added by devel/scanprov +PERL_MAGIC_dbline # added by devel/scanprov +PERL_MAGIC_defelem # added by devel/scanprov +PERL_MAGIC_env # added by devel/scanprov +PERL_MAGIC_envelem # added by devel/scanprov +PERL_MAGIC_ext # added by devel/scanprov +PERL_MAGIC_fm # added by devel/scanprov +PERL_MAGIC_glob # added by devel/scanprov +PERL_MAGIC_isa # added by devel/scanprov +PERL_MAGIC_isaelem # added by devel/scanprov +PERL_MAGIC_mutex # added by devel/scanprov +PERL_MAGIC_nkeys # added by devel/scanprov +PERL_MAGIC_overload # added by devel/scanprov +PERL_MAGIC_overload_elem # added by devel/scanprov +PERL_MAGIC_overload_table # added by devel/scanprov +PERL_MAGIC_pos # added by devel/scanprov +PERL_MAGIC_qr # added by devel/scanprov +PERL_MAGIC_regdata # added by devel/scanprov +PERL_MAGIC_regdatum # added by devel/scanprov +PERL_MAGIC_regex_global # added by devel/scanprov +PERL_MAGIC_sig # added by devel/scanprov +PERL_MAGIC_sigelem # added by devel/scanprov +PERL_MAGIC_substr # added by devel/scanprov +PERL_MAGIC_sv # added by devel/scanprov +PERL_MAGIC_taint # added by devel/scanprov +PERL_MAGIC_tied # added by devel/scanprov +PERL_MAGIC_tiedelem # added by devel/scanprov +PERL_MAGIC_tiedscalar # added by devel/scanprov +PERL_MAGIC_uvar # added by devel/scanprov +PERL_MAGIC_vec # added by devel/scanprov +PERL_UNUSED_DECL # added by devel/scanprov diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5007003 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5007003 new file mode 100644 index 00000000000..2d4166822eb --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5007003 @@ -0,0 +1,86 @@ +5.007003 +PerlIO_clearerr # E (PerlIO_clearerr) +PerlIO_close # E (PerlIO_close) +PerlIO_eof # E (PerlIO_eof) +PerlIO_error # E (PerlIO_error) +PerlIO_fileno # E (PerlIO_fileno) +PerlIO_fill # E (PerlIO_fill) +PerlIO_flush # E (PerlIO_flush) +PerlIO_get_base # E (PerlIO_get_base) +PerlIO_get_bufsiz # E (PerlIO_get_bufsiz) +PerlIO_get_cnt # E (PerlIO_get_cnt) +PerlIO_get_ptr # E (PerlIO_get_ptr) +PerlIO_read # E (PerlIO_read) +PerlIO_seek # E (PerlIO_seek) +PerlIO_set_cnt # E (PerlIO_set_cnt) +PerlIO_set_ptrcnt # E (PerlIO_set_ptrcnt) +PerlIO_setlinebuf # E (PerlIO_setlinebuf) +PerlIO_stderr # E (PerlIO_stderr) +PerlIO_stdin # E (PerlIO_stdin) +PerlIO_stdout # E (PerlIO_stdout) +PerlIO_tell # E (PerlIO_tell) +PerlIO_unread # E (PerlIO_unread) +PerlIO_write # E (PerlIO_write) +SvLOCK # E +SvSHARE # E +SvUNLOCK # E +atfork_lock # E +atfork_unlock # E +custom_op_desc # E +custom_op_name # E +deb # U +debstack # U +debstackptrs # U +grok_bin # E +grok_hex # E +grok_oct # E +gv_fetchmeth_autoload # E +ibcmp_utf8 # E +my_fork # E +my_socketpair # E +pack_cat # E +perl_destruct # E (perl_destruct) +pv_uni_display # E +regclass_swash # E (Perl_regclass_swash) +save_shared_pvref # E +savesharedpv # E +sortsv # E +sv_copypv # E +sv_magicext # E +sv_nolocking # E +sv_nosharing # E +sv_nounlocking # E +sv_pvn_nomg # E +sv_recode_to_utf8 # E +sv_uni_display # E +to_uni_fold # E +to_uni_lower # E (Perl_to_uni_lower) +to_uni_title # E (Perl_to_uni_title) +to_uni_upper # E (Perl_to_uni_upper) +to_utf8_case # E +to_utf8_fold # E +to_utf8_lower # E (Perl_to_utf8_lower) +to_utf8_title # E (Perl_to_utf8_title) +to_utf8_upper # E (Perl_to_utf8_upper) +unpack_str # E +uvchr_to_utf8_flags # E +uvuni_to_utf8_flags # E +vdeb # U +IS_NUMBER_NAN # added by devel/scanprov +MY_CXT # added by devel/scanprov +MY_CXT_INIT # added by devel/scanprov +PERL_MAGIC_shared # added by devel/scanprov +PERL_MAGIC_shared_scalar # added by devel/scanprov +PERL_MAGIC_uvar_elem # added by devel/scanprov +PERL_SCAN_ALLOW_UNDERSCORES # added by devel/scanprov +PERL_SCAN_DISALLOW_PREFIX # added by devel/scanprov +PERL_SCAN_GREATER_THAN_UV_MAX # added by devel/scanprov +START_MY_CXT # added by devel/scanprov +_aMY_CXT # added by devel/scanprov +_pMY_CXT # added by devel/scanprov +aMY_CXT # added by devel/scanprov +aMY_CXT_ # added by devel/scanprov +dMY_CXT # added by devel/scanprov +dMY_CXT_SV # added by devel/scanprov +pMY_CXT # added by devel/scanprov +pMY_CXT_ # added by devel/scanprov diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5008000 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5008000 new file mode 100644 index 00000000000..5af2a55ce05 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5008000 @@ -0,0 +1,6 @@ +5.008000 +Poison # E +hv_iternext_flags # E +hv_store_flags # E +is_utf8_idcont # U +nothreadhook # U diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5008001 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5008001 new file mode 100644 index 00000000000..cc274f482ab --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5008001 @@ -0,0 +1,20 @@ +5.008001 +SvVOK # U +XSRETURN_UV # U +doing_taint # U +is_utf8_string_loc # U +packlist # U +save_bool # U +savestack_grow_cnt # U +scan_vstring # E +sv_cat_decode # U +sv_compile_2op # E (Perl_sv_compile_2op) +sv_setpviv # U +sv_setpviv_mg # U +unpackstring # U +IN_PERL_COMPILETIME # added by devel/scanprov +PERL_MAGIC_utf8 # added by devel/scanprov +PERL_MAGIC_vstring # added by devel/scanprov +PERL_SCAN_SILENT_ILLDIGIT # added by devel/scanprov +XST_mUV # added by devel/scanprov +PERL_GCC_BRACE_GROUPS_FORBIDDEN # added by devel/scanprov diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5008002 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5008002 new file mode 100644 index 00000000000..63aac525fed --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5008002 @@ -0,0 +1 @@ +5.008002 diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5008003 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5008003 new file mode 100644 index 00000000000..50c6ce1aa14 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5008003 @@ -0,0 +1,3 @@ +5.008003 +SvIsCOW # U +SvIsCOW_shared_hash # U diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5008004 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5008004 new file mode 100644 index 00000000000..bb7bcdf66ac --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5008004 @@ -0,0 +1 @@ +5.008004 diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5008005 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5008005 new file mode 100644 index 00000000000..7bd2029f4b3 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5008005 @@ -0,0 +1 @@ +5.008005 diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5009000 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5009000 new file mode 100644 index 00000000000..8b45dc7ba02 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5009000 @@ -0,0 +1,7 @@ +5.009000 +new_version # E +save_set_svflags # U +upg_version # E +vcmp # U +vnumify # E +vstringify # E diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5009001 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5009001 new file mode 100644 index 00000000000..335f490f8da --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5009001 @@ -0,0 +1,9 @@ +5.009001 +SvIV_nomg # U +SvUV_nomg # U +hv_assert # U +hv_clear_placeholders # U +hv_scalar # E +scan_version # E (Perl_scan_version) +sv_2iv_flags # U +sv_2uv_flags # U diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5009002 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5009002 new file mode 100644 index 00000000000..2b66b272cc1 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/base/5009002 @@ -0,0 +1,21 @@ +5.009002 +CopyD # E +MoveD # E +PUSHmortal # E +SvPVbyte_force # E +UNDERBAR # E +XPUSHmortal # E +ZeroD # E +dUNDERBAR # E +find_rundefsvoffset # U +mPUSHi # U +mPUSHn # U +mPUSHp # U +mPUSHu # U +mXPUSHi # U +mXPUSHn # U +mXPUSHp # U +mXPUSHu # U +vnormal # E +PERL_BCDVERSION # added by devel/scanprov +MY_CXT_CLONE # added by devel/scanprov diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/embed.fnc b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/embed.fnc new file mode 100644 index 00000000000..8ca6b0e85a5 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/embed.fnc @@ -0,0 +1,1487 @@ +: Lines are of the form: +: flags|return_type|function_name|arg1|arg2|...|argN +: +: A line may be continued on another by ending it with a backslash. +: Leading and trailing whitespace will be ignored in each component. +: +: flags are single letters with following meanings: +: A member of public API +: m Implemented as a macro - no export, no +: proto, no #define +: d function has documentation with its source +: s static function, should have an S_ prefix in +: source file; for macros (m), suffix the usage +: example with a semicolon +: n has no implicit interpreter/thread context argument +: p function has a Perl_ prefix +: f function takes printf style format string, varargs +: r function never returns +: o has no compatibility macro (#define foo Perl_foo) +: x not exported +: X explicitly exported +: M may change +: E visible to extensions included in the Perl core +: b binary backward compatibility; function is a macro +: but has also Perl_ implementation (which is exported) +: U suppress usage example in autogenerated documentation +: +: Individual flags may be separated by whitespace. +: +: New global functions should be added at the end for binary compatibility +: in some configurations. + +START_EXTERN_C + +#if defined(PERL_IMPLICIT_SYS) +Ano |PerlInterpreter* |perl_alloc_using \ + |struct IPerlMem* m|struct IPerlMem* ms \ + |struct IPerlMem* mp|struct IPerlEnv* e \ + |struct IPerlStdIO* io|struct IPerlLIO* lio \ + |struct IPerlDir* d|struct IPerlSock* s \ + |struct IPerlProc* p +#endif +Anod |PerlInterpreter* |perl_alloc +Anod |void |perl_construct |PerlInterpreter* interp +Anod |int |perl_destruct |PerlInterpreter* interp +Anod |void |perl_free |PerlInterpreter* interp +Anod |int |perl_run |PerlInterpreter* interp +Anod |int |perl_parse |PerlInterpreter* interp|XSINIT_t xsinit \ + |int argc|char** argv|char** env +Anp |bool |doing_taint |int argc|char** argv|char** env +#if defined(USE_ITHREADS) +Anod |PerlInterpreter*|perl_clone|PerlInterpreter* interp|UV flags +# if defined(PERL_IMPLICIT_SYS) +Ano |PerlInterpreter*|perl_clone_using|PerlInterpreter *interp|UV flags \ + |struct IPerlMem* m|struct IPerlMem* ms \ + |struct IPerlMem* mp|struct IPerlEnv* e \ + |struct IPerlStdIO* io|struct IPerlLIO* lio \ + |struct IPerlDir* d|struct IPerlSock* s \ + |struct IPerlProc* p +# endif +#endif + +Anop |Malloc_t|malloc |MEM_SIZE nbytes +Anop |Malloc_t|calloc |MEM_SIZE elements|MEM_SIZE size +Anop |Malloc_t|realloc |Malloc_t where|MEM_SIZE nbytes +Anop |Free_t |mfree |Malloc_t where +#if defined(MYMALLOC) +np |MEM_SIZE|malloced_size |void *p +#endif + +Anp |void* |get_context +Anp |void |set_context |void *thx + +END_EXTERN_C + +/* functions with flag 'n' should come before here */ +START_EXTERN_C +# include "pp_proto.h" +Ap |SV* |amagic_call |SV* left|SV* right|int method|int dir +Ap |bool |Gv_AMupdate |HV* stash +Ap |CV* |gv_handler |HV* stash|I32 id +p |OP* |append_elem |I32 optype|OP* head|OP* tail +p |OP* |append_list |I32 optype|LISTOP* first|LISTOP* last +p |I32 |apply |I32 type|SV** mark|SV** sp +ApM |void |apply_attrs_string|char *stashpv|CV *cv|char *attrstr|STRLEN len +Apd |void |av_clear |AV* ar +Apd |SV* |av_delete |AV* ar|I32 key|I32 flags +Apd |bool |av_exists |AV* ar|I32 key +Apd |void |av_extend |AV* ar|I32 key +p |AV* |av_fake |I32 size|SV** svp +Apd |SV** |av_fetch |AV* ar|I32 key|I32 lval +Apd |void |av_fill |AV* ar|I32 fill +Apd |I32 |av_len |AV* ar +Apd |AV* |av_make |I32 size|SV** svp +Apd |SV* |av_pop |AV* ar +Apd |void |av_push |AV* ar|SV* val +p |void |av_reify |AV* ar +Apd |SV* |av_shift |AV* ar +Apd |SV** |av_store |AV* ar|I32 key|SV* val +Apd |void |av_undef |AV* ar +Apd |void |av_unshift |AV* ar|I32 num +p |OP* |bind_match |I32 type|OP* left|OP* pat +p |OP* |block_end |I32 floor|OP* seq +Ap |I32 |block_gimme +p |int |block_start |int full +p |void |boot_core_UNIVERSAL +p |void |boot_core_PerlIO +Ap |void |call_list |I32 oldscope|AV* av_list +p |bool |cando |Mode_t mode|Uid_t effective|Stat_t* statbufp +Ap |U32 |cast_ulong |NV f +Ap |I32 |cast_i32 |NV f +Ap |IV |cast_iv |NV f +Ap |UV |cast_uv |NV f +#if !defined(HAS_TRUNCATE) && !defined(HAS_CHSIZE) && defined(F_FREESP) +Ap |I32 |my_chsize |int fd|Off_t length +#endif +p |OP* |convert |I32 optype|I32 flags|OP* o +Afprd |void |croak |const char* pat|... +Apr |void |vcroak |const char* pat|va_list* args +#if defined(PERL_IMPLICIT_CONTEXT) +Afnrp |void |croak_nocontext|const char* pat|... +Afnp |OP* |die_nocontext |const char* pat|... +Afnp |void |deb_nocontext |const char* pat|... +Afnp |char* |form_nocontext |const char* pat|... +Anp |void |load_module_nocontext|U32 flags|SV* name|SV* ver|... +Afnp |SV* |mess_nocontext |const char* pat|... +Afnp |void |warn_nocontext |const char* pat|... +Afnp |void |warner_nocontext|U32 err|const char* pat|... +Afnp |SV* |newSVpvf_nocontext|const char* pat|... +Afnp |void |sv_catpvf_nocontext|SV* sv|const char* pat|... +Afnp |void |sv_setpvf_nocontext|SV* sv|const char* pat|... +Afnp |void |sv_catpvf_mg_nocontext|SV* sv|const char* pat|... +Afnp |void |sv_setpvf_mg_nocontext|SV* sv|const char* pat|... +Afnp |int |fprintf_nocontext|PerlIO* stream|const char* fmt|... +Afnp |int |printf_nocontext|const char* fmt|... +#endif +p |void |cv_ckproto |CV* cv|GV* gv|char* p +pd |CV* |cv_clone |CV* proto +Apd |SV* |cv_const_sv |CV* cv +p |SV* |op_const_sv |OP* o|CV* cv +Apd |void |cv_undef |CV* cv +Ap |void |cx_dump |PERL_CONTEXT* cs +Ap |SV* |filter_add |filter_t funcp|SV* datasv +Ap |void |filter_del |filter_t funcp +Ap |I32 |filter_read |int idx|SV* buffer|int maxlen +Ap |char** |get_op_descs +Ap |char** |get_op_names +p |char* |get_no_modify +p |U32* |get_opargs +Ap |PPADDR_t*|get_ppaddr +Ep |I32 |cxinc +Afp |void |deb |const char* pat|... +Ap |void |vdeb |const char* pat|va_list* args +Ap |void |debprofdump +Ap |I32 |debop |OP* o +Ap |I32 |debstack +Ap |I32 |debstackptrs +Ap |char* |delimcpy |char* to|char* toend|char* from \ + |char* fromend|int delim|I32* retlen +p |void |deprecate |char* s +p |void |deprecate_old |char* s +Afp |OP* |die |const char* pat|... +p |OP* |vdie |const char* pat|va_list* args +p |OP* |die_where |char* message|STRLEN msglen +Ap |void |dounwind |I32 cxix +p |bool |do_aexec |SV* really|SV** mark|SV** sp +p |bool |do_aexec5 |SV* really|SV** mark|SV** sp|int fd|int flag +Ap |int |do_binmode |PerlIO *fp|int iotype|int mode +p |void |do_chop |SV* asv|SV* sv +Ap |bool |do_close |GV* gv|bool not_implicit +p |bool |do_eof |GV* gv +p |bool |do_exec |char* cmd +#if defined(WIN32) +Ap |int |do_aspawn |SV* really|SV** mark|SV** sp +Ap |int |do_spawn |char* cmd +Ap |int |do_spawn_nowait|char* cmd +#endif +#if !defined(WIN32) +p |bool |do_exec3 |char* cmd|int fd|int flag +#endif +p |void |do_execfree +#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM) +p |I32 |do_ipcctl |I32 optype|SV** mark|SV** sp +p |I32 |do_ipcget |I32 optype|SV** mark|SV** sp +p |I32 |do_msgrcv |SV** mark|SV** sp +p |I32 |do_msgsnd |SV** mark|SV** sp +p |I32 |do_semop |SV** mark|SV** sp +p |I32 |do_shmio |I32 optype|SV** mark|SV** sp +#endif +Ap |void |do_join |SV* sv|SV* del|SV** mark|SV** sp +p |OP* |do_kv +Ap |bool |do_open |GV* gv|char* name|I32 len|int as_raw \ + |int rawmode|int rawperm|PerlIO* supplied_fp +Ap |bool |do_open9 |GV *gv|char *name|I32 len|int as_raw \ + |int rawmode|int rawperm|PerlIO *supplied_fp \ + |SV *svs|I32 num +Ap |bool |do_openn |GV *gv|char *name|I32 len|int as_raw \ + |int rawmode|int rawperm|PerlIO *supplied_fp \ + |SV **svp|I32 num +p |void |do_pipe |SV* sv|GV* rgv|GV* wgv +p |bool |do_print |SV* sv|PerlIO* fp +p |OP* |do_readline +p |I32 |do_chomp |SV* sv +p |bool |do_seek |GV* gv|Off_t pos|int whence +Ap |void |do_sprintf |SV* sv|I32 len|SV** sarg +p |Off_t |do_sysseek |GV* gv|Off_t pos|int whence +p |Off_t |do_tell |GV* gv +p |I32 |do_trans |SV* sv +p |UV |do_vecget |SV* sv|I32 offset|I32 size +p |void |do_vecset |SV* sv +p |void |do_vop |I32 optype|SV* sv|SV* left|SV* right +p |OP* |dofile |OP* term +Ap |I32 |dowantarray +Ap |void |dump_all +Ap |void |dump_eval +#if defined(DUMP_FDS) +Ap |void |dump_fds |char* s +#endif +Ap |void |dump_form |GV* gv +Ap |void |gv_dump |GV* gv +Ap |void |op_dump |OP* arg +Ap |void |pmop_dump |PMOP* pm +Ap |void |dump_packsubs |HV* stash +Ap |void |dump_sub |GV* gv +Apd |void |fbm_compile |SV* sv|U32 flags +Apd |char* |fbm_instr |unsigned char* big|unsigned char* bigend \ + |SV* littlesv|U32 flags +p |char* |find_script |char *scriptname|bool dosearch \ + |char **search_ext|I32 flags +p |OP* |force_list |OP* arg +p |OP* |fold_constants |OP* arg +Afpd |char* |form |const char* pat|... +Ap |char* |vform |const char* pat|va_list* args +Ap |void |free_tmps +p |OP* |gen_constant_list|OP* o +#if !defined(HAS_GETENV_LEN) +p |char* |getenv_len |const char* key|unsigned long *len +#endif +Ap |void |gp_free |GV* gv +Ap |GP* |gp_ref |GP* gp +Ap |GV* |gv_AVadd |GV* gv +Ap |GV* |gv_HVadd |GV* gv +Ap |GV* |gv_IOadd |GV* gv +Ap |GV* |gv_autoload4 |HV* stash|const char* name|STRLEN len \ + |I32 method +Ap |void |gv_check |HV* stash +Ap |void |gv_efullname |SV* sv|GV* gv +Ap |void |gv_efullname3 |SV* sv|GV* gv|const char* prefix +Ap |void |gv_efullname4 |SV* sv|GV* gv|const char* prefix|bool keepmain +Ap |GV* |gv_fetchfile |const char* name +Apd |GV* |gv_fetchmeth |HV* stash|const char* name|STRLEN len \ + |I32 level +Apd |GV* |gv_fetchmeth_autoload |HV* stash|const char* name|STRLEN len \ + |I32 level +Apd |GV* |gv_fetchmethod |HV* stash|const char* name +Apd |GV* |gv_fetchmethod_autoload|HV* stash|const char* name \ + |I32 autoload +Ap |GV* |gv_fetchpv |const char* name|I32 add|I32 sv_type +Ap |void |gv_fullname |SV* sv|GV* gv +Ap |void |gv_fullname3 |SV* sv|GV* gv|const char* prefix +Ap |void |gv_fullname4 |SV* sv|GV* gv|const char* prefix|bool keepmain +Ap |void |gv_init |GV* gv|HV* stash|const char* name \ + |STRLEN len|int multi +Apd |HV* |gv_stashpv |const char* name|I32 create +Ap |HV* |gv_stashpvn |const char* name|U32 namelen|I32 create +Apd |HV* |gv_stashsv |SV* sv|I32 create +Apd |void |hv_clear |HV* tb +Ap |void |hv_delayfree_ent|HV* hv|HE* entry +Apd |SV* |hv_delete |HV* tb|const char* key|I32 klen|I32 flags +Apd |SV* |hv_delete_ent |HV* tb|SV* key|I32 flags|U32 hash +Apd |bool |hv_exists |HV* tb|const char* key|I32 klen +Apd |bool |hv_exists_ent |HV* tb|SV* key|U32 hash +Apd |SV** |hv_fetch |HV* tb|const char* key|I32 klen|I32 lval +Apd |HE* |hv_fetch_ent |HV* tb|SV* key|I32 lval|U32 hash +Ap |void |hv_free_ent |HV* hv|HE* entry +Apd |I32 |hv_iterinit |HV* tb +Apd |char* |hv_iterkey |HE* entry|I32* retlen +Apd |SV* |hv_iterkeysv |HE* entry +Apd |HE* |hv_iternext |HV* tb +Apd |SV* |hv_iternextsv |HV* hv|char** key|I32* retlen +ApMd |HE* |hv_iternext_flags|HV* tb|I32 flags +Apd |SV* |hv_iterval |HV* tb|HE* entry +Ap |void |hv_ksplit |HV* hv|IV newmax +Apd |void |hv_magic |HV* hv|GV* gv|int how +Apd |SV** |hv_store |HV* tb|const char* key|I32 klen|SV* val \ + |U32 hash +Apd |HE* |hv_store_ent |HV* tb|SV* key|SV* val|U32 hash +ApM |SV** |hv_store_flags |HV* tb|const char* key|I32 klen|SV* val \ + |U32 hash|int flags +Apd |void |hv_undef |HV* tb +Ap |I32 |ibcmp |const char* a|const char* b|I32 len +Ap |I32 |ibcmp_locale |const char* a|const char* b|I32 len +Apd |I32 |ibcmp_utf8 |const char* a|char **pe1|UV l1|bool u1|const char* b|char **pe2|UV l2|bool u2 +p |bool |ingroup |Gid_t testgid|Uid_t effective +p |void |init_argv_symbols|int|char ** +p |void |init_debugger +Ap |void |init_stacks +Ap |void |init_tm |struct tm *ptm +pd |U32 |intro_my +Ap |char* |instr |const char* big|const char* little +p |bool |io_close |IO* io|bool not_implicit +p |OP* |invert |OP* cmd +dp |bool |is_gv_magical |char *name|STRLEN len|U32 flags +Ap |I32 |is_lvalue_sub +Ap |U32 |to_uni_upper_lc|U32 c +Ap |U32 |to_uni_title_lc|U32 c +Ap |U32 |to_uni_lower_lc|U32 c +Ap |bool |is_uni_alnum |UV c +Ap |bool |is_uni_alnumc |UV c +Ap |bool |is_uni_idfirst |UV c +Ap |bool |is_uni_alpha |UV c +Ap |bool |is_uni_ascii |UV c +Ap |bool |is_uni_space |UV c +Ap |bool |is_uni_cntrl |UV c +Ap |bool |is_uni_graph |UV c +Ap |bool |is_uni_digit |UV c +Ap |bool |is_uni_upper |UV c +Ap |bool |is_uni_lower |UV c +Ap |bool |is_uni_print |UV c +Ap |bool |is_uni_punct |UV c +Ap |bool |is_uni_xdigit |UV c +Ap |UV |to_uni_upper |UV c|U8 *p|STRLEN *lenp +Ap |UV |to_uni_title |UV c|U8 *p|STRLEN *lenp +Ap |UV |to_uni_lower |UV c|U8 *p|STRLEN *lenp +Ap |UV |to_uni_fold |UV c|U8 *p|STRLEN *lenp +Ap |bool |is_uni_alnum_lc|UV c +Ap |bool |is_uni_alnumc_lc|UV c +Ap |bool |is_uni_idfirst_lc|UV c +Ap |bool |is_uni_alpha_lc|UV c +Ap |bool |is_uni_ascii_lc|UV c +Ap |bool |is_uni_space_lc|UV c +Ap |bool |is_uni_cntrl_lc|UV c +Ap |bool |is_uni_graph_lc|UV c +Ap |bool |is_uni_digit_lc|UV c +Ap |bool |is_uni_upper_lc|UV c +Ap |bool |is_uni_lower_lc|UV c +Ap |bool |is_uni_print_lc|UV c +Ap |bool |is_uni_punct_lc|UV c +Ap |bool |is_uni_xdigit_lc|UV c +Apd |STRLEN |is_utf8_char |U8 *p +Apd |bool |is_utf8_string |U8 *s|STRLEN len +Apd |bool |is_utf8_string_loc|U8 *s|STRLEN len|U8 **p +Ap |bool |is_utf8_alnum |U8 *p +Ap |bool |is_utf8_alnumc |U8 *p +Ap |bool |is_utf8_idfirst|U8 *p +Ap |bool |is_utf8_idcont |U8 *p +Ap |bool |is_utf8_alpha |U8 *p +Ap |bool |is_utf8_ascii |U8 *p +Ap |bool |is_utf8_space |U8 *p +Ap |bool |is_utf8_cntrl |U8 *p +Ap |bool |is_utf8_digit |U8 *p +Ap |bool |is_utf8_graph |U8 *p +Ap |bool |is_utf8_upper |U8 *p +Ap |bool |is_utf8_lower |U8 *p +Ap |bool |is_utf8_print |U8 *p +Ap |bool |is_utf8_punct |U8 *p +Ap |bool |is_utf8_xdigit |U8 *p +Ap |bool |is_utf8_mark |U8 *p +p |OP* |jmaybe |OP* arg +p |I32 |keyword |char* d|I32 len +Ap |void |leave_scope |I32 base +p |void |lex_end +p |void |lex_start |SV* line +Ap |void |op_null |OP* o +p |void |op_clear |OP* o +p |OP* |linklist |OP* o +p |OP* |list |OP* o +p |OP* |listkids |OP* o +Apd |void |load_module|U32 flags|SV* name|SV* ver|... +Ap |void |vload_module|U32 flags|SV* name|SV* ver|va_list* args +p |OP* |localize |OP* arg|I32 lexical +Apd |I32 |looks_like_number|SV* sv +Apd |UV |grok_bin |char* start|STRLEN* len|I32* flags|NV *result +Apd |UV |grok_hex |char* start|STRLEN* len|I32* flags|NV *result +Apd |int |grok_number |const char *pv|STRLEN len|UV *valuep +Apd |bool |grok_numeric_radix|const char **sp|const char *send +Apd |UV |grok_oct |char* start|STRLEN* len|I32* flags|NV *result +p |int |magic_clearenv |SV* sv|MAGIC* mg +p |int |magic_clear_all_env|SV* sv|MAGIC* mg +p |int |magic_clearpack|SV* sv|MAGIC* mg +p |int |magic_clearsig |SV* sv|MAGIC* mg +p |int |magic_existspack|SV* sv|MAGIC* mg +p |int |magic_freeregexp|SV* sv|MAGIC* mg +p |int |magic_freeovrld|SV* sv|MAGIC* mg +p |int |magic_get |SV* sv|MAGIC* mg +p |int |magic_getarylen|SV* sv|MAGIC* mg +p |int |magic_getdefelem|SV* sv|MAGIC* mg +p |int |magic_getglob |SV* sv|MAGIC* mg +p |int |magic_getnkeys |SV* sv|MAGIC* mg +p |int |magic_getpack |SV* sv|MAGIC* mg +p |int |magic_getpos |SV* sv|MAGIC* mg +p |int |magic_getsig |SV* sv|MAGIC* mg +p |int |magic_getsubstr|SV* sv|MAGIC* mg +p |int |magic_gettaint |SV* sv|MAGIC* mg +p |int |magic_getuvar |SV* sv|MAGIC* mg +p |int |magic_getvec |SV* sv|MAGIC* mg +p |U32 |magic_len |SV* sv|MAGIC* mg +p |int |magic_nextpack |SV* sv|MAGIC* mg|SV* key +p |U32 |magic_regdata_cnt|SV* sv|MAGIC* mg +p |int |magic_regdatum_get|SV* sv|MAGIC* mg +p |int |magic_regdatum_set|SV* sv|MAGIC* mg +p |int |magic_set |SV* sv|MAGIC* mg +p |int |magic_setamagic|SV* sv|MAGIC* mg +p |int |magic_setarylen|SV* sv|MAGIC* mg +p |int |magic_setbm |SV* sv|MAGIC* mg +p |int |magic_setdbline|SV* sv|MAGIC* mg +#if defined(USE_LOCALE_COLLATE) +p |int |magic_setcollxfrm|SV* sv|MAGIC* mg +#endif +p |int |magic_setdefelem|SV* sv|MAGIC* mg +p |int |magic_setenv |SV* sv|MAGIC* mg +p |int |magic_setfm |SV* sv|MAGIC* mg +p |int |magic_setisa |SV* sv|MAGIC* mg +p |int |magic_setglob |SV* sv|MAGIC* mg +p |int |magic_setmglob |SV* sv|MAGIC* mg +p |int |magic_setnkeys |SV* sv|MAGIC* mg +p |int |magic_setpack |SV* sv|MAGIC* mg +p |int |magic_setpos |SV* sv|MAGIC* mg +p |int |magic_setregexp|SV* sv|MAGIC* mg +p |int |magic_setsig |SV* sv|MAGIC* mg +p |int |magic_setsubstr|SV* sv|MAGIC* mg +p |int |magic_settaint |SV* sv|MAGIC* mg +p |int |magic_setuvar |SV* sv|MAGIC* mg +p |int |magic_setvec |SV* sv|MAGIC* mg +p |int |magic_setutf8 |SV* sv|MAGIC* mg +p |int |magic_set_all_env|SV* sv|MAGIC* mg +p |U32 |magic_sizepack |SV* sv|MAGIC* mg +p |int |magic_wipepack |SV* sv|MAGIC* mg +p |void |magicname |char* sym|char* name|I32 namlen +Ap |void |markstack_grow +#if defined(USE_LOCALE_COLLATE) +p |char* |mem_collxfrm |const char* s|STRLEN len|STRLEN* xlen +#endif +Afp |SV* |mess |const char* pat|... +Ap |SV* |vmess |const char* pat|va_list* args +p |void |qerror |SV* err +Apd |void |sortsv |SV ** array|size_t num_elts|SVCOMPARE_t cmp +Apd |int |mg_clear |SV* sv +Apd |int |mg_copy |SV* sv|SV* nsv|const char* key|I32 klen +Apd |MAGIC* |mg_find |SV* sv|int type +Apd |int |mg_free |SV* sv +Apd |int |mg_get |SV* sv +Apd |U32 |mg_length |SV* sv +Apd |void |mg_magical |SV* sv +Apd |int |mg_set |SV* sv +Ap |I32 |mg_size |SV* sv +Ap |void |mini_mktime |struct tm *pm +p |OP* |mod |OP* o|I32 type +p |int |mode_from_discipline|SV* discp +Ap |char* |moreswitches |char* s +p |OP* |my |OP* o +Ap |NV |my_atof |const char *s +#if (!defined(HAS_MEMCPY) && !defined(HAS_BCOPY)) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY) && !defined(HAS_SAFE_BCOPY)) +Anp |char* |my_bcopy |const char* from|char* to|I32 len +#endif +#if !defined(HAS_BZERO) && !defined(HAS_MEMSET) +Anp |char* |my_bzero |char* loc|I32 len +#endif +Apr |void |my_exit |U32 status +Apr |void |my_failure_exit +Ap |I32 |my_fflush_all +Anp |Pid_t |my_fork +Anp |void |atfork_lock +Anp |void |atfork_unlock +Ap |I32 |my_lstat +#if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP) +Anp |I32 |my_memcmp |const char* s1|const char* s2|I32 len +#endif +#if !defined(HAS_MEMSET) +Anp |void* |my_memset |char* loc|I32 ch|I32 len +#endif +Ap |I32 |my_pclose |PerlIO* ptr +Ap |PerlIO*|my_popen |char* cmd|char* mode +Ap |PerlIO*|my_popen_list |char* mode|int n|SV ** args +Ap |void |my_setenv |char* nam|char* val +Ap |I32 |my_stat +Ap |char * |my_strftime |char *fmt|int sec|int min|int hour|int mday|int mon|int year|int wday|int yday|int isdst +#if defined(MYSWAP) +Ap |short |my_swap |short s +Ap |long |my_htonl |long l +Ap |long |my_ntohl |long l +#endif +p |void |my_unexec +Ap |OP* |newANONLIST |OP* o +Ap |OP* |newANONHASH |OP* o +Ap |OP* |newANONSUB |I32 floor|OP* proto|OP* block +Ap |OP* |newASSIGNOP |I32 flags|OP* left|I32 optype|OP* right +Ap |OP* |newCONDOP |I32 flags|OP* expr|OP* trueop|OP* falseop +Apd |CV* |newCONSTSUB |HV* stash|char* name|SV* sv +Ap |void |newFORM |I32 floor|OP* o|OP* block +Ap |OP* |newFOROP |I32 flags|char* label|line_t forline \ + |OP* sclr|OP* expr|OP*block|OP*cont +Ap |OP* |newLOGOP |I32 optype|I32 flags|OP* left|OP* right +Ap |OP* |newLOOPEX |I32 type|OP* label +Ap |OP* |newLOOPOP |I32 flags|I32 debuggable|OP* expr|OP* block +Ap |OP* |newNULLLIST +Ap |OP* |newOP |I32 optype|I32 flags +Ap |void |newPROG |OP* o +Ap |OP* |newRANGE |I32 flags|OP* left|OP* right +Ap |OP* |newSLICEOP |I32 flags|OP* subscript|OP* listop +Ap |OP* |newSTATEOP |I32 flags|char* label|OP* o +Ap |CV* |newSUB |I32 floor|OP* o|OP* proto|OP* block +Apd |CV* |newXS |char* name|XSUBADDR_t f|char* filename +Apd |AV* |newAV +Ap |OP* |newAVREF |OP* o +Ap |OP* |newBINOP |I32 type|I32 flags|OP* first|OP* last +Ap |OP* |newCVREF |I32 flags|OP* o +Ap |OP* |newGVOP |I32 type|I32 flags|GV* gv +Ap |GV* |newGVgen |char* pack +Ap |OP* |newGVREF |I32 type|OP* o +Ap |OP* |newHVREF |OP* o +Apd |HV* |newHV +Ap |HV* |newHVhv |HV* hv +Ap |IO* |newIO +Ap |OP* |newLISTOP |I32 type|I32 flags|OP* first|OP* last +Ap |OP* |newPADOP |I32 type|I32 flags|SV* sv +Ap |OP* |newPMOP |I32 type|I32 flags +Ap |OP* |newPVOP |I32 type|I32 flags|char* pv +Ap |SV* |newRV |SV* pref +Apd |SV* |newRV_noinc |SV *sv +Apd |SV* |newSV |STRLEN len +Ap |OP* |newSVREF |OP* o +Ap |OP* |newSVOP |I32 type|I32 flags|SV* sv +Apd |SV* |newSViv |IV i +Apd |SV* |newSVuv |UV u +Apd |SV* |newSVnv |NV n +Apd |SV* |newSVpv |const char* s|STRLEN len +Apd |SV* |newSVpvn |const char* s|STRLEN len +Apd |SV* |newSVpvn_share |const char* s|I32 len|U32 hash +Afpd |SV* |newSVpvf |const char* pat|... +Ap |SV* |vnewSVpvf |const char* pat|va_list* args +Apd |SV* |newSVrv |SV* rv|const char* classname +Apd |SV* |newSVsv |SV* old +Ap |OP* |newUNOP |I32 type|I32 flags|OP* first +Ap |OP* |newWHILEOP |I32 flags|I32 debuggable|LOOP* loop \ + |I32 whileline|OP* expr|OP* block|OP* cont + +Ap |PERL_SI*|new_stackinfo|I32 stitems|I32 cxitems +Ap |char* |scan_vstring |char *vstr|SV *sv +Apd |char* |scan_version |char *vstr|SV *sv|bool qv +Apd |SV* |new_version |SV *ver +Apd |SV* |upg_version |SV *ver +Apd |SV* |vnumify |SV *vs +Apd |SV* |vnormal |SV *vs +Apd |SV* |vstringify |SV *vs +Apd |int |vcmp |SV *lvs|SV *rvs +p |PerlIO*|nextargv |GV* gv +Ap |char* |ninstr |const char* big|const char* bigend \ + |const char* little|const char* lend +p |OP* |oopsCV |OP* o +Ap |void |op_free |OP* arg +p |void |package |OP* o +pd |PADOFFSET|pad_alloc |I32 optype|U32 tmptype +p |PADOFFSET|allocmy |char* name +pd |PADOFFSET|pad_findmy |char* name +Ap |PADOFFSET|find_rundefsvoffset | +p |OP* |oopsAV |OP* o +p |OP* |oopsHV |OP* o +pd |void |pad_leavemy +Apd |SV* |pad_sv |PADOFFSET po +pd |void |pad_free |PADOFFSET po +pd |void |pad_reset +pd |void |pad_swipe |PADOFFSET po|bool refadjust +p |void |peep |OP* o +dopM |PerlIO*|start_glob |SV* pattern|IO *io +#if defined(USE_REENTRANT_API) +Ap |void |reentrant_size +Ap |void |reentrant_init +Ap |void |reentrant_free +Anp |void* |reentrant_retry|const char*|... +#endif +Ap |void |call_atexit |ATEXIT_t fn|void *ptr +Apd |I32 |call_argv |const char* sub_name|I32 flags|char** argv +Apd |I32 |call_method |const char* methname|I32 flags +Apd |I32 |call_pv |const char* sub_name|I32 flags +Apd |I32 |call_sv |SV* sv|I32 flags +Ap |void |despatch_signals +Apd |SV* |eval_pv |const char* p|I32 croak_on_error +Apd |I32 |eval_sv |SV* sv|I32 flags +Apd |SV* |get_sv |const char* name|I32 create +Apd |AV* |get_av |const char* name|I32 create +Apd |HV* |get_hv |const char* name|I32 create +Apd |CV* |get_cv |const char* name|I32 create +Ap |int |init_i18nl10n |int printwarn +Ap |int |init_i18nl14n |int printwarn +Ap |void |new_collate |char* newcoll +Ap |void |new_ctype |char* newctype +Ap |void |new_numeric |char* newcoll +Ap |void |set_numeric_local +Ap |void |set_numeric_radix +Ap |void |set_numeric_standard +Apd |void |require_pv |const char* pv +Apd |void |pack_cat |SV *cat|char *pat|char *patend|SV **beglist|SV **endlist|SV ***next_in_list|U32 flags +Apd |void |packlist |SV *cat|char *pat|char *patend|SV **beglist|SV **endlist +p |void |pidgone |Pid_t pid|int status +Ap |void |pmflag |U32* pmfl|int ch +p |OP* |pmruntime |OP* pm|OP* expr|OP* repl +p |OP* |pmtrans |OP* o|OP* expr|OP* repl +Ap |void |pop_scope +p |OP* |prepend_elem |I32 optype|OP* head|OP* tail +Ap |void |push_scope +p |OP* |ref |OP* o|I32 type +p |OP* |refkids |OP* o|I32 type +Ap |void |regdump |regexp* r +Ap |SV* |regclass_swash |struct regnode *n|bool doinit|SV **listsvp|SV **altsvp +Ap |I32 |pregexec |regexp* prog|char* stringarg \ + |char* strend|char* strbeg|I32 minend \ + |SV* screamer|U32 nosave +Ap |void |pregfree |struct regexp* r +Ap |regexp*|pregcomp |char* exp|char* xend|PMOP* pm +Ap |char* |re_intuit_start|regexp* prog|SV* sv|char* strpos \ + |char* strend|U32 flags \ + |struct re_scream_pos_data_s *data +Ap |SV* |re_intuit_string|regexp* prog +Ap |I32 |regexec_flags |regexp* prog|char* stringarg \ + |char* strend|char* strbeg|I32 minend \ + |SV* screamer|void* data|U32 flags +Ap |regnode*|regnext |regnode* p +Ep |void |regprop |SV* sv|regnode* o +Ap |void |repeatcpy |char* to|const char* from|I32 len|I32 count +Ap |char* |rninstr |const char* big|const char* bigend \ + |const char* little|const char* lend +Ap |Sighandler_t|rsignal |int i|Sighandler_t t +p |int |rsignal_restore|int i|Sigsave_t* t +p |int |rsignal_save |int i|Sighandler_t t1|Sigsave_t* t2 +Ap |Sighandler_t|rsignal_state|int i +p |void |rxres_free |void** rsp +p |void |rxres_restore |void** rsp|REGEXP* prx +p |void |rxres_save |void** rsp|REGEXP* prx +#if !defined(HAS_RENAME) +p |I32 |same_dirent |char* a|char* b +#endif +Apd |char* |savepv |const char* pv +Apd |char* |savesharedpv |const char* pv +Apd |char* |savepvn |const char* pv|I32 len +Ap |void |savestack_grow +Ap |void |savestack_grow_cnt |I32 need +Ap |void |save_aelem |AV* av|I32 idx|SV **sptr +Ap |I32 |save_alloc |I32 size|I32 pad +Ap |void |save_aptr |AV** aptr +Ap |AV* |save_ary |GV* gv +Ap |void |save_bool |bool* boolp +Ap |void |save_clearsv |SV** svp +Ap |void |save_delete |HV* hv|char* key|I32 klen +Ap |void |save_destructor|DESTRUCTORFUNC_NOCONTEXT_t f|void* p +Ap |void |save_destructor_x|DESTRUCTORFUNC_t f|void* p +Ap |void |save_freesv |SV* sv +p |void |save_freeop |OP* o +Ap |void |save_freepv |char* pv +Ap |void |save_generic_svref|SV** sptr +Ap |void |save_generic_pvref|char** str +Ap |void |save_shared_pvref|char** str +Ap |void |save_gp |GV* gv|I32 empty +Ap |HV* |save_hash |GV* gv +Ap |void |save_helem |HV* hv|SV *key|SV **sptr +Ap |void |save_hints +Ap |void |save_hptr |HV** hptr +Ap |void |save_I16 |I16* intp +Ap |void |save_I32 |I32* intp +Ap |void |save_I8 |I8* bytep +Ap |void |save_int |int* intp +Ap |void |save_item |SV* item +Ap |void |save_iv |IV* iv +Ap |void |save_list |SV** sarg|I32 maxsarg +Ap |void |save_long |long* longp +Ap |void |save_mortalizesv|SV* sv +Ap |void |save_nogv |GV* gv +p |void |save_op +Ap |SV* |save_scalar |GV* gv +Ap |void |save_pptr |char** pptr +Ap |void |save_vptr |void* pptr +Ap |void |save_re_context +Ap |void |save_padsv |PADOFFSET off +Ap |void |save_sptr |SV** sptr +Ap |SV* |save_svref |SV** sptr +Ap |SV** |save_threadsv |PADOFFSET i +p |OP* |sawparens |OP* o +p |OP* |scalar |OP* o +p |OP* |scalarkids |OP* o +p |OP* |scalarseq |OP* o +p |OP* |scalarvoid |OP* o +Apd |NV |scan_bin |char* start|STRLEN len|STRLEN* retlen +Apd |NV |scan_hex |char* start|STRLEN len|STRLEN* retlen +Ap |char* |scan_num |char* s|YYSTYPE *lvalp +Apd |NV |scan_oct |char* start|STRLEN len|STRLEN* retlen +p |OP* |scope |OP* o +Ap |char* |screaminstr |SV* bigsv|SV* littlesv|I32 start_shift \ + |I32 end_shift|I32 *state|I32 last +#if !defined(VMS) +p |I32 |setenv_getix |char* nam +#endif +p |void |setdefout |GV* gv +p |HEK* |share_hek |const char* sv|I32 len|U32 hash +np |Signal_t |sighandler |int sig +Anp |Signal_t |csighandler |int sig +Ap |SV** |stack_grow |SV** sp|SV**p|int n +Ap |I32 |start_subparse |I32 is_format|U32 flags +p |void |sub_crush_depth|CV* cv +Apd |bool |sv_2bool |SV* sv +Apd |CV* |sv_2cv |SV* sv|HV** st|GV** gvp|I32 lref +Apd |IO* |sv_2io |SV* sv +Amb |IV |sv_2iv |SV* sv +Apd |IV |sv_2iv_flags |SV* sv|I32 flags +Apd |SV* |sv_2mortal |SV* sv +Apd |NV |sv_2nv |SV* sv +Amb |char* |sv_2pv |SV* sv|STRLEN* lp +Apd |char* |sv_2pvutf8 |SV* sv|STRLEN* lp +Apd |char* |sv_2pvbyte |SV* sv|STRLEN* lp +Ap |char* |sv_pvn_nomg |SV* sv|STRLEN* lp +Amb |UV |sv_2uv |SV* sv +Apd |UV |sv_2uv_flags |SV* sv|I32 flags +Apd |IV |sv_iv |SV* sv +Apd |UV |sv_uv |SV* sv +Apd |NV |sv_nv |SV* sv +Apd |char* |sv_pvn |SV *sv|STRLEN *len +Apd |char* |sv_pvutf8n |SV *sv|STRLEN *len +Apd |char* |sv_pvbyten |SV *sv|STRLEN *len +Apd |I32 |sv_true |SV *sv +pd |void |sv_add_arena |char* ptr|U32 size|U32 flags +Apd |int |sv_backoff |SV* sv +Apd |SV* |sv_bless |SV* sv|HV* stash +Afpd |void |sv_catpvf |SV* sv|const char* pat|... +Ap |void |sv_vcatpvf |SV* sv|const char* pat|va_list* args +Apd |void |sv_catpv |SV* sv|const char* ptr +Amdb |void |sv_catpvn |SV* sv|const char* ptr|STRLEN len +Amdb |void |sv_catsv |SV* dsv|SV* ssv +Apd |void |sv_chop |SV* sv|char* ptr +pd |I32 |sv_clean_all +pd |void |sv_clean_objs +Apd |void |sv_clear |SV* sv +Apd |I32 |sv_cmp |SV* sv1|SV* sv2 +Apd |I32 |sv_cmp_locale |SV* sv1|SV* sv2 +#if defined(USE_LOCALE_COLLATE) +Apd |char* |sv_collxfrm |SV* sv|STRLEN* nxp +#endif +Ap |OP* |sv_compile_2op |SV* sv|OP** startp|char* code|PAD** padp +Apd |int |getcwd_sv |SV* sv +Apd |void |sv_dec |SV* sv +Ap |void |sv_dump |SV* sv +Apd |bool |sv_derived_from|SV* sv|const char* name +Apd |I32 |sv_eq |SV* sv1|SV* sv2 +Apd |void |sv_free |SV* sv +poMX |void |sv_free2 |SV* sv +pd |void |sv_free_arenas +Apd |char* |sv_gets |SV* sv|PerlIO* fp|I32 append +Apd |char* |sv_grow |SV* sv|STRLEN newlen +Apd |void |sv_inc |SV* sv +Apd |void |sv_insert |SV* bigsv|STRLEN offset|STRLEN len \ + |char* little|STRLEN littlelen +Apd |int |sv_isa |SV* sv|const char* name +Apd |int |sv_isobject |SV* sv +Apd |STRLEN |sv_len |SV* sv +Apd |STRLEN |sv_len_utf8 |SV* sv +Apd |void |sv_magic |SV* sv|SV* obj|int how|const char* name \ + |I32 namlen +Apd |MAGIC *|sv_magicext |SV* sv|SV* obj|int how|MGVTBL *vtbl \ + | const char* name|I32 namlen +Apd |SV* |sv_mortalcopy |SV* oldsv +Apd |SV* |sv_newmortal +Apd |SV* |sv_newref |SV* sv +Ap |char* |sv_peek |SV* sv +Apd |void |sv_pos_u2b |SV* sv|I32* offsetp|I32* lenp +Apd |void |sv_pos_b2u |SV* sv|I32* offsetp +Amdb |char* |sv_pvn_force |SV* sv|STRLEN* lp +Apd |char* |sv_pvutf8n_force|SV* sv|STRLEN* lp +Apd |char* |sv_pvbyten_force|SV* sv|STRLEN* lp +Apd |char* |sv_recode_to_utf8 |SV* sv|SV *encoding +Apd |bool |sv_cat_decode |SV* dsv|SV *encoding|SV *ssv|int *offset \ + |char* tstr|int tlen +Apd |char* |sv_reftype |SV* sv|int ob +Apd |void |sv_replace |SV* sv|SV* nsv +Apd |void |sv_report_used +Apd |void |sv_reset |char* s|HV* stash +Afpd |void |sv_setpvf |SV* sv|const char* pat|... +Ap |void |sv_vsetpvf |SV* sv|const char* pat|va_list* args +Apd |void |sv_setiv |SV* sv|IV num +Apdb |void |sv_setpviv |SV* sv|IV num +Apd |void |sv_setuv |SV* sv|UV num +Apd |void |sv_setnv |SV* sv|NV num +Apd |SV* |sv_setref_iv |SV* rv|const char* classname|IV iv +Apd |SV* |sv_setref_uv |SV* rv|const char* classname|UV uv +Apd |SV* |sv_setref_nv |SV* rv|const char* classname|NV nv +Apd |SV* |sv_setref_pv |SV* rv|const char* classname|void* pv +Apd |SV* |sv_setref_pvn |SV* rv|const char* classname|char* pv \ + |STRLEN n +Apd |void |sv_setpv |SV* sv|const char* ptr +Apd |void |sv_setpvn |SV* sv|const char* ptr|STRLEN len +Amdb |void |sv_setsv |SV* dsv|SV* ssv +Apd |void |sv_taint |SV* sv +Apd |bool |sv_tainted |SV* sv +Apd |int |sv_unmagic |SV* sv|int type +Apd |void |sv_unref |SV* sv +Apd |void |sv_unref_flags |SV* sv|U32 flags +Apd |void |sv_untaint |SV* sv +Apd |bool |sv_upgrade |SV* sv|U32 mt +Apd |void |sv_usepvn |SV* sv|char* ptr|STRLEN len +Apd |void |sv_vcatpvfn |SV* sv|const char* pat|STRLEN patlen \ + |va_list* args|SV** svargs|I32 svmax \ + |bool *maybe_tainted +Apd |void |sv_vsetpvfn |SV* sv|const char* pat|STRLEN patlen \ + |va_list* args|SV** svargs|I32 svmax \ + |bool *maybe_tainted +Ap |NV |str_to_version |SV *sv +Ap |SV* |swash_init |char* pkg|char* name|SV* listsv \ + |I32 minbits|I32 none +Ap |UV |swash_fetch |SV *sv|U8 *ptr|bool do_utf8 +Ap |void |taint_env +Ap |void |taint_proper |const char* f|const char* s +Apd |UV |to_utf8_case |U8 *p|U8* ustrp|STRLEN *lenp \ + |SV **swash|char *normal|char *special +Apd |UV |to_utf8_lower |U8 *p|U8* ustrp|STRLEN *lenp +Apd |UV |to_utf8_upper |U8 *p|U8* ustrp|STRLEN *lenp +Apd |UV |to_utf8_title |U8 *p|U8* ustrp|STRLEN *lenp +Apd |UV |to_utf8_fold |U8 *p|U8* ustrp|STRLEN *lenp +#if defined(UNLINK_ALL_VERSIONS) +Ap |I32 |unlnk |char* f +#endif +Apd |I32 |unpack_str |char *pat|char *patend|char *s|char *strbeg|char *strend|char **new_s|I32 ocnt|U32 flags +Apd |I32 |unpackstring |char *pat|char *patend|char *s|char *strend|U32 flags +Ap |void |unsharepvn |const char* sv|I32 len|U32 hash +p |void |unshare_hek |HEK* hek +p |void |utilize |int aver|I32 floor|OP* version|OP* idop|OP* arg +Ap |U8* |utf16_to_utf8 |U8* p|U8 *d|I32 bytelen|I32 *newlen +Ap |U8* |utf16_to_utf8_reversed|U8* p|U8 *d|I32 bytelen|I32 *newlen +Adp |STRLEN |utf8_length |U8* s|U8 *e +Apd |IV |utf8_distance |U8 *a|U8 *b +Apd |U8* |utf8_hop |U8 *s|I32 off +ApMd |U8* |utf8_to_bytes |U8 *s|STRLEN *len +ApMd |U8* |bytes_from_utf8|U8 *s|STRLEN *len|bool *is_utf8 +ApMd |U8* |bytes_to_utf8 |U8 *s|STRLEN *len +Apd |UV |utf8_to_uvchr |U8 *s|STRLEN* retlen +Apd |UV |utf8_to_uvuni |U8 *s|STRLEN* retlen +Adp |UV |utf8n_to_uvchr |U8 *s|STRLEN curlen|STRLEN* retlen|U32 flags +Adp |UV |utf8n_to_uvuni |U8 *s|STRLEN curlen|STRLEN* retlen|U32 flags +Apd |U8* |uvchr_to_utf8 |U8 *d|UV uv +Ap |U8* |uvuni_to_utf8 |U8 *d|UV uv +Ap |U8* |uvchr_to_utf8_flags |U8 *d|UV uv|UV flags +Apd |U8* |uvuni_to_utf8_flags |U8 *d|UV uv|UV flags +Apd |char* |pv_uni_display |SV *dsv|U8 *spv|STRLEN len \ + |STRLEN pvlim|UV flags +Apd |char* |sv_uni_display |SV *dsv|SV *ssv|STRLEN pvlim|UV flags +p |void |vivify_defelem |SV* sv +p |void |vivify_ref |SV* sv|U32 to_what +p |I32 |wait4pid |Pid_t pid|int* statusp|int flags +p |U32 |parse_unicode_opts|char **popt +p |U32 |seed +p |UV |get_hash_seed +p |void |report_evil_fh |GV *gv|IO *io|I32 op +pd |void |report_uninit |SV* uninit_sv +Afpd |void |warn |const char* pat|... +Ap |void |vwarn |const char* pat|va_list* args +Afp |void |warner |U32 err|const char* pat|... +Ap |void |vwarner |U32 err|const char* pat|va_list* args +p |void |watch |char** addr +Ap |I32 |whichsig |char* sig +p |void |write_to_stderr|const char* message|int msglen +p |int |yyerror |char* s +p |int |yylex +p |int |yyparse +p |int |yywarn |char* s +#if defined(MYMALLOC) +Ap |void |dump_mstats |char* s +Ap |int |get_mstats |perl_mstats_t *buf|int buflen|int level +#endif +Anp |Malloc_t|safesysmalloc |MEM_SIZE nbytes +Anp |Malloc_t|safesyscalloc |MEM_SIZE elements|MEM_SIZE size +Anp |Malloc_t|safesysrealloc|Malloc_t where|MEM_SIZE nbytes +Anp |Free_t |safesysfree |Malloc_t where +#if defined(PERL_GLOBAL_STRUCT) +Ap |struct perl_vars *|GetVars +#endif +Ap |int |runops_standard +Ap |int |runops_debug +Afpd |void |sv_catpvf_mg |SV *sv|const char* pat|... +Ap |void |sv_vcatpvf_mg |SV* sv|const char* pat|va_list* args +Apd |void |sv_catpv_mg |SV *sv|const char *ptr +Apd |void |sv_catpvn_mg |SV *sv|const char *ptr|STRLEN len +Apd |void |sv_catsv_mg |SV *dstr|SV *sstr +Afpd |void |sv_setpvf_mg |SV *sv|const char* pat|... +Ap |void |sv_vsetpvf_mg |SV* sv|const char* pat|va_list* args +Apd |void |sv_setiv_mg |SV *sv|IV i +Apdb |void |sv_setpviv_mg |SV *sv|IV iv +Apd |void |sv_setuv_mg |SV *sv|UV u +Apd |void |sv_setnv_mg |SV *sv|NV num +Apd |void |sv_setpv_mg |SV *sv|const char *ptr +Apd |void |sv_setpvn_mg |SV *sv|const char *ptr|STRLEN len +Apd |void |sv_setsv_mg |SV *dstr|SV *sstr +Apd |void |sv_usepvn_mg |SV *sv|char *ptr|STRLEN len +Ap |MGVTBL*|get_vtbl |int vtbl_id +Ap |char* |pv_display |SV *dsv|char *pv|STRLEN cur|STRLEN len \ + |STRLEN pvlim +Afp |void |dump_indent |I32 level|PerlIO *file|const char* pat|... +Ap |void |dump_vindent |I32 level|PerlIO *file|const char* pat \ + |va_list *args +Ap |void |do_gv_dump |I32 level|PerlIO *file|char *name|GV *sv +Ap |void |do_gvgv_dump |I32 level|PerlIO *file|char *name|GV *sv +Ap |void |do_hv_dump |I32 level|PerlIO *file|char *name|HV *sv +Ap |void |do_magic_dump |I32 level|PerlIO *file|MAGIC *mg|I32 nest \ + |I32 maxnest|bool dumpops|STRLEN pvlim +Ap |void |do_op_dump |I32 level|PerlIO *file|OP *o +Ap |void |do_pmop_dump |I32 level|PerlIO *file|PMOP *pm +Ap |void |do_sv_dump |I32 level|PerlIO *file|SV *sv|I32 nest \ + |I32 maxnest|bool dumpops|STRLEN pvlim +Ap |void |magic_dump |MAGIC *mg +#if defined(PERL_FLEXIBLE_EXCEPTIONS) +Ap |void* |default_protect|volatile JMPENV *je|int *excpt \ + |protect_body_t body|... +Ap |void* |vdefault_protect|volatile JMPENV *je|int *excpt \ + |protect_body_t body|va_list *args +#endif +Ap |void |reginitcolors +Apd |char* |sv_2pv_nolen |SV* sv +Apd |char* |sv_2pvutf8_nolen|SV* sv +Apd |char* |sv_2pvbyte_nolen|SV* sv +Amdb |char* |sv_pv |SV *sv +Amdb |char* |sv_pvutf8 |SV *sv +Amdb |char* |sv_pvbyte |SV *sv +Amdb |STRLEN |sv_utf8_upgrade|SV *sv +ApdM |bool |sv_utf8_downgrade|SV *sv|bool fail_ok +Apd |void |sv_utf8_encode |SV *sv +ApdM |bool |sv_utf8_decode |SV *sv +Apd |void |sv_force_normal|SV *sv +Apd |void |sv_force_normal_flags|SV *sv|U32 flags +Ap |void |tmps_grow |I32 n +Apd |SV* |sv_rvweaken |SV *sv +p |int |magic_killbackrefs|SV *sv|MAGIC *mg +Ap |OP* |newANONATTRSUB |I32 floor|OP *proto|OP *attrs|OP *block +Ap |CV* |newATTRSUB |I32 floor|OP *o|OP *proto|OP *attrs|OP *block +Ap |void |newMYSUB |I32 floor|OP *o|OP *proto|OP *attrs|OP *block +p |OP * |my_attrs |OP *o|OP *attrs +p |void |boot_core_xsutils +#if defined(USE_ITHREADS) +Ap |PERL_CONTEXT*|cx_dup |PERL_CONTEXT* cx|I32 ix|I32 max|CLONE_PARAMS* param +Ap |PERL_SI*|si_dup |PERL_SI* si|CLONE_PARAMS* param +Ap |ANY* |ss_dup |PerlInterpreter* proto_perl|CLONE_PARAMS* param +Ap |void* |any_dup |void* v|PerlInterpreter* proto_perl +Ap |HE* |he_dup |HE* e|bool shared|CLONE_PARAMS* param +Ap |REGEXP*|re_dup |REGEXP* r|CLONE_PARAMS* param +Ap |PerlIO*|fp_dup |PerlIO* fp|char type|CLONE_PARAMS* param +Ap |DIR* |dirp_dup |DIR* dp +Ap |GP* |gp_dup |GP* gp|CLONE_PARAMS* param +Ap |MAGIC* |mg_dup |MAGIC* mg|CLONE_PARAMS* param +Ap |SV* |sv_dup |SV* sstr|CLONE_PARAMS* param +#if defined(HAVE_INTERP_INTERN) +Ap |void |sys_intern_dup |struct interp_intern* src \ + |struct interp_intern* dst +#endif +Ap |PTR_TBL_t*|ptr_table_new +Ap |void* |ptr_table_fetch|PTR_TBL_t *tbl|void *sv +Ap |void |ptr_table_store|PTR_TBL_t *tbl|void *oldsv|void *newsv +Ap |void |ptr_table_split|PTR_TBL_t *tbl +Ap |void |ptr_table_clear|PTR_TBL_t *tbl +Ap |void |ptr_table_free|PTR_TBL_t *tbl +#endif +#if defined(HAVE_INTERP_INTERN) +Ap |void |sys_intern_clear +Ap |void |sys_intern_init +#endif + +Ap |char * |custom_op_name |OP* op +Ap |char * |custom_op_desc |OP* op + +#if defined(PERL_COPY_ON_WRITE) +pMX |int |sv_release_IVX |SV *sv +#endif + +Adp |void |sv_nosharing |SV * +Adp |void |sv_nolocking |SV * +Adp |void |sv_nounlocking |SV * +Adp |int |nothreadhook + +END_EXTERN_C + +#if defined(PERL_IN_DOOP_C) || defined(PERL_DECL_PROT) +s |I32 |do_trans_simple |SV *sv +s |I32 |do_trans_count |SV *sv +s |I32 |do_trans_complex |SV *sv +s |I32 |do_trans_simple_utf8 |SV *sv +s |I32 |do_trans_count_utf8 |SV *sv +s |I32 |do_trans_complex_utf8 |SV *sv +#endif + +#if defined(PERL_IN_GV_C) || defined(PERL_DECL_PROT) +s |void |gv_init_sv |GV *gv|I32 sv_type +s |void |require_errno |GV *gv +#endif + +#if defined(PERL_IN_HV_C) || defined(PERL_DECL_PROT) +s |void |hsplit |HV *hv +s |void |hfreeentries |HV *hv +s |void |more_he +s |HE* |new_he +s |void |del_he |HE *p +s |HEK* |save_hek_flags |const char *str|I32 len|U32 hash|int flags +s |void |hv_magic_check |HV *hv|bool *needs_copy|bool *needs_store +s |void |unshare_hek_or_pvn|HEK* hek|const char* sv|I32 len|U32 hash +s |HEK* |share_hek_flags|const char* sv|I32 len|U32 hash|int flags +s |void |hv_notallowed |int flags|const char *key|I32 klen|const char *msg +#endif + +#if defined(PERL_IN_MG_C) || defined(PERL_DECL_PROT) +s |void |save_magic |I32 mgs_ix|SV *sv +s |int |magic_methpack |SV *sv|MAGIC *mg|char *meth +s |int |magic_methcall |SV *sv|MAGIC *mg|char *meth|I32 f \ + |int n|SV *val +#endif + +#if defined(PERL_IN_OP_C) || defined(PERL_DECL_PROT) +s |I32 |list_assignment|OP *o +s |void |bad_type |I32 n|char *t|char *name|OP *kid +s |void |cop_free |COP *cop +s |OP* |modkids |OP *o|I32 type +s |void |no_bareword_allowed|OP *o +s |OP* |no_fh_allowed |OP *o +s |OP* |scalarboolean |OP *o +s |OP* |too_few_arguments|OP *o|char* name +s |OP* |too_many_arguments|OP *o|char* name +s |OP* |newDEFSVOP +s |OP* |new_logop |I32 type|I32 flags|OP **firstp|OP **otherp +s |void |simplify_sort |OP *o +s |bool |is_handle_constructor |OP *o|I32 argnum +s |char* |gv_ename |GV *gv +s |bool |scalar_mod_type|OP *o|I32 type +s |OP * |my_kid |OP *o|OP *attrs|OP **imopsp +s |OP * |dup_attrlist |OP *o +s |void |apply_attrs |HV *stash|SV *target|OP *attrs|bool for_my +s |void |apply_attrs_my |HV *stash|OP *target|OP *attrs|OP **imopsp +#endif +#if defined(PL_OP_SLAB_ALLOC) +Ap |void* |Slab_Alloc |int m|size_t sz +Ap |void |Slab_Free |void *op +#endif + +#if defined(PERL_IN_PERL_C) || defined(PERL_DECL_PROT) +s |void |find_beginning +s |void |forbid_setid |char * +s |void |incpush |char *|int|int|int +s |void |init_interp +s |void |init_ids +s |void |init_lexer +s |void |init_main_stash +s |void |init_perllib +s |void |init_postdump_symbols|int|char **|char ** +s |void |init_predump_symbols +rs |void |my_exit_jump +s |void |nuke_stacks +s |void |open_script |char *|bool|SV * +s |void |usage |char * +s |void |validate_suid |char *|char* +# if defined(IAMSUID) +s |int |fd_on_nosuid_fs|int fd +# endif +s |void* |parse_body |char **env|XSINIT_t xsinit +s |void* |run_body |I32 oldscope +s |void |call_body |OP *myop|int is_eval +s |void* |call_list_body |CV *cv +#if defined(PERL_FLEXIBLE_EXCEPTIONS) +s |void* |vparse_body |va_list args +s |void* |vrun_body |va_list args +s |void* |vcall_body |va_list args +s |void* |vcall_list_body|va_list args +#endif +#endif + +#if defined(PERL_IN_PP_C) || defined(PERL_DECL_PROT) +s |SV* |refto |SV* sv +#endif + +#if defined(PERL_IN_PP_PACK_C) || defined(PERL_DECL_PROT) +s |I32 |unpack_rec |tempsym_t* symptr|char *s|char *strbeg|char *strend|char **new_s +s |SV ** |pack_rec |SV *cat|tempsym_t* symptr|SV **beglist|SV **endlist +s |SV* |mul128 |SV *sv|U8 m +s |I32 |measure_struct |tempsym_t* symptr +s |char * |group_end |char *pat|char *patend|char ender +s |char * |get_num |char *ppat|I32 * +s |bool |next_symbol |tempsym_t* symptr +s |void |doencodes |SV* sv|char* s|I32 len +s |SV* |is_an_int |char *s|STRLEN l +s |int |div128 |SV *pnum|bool *done +#endif + +#if defined(PERL_IN_PP_CTL_C) || defined(PERL_DECL_PROT) +s |OP* |docatch |OP *o +s |void* |docatch_body +#if defined(PERL_FLEXIBLE_EXCEPTIONS) +s |void* |vdocatch_body |va_list args +#endif +s |OP* |dofindlabel |OP *o|char *label|OP **opstack|OP **oplimit +s |OP* |doparseform |SV *sv +sn |bool |num_overflow |NV value|I32 fldsize|I32 frcsize +s |I32 |dopoptoeval |I32 startingblock +s |I32 |dopoptolabel |char *label +s |I32 |dopoptoloop |I32 startingblock +s |I32 |dopoptosub |I32 startingblock +s |I32 |dopoptosub_at |PERL_CONTEXT* cxstk|I32 startingblock +s |void |save_lines |AV *array|SV *sv +s |OP* |doeval |int gimme|OP** startop|CV* outside|U32 seq +s |PerlIO *|doopen_pm |const char *name|const char *mode +s |bool |path_is_absolute|char *name +#endif + +#if defined(PERL_IN_PP_HOT_C) || defined(PERL_DECL_PROT) +s |void |do_oddball |HV *hash|SV **relem|SV **firstrelem +s |CV* |get_db_sub |SV **svp|CV *cv +s |SV* |method_common |SV* meth|U32* hashp +#endif + +#if defined(PERL_IN_PP_SYS_C) || defined(PERL_DECL_PROT) +s |OP* |doform |CV *cv|GV *gv|OP *retop +s |int |emulate_eaccess|const char* path|Mode_t mode +# if !defined(HAS_MKDIR) || !defined(HAS_RMDIR) +s |int |dooneliner |char *cmd|char *filename +# endif +#endif + +#if defined(PERL_IN_REGCOMP_C) || defined(PERL_DECL_PROT) +Es |regnode*|reg |struct RExC_state_t*|I32|I32 * +Es |regnode*|reganode |struct RExC_state_t*|U8|U32 +Es |regnode*|regatom |struct RExC_state_t*|I32 * +Es |regnode*|regbranch |struct RExC_state_t*|I32 *|I32 +Es |void |reguni |struct RExC_state_t*|UV|char *|STRLEN* +Es |regnode*|regclass |struct RExC_state_t* +Es |I32 |regcurly |char * +Es |regnode*|reg_node |struct RExC_state_t*|U8 +Es |regnode*|regpiece |struct RExC_state_t*|I32 * +Es |void |reginsert |struct RExC_state_t*|U8|regnode * +Es |void |regoptail |struct RExC_state_t*|regnode *|regnode * +Es |void |regtail |struct RExC_state_t*|regnode *|regnode * +Es |char*|regwhite |char *|char * +Es |char*|nextchar |struct RExC_state_t* +# ifdef DEBUGGING +Es |regnode*|dumpuntil |regnode *start|regnode *node \ + |regnode *last|SV* sv|I32 l +Es |void |put_byte |SV* sv|int c +# endif +Es |void |scan_commit |struct RExC_state_t*|struct scan_data_t *data +Es |void |cl_anything |struct RExC_state_t*|struct regnode_charclass_class *cl +Es |int |cl_is_anything |struct regnode_charclass_class *cl +Es |void |cl_init |struct RExC_state_t*|struct regnode_charclass_class *cl +Es |void |cl_init_zero |struct RExC_state_t*|struct regnode_charclass_class *cl +Es |void |cl_and |struct regnode_charclass_class *cl \ + |struct regnode_charclass_class *and_with +Es |void |cl_or |struct RExC_state_t*|struct regnode_charclass_class *cl \ + |struct regnode_charclass_class *or_with +Es |I32 |study_chunk |struct RExC_state_t*|regnode **scanp|I32 *deltap \ + |regnode *last|struct scan_data_t *data \ + |U32 flags +Es |I32 |add_data |struct RExC_state_t*|I32 n|char *s +rs |void|re_croak2 |const char* pat1|const char* pat2|... +Es |I32 |regpposixcc |struct RExC_state_t*|I32 value +Es |void |checkposixcc |struct RExC_state_t* +#endif + +#if defined(PERL_IN_REGEXEC_C) || defined(PERL_DECL_PROT) +Es |I32 |regmatch |regnode *prog +Es |I32 |regrepeat |regnode *p|I32 max +Es |I32 |regrepeat_hard |regnode *p|I32 max|I32 *lp +Es |I32 |regtry |regexp *prog|char *startpos +Es |bool |reginclass |regnode *n|U8 *p|STRLEN *lenp|bool do_utf8sv_is_utf8 +Es |CHECKPOINT|regcppush |I32 parenfloor +Es |char*|regcppop +Es |char*|regcp_set_to |I32 ss +Es |void |cache_re |regexp *prog +Es |U8* |reghop |U8 *pos|I32 off +Es |U8* |reghop3 |U8 *pos|I32 off|U8 *lim +Es |U8* |reghopmaybe |U8 *pos|I32 off +Es |U8* |reghopmaybe3 |U8 *pos|I32 off|U8 *lim +Es |char* |find_byclass |regexp * prog|regnode *c|char *s|char *strend|char *startpos|I32 norun +Es |void |to_utf8_substr |regexp * prog +Es |void |to_byte_substr |regexp * prog +#endif + +#if defined(PERL_IN_DUMP_C) || defined(PERL_DECL_PROT) +s |CV* |deb_curcv |I32 ix +s |void |debprof |OP *o +#endif + +#if defined(PERL_IN_SCOPE_C) || defined(PERL_DECL_PROT) +s |SV* |save_scalar_at |SV **sptr +#endif + +#if defined(PERL_IN_SV_C) || defined(PERL_DECL_PROT) +s |IV |asIV |SV* sv +s |UV |asUV |SV* sv +s |SV* |more_sv +s |void |more_xiv +s |void |more_xnv +s |void |more_xpv +s |void |more_xpviv +s |void |more_xpvnv +s |void |more_xpvcv +s |void |more_xpvav +s |void |more_xpvhv +s |void |more_xpvmg +s |void |more_xpvlv +s |void |more_xpvbm +s |void |more_xrv +s |XPVIV* |new_xiv +s |XPVNV* |new_xnv +s |XPV* |new_xpv +s |XPVIV* |new_xpviv +s |XPVNV* |new_xpvnv +s |XPVCV* |new_xpvcv +s |XPVAV* |new_xpvav +s |XPVHV* |new_xpvhv +s |XPVMG* |new_xpvmg +s |XPVLV* |new_xpvlv +s |XPVBM* |new_xpvbm +s |XRV* |new_xrv +s |void |del_xiv |XPVIV* p +s |void |del_xnv |XPVNV* p +s |void |del_xpv |XPV* p +s |void |del_xpviv |XPVIV* p +s |void |del_xpvnv |XPVNV* p +s |void |del_xpvcv |XPVCV* p +s |void |del_xpvav |XPVAV* p +s |void |del_xpvhv |XPVHV* p +s |void |del_xpvmg |XPVMG* p +s |void |del_xpvlv |XPVLV* p +s |void |del_xpvbm |XPVBM* p +s |void |del_xrv |XRV* p +s |void |sv_unglob |SV* sv +s |void |not_a_number |SV *sv +s |I32 |visit |SVFUNC_t f|U32 flags|U32 mask +s |void |sv_add_backref |SV *tsv|SV *sv +s |void |sv_del_backref |SV *sv +# ifdef DEBUGGING +s |void |del_sv |SV *p +# endif +# if !defined(NV_PRESERVES_UV) +s |int |sv_2iuv_non_preserve |SV *sv|I32 numtype +# endif +s |I32 |expect_number |char** pattern +# +# if defined(USE_ITHREADS) +s |SV* |gv_share |SV *sv|CLONE_PARAMS *param +# endif +s |bool |utf8_mg_pos |SV *sv|MAGIC **mgp|STRLEN **cachep|I32 i|I32 *offsetp|I32 uoff|U8 **sp|U8 *start|U8 *send +s |bool |utf8_mg_pos_init |SV *sv|MAGIC **mgp|STRLEN **cachep|I32 i|I32 *offsetp|U8 *s|U8 *start +#if defined(PERL_COPY_ON_WRITE) +sM |void |sv_release_COW |SV *sv|char *pvx|STRLEN cur|STRLEN len \ + |U32 hash|SV *after +#endif +#endif + +#if defined(PERL_IN_TOKE_C) || defined(PERL_DECL_PROT) +s |void |check_uni +s |void |force_next |I32 type +s |char* |force_version |char *start|int guessing +s |char* |force_word |char *start|int token|int check_keyword \ + |int allow_pack|int allow_tick +s |SV* |tokeq |SV *sv +s |int |pending_ident +s |char* |scan_const |char *start +s |char* |scan_formline |char *s +s |char* |scan_heredoc |char *s +s |char* |scan_ident |char *s|char *send|char *dest \ + |STRLEN destlen|I32 ck_uni +s |char* |scan_inputsymbol|char *start +s |char* |scan_pat |char *start|I32 type +s |char* |scan_str |char *start|int keep_quoted|int keep_delims +s |char* |scan_subst |char *start +s |char* |scan_trans |char *start +s |char* |scan_word |char *s|char *dest|STRLEN destlen \ + |int allow_package|STRLEN *slp +s |char* |skipspace |char *s +s |char* |swallow_bom |U8 *s +s |void |checkcomma |char *s|char *name|char *what +s |void |force_ident |char *s|int kind +s |void |incline |char *s +s |int |intuit_method |char *s|GV *gv +s |int |intuit_more |char *s +s |I32 |lop |I32 f|int x|char *s +s |void |missingterm |char *s +s |void |no_op |char *what|char *s +s |void |set_csh +s |I32 |sublex_done +s |I32 |sublex_push +s |I32 |sublex_start +s |char * |filter_gets |SV *sv|PerlIO *fp|STRLEN append +s |HV * |find_in_my_stash|char *pkgname|I32 len +s |SV* |new_constant |char *s|STRLEN len|const char *key|SV *sv \ + |SV *pv|const char *type +# if defined(DEBUGGING) +s |void |tokereport |char *thing|char *s|I32 rv +# endif +s |int |ao |int toketype +s |void |depcom +s |char* |incl_perldb +#if 0 +s |I32 |utf16_textfilter|int idx|SV *sv|int maxlen +s |I32 |utf16rev_textfilter|int idx|SV *sv|int maxlen +#endif +# if defined(PERL_CR_FILTER) +s |I32 |cr_textfilter |int idx|SV *sv|int maxlen +# endif +#endif + +#if defined(PERL_IN_UNIVERSAL_C) || defined(PERL_DECL_PROT) +s |SV*|isa_lookup |HV *stash|const char *name|HV *name_stash|int len|int level +#endif + +#if defined(PERL_IN_LOCALE_C) || defined(PERL_DECL_PROT) +s |char* |stdize_locale |char* locs +#endif + +#if defined(PERL_IN_UTIL_C) || defined(PERL_DECL_PROT) +s |COP* |closest_cop |COP *cop|OP *o +s |SV* |mess_alloc +#endif + +#if defined(PERL_IN_NUMERIC_C) || defined(PERL_DECL_PROT) +sn |NV|mulexp10 |NV value|I32 exponent +#endif + +START_EXTERN_C + +Apd |void |sv_setsv_flags |SV* dsv|SV* ssv|I32 flags +Apd |void |sv_catpvn_flags|SV* sv|const char* ptr|STRLEN len|I32 flags +Apd |void |sv_catsv_flags |SV* dsv|SV* ssv|I32 flags +Apd |STRLEN |sv_utf8_upgrade_flags|SV *sv|I32 flags +Apd |char* |sv_pvn_force_flags|SV* sv|STRLEN* lp|I32 flags +Apd |char* |sv_2pv_flags |SV* sv|STRLEN* lp|I32 flags +Apd |void |sv_copypv |SV* dsv|SV* ssv +Ap |char* |my_atof2 |const char *s|NV* value +Apn |int |my_socketpair |int family|int type|int protocol|int fd[2] +#ifdef PERL_COPY_ON_WRITE +pMXE |SV* |sv_setsv_cow |SV* dsv|SV* ssv +#endif + +#if defined(USE_PERLIO) && !defined(USE_SFIO) +Ap |int |PerlIO_close |PerlIO * +Ap |int |PerlIO_fill |PerlIO * +Ap |int |PerlIO_fileno |PerlIO * +Ap |int |PerlIO_eof |PerlIO * +Ap |int |PerlIO_error |PerlIO * +Ap |int |PerlIO_flush |PerlIO * +Ap |void |PerlIO_clearerr |PerlIO * +Ap |void |PerlIO_set_cnt |PerlIO *|int +Ap |void |PerlIO_set_ptrcnt |PerlIO *|STDCHAR *|int +Ap |void |PerlIO_setlinebuf |PerlIO * +Ap |SSize_t|PerlIO_read |PerlIO *|void *|Size_t +Ap |SSize_t|PerlIO_write |PerlIO *|const void *|Size_t +Ap |SSize_t|PerlIO_unread |PerlIO *|const void *|Size_t +Ap |Off_t |PerlIO_tell |PerlIO * +Ap |int |PerlIO_seek |PerlIO *|Off_t|int + +Ap |STDCHAR *|PerlIO_get_base |PerlIO * +Ap |STDCHAR *|PerlIO_get_ptr |PerlIO * +Ap |int |PerlIO_get_bufsiz |PerlIO * +Ap |int |PerlIO_get_cnt |PerlIO * + +Ap |PerlIO *|PerlIO_stdin +Ap |PerlIO *|PerlIO_stdout +Ap |PerlIO *|PerlIO_stderr +#endif /* PERLIO_LAYERS */ + +p |void |deb_stack_all +#ifdef PERL_IN_DEB_C +s |void |deb_stack_n |SV** stack_base|I32 stack_min \ + |I32 stack_max|I32 mark_min|I32 mark_max +#endif + +pd |PADLIST*|pad_new |int flags +pd |void |pad_undef |CV* cv +pd |PADOFFSET|pad_add_name |char *name\ + |HV* typestash|HV* ourstash \ + |bool clone +pd |PADOFFSET|pad_add_anon |SV* sv|OPCODE op_type +pd |void |pad_check_dup |char* name|bool is_our|HV* ourstash +#ifdef DEBUGGING +pd |void |pad_setsv |PADOFFSET po|SV* sv +#endif +pd |void |pad_block_start|int full +pd |void |pad_tidy |padtidy_type type +pd |void |do_dump_pad |I32 level|PerlIO *file \ + |PADLIST *padlist|int full +pd |void |pad_fixup_inner_anons|PADLIST *padlist|CV *old_cv|CV *new_cv + +pd |void |pad_push |PADLIST *padlist|int depth|int has_args + +#if defined(PERL_IN_PAD_C) || defined(PERL_DECL_PROT) +sd |PADOFFSET|pad_findlex |char *name|CV* cv|U32 seq|int warn \ + |SV** out_capture|SV** out_name_sv \ + |int *out_flags +# if defined(DEBUGGING) +sd |void |cv_dump |CV *cv|char *title +# endif +#endif +pd |CV* |find_runcv |U32 *db_seqp +p |void |free_tied_hv_pool +#if defined(DEBUGGING) +p |int |get_debug_opts |char **s +#endif +Ap |void |save_set_svflags|SV* sv|U32 mask|U32 val +Apod |void |hv_assert |HV* tb + +#if defined(PERL_IN_HV_C) || defined(PERL_DECL_PROT) +sM |SV* |hv_delete_common|HV* tb|SV* key_sv|const char* key|STRLEN klen|int k_flags|I32 d_flags|U32 hash +sM |HE* |hv_fetch_common|HV* tb|SV* key_sv|const char* key|STRLEN klen|int flags|int action|SV* val|U32 hash +#endif + +Apd |void |hv_clear_placeholders|HV* hb + +Apd |SV* |hv_scalar |HV* hv| +p |SV* |magic_scalarpack|HV* hv|MAGIC* mg +#ifdef PERL_IN_SV_C +sMd |SV* |find_uninit_var|OP* obase|SV* uninit_sv|bool top +#endif + +#ifdef PERL_NEED_MY_HTOLE16 +np |U16 |my_htole16 |U16 n +#endif +#ifdef PERL_NEED_MY_LETOH16 +np |U16 |my_letoh16 |U16 n +#endif +#ifdef PERL_NEED_MY_HTOBE16 +np |U16 |my_htobe16 |U16 n +#endif +#ifdef PERL_NEED_MY_BETOH16 +np |U16 |my_betoh16 |U16 n +#endif +#ifdef PERL_NEED_MY_HTOLE32 +np |U32 |my_htole32 |U32 n +#endif +#ifdef PERL_NEED_MY_LETOH32 +np |U32 |my_letoh32 |U32 n +#endif +#ifdef PERL_NEED_MY_HTOBE32 +np |U32 |my_htobe32 |U32 n +#endif +#ifdef PERL_NEED_MY_BETOH32 +np |U32 |my_betoh32 |U32 n +#endif +#ifdef PERL_NEED_MY_HTOLE64 +np |U64 |my_htole64 |U64 n +#endif +#ifdef PERL_NEED_MY_LETOH64 +np |U64 |my_letoh64 |U64 n +#endif +#ifdef PERL_NEED_MY_HTOBE64 +np |U64 |my_htobe64 |U64 n +#endif +#ifdef PERL_NEED_MY_BETOH64 +np |U64 |my_betoh64 |U64 n +#endif + +#ifdef PERL_NEED_MY_HTOLES +np |short |my_htoles |short n +#endif +#ifdef PERL_NEED_MY_LETOHS +np |short |my_letohs |short n +#endif +#ifdef PERL_NEED_MY_HTOBES +np |short |my_htobes |short n +#endif +#ifdef PERL_NEED_MY_BETOHS +np |short |my_betohs |short n +#endif +#ifdef PERL_NEED_MY_HTOLEI +np |int |my_htolei |int n +#endif +#ifdef PERL_NEED_MY_LETOHI +np |int |my_letohi |int n +#endif +#ifdef PERL_NEED_MY_HTOBEI +np |int |my_htobei |int n +#endif +#ifdef PERL_NEED_MY_BETOHI +np |int |my_betohi |int n +#endif +#ifdef PERL_NEED_MY_HTOLEL +np |long |my_htolel |long n +#endif +#ifdef PERL_NEED_MY_LETOHL +np |long |my_letohl |long n +#endif +#ifdef PERL_NEED_MY_HTOBEL +np |long |my_htobel |long n +#endif +#ifdef PERL_NEED_MY_BETOHL +np |long |my_betohl |long n +#endif + +np |void |my_swabn |void* ptr|int n + +END_EXTERN_C diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/MY_CXT b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/MY_CXT new file mode 100644 index 00000000000..601ed14e96f --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/MY_CXT @@ -0,0 +1,192 @@ +################################################################################ +## +## $Revision: 1.1 $ +## $Author: millert $ +## $Date: 2005/01/15 21:16:46 $ +## +################################################################################ +## +## Version 3.x, Copyright (C) 2004, Marcus Holland-Moritz. +## Version 2.x, Copyright (C) 2001, Paul Marquess. +## Version 1.x, Copyright (C) 1999, Kenneth Albanowski. +## +## This program is free software; you can redistribute it and/or +## modify it under the same terms as Perl itself. +## +################################################################################ + +=provides + +START_MY_CXT +dMY_CXT_SV +dMY_CXT +MY_CXT_INIT +MY_CXT_CLONE +MY_CXT +pMY_CXT +pMY_CXT_ +_pMY_CXT +aMY_CXT +aMY_CXT_ +_aMY_CXT + +=implementation + +/* + * Boilerplate macros for initializing and accessing interpreter-local + * data from C. All statics in extensions should be reworked to use + * this, if you want to make the extension thread-safe. See ext/re/re.xs + * for an example of the use of these macros. + * + * Code that uses these macros is responsible for the following: + * 1. #define MY_CXT_KEY to a unique string, e.g. "DynaLoader_guts" + * 2. Declare a typedef named my_cxt_t that is a structure that contains + * all the data that needs to be interpreter-local. + * 3. Use the START_MY_CXT macro after the declaration of my_cxt_t. + * 4. Use the MY_CXT_INIT macro such that it is called exactly once + * (typically put in the BOOT: section). + * 5. Use the members of the my_cxt_t structure everywhere as + * MY_CXT.member. + * 6. Use the dMY_CXT macro (a declaration) in all the functions that + * access MY_CXT. + */ + +#if defined(MULTIPLICITY) || defined(PERL_OBJECT) || \ + defined(PERL_CAPI) || defined(PERL_IMPLICIT_CONTEXT) + +#ifndef START_MY_CXT + +/* This must appear in all extensions that define a my_cxt_t structure, + * right after the definition (i.e. at file scope). The non-threads + * case below uses it to declare the data as static. */ +#define START_MY_CXT + +#if (PERL_VERSION < 4 || (PERL_VERSION == 4 && PERL_SUBVERSION < 68 )) +/* Fetches the SV that keeps the per-interpreter data. */ +#define dMY_CXT_SV \ + SV *my_cxt_sv = get_sv(MY_CXT_KEY, FALSE) +#else /* >= perl5.004_68 */ +#define dMY_CXT_SV \ + SV *my_cxt_sv = *hv_fetch(PL_modglobal, MY_CXT_KEY, \ + sizeof(MY_CXT_KEY)-1, TRUE) +#endif /* < perl5.004_68 */ + +/* This declaration should be used within all functions that use the + * interpreter-local data. */ +#define dMY_CXT \ + dMY_CXT_SV; \ + my_cxt_t *my_cxtp = INT2PTR(my_cxt_t*,SvUV(my_cxt_sv)) + +/* Creates and zeroes the per-interpreter data. + * (We allocate my_cxtp in a Perl SV so that it will be released when + * the interpreter goes away.) */ +#define MY_CXT_INIT \ + dMY_CXT_SV; \ + /* newSV() allocates one more than needed */ \ + my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\ + Zero(my_cxtp, 1, my_cxt_t); \ + sv_setuv(my_cxt_sv, PTR2UV(my_cxtp)) + +/* This macro must be used to access members of the my_cxt_t structure. + * e.g. MYCXT.some_data */ +#define MY_CXT (*my_cxtp) + +/* Judicious use of these macros can reduce the number of times dMY_CXT + * is used. Use is similar to pTHX, aTHX etc. */ +#define pMY_CXT my_cxt_t *my_cxtp +#define pMY_CXT_ pMY_CXT, +#define _pMY_CXT ,pMY_CXT +#define aMY_CXT my_cxtp +#define aMY_CXT_ aMY_CXT, +#define _aMY_CXT ,aMY_CXT + +#endif /* START_MY_CXT */ + +#ifndef MY_CXT_CLONE +/* Clones the per-interpreter data. */ +#define MY_CXT_CLONE \ + dMY_CXT_SV; \ + my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\ + Copy(INT2PTR(my_cxt_t*, SvUV(my_cxt_sv)), my_cxtp, 1, my_cxt_t);\ + sv_setuv(my_cxt_sv, PTR2UV(my_cxtp)) +#endif + +#else /* single interpreter */ + +#ifndef START_MY_CXT + +#define START_MY_CXT static my_cxt_t my_cxt; +#define dMY_CXT_SV dNOOP +#define dMY_CXT dNOOP +#define MY_CXT_INIT NOOP +#define MY_CXT my_cxt + +#define pMY_CXT void +#define pMY_CXT_ +#define _pMY_CXT +#define aMY_CXT +#define aMY_CXT_ +#define _aMY_CXT + +#endif /* START_MY_CXT */ + +#ifndef MY_CXT_CLONE +#define MY_CXT_CLONE NOOP +#endif + +#endif + +=xsmisc + +#define MY_CXT_KEY "Devel::PPPort::_guts" XS_VERSION + +typedef struct { + /* Put Global Data in here */ + int dummy; +} my_cxt_t; + +START_MY_CXT + +=xsboot + +{ + MY_CXT_INIT; + /* If any of the fields in the my_cxt_t struct need + * to be initialised, do it here. + */ + MY_CXT.dummy = 42; +} + +=xsubs + +int +MY_CXT_1() + CODE: + dMY_CXT; + RETVAL = MY_CXT.dummy == 42; + ++MY_CXT.dummy; + OUTPUT: + RETVAL + +int +MY_CXT_2() + CODE: + dMY_CXT; + RETVAL = MY_CXT.dummy == 43; + OUTPUT: + RETVAL + +int +MY_CXT_CLONE() + CODE: + MY_CXT_CLONE; + RETVAL = 42; + OUTPUT: + RETVAL + +=tests plan => 3 + +ok(&Devel::PPPort::MY_CXT_1()); +ok(&Devel::PPPort::MY_CXT_2()); +ok(&Devel::PPPort::MY_CXT_CLONE()); + diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/SvPV b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/SvPV new file mode 100644 index 00000000000..711955f67f3 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/SvPV @@ -0,0 +1,140 @@ +################################################################################ +## +## $Revision: 1.1 $ +## $Author: millert $ +## $Date: 2005/01/15 21:16:46 $ +## +################################################################################ +## +## Version 3.x, Copyright (C) 2004, Marcus Holland-Moritz. +## Version 2.x, Copyright (C) 2001, Paul Marquess. +## Version 1.x, Copyright (C) 1999, Kenneth Albanowski. +## +## This program is free software; you can redistribute it and/or +## modify it under the same terms as Perl itself. +## +################################################################################ + +=provides + +SvPV_nolen +sv_2pv_nolen +SvPVbyte +sv_2pvbyte +sv_pvn +sv_pvn_force + +=implementation + +#ifndef SvPV_nolen + +#if { NEED sv_2pv_nolen } + +char * +sv_2pv_nolen(pTHX_ register SV *sv) +{ + STRLEN n_a; + return sv_2pv(sv, &n_a); +} + +#endif + +/* Hint: sv_2pv_nolen + * Use the SvPV_nolen() macro instead of sv_2pv_nolen(). + */ + +/* SvPV_nolen depends on sv_2pv_nolen */ +#define SvPV_nolen(sv) \ + ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ + ? SvPVX(sv) : sv_2pv_nolen(sv)) + +#endif + +#ifdef SvPVbyte + +/* Hint: SvPVbyte + * Does not work in perl-5.6.1, ppport.h implements a version + * borrowed from perl-5.7.3. + */ + +#if { VERSION < 5.7.0 } + +#if { NEED sv_2pvbyte } + +char * +sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp) +{ + sv_utf8_downgrade(sv,0); + return SvPV(sv,*lp); +} + +#endif + +/* Hint: sv_2pvbyte + * Use the SvPVbyte() macro instead of sv_2pvbyte(). + */ + +#undef SvPVbyte + +/* SvPVbyte depends on sv_2pvbyte */ +#define SvPVbyte(sv, lp) \ + ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8)) == (SVf_POK) \ + ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pvbyte(sv, &lp)) + +#endif + +#else + +# define SvPVbyte SvPV +# define sv_2pvbyte sv_2pv + +#endif + +/* sv_2pvbyte_nolen depends on sv_2pv_nolen */ +__UNDEFINED__ sv_2pvbyte_nolen sv_2pv_nolen + +/* Hint: sv_pvn + * Always use the SvPV() macro instead of sv_pvn(). + */ +__UNDEFINED__ sv_pvn(sv, len) SvPV(sv, len) + +/* Hint: sv_pvn + * Always use the SvPV_force() macro instead of sv_pvn_force(). + */ +__UNDEFINED__ sv_pvn_force(sv, len) SvPV_force(sv, len) + +=xsinit + +#define NEED_sv_2pv_nolen +#define NEED_sv_2pvbyte + +=xsubs + +IV +SvPVbyte(sv) + SV *sv + PREINIT: + STRLEN len; + const char *str; + CODE: + str = SvPVbyte(sv, len); + RETVAL = strEQ(str, "mhx") ? len : -1; + OUTPUT: + RETVAL + +IV +SvPV_nolen(sv) + SV *sv + PREINIT: + const char *str; + CODE: + str = SvPV_nolen(sv); + RETVAL = strEQ(str, "mhx") ? 3 : 0; + OUTPUT: + RETVAL + +=tests plan => 2 + +ok(&Devel::PPPort::SvPVbyte("mhx"), 3); +ok(&Devel::PPPort::SvPVbyte("mhx"), 3); + diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/call b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/call new file mode 100644 index 00000000000..2ff01353d6a --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/call @@ -0,0 +1,239 @@ +################################################################################ +## +## $Revision: 1.1 $ +## $Author: millert $ +## $Date: 2005/01/15 21:16:45 $ +## +################################################################################ +## +## Version 3.x, Copyright (C) 2004, Marcus Holland-Moritz. +## Version 2.x, Copyright (C) 2001, Paul Marquess. +## Version 1.x, Copyright (C) 1999, Kenneth Albanowski. +## +## This program is free software; you can redistribute it and/or +## modify it under the same terms as Perl itself. +## +################################################################################ + +=provides + +eval_pv +eval_sv +call_sv +call_pv +call_argv +call_method + +=implementation + +/* Replace: 1 */ +__UNDEFINED__ call_sv perl_call_sv +__UNDEFINED__ call_pv perl_call_pv +__UNDEFINED__ call_argv perl_call_argv +__UNDEFINED__ call_method perl_call_method + +__UNDEFINED__ eval_sv perl_eval_sv +/* Replace: 0 */ + +/* Replace perl_eval_pv with eval_pv */ +/* eval_pv depends on eval_sv */ + +#ifndef eval_pv +#if { NEED eval_pv } + +SV* +eval_pv(char *p, I32 croak_on_error) +{ + dSP; + SV* sv = newSVpv(p, 0); + + PUSHMARK(sp); + eval_sv(sv, G_SCALAR); + SvREFCNT_dec(sv); + + SPAGAIN; + sv = POPs; + PUTBACK; + + if (croak_on_error && SvTRUE(GvSV(errgv))) + croak(SvPVx(GvSV(errgv), na)); + + return sv; +} + +#endif +#endif + +=xsinit + +#define NEED_eval_pv + +=xsubs + +I32 +G_SCALAR() + CODE: + RETVAL = G_SCALAR; + OUTPUT: + RETVAL + +I32 +G_ARRAY() + CODE: + RETVAL = G_ARRAY; + OUTPUT: + RETVAL + +I32 +G_DISCARD() + CODE: + RETVAL = G_DISCARD; + OUTPUT: + RETVAL + +void +eval_sv(sv, flags) + SV* sv + I32 flags + PREINIT: + I32 i; + PPCODE: + PUTBACK; + i = eval_sv(sv, flags); + SPAGAIN; + EXTEND(SP, 1); + PUSHs(sv_2mortal(newSViv(i))); + +void +eval_pv(p, croak_on_error) + char* p + I32 croak_on_error + PPCODE: + PUTBACK; + EXTEND(SP, 1); + PUSHs(eval_pv(p, croak_on_error)); + +void +call_sv(sv, flags, ...) + SV* sv + I32 flags + PREINIT: + I32 i; + PPCODE: + for (i=0; i<items-2; i++) + ST(i) = ST(i+2); /* pop first two args */ + PUSHMARK(SP); + SP += items - 2; + PUTBACK; + i = call_sv(sv, flags); + SPAGAIN; + EXTEND(SP, 1); + PUSHs(sv_2mortal(newSViv(i))); + +void +call_pv(subname, flags, ...) + char* subname + I32 flags + PREINIT: + I32 i; + PPCODE: + for (i=0; i<items-2; i++) + ST(i) = ST(i+2); /* pop first two args */ + PUSHMARK(SP); + SP += items - 2; + PUTBACK; + i = call_pv(subname, flags); + SPAGAIN; + EXTEND(SP, 1); + PUSHs(sv_2mortal(newSViv(i))); + +void +call_argv(subname, flags, ...) + char* subname + I32 flags + PREINIT: + I32 i; + char *args[8]; + PPCODE: + if (items > 8) /* play safe */ + XSRETURN_UNDEF; + for (i=2; i<items; i++) + args[i-2] = SvPV_nolen(ST(i)); + args[items-2] = NULL; + PUTBACK; + i = call_argv(subname, flags, args); + SPAGAIN; + EXTEND(SP, 1); + PUSHs(sv_2mortal(newSViv(i))); + +void +call_method(methname, flags, ...) + char* methname + I32 flags + PREINIT: + I32 i; + PPCODE: + for (i=0; i<items-2; i++) + ST(i) = ST(i+2); /* pop first two args */ + PUSHMARK(SP); + SP += items - 2; + PUTBACK; + i = call_method(methname, flags); + SPAGAIN; + EXTEND(SP, 1); + PUSHs(sv_2mortal(newSViv(i))); + +=tests plan => 44 + +sub eq_array +{ + my($a, $b) = @_; + join(':', @$a) eq join(':', @$b); +} + +sub f +{ + shift; + unshift @_, 'b'; + pop @_; + @_, defined wantarray ? wantarray ? 'x' : 'y' : 'z'; +} + +my $obj = bless [], 'Foo'; + +sub Foo::meth +{ + return 'bad_self' unless @_ && ref $_[0] && ref($_[0]) eq 'Foo'; + shift; + shift; + unshift @_, 'b'; + pop @_; + @_, defined wantarray ? wantarray ? 'x' : 'y' : 'z'; +} + +my $test; + +for $test ( + # flags args expected description + [ &Devel::PPPort::G_SCALAR, [ ], [ qw(y 1) ], '0 args, G_SCALAR' ], + [ &Devel::PPPort::G_SCALAR, [ qw(a p q) ], [ qw(y 1) ], '3 args, G_SCALAR' ], + [ &Devel::PPPort::G_ARRAY, [ ], [ qw(x 1) ], '0 args, G_ARRAY' ], + [ &Devel::PPPort::G_ARRAY, [ qw(a p q) ], [ qw(b p x 3) ], '3 args, G_ARRAY' ], + [ &Devel::PPPort::G_DISCARD, [ ], [ qw(0) ], '0 args, G_DISCARD' ], + [ &Devel::PPPort::G_DISCARD, [ qw(a p q) ], [ qw(0) ], '3 args, G_DISCARD' ], +) +{ + my ($flags, $args, $expected, $description) = @$test; + print "# --- $description ---\n"; + ok(eq_array( [ &Devel::PPPort::call_sv(\&f, $flags, @$args) ], $expected)); + ok(eq_array( [ &Devel::PPPort::call_sv(*f, $flags, @$args) ], $expected)); + ok(eq_array( [ &Devel::PPPort::call_sv('f', $flags, @$args) ], $expected)); + ok(eq_array( [ &Devel::PPPort::call_pv('f', $flags, @$args) ], $expected)); + ok(eq_array( [ &Devel::PPPort::call_argv('f', $flags, @$args) ], $expected)); + ok(eq_array( [ &Devel::PPPort::eval_sv("f(qw(@$args))", $flags) ], $expected)); + ok(eq_array( [ &Devel::PPPort::call_method('meth', $flags, $obj, @$args) ], $expected)); +}; + +ok(&Devel::PPPort::eval_pv('f()', 0), 'y'); +ok(&Devel::PPPort::eval_pv('f(qw(a b c))', 0), 'y'); + diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/cop b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/cop new file mode 100644 index 00000000000..fef50dbc41c --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/cop @@ -0,0 +1,84 @@ +################################################################################ +## +## $Revision: 1.1 $ +## $Author: millert $ +## $Date: 2005/01/15 21:16:45 $ +## +################################################################################ +## +## Version 3.x, Copyright (C) 2004, Marcus Holland-Moritz. +## Version 2.x, Copyright (C) 2001, Paul Marquess. +## Version 1.x, Copyright (C) 1999, Kenneth Albanowski. +## +## This program is free software; you can redistribute it and/or +## modify it under the same terms as Perl itself. +## +################################################################################ + +=provides + +__UNDEFINED__ + +=implementation + +#ifdef USE_ITHREADS + +__UNDEFINED__ CopFILE(c) ((c)->cop_file) +__UNDEFINED__ CopFILEGV(c) (CopFILE(c) ? gv_fetchfile(CopFILE(c)) : Nullgv) +__UNDEFINED__ CopFILE_set(c,pv) ((c)->cop_file = savepv(pv)) +__UNDEFINED__ CopFILESV(c) (CopFILE(c) ? GvSV(gv_fetchfile(CopFILE(c))) : Nullsv) +__UNDEFINED__ CopFILEAV(c) (CopFILE(c) ? GvAV(gv_fetchfile(CopFILE(c))) : Nullav) +__UNDEFINED__ CopSTASHPV(c) ((c)->cop_stashpv) +__UNDEFINED__ CopSTASHPV_set(c,pv) ((c)->cop_stashpv = ((pv) ? savepv(pv) : Nullch)) +__UNDEFINED__ CopSTASH(c) (CopSTASHPV(c) ? gv_stashpv(CopSTASHPV(c),GV_ADD) : Nullhv) +__UNDEFINED__ CopSTASH_set(c,hv) CopSTASHPV_set(c, (hv) ? HvNAME(hv) : Nullch) +__UNDEFINED__ CopSTASH_eq(c,hv) ((hv) && (CopSTASHPV(c) == HvNAME(hv) \ + || (CopSTASHPV(c) && HvNAME(hv) \ + && strEQ(CopSTASHPV(c), HvNAME(hv))))) + +#else + +__UNDEFINED__ CopFILEGV(c) ((c)->cop_filegv) +__UNDEFINED__ CopFILEGV_set(c,gv) ((c)->cop_filegv = (GV*)SvREFCNT_inc(gv)) +__UNDEFINED__ CopFILE_set(c,pv) CopFILEGV_set((c), gv_fetchfile(pv)) +__UNDEFINED__ CopFILESV(c) (CopFILEGV(c) ? GvSV(CopFILEGV(c)) : Nullsv) +__UNDEFINED__ CopFILEAV(c) (CopFILEGV(c) ? GvAV(CopFILEGV(c)) : Nullav) +__UNDEFINED__ CopFILE(c) (CopFILESV(c) ? SvPVX(CopFILESV(c)) : Nullch) +__UNDEFINED__ CopSTASH(c) ((c)->cop_stash) +__UNDEFINED__ CopSTASH_set(c,hv) ((c)->cop_stash = (hv)) +__UNDEFINED__ CopSTASHPV(c) (CopSTASH(c) ? HvNAME(CopSTASH(c)) : Nullch) +__UNDEFINED__ CopSTASHPV_set(c,pv) CopSTASH_set((c), gv_stashpv(pv,GV_ADD)) +__UNDEFINED__ CopSTASH_eq(c,hv) (CopSTASH(c) == (hv)) + +#endif /* USE_ITHREADS */ + +=xsubs + +char * +CopSTASHPV() + CODE: + RETVAL = CopSTASHPV(PL_curcop); + OUTPUT: + RETVAL + +char * +CopFILE() + CODE: + RETVAL = CopFILE(PL_curcop); + OUTPUT: + RETVAL + +=tests plan => 2 + +my $package; +{ + package MyPackage; + $package = &Devel::PPPort::CopSTASHPV(); +} +print "# $package\n"; +ok($package, "MyPackage"); + +my $file = &Devel::PPPort::CopFILE(); +print "# $file\n"; +ok($file =~ /cop/i); + diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/format b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/format new file mode 100644 index 00000000000..e6f52a87131 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/format @@ -0,0 +1,54 @@ +################################################################################ +## +## $Revision: 1.1 $ +## $Author: millert $ +## $Date: 2005/01/15 21:16:45 $ +## +################################################################################ +## +## Version 3.x, Copyright (C) 2004, Marcus Holland-Moritz. +## Version 2.x, Copyright (C) 2001, Paul Marquess. +## Version 1.x, Copyright (C) 1999, Kenneth Albanowski. +## +## This program is free software; you can redistribute it and/or +## modify it under the same terms as Perl itself. +## +################################################################################ + +=provides + +/^#\s*define\s+(\w+)/ + +=implementation + +#ifndef IVdf +# if IVSIZE == LONGSIZE +# define IVdf "ld" +# define UVuf "lu" +# define UVof "lo" +# define UVxf "lx" +# define UVXf "lX" +# else +# if IVSIZE == INTSIZE +# define IVdf "d" +# define UVuf "u" +# define UVof "o" +# define UVxf "x" +# define UVXf "X" +# endif +# endif +#endif + +#ifndef NVef +# if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE) && \ + defined(PERL_PRIfldbl) /* Not very likely, but let's try anyway. */ +# define NVef PERL_PRIeldbl +# define NVff PERL_PRIfldbl +# define NVgf PERL_PRIgldbl +# else +# define NVef "e" +# define NVff "f" +# define NVgf "g" +# endif +#endif + diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/grok b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/grok new file mode 100644 index 00000000000..07850cf1202 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/grok @@ -0,0 +1,680 @@ +################################################################################ +## +## $Revision: 1.1 $ +## $Author: millert $ +## $Date: 2005/01/15 21:16:46 $ +## +################################################################################ +## +## Version 3.x, Copyright (C) 2004, Marcus Holland-Moritz. +## Version 2.x, Copyright (C) 2001, Paul Marquess. +## Version 1.x, Copyright (C) 1999, Kenneth Albanowski. +## +## This program is free software; you can redistribute it and/or +## modify it under the same terms as Perl itself. +## +################################################################################ + +=provides + +grok_hex +grok_oct +grok_bin +grok_numeric_radix +grok_number +__UNDEFINED__ + +=implementation + +__UNDEFINED__ IN_PERL_COMPILETIME (PL_curcop == &PL_compiling) +__UNDEFINED__ IN_LOCALE_RUNTIME (PL_curcop->op_private & HINT_LOCALE) +__UNDEFINED__ IN_LOCALE_COMPILETIME (PL_hints & HINT_LOCALE) +__UNDEFINED__ IN_LOCALE (IN_PERL_COMPILETIME ? IN_LOCALE_COMPILETIME : IN_LOCALE_RUNTIME) + +__UNDEFINED__ IS_NUMBER_IN_UV 0x01 +__UNDEFINED__ IS_NUMBER_GREATER_THAN_UV_MAX 0x02 +__UNDEFINED__ IS_NUMBER_NOT_INT 0x04 +__UNDEFINED__ IS_NUMBER_NEG 0x08 +__UNDEFINED__ IS_NUMBER_INFINITY 0x10 +__UNDEFINED__ IS_NUMBER_NAN 0x20 + +/* GROK_NUMERIC_RADIX depends on grok_numeric_radix */ +__UNDEFINED__ GROK_NUMERIC_RADIX(sp, send) grok_numeric_radix(sp, send) + +__UNDEFINED__ PERL_SCAN_GREATER_THAN_UV_MAX 0x02 +__UNDEFINED__ PERL_SCAN_SILENT_ILLDIGIT 0x04 +__UNDEFINED__ PERL_SCAN_ALLOW_UNDERSCORES 0x01 +__UNDEFINED__ PERL_SCAN_DISALLOW_PREFIX 0x02 + +#ifndef grok_numeric_radix +#if { NEED grok_numeric_radix } +bool +grok_numeric_radix(pTHX_ const char **sp, const char *send) +{ +#ifdef USE_LOCALE_NUMERIC +#ifdef PL_numeric_radix_sv + if (PL_numeric_radix_sv && IN_LOCALE) { + STRLEN len; + char* radix = SvPV(PL_numeric_radix_sv, len); + if (*sp + len <= send && memEQ(*sp, radix, len)) { + *sp += len; + return TRUE; + } + } +#else + /* older perls don't have PL_numeric_radix_sv so the radix + * must manually be requested from locale.h + */ +#include <locale.h> + dTHR; /* needed for older threaded perls */ + struct lconv *lc = localeconv(); + char *radix = lc->decimal_point; + if (radix && IN_LOCALE) { + STRLEN len = strlen(radix); + if (*sp + len <= send && memEQ(*sp, radix, len)) { + *sp += len; + return TRUE; + } + } +#endif /* PERL_VERSION */ +#endif /* USE_LOCALE_NUMERIC */ + /* always try "." if numeric radix didn't match because + * we may have data from different locales mixed */ + if (*sp < send && **sp == '.') { + ++*sp; + return TRUE; + } + return FALSE; +} +#endif +#endif + +/* grok_number depends on grok_numeric_radix */ + +#ifndef grok_number +#if { NEED grok_number } +int +grok_number(pTHX_ const char *pv, STRLEN len, UV *valuep) +{ + const char *s = pv; + const char *send = pv + len; + const UV max_div_10 = UV_MAX / 10; + const char max_mod_10 = UV_MAX % 10; + int numtype = 0; + int sawinf = 0; + int sawnan = 0; + + while (s < send && isSPACE(*s)) + s++; + if (s == send) { + return 0; + } else if (*s == '-') { + s++; + numtype = IS_NUMBER_NEG; + } + else if (*s == '+') + s++; + + if (s == send) + return 0; + + /* next must be digit or the radix separator or beginning of infinity */ + if (isDIGIT(*s)) { + /* UVs are at least 32 bits, so the first 9 decimal digits cannot + overflow. */ + UV value = *s - '0'; + /* This construction seems to be more optimiser friendly. + (without it gcc does the isDIGIT test and the *s - '0' separately) + With it gcc on arm is managing 6 instructions (6 cycles) per digit. + In theory the optimiser could deduce how far to unroll the loop + before checking for overflow. */ + if (++s < send) { + int digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + /* Now got 9 digits, so need to check + each time for overflow. */ + digit = *s - '0'; + while (digit >= 0 && digit <= 9 + && (value < max_div_10 + || (value == max_div_10 + && digit <= max_mod_10))) { + value = value * 10 + digit; + if (++s < send) + digit = *s - '0'; + else + break; + } + if (digit >= 0 && digit <= 9 + && (s < send)) { + /* value overflowed. + skip the remaining digits, don't + worry about setting *valuep. */ + do { + s++; + } while (s < send && isDIGIT(*s)); + numtype |= + IS_NUMBER_GREATER_THAN_UV_MAX; + goto skip_value; + } + } + } + } + } + } + } + } + } + } + } + } + } + } + } + } + } + } + numtype |= IS_NUMBER_IN_UV; + if (valuep) + *valuep = value; + + skip_value: + if (GROK_NUMERIC_RADIX(&s, send)) { + numtype |= IS_NUMBER_NOT_INT; + while (s < send && isDIGIT(*s)) /* optional digits after the radix */ + s++; + } + } + else if (GROK_NUMERIC_RADIX(&s, send)) { + numtype |= IS_NUMBER_NOT_INT | IS_NUMBER_IN_UV; /* valuep assigned below */ + /* no digits before the radix means we need digits after it */ + if (s < send && isDIGIT(*s)) { + do { + s++; + } while (s < send && isDIGIT(*s)); + if (valuep) { + /* integer approximation is valid - it's 0. */ + *valuep = 0; + } + } + else + return 0; + } else if (*s == 'I' || *s == 'i') { + s++; if (s == send || (*s != 'N' && *s != 'n')) return 0; + s++; if (s == send || (*s != 'F' && *s != 'f')) return 0; + s++; if (s < send && (*s == 'I' || *s == 'i')) { + s++; if (s == send || (*s != 'N' && *s != 'n')) return 0; + s++; if (s == send || (*s != 'I' && *s != 'i')) return 0; + s++; if (s == send || (*s != 'T' && *s != 't')) return 0; + s++; if (s == send || (*s != 'Y' && *s != 'y')) return 0; + s++; + } + sawinf = 1; + } else if (*s == 'N' || *s == 'n') { + /* XXX TODO: There are signaling NaNs and quiet NaNs. */ + s++; if (s == send || (*s != 'A' && *s != 'a')) return 0; + s++; if (s == send || (*s != 'N' && *s != 'n')) return 0; + s++; + sawnan = 1; + } else + return 0; + + if (sawinf) { + numtype &= IS_NUMBER_NEG; /* Keep track of sign */ + numtype |= IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT; + } else if (sawnan) { + numtype &= IS_NUMBER_NEG; /* Keep track of sign */ + numtype |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT; + } else if (s < send) { + /* we can have an optional exponent part */ + if (*s == 'e' || *s == 'E') { + /* The only flag we keep is sign. Blow away any "it's UV" */ + numtype &= IS_NUMBER_NEG; + numtype |= IS_NUMBER_NOT_INT; + s++; + if (s < send && (*s == '-' || *s == '+')) + s++; + if (s < send && isDIGIT(*s)) { + do { + s++; + } while (s < send && isDIGIT(*s)); + } + else + return 0; + } + } + while (s < send && isSPACE(*s)) + s++; + if (s >= send) + return numtype; + if (len == 10 && memEQ(pv, "0 but true", 10)) { + if (valuep) + *valuep = 0; + return IS_NUMBER_IN_UV; + } + return 0; +} +#endif +#endif + +/* + * The grok_* routines have been modified to use warn() instead of + * Perl_warner(). Also, 'hexdigit' was the former name of PL_hexdigit, + * which is why the stack variable has been renamed to 'xdigit'. + */ + +#ifndef grok_bin +#if { NEED grok_bin } +UV +grok_bin(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result) +{ + const char *s = start; + STRLEN len = *len_p; + UV value = 0; + NV value_nv = 0; + + const UV max_div_2 = UV_MAX / 2; + bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES; + bool overflowed = FALSE; + + if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) { + /* strip off leading b or 0b. + for compatibility silently suffer "b" and "0b" as valid binary + numbers. */ + if (len >= 1) { + if (s[0] == 'b') { + s++; + len--; + } + else if (len >= 2 && s[0] == '0' && s[1] == 'b') { + s+=2; + len-=2; + } + } + } + + for (; len-- && *s; s++) { + char bit = *s; + if (bit == '0' || bit == '1') { + /* Write it in this wonky order with a goto to attempt to get the + compiler to make the common case integer-only loop pretty tight. + With gcc seems to be much straighter code than old scan_bin. */ + redo: + if (!overflowed) { + if (value <= max_div_2) { + value = (value << 1) | (bit - '0'); + continue; + } + /* Bah. We're just overflowed. */ + warn("Integer overflow in binary number"); + overflowed = TRUE; + value_nv = (NV) value; + } + value_nv *= 2.0; + /* If an NV has not enough bits in its mantissa to + * represent a UV this summing of small low-order numbers + * is a waste of time (because the NV cannot preserve + * the low-order bits anyway): we could just remember when + * did we overflow and in the end just multiply value_nv by the + * right amount. */ + value_nv += (NV)(bit - '0'); + continue; + } + if (bit == '_' && len && allow_underscores && (bit = s[1]) + && (bit == '0' || bit == '1')) + { + --len; + ++s; + goto redo; + } + if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT)) + warn("Illegal binary digit '%c' ignored", *s); + break; + } + + if ( ( overflowed && value_nv > 4294967295.0) +#if UVSIZE > 4 + || (!overflowed && value > 0xffffffff ) +#endif + ) { + warn("Binary number > 0b11111111111111111111111111111111 non-portable"); + } + *len_p = s - start; + if (!overflowed) { + *flags = 0; + return value; + } + *flags = PERL_SCAN_GREATER_THAN_UV_MAX; + if (result) + *result = value_nv; + return UV_MAX; +} +#endif +#endif + +#ifndef grok_hex +#if { NEED grok_hex } +UV +grok_hex(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result) +{ + const char *s = start; + STRLEN len = *len_p; + UV value = 0; + NV value_nv = 0; + + const UV max_div_16 = UV_MAX / 16; + bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES; + bool overflowed = FALSE; + const char *xdigit; + + if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) { + /* strip off leading x or 0x. + for compatibility silently suffer "x" and "0x" as valid hex numbers. + */ + if (len >= 1) { + if (s[0] == 'x') { + s++; + len--; + } + else if (len >= 2 && s[0] == '0' && s[1] == 'x') { + s+=2; + len-=2; + } + } + } + + for (; len-- && *s; s++) { + xdigit = strchr((char *) PL_hexdigit, *s); + if (xdigit) { + /* Write it in this wonky order with a goto to attempt to get the + compiler to make the common case integer-only loop pretty tight. + With gcc seems to be much straighter code than old scan_hex. */ + redo: + if (!overflowed) { + if (value <= max_div_16) { + value = (value << 4) | ((xdigit - PL_hexdigit) & 15); + continue; + } + warn("Integer overflow in hexadecimal number"); + overflowed = TRUE; + value_nv = (NV) value; + } + value_nv *= 16.0; + /* If an NV has not enough bits in its mantissa to + * represent a UV this summing of small low-order numbers + * is a waste of time (because the NV cannot preserve + * the low-order bits anyway): we could just remember when + * did we overflow and in the end just multiply value_nv by the + * right amount of 16-tuples. */ + value_nv += (NV)((xdigit - PL_hexdigit) & 15); + continue; + } + if (*s == '_' && len && allow_underscores && s[1] + && (xdigit = strchr((char *) PL_hexdigit, s[1]))) + { + --len; + ++s; + goto redo; + } + if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT)) + warn("Illegal hexadecimal digit '%c' ignored", *s); + break; + } + + if ( ( overflowed && value_nv > 4294967295.0) +#if UVSIZE > 4 + || (!overflowed && value > 0xffffffff ) +#endif + ) { + warn("Hexadecimal number > 0xffffffff non-portable"); + } + *len_p = s - start; + if (!overflowed) { + *flags = 0; + return value; + } + *flags = PERL_SCAN_GREATER_THAN_UV_MAX; + if (result) + *result = value_nv; + return UV_MAX; +} +#endif +#endif + +#ifndef grok_oct +#if { NEED grok_oct } +UV +grok_oct(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result) +{ + const char *s = start; + STRLEN len = *len_p; + UV value = 0; + NV value_nv = 0; + + const UV max_div_8 = UV_MAX / 8; + bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES; + bool overflowed = FALSE; + + for (; len-- && *s; s++) { + /* gcc 2.95 optimiser not smart enough to figure that this subtraction + out front allows slicker code. */ + int digit = *s - '0'; + if (digit >= 0 && digit <= 7) { + /* Write it in this wonky order with a goto to attempt to get the + compiler to make the common case integer-only loop pretty tight. + */ + redo: + if (!overflowed) { + if (value <= max_div_8) { + value = (value << 3) | digit; + continue; + } + /* Bah. We're just overflowed. */ + warn("Integer overflow in octal number"); + overflowed = TRUE; + value_nv = (NV) value; + } + value_nv *= 8.0; + /* If an NV has not enough bits in its mantissa to + * represent a UV this summing of small low-order numbers + * is a waste of time (because the NV cannot preserve + * the low-order bits anyway): we could just remember when + * did we overflow and in the end just multiply value_nv by the + * right amount of 8-tuples. */ + value_nv += (NV)digit; + continue; + } + if (digit == ('_' - '0') && len && allow_underscores + && (digit = s[1] - '0') && (digit >= 0 && digit <= 7)) + { + --len; + ++s; + goto redo; + } + /* Allow \octal to work the DWIM way (that is, stop scanning + * as soon as non-octal characters are seen, complain only iff + * someone seems to want to use the digits eight and nine). */ + if (digit == 8 || digit == 9) { + if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT)) + warn("Illegal octal digit '%c' ignored", *s); + } + break; + } + + if ( ( overflowed && value_nv > 4294967295.0) +#if UVSIZE > 4 + || (!overflowed && value > 0xffffffff ) +#endif + ) { + warn("Octal number > 037777777777 non-portable"); + } + *len_p = s - start; + if (!overflowed) { + *flags = 0; + return value; + } + *flags = PERL_SCAN_GREATER_THAN_UV_MAX; + if (result) + *result = value_nv; + return UV_MAX; +} +#endif +#endif + +=xsinit + +#define NEED_grok_number +#define NEED_grok_numeric_radix +#define NEED_grok_bin +#define NEED_grok_hex +#define NEED_grok_oct + +=xsubs + +UV +grok_number(string) + SV *string + PREINIT: + const char *pv; + STRLEN len; + CODE: + pv = SvPV(string, len); + if (!grok_number(pv, len, &RETVAL)) + XSRETURN_UNDEF; + OUTPUT: + RETVAL + +UV +grok_bin(string) + SV *string + PREINIT: + char *pv; + I32 flags; + STRLEN len; + CODE: + pv = SvPV(string, len); + RETVAL = grok_bin(pv, &len, &flags, NULL); + OUTPUT: + RETVAL + +UV +grok_hex(string) + SV *string + PREINIT: + char *pv; + I32 flags; + STRLEN len; + CODE: + pv = SvPV(string, len); + RETVAL = grok_hex(pv, &len, &flags, NULL); + OUTPUT: + RETVAL + +UV +grok_oct(string) + SV *string + PREINIT: + char *pv; + I32 flags; + STRLEN len; + CODE: + pv = SvPV(string, len); + RETVAL = grok_oct(pv, &len, &flags, NULL); + OUTPUT: + RETVAL + +UV +Perl_grok_number(string) + SV *string + PREINIT: + const char *pv; + STRLEN len; + CODE: + pv = SvPV(string, len); + if (!Perl_grok_number(aTHX_ pv, len, &RETVAL)) + XSRETURN_UNDEF; + OUTPUT: + RETVAL + +UV +Perl_grok_bin(string) + SV *string + PREINIT: + char *pv; + I32 flags; + STRLEN len; + CODE: + pv = SvPV(string, len); + RETVAL = Perl_grok_bin(aTHX_ pv, &len, &flags, NULL); + OUTPUT: + RETVAL + +UV +Perl_grok_hex(string) + SV *string + PREINIT: + char *pv; + I32 flags; + STRLEN len; + CODE: + pv = SvPV(string, len); + RETVAL = Perl_grok_hex(aTHX_ pv, &len, &flags, NULL); + OUTPUT: + RETVAL + +UV +Perl_grok_oct(string) + SV *string + PREINIT: + char *pv; + I32 flags; + STRLEN len; + CODE: + pv = SvPV(string, len); + RETVAL = Perl_grok_oct(aTHX_ pv, &len, &flags, NULL); + OUTPUT: + RETVAL + +=tests plan => 10 + +ok(&Devel::PPPort::grok_number("42"), 42); +ok(!defined(&Devel::PPPort::grok_number("A"))); +ok(&Devel::PPPort::grok_bin("10000001"), 129); +ok(&Devel::PPPort::grok_hex("deadbeef"), 0xdeadbeef); +ok(&Devel::PPPort::grok_oct("377"), 255); + +ok(&Devel::PPPort::Perl_grok_number("42"), 42); +ok(!defined(&Devel::PPPort::Perl_grok_number("A"))); +ok(&Devel::PPPort::Perl_grok_bin("10000001"), 129); +ok(&Devel::PPPort::Perl_grok_hex("deadbeef"), 0xdeadbeef); +ok(&Devel::PPPort::Perl_grok_oct("377"), 255); + diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/limits b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/limits new file mode 100644 index 00000000000..9fa7284d201 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/limits @@ -0,0 +1,331 @@ +################################################################################ +## +## $Revision: 1.1 $ +## $Author: millert $ +## $Date: 2005/01/15 21:16:46 $ +## +################################################################################ +## +## Version 3.x, Copyright (C) 2004, Marcus Holland-Moritz. +## Version 2.x, Copyright (C) 2001, Paul Marquess. +## Version 1.x, Copyright (C) 1999, Kenneth Albanowski. +## +## This program is free software; you can redistribute it and/or +## modify it under the same terms as Perl itself. +## +################################################################################ + +=provides + +PERL_UCHAR_MIN +PERL_UCHAR_MAX +PERL_USHORT_MIN +PERL_USHORT_MAX +PERL_SHORT_MAX +PERL_SHORT_MIN +PERL_UINT_MAX +PERL_UINT_MIN +PERL_INT_MAX +PERL_INT_MIN +PERL_ULONG_MAX +PERL_ULONG_MIN +PERL_LONG_MAX +PERL_LONG_MIN +PERL_UQUAD_MAX +PERL_UQUAD_MIN +PERL_QUAD_MAX +PERL_QUAD_MIN +IVSIZE +UVSIZE +IVTYPE +UVTYPE + +=implementation + +#ifdef I_LIMITS +# include <limits.h> +#endif + +#ifndef PERL_UCHAR_MIN +# define PERL_UCHAR_MIN ((unsigned char)0) +#endif + +#ifndef PERL_UCHAR_MAX +# ifdef UCHAR_MAX +# define PERL_UCHAR_MAX ((unsigned char)UCHAR_MAX) +# else +# ifdef MAXUCHAR +# define PERL_UCHAR_MAX ((unsigned char)MAXUCHAR) +# else +# define PERL_UCHAR_MAX ((unsigned char)~(unsigned)0) +# endif +# endif +#endif + +#ifndef PERL_USHORT_MIN +# define PERL_USHORT_MIN ((unsigned short)0) +#endif + +#ifndef PERL_USHORT_MAX +# ifdef USHORT_MAX +# define PERL_USHORT_MAX ((unsigned short)USHORT_MAX) +# else +# ifdef MAXUSHORT +# define PERL_USHORT_MAX ((unsigned short)MAXUSHORT) +# else +# ifdef USHRT_MAX +# define PERL_USHORT_MAX ((unsigned short)USHRT_MAX) +# else +# define PERL_USHORT_MAX ((unsigned short)~(unsigned)0) +# endif +# endif +# endif +#endif + +#ifndef PERL_SHORT_MAX +# ifdef SHORT_MAX +# define PERL_SHORT_MAX ((short)SHORT_MAX) +# else +# ifdef MAXSHORT /* Often used in <values.h> */ +# define PERL_SHORT_MAX ((short)MAXSHORT) +# else +# ifdef SHRT_MAX +# define PERL_SHORT_MAX ((short)SHRT_MAX) +# else +# define PERL_SHORT_MAX ((short) (PERL_USHORT_MAX >> 1)) +# endif +# endif +# endif +#endif + +#ifndef PERL_SHORT_MIN +# ifdef SHORT_MIN +# define PERL_SHORT_MIN ((short)SHORT_MIN) +# else +# ifdef MINSHORT +# define PERL_SHORT_MIN ((short)MINSHORT) +# else +# ifdef SHRT_MIN +# define PERL_SHORT_MIN ((short)SHRT_MIN) +# else +# define PERL_SHORT_MIN (-PERL_SHORT_MAX - ((3 & -1) == 3)) +# endif +# endif +# endif +#endif + +#ifndef PERL_UINT_MAX +# ifdef UINT_MAX +# define PERL_UINT_MAX ((unsigned int)UINT_MAX) +# else +# ifdef MAXUINT +# define PERL_UINT_MAX ((unsigned int)MAXUINT) +# else +# define PERL_UINT_MAX (~(unsigned int)0) +# endif +# endif +#endif + +#ifndef PERL_UINT_MIN +# define PERL_UINT_MIN ((unsigned int)0) +#endif + +#ifndef PERL_INT_MAX +# ifdef INT_MAX +# define PERL_INT_MAX ((int)INT_MAX) +# else +# ifdef MAXINT /* Often used in <values.h> */ +# define PERL_INT_MAX ((int)MAXINT) +# else +# define PERL_INT_MAX ((int)(PERL_UINT_MAX >> 1)) +# endif +# endif +#endif + +#ifndef PERL_INT_MIN +# ifdef INT_MIN +# define PERL_INT_MIN ((int)INT_MIN) +# else +# ifdef MININT +# define PERL_INT_MIN ((int)MININT) +# else +# define PERL_INT_MIN (-PERL_INT_MAX - ((3 & -1) == 3)) +# endif +# endif +#endif + +#ifndef PERL_ULONG_MAX +# ifdef ULONG_MAX +# define PERL_ULONG_MAX ((unsigned long)ULONG_MAX) +# else +# ifdef MAXULONG +# define PERL_ULONG_MAX ((unsigned long)MAXULONG) +# else +# define PERL_ULONG_MAX (~(unsigned long)0) +# endif +# endif +#endif + +#ifndef PERL_ULONG_MIN +# define PERL_ULONG_MIN ((unsigned long)0L) +#endif + +#ifndef PERL_LONG_MAX +# ifdef LONG_MAX +# define PERL_LONG_MAX ((long)LONG_MAX) +# else +# ifdef MAXLONG +# define PERL_LONG_MAX ((long)MAXLONG) +# else +# define PERL_LONG_MAX ((long) (PERL_ULONG_MAX >> 1)) +# endif +# endif +#endif + +#ifndef PERL_LONG_MIN +# ifdef LONG_MIN +# define PERL_LONG_MIN ((long)LONG_MIN) +# else +# ifdef MINLONG +# define PERL_LONG_MIN ((long)MINLONG) +# else +# define PERL_LONG_MIN (-PERL_LONG_MAX - ((3 & -1) == 3)) +# endif +# endif +#endif + +#if defined(HAS_QUAD) && (defined(convex) || defined(uts)) +# ifndef PERL_UQUAD_MAX +# ifdef ULONGLONG_MAX +# define PERL_UQUAD_MAX ((unsigned long long)ULONGLONG_MAX) +# else +# ifdef MAXULONGLONG +# define PERL_UQUAD_MAX ((unsigned long long)MAXULONGLONG) +# else +# define PERL_UQUAD_MAX (~(unsigned long long)0) +# endif +# endif +# endif + +# ifndef PERL_UQUAD_MIN +# define PERL_UQUAD_MIN ((unsigned long long)0L) +# endif + +# ifndef PERL_QUAD_MAX +# ifdef LONGLONG_MAX +# define PERL_QUAD_MAX ((long long)LONGLONG_MAX) +# else +# ifdef MAXLONGLONG +# define PERL_QUAD_MAX ((long long)MAXLONGLONG) +# else +# define PERL_QUAD_MAX ((long long) (PERL_UQUAD_MAX >> 1)) +# endif +# endif +# endif + +# ifndef PERL_QUAD_MIN +# ifdef LONGLONG_MIN +# define PERL_QUAD_MIN ((long long)LONGLONG_MIN) +# else +# ifdef MINLONGLONG +# define PERL_QUAD_MIN ((long long)MINLONGLONG) +# else +# define PERL_QUAD_MIN (-PERL_QUAD_MAX - ((3 & -1) == 3)) +# endif +# endif +# endif +#endif + +/* This is based on code from 5.003 perl.h */ +#ifdef HAS_QUAD +# ifdef cray + __UNDEFINED__ IVTYPE int + __UNDEFINED__ IV_MIN PERL_INT_MIN + __UNDEFINED__ IV_MAX PERL_INT_MAX + __UNDEFINED__ UV_MIN PERL_UINT_MIN + __UNDEFINED__ UV_MAX PERL_UINT_MAX +# ifdef INTSIZE + __UNDEFINED__ IVSIZE INTSIZE +# endif +# else +# if defined(convex) || defined(uts) + __UNDEFINED__ IVTYPE long long + __UNDEFINED__ IV_MIN PERL_QUAD_MIN + __UNDEFINED__ IV_MAX PERL_QUAD_MAX + __UNDEFINED__ UV_MIN PERL_UQUAD_MIN + __UNDEFINED__ UV_MAX PERL_UQUAD_MAX +# ifdef LONGLONGSIZE + __UNDEFINED__ IVSIZE LONGLONGSIZE +# endif +# else + __UNDEFINED__ IVTYPE long + __UNDEFINED__ IV_MIN PERL_LONG_MIN + __UNDEFINED__ IV_MAX PERL_LONG_MAX + __UNDEFINED__ UV_MIN PERL_ULONG_MIN + __UNDEFINED__ UV_MAX PERL_ULONG_MAX +# ifdef LONGSIZE + __UNDEFINED__ IVSIZE LONGSIZE +# endif +# endif +# endif + __UNDEFINED__ IVSIZE 8 + __UNDEFINED__ PERL_QUAD_MIN IV_MIN + __UNDEFINED__ PERL_QUAD_MAX IV_MAX + __UNDEFINED__ PERL_UQUAD_MIN UV_MIN + __UNDEFINED__ PERL_UQUAD_MAX UV_MAX +#else + __UNDEFINED__ IVTYPE long + __UNDEFINED__ IV_MIN PERL_LONG_MIN + __UNDEFINED__ IV_MAX PERL_LONG_MAX + __UNDEFINED__ UV_MIN PERL_ULONG_MIN + __UNDEFINED__ UV_MAX PERL_ULONG_MAX +#endif + +#ifndef IVSIZE +# ifdef LONGSIZE +# define IVSIZE LONGSIZE +# else +# define IVSIZE 4 /* A bold guess, but the best we can make. */ +# endif +#endif + +__UNDEFINED__ UVTYPE unsigned IVTYPE +__UNDEFINED__ UVSIZE IVSIZE + +=xsubs + +IV +iv_size() + CODE: + RETVAL = IVSIZE == sizeof(IV); + OUTPUT: + RETVAL + +IV +uv_size() + CODE: + RETVAL = UVSIZE == sizeof(UV); + OUTPUT: + RETVAL + +IV +iv_type() + CODE: + RETVAL = sizeof(IVTYPE) == sizeof(IV); + OUTPUT: + RETVAL + +IV +uv_type() + CODE: + RETVAL = sizeof(UVTYPE) == sizeof(UV); + OUTPUT: + RETVAL + +=tests plan => 4 + +ok(&Devel::PPPort::iv_size()); +ok(&Devel::PPPort::uv_size()); +ok(&Devel::PPPort::iv_type()); +ok(&Devel::PPPort::uv_type()); + diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/mPUSH b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/mPUSH new file mode 100644 index 00000000000..c36a260523a --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/mPUSH @@ -0,0 +1,117 @@ +################################################################################ +## +## $Revision: 1.1 $ +## $Author: millert $ +## $Date: 2005/01/15 21:16:46 $ +## +################################################################################ +## +## Version 3.x, Copyright (C) 2004, Marcus Holland-Moritz. +## Version 2.x, Copyright (C) 2001, Paul Marquess. +## Version 1.x, Copyright (C) 1999, Kenneth Albanowski. +## +## This program is free software; you can redistribute it and/or +## modify it under the same terms as Perl itself. +## +################################################################################ + +=provides + +__UNDEFINED__ + +=implementation + +__UNDEFINED__ PUSHmortal PUSHs(sv_newmortal()) +__UNDEFINED__ mPUSHp(p,l) sv_setpvn_mg(PUSHmortal, (p), (l)) +__UNDEFINED__ mPUSHn(n) sv_setnv_mg(PUSHmortal, (NV)(n)) +__UNDEFINED__ mPUSHi(i) sv_setiv_mg(PUSHmortal, (IV)(i)) +__UNDEFINED__ mPUSHu(u) sv_setuv_mg(PUSHmortal, (UV)(u)) + +__UNDEFINED__ XPUSHmortal XPUSHs(sv_newmortal()) +__UNDEFINED__ mXPUSHp(p,l) STMT_START { EXTEND(sp,1); sv_setpvn_mg(PUSHmortal, (p), (l)); } STMT_END +__UNDEFINED__ mXPUSHn(n) STMT_START { EXTEND(sp,1); sv_setnv_mg(PUSHmortal, (NV)(n)); } STMT_END +__UNDEFINED__ mXPUSHi(i) STMT_START { EXTEND(sp,1); sv_setiv_mg(PUSHmortal, (IV)(i)); } STMT_END +__UNDEFINED__ mXPUSHu(u) STMT_START { EXTEND(sp,1); sv_setuv_mg(PUSHmortal, (UV)(u)); } STMT_END + +=xsubs + +void +mPUSHp() + PPCODE: + EXTEND(SP, 3); + mPUSHp("one", 3); + mPUSHp("two", 3); + mPUSHp("three", 5); + XSRETURN(3); + +void +mPUSHn() + PPCODE: + EXTEND(SP, 3); + mPUSHn(0.5); + mPUSHn(-0.25); + mPUSHn(0.125); + XSRETURN(3); + +void +mPUSHi() + PPCODE: + EXTEND(SP, 3); + mPUSHi(-1); + mPUSHi(2); + mPUSHi(-3); + XSRETURN(3); + +void +mPUSHu() + PPCODE: + EXTEND(SP, 3); + mPUSHu(1); + mPUSHu(2); + mPUSHu(3); + XSRETURN(3); + +void +mXPUSHp() + PPCODE: + mXPUSHp("one", 3); + mXPUSHp("two", 3); + mXPUSHp("three", 5); + XSRETURN(3); + +void +mXPUSHn() + PPCODE: + mXPUSHn(0.5); + mXPUSHn(-0.25); + mXPUSHn(0.125); + XSRETURN(3); + +void +mXPUSHi() + PPCODE: + mXPUSHi(-1); + mXPUSHi(2); + mXPUSHi(-3); + XSRETURN(3); + +void +mXPUSHu() + PPCODE: + mXPUSHu(1); + mXPUSHu(2); + mXPUSHu(3); + XSRETURN(3); + +=tests plan => 8 + +ok(join(':', &Devel::PPPort::mPUSHp()), "one:two:three"); +ok(join(':', &Devel::PPPort::mPUSHn()), "0.5:-0.25:0.125"); +ok(join(':', &Devel::PPPort::mPUSHi()), "-1:2:-3"); +ok(join(':', &Devel::PPPort::mPUSHu()), "1:2:3"); + +ok(join(':', &Devel::PPPort::mXPUSHp()), "one:two:three"); +ok(join(':', &Devel::PPPort::mXPUSHn()), "0.5:-0.25:0.125"); +ok(join(':', &Devel::PPPort::mXPUSHi()), "-1:2:-3"); +ok(join(':', &Devel::PPPort::mXPUSHu()), "1:2:3"); + diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/magic b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/magic new file mode 100644 index 00000000000..57ea3f26ec0 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/magic @@ -0,0 +1,290 @@ +################################################################################ +## +## $Revision: 1.1 $ +## $Author: millert $ +## $Date: 2005/01/15 21:16:46 $ +## +################################################################################ +## +## Version 3.x, Copyright (C) 2004, Marcus Holland-Moritz. +## Version 2.x, Copyright (C) 2001, Paul Marquess. +## Version 1.x, Copyright (C) 1999, Kenneth Albanowski. +## +## This program is free software; you can redistribute it and/or +## modify it under the same terms as Perl itself. +## +################################################################################ + +=provides + +__UNDEFINED__ +/sv_\w+_mg/ + +=implementation + +__UNDEFINED__ SvGETMAGIC(x) STMT_START { if (SvGMAGICAL(x)) mg_get(x); } STMT_END + +__UNDEFINED__ PERL_MAGIC_sv '\0' +__UNDEFINED__ PERL_MAGIC_overload 'A' +__UNDEFINED__ PERL_MAGIC_overload_elem 'a' +__UNDEFINED__ PERL_MAGIC_overload_table 'c' +__UNDEFINED__ PERL_MAGIC_bm 'B' +__UNDEFINED__ PERL_MAGIC_regdata 'D' +__UNDEFINED__ PERL_MAGIC_regdatum 'd' +__UNDEFINED__ PERL_MAGIC_env 'E' +__UNDEFINED__ PERL_MAGIC_envelem 'e' +__UNDEFINED__ PERL_MAGIC_fm 'f' +__UNDEFINED__ PERL_MAGIC_regex_global 'g' +__UNDEFINED__ PERL_MAGIC_isa 'I' +__UNDEFINED__ PERL_MAGIC_isaelem 'i' +__UNDEFINED__ PERL_MAGIC_nkeys 'k' +__UNDEFINED__ PERL_MAGIC_dbfile 'L' +__UNDEFINED__ PERL_MAGIC_dbline 'l' +__UNDEFINED__ PERL_MAGIC_mutex 'm' +__UNDEFINED__ PERL_MAGIC_shared 'N' +__UNDEFINED__ PERL_MAGIC_shared_scalar 'n' +__UNDEFINED__ PERL_MAGIC_collxfrm 'o' +__UNDEFINED__ PERL_MAGIC_tied 'P' +__UNDEFINED__ PERL_MAGIC_tiedelem 'p' +__UNDEFINED__ PERL_MAGIC_tiedscalar 'q' +__UNDEFINED__ PERL_MAGIC_qr 'r' +__UNDEFINED__ PERL_MAGIC_sig 'S' +__UNDEFINED__ PERL_MAGIC_sigelem 's' +__UNDEFINED__ PERL_MAGIC_taint 't' +__UNDEFINED__ PERL_MAGIC_uvar 'U' +__UNDEFINED__ PERL_MAGIC_uvar_elem 'u' +__UNDEFINED__ PERL_MAGIC_vstring 'V' +__UNDEFINED__ PERL_MAGIC_vec 'v' +__UNDEFINED__ PERL_MAGIC_utf8 'w' +__UNDEFINED__ PERL_MAGIC_substr 'x' +__UNDEFINED__ PERL_MAGIC_defelem 'y' +__UNDEFINED__ PERL_MAGIC_glob '*' +__UNDEFINED__ PERL_MAGIC_arylen '#' +__UNDEFINED__ PERL_MAGIC_pos '.' +__UNDEFINED__ PERL_MAGIC_backref '<' +__UNDEFINED__ PERL_MAGIC_ext '~' + +/* That's the best we can do... */ +__UNDEFINED__ SvPV_force_nomg SvPV_force +__UNDEFINED__ SvPV_nomg SvPV +__UNDEFINED__ sv_catpvn_nomg sv_catpvn +__UNDEFINED__ sv_catsv_nomg sv_catsv +__UNDEFINED__ sv_setsv_nomg sv_setsv +__UNDEFINED__ sv_pvn_nomg sv_pvn +__UNDEFINED__ SvIV_nomg SvIV +__UNDEFINED__ SvUV_nomg SvUV + +#ifndef sv_catpv_mg +# define sv_catpv_mg(sv, ptr) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_catpv(TeMpSv,ptr); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_catpvn_mg +# define sv_catpvn_mg(sv, ptr, len) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_catpvn(TeMpSv,ptr,len); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_catsv_mg +# define sv_catsv_mg(dsv, ssv) \ + STMT_START { \ + SV *TeMpSv = dsv; \ + sv_catsv(TeMpSv,ssv); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_setiv_mg +# define sv_setiv_mg(sv, i) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_setiv(TeMpSv,i); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_setnv_mg +# define sv_setnv_mg(sv, num) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_setnv(TeMpSv,num); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_setpv_mg +# define sv_setpv_mg(sv, ptr) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_setpv(TeMpSv,ptr); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_setpvn_mg +# define sv_setpvn_mg(sv, ptr, len) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_setpvn(TeMpSv,ptr,len); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_setsv_mg +# define sv_setsv_mg(dsv, ssv) \ + STMT_START { \ + SV *TeMpSv = dsv; \ + sv_setsv(TeMpSv,ssv); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_setuv_mg +# define sv_setuv_mg(sv, i) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_setuv(TeMpSv,i); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_usepvn_mg +# define sv_usepvn_mg(sv, ptr, len) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_usepvn(TeMpSv,ptr,len); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +=xsubs + +void +sv_catpv_mg(sv, string) + SV *sv; + char *string; + CODE: + sv_catpv_mg(sv, string); + +void +sv_catpvn_mg(sv, sv2) + SV *sv; + SV *sv2; + PREINIT: + char *str; + STRLEN len; + CODE: + str = SvPV(sv2, len); + sv_catpvn_mg(sv, str, len); + +void +sv_catsv_mg(sv, sv2) + SV *sv; + SV *sv2; + CODE: + sv_catsv_mg(sv, sv2); + +void +sv_setiv_mg(sv, iv) + SV *sv; + IV iv; + CODE: + sv_setiv_mg(sv, iv); + +void +sv_setnv_mg(sv, nv) + SV *sv; + NV nv; + CODE: + sv_setnv_mg(sv, nv); + +void +sv_setpv_mg(sv, pv) + SV *sv; + char *pv; + CODE: + sv_setpv_mg(sv, pv); + +void +sv_setpvn_mg(sv, sv2) + SV *sv; + SV *sv2; + PREINIT: + char *str; + STRLEN len; + CODE: + str = SvPV(sv2, len); + sv_setpvn_mg(sv, str, len); + +void +sv_setsv_mg(sv, sv2) + SV *sv; + SV *sv2; + CODE: + sv_setsv_mg(sv, sv2); + +void +sv_setuv_mg(sv, uv) + SV *sv; + UV uv; + CODE: + sv_setuv_mg(sv, uv); + +void +sv_usepvn_mg(sv, sv2) + SV *sv; + SV *sv2; + PREINIT: + char *str, *copy; + STRLEN len; + CODE: + str = SvPV(sv2, len); + New(42, copy, len+1, char); + Copy(str, copy, len+1, char); + sv_usepvn_mg(sv, copy, len); + +=tests plan => 10 + +use Tie::Hash; +my %h; +tie %h, 'Tie::StdHash'; +$h{foo} = 'foo'; +$h{bar} = ''; + +&Devel::PPPort::sv_catpv_mg($h{foo}, 'bar'); +ok($h{foo}, 'foobar'); + +&Devel::PPPort::sv_catpvn_mg($h{bar}, 'baz'); +ok($h{bar}, 'baz'); + +&Devel::PPPort::sv_catsv_mg($h{foo}, '42'); +ok($h{foo}, 'foobar42'); + +&Devel::PPPort::sv_setiv_mg($h{bar}, 42); +ok($h{bar}, 42); + +&Devel::PPPort::sv_setnv_mg($h{PI}, 3.14159); +ok(abs($h{PI} - 3.14159) < 0.01); + +&Devel::PPPort::sv_setpv_mg($h{mhx}, 'mhx'); +ok($h{mhx}, 'mhx'); + +&Devel::PPPort::sv_setpvn_mg($h{mhx}, 'Marcus'); +ok($h{mhx}, 'Marcus'); + +&Devel::PPPort::sv_setsv_mg($h{sv}, 'SV'); +ok($h{sv}, 'SV'); + +&Devel::PPPort::sv_setuv_mg($h{sv}, 4711); +ok($h{sv}, 4711); + +&Devel::PPPort::sv_usepvn_mg($h{sv}, 'Perl'); +ok($h{sv}, 'Perl'); + diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/misc b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/misc new file mode 100644 index 00000000000..b89a29abd4b --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/misc @@ -0,0 +1,385 @@ +################################################################################ +## +## $Revision: 1.1 $ +## $Author: millert $ +## $Date: 2005/01/15 21:16:46 $ +## +################################################################################ +## +## Version 3.x, Copyright (C) 2004, Marcus Holland-Moritz. +## Version 2.x, Copyright (C) 2001, Paul Marquess. +## Version 1.x, Copyright (C) 1999, Kenneth Albanowski. +## +## This program is free software; you can redistribute it and/or +## modify it under the same terms as Perl itself. +## +################################################################################ + +=provides + +__UNDEFINED__ +PERL_UNUSED_DECL +PERL_GCC_BRACE_GROUPS_FORBIDDEN +NVTYPE +INT2PTR +PTRV +NUM2PTR +PTR2IV +PTR2UV +PTR2NV +PTR2ul +START_EXTERN_C +END_EXTERN_C +EXTERN_C +STMT_START +STMT_END +/PL_\w+/ + +=implementation + +#if (PERL_VERSION < 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION <= 5)) +/* Replace: 1 */ +# define PL_DBsingle DBsingle +# define PL_DBsub DBsub +# define PL_Sv Sv +# define PL_compiling compiling +# define PL_copline copline +# define PL_curcop curcop +# define PL_curstash curstash +# define PL_debstash debstash +# define PL_defgv defgv +# define PL_diehook diehook +# define PL_dirty dirty +# define PL_dowarn dowarn +# define PL_errgv errgv +# define PL_hexdigit hexdigit +# define PL_hints hints +# define PL_na na +# define PL_no_modify no_modify +# define PL_perl_destruct_level perl_destruct_level +# define PL_perldb perldb +# define PL_ppaddr ppaddr +# define PL_rsfp_filters rsfp_filters +# define PL_rsfp rsfp +# define PL_stack_base stack_base +# define PL_stack_sp stack_sp +# define PL_stdingv stdingv +# define PL_sv_arenaroot sv_arenaroot +# define PL_sv_no sv_no +# define PL_sv_undef sv_undef +# define PL_sv_yes sv_yes +# define PL_tainted tainted +# define PL_tainting tainting +/* Replace: 0 */ +#endif + +#ifdef HASATTRIBUTE +# if (defined(__GNUC__) && defined(__cplusplus)) || defined(__INTEL_COMPILER) +# define PERL_UNUSED_DECL +# else +# define PERL_UNUSED_DECL __attribute__((unused)) +# endif +#else +# define PERL_UNUSED_DECL +#endif + +__UNDEFINED__ NOOP (void)0 +__UNDEFINED__ dNOOP extern int Perl___notused PERL_UNUSED_DECL + +#ifndef NVTYPE +# if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE) +# define NVTYPE long double +# else +# define NVTYPE double +# endif +typedef NVTYPE NV; +#endif + +#ifndef INT2PTR + +# if (IVSIZE == PTRSIZE) && (UVSIZE == PTRSIZE) +# define PTRV UV +# define INT2PTR(any,d) (any)(d) +# else +# if PTRSIZE == LONGSIZE +# define PTRV unsigned long +# else +# define PTRV unsigned +# endif +# define INT2PTR(any,d) (any)(PTRV)(d) +# endif + +# define NUM2PTR(any,d) (any)(PTRV)(d) +# define PTR2IV(p) INT2PTR(IV,p) +# define PTR2UV(p) INT2PTR(UV,p) +# define PTR2NV(p) NUM2PTR(NV,p) + +# if PTRSIZE == LONGSIZE +# define PTR2ul(p) (unsigned long)(p) +# else +# define PTR2ul(p) INT2PTR(unsigned long,p) +# endif + +#endif /* !INT2PTR */ + +#undef START_EXTERN_C +#undef END_EXTERN_C +#undef EXTERN_C +#ifdef __cplusplus +# define START_EXTERN_C extern "C" { +# define END_EXTERN_C } +# define EXTERN_C extern "C" +#else +# define START_EXTERN_C +# define END_EXTERN_C +# define EXTERN_C extern +#endif + +#ifndef PERL_GCC_BRACE_GROUPS_FORBIDDEN +# if defined(__STRICT_ANSI__) && defined(PERL_GCC_PEDANTIC) +# define PERL_GCC_BRACE_GROUPS_FORBIDDEN +# endif +#endif + +#undef STMT_START +#undef STMT_END +#if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) && !defined(__cplusplus) +# define STMT_START (void)( /* gcc supports ``({ STATEMENTS; })'' */ +# define STMT_END ) +#else +# if defined(VOIDFLAGS) && (VOIDFLAGS) && (defined(sun) || defined(__sun__)) && !defined(__GNUC__) +# define STMT_START if (1) +# define STMT_END else (void)0 +# else +# define STMT_START do +# define STMT_END while (0) +# endif +#endif + +__UNDEFINED__ boolSV(b) ((b) ? &PL_sv_yes : &PL_sv_no) + +/* DEFSV appears first in 5.004_56 */ +__UNDEFINED__ DEFSV GvSV(PL_defgv) +__UNDEFINED__ SAVE_DEFSV SAVESPTR(GvSV(PL_defgv)) + +/* Older perls (<=5.003) lack AvFILLp */ +__UNDEFINED__ AvFILLp AvFILL + +__UNDEFINED__ ERRSV get_sv("@",FALSE) + +__UNDEFINED__ newSVpvn(data,len) ((data) \ + ? ((len) ? newSVpv((data), (len)) : newSVpv("", 0)) \ + : newSV(0)) + +/* Hint: gv_stashpvn + * This function's backport doesn't support the length parameter, but + * rather ignores it. Portability can only be ensured if the length + * parameter is used for speed reasons, but the length can always be + * correctly computed from the string argument. + */ + +__UNDEFINED__ gv_stashpvn(str,len,create) gv_stashpv(str,create) + +/* Replace: 1 */ +__UNDEFINED__ get_cv perl_get_cv +__UNDEFINED__ get_sv perl_get_sv +__UNDEFINED__ get_av perl_get_av +__UNDEFINED__ get_hv perl_get_hv +/* Replace: 0 */ + +#ifdef HAS_MEMCMP +__UNDEFINED__ memNE(s1,s2,l) (memcmp(s1,s2,l)) +__UNDEFINED__ memEQ(s1,s2,l) (!memcmp(s1,s2,l)) +#else +__UNDEFINED__ memNE(s1,s2,l) (bcmp(s1,s2,l)) +__UNDEFINED__ memEQ(s1,s2,l) (!bcmp(s1,s2,l)) +#endif + +__UNDEFINED__ MoveD(s,d,n,t) memmove((char*)(d),(char*)(s), (n) * sizeof(t)) +__UNDEFINED__ CopyD(s,d,n,t) memcpy((char*)(d),(char*)(s), (n) * sizeof(t)) +#ifdef HAS_MEMSET +__UNDEFINED__ ZeroD(d,n,t) memzero((char*)(d), (n) * sizeof(t)) +#else +__UNDEFINED__ ZeroD(d,n,t) ((void)memzero((char*)(d), (n) * sizeof(t)),d) +#endif + +__UNDEFINED__ Poison(d,n,t) (void)memset((char*)(d), 0xAB, (n) * sizeof(t)) + +__UNDEFINED__ dUNDERBAR dNOOP +__UNDEFINED__ UNDERBAR DEFSV + +__UNDEFINED__ dAX I32 ax = MARK - PL_stack_base + 1 +__UNDEFINED__ dITEMS I32 items = SP - MARK + +=xsubs + +int +gv_stashpvn(name, create) + char *name + I32 create + CODE: + RETVAL = gv_stashpvn(name, strlen(name), create) != NULL; + OUTPUT: + RETVAL + +int +get_sv(name, create) + char *name + I32 create + CODE: + RETVAL = get_sv(name, create) != NULL; + OUTPUT: + RETVAL + +int +get_av(name, create) + char *name + I32 create + CODE: + RETVAL = get_av(name, create) != NULL; + OUTPUT: + RETVAL + +int +get_hv(name, create) + char *name + I32 create + CODE: + RETVAL = get_hv(name, create) != NULL; + OUTPUT: + RETVAL + +int +get_cv(name, create) + char *name + I32 create + CODE: + RETVAL = get_cv(name, create) != NULL; + OUTPUT: + RETVAL + +void +newSVpvn() + PPCODE: + XPUSHs(newSVpvn("test", 4)); + XPUSHs(newSVpvn("test", 2)); + XPUSHs(newSVpvn("test", 0)); + XPUSHs(newSVpvn(NULL, 2)); + XPUSHs(newSVpvn(NULL, 0)); + XSRETURN(5); + +SV * +PL_sv_undef() + CODE: + RETVAL = newSVsv(&PL_sv_undef); + OUTPUT: + RETVAL + +SV * +PL_sv_yes() + CODE: + RETVAL = newSVsv(&PL_sv_yes); + OUTPUT: + RETVAL + +SV * +PL_sv_no() + CODE: + RETVAL = newSVsv(&PL_sv_no); + OUTPUT: + RETVAL + +int +PL_na(string) + char *string + CODE: + PL_na = strlen(string); + RETVAL = PL_na; + OUTPUT: + RETVAL + +SV* +boolSV(value) + int value + CODE: + RETVAL = newSVsv(boolSV(value)); + OUTPUT: + RETVAL + +SV* +DEFSV() + CODE: + RETVAL = newSVsv(DEFSV); + OUTPUT: + RETVAL + +int +ERRSV() + CODE: + RETVAL = SvTRUE(ERRSV); + OUTPUT: + RETVAL + +SV* +UNDERBAR() + CODE: + { + dUNDERBAR; + RETVAL = newSVsv(UNDERBAR); + } + OUTPUT: + RETVAL + +=tests plan => 31 + +use vars qw($my_sv @my_av %my_hv); + +my @s = &Devel::PPPort::newSVpvn(); +ok(@s == 5); +ok($s[0], "test"); +ok($s[1], "te"); +ok($s[2], ""); +ok(!defined($s[3])); +ok(!defined($s[4])); + +ok(!defined(&Devel::PPPort::PL_sv_undef())); +ok(&Devel::PPPort::PL_sv_yes()); +ok(!&Devel::PPPort::PL_sv_no()); +ok(&Devel::PPPort::PL_na("abcd"), 4); + +ok(&Devel::PPPort::boolSV(1)); +ok(!&Devel::PPPort::boolSV(0)); + +$_ = "Fred"; +ok(&Devel::PPPort::DEFSV(), "Fred"); +ok(&Devel::PPPort::UNDERBAR(), "Fred"); + +eval { 1 }; +ok(!&Devel::PPPort::ERRSV()); +eval { cannot_call_this_one() }; +ok(&Devel::PPPort::ERRSV()); + +ok(&Devel::PPPort::gv_stashpvn('Devel::PPPort', 0)); +ok(!&Devel::PPPort::gv_stashpvn('does::not::exist', 0)); +ok(&Devel::PPPort::gv_stashpvn('does::not::exist', 1)); + +$my_sv = 1; +ok(&Devel::PPPort::get_sv('my_sv', 0)); +ok(!&Devel::PPPort::get_sv('not_my_sv', 0)); +ok(&Devel::PPPort::get_sv('not_my_sv', 1)); + +@my_av = (1); +ok(&Devel::PPPort::get_av('my_av', 0)); +ok(!&Devel::PPPort::get_av('not_my_av', 0)); +ok(&Devel::PPPort::get_av('not_my_av', 1)); + +%my_hv = (a=>1); +ok(&Devel::PPPort::get_hv('my_hv', 0)); +ok(!&Devel::PPPort::get_hv('not_my_hv', 0)); +ok(&Devel::PPPort::get_hv('not_my_hv', 1)); + +sub my_cv { 1 }; +ok(&Devel::PPPort::get_cv('my_cv', 0)); +ok(!&Devel::PPPort::get_cv('not_my_cv', 0)); +ok(&Devel::PPPort::get_cv('not_my_cv', 1)); + diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/newCONSTSUB b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/newCONSTSUB new file mode 100644 index 00000000000..f4bd221d5ae --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/newCONSTSUB @@ -0,0 +1,107 @@ +################################################################################ +## +## $Revision: 1.1 $ +## $Author: millert $ +## $Date: 2005/01/15 21:16:46 $ +## +################################################################################ +## +## Version 3.x, Copyright (C) 2004, Marcus Holland-Moritz. +## Version 2.x, Copyright (C) 2001, Paul Marquess. +## Version 1.x, Copyright (C) 1999, Kenneth Albanowski. +## +## This program is free software; you can redistribute it and/or +## modify it under the same terms as Perl itself. +## +################################################################################ + +=provides + +newCONSTSUB + +=implementation + +/* Hint: newCONSTSUB + * Returns a CV* as of perl-5.7.1. This return value is not supported + * by Devel::PPPort. + */ + +/* newCONSTSUB from IO.xs is in the core starting with 5.004_63 */ +#if { VERSION < 5.004_63 } && { VERSION != 5.004_05 } +#if { NEED newCONSTSUB } + +void +newCONSTSUB(HV *stash, char *name, SV *sv) +{ + U32 oldhints = PL_hints; + HV *old_cop_stash = PL_curcop->cop_stash; + HV *old_curstash = PL_curstash; + line_t oldline = PL_curcop->cop_line; + PL_curcop->cop_line = PL_copline; + + PL_hints &= ~HINT_BLOCK_SCOPE; + if (stash) + PL_curstash = PL_curcop->cop_stash = stash; + + newSUB( + +#if { VERSION < 5.003_22 } + start_subparse(), +#elif { VERSION == 5.003_22 } + start_subparse(0), +#else /* 5.003_23 onwards */ + start_subparse(FALSE, 0), +#endif + + newSVOP(OP_CONST, 0, newSVpv(name,0)), + newSVOP(OP_CONST, 0, &PL_sv_no), /* SvPV(&PL_sv_no) == "" -- GMB */ + newSTATEOP(0, Nullch, newSVOP(OP_CONST, 0, sv)) + ); + + PL_hints = oldhints; + PL_curcop->cop_stash = old_cop_stash; + PL_curstash = old_curstash; + PL_curcop->cop_line = oldline; +} +#endif +#endif + +=xsinit + +#define NEED_newCONSTSUB + +=xsmisc + +void call_newCONSTSUB_1(void) +{ +#ifdef PERL_NO_GET_CONTEXT + dTHX; +#endif + newCONSTSUB(gv_stashpv("Devel::PPPort", FALSE), "test_value_1", newSViv(1)); +} + +extern void call_newCONSTSUB_2(void); +extern void call_newCONSTSUB_3(void); + +=xsubs + +void +call_newCONSTSUB_1() + +void +call_newCONSTSUB_2() + +void +call_newCONSTSUB_3() + +=tests plan => 3 + +&Devel::PPPort::call_newCONSTSUB_1(); +ok(&Devel::PPPort::test_value_1(), 1); + +&Devel::PPPort::call_newCONSTSUB_2(); +ok(&Devel::PPPort::test_value_2(), 2); + +&Devel::PPPort::call_newCONSTSUB_3(); +ok(&Devel::PPPort::test_value_3(), 3); + diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/newRV b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/newRV new file mode 100644 index 00000000000..4e49f692739 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/newRV @@ -0,0 +1,74 @@ +################################################################################ +## +## $Revision: 1.1 $ +## $Author: millert $ +## $Date: 2005/01/15 21:16:46 $ +## +################################################################################ +## +## Version 3.x, Copyright (C) 2004, Marcus Holland-Moritz. +## Version 2.x, Copyright (C) 2001, Paul Marquess. +## Version 1.x, Copyright (C) 1999, Kenneth Albanowski. +## +## This program is free software; you can redistribute it and/or +## modify it under the same terms as Perl itself. +## +################################################################################ + +=provides + +newRV_inc +newRV_noinc + +=implementation + +__UNDEFINED__ newRV_inc(sv) newRV(sv) /* Replace */ + +#ifndef newRV_noinc +#if { NEED newRV_noinc } +SV * +newRV_noinc(SV *sv) +{ + SV *rv = (SV *)newRV(sv); + SvREFCNT_dec(sv); + return rv; +} +#endif +#endif + +=xsinit + +#define NEED_newRV_noinc + +=xsubs + +U32 +newRV_inc_REFCNT() + PREINIT: + SV *sv, *rv; + CODE: + sv = newSViv(42); + rv = newRV_inc(sv); + SvREFCNT_dec(sv); + RETVAL = SvREFCNT(sv); + sv_2mortal(rv); + OUTPUT: + RETVAL + +U32 +newRV_noinc_REFCNT() + PREINIT: + SV *sv, *rv; + CODE: + sv = newSViv(42); + rv = newRV_noinc(sv); + RETVAL = SvREFCNT(sv); + sv_2mortal(rv); + OUTPUT: + RETVAL + +=tests plan => 2 + +ok(&Devel::PPPort::newRV_inc_REFCNT, 1); +ok(&Devel::PPPort::newRV_noinc_REFCNT, 1); + diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/ppphbin b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/ppphbin new file mode 100644 index 00000000000..e531fcfb3a9 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/ppphbin @@ -0,0 +1,662 @@ +################################################################################ +## +## $Revision: 1.1 $ +## $Author: millert $ +## $Date: 2005/01/15 21:16:46 $ +## +################################################################################ +## +## Version 3.x, Copyright (C) 2004, Marcus Holland-Moritz. +## Version 2.x, Copyright (C) 2001, Paul Marquess. +## Version 1.x, Copyright (C) 1999, Kenneth Albanowski. +## +## This program is free software; you can redistribute it and/or +## modify it under the same terms as Perl itself. +## +################################################################################ + +=provides + +=implementation + +=cut + +use strict; + +my %opt = ( + quiet => 0, + diag => 1, + hints => 1, + changes => 1, + cplusplus => 0, +); + +my($ppport) = $0 =~ /([\w.]+)$/; +my $LF = '(?:\r\n|[\r\n])'; # line feed +my $HS = "[ \t]"; # horizontal whitespace + +eval { + require Getopt::Long; + Getopt::Long::GetOptions(\%opt, qw( + help quiet diag! hints! changes! cplusplus + patch=s copy=s diff=s compat-version=s + list-provided list-unsupported + )) or usage(); +}; + +if ($@ and grep /^-/, @ARGV) { + usage() if "@ARGV" =~ /^--?h(?:elp)?$/; + die "Getopt::Long not found. Please don't use any options.\n"; +} + +usage() if $opt{help}; + +if (exists $opt{'compat-version'}) { + my($r,$v,$s) = eval { parse_version($opt{'compat-version'}) }; + if ($@) { + die "Invalid version number format: '$opt{'compat-version'}'\n"; + } + die "Only Perl 5 is supported\n" if $r != 5; + die "Invalid version number: $opt{'compat-version'}\n" if $v >= 1000 || $v >= 1000; + $opt{'compat-version'} = sprintf "%d.%03d%03d", $r, $v, $s; +} +else { + $opt{'compat-version'} = 5; +} + +# Never use C comments in this file!!!!! +my $ccs = '/'.'*'; +my $cce = '*'.'/'; +my $rccs = quotemeta $ccs; +my $rcce = quotemeta $cce; + +my @files; + +if (@ARGV) { + @files = map { glob $_ } @ARGV; +} +else { + eval { + require File::Find; + File::Find::find(sub { + $File::Find::name =~ /\.(xs|c|h|cc)$/i + and push @files, $File::Find::name; + }, '.'); + }; + if ($@) { + @files = map { glob $_ } qw(*.xs *.c *.h *.cc); + } + my %filter = map { /(.*)\.xs$/ ? ("$1.c" => 1) : () } @files; + @files = grep { !/\b\Q$ppport\E$/i && !exists $filter{$_} } @files; +} + +unless (@files) { + die "No input files given!\n"; +} + +my %API = map { /^(\w+)\|([^|]*)\|([^|]*)\|(\w*)$/ + ? ( $1 => { + ($2 ? ( base => $2 ) : ()), + ($3 ? ( todo => $3 ) : ()), + (index($4, 'v') >= 0 ? ( varargs => 1 ) : ()), + (index($4, 'p') >= 0 ? ( provided => 1 ) : ()), + (index($4, 'n') >= 0 ? ( nothxarg => 1 ) : ()), + } ) + : die "invalid spec: $_" } qw( +__PERL_API__ +); + +if (exists $opt{'list-unsupported'}) { + my $f; + for $f (sort { lc $a cmp lc $b } keys %API) { + next unless $API{$f}{todo}; + print "$f ", '.'x(40-length($f)), " ", format_version($API{$f}{todo}), "\n"; + } + exit 0; +} + +# Scan for possible replacement candidates + +my(%replace, %need, %hints, %depends); +my $replace = 0; +my $hint = ''; + +while (<DATA>) { + if ($hint) { + if (m{^\s*\*\s(.*?)\s*$}) { + $hints{$hint} ||= ''; # suppress warning with older perls + $hints{$hint} .= "$1\n"; + } + else { + $hint = ''; + } + } + $hint = $1 if m{^\s*$rccs\sHint:\s+(\w+)\s*$}; + + $replace = $1 if m{^\s*$rccs\s+Replace:\s+(\d+)\s+$rcce\s*$}; + $replace{$2} = $1 if $replace and m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+)}; + $replace{$2} = $1 if m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+).*$rccs\s+Replace\s+$rcce}; + $replace{$1} = $2 if m{^\s*$rccs\s+Replace (\w+) with (\w+)\s+$rcce\s*$}; + + if (m{^\s*$rccs\s+(\w+)\s+depends\s+on\s+(\w+(\s*,\s*\w+)*)\s+$rcce\s*$}) { + push @{$depends{$1}}, map { s/\s+//g; $_ } split /,/, $2; + } + + $need{$1} = 1 if m{^#if\s+defined\(NEED_(\w+)(?:_GLOBAL)?\)}; +} + +if (exists $opt{'list-provided'}) { + my $f; + for $f (sort { lc $a cmp lc $b } keys %API) { + next unless $API{$f}{provided}; + my @flags; + push @flags, 'explicit' if exists $need{$f}; + push @flags, 'depend' if exists $depends{$f}; + push @flags, 'hint' if exists $hints{$f}; + my $flags = @flags ? ' ['.join(', ', @flags).']' : ''; + print "$f$flags\n"; + } + exit 0; +} + +my(%files, %global, %revreplace); +%revreplace = reverse %replace; +my $filename; +my $patch_opened = 0; + +for $filename (@files) { + unless (open IN, "<$filename") { + warn "Unable to read from $filename: $!\n"; + next; + } + + info("Scanning $filename ..."); + + my $c = do { local $/; <IN> }; + close IN; + + my %file = (orig => $c, changes => 0); + + # temporarily remove C comments from the code + my @ccom; + $c =~ s{ + ( + [^"'/]+ + | + (?:"[^"\\]*(?:\\.[^"\\]*)*" [^"'/]*)+ + | + (?:'[^'\\]*(?:\\.[^'\\]*)*' [^"'/]*)+ + ) + | + (/ (?: + \*[^*]*\*+(?:[^$ccs][^*]*\*+)* / + | + /[^\r\n]* + )) + }{ + defined $2 and push @ccom, $2; + defined $1 ? $1 : "$ccs$#ccom$cce"; + }egsx; + + $file{ccom} = \@ccom; + $file{code} = $c; + $file{has_inc_ppport} = ($c =~ /#.*include.*\Q$ppport\E/); + + my $func; + + for $func (keys %API) { + my $match = $func; + $match .= "|$revreplace{$func}" if exists $revreplace{$func}; + if ($c =~ /\b(?:Perl_)?($match)\b/) { + $file{uses_replace}{$1}++ if exists $revreplace{$func} && $1 eq $revreplace{$func}; + $file{uses_Perl}{$func}++ if $c =~ /\bPerl_$func\b/; + if (exists $API{$func}{provided}) { + if (!exists $API{$func}{base} || $API{$func}{base} > $opt{'compat-version'}) { + $file{uses}{$func}++; + my @deps = rec_depend($func); + if (@deps) { + $file{uses_deps}{$func} = \@deps; + for (@deps) { + $file{uses}{$_} = 0 unless exists $file{uses}{$_}; + } + } + for ($func, @deps) { + if (exists $need{$_}) { + $file{needs}{$_} = 'static'; + } + } + } + } + if (exists $API{$func}{todo} && $API{$func}{todo} > $opt{'compat-version'}) { + if ($c =~ /\b$func\b/) { + $file{uses_todo}{$func}++; + } + } + } + } + + while ($c =~ /^$HS*#$HS*define$HS+(NEED_(\w+?)(_GLOBAL)?)\b/mg) { + if (exists $need{$2}) { + $file{defined $3 ? 'needed_global' : 'needed_static'}{$2}++; + } + else { + warning("Possibly wrong #define $1 in $filename"); + } + } + + for (qw(uses needs uses_todo needed_global needed_static)) { + for $func (keys %{$file{$_}}) { + push @{$global{$_}{$func}}, $filename; + } + } + + $files{$filename} = \%file; +} + +# Globally resolve NEED_'s +my $need; +for $need (keys %{$global{needs}}) { + if (@{$global{needs}{$need}} > 1) { + my @targets = @{$global{needs}{$need}}; + my @t = grep $files{$_}{needed_global}{$need}, @targets; + @targets = @t if @t; + @t = grep /\.xs$/i, @targets; + @targets = @t if @t; + my $target = shift @targets; + $files{$target}{needs}{$need} = 'global'; + for (@{$global{needs}{$need}}) { + $files{$_}{needs}{$need} = 'extern' if $_ ne $target; + } + } +} + +for $filename (@files) { + exists $files{$filename} or next; + + info("=== Analyzing $filename ==="); + + my %file = %{$files{$filename}}; + my $func; + my $c = $file{code}; + + for $func (sort keys %{$file{uses_Perl}}) { + if ($API{$func}{varargs}) { + my $changes = ($c =~ s{\b(Perl_$func\s*\(\s*)(?!aTHX_?)(\)|[^\s)]*\))} + { $1 . ($2 eq ')' ? 'aTHX' : 'aTHX_ ') . $2 }ge); + if ($changes) { + warning("Doesn't pass interpreter argument aTHX to Perl_$func"); + $file{changes} += $changes; + } + } + else { + warning("Uses Perl_$func instead of $func"); + $file{changes} += ($c =~ s{\bPerl_$func(\s*)\((\s*aTHX_?)?\s*} + {$func$1(}g); + } + } + + for $func (sort keys %{$file{uses_replace}}) { + warning("Uses $func instead of $replace{$func}"); + $file{changes} += ($c =~ s/\b$func\b/$replace{$func}/g); + } + + for $func (sort keys %{$file{uses}}) { + next unless $file{uses}{$func}; # if it's only a dependency + if (exists $file{uses_deps}{$func}) { + diag("Uses $func, which depends on ", join(', ', @{$file{uses_deps}{$func}})); + } + elsif (exists $replace{$func}) { + warning("Uses $func instead of $replace{$func}"); + $file{changes} += ($c =~ s/\b$func\b/$replace{$func}/g); + } + else { + diag("Uses $func"); + } + hint($func); + } + + for $func (sort keys %{$file{uses_todo}}) { + warning("Uses $func, which may not be portable below perl ", + format_version($API{$func}{todo})); + } + + for $func (sort keys %{$file{needed_static}}) { + my $message = ''; + if (not exists $file{uses}{$func}) { + $message = "No need to define NEED_$func if $func is never used"; + } + elsif (exists $file{needs}{$func} && $file{needs}{$func} ne 'static') { + $message = "No need to define NEED_$func when already needed globally"; + } + if ($message) { + diag($message); + $file{changes} += ($c =~ s/^$HS*#$HS*define$HS+NEED_$func\b.*$LF//mg); + } + } + + for $func (sort keys %{$file{needed_global}}) { + my $message = ''; + if (not exists $global{uses}{$func}) { + $message = "No need to define NEED_${func}_GLOBAL if $func is never used"; + } + elsif (exists $file{needs}{$func}) { + if ($file{needs}{$func} eq 'extern') { + $message = "No need to define NEED_${func}_GLOBAL when already needed globally"; + } + elsif ($file{needs}{$func} eq 'static') { + $message = "No need to define NEED_${func}_GLOBAL when only used in this file"; + } + } + if ($message) { + diag($message); + $file{changes} += ($c =~ s/^$HS*#$HS*define$HS+NEED_${func}_GLOBAL\b.*$LF//mg); + } + } + + $file{needs_inc_ppport} = keys %{$file{uses}}; + + if ($file{needs_inc_ppport}) { + my $pp = ''; + + for $func (sort keys %{$file{needs}}) { + my $type = $file{needs}{$func}; + next if $type eq 'extern'; + my $suffix = $type eq 'global' ? '_GLOBAL' : ''; + unless (exists $file{"needed_$type"}{$func}) { + if ($type eq 'global') { + diag("Files [@{$global{needs}{$func}}] need $func, adding global request"); + } + else { + diag("File needs $func, adding static request"); + } + $pp .= "#define NEED_$func$suffix\n"; + } + } + + if ($pp && ($c =~ s/^(?=$HS*#$HS*define$HS+NEED_\w+)/$pp/m)) { + $pp = ''; + $file{changes}++; + } + + unless ($file{has_inc_ppport}) { + diag("Needs to include '$ppport'"); + $pp .= qq(#include "$ppport"\n) + } + + if ($pp) { + $file{changes} += ($c =~ s/^($HS*#$HS*define$HS+NEED_\w+.*?)^/$1$pp/ms) + || ($c =~ s/^(?=$HS*#$HS*include.*\Q$ppport\E)/$pp/m) + || ($c =~ s/^($HS*#$HS*include.*XSUB.*\s*?)^/$1$pp/m) + || ($c =~ s/^/$pp/); + } + } + else { + if ($file{has_inc_ppport}) { + diag("No need to include '$ppport'"); + $file{changes} += ($c =~ s/^$HS*?#$HS*include.*\Q$ppport\E.*?$LF//m); + } + } + + # put back in our C comments + my $ix; + my $cppc = 0; + my @ccom = @{$file{ccom}}; + for $ix (0 .. $#ccom) { + if (!$opt{cplusplus} && $ccom[$ix] =~ s!^//!!) { + $cppc++; + $file{changes} += $c =~ s/$rccs$ix$rcce/$ccs$ccom[$ix] $cce/; + } + else { + $c =~ s/$rccs$ix$rcce/$ccom[$ix]/; + } + } + + if ($cppc) { + my $s = $cppc != 1 ? 's' : ''; + warning("Uses $cppc C++ style comment$s, which is not portable"); + } + + if ($file{changes}) { + if (exists $opt{copy}) { + my $newfile = "$filename$opt{copy}"; + if (-e $newfile) { + error("'$newfile' already exists, refusing to write copy of '$filename'"); + } + else { + local *F; + if (open F, ">$newfile") { + info("Writing copy of '$filename' with changes to '$newfile'"); + print F $c; + close F; + } + else { + error("Cannot open '$newfile' for writing: $!"); + } + } + } + elsif (exists $opt{patch} || $opt{changes}) { + if (exists $opt{patch}) { + unless ($patch_opened) { + if (open PATCH, ">$opt{patch}") { + $patch_opened = 1; + } + else { + error("Cannot open '$opt{patch}' for writing: $!"); + delete $opt{patch}; + $opt{changes} = 1; + goto fallback; + } + } + mydiff(\*PATCH, $filename, $c); + } + else { +fallback: + info("Suggested changes:"); + mydiff(\*STDOUT, $filename, $c); + } + } + else { + my $s = $file{changes} == 1 ? '' : 's'; + info("$file{changes} potentially required change$s detected"); + } + } + else { + info("Looks good"); + } +} + +close PATCH if $patch_opened; + +exit 0; + +####################################################################### + +sub mydiff +{ + local *F = shift; + my($file, $str) = @_; + my $diff; + + if (exists $opt{diff}) { + $diff = run_diff($opt{diff}, $file, $str); + } + + if (!defined $diff and can_use('Text::Diff')) { + $diff = Text::Diff::diff($file, \$str, { STYLE => 'Unified' }); + $diff = <<HEADER . $diff; +--- $file ++++ $file.patched +HEADER + } + + if (!defined $diff) { + $diff = run_diff('diff -u', $file, $str); + } + + if (!defined $diff) { + $diff = run_diff('diff', $file, $str); + } + + if (!defined $diff) { + error("Cannot generate a diff. Please install Text::Diff or use --copy."); + return; + } + + print F $diff; + +} + +sub run_diff +{ + my($prog, $file, $str) = @_; + my $tmp = 'dppptemp'; + my $suf = 'aaa'; + my $diff = ''; + local *F; + + while (-e "$tmp.$suf") { $suf++ } + $tmp = "$tmp.$suf"; + + if (open F, ">$tmp") { + print F $str; + close F; + + if (open F, "$prog $file $tmp |") { + while (<F>) { + s/\Q$tmp\E/$file.patched/; + $diff .= $_; + } + close F; + unlink $tmp; + return $diff; + } + + unlink $tmp; + } + else { + error("Cannot open '$tmp' for writing: $!"); + } + + return undef; +} + +sub can_use +{ + eval "use @_;"; + return $@ eq ''; +} + +sub rec_depend +{ + my $func = shift; + my %seen; + return () unless exists $depends{$func}; + grep !$seen{$_}++, map { ($_, rec_depend($_)) } @{$depends{$func}}; +} + +sub parse_version +{ + my $ver = shift; + + if ($ver =~ /^(\d+)\.(\d+)\.(\d+)$/) { + return ($1, $2, $3); + } + elsif ($ver !~ /^\d+\.[\d_]+$/) { + die "cannot parse version '$ver'\n"; + } + + $ver =~ s/_//g; + $ver =~ s/$/000000/; + + my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/; + + $v = int $v; + $s = int $s; + + if ($r < 5 || ($r == 5 && $v < 6)) { + if ($s % 10) { + die "cannot parse version '$ver'\n"; + } + } + + return ($r, $v, $s); +} + +sub format_version +{ + my $ver = shift; + + $ver =~ s/$/000000/; + my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/; + + $v = int $v; + $s = int $s; + + if ($r < 5 || ($r == 5 && $v < 6)) { + if ($s % 10) { + die "invalid version '$ver'\n"; + } + $s /= 10; + + $ver = sprintf "%d.%03d", $r, $v; + $s > 0 and $ver .= sprintf "_%02d", $s; + + return $ver; + } + + return sprintf "%d.%d.%d", $r, $v, $s; +} + +sub info +{ + $opt{quiet} and return; + print @_, "\n"; +} + +sub diag +{ + $opt{quiet} and return; + $opt{diag} and print @_, "\n"; +} + +sub warning +{ + $opt{quiet} and return; + print "*** ", @_, "\n"; +} + +sub error +{ + print "*** ERROR: ", @_, "\n"; +} + +my %given_hints; +sub hint +{ + $opt{quiet} and return; + $opt{hints} or return; + my $func = shift; + exists $hints{$func} or return; + $given_hints{$func}++ and return; + my $hint = $hints{$func}; + $hint =~ s/^/ /mg; + print " --- hint for $func ---\n", $hint; +} + +sub usage +{ + my($usage) = do { local(@ARGV,$/)=($0); <> } =~ /^=head\d$HS+SYNOPSIS\s*^(.*?)\s*^=/ms; + my %M = ( 'I' => '*' ); + $usage =~ s/^\s*perl\s+\S+/$^X $0/; + $usage =~ s/([A-Z])<([^>]+)>/$M{$1}$2$M{$1}/g; + + print <<ENDUSAGE; + +Usage: $usage + +See perldoc $0 for details. + +ENDUSAGE + + exit 2; +} diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/ppphdoc b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/ppphdoc new file mode 100644 index 00000000000..5d868f0ad69 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/ppphdoc @@ -0,0 +1,286 @@ +################################################################################ +## +## $Revision: 1.1 $ +## $Author: millert $ +## $Date: 2005/01/15 21:16:46 $ +## +################################################################################ +## +## Version 3.x, Copyright (C) 2004, Marcus Holland-Moritz. +## Version 2.x, Copyright (C) 2001, Paul Marquess. +## Version 1.x, Copyright (C) 1999, Kenneth Albanowski. +## +## This program is free software; you can redistribute it and/or +## modify it under the same terms as Perl itself. +## +################################################################################ + +=provides + +=dontwarn + +NEED_function +NEED_function_GLOBAL +DPPP_NAMESPACE + +=implementation + +=pod + +=head1 NAME + +ppport.h - Perl/Pollution/Portability version __VERSION__ + +=head1 SYNOPSIS + + perl ppport.h [options] [files] + + --help show short help + + --patch=file write one patch file with changes + --copy=suffix write changed copies with suffix + --diff=program use diff program and options + + --compat-version=version provide compatibility with Perl version + --cplusplus accept C++ comments + + --quiet don't output anything except fatal errors + --nodiag don't show diagnostics + --nohints don't show hints + --nochanges don't suggest changes + + --list-provided list provided API + --list-unsupported list unsupported API + +=head1 COMPATIBILITY + +This version of F<ppport.h> is designed to support operation with Perl +installations back to __MIN_PERL__, and has been tested up to __MAX_PERL__. + +=head1 OPTIONS + +=head2 --help + +Display a brief usage summary. + +=head2 --patch=I<file> + +If this option is given, a single patch file will be created if +any changes are suggested. This requires a working diff program +to be installed on your system. + +=head2 --copy=I<suffix> + +If this option is given, a copy of each file will be saved with +the given suffix that contains the suggested changes. This does +not require any external programs. + +If neither C<--patch> or C<--copy> are given, the default is to +simply print the diffs for each file. This requires either +C<Text::Diff> or a C<diff> program to be installed. + +=head2 --diff=I<program> + +Manually set the diff program and options to use. The default +is to use C<Text::Diff>, when installed, and output unified +context diffs. + +=head2 --compat-version=I<version> + +Tell F<ppport.h> to check for compatibility with the given +Perl version. The default is to check for compatibility with Perl +version __MIN_PERL__. You can use this option to reduce the output +of F<ppport.h> if you intend to be backward compatible only +up to a certain Perl version. + +=head2 --cplusplus + +Usually, F<ppport.h> will detect C++ style comments and +replace them with C style comments for portability reasons. +Using this option instructs F<ppport.h> to leave C++ +comments untouched. + +=head2 --quiet + +Be quiet. Don't print anything except fatal errors. + +=head2 --nodiag + +Don't output any diagnostic messages. Only portability +alerts will be printed. + +=head2 --nohints + +Don't output any hints. Hints often contain useful portability +notes. + +=head2 --nochanges + +Don't suggest any changes. Only give diagnostic output and hints +unless these are also deactivated. + +=head2 --list-provided + +Lists the API elements for which compatibility is provided by +F<ppport.h>. Also lists if it must be explicitly requested, +if it has dependencies, and if there are hints for it. + +=head2 --list-unsupported + +Lists the API elements that are known not to be supported by +F<ppport.h> and below which version of Perl they probably +won't be available or work. + +=head1 DESCRIPTION + +In order for a Perl extension (XS) module to be as portable as possible +across differing versions of Perl itself, certain steps need to be taken. + +=over 4 + +=item * + +Including this header is the first major one. This alone will give you +access to a large part of the Perl API that hasn't been available in +earlier Perl releases. Use + + perl ppport.h --list-provided + +to see which API elements are provided by ppport.h. + +=item * + +You should avoid using deprecated parts of the API. For example, using +global Perl variables without the C<PL_> prefix is deprecated. Also, +some API functions used to have a C<perl_> prefix. Using this form is +also deprecated. You can safely use the supported API, as F<ppport.h> +will provide wrappers for older Perl versions. + +=item * + +If you use one of a few functions that were not present in earlier +versions of Perl, and that can't be provided using a macro, you have +to explicitly request support for these functions by adding one or +more C<#define>s in your source code before the inclusion of F<ppport.h>. + +These functions will be marked C<explicit> in the list shown by +C<--list-provided>. + +Depending on whether you module has a single or multiple files that +use such functions, you want either C<static> or global variants. + +For a C<static> function, use: + + #define NEED_function + +For a global function, use: + + #define NEED_function_GLOBAL + +Note that you mustn't have more than one global request for one +function in your project. + + __EXPLICIT_API__ + +To avoid namespace conflicts, you can change the namespace of the +explicitly exported functions using the C<DPPP_NAMESPACE> macro. +Just C<#define> the macro before including C<ppport.h>: + + #define DPPP_NAMESPACE MyOwnNamespace_ + #include "ppport.h" + +The default namespace is C<DPPP_>. + +=back + +The good thing is that most of the above can be checked by running +F<ppport.h> on your source code. See the next section for +details. + +=head1 EXAMPLES + +To verify whether F<ppport.h> is needed for your module, whether you +should make any changes to your code, and whether any special defines +should be used, F<ppport.h> can be run as a Perl script to check your +source code. Simply say: + + perl ppport.h + +The result will usually be a list of patches suggesting changes +that should at least be acceptable, if not necessarily the most +efficient solution, or a fix for all possible problems. + +If you know that your XS module uses features only available in +newer Perl releases, if you're aware that it uses C++ comments, +and if you want all suggestions as a single patch file, you could +use something like this: + + perl ppport.h --compat-version=5.6.0 --cplusplus --patch=test.diff + +If you only want your code to be scanned without any suggestions +for changes, use: + + perl ppport.h --nochanges + +You can specify a different C<diff> program or options, using +the C<--diff> option: + + perl ppport.h --diff='diff -C 10' + +This would output context diffs with 10 lines of context. + +=head1 BUGS + +If this version of F<ppport.h> is causing failure during +the compilation of this module, please check if newer versions +of either this module or C<Devel::PPPort> are available on CPAN +before sending a bug report. + +If F<ppport.h> was generated using the latest version of +C<Devel::PPPort> and is causing failure of this module, please +file a bug report using the CPAN Request Tracker at L<http://rt.cpan.org/>. + +Please include the following information: + +=over 4 + +=item 1. + +The complete output from running "perl -V" + +=item 2. + +This file. + +=item 3. + +The name and version of the module you were trying to build. + +=item 4. + +A full log of the build that failed. + +=item 5. + +Any other information that you think could be relevant. + +=back + +For the latest version of this code, please get the C<Devel::PPPort> +module from CPAN. + +=head1 COPYRIGHT + +Version 3.x, Copyright (c) 2004, Marcus Holland-Moritz. + +Version 2.x, Copyright (C) 2001, Paul Marquess. + +Version 1.x, Copyright (C) 1999, Kenneth Albanowski. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=head1 SEE ALSO + +See L<Devel::PPPort>. + diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/ppphtest b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/ppphtest new file mode 100644 index 00000000000..dd3f164dbdc --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/ppphtest @@ -0,0 +1,576 @@ +################################################################################ +## +## $Revision: 1.1 $ +## $Author: millert $ +## $Date: 2005/01/15 21:16:46 $ +## +################################################################################ +## +## Version 3.x, Copyright (C) 2004, Marcus Holland-Moritz. +## Version 2.x, Copyright (C) 2001, Paul Marquess. +## Version 1.x, Copyright (C) 1999, Kenneth Albanowski. +## +## This program is free software; you can redistribute it and/or +## modify it under the same terms as Perl itself. +## +################################################################################ + +=tests plan => 134 + +use File::Path qw/rmtree mkpath/; +use Config; + +my $tmp = 'ppptmp'; +my $inc = ''; +my $perl = find_perl(); + +rmtree($tmp) if -d $tmp; +mkpath($tmp) or die "mkpath $tmp: $!\n"; +chdir($tmp) or die "chdir $tmp: $!\n"; + +if ($ENV{'PERL_CORE'}) { + if (-d '../../lib') { + $inc = $^O eq 'VMS' ? '-"I../../lib"' : '-I../../lib'; + unshift @INC, '../../lib'; + } +} +if ($perl =~ m!^\./!) { + $perl = ".$perl"; +} + +END { + chdir('..') if !-d $tmp && -d "../$tmp"; + rmtree($tmp) if -d $tmp; +} + +ok(&Devel::PPPort::WriteFile("ppport.h")); + +sub ppport +{ + my @args = @_; + print "# *** running $perl $inc ppport.h @args ***\n"; + my $out = join '', `$perl $inc ppport.h @args`; + my $copy = $out; + $copy =~ s/^/# | /mg; + print "$copy\n"; + return $out; +} + +sub matches +{ + my($str, $re, $mod) = @_; + my @n; + eval "\@n = \$str =~ /$re/g$mod;"; + if ($@) { + my $err = $@; + $err =~ s/^/# *** /mg; + print "# *** ERROR ***\n$err\n"; + } + return $@ ? -42 : scalar @n; +} + +sub eq_files +{ + my($f1, $f2) = @_; + return 0 unless -e $f1 && -e $f2; + local *F; + for ($f1, $f2) { + print "# File: $_\n"; + unless (open F, $_) { + print "# couldn't open $_: $!\n"; + return 0; + } + $_ = do { local $/; <F> }; + close F; + my $copy = $_; + $copy =~ s/^/# | /mg; + print "$copy\n"; + } + return $f1 eq $f2; +} + +my @tests; + +for (split /\s*={70,}\s*/, do { local $/; <DATA> }) { + s/^\s+//; s/\s+$//; + my($c, %f); + ($c, @f{m/-{20,}\s+(\S+)\s+-{20,}/g}) = split /\s*-{20,}\s+\S+\s+-{20,}\s*/; + push @tests, { code => $c, files => \%f }; +} + +my $t; +for $t (@tests) { + my $f; + for $f (keys %{$t->{files}}) { + my @f = split /\//, $f; + if (@f > 1) { + pop @f; + my $path = join '/', @f; + mkpath($path) or die "mkpath('$path'): $!\n"; + } + my $txt = $t->{files}{$f}; + local *F; + open F, ">$f" or die "open $f: $!\n"; + print F "$txt\n"; + close F; + $txt =~ s/^/# | /mg; + print "# *** writing $f ***\n$txt\n"; + } + + eval $t->{code}; + if ($@) { + my $err = $@; + $err =~ s/^/# *** /mg; + print "# *** ERROR ***\n$err\n"; + } + ok($@, ''); + + for (keys %{$t->{files}}) { + unlink $_ or die "unlink('$_'): $!\n"; + } +} + +sub find_perl +{ + my $perl = $^X; + + return $perl if $^O eq 'VMS'; + + my $exe = $Config{'_exe'} || ''; + + if ($perl =~ /^perl\Q$exe\E$/i) { + $perl = "perl$exe"; + eval "require File::Spec"; + if ($@) { + $perl = "./$perl"; + } else { + $perl = File::Spec->catfile(File::Spec->curdir(), $perl); + } + } + + if ($perl !~ /\Q$exe\E$/i) { + $perl .= $exe; + } + + warn "find_perl: cannot find $perl from $^X" unless -f $perl; + + return $perl; +} + +__DATA__ + +my $o = ppport(qw(--help)); +ok($o =~ /^Usage:.*ppport\.h/m); +ok($o =~ /--help/m); + +$o = ppport(qw(--nochanges)); +ok($o =~ /^scanning.*test\.xs/mi); +ok($o =~ /analyzing.*test\.xs/mi); +ok(matches($o, '^scanning', 'mi'), 1); +ok(matches($o, 'analyzing', 'mi'), 1); +ok($o =~ /Uses Perl_newSViv instead of newSViv/); + +$o = ppport(qw(--quiet --nochanges)); +ok($o =~ /^\s*$/); + +---------------------------- test.xs ------------------------------------------ + +Perl_newSViv(); + +=============================================================================== + +# check if C and C++ comments are filtered correctly + +my $o = ppport(qw(--copy=a)); +ok($o =~ /^scanning.*MyExt\.xs/mi); +ok($o =~ /analyzing.*MyExt\.xs/mi); +ok(matches($o, '^scanning', 'mi'), 1); +ok($o =~ /^Needs to include.*ppport\.h/m); +ok($o !~ /^Uses grok_bin/m); +ok($o !~ /^Uses newSVpv/m); +ok($o =~ /Uses 1 C\+\+ style comment/m); +ok(eq_files('MyExt.xsa', 'MyExt.ra')); + +# check if C++ are left untouched with --cplusplus + +$o = ppport(qw(--copy=b --cplusplus)); +ok($o =~ /^scanning.*MyExt\.xs/mi); +ok($o =~ /analyzing.*MyExt\.xs/mi); +ok(matches($o, '^scanning', 'mi'), 1); +ok($o =~ /^Needs to include.*ppport\.h/m); +ok($o !~ /^Uses grok_bin/m); +ok($o !~ /^Uses newSVpv/m); +ok($o !~ /Uses \d+ C\+\+ style comment/m); +ok(eq_files('MyExt.xsb', 'MyExt.rb')); + +unlink qw(MyExt.xsa MyExt.xsb); + +---------------------------- MyExt.xs ----------------------------------------- + +newSVuv(); + // newSVpv(); + XPUSHs(foo); +/* grok_bin(); */ + +---------------------------- MyExt.ra ----------------------------------------- + +#include "ppport.h" +newSVuv(); + /* newSVpv(); */ + XPUSHs(foo); +/* grok_bin(); */ + +---------------------------- MyExt.rb ----------------------------------------- + +#include "ppport.h" +newSVuv(); + // newSVpv(); + XPUSHs(foo); +/* grok_bin(); */ + +=============================================================================== + +my $o = ppport(qw(--nochanges file1.xs)); +ok($o =~ /^scanning.*file1\.xs/mi); +ok($o =~ /analyzing.*file1\.xs/mi); +ok($o !~ /^scanning.*file2\.xs/mi); +ok($o =~ /^Uses newCONSTSUB/m); +ok($o =~ /^Uses SvPV_nolen.*depends.*sv_2pv_nolen/m); +ok($o =~ /hint for newCONSTSUB/m); +ok($o !~ /hint for sv_2pv_nolen/m); +ok($o =~ /^Looks good/m); + +$o = ppport(qw(--nochanges --nohints file1.xs)); +ok($o =~ /^scanning.*file1\.xs/mi); +ok($o =~ /analyzing.*file1\.xs/mi); +ok($o !~ /^scanning.*file2\.xs/mi); +ok($o =~ /^Uses newCONSTSUB/m); +ok($o =~ /^Uses SvPV_nolen.*depends.*sv_2pv_nolen/m); +ok($o !~ /hint for newCONSTSUB/m); +ok($o !~ /hint for sv_2pv_nolen/m); +ok($o =~ /^Looks good/m); + +$o = ppport(qw(--nochanges --nohints --nodiag file1.xs)); +ok($o =~ /^scanning.*file1\.xs/mi); +ok($o =~ /analyzing.*file1\.xs/mi); +ok($o !~ /^scanning.*file2\.xs/mi); +ok($o !~ /^Uses newCONSTSUB/m); +ok($o !~ /^Uses SvPV_nolen/m); +ok($o !~ /hint for newCONSTSUB/m); +ok($o !~ /hint for sv_2pv_nolen/m); +ok($o =~ /^Looks good/m); + +$o = ppport(qw(--nochanges --quiet file1.xs)); +ok($o =~ /^\s*$/); + +$o = ppport(qw(--nochanges file2.xs)); +ok($o =~ /^scanning.*file2\.xs/mi); +ok($o =~ /analyzing.*file2\.xs/mi); +ok($o !~ /^scanning.*file1\.xs/mi); +ok($o =~ /^Uses mXPUSHp/m); +ok($o =~ /^Needs to include.*ppport\.h/m); +ok($o !~ /^Looks good/m); +ok($o =~ /^1 potentially required change detected/m); + +$o = ppport(qw(--nochanges --nohints file2.xs)); +ok($o =~ /^scanning.*file2\.xs/mi); +ok($o =~ /analyzing.*file2\.xs/mi); +ok($o !~ /^scanning.*file1\.xs/mi); +ok($o =~ /^Uses mXPUSHp/m); +ok($o =~ /^Needs to include.*ppport\.h/m); +ok($o !~ /^Looks good/m); +ok($o =~ /^1 potentially required change detected/m); + +$o = ppport(qw(--nochanges --nohints --nodiag file2.xs)); +ok($o =~ /^scanning.*file2\.xs/mi); +ok($o =~ /analyzing.*file2\.xs/mi); +ok($o !~ /^scanning.*file1\.xs/mi); +ok($o !~ /^Uses mXPUSHp/m); +ok($o !~ /^Needs to include.*ppport\.h/m); +ok($o !~ /^Looks good/m); +ok($o =~ /^1 potentially required change detected/m); + +$o = ppport(qw(--nochanges --quiet file2.xs)); +ok($o =~ /^\s*$/); + +---------------------------- file1.xs ----------------------------------------- + +#define NEED_newCONSTSUB +#define NEED_sv_2pv_nolen +#include "ppport.h" + +newCONSTSUB(); +SvPV_nolen(); + +---------------------------- file2.xs ----------------------------------------- + +mXPUSHp(foo); + +=============================================================================== + +my $o = ppport(qw(--nochanges)); +ok($o =~ /^scanning.*FooBar\.xs/mi); +ok($o =~ /analyzing.*FooBar\.xs/mi); +ok(matches($o, '^scanning', 'mi'), 1); +ok($o !~ /^Looks good/m); +ok($o =~ /^Uses grok_bin/m); + +---------------------------- FooBar.xs ---------------------------------------- + +newSViv(); +XPUSHs(foo); +grok_bin(); + +=============================================================================== + +my $o = ppport(qw(--nochanges)); +ok($o =~ /^scanning.*First\.xs/mi); +ok($o =~ /analyzing.*First\.xs/mi); +ok($o =~ /^scanning.*second\.h/mi); +ok($o =~ /analyzing.*second\.h/mi); +ok($o =~ /^scanning.*sub.*third\.c/mi); +ok($o =~ /analyzing.*sub.*third\.c/mi); +ok($o !~ /^scanning.*foobar/mi); +ok(matches($o, '^scanning', 'mi'), 3); + +---------------------------- First.xs ----------------------------------------- + +one + +---------------------------- foobar.xyz --------------------------------------- + +two + +---------------------------- second.h ----------------------------------------- + +three + +---------------------------- sub/third.c -------------------------------------- + +four + +=============================================================================== + +my $o = ppport(qw(--nochanges)); +ok($o =~ /Possibly wrong #define NEED_foobar in.*test.xs/i); + +---------------------------- test.xs ------------------------------------------ + +#define NEED_foobar + +=============================================================================== + +# And now some complex "real-world" example + +my $o = ppport(qw(--copy=f)); +for (qw(main.xs mod1.c mod2.c mod3.c mod4.c mod5.c)) { + ok($o =~ /^scanning.*\Q$_\E/mi); + ok($o =~ /analyzing.*\Q$_\E/i); +} +ok(matches($o, '^scanning', 'mi'), 6); + +ok(matches($o, '^Writing copy of', 'mi'), 5); +ok(!-e "mod5.cf"); + +for (qw(main.xs mod1.c mod2.c mod3.c mod4.c)) { + ok($o =~ /^Writing copy of.*\Q$_\E.*with changes/mi); + ok(-e "${_}f"); + ok(eq_files("${_}f", "${_}r")); + unlink "${_}f"; +} + +---------------------------- main.xs ------------------------------------------ + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#define NEED_newCONSTSUB +#define NEED_grok_hex_GLOBAL +#include "ppport.h" + +newCONSTSUB(); +grok_hex(); +Perl_grok_bin(aTHX_ foo, bar); + +/* some comment */ + +perl_eval_pv(); +grok_bin(); +Perl_grok_bin(bar, sv_no); + +---------------------------- mod1.c ------------------------------------------- + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#define NEED_grok_bin_GLOBAL +#define NEED_newCONSTSUB +#include "ppport.h" + +newCONSTSUB(); +grok_bin(); +{ + Perl_croak ("foo"); + Perl_sv_catpvf(); /* I know it's wrong ;-) */ +} + +---------------------------- mod2.c ------------------------------------------- + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#define NEED_eval_pv +#include "ppport.h" + +newSViv(); + +/* + eval_pv(); +*/ + +---------------------------- mod3.c ------------------------------------------- + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +grok_oct(); +eval_pv(); + +---------------------------- mod4.c ------------------------------------------- + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +START_MY_CXT; + +---------------------------- mod5.c ------------------------------------------- + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#include "ppport.h" +call_pv(); + +---------------------------- main.xsr ----------------------------------------- + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#define NEED_eval_pv_GLOBAL +#define NEED_grok_hex +#define NEED_newCONSTSUB_GLOBAL +#include "ppport.h" + +newCONSTSUB(); +grok_hex(); +grok_bin(foo, bar); + +/* some comment */ + +eval_pv(); +grok_bin(); +grok_bin(bar, PL_sv_no); + +---------------------------- mod1.cr ------------------------------------------ + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#define NEED_grok_bin_GLOBAL +#include "ppport.h" + +newCONSTSUB(); +grok_bin(); +{ + Perl_croak (aTHX_ "foo"); + Perl_sv_catpvf(aTHX); /* I know it's wrong ;-) */ +} + +---------------------------- mod2.cr ------------------------------------------ + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + + +newSViv(); + +/* + eval_pv(); +*/ + +---------------------------- mod3.cr ------------------------------------------ + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" +#define NEED_grok_oct +#include "ppport.h" + +grok_oct(); +eval_pv(); + +---------------------------- mod4.cr ------------------------------------------ + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" +#include "ppport.h" + +START_MY_CXT; + +=============================================================================== + +my $o = ppport(qw(--nochanges)); +ok($o =~ /Uses grok_hex/m); +ok($o !~ /Looks good/m); + +$o = ppport(qw(--nochanges --compat-version=5.8.0)); +ok($o !~ /Uses grok_hex/m); +ok($o =~ /Looks good/m); + +---------------------------- FooBar.xs ---------------------------------------- + +grok_hex(); + +=============================================================================== + +my $o = ppport(qw(--nochanges)); +ok($o =~ /Uses SvPVutf8_force, which may not be portable/m); + +$o = ppport(qw(--nochanges --compat-version=5.6.0)); +ok($o !~ /Uses SvPVutf8_force/m); + +---------------------------- FooBar.xs ---------------------------------------- + +SvPVutf8_force(); + +=============================================================================== + +my $o = ppport(qw(--nochanges)); +ok($o !~ /potentially required change/); +ok(matches($o, '^Looks good', 'mi'), 2); + +---------------------------- FooBar.xs ---------------------------------------- + +#define NEED_grok_numeric_radix +#define NEED_grok_number +#include "ppport.h" + +GROK_NUMERIC_RADIX(); +grok_number(); + +---------------------------- foo.c -------------------------------------------- + +#include "ppport.h" + +call_pv(); + diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/sv_xpvf b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/sv_xpvf new file mode 100644 index 00000000000..27028dbc656 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/sv_xpvf @@ -0,0 +1,327 @@ +################################################################################ +## +## $Revision: 1.1 $ +## $Author: millert $ +## $Date: 2005/01/15 21:16:46 $ +## +################################################################################ +## +## Version 3.x, Copyright (C) 2004, Marcus Holland-Moritz. +## Version 2.x, Copyright (C) 2001, Paul Marquess. +## Version 1.x, Copyright (C) 1999, Kenneth Albanowski. +## +## This program is free software; you can redistribute it and/or +## modify it under the same terms as Perl itself. +## +################################################################################ + +=provides + +vnewSVpvf +sv_vcatpvf +sv_vsetpvf + +sv_catpvf_mg +sv_catpvf_mg_nocontext +sv_vcatpvf_mg + +sv_setpvf_mg +sv_setpvf_mg_nocontext +sv_vsetpvf_mg + +=implementation + +#if { VERSION >= 5.004 } && !defined(vnewSVpvf) +#if { NEED vnewSVpvf } + +SV * +vnewSVpvf(pTHX_ const char *pat, va_list *args) +{ + register SV *sv = newSV(0); + sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); + return sv; +} + +#endif +#endif + +/* sv_vcatpvf depends on sv_vcatpvfn */ +#if { VERSION >= 5.004 } && !defined(sv_vcatpvf) +# define sv_vcatpvf(sv, pat, args) sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)) +#endif + +/* sv_vsetpvf depends on sv_vsetpvfn */ +#if { VERSION >= 5.004 } && !defined(sv_vsetpvf) +# define sv_vsetpvf(sv, pat, args) sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)) +#endif + +/* sv_catpvf_mg depends on sv_vcatpvfn, sv_catpvf_mg_nocontext */ +#if { VERSION >= 5.004 } && !defined(sv_catpvf_mg) +#if { NEED sv_catpvf_mg } + +void +sv_catpvf_mg(pTHX_ SV *sv, const char *pat, ...) +{ + va_list args; + va_start(args, pat); + sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + SvSETMAGIC(sv); + va_end(args); +} + +#endif +#endif + +/* sv_catpvf_mg_nocontext depends on sv_vcatpvfn */ +#ifdef PERL_IMPLICIT_CONTEXT +#if { VERSION >= 5.004 } && !defined(sv_catpvf_mg_nocontext) +#if { NEED sv_catpvf_mg_nocontext } + +void +sv_catpvf_mg_nocontext(SV *sv, const char *pat, ...) +{ + dTHX; + va_list args; + va_start(args, pat); + sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + SvSETMAGIC(sv); + va_end(args); +} + +#endif +#endif +#endif + +#ifndef sv_catpvf_mg +# ifdef PERL_IMPLICIT_CONTEXT +# define sv_catpvf_mg Perl_sv_catpvf_mg_nocontext +# else +# define sv_catpvf_mg Perl_sv_catpvf_mg +# endif +#endif + +/* sv_vcatpvf_mg depends on sv_vcatpvfn */ +#if { VERSION >= 5.004 } && !defined(sv_vcatpvf_mg) +# define sv_vcatpvf_mg(sv, pat, args) \ + STMT_START { \ + sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); \ + SvSETMAGIC(sv); \ + } STMT_END +#endif + +/* sv_setpvf_mg depends on sv_vsetpvfn, sv_setpvf_mg_nocontext */ +#if { VERSION >= 5.004 } && !defined(sv_setpvf_mg) +#if { NEED sv_setpvf_mg } + +void +sv_setpvf_mg(pTHX_ SV *sv, const char *pat, ...) +{ + va_list args; + va_start(args, pat); + sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + SvSETMAGIC(sv); + va_end(args); +} + +#endif +#endif + +/* sv_setpvf_mg_nocontext depends on sv_vsetpvfn */ +#ifdef PERL_IMPLICIT_CONTEXT +#if { VERSION >= 5.004 } && !defined(sv_setpvf_mg_nocontext) +#if { NEED sv_setpvf_mg_nocontext } + +void +sv_setpvf_mg_nocontext(SV *sv, const char *pat, ...) +{ + dTHX; + va_list args; + va_start(args, pat); + sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + SvSETMAGIC(sv); + va_end(args); +} + +#endif +#endif +#endif + +#ifndef sv_setpvf_mg +# ifdef PERL_IMPLICIT_CONTEXT +# define sv_setpvf_mg Perl_sv_setpvf_mg_nocontext +# else +# define sv_setpvf_mg Perl_sv_setpvf_mg +# endif +#endif + +/* sv_vsetpvf_mg depends on sv_vsetpvfn */ +#if { VERSION >= 5.004 } && !defined(sv_vsetpvf_mg) +# define sv_vsetpvf_mg(sv, pat, args) \ + STMT_START { \ + sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); \ + SvSETMAGIC(sv); \ + } STMT_END +#endif + +=xsinit + +#define NEED_vnewSVpvf +#define NEED_sv_catpvf_mg +#define NEED_sv_catpvf_mg_nocontext +#define NEED_sv_setpvf_mg +#define NEED_sv_setpvf_mg_nocontext + +=xsmisc + +static SV * test_vnewSVpvf(pTHX_ const char *pat, ...) +{ + SV *sv; + va_list args; + va_start(args, pat); +#if { VERSION >= 5.004 } + sv = vnewSVpvf(pat, &args); +#else + sv = newSVpv(pat, 0); +#endif + va_end(args); + return sv; +} + +static void test_sv_vcatpvf(pTHX_ SV *sv, const char *pat, ...) +{ + va_list args; + va_start(args, pat); +#if { VERSION >= 5.004 } + sv_vcatpvf(sv, pat, &args); +#else + sv_catpv(sv, pat); +#endif + va_end(args); +} + +static void test_sv_vsetpvf(pTHX_ SV *sv, const char *pat, ...) +{ + va_list args; + va_start(args, pat); +#if { VERSION >= 5.004 } + sv_vsetpvf(sv, pat, &args); +#else + sv_setpv(sv, pat); +#endif + va_end(args); +} + +=xsubs + +SV * +vnewSVpvf() + CODE: + RETVAL = test_vnewSVpvf(aTHX_ "%s-%d", "Perl", 42); + OUTPUT: + RETVAL + +SV * +sv_vcatpvf(sv) + SV *sv + CODE: + RETVAL = newSVsv(sv); + test_sv_vcatpvf(aTHX_ RETVAL, "%s-%d", "Perl", 42); + OUTPUT: + RETVAL + +SV * +sv_vsetpvf(sv) + SV *sv + CODE: + RETVAL = newSVsv(sv); + test_sv_vsetpvf(aTHX_ RETVAL, "%s-%d", "Perl", 42); + OUTPUT: + RETVAL + +void +sv_catpvf_mg(sv) + SV *sv + CODE: +#if { VERSION >= 5.004 } + sv_catpvf_mg(sv, "%s-%d", "Perl", 42); +#endif + +void +Perl_sv_catpvf_mg(sv) + SV *sv + CODE: +#if { VERSION >= 5.004 } + Perl_sv_catpvf_mg(aTHX_ sv, "%s-%d", "-Perl", 43); +#endif + +void +sv_catpvf_mg_nocontext(sv) + SV *sv + CODE: +#if { VERSION >= 5.004 } +#ifdef PERL_IMPLICIT_CONTEXT + sv_catpvf_mg_nocontext(sv, "%s-%d", "-Perl", 44); +#else + sv_catpvf_mg(sv, "%s-%d", "-Perl", 44); +#endif +#endif + +void +sv_setpvf_mg(sv) + SV *sv + CODE: +#if { VERSION >= 5.004 } + sv_setpvf_mg(sv, "%s-%d", "mhx", 42); +#endif + +void +Perl_sv_setpvf_mg(sv) + SV *sv + CODE: +#if { VERSION >= 5.004 } + Perl_sv_setpvf_mg(aTHX_ sv, "%s-%d", "foo", 43); +#endif + +void +sv_setpvf_mg_nocontext(sv) + SV *sv + CODE: +#if { VERSION >= 5.004 } +#ifdef PERL_IMPLICIT_CONTEXT + sv_setpvf_mg_nocontext(sv, "%s-%d", "bar", 44); +#else + sv_setpvf_mg(sv, "%s-%d", "bar", 44); +#endif +#endif + +=tests plan => 9 + +use Tie::Hash; +my %h; +tie %h, 'Tie::StdHash'; +$h{foo} = 'foo-'; +$h{bar} = ''; + +ok(&Devel::PPPort::vnewSVpvf(), $] >= 5.004 ? 'Perl-42' : '%s-%d'); +ok(&Devel::PPPort::sv_vcatpvf('1-2-3-'), $] >= 5.004 ? '1-2-3-Perl-42' : '1-2-3-%s-%d'); +ok(&Devel::PPPort::sv_vsetpvf('1-2-3-'), $] >= 5.004 ? 'Perl-42' : '%s-%d'); + +&Devel::PPPort::sv_catpvf_mg($h{foo}); +ok($h{foo}, $] >= 5.004 ? 'foo-Perl-42' : 'foo-'); + +&Devel::PPPort::Perl_sv_catpvf_mg($h{foo}); +ok($h{foo}, $] >= 5.004 ? 'foo-Perl-42-Perl-43' : 'foo-'); + +&Devel::PPPort::sv_catpvf_mg_nocontext($h{foo}); +ok($h{foo}, $] >= 5.004 ? 'foo-Perl-42-Perl-43-Perl-44' : 'foo-'); + +&Devel::PPPort::sv_setpvf_mg($h{bar}); +ok($h{bar}, $] >= 5.004 ? 'mhx-42' : ''); + +&Devel::PPPort::Perl_sv_setpvf_mg($h{bar}); +ok($h{bar}, $] >= 5.004 ? 'foo-43' : ''); + +&Devel::PPPort::sv_setpvf_mg_nocontext($h{bar}); +ok($h{bar}, $] >= 5.004 ? 'bar-44' : ''); + + diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/threads b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/threads new file mode 100644 index 00000000000..bd17dc31be0 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/threads @@ -0,0 +1,57 @@ +################################################################################ +## +## $Revision: 1.1 $ +## $Author: millert $ +## $Date: 2005/01/15 21:16:46 $ +## +################################################################################ +## +## Version 3.x, Copyright (C) 2004, Marcus Holland-Moritz. +## Version 2.x, Copyright (C) 2001, Paul Marquess. +## Version 1.x, Copyright (C) 1999, Kenneth Albanowski. +## +## This program is free software; you can redistribute it and/or +## modify it under the same terms as Perl itself. +## +################################################################################ + +=provides + +__UNDEFINED__ + +=implementation + +__UNDEFINED__ dTHR dNOOP + +__UNDEFINED__ dTHX dNOOP +__UNDEFINED__ dTHXa(x) dNOOP + +__UNDEFINED__ pTHX void +__UNDEFINED__ pTHX_ +__UNDEFINED__ aTHX +__UNDEFINED__ aTHX_ + +__UNDEFINED__ dTHXoa(x) dTHXa(x) + +=xsubs + +IV +no_THX_arg(sv) + SV *sv + CODE: + RETVAL = 1 + sv_2iv(sv); + OUTPUT: + RETVAL + +void +with_THX_arg(error) + char *error + PPCODE: + Perl_croak(aTHX_ "%s", error); + +=tests plan => 2 + +ok(&Devel::PPPort::no_THX_arg("42"), 43); +eval { &Devel::PPPort::with_THX_arg("yes\n"); }; +ok($@ =~ /^yes/); + diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/uv b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/uv new file mode 100644 index 00000000000..69a35f2e3b3 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/uv @@ -0,0 +1,130 @@ +################################################################################ +## +## $Revision: 1.1 $ +## $Author: millert $ +## $Date: 2005/01/15 21:16:46 $ +## +################################################################################ +## +## Version 3.x, Copyright (C) 2004, Marcus Holland-Moritz. +## Version 2.x, Copyright (C) 2001, Paul Marquess. +## Version 1.x, Copyright (C) 1999, Kenneth Albanowski. +## +## This program is free software; you can redistribute it and/or +## modify it under the same terms as Perl itself. +## +################################################################################ + +=provides + +sv_setuv +newSVuv +__UNDEFINED__ + +=implementation + +#ifndef sv_setuv +# define sv_setuv(sv, uv) \ + STMT_START { \ + UV TeMpUv = uv; \ + if (TeMpUv <= IV_MAX) \ + sv_setiv(sv, TeMpUv); \ + else \ + sv_setnv(sv, (double)TeMpUv); \ + } STMT_END +#endif + +#ifndef newSVuv +# define newSVuv(uv) ((uv) <= IV_MAX ? newSViv((IV)uv) : newSVnv((NV)uv)) +#endif + +__UNDEFINED__ sv_2uv(sv) ((PL_Sv = (sv)), (UV) (SvNOK(PL_Sv) ? SvNV(PL_Sv) : sv_2nv(PL_Sv))) +__UNDEFINED__ SvUVX(sv) ((UV)SvIVX(sv)) +__UNDEFINED__ SvUVXx(sv) SvUVX(sv) +__UNDEFINED__ SvUV(sv) (SvIOK(sv) ? SvUVX(sv) : sv_2uv(sv)) +__UNDEFINED__ SvUVx(sv) ((PL_Sv = (sv)), SvUV(PL_Sv)) + +/* Hint: sv_uv + * Always use the SvUVx() macro instead of sv_uv(). + */ +__UNDEFINED__ sv_uv(sv) SvUVx(sv) + +__UNDEFINED__ XST_mUV(i,v) (ST(i) = sv_2mortal(newSVuv(v)) ) +__UNDEFINED__ XSRETURN_UV(v) STMT_START { XST_mUV(0,v); XSRETURN(1); } STMT_END + +__UNDEFINED__ PUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); PUSHTARG; } STMT_END +__UNDEFINED__ XPUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); XPUSHTARG; } STMT_END + +=xsubs + +SV * +sv_setuv(uv) + UV uv + CODE: + RETVAL = newSViv(1); + sv_setuv(RETVAL, uv); + OUTPUT: + RETVAL + +SV * +newSVuv(uv) + UV uv + CODE: + RETVAL = newSVuv(uv); + OUTPUT: + RETVAL + +UV +sv_2uv(sv) + SV *sv + CODE: + RETVAL = sv_2uv(sv); + OUTPUT: + RETVAL + +UV +SvUVx(sv) + SV *sv + CODE: + sv--; + RETVAL = SvUVx(++sv); + OUTPUT: + RETVAL + +void +XSRETURN_UV() + PPCODE: + XSRETURN_UV(42); + +void +PUSHu() + PREINIT: + dTARG; + PPCODE: + TARG = sv_newmortal(); + EXTEND(SP, 1); + PUSHu(42); + XSRETURN(1); + +void +XPUSHu() + PREINIT: + dTARG; + PPCODE: + TARG = sv_newmortal(); + XPUSHu(43); + XSRETURN(1); + +=tests plan => 10 + +ok(&Devel::PPPort::sv_setuv(42), 42); +ok(&Devel::PPPort::newSVuv(123), 123); +ok(&Devel::PPPort::sv_2uv("4711"), 4711); +ok(&Devel::PPPort::sv_2uv("1735928559"), 1735928559); +ok(&Devel::PPPort::SvUVx("1735928559"), 1735928559); +ok(&Devel::PPPort::SvUVx(1735928559), 1735928559); +ok(&Devel::PPPort::SvUVx(0xdeadbeef), 0xdeadbeef); +ok(&Devel::PPPort::XSRETURN_UV(), 42); +ok(&Devel::PPPort::PUSHu(), 42); +ok(&Devel::PPPort::XPUSHu(), 43); + diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/version b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/version new file mode 100644 index 00000000000..8571d34273a --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/inc/version @@ -0,0 +1,56 @@ +################################################################################ +## +## $Revision: 1.1 $ +## $Author: millert $ +## $Date: 2005/01/15 21:16:46 $ +## +################################################################################ +## +## Version 3.x, Copyright (C) 2004, Marcus Holland-Moritz. +## Version 2.x, Copyright (C) 2001, Paul Marquess. +## Version 1.x, Copyright (C) 1999, Kenneth Albanowski. +## +## This program is free software; you can redistribute it and/or +## modify it under the same terms as Perl itself. +## +################################################################################ + +=provides + +PERL_REVISION +PERL_VERSION +PERL_SUBVERSION +PERL_BCDVERSION + +=dontwarn + +PERL_PATCHLEVEL_H_IMPLICIT + +=implementation + +#ifndef PERL_REVISION +# if !defined(__PATCHLEVEL_H_INCLUDED__) && !(defined(PATCHLEVEL) && defined(SUBVERSION)) +# define PERL_PATCHLEVEL_H_IMPLICIT +# include <patchlevel.h> +# endif +# if !(defined(PERL_VERSION) || (defined(SUBVERSION) && defined(PATCHLEVEL))) +# include <could_not_find_Perl_patchlevel.h> +# endif +# ifndef PERL_REVISION +# define PERL_REVISION (5) + /* Replace: 1 */ +# define PERL_VERSION PATCHLEVEL +# define PERL_SUBVERSION SUBVERSION + /* Replace PERL_PATCHLEVEL with PERL_VERSION */ + /* Replace: 0 */ +# endif +#endif + +#define PERL_BCDVERSION ((PERL_REVISION * 0x1000000L) + (PERL_VERSION * 0x1000L) + PERL_SUBVERSION) + +/* It is very unlikely that anyone will try to use this with Perl 6 + (or greater), but who knows. + */ +#if PERL_REVISION != 5 +# error ppport.h only works with Perl version 5 +#endif /* PERL_REVISION != 5 */ diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/ppptools.pl b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/ppptools.pl new file mode 100644 index 00000000000..1f89196f17c --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/ppptools.pl @@ -0,0 +1,375 @@ +################################################################################ +# +# ppptools.pl -- various utility functions +# +################################################################################ +# +# $Revision: 1.1 $ +# $Author: millert $ +# $Date: 2005/01/15 21:16:45 $ +# +################################################################################ +# +# Version 3.x, Copyright (C) 2004, Marcus Holland-Moritz. +# Version 2.x, Copyright (C) 2001, Paul Marquess. +# Version 1.x, Copyright (C) 1999, Kenneth Albanowski. +# +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. +# +################################################################################ + +sub parse_todo +{ + my $dir = shift || 'parts/todo'; + local *TODO; + my %todo; + my $todo; + + for $todo (glob "$dir/*") { + open TODO, $todo or die "cannot open $todo: $!\n"; + my $perl = <TODO>; + chomp $perl; + while (<TODO>) { + chomp; + s/#.*//; + s/^\s+//; s/\s+$//; + /^\s*$/ and next; + /^\w+$/ or die "invalid identifier: $_\n"; + exists $todo{$_} and die "duplicate identifier: $_ ($todo{$_} <=> $perl)\n"; + $todo{$_} = $perl; + } + close TODO; + } + + return \%todo; +} + +sub expand_version +{ + my($op, $ver) = @_; + my($r, $v, $s) = parse_version($ver); + $r == 5 or die "only Perl revision 5 is supported\n"; + $op eq '==' and return "((PERL_VERSION == $v) && (PERL_SUBVERSION == $s))"; + $op eq '!=' and return "((PERL_VERSION != $v) || (PERL_SUBVERSION != $s))"; + $op =~ /([<>])/ and return "((PERL_VERSION $1 $v) || ((PERL_VERSION == $v) && (PERL_SUBVERSION $op $s)))"; + die "cannot expand version expression ($op $ver)\n"; +} + +sub parse_partspec +{ + my $file = shift; + my $section = 'implementation'; + my $vsec = join '|', qw( provides dontwarn implementation + xsubs xsinit xsmisc xshead xsboot tests ); + my(%data, %options); + local *F; + + open F, $file or die "$file: $!\n"; + while (<F>) { + /^##/ and next; + if (/^=($vsec)(?:\s+(.*))?/) { + $section = $1; + if (defined $2) { + my $opt = $2; + $options{$section} = eval "{ $opt }"; + $@ and die "Invalid options ($opt) in section $section of $file: $@\n"; + } + next; + } + push @{$data{$section}}, $_; + } + close F; + + for (keys %data) { + my @v = @{$data{$_}}; + shift @v while @v && $v[0] =~ /^\s*$/; + pop @v while @v && $v[-1] =~ /^\s*$/; + $data{$_} = join '', @v; + } + + unless (exists $data{provides}) { + $data{provides} = ($file =~ /(\w+)$/)[0]; + } + $data{provides} = [$data{provides} =~ /(\S+)/g]; + + if (exists $data{dontwarn}) { + $data{dontwarn} = [$data{dontwarn} =~ /(\S+)/g]; + } + + my @prov; + my %proto; + + if (exists $data{tests} && (!exists $data{implementation} || $data{implementation} !~ /\S/)) { + $data{implementation} = ''; + } + else { + $data{implementation} =~ /\S/ or die "Empty implementation in $file\n"; + + my $p; + + for $p (@{$data{provides}}) { + if ($p =~ m#^/.*/\w*$#) { + my @tmp = eval "\$data{implementation} =~ ${p}gm"; + $@ and die "invalid regex $p in $file\n"; + @tmp or warn "no matches for regex $p in $file\n"; + push @prov, do { my %h; grep !$h{$_}++, @tmp }; + } + elsif ($p eq '__UNDEFINED__') { + my @tmp = $data{implementation} =~ /^\s*__UNDEFINED__[^\r\n\S]+(\w+)/gm; + @tmp or warn "no __UNDEFINED__ macros in $file\n"; + push @prov, @tmp; + } + else { + push @prov, $p; + } + } + + for (@prov) { + if ($data{implementation} !~ /\b\Q$_\E\b/) { + warn "$file claims to provide $_, but doesn't seem to do so\n"; + next; + } + + # scan for prototypes + my($proto) = $data{implementation} =~ / + ( ^ (?:[\w*]|[^\S\r\n])+ + [\r\n]*? + ^ \b$_\b \s* + \( [^{]* \) + ) + \s* \{ + /xm or next; + + $proto =~ s/^\s+//; + $proto =~ s/\s+$//; + $proto =~ s/\s+/ /g; + + exists $proto{$_} and warn "$file: duplicate prototype for $_\n"; + $proto{$_} = $proto; + } + } + + for $section (qw( implementation xsubs xsinit xsmisc xshead xsboot )) { + if (exists $data{$section}) { + $data{$section} =~ s/\{\s*version\s*(<|>|==|!=|>=|<=)\s*([\d._]+)\s*\}/expand_version($1, $2)/gei; + } + } + + $data{provides} = \@prov; + $data{prototypes} = \%proto; + $data{OPTIONS} = \%options; + + my %prov = map { ($_ => 1) } @prov; + my %dontwarn = exists $data{dontwarn} ? map { ($_ => 1) } @{$data{dontwarn}} : (); + my @maybeprov = do { my %h; + grep { + my($nop) = /^Perl_(.*)/; + not exists $prov{$_} || + exists $dontwarn{$_} || + (defined $nop && exists $prov{$nop} ) || + (defined $nop && exists $dontwarn{$nop}) || + $h{$_}++; + } + $data{implementation} =~ /^\s*#\s*define\s+(\w+)/g }; + + if (@maybeprov) { + warn "$file seems to provide these macros, but doesn't list them:\n " + . join("\n ", @maybeprov) . "\n"; + } + + return \%data; +} + +sub compare_prototypes +{ + my($p1, $p2) = @_; + for ($p1, $p2) { + s/^\s+//; + s/\s+$//; + s/\s+/ /g; + s/(\w)\s(\W)/$1$2/g; + s/(\W)\s(\w)/$1$2/g; + } + return $p1 cmp $p2; +} + +sub ppcond +{ + my $s = shift; + my @c; + my $p; + + for $p (@$s) { + push @c, map "!($_)", @{$p->{pre}}; + defined $p->{cur} and push @c, "($p->{cur})"; + } + + join " && ", @c; +} + +sub trim_arg +{ + my $in = shift; + + $in eq '...' and return ($in); + + local $_ = $in; + my $id; + + s/[*()]/ /g; + s/\[[^\]]*\]/ /g; + s/\b(?:auto|const|extern|inline|register|static|volatile|restrict)\b//g; + s/^\s*//; s/\s*$//; + + if( /^\b(?:struct|union|enum)\s+\w+(?:\s+(\w+))?$/ ) { + defined $1 and $id = $1; + } + else { + if( s/\b(?:char|double|float|int|long|short|signed|unsigned|void)\b//g ) { + /^\s*(\w+)\s*$/ and $id = $1; + } + else { + /^\s*\w+\s+(\w+)\s*$/ and $id = $1; + } + } + + $_ = $in; + + defined $id and s/\b$id\b//; + + # these don't matter at all + s/\b(?:auto|extern|inline|register|static|volatile|restrict)\b//g; + + s/(?=<\*)\s+(?=\*)//g; + s/\s*(\*+)\s*/ $1 /g; + s/^\s*//; s/\s*$//; + s/\s+/ /g; + + return ($_, $id); +} + +sub parse_embed +{ + my @files = @_; + my @func; + my @pps; + my $file; + local *FILE; + + for $file (@files) { + open FILE, $file or die "$file: $!\n"; + my($line, $l); + + while (defined($line = <FILE>)) { + while ($line =~ /\\$/ && defined($l = <FILE>)) { + $line =~ s/\\\s*//; + $line .= $l; + } + next if $line =~ /^\s*:/; + $line =~ s/^\s+|\s+$//gs; + my($dir, $args) = ($line =~ /^\s*#\s*(\w+)(?:\s*(.*?)\s*)?$/); + if (defined $dir and defined $args) { + for ($dir) { + /^ifdef$/ and do { push @pps, { pre => [], cur => "defined($args)" } ; last }; + /^ifndef$/ and do { push @pps, { pre => [], cur => "!defined($args)" } ; last }; + /^if$/ and do { push @pps, { pre => [], cur => $args } ; last }; + /^elif$/ and do { push @{$pps[-1]{pre}}, $pps[-1]{cur}; $pps[-1]{cur} = $args; last }; + /^else$/ and do { push @{$pps[-1]{pre}}, $pps[-1]{cur}; $pps[-1]{cur} = undef; last }; + /^endif$/ and do { pop @pps ; last }; + /^include$/ and last; + /^define$/ and last; + /^undef$/ and last; + warn "unhandled preprocessor directive: $dir\n"; + } + } + else { + my @e = split /\s*\|\s*/, $line; + if( @e >= 3 ) { + my($flags, $ret, $name, @args) = @e; + for (@args) { + $_ = [trim_arg($_)]; + } + ($ret) = trim_arg($ret); + push @func, { + name => $name, + flags => { map { $_, 1 } $flags =~ /./g }, + ret => $ret, + args => \@args, + cond => ppcond(\@pps), + }; + } + } + } + + close FILE; + } + + return @func; +} + +sub make_prototype +{ + my $f = shift; + my @args = map { "@$_" } @{$f->{args}}; + my $proto; + my $pTHX_ = exists $f->{flags}{n} ? "" : "pTHX_ "; + $proto = "$f->{ret} $f->{name}" . "($pTHX_" . join(', ', @args) . ')'; + return $proto; +} + +sub format_version +{ + my $ver = shift; + + $ver =~ s/$/000000/; + my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/; + + $v = int $v; + $s = int $s; + + if ($r < 5 || ($r == 5 && $v < 6)) { + if ($s % 10) { + die "invalid version '$ver'\n"; + } + $s /= 10; + + $ver = sprintf "%d.%03d", $r, $v; + $s > 0 and $ver .= sprintf "_%02d", $s; + + return $ver; + } + + return sprintf "%d.%d.%d", $r, $v, $s; +} + +sub parse_version +{ + my $ver = shift; + + if ($ver =~ /^(\d+)\.(\d+)\.(\d+)$/) { + return ($1, $2, $3); + } + elsif ($ver !~ /^\d+\.[\d_]+$/) { + die "cannot parse version '$ver'\n"; + } + + $ver =~ s/_//g; + $ver =~ s/$/000000/; + + my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/; + + $v = int $v; + $s = int $s; + + if ($r < 5 || ($r == 5 && $v < 6)) { + if ($s % 10) { + die "cannot parse version '$ver'\n"; + } + $s /= 10; + } + + return ($r, $v, $s); +} + +1; diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5004000 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5004000 new file mode 100644 index 00000000000..58f01f5f2f8 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5004000 @@ -0,0 +1,65 @@ +5.004000 +GIMME_V # E +G_VOID # E +HEf_SVKEY # E +HeHASH # U +HeKEY # E +HeKLEN # U +HePV # E +HeSVKEY # E +HeSVKEY_force # E +HeSVKEY_set # E +HeVAL # E +SvSetMagicSV # U +SvSetMagicSV_nosteal # U +SvSetSV_nosteal # U +SvTAINTED # U +SvTAINTED_off # U +SvTAINTED_on # U +block_gimme # U +call_list # U +cv_const_sv # E +delimcpy # E +do_open # E (Perl_do_open) +form # E +gv_autoload4 # E +gv_efullname3 # U +gv_fetchmethod_autoload # E +gv_fullname3 # U +hv_delayfree_ent # U +hv_delete_ent # E +hv_exists_ent # U +hv_fetch_ent # E +hv_free_ent # U +hv_iterkeysv # E +hv_ksplit # U +hv_store_ent # E +ibcmp_locale # U +my_failure_exit # U +my_memcmp # U +my_pclose # E (Perl_my_pclose) +my_popen # E (Perl_my_popen) +newSVpvf # E +rsignal # E +rsignal_state # E +save_I16 # U +save_gp # U +start_subparse # E (Perl_start_subparse) +sv_catpvf # U +sv_catpvf_mg # U +sv_cmp_locale # U +sv_derived_from # U +sv_gets # E (Perl_sv_gets) +sv_setpvf # U +sv_setpvf_mg # U +sv_taint # U +sv_tainted # U +sv_untaint # U +sv_vcatpvf # U +sv_vcatpvf_mg # U +sv_vcatpvfn # U +sv_vsetpvf # U +sv_vsetpvf_mg # U +sv_vsetpvfn # U +unsharepvn # U +vnewSVpvf # E diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5004010 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5004010 new file mode 100644 index 00000000000..8c298666039 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5004010 @@ -0,0 +1 @@ +5.004010 diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5004020 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5004020 new file mode 100644 index 00000000000..4b43fdf8e46 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5004020 @@ -0,0 +1 @@ +5.004020 diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5004030 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5004030 new file mode 100644 index 00000000000..e45facbb1f9 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5004030 @@ -0,0 +1 @@ +5.004030 diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5004040 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5004040 new file mode 100644 index 00000000000..9920f573c48 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5004040 @@ -0,0 +1,2 @@ +5.004040 +newWHILEOP # E (Perl_newWHILEOP) diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5004050 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5004050 new file mode 100644 index 00000000000..f1c9f8942a7 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5004050 @@ -0,0 +1,4 @@ +5.004050 +do_binmode # U +save_aelem # U +save_helem # U diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5005000 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5005000 new file mode 100644 index 00000000000..e0eecec5205 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5005000 @@ -0,0 +1,27 @@ +5.005000 +PL_modglobal # E +cx_dump # U +debop # U +debprofdump # U +fbm_compile # E (Perl_fbm_compile) +fbm_instr # E (Perl_fbm_instr) +get_op_descs # E +get_op_names # E +init_stacks # U +mg_length # U +mg_size # U +newHVhv # E +new_stackinfo # E +regdump # U +regexec_flags # U +regnext # E (Perl_regnext) +runops_debug # U +runops_standard # U +save_hints # U +save_iv # U (save_iv) +save_threadsv # E +screaminstr # E (Perl_screaminstr) +sv_iv # U +sv_nv # U +sv_peek # U +sv_true # U diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5005010 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5005010 new file mode 100644 index 00000000000..deebff5bf8a --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5005010 @@ -0,0 +1 @@ +5.005010 diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5005020 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5005020 new file mode 100644 index 00000000000..d19ff2ae09e --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5005020 @@ -0,0 +1 @@ +5.005020 diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5005030 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5005030 new file mode 100644 index 00000000000..362e8f27738 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5005030 @@ -0,0 +1,4 @@ +5.005030 +POPpx # E +get_vtbl # E +save_generic_svref # U diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5005040 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5005040 new file mode 100644 index 00000000000..8a165c20337 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5005040 @@ -0,0 +1 @@ +5.005040 diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5006000 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5006000 new file mode 100644 index 00000000000..b1e9b26ad0e --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5006000 @@ -0,0 +1,156 @@ +5.006000 +SvIOK_UV # U +SvIOK_notUV # U +SvIOK_only_UV # U +SvPOK_only_UTF8 # U +SvPVbyte_nolen # E +SvPVbytex # E +SvPVbytex_force # E +SvPVutf8 # E +SvPVutf8_force # E +SvPVutf8_nolen # E +SvPVutf8x # E +SvPVutf8x_force # E +SvUTF8 # U +SvUTF8_off # U +SvUTF8_on # U +av_delete # E +av_exists # U +call_atexit # E +cast_i32 # U (cast_i32) +cast_iv # U (cast_iv) +cast_ulong # U +cast_uv # U (cast_uv) +do_gv_dump # U +do_gvgv_dump # U +do_hv_dump # U +do_magic_dump # U +do_op_dump # U +do_open9 # U +do_pmop_dump # U +do_sv_dump # U +dump_all # U +dump_eval # U +dump_form # U +dump_indent # U +dump_packsubs # U +dump_sub # U +dump_vindent # U +get_context # E +get_ppaddr # E +gv_dump # U +init_i18nl10n # U (perl_init_i18nl10n) +init_i18nl14n # U (perl_init_i18nl14n) +is_uni_alnum # U +is_uni_alnum_lc # U +is_uni_alnumc # U +is_uni_alnumc_lc # U +is_uni_alpha # U +is_uni_alpha_lc # U +is_uni_ascii # U +is_uni_ascii_lc # U +is_uni_cntrl # U +is_uni_cntrl_lc # U +is_uni_digit # U +is_uni_digit_lc # U +is_uni_graph # U +is_uni_graph_lc # U +is_uni_idfirst # U +is_uni_idfirst_lc # U +is_uni_lower # U +is_uni_lower_lc # U +is_uni_print # U +is_uni_print_lc # U +is_uni_punct # U +is_uni_punct_lc # U +is_uni_space # U +is_uni_space_lc # U +is_uni_upper # U +is_uni_upper_lc # U +is_uni_xdigit # U +is_uni_xdigit_lc # U +is_utf8_alnum # U +is_utf8_alnumc # U +is_utf8_alpha # U +is_utf8_ascii # U +is_utf8_char # U +is_utf8_cntrl # U +is_utf8_digit # U +is_utf8_graph # U +is_utf8_idfirst # U +is_utf8_lower # U +is_utf8_mark # U +is_utf8_print # U +is_utf8_punct # U +is_utf8_space # U +is_utf8_upper # U +is_utf8_xdigit # U +load_module # U +magic_dump # U +mess # E (Perl_mess) +my_atof # U +my_fflush_all # U +newANONATTRSUB # E +newATTRSUB # E +newMYSUB # U +newPADOP # E +newXS # E (Perl_newXS) +newXSproto # E +new_collate # U (perl_new_collate) +new_ctype # U (perl_new_ctype) +new_numeric # U (perl_new_numeric) +op_dump # U +perl_parse # E (perl_parse) +pmop_dump # U +pv_display # E +re_intuit_start # E +re_intuit_string # E +reginitcolors # U +require_pv # U (perl_require_pv) +safesyscalloc # E +safesysfree # U +safesysmalloc # E +safesysrealloc # E +save_I8 # U +save_alloc # U +save_destructor # E (Perl_save_destructor) +save_destructor_x # E +save_re_context # U +save_vptr # U +scan_bin # U +set_context # U +set_numeric_local # U (perl_set_numeric_local) +set_numeric_radix # U +set_numeric_standard # U (perl_set_numeric_standard) +str_to_version # U +sv_2pvutf8 # E +sv_2pvutf8_nolen # E +sv_force_normal # U +sv_len_utf8 # U +sv_pos_b2u # U +sv_pos_u2b # U +sv_pv # E +sv_pvbyte # E +sv_pvbyten # E +sv_pvbyten_force # E +sv_pvutf8 # E +sv_pvutf8n # E +sv_pvutf8n_force # E +sv_rvweaken # E +sv_utf8_decode # U +sv_utf8_downgrade # U +sv_utf8_encode # U +swash_init # E +tmps_grow # U +to_uni_lower_lc # U +to_uni_title_lc # U +to_uni_upper_lc # U +utf8_distance # U +utf8_hop # E +vcroak # U +vform # E +vload_module # U +vmess # E +vwarn # U +vwarner # U +warner # U diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5006001 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5006001 new file mode 100644 index 00000000000..bb24f78e754 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5006001 @@ -0,0 +1,10 @@ +5.006001 +apply_attrs_string # U +bytes_to_utf8 # E +gv_efullname4 # U +gv_fullname4 # U +is_utf8_string # U +save_generic_pvref # U +utf16_to_utf8 # E (Perl_utf16_to_utf8) +utf16_to_utf8_reversed # E (Perl_utf16_to_utf8_reversed) +utf8_to_bytes # E diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5006002 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5006002 new file mode 100644 index 00000000000..dfe09ce2c59 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5006002 @@ -0,0 +1 @@ +5.006002 diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5007000 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5007000 new file mode 100644 index 00000000000..49d08465db8 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5007000 @@ -0,0 +1 @@ +5.007000 diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5007001 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5007001 new file mode 100644 index 00000000000..b5039cef8da --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5007001 @@ -0,0 +1,25 @@ +5.007001 +POPpbytex # E +SvUOK # U +bytes_from_utf8 # E +csighandler # U +despatch_signals # U +do_openn # U +gv_handler # E +is_lvalue_sub # U +my_popen_list # E +newSVpvn_share # E +save_mortalizesv # U +save_padsv # U +scan_num # E (Perl_scan_num) +sv_force_normal_flags # U +sv_setref_uv # E +sv_unref_flags # U +sv_utf8_upgrade # E (Perl_sv_utf8_upgrade) +utf8_length # U +utf8_to_uvchr # U +utf8_to_uvuni # U +utf8n_to_uvchr # U +utf8n_to_uvuni # U +uvchr_to_utf8 # E +uvuni_to_utf8 # E diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5007002 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5007002 new file mode 100644 index 00000000000..805bcae5cd4 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5007002 @@ -0,0 +1,18 @@ +5.007002 +calloc # E +getcwd_sv # U +init_tm # U +malloc # E +mfree # U +mini_mktime # U +my_atof2 # E +my_strftime # E +op_null # U +realloc # E +sv_2pv_flags # E +sv_catpvn_flags # U +sv_catsv_flags # U +sv_pvn_force_flags # E +sv_setsv_flags # U +sv_utf8_upgrade_flags # U +swash_fetch # E (Perl_swash_fetch) diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5007003 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5007003 new file mode 100644 index 00000000000..a742bdcf3be --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5007003 @@ -0,0 +1,64 @@ +5.007003 +PerlIO_clearerr # E (PerlIO_clearerr) +PerlIO_close # E (PerlIO_close) +PerlIO_eof # E (PerlIO_eof) +PerlIO_error # E (PerlIO_error) +PerlIO_fileno # E (PerlIO_fileno) +PerlIO_fill # E (PerlIO_fill) +PerlIO_flush # E (PerlIO_flush) +PerlIO_get_base # E (PerlIO_get_base) +PerlIO_get_bufsiz # E (PerlIO_get_bufsiz) +PerlIO_get_cnt # E (PerlIO_get_cnt) +PerlIO_get_ptr # E (PerlIO_get_ptr) +PerlIO_read # E (PerlIO_read) +PerlIO_seek # E (PerlIO_seek) +PerlIO_set_cnt # E (PerlIO_set_cnt) +PerlIO_set_ptrcnt # E (PerlIO_set_ptrcnt) +PerlIO_setlinebuf # E (PerlIO_setlinebuf) +PerlIO_stderr # E (PerlIO_stderr) +PerlIO_stdin # E (PerlIO_stdin) +PerlIO_stdout # E (PerlIO_stdout) +PerlIO_tell # E (PerlIO_tell) +PerlIO_unread # E (PerlIO_unread) +PerlIO_write # E (PerlIO_write) +SvLOCK # E +SvSHARE # E +SvUNLOCK # E +atfork_lock # E +atfork_unlock # E +custom_op_desc # E +custom_op_name # E +deb # U +debstack # U +debstackptrs # U +gv_fetchmeth_autoload # E +ibcmp_utf8 # E +my_fork # E +my_socketpair # E +pack_cat # E +perl_destruct # E (perl_destruct) +pv_uni_display # E +regclass_swash # E (Perl_regclass_swash) +save_shared_pvref # E +savesharedpv # E +sortsv # E +sv_copypv # E +sv_magicext # E +sv_nolocking # E +sv_nosharing # E +sv_nounlocking # E +sv_recode_to_utf8 # E +sv_uni_display # E +to_uni_fold # E +to_uni_lower # E (Perl_to_uni_lower) +to_uni_title # E (Perl_to_uni_title) +to_uni_upper # E (Perl_to_uni_upper) +to_utf8_case # E +to_utf8_fold # E +to_utf8_lower # E (Perl_to_utf8_lower) +to_utf8_title # E (Perl_to_utf8_title) +to_utf8_upper # E (Perl_to_utf8_upper) +unpack_str # E +uvchr_to_utf8_flags # E +uvuni_to_utf8_flags # E +vdeb # U diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5008000 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5008000 new file mode 100644 index 00000000000..461ce9cba79 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5008000 @@ -0,0 +1,5 @@ +5.008000 +hv_iternext_flags # E +hv_store_flags # E +is_utf8_idcont # U +nothreadhook # U diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5008001 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5008001 new file mode 100644 index 00000000000..595263f05b9 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5008001 @@ -0,0 +1,13 @@ +5.008001 +SvVOK # U +doing_taint # U +is_utf8_string_loc # U +packlist # U +save_bool # U +savestack_grow_cnt # U +scan_vstring # E +sv_cat_decode # U +sv_compile_2op # E (Perl_sv_compile_2op) +sv_setpviv # U +sv_setpviv_mg # U +unpackstring # U diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5008002 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5008002 new file mode 100644 index 00000000000..63aac525fed --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5008002 @@ -0,0 +1 @@ +5.008002 diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5008003 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5008003 new file mode 100644 index 00000000000..50c6ce1aa14 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5008003 @@ -0,0 +1,3 @@ +5.008003 +SvIsCOW # U +SvIsCOW_shared_hash # U diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5008004 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5008004 new file mode 100644 index 00000000000..bb7bcdf66ac --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5008004 @@ -0,0 +1 @@ +5.008004 diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5008005 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5008005 new file mode 100644 index 00000000000..7bd2029f4b3 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5008005 @@ -0,0 +1 @@ +5.008005 diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5009000 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5009000 new file mode 100644 index 00000000000..8b45dc7ba02 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5009000 @@ -0,0 +1,7 @@ +5.009000 +new_version # E +save_set_svflags # U +upg_version # E +vcmp # U +vnumify # E +vstringify # E diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5009001 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5009001 new file mode 100644 index 00000000000..19e05e4992e --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5009001 @@ -0,0 +1,7 @@ +5.009001 +hv_assert # U +hv_clear_placeholders # U +hv_scalar # E +scan_version # E (Perl_scan_version) +sv_2iv_flags # U +sv_2uv_flags # U diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5009002 b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5009002 new file mode 100644 index 00000000000..90f6bbe3d00 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/parts/todo/5009002 @@ -0,0 +1,4 @@ +5.009002 +SvPVbyte_force # E +find_rundefsvoffset # U +vnormal # E diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/t/MY_CXT.t b/gnu/usr.bin/perl/ext/Devel/PPPort/t/MY_CXT.t new file mode 100755 index 00000000000..e9f1238307c --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/t/MY_CXT.t @@ -0,0 +1,41 @@ +################################################################################ +# +# !!!!! Do NOT edit this file directly! !!!!! +# +# Edit mktests.PL and/or parts/inc/MY_CXT instead. +# +################################################################################ + +BEGIN { + if ($ENV{'PERL_CORE'}) { + chdir 't' if -d 't'; + @INC = ('../lib', '../ext/Devel/PPPort/t') if -d '../lib' && -d '../ext'; + require Config; import Config; + use vars '%Config'; + if (" $Config{'extensions'} " !~ m[ Devel/PPPort ]) { + print "1..0 # Skip -- Perl configured without Devel::PPPort module\n"; + exit 0; + } + } + else { + unshift @INC, 't'; + } + + eval "use Test"; + if ($@) { + require 'testutil.pl'; + print "1..3\n"; + } + else { + plan(tests => 3); + } +} + +use Devel::PPPort; +use strict; +$^W = 1; + +ok(&Devel::PPPort::MY_CXT_1()); +ok(&Devel::PPPort::MY_CXT_2()); +ok(&Devel::PPPort::MY_CXT_CLONE()); + diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/t/SvPV.t b/gnu/usr.bin/perl/ext/Devel/PPPort/t/SvPV.t new file mode 100755 index 00000000000..5e6009c3a46 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/t/SvPV.t @@ -0,0 +1,40 @@ +################################################################################ +# +# !!!!! Do NOT edit this file directly! !!!!! +# +# Edit mktests.PL and/or parts/inc/SvPV instead. +# +################################################################################ + +BEGIN { + if ($ENV{'PERL_CORE'}) { + chdir 't' if -d 't'; + @INC = ('../lib', '../ext/Devel/PPPort/t') if -d '../lib' && -d '../ext'; + require Config; import Config; + use vars '%Config'; + if (" $Config{'extensions'} " !~ m[ Devel/PPPort ]) { + print "1..0 # Skip -- Perl configured without Devel::PPPort module\n"; + exit 0; + } + } + else { + unshift @INC, 't'; + } + + eval "use Test"; + if ($@) { + require 'testutil.pl'; + print "1..2\n"; + } + else { + plan(tests => 2); + } +} + +use Devel::PPPort; +use strict; +$^W = 1; + +ok(&Devel::PPPort::SvPVbyte("mhx"), 3); +ok(&Devel::PPPort::SvPVbyte("mhx"), 3); + diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/t/call.t b/gnu/usr.bin/perl/ext/Devel/PPPort/t/call.t new file mode 100755 index 00000000000..ffcfcc4b2dd --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/t/call.t @@ -0,0 +1,89 @@ +################################################################################ +# +# !!!!! Do NOT edit this file directly! !!!!! +# +# Edit mktests.PL and/or parts/inc/call instead. +# +################################################################################ + +BEGIN { + if ($ENV{'PERL_CORE'}) { + chdir 't' if -d 't'; + @INC = ('../lib', '../ext/Devel/PPPort/t') if -d '../lib' && -d '../ext'; + require Config; import Config; + use vars '%Config'; + if (" $Config{'extensions'} " !~ m[ Devel/PPPort ]) { + print "1..0 # Skip -- Perl configured without Devel::PPPort module\n"; + exit 0; + } + } + else { + unshift @INC, 't'; + } + + eval "use Test"; + if ($@) { + require 'testutil.pl'; + print "1..44\n"; + } + else { + plan(tests => 44); + } +} + +use Devel::PPPort; +use strict; +$^W = 1; + +sub eq_array +{ + my($a, $b) = @_; + join(':', @$a) eq join(':', @$b); +} + +sub f +{ + shift; + unshift @_, 'b'; + pop @_; + @_, defined wantarray ? wantarray ? 'x' : 'y' : 'z'; +} + +my $obj = bless [], 'Foo'; + +sub Foo::meth +{ + return 'bad_self' unless @_ && ref $_[0] && ref($_[0]) eq 'Foo'; + shift; + shift; + unshift @_, 'b'; + pop @_; + @_, defined wantarray ? wantarray ? 'x' : 'y' : 'z'; +} + +my $test; + +for $test ( + # flags args expected description + [ &Devel::PPPort::G_SCALAR, [ ], [ qw(y 1) ], '0 args, G_SCALAR' ], + [ &Devel::PPPort::G_SCALAR, [ qw(a p q) ], [ qw(y 1) ], '3 args, G_SCALAR' ], + [ &Devel::PPPort::G_ARRAY, [ ], [ qw(x 1) ], '0 args, G_ARRAY' ], + [ &Devel::PPPort::G_ARRAY, [ qw(a p q) ], [ qw(b p x 3) ], '3 args, G_ARRAY' ], + [ &Devel::PPPort::G_DISCARD, [ ], [ qw(0) ], '0 args, G_DISCARD' ], + [ &Devel::PPPort::G_DISCARD, [ qw(a p q) ], [ qw(0) ], '3 args, G_DISCARD' ], +) +{ + my ($flags, $args, $expected, $description) = @$test; + print "# --- $description ---\n"; + ok(eq_array( [ &Devel::PPPort::call_sv(\&f, $flags, @$args) ], $expected)); + ok(eq_array( [ &Devel::PPPort::call_sv(*f, $flags, @$args) ], $expected)); + ok(eq_array( [ &Devel::PPPort::call_sv('f', $flags, @$args) ], $expected)); + ok(eq_array( [ &Devel::PPPort::call_pv('f', $flags, @$args) ], $expected)); + ok(eq_array( [ &Devel::PPPort::call_argv('f', $flags, @$args) ], $expected)); + ok(eq_array( [ &Devel::PPPort::eval_sv("f(qw(@$args))", $flags) ], $expected)); + ok(eq_array( [ &Devel::PPPort::call_method('meth', $flags, $obj, @$args) ], $expected)); +}; + +ok(&Devel::PPPort::eval_pv('f()', 0), 'y'); +ok(&Devel::PPPort::eval_pv('f(qw(a b c))', 0), 'y'); + diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/t/cop.t b/gnu/usr.bin/perl/ext/Devel/PPPort/t/cop.t new file mode 100755 index 00000000000..1bcc9996e36 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/t/cop.t @@ -0,0 +1,49 @@ +################################################################################ +# +# !!!!! Do NOT edit this file directly! !!!!! +# +# Edit mktests.PL and/or parts/inc/cop instead. +# +################################################################################ + +BEGIN { + if ($ENV{'PERL_CORE'}) { + chdir 't' if -d 't'; + @INC = ('../lib', '../ext/Devel/PPPort/t') if -d '../lib' && -d '../ext'; + require Config; import Config; + use vars '%Config'; + if (" $Config{'extensions'} " !~ m[ Devel/PPPort ]) { + print "1..0 # Skip -- Perl configured without Devel::PPPort module\n"; + exit 0; + } + } + else { + unshift @INC, 't'; + } + + eval "use Test"; + if ($@) { + require 'testutil.pl'; + print "1..2\n"; + } + else { + plan(tests => 2); + } +} + +use Devel::PPPort; +use strict; +$^W = 1; + +my $package; +{ + package MyPackage; + $package = &Devel::PPPort::CopSTASHPV(); +} +print "# $package\n"; +ok($package, "MyPackage"); + +my $file = &Devel::PPPort::CopFILE(); +print "# $file\n"; +ok($file =~ /cop/i); + diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/t/grok.t b/gnu/usr.bin/perl/ext/Devel/PPPort/t/grok.t new file mode 100755 index 00000000000..8766b353d60 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/t/grok.t @@ -0,0 +1,49 @@ +################################################################################ +# +# !!!!! Do NOT edit this file directly! !!!!! +# +# Edit mktests.PL and/or parts/inc/grok instead. +# +################################################################################ + +BEGIN { + if ($ENV{'PERL_CORE'}) { + chdir 't' if -d 't'; + @INC = ('../lib', '../ext/Devel/PPPort/t') if -d '../lib' && -d '../ext'; + require Config; import Config; + use vars '%Config'; + if (" $Config{'extensions'} " !~ m[ Devel/PPPort ]) { + print "1..0 # Skip -- Perl configured without Devel::PPPort module\n"; + exit 0; + } + } + else { + unshift @INC, 't'; + } + + eval "use Test"; + if ($@) { + require 'testutil.pl'; + print "1..10\n"; + } + else { + plan(tests => 10); + } +} + +use Devel::PPPort; +use strict; +$^W = 1; + +ok(&Devel::PPPort::grok_number("42"), 42); +ok(!defined(&Devel::PPPort::grok_number("A"))); +ok(&Devel::PPPort::grok_bin("10000001"), 129); +ok(&Devel::PPPort::grok_hex("deadbeef"), 0xdeadbeef); +ok(&Devel::PPPort::grok_oct("377"), 255); + +ok(&Devel::PPPort::Perl_grok_number("42"), 42); +ok(!defined(&Devel::PPPort::Perl_grok_number("A"))); +ok(&Devel::PPPort::Perl_grok_bin("10000001"), 129); +ok(&Devel::PPPort::Perl_grok_hex("deadbeef"), 0xdeadbeef); +ok(&Devel::PPPort::Perl_grok_oct("377"), 255); + diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/t/limits.t b/gnu/usr.bin/perl/ext/Devel/PPPort/t/limits.t new file mode 100755 index 00000000000..1ccb8b1df03 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/t/limits.t @@ -0,0 +1,42 @@ +################################################################################ +# +# !!!!! Do NOT edit this file directly! !!!!! +# +# Edit mktests.PL and/or parts/inc/limits instead. +# +################################################################################ + +BEGIN { + if ($ENV{'PERL_CORE'}) { + chdir 't' if -d 't'; + @INC = ('../lib', '../ext/Devel/PPPort/t') if -d '../lib' && -d '../ext'; + require Config; import Config; + use vars '%Config'; + if (" $Config{'extensions'} " !~ m[ Devel/PPPort ]) { + print "1..0 # Skip -- Perl configured without Devel::PPPort module\n"; + exit 0; + } + } + else { + unshift @INC, 't'; + } + + eval "use Test"; + if ($@) { + require 'testutil.pl'; + print "1..4\n"; + } + else { + plan(tests => 4); + } +} + +use Devel::PPPort; +use strict; +$^W = 1; + +ok(&Devel::PPPort::iv_size()); +ok(&Devel::PPPort::uv_size()); +ok(&Devel::PPPort::iv_type()); +ok(&Devel::PPPort::uv_type()); + diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/t/mPUSH.t b/gnu/usr.bin/perl/ext/Devel/PPPort/t/mPUSH.t new file mode 100755 index 00000000000..66c62f9b612 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/t/mPUSH.t @@ -0,0 +1,47 @@ +################################################################################ +# +# !!!!! Do NOT edit this file directly! !!!!! +# +# Edit mktests.PL and/or parts/inc/mPUSH instead. +# +################################################################################ + +BEGIN { + if ($ENV{'PERL_CORE'}) { + chdir 't' if -d 't'; + @INC = ('../lib', '../ext/Devel/PPPort/t') if -d '../lib' && -d '../ext'; + require Config; import Config; + use vars '%Config'; + if (" $Config{'extensions'} " !~ m[ Devel/PPPort ]) { + print "1..0 # Skip -- Perl configured without Devel::PPPort module\n"; + exit 0; + } + } + else { + unshift @INC, 't'; + } + + eval "use Test"; + if ($@) { + require 'testutil.pl'; + print "1..8\n"; + } + else { + plan(tests => 8); + } +} + +use Devel::PPPort; +use strict; +$^W = 1; + +ok(join(':', &Devel::PPPort::mPUSHp()), "one:two:three"); +ok(join(':', &Devel::PPPort::mPUSHn()), "0.5:-0.25:0.125"); +ok(join(':', &Devel::PPPort::mPUSHi()), "-1:2:-3"); +ok(join(':', &Devel::PPPort::mPUSHu()), "1:2:3"); + +ok(join(':', &Devel::PPPort::mXPUSHp()), "one:two:three"); +ok(join(':', &Devel::PPPort::mXPUSHn()), "0.5:-0.25:0.125"); +ok(join(':', &Devel::PPPort::mXPUSHi()), "-1:2:-3"); +ok(join(':', &Devel::PPPort::mXPUSHu()), "1:2:3"); + diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/t/magic.t b/gnu/usr.bin/perl/ext/Devel/PPPort/t/magic.t new file mode 100755 index 00000000000..8f73dc69d1e --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/t/magic.t @@ -0,0 +1,73 @@ +################################################################################ +# +# !!!!! Do NOT edit this file directly! !!!!! +# +# Edit mktests.PL and/or parts/inc/magic instead. +# +################################################################################ + +BEGIN { + if ($ENV{'PERL_CORE'}) { + chdir 't' if -d 't'; + @INC = ('../lib', '../ext/Devel/PPPort/t') if -d '../lib' && -d '../ext'; + require Config; import Config; + use vars '%Config'; + if (" $Config{'extensions'} " !~ m[ Devel/PPPort ]) { + print "1..0 # Skip -- Perl configured without Devel::PPPort module\n"; + exit 0; + } + } + else { + unshift @INC, 't'; + } + + eval "use Test"; + if ($@) { + require 'testutil.pl'; + print "1..10\n"; + } + else { + plan(tests => 10); + } +} + +use Devel::PPPort; +use strict; +$^W = 1; + +use Tie::Hash; +my %h; +tie %h, 'Tie::StdHash'; +$h{foo} = 'foo'; +$h{bar} = ''; + +&Devel::PPPort::sv_catpv_mg($h{foo}, 'bar'); +ok($h{foo}, 'foobar'); + +&Devel::PPPort::sv_catpvn_mg($h{bar}, 'baz'); +ok($h{bar}, 'baz'); + +&Devel::PPPort::sv_catsv_mg($h{foo}, '42'); +ok($h{foo}, 'foobar42'); + +&Devel::PPPort::sv_setiv_mg($h{bar}, 42); +ok($h{bar}, 42); + +&Devel::PPPort::sv_setnv_mg($h{PI}, 3.14159); +ok(abs($h{PI} - 3.14159) < 0.01); + +&Devel::PPPort::sv_setpv_mg($h{mhx}, 'mhx'); +ok($h{mhx}, 'mhx'); + +&Devel::PPPort::sv_setpvn_mg($h{mhx}, 'Marcus'); +ok($h{mhx}, 'Marcus'); + +&Devel::PPPort::sv_setsv_mg($h{sv}, 'SV'); +ok($h{sv}, 'SV'); + +&Devel::PPPort::sv_setuv_mg($h{sv}, 4711); +ok($h{sv}, 4711); + +&Devel::PPPort::sv_usepvn_mg($h{sv}, 'Perl'); +ok($h{sv}, 'Perl'); + diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/t/misc.t b/gnu/usr.bin/perl/ext/Devel/PPPort/t/misc.t new file mode 100755 index 00000000000..20f53a799bc --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/t/misc.t @@ -0,0 +1,88 @@ +################################################################################ +# +# !!!!! Do NOT edit this file directly! !!!!! +# +# Edit mktests.PL and/or parts/inc/misc instead. +# +################################################################################ + +BEGIN { + if ($ENV{'PERL_CORE'}) { + chdir 't' if -d 't'; + @INC = ('../lib', '../ext/Devel/PPPort/t') if -d '../lib' && -d '../ext'; + require Config; import Config; + use vars '%Config'; + if (" $Config{'extensions'} " !~ m[ Devel/PPPort ]) { + print "1..0 # Skip -- Perl configured without Devel::PPPort module\n"; + exit 0; + } + } + else { + unshift @INC, 't'; + } + + eval "use Test"; + if ($@) { + require 'testutil.pl'; + print "1..31\n"; + } + else { + plan(tests => 31); + } +} + +use Devel::PPPort; +use strict; +$^W = 1; + +use vars qw($my_sv @my_av %my_hv); + +my @s = &Devel::PPPort::newSVpvn(); +ok(@s == 5); +ok($s[0], "test"); +ok($s[1], "te"); +ok($s[2], ""); +ok(!defined($s[3])); +ok(!defined($s[4])); + +ok(!defined(&Devel::PPPort::PL_sv_undef())); +ok(&Devel::PPPort::PL_sv_yes()); +ok(!&Devel::PPPort::PL_sv_no()); +ok(&Devel::PPPort::PL_na("abcd"), 4); + +ok(&Devel::PPPort::boolSV(1)); +ok(!&Devel::PPPort::boolSV(0)); + +$_ = "Fred"; +ok(&Devel::PPPort::DEFSV(), "Fred"); +ok(&Devel::PPPort::UNDERBAR(), "Fred"); + +eval { 1 }; +ok(!&Devel::PPPort::ERRSV()); +eval { cannot_call_this_one() }; +ok(&Devel::PPPort::ERRSV()); + +ok(&Devel::PPPort::gv_stashpvn('Devel::PPPort', 0)); +ok(!&Devel::PPPort::gv_stashpvn('does::not::exist', 0)); +ok(&Devel::PPPort::gv_stashpvn('does::not::exist', 1)); + +$my_sv = 1; +ok(&Devel::PPPort::get_sv('my_sv', 0)); +ok(!&Devel::PPPort::get_sv('not_my_sv', 0)); +ok(&Devel::PPPort::get_sv('not_my_sv', 1)); + +@my_av = (1); +ok(&Devel::PPPort::get_av('my_av', 0)); +ok(!&Devel::PPPort::get_av('not_my_av', 0)); +ok(&Devel::PPPort::get_av('not_my_av', 1)); + +%my_hv = (a=>1); +ok(&Devel::PPPort::get_hv('my_hv', 0)); +ok(!&Devel::PPPort::get_hv('not_my_hv', 0)); +ok(&Devel::PPPort::get_hv('not_my_hv', 1)); + +sub my_cv { 1 }; +ok(&Devel::PPPort::get_cv('my_cv', 0)); +ok(!&Devel::PPPort::get_cv('not_my_cv', 0)); +ok(&Devel::PPPort::get_cv('not_my_cv', 1)); + diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/t/newCONSTSUB.t b/gnu/usr.bin/perl/ext/Devel/PPPort/t/newCONSTSUB.t new file mode 100755 index 00000000000..c40fc49631b --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/t/newCONSTSUB.t @@ -0,0 +1,46 @@ +################################################################################ +# +# !!!!! Do NOT edit this file directly! !!!!! +# +# Edit mktests.PL and/or parts/inc/newCONSTSUB instead. +# +################################################################################ + +BEGIN { + if ($ENV{'PERL_CORE'}) { + chdir 't' if -d 't'; + @INC = ('../lib', '../ext/Devel/PPPort/t') if -d '../lib' && -d '../ext'; + require Config; import Config; + use vars '%Config'; + if (" $Config{'extensions'} " !~ m[ Devel/PPPort ]) { + print "1..0 # Skip -- Perl configured without Devel::PPPort module\n"; + exit 0; + } + } + else { + unshift @INC, 't'; + } + + eval "use Test"; + if ($@) { + require 'testutil.pl'; + print "1..3\n"; + } + else { + plan(tests => 3); + } +} + +use Devel::PPPort; +use strict; +$^W = 1; + +&Devel::PPPort::call_newCONSTSUB_1(); +ok(&Devel::PPPort::test_value_1(), 1); + +&Devel::PPPort::call_newCONSTSUB_2(); +ok(&Devel::PPPort::test_value_2(), 2); + +&Devel::PPPort::call_newCONSTSUB_3(); +ok(&Devel::PPPort::test_value_3(), 3); + diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/t/newRV.t b/gnu/usr.bin/perl/ext/Devel/PPPort/t/newRV.t new file mode 100755 index 00000000000..e5baf9e8941 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/t/newRV.t @@ -0,0 +1,40 @@ +################################################################################ +# +# !!!!! Do NOT edit this file directly! !!!!! +# +# Edit mktests.PL and/or parts/inc/newRV instead. +# +################################################################################ + +BEGIN { + if ($ENV{'PERL_CORE'}) { + chdir 't' if -d 't'; + @INC = ('../lib', '../ext/Devel/PPPort/t') if -d '../lib' && -d '../ext'; + require Config; import Config; + use vars '%Config'; + if (" $Config{'extensions'} " !~ m[ Devel/PPPort ]) { + print "1..0 # Skip -- Perl configured without Devel::PPPort module\n"; + exit 0; + } + } + else { + unshift @INC, 't'; + } + + eval "use Test"; + if ($@) { + require 'testutil.pl'; + print "1..2\n"; + } + else { + plan(tests => 2); + } +} + +use Devel::PPPort; +use strict; +$^W = 1; + +ok(&Devel::PPPort::newRV_inc_REFCNT, 1); +ok(&Devel::PPPort::newRV_noinc_REFCNT, 1); + diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/t/ppphtest.t b/gnu/usr.bin/perl/ext/Devel/PPPort/t/ppphtest.t new file mode 100755 index 00000000000..e1cf0eddc32 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/t/ppphtest.t @@ -0,0 +1,594 @@ +################################################################################ +# +# !!!!! Do NOT edit this file directly! !!!!! +# +# Edit mktests.PL and/or parts/inc/ppphtest instead. +# +################################################################################ + +BEGIN { + if ($ENV{'PERL_CORE'}) { + chdir 't' if -d 't'; + @INC = ('../lib', '../ext/Devel/PPPort/t') if -d '../lib' && -d '../ext'; + require Config; import Config; + use vars '%Config'; + if (" $Config{'extensions'} " !~ m[ Devel/PPPort ]) { + print "1..0 # Skip -- Perl configured without Devel::PPPort module\n"; + exit 0; + } + } + else { + unshift @INC, 't'; + } + + eval "use Test"; + if ($@) { + require 'testutil.pl'; + print "1..134\n"; + } + else { + plan(tests => 134); + } +} + +use Devel::PPPort; +use strict; +$^W = 1; + +use File::Path qw/rmtree mkpath/; +use Config; + +my $tmp = 'ppptmp'; +my $inc = ''; +my $perl = find_perl(); + +rmtree($tmp) if -d $tmp; +mkpath($tmp) or die "mkpath $tmp: $!\n"; +chdir($tmp) or die "chdir $tmp: $!\n"; + +if ($ENV{'PERL_CORE'}) { + if (-d '../../lib') { + $inc = $^O eq 'VMS' ? '-"I../../lib"' : '-I../../lib'; + unshift @INC, '../../lib'; + } +} +if ($perl =~ m!^\./!) { + $perl = ".$perl"; +} + +END { + chdir('..') if !-d $tmp && -d "../$tmp"; + rmtree($tmp) if -d $tmp; +} + +ok(&Devel::PPPort::WriteFile("ppport.h")); + +sub ppport +{ + my @args = @_; + print "# *** running $perl $inc ppport.h @args ***\n"; + my $out = join '', `$perl $inc ppport.h @args`; + my $copy = $out; + $copy =~ s/^/# | /mg; + print "$copy\n"; + return $out; +} + +sub matches +{ + my($str, $re, $mod) = @_; + my @n; + eval "\@n = \$str =~ /$re/g$mod;"; + if ($@) { + my $err = $@; + $err =~ s/^/# *** /mg; + print "# *** ERROR ***\n$err\n"; + } + return $@ ? -42 : scalar @n; +} + +sub eq_files +{ + my($f1, $f2) = @_; + return 0 unless -e $f1 && -e $f2; + local *F; + for ($f1, $f2) { + print "# File: $_\n"; + unless (open F, $_) { + print "# couldn't open $_: $!\n"; + return 0; + } + $_ = do { local $/; <F> }; + close F; + my $copy = $_; + $copy =~ s/^/# | /mg; + print "$copy\n"; + } + return $f1 eq $f2; +} + +my @tests; + +for (split /\s*={70,}\s*/, do { local $/; <DATA> }) { + s/^\s+//; s/\s+$//; + my($c, %f); + ($c, @f{m/-{20,}\s+(\S+)\s+-{20,}/g}) = split /\s*-{20,}\s+\S+\s+-{20,}\s*/; + push @tests, { code => $c, files => \%f }; +} + +my $t; +for $t (@tests) { + my $f; + for $f (keys %{$t->{files}}) { + my @f = split /\//, $f; + if (@f > 1) { + pop @f; + my $path = join '/', @f; + mkpath($path) or die "mkpath('$path'): $!\n"; + } + my $txt = $t->{files}{$f}; + local *F; + open F, ">$f" or die "open $f: $!\n"; + print F "$txt\n"; + close F; + $txt =~ s/^/# | /mg; + print "# *** writing $f ***\n$txt\n"; + } + + eval $t->{code}; + if ($@) { + my $err = $@; + $err =~ s/^/# *** /mg; + print "# *** ERROR ***\n$err\n"; + } + ok($@, ''); + + for (keys %{$t->{files}}) { + unlink $_ or die "unlink('$_'): $!\n"; + } +} + +sub find_perl +{ + my $perl = $^X; + + return $perl if $^O eq 'VMS'; + + my $exe = $Config{'_exe'} || ''; + + if ($perl =~ /^perl\Q$exe\E$/i) { + $perl = "perl$exe"; + eval "require File::Spec"; + if ($@) { + $perl = "./$perl"; + } else { + $perl = File::Spec->catfile(File::Spec->curdir(), $perl); + } + } + + if ($perl !~ /\Q$exe\E$/i) { + $perl .= $exe; + } + + warn "find_perl: cannot find $perl from $^X" unless -f $perl; + + return $perl; +} + +__DATA__ + +my $o = ppport(qw(--help)); +ok($o =~ /^Usage:.*ppport\.h/m); +ok($o =~ /--help/m); + +$o = ppport(qw(--nochanges)); +ok($o =~ /^scanning.*test\.xs/mi); +ok($o =~ /analyzing.*test\.xs/mi); +ok(matches($o, '^scanning', 'mi'), 1); +ok(matches($o, 'analyzing', 'mi'), 1); +ok($o =~ /Uses Perl_newSViv instead of newSViv/); + +$o = ppport(qw(--quiet --nochanges)); +ok($o =~ /^\s*$/); + +---------------------------- test.xs ------------------------------------------ + +Perl_newSViv(); + +=============================================================================== + +# check if C and C++ comments are filtered correctly + +my $o = ppport(qw(--copy=a)); +ok($o =~ /^scanning.*MyExt\.xs/mi); +ok($o =~ /analyzing.*MyExt\.xs/mi); +ok(matches($o, '^scanning', 'mi'), 1); +ok($o =~ /^Needs to include.*ppport\.h/m); +ok($o !~ /^Uses grok_bin/m); +ok($o !~ /^Uses newSVpv/m); +ok($o =~ /Uses 1 C\+\+ style comment/m); +ok(eq_files('MyExt.xsa', 'MyExt.ra')); + +# check if C++ are left untouched with --cplusplus + +$o = ppport(qw(--copy=b --cplusplus)); +ok($o =~ /^scanning.*MyExt\.xs/mi); +ok($o =~ /analyzing.*MyExt\.xs/mi); +ok(matches($o, '^scanning', 'mi'), 1); +ok($o =~ /^Needs to include.*ppport\.h/m); +ok($o !~ /^Uses grok_bin/m); +ok($o !~ /^Uses newSVpv/m); +ok($o !~ /Uses \d+ C\+\+ style comment/m); +ok(eq_files('MyExt.xsb', 'MyExt.rb')); + +unlink qw(MyExt.xsa MyExt.xsb); + +---------------------------- MyExt.xs ----------------------------------------- + +newSVuv(); + // newSVpv(); + XPUSHs(foo); +/* grok_bin(); */ + +---------------------------- MyExt.ra ----------------------------------------- + +#include "ppport.h" +newSVuv(); + /* newSVpv(); */ + XPUSHs(foo); +/* grok_bin(); */ + +---------------------------- MyExt.rb ----------------------------------------- + +#include "ppport.h" +newSVuv(); + // newSVpv(); + XPUSHs(foo); +/* grok_bin(); */ + +=============================================================================== + +my $o = ppport(qw(--nochanges file1.xs)); +ok($o =~ /^scanning.*file1\.xs/mi); +ok($o =~ /analyzing.*file1\.xs/mi); +ok($o !~ /^scanning.*file2\.xs/mi); +ok($o =~ /^Uses newCONSTSUB/m); +ok($o =~ /^Uses SvPV_nolen.*depends.*sv_2pv_nolen/m); +ok($o =~ /hint for newCONSTSUB/m); +ok($o !~ /hint for sv_2pv_nolen/m); +ok($o =~ /^Looks good/m); + +$o = ppport(qw(--nochanges --nohints file1.xs)); +ok($o =~ /^scanning.*file1\.xs/mi); +ok($o =~ /analyzing.*file1\.xs/mi); +ok($o !~ /^scanning.*file2\.xs/mi); +ok($o =~ /^Uses newCONSTSUB/m); +ok($o =~ /^Uses SvPV_nolen.*depends.*sv_2pv_nolen/m); +ok($o !~ /hint for newCONSTSUB/m); +ok($o !~ /hint for sv_2pv_nolen/m); +ok($o =~ /^Looks good/m); + +$o = ppport(qw(--nochanges --nohints --nodiag file1.xs)); +ok($o =~ /^scanning.*file1\.xs/mi); +ok($o =~ /analyzing.*file1\.xs/mi); +ok($o !~ /^scanning.*file2\.xs/mi); +ok($o !~ /^Uses newCONSTSUB/m); +ok($o !~ /^Uses SvPV_nolen/m); +ok($o !~ /hint for newCONSTSUB/m); +ok($o !~ /hint for sv_2pv_nolen/m); +ok($o =~ /^Looks good/m); + +$o = ppport(qw(--nochanges --quiet file1.xs)); +ok($o =~ /^\s*$/); + +$o = ppport(qw(--nochanges file2.xs)); +ok($o =~ /^scanning.*file2\.xs/mi); +ok($o =~ /analyzing.*file2\.xs/mi); +ok($o !~ /^scanning.*file1\.xs/mi); +ok($o =~ /^Uses mXPUSHp/m); +ok($o =~ /^Needs to include.*ppport\.h/m); +ok($o !~ /^Looks good/m); +ok($o =~ /^1 potentially required change detected/m); + +$o = ppport(qw(--nochanges --nohints file2.xs)); +ok($o =~ /^scanning.*file2\.xs/mi); +ok($o =~ /analyzing.*file2\.xs/mi); +ok($o !~ /^scanning.*file1\.xs/mi); +ok($o =~ /^Uses mXPUSHp/m); +ok($o =~ /^Needs to include.*ppport\.h/m); +ok($o !~ /^Looks good/m); +ok($o =~ /^1 potentially required change detected/m); + +$o = ppport(qw(--nochanges --nohints --nodiag file2.xs)); +ok($o =~ /^scanning.*file2\.xs/mi); +ok($o =~ /analyzing.*file2\.xs/mi); +ok($o !~ /^scanning.*file1\.xs/mi); +ok($o !~ /^Uses mXPUSHp/m); +ok($o !~ /^Needs to include.*ppport\.h/m); +ok($o !~ /^Looks good/m); +ok($o =~ /^1 potentially required change detected/m); + +$o = ppport(qw(--nochanges --quiet file2.xs)); +ok($o =~ /^\s*$/); + +---------------------------- file1.xs ----------------------------------------- + +#define NEED_newCONSTSUB +#define NEED_sv_2pv_nolen +#include "ppport.h" + +newCONSTSUB(); +SvPV_nolen(); + +---------------------------- file2.xs ----------------------------------------- + +mXPUSHp(foo); + +=============================================================================== + +my $o = ppport(qw(--nochanges)); +ok($o =~ /^scanning.*FooBar\.xs/mi); +ok($o =~ /analyzing.*FooBar\.xs/mi); +ok(matches($o, '^scanning', 'mi'), 1); +ok($o !~ /^Looks good/m); +ok($o =~ /^Uses grok_bin/m); + +---------------------------- FooBar.xs ---------------------------------------- + +newSViv(); +XPUSHs(foo); +grok_bin(); + +=============================================================================== + +my $o = ppport(qw(--nochanges)); +ok($o =~ /^scanning.*First\.xs/mi); +ok($o =~ /analyzing.*First\.xs/mi); +ok($o =~ /^scanning.*second\.h/mi); +ok($o =~ /analyzing.*second\.h/mi); +ok($o =~ /^scanning.*sub.*third\.c/mi); +ok($o =~ /analyzing.*sub.*third\.c/mi); +ok($o !~ /^scanning.*foobar/mi); +ok(matches($o, '^scanning', 'mi'), 3); + +---------------------------- First.xs ----------------------------------------- + +one + +---------------------------- foobar.xyz --------------------------------------- + +two + +---------------------------- second.h ----------------------------------------- + +three + +---------------------------- sub/third.c -------------------------------------- + +four + +=============================================================================== + +my $o = ppport(qw(--nochanges)); +ok($o =~ /Possibly wrong #define NEED_foobar in.*test.xs/i); + +---------------------------- test.xs ------------------------------------------ + +#define NEED_foobar + +=============================================================================== + +# And now some complex "real-world" example + +my $o = ppport(qw(--copy=f)); +for (qw(main.xs mod1.c mod2.c mod3.c mod4.c mod5.c)) { + ok($o =~ /^scanning.*\Q$_\E/mi); + ok($o =~ /analyzing.*\Q$_\E/i); +} +ok(matches($o, '^scanning', 'mi'), 6); + +ok(matches($o, '^Writing copy of', 'mi'), 5); +ok(!-e "mod5.cf"); + +for (qw(main.xs mod1.c mod2.c mod3.c mod4.c)) { + ok($o =~ /^Writing copy of.*\Q$_\E.*with changes/mi); + ok(-e "${_}f"); + ok(eq_files("${_}f", "${_}r")); + unlink "${_}f"; +} + +---------------------------- main.xs ------------------------------------------ + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#define NEED_newCONSTSUB +#define NEED_grok_hex_GLOBAL +#include "ppport.h" + +newCONSTSUB(); +grok_hex(); +Perl_grok_bin(aTHX_ foo, bar); + +/* some comment */ + +perl_eval_pv(); +grok_bin(); +Perl_grok_bin(bar, sv_no); + +---------------------------- mod1.c ------------------------------------------- + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#define NEED_grok_bin_GLOBAL +#define NEED_newCONSTSUB +#include "ppport.h" + +newCONSTSUB(); +grok_bin(); +{ + Perl_croak ("foo"); + Perl_sv_catpvf(); /* I know it's wrong ;-) */ +} + +---------------------------- mod2.c ------------------------------------------- + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#define NEED_eval_pv +#include "ppport.h" + +newSViv(); + +/* + eval_pv(); +*/ + +---------------------------- mod3.c ------------------------------------------- + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +grok_oct(); +eval_pv(); + +---------------------------- mod4.c ------------------------------------------- + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +START_MY_CXT; + +---------------------------- mod5.c ------------------------------------------- + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#include "ppport.h" +call_pv(); + +---------------------------- main.xsr ----------------------------------------- + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#define NEED_eval_pv_GLOBAL +#define NEED_grok_hex +#define NEED_newCONSTSUB_GLOBAL +#include "ppport.h" + +newCONSTSUB(); +grok_hex(); +grok_bin(foo, bar); + +/* some comment */ + +eval_pv(); +grok_bin(); +grok_bin(bar, PL_sv_no); + +---------------------------- mod1.cr ------------------------------------------ + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#define NEED_grok_bin_GLOBAL +#include "ppport.h" + +newCONSTSUB(); +grok_bin(); +{ + Perl_croak (aTHX_ "foo"); + Perl_sv_catpvf(aTHX); /* I know it's wrong ;-) */ +} + +---------------------------- mod2.cr ------------------------------------------ + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + + +newSViv(); + +/* + eval_pv(); +*/ + +---------------------------- mod3.cr ------------------------------------------ + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" +#define NEED_grok_oct +#include "ppport.h" + +grok_oct(); +eval_pv(); + +---------------------------- mod4.cr ------------------------------------------ + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" +#include "ppport.h" + +START_MY_CXT; + +=============================================================================== + +my $o = ppport(qw(--nochanges)); +ok($o =~ /Uses grok_hex/m); +ok($o !~ /Looks good/m); + +$o = ppport(qw(--nochanges --compat-version=5.8.0)); +ok($o !~ /Uses grok_hex/m); +ok($o =~ /Looks good/m); + +---------------------------- FooBar.xs ---------------------------------------- + +grok_hex(); + +=============================================================================== + +my $o = ppport(qw(--nochanges)); +ok($o =~ /Uses SvPVutf8_force, which may not be portable/m); + +$o = ppport(qw(--nochanges --compat-version=5.6.0)); +ok($o !~ /Uses SvPVutf8_force/m); + +---------------------------- FooBar.xs ---------------------------------------- + +SvPVutf8_force(); + +=============================================================================== + +my $o = ppport(qw(--nochanges)); +ok($o !~ /potentially required change/); +ok(matches($o, '^Looks good', 'mi'), 2); + +---------------------------- FooBar.xs ---------------------------------------- + +#define NEED_grok_numeric_radix +#define NEED_grok_number +#include "ppport.h" + +GROK_NUMERIC_RADIX(); +grok_number(); + +---------------------------- foo.c -------------------------------------------- + +#include "ppport.h" + +call_pv(); + diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/t/sv_xpvf.t b/gnu/usr.bin/perl/ext/Devel/PPPort/t/sv_xpvf.t new file mode 100755 index 00000000000..33e203dde98 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/t/sv_xpvf.t @@ -0,0 +1,65 @@ +################################################################################ +# +# !!!!! Do NOT edit this file directly! !!!!! +# +# Edit mktests.PL and/or parts/inc/sv_xpvf instead. +# +################################################################################ + +BEGIN { + if ($ENV{'PERL_CORE'}) { + chdir 't' if -d 't'; + @INC = ('../lib', '../ext/Devel/PPPort/t') if -d '../lib' && -d '../ext'; + require Config; import Config; + use vars '%Config'; + if (" $Config{'extensions'} " !~ m[ Devel/PPPort ]) { + print "1..0 # Skip -- Perl configured without Devel::PPPort module\n"; + exit 0; + } + } + else { + unshift @INC, 't'; + } + + eval "use Test"; + if ($@) { + require 'testutil.pl'; + print "1..9\n"; + } + else { + plan(tests => 9); + } +} + +use Devel::PPPort; +use strict; +$^W = 1; + +use Tie::Hash; +my %h; +tie %h, 'Tie::StdHash'; +$h{foo} = 'foo-'; +$h{bar} = ''; + +ok(&Devel::PPPort::vnewSVpvf(), $] >= 5.004 ? 'Perl-42' : '%s-%d'); +ok(&Devel::PPPort::sv_vcatpvf('1-2-3-'), $] >= 5.004 ? '1-2-3-Perl-42' : '1-2-3-%s-%d'); +ok(&Devel::PPPort::sv_vsetpvf('1-2-3-'), $] >= 5.004 ? 'Perl-42' : '%s-%d'); + +&Devel::PPPort::sv_catpvf_mg($h{foo}); +ok($h{foo}, $] >= 5.004 ? 'foo-Perl-42' : 'foo-'); + +&Devel::PPPort::Perl_sv_catpvf_mg($h{foo}); +ok($h{foo}, $] >= 5.004 ? 'foo-Perl-42-Perl-43' : 'foo-'); + +&Devel::PPPort::sv_catpvf_mg_nocontext($h{foo}); +ok($h{foo}, $] >= 5.004 ? 'foo-Perl-42-Perl-43-Perl-44' : 'foo-'); + +&Devel::PPPort::sv_setpvf_mg($h{bar}); +ok($h{bar}, $] >= 5.004 ? 'mhx-42' : ''); + +&Devel::PPPort::Perl_sv_setpvf_mg($h{bar}); +ok($h{bar}, $] >= 5.004 ? 'foo-43' : ''); + +&Devel::PPPort::sv_setpvf_mg_nocontext($h{bar}); +ok($h{bar}, $] >= 5.004 ? 'bar-44' : ''); + diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/t/testutil.pl b/gnu/usr.bin/perl/ext/Devel/PPPort/t/testutil.pl new file mode 100644 index 00000000000..408553fd3bb --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/t/testutil.pl @@ -0,0 +1,32 @@ +{ + my $__ntest; + + sub ok ($;$$) { + local($\,$,); + my $ok = 0; + my $result = shift; + if (@_ == 0) { + $ok = $result; + } else { + $expected = shift; + if (!defined $expected) { + $ok = !defined $result; + } elsif (!defined $result) { + $ok = 0; + } elsif (ref($expected) eq 'Regexp') { + $ok = $result =~ /$expected/; + } else { + $ok = $result eq $expected; + } + } + ++$__ntest; + if ($ok) { + print "ok $__ntest\n" + } + else { + print "not ok $__ntest\n" + } + } +} + +1; diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/t/threads.t b/gnu/usr.bin/perl/ext/Devel/PPPort/t/threads.t new file mode 100755 index 00000000000..7243d8dda6e --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/t/threads.t @@ -0,0 +1,41 @@ +################################################################################ +# +# !!!!! Do NOT edit this file directly! !!!!! +# +# Edit mktests.PL and/or parts/inc/threads instead. +# +################################################################################ + +BEGIN { + if ($ENV{'PERL_CORE'}) { + chdir 't' if -d 't'; + @INC = ('../lib', '../ext/Devel/PPPort/t') if -d '../lib' && -d '../ext'; + require Config; import Config; + use vars '%Config'; + if (" $Config{'extensions'} " !~ m[ Devel/PPPort ]) { + print "1..0 # Skip -- Perl configured without Devel::PPPort module\n"; + exit 0; + } + } + else { + unshift @INC, 't'; + } + + eval "use Test"; + if ($@) { + require 'testutil.pl'; + print "1..2\n"; + } + else { + plan(tests => 2); + } +} + +use Devel::PPPort; +use strict; +$^W = 1; + +ok(&Devel::PPPort::no_THX_arg("42"), 43); +eval { &Devel::PPPort::with_THX_arg("yes\n"); }; +ok($@ =~ /^yes/); + diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/t/uv.t b/gnu/usr.bin/perl/ext/Devel/PPPort/t/uv.t new file mode 100755 index 00000000000..1272be7733e --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/t/uv.t @@ -0,0 +1,48 @@ +################################################################################ +# +# !!!!! Do NOT edit this file directly! !!!!! +# +# Edit mktests.PL and/or parts/inc/uv instead. +# +################################################################################ + +BEGIN { + if ($ENV{'PERL_CORE'}) { + chdir 't' if -d 't'; + @INC = ('../lib', '../ext/Devel/PPPort/t') if -d '../lib' && -d '../ext'; + require Config; import Config; + use vars '%Config'; + if (" $Config{'extensions'} " !~ m[ Devel/PPPort ]) { + print "1..0 # Skip -- Perl configured without Devel::PPPort module\n"; + exit 0; + } + } + else { + unshift @INC, 't'; + } + + eval "use Test"; + if ($@) { + require 'testutil.pl'; + print "1..10\n"; + } + else { + plan(tests => 10); + } +} + +use Devel::PPPort; +use strict; +$^W = 1; + +ok(&Devel::PPPort::sv_setuv(42), 42); +ok(&Devel::PPPort::newSVuv(123), 123); +ok(&Devel::PPPort::sv_2uv("4711"), 4711); +ok(&Devel::PPPort::sv_2uv("1735928559"), 1735928559); +ok(&Devel::PPPort::SvUVx("1735928559"), 1735928559); +ok(&Devel::PPPort::SvUVx(1735928559), 1735928559); +ok(&Devel::PPPort::SvUVx(0xdeadbeef), 0xdeadbeef); +ok(&Devel::PPPort::XSRETURN_UV(), 42); +ok(&Devel::PPPort::PUSHu(), 42); +ok(&Devel::PPPort::XPUSHu(), 43); + diff --git a/gnu/usr.bin/perl/ext/Devel/PPPort/typemap b/gnu/usr.bin/perl/ext/Devel/PPPort/typemap new file mode 100644 index 00000000000..e472d7ea623 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Devel/PPPort/typemap @@ -0,0 +1,35 @@ +################################################################################ +# +# typemap -- XS type mappings not present in early perls +# +################################################################################ +# +# $Revision: 1.1 $ +# $Author: millert $ +# $Date: 2005/01/15 21:16:45 $ +# +################################################################################ +# +# Version 3.x, Copyright (C) 2004, Marcus Holland-Moritz. +# Version 2.x, Copyright (C) 2001, Paul Marquess. +# Version 1.x, Copyright (C) 1999, Kenneth Albanowski. +# +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. +# +################################################################################ + +UV T_UV +NV T_NV + +INPUT +T_UV + $var = ($type)SvUV($arg) +T_NV + $var = ($type)SvNV($arg) + +OUTPUT +T_UV + sv_setuv($arg, (UV)$var); +T_NV + sv_setnv($arg, (NV)$var); diff --git a/gnu/usr.bin/perl/ext/Errno/Errno_pm.PL b/gnu/usr.bin/perl/ext/Errno/Errno_pm.PL index fdab9eededb..a795cfc822d 100644 --- a/gnu/usr.bin/perl/ext/Errno/Errno_pm.PL +++ b/gnu/usr.bin/perl/ext/Errno/Errno_pm.PL @@ -377,7 +377,8 @@ sub FIRSTKEY { sub EXISTS { my ($self, $errname) = @_; - my $proto = prototype($errname); + my $r = ref $errname; + my $proto = !$r || $r eq 'CODE' ? prototype($errname) : undef; defined($proto) && $proto eq ""; } diff --git a/gnu/usr.bin/perl/ext/Errno/t/Errno.t b/gnu/usr.bin/perl/ext/Errno/t/Errno.t index a879cf23ce9..a6b08e03f99 100644 --- a/gnu/usr.bin/perl/ext/Errno/t/Errno.t +++ b/gnu/usr.bin/perl/ext/Errno/t/Errno.t @@ -13,7 +13,7 @@ BEGIN { use Errno; -print "1..5\n"; +print "1..6\n"; print "not " unless @Errno::EXPORT_OK; print "ok 1\n"; @@ -53,3 +53,6 @@ if($s1 ne $s2) { } print "ok 5\n"; + +eval { exists $!{[]} }; +print $@ ? "not ok 6\n" : "ok 6\n"; diff --git a/gnu/usr.bin/perl/ext/Time/HiRes/ppport.h b/gnu/usr.bin/perl/ext/Time/HiRes/ppport.h new file mode 100644 index 00000000000..23d8894bdfd --- /dev/null +++ b/gnu/usr.bin/perl/ext/Time/HiRes/ppport.h @@ -0,0 +1,4812 @@ +#if 0 +<<'SKIP'; +#endif +/* +---------------------------------------------------------------------- + + ppport.h -- Perl/Pollution/Portability Version 3.03 + + Automatically created by Devel::PPPort running under + perl 5.008004 on Thu Sep 16 09:09:58 2004. + + Do NOT edit this file directly! -- Edit PPPort_pm.PL and the + includes in parts/inc/ instead. + + Use 'perldoc ppport.h' to view the documentation below. + +---------------------------------------------------------------------- + +SKIP + +=pod + +=head1 NAME + +ppport.h - Perl/Pollution/Portability version 3.03 + +=head1 SYNOPSIS + + perl ppport.h [options] [files] + + --help show short help + + --patch=file write one patch file with changes + --copy=suffix write changed copies with suffix + --diff=program use diff program and options + + --compat-version=version provide compatibility with Perl version + --cplusplus accept C++ comments + + --quiet don't output anything except fatal errors + --nodiag don't show diagnostics + --nohints don't show hints + --nochanges don't suggest changes + + --list-provided list provided API + --list-unsupported list unsupported API + +=head1 COMPATIBILITY + +This version of F<ppport.h> is designed to support operation with Perl +installations back to 5.003, and has been tested up to 5.9.2. + +=head1 OPTIONS + +=head2 --help + +Display a brief usage summary. + +=head2 --patch=I<file> + +If this option is given, a single patch file will be created if +any changes are suggested. This requires a working diff program +to be installed on your system. + +=head2 --copy=I<suffix> + +If this option is given, a copy of each file will be saved with +the given suffix that contains the suggested changes. This does +not require any external programs. + +If neither C<--patch> or C<--copy> are given, the default is to +simply print the diffs for each file. This requires either +C<Text::Diff> or a C<diff> program to be installed. + +=head2 --diff=I<program> + +Manually set the diff program and options to use. The default +is to use C<Text::Diff>, when installed, and output unified +context diffs. + +=head2 --compat-version=I<version> + +Tell F<ppport.h> to check for compatibility with the given +Perl version. The default is to check for compatibility with Perl +version 5.003. You can use this option to reduce the output +of F<ppport.h> if you intend to be backward compatible only +up to a certain Perl version. + +=head2 --cplusplus + +Usually, F<ppport.h> will detect C++ style comments and +replace them with C style comments for portability reasons. +Using this option instructs F<ppport.h> to leave C++ +comments untouched. + +=head2 --quiet + +Be quiet. Don't print anything except fatal errors. + +=head2 --nodiag + +Don't output any diagnostic messages. Only portability +alerts will be printed. + +=head2 --nohints + +Don't output any hints. Hints often contain useful portability +notes. + +=head2 --nochanges + +Don't suggest any changes. Only give diagnostic output and hints +unless these are also deactivated. + +=head2 --list-provided + +Lists the API elements for which compatibility is provided by +F<ppport.h>. Also lists if it must be explicitly requested, +if it has dependencies, and if there are hints for it. + +=head2 --list-unsupported + +Lists the API elements that are known not to be supported by +F<ppport.h> and below which version of Perl they probably +won't be available or work. + +=head1 DESCRIPTION + +In order for a Perl extension (XS) module to be as portable as possible +across differing versions of Perl itself, certain steps need to be taken. + +=over 4 + +=item * + +Including this header is the first major one. This alone will give you +access to a large part of the Perl API that hasn't been available in +earlier Perl releases. Use + + perl ppport.h --list-provided + +to see which API elements are provided by ppport.h. + +=item * + +You should avoid using deprecated parts of the API. For example, using +global Perl variables without the C<PL_> prefix is deprecated. Also, +some API functions used to have a C<perl_> prefix. Using this form is +also deprecated. You can safely use the supported API, as F<ppport.h> +will provide wrappers for older Perl versions. + +=item * + +If you use one of a few functions that were not present in earlier +versions of Perl, and that can't be provided using a macro, you have +to explicitly request support for these functions by adding one or +more C<#define>s in your source code before the inclusion of F<ppport.h>. + +These functions will be marked C<explicit> in the list shown by +C<--list-provided>. + +Depending on whether you module has a single or multiple files that +use such functions, you want either C<static> or global variants. + +For a C<static> function, use: + + #define NEED_function + +For a global function, use: + + #define NEED_function_GLOBAL + +Note that you mustn't have more than one global request for one +function in your project. + + Function Static Request Global Request + ----------------------------------------------------------------------------------------- + eval_pv() NEED_eval_pv NEED_eval_pv_GLOBAL + grok_bin() NEED_grok_bin NEED_grok_bin_GLOBAL + grok_hex() NEED_grok_hex NEED_grok_hex_GLOBAL + grok_number() NEED_grok_number NEED_grok_number_GLOBAL + grok_numeric_radix() NEED_grok_numeric_radix NEED_grok_numeric_radix_GLOBAL + grok_oct() NEED_grok_oct NEED_grok_oct_GLOBAL + newCONSTSUB() NEED_newCONSTSUB NEED_newCONSTSUB_GLOBAL + newRV_noinc() NEED_newRV_noinc NEED_newRV_noinc_GLOBAL + sv_2pv_nolen() NEED_sv_2pv_nolen NEED_sv_2pv_nolen_GLOBAL + sv_2pvbyte() NEED_sv_2pvbyte NEED_sv_2pvbyte_GLOBAL + sv_catpvf_mg() NEED_sv_catpvf_mg NEED_sv_catpvf_mg_GLOBAL + sv_catpvf_mg_nocontext() NEED_sv_catpvf_mg_nocontext NEED_sv_catpvf_mg_nocontext_GLOBAL + sv_setpvf_mg() NEED_sv_setpvf_mg NEED_sv_setpvf_mg_GLOBAL + sv_setpvf_mg_nocontext() NEED_sv_setpvf_mg_nocontext NEED_sv_setpvf_mg_nocontext_GLOBAL + vnewSVpvf() NEED_vnewSVpvf NEED_vnewSVpvf_GLOBAL + +To avoid namespace conflicts, you can change the namespace of the +explicitly exported functions using the C<DPPP_NAMESPACE> macro. +Just C<#define> the macro before including C<ppport.h>: + + #define DPPP_NAMESPACE MyOwnNamespace_ + #include "ppport.h" + +The default namespace is C<DPPP_>. + +=back + +The good thing is that most of the above can be checked by running +F<ppport.h> on your source code. See the next section for +details. + +=head1 EXAMPLES + +To verify whether F<ppport.h> is needed for your module, whether you +should make any changes to your code, and whether any special defines +should be used, F<ppport.h> can be run as a Perl script to check your +source code. Simply say: + + perl ppport.h + +The result will usually be a list of patches suggesting changes +that should at least be acceptable, if not necessarily the most +efficient solution, or a fix for all possible problems. + +If you know that your XS module uses features only available in +newer Perl releases, if you're aware that it uses C++ comments, +and if you want all suggestions as a single patch file, you could +use something like this: + + perl ppport.h --compat-version=5.6.0 --cplusplus --patch=test.diff + +If you only want your code to be scanned without any suggestions +for changes, use: + + perl ppport.h --nochanges + +You can specify a different C<diff> program or options, using +the C<--diff> option: + + perl ppport.h --diff='diff -C 10' + +This would output context diffs with 10 lines of context. + +=head1 BUGS + +If this version of F<ppport.h> is causing failure during +the compilation of this module, please check if newer versions +of either this module or C<Devel::PPPort> are available on CPAN +before sending a bug report. + +If F<ppport.h> was generated using the latest version of +C<Devel::PPPort> and is causing failure of this module, please +file a bug report using the CPAN Request Tracker at L<http://rt.cpan.org/>. + +Please include the following information: + +=over 4 + +=item 1. + +The complete output from running "perl -V" + +=item 2. + +This file. + +=item 3. + +The name and version of the module you were trying to build. + +=item 4. + +A full log of the build that failed. + +=item 5. + +Any other information that you think could be relevant. + +=back + +For the latest version of this code, please get the C<Devel::PPPort> +module from CPAN. + +=head1 COPYRIGHT + +Version 3.x, Copyright (c) 2004, Marcus Holland-Moritz. + +Version 2.x, Copyright (C) 2001, Paul Marquess. + +Version 1.x, Copyright (C) 1999, Kenneth Albanowski. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=head1 SEE ALSO + +See L<Devel::PPPort>. + +=cut + +use strict; + +my %opt = ( + quiet => 0, + diag => 1, + hints => 1, + changes => 1, + cplusplus => 0, +); + +my($ppport) = $0 =~ /([\w.]+)$/; +my $LF = '(?:\r\n|[\r\n])'; # line feed +my $HS = "[ \t]"; # horizontal whitespace + +eval { + require Getopt::Long; + Getopt::Long::GetOptions(\%opt, qw( + help quiet diag! hints! changes! cplusplus + patch=s copy=s diff=s compat-version=s + list-provided list-unsupported + )) or usage(); +}; + +if ($@ and grep /^-/, @ARGV) { + usage() if "@ARGV" =~ /^--?h(?:elp)?$/; + die "Getopt::Long not found. Please don't use any options.\n"; +} + +usage() if $opt{help}; + +if (exists $opt{'compat-version'}) { + my($r,$v,$s) = eval { parse_version($opt{'compat-version'}) }; + if ($@) { + die "Invalid version number format: '$opt{'compat-version'}'\n"; + } + die "Only Perl 5 is supported\n" if $r != 5; + die "Invalid version number: $opt{'compat-version'}\n" if $v >= 1000 || $v >= 1000; + $opt{'compat-version'} = sprintf "%d.%03d%03d", $r, $v, $s; +} +else { + $opt{'compat-version'} = 5; +} + +# Never use C comments in this file!!!!! +my $ccs = '/'.'*'; +my $cce = '*'.'/'; +my $rccs = quotemeta $ccs; +my $rcce = quotemeta $cce; + +my @files; + +if (@ARGV) { + @files = map { glob $_ } @ARGV; +} +else { + eval { + require File::Find; + File::Find::find(sub { + $File::Find::name =~ /\.(xs|c|h|cc)$/i + and push @files, $File::Find::name; + }, '.'); + }; + if ($@) { + @files = map { glob $_ } qw(*.xs *.c *.h *.cc); + } + my %filter = map { /(.*)\.xs$/ ? ("$1.c" => 1) : () } @files; + @files = grep { !/\b\Q$ppport\E$/i && !exists $filter{$_} } @files; +} + +unless (@files) { + die "No input files given!\n"; +} + +my %API = map { /^(\w+)\|([^|]*)\|([^|]*)\|(\w*)$/ + ? ( $1 => { + ($2 ? ( base => $2 ) : ()), + ($3 ? ( todo => $3 ) : ()), + (index($4, 'v') >= 0 ? ( varargs => 1 ) : ()), + (index($4, 'p') >= 0 ? ( provided => 1 ) : ()), + (index($4, 'n') >= 0 ? ( nothxarg => 1 ) : ()), + } ) + : die "invalid spec: $_" } qw( +AvFILLp|5.004050||p +AvFILL||| +CLASS|||n +CX_CURPAD_SAVE||| +CX_CURPAD_SV||| +CopFILEAV|5.006000||p +CopFILEGV_set|5.006000||p +CopFILEGV|5.006000||p +CopFILESV|5.006000||p +CopFILE_set|5.006000||p +CopFILE|5.006000||p +CopSTASHPV_set|5.006000||p +CopSTASHPV|5.006000||p +CopSTASH_eq|5.006000||p +CopSTASH_set|5.006000||p +CopSTASH|5.006000||p +CopyD|5.009002||p +Copy||| +CvPADLIST||| +CvSTASH||| +CvWEAKOUTSIDE||| +DEFSV|5.004050||p +END_EXTERN_C|5.005000||p +ENTER||| +ERRSV|5.004050||p +EXTEND||| +EXTERN_C|5.005000||p +FREETMPS||| +GIMME_V||5.004000|n +GIMME|||n +GROK_NUMERIC_RADIX|5.007002||p +G_ARRAY||| +G_DISCARD||| +G_EVAL||| +G_NOARGS||| +G_SCALAR||| +G_VOID||5.004000| +GetVars||| +GvSV||| +Gv_AMupdate||| +HEf_SVKEY||5.004000| +HeHASH||5.004000| +HeKEY||5.004000| +HeKLEN||5.004000| +HePV||5.004000| +HeSVKEY_force||5.004000| +HeSVKEY_set||5.004000| +HeSVKEY||5.004000| +HeVAL||5.004000| +HvNAME||| +INT2PTR|5.006000||p +IN_LOCALE_COMPILETIME|5.007002||p +IN_LOCALE_RUNTIME|5.007002||p +IN_LOCALE|5.007002||p +IN_PERL_COMPILETIME|5.008001||p +IS_NUMBER_GREATER_THAN_UV_MAX|5.007002||p +IS_NUMBER_INFINITY|5.007002||p +IS_NUMBER_IN_UV|5.007002||p +IS_NUMBER_NAN|5.007003||p +IS_NUMBER_NEG|5.007002||p +IS_NUMBER_NOT_INT|5.007002||p +IVSIZE|5.006000||p +IVTYPE|5.006000||p +IVdf|5.006000||p +LEAVE||| +LVRET||| +MARK||| +MY_CXT_CLONE|5.009002||p +MY_CXT_INIT|5.007003||p +MY_CXT|5.007003||p +MoveD|5.009002||p +Move||| +NEWSV||| +NOOP|5.005000||p +NUM2PTR|5.006000||p +NVTYPE|5.006000||p +NVef|5.006001||p +NVff|5.006001||p +NVgf|5.006001||p +Newc||| +Newz||| +New||| +Nullav||| +Nullch||| +Nullcv||| +Nullhv||| +Nullsv||| +ORIGMARK||| +PAD_BASE_SV||| +PAD_CLONE_VARS||| +PAD_COMPNAME_FLAGS||| +PAD_COMPNAME_GEN||| +PAD_COMPNAME_OURSTASH||| +PAD_COMPNAME_PV||| +PAD_COMPNAME_TYPE||| +PAD_RESTORE_LOCAL||| +PAD_SAVE_LOCAL||| +PAD_SAVE_SETNULLPAD||| +PAD_SETSV||| +PAD_SET_CUR_NOSAVE||| +PAD_SET_CUR||| +PAD_SVl||| +PAD_SV||| +PERL_BCDVERSION|5.009002||p +PERL_GCC_BRACE_GROUPS_FORBIDDEN|5.008001||p +PERL_INT_MAX|5.004000||p +PERL_INT_MIN|5.004000||p +PERL_LONG_MAX|5.004000||p +PERL_LONG_MIN|5.004000||p +PERL_MAGIC_arylen|5.007002||p +PERL_MAGIC_backref|5.007002||p +PERL_MAGIC_bm|5.007002||p +PERL_MAGIC_collxfrm|5.007002||p +PERL_MAGIC_dbfile|5.007002||p +PERL_MAGIC_dbline|5.007002||p +PERL_MAGIC_defelem|5.007002||p +PERL_MAGIC_envelem|5.007002||p +PERL_MAGIC_env|5.007002||p +PERL_MAGIC_ext|5.007002||p +PERL_MAGIC_fm|5.007002||p +PERL_MAGIC_glob|5.007002||p +PERL_MAGIC_isaelem|5.007002||p +PERL_MAGIC_isa|5.007002||p +PERL_MAGIC_mutex|5.007002||p +PERL_MAGIC_nkeys|5.007002||p +PERL_MAGIC_overload_elem|5.007002||p +PERL_MAGIC_overload_table|5.007002||p +PERL_MAGIC_overload|5.007002||p +PERL_MAGIC_pos|5.007002||p +PERL_MAGIC_qr|5.007002||p +PERL_MAGIC_regdata|5.007002||p +PERL_MAGIC_regdatum|5.007002||p +PERL_MAGIC_regex_global|5.007002||p +PERL_MAGIC_shared_scalar|5.007003||p +PERL_MAGIC_shared|5.007003||p +PERL_MAGIC_sigelem|5.007002||p +PERL_MAGIC_sig|5.007002||p +PERL_MAGIC_substr|5.007002||p +PERL_MAGIC_sv|5.007002||p +PERL_MAGIC_taint|5.007002||p +PERL_MAGIC_tiedelem|5.007002||p +PERL_MAGIC_tiedscalar|5.007002||p +PERL_MAGIC_tied|5.007002||p +PERL_MAGIC_utf8|5.008001||p +PERL_MAGIC_uvar_elem|5.007003||p +PERL_MAGIC_uvar|5.007002||p +PERL_MAGIC_vec|5.007002||p +PERL_MAGIC_vstring|5.008001||p +PERL_QUAD_MAX|5.004000||p +PERL_QUAD_MIN|5.004000||p +PERL_REVISION|5.006000||p +PERL_SCAN_ALLOW_UNDERSCORES|5.007003||p +PERL_SCAN_DISALLOW_PREFIX|5.007003||p +PERL_SCAN_GREATER_THAN_UV_MAX|5.007003||p +PERL_SCAN_SILENT_ILLDIGIT|5.008001||p +PERL_SHORT_MAX|5.004000||p +PERL_SHORT_MIN|5.004000||p +PERL_SUBVERSION|5.006000||p +PERL_UCHAR_MAX|5.004000||p +PERL_UCHAR_MIN|5.004000||p +PERL_UINT_MAX|5.004000||p +PERL_UINT_MIN|5.004000||p +PERL_ULONG_MAX|5.004000||p +PERL_ULONG_MIN|5.004000||p +PERL_UNUSED_DECL|5.007002||p +PERL_UQUAD_MAX|5.004000||p +PERL_UQUAD_MIN|5.004000||p +PERL_USHORT_MAX|5.004000||p +PERL_USHORT_MIN|5.004000||p +PERL_VERSION|5.006000||p +PL_DBsingle|||pn +PL_DBsub|||pn +PL_DBtrace|||n +PL_Sv|5.005000||p +PL_compiling|5.004050||p +PL_copline|5.005000||p +PL_curcop|5.004050||p +PL_curstash|5.004050||p +PL_debstash|5.004050||p +PL_defgv|5.004050||p +PL_diehook|5.004050||p +PL_dirty|5.004050||p +PL_dowarn|||pn +PL_errgv|5.004050||p +PL_hexdigit|5.005000||p +PL_hints|5.005000||p +PL_last_in_gv|||n +PL_modglobal||5.005000|n +PL_na|5.004050||pn +PL_no_modify|5.006000||p +PL_ofs_sv|||n +PL_perl_destruct_level|5.004050||p +PL_perldb|5.004050||p +PL_ppaddr|5.006000||p +PL_rsfp_filters|5.004050||p +PL_rsfp|5.004050||p +PL_rs|||n +PL_stack_base|5.004050||p +PL_stack_sp|5.004050||p +PL_stdingv|5.004050||p +PL_sv_arenaroot|5.004050||p +PL_sv_no|5.004050||pn +PL_sv_undef|5.004050||pn +PL_sv_yes|5.004050||pn +PL_tainted|5.004050||p +PL_tainting|5.004050||p +POPi|||n +POPl|||n +POPn|||n +POPpbytex||5.007001|n +POPpx||5.005030|n +POPp|||n +POPs|||n +PTR2IV|5.006000||p +PTR2NV|5.006000||p +PTR2UV|5.006000||p +PTR2ul|5.007001||p +PTRV|5.006000||p +PUSHMARK||| +PUSHi||| +PUSHmortal|5.009002||p +PUSHn||| +PUSHp||| +PUSHs||| +PUSHu|5.004000||p +PUTBACK||| +PerlIO_clearerr||5.007003| +PerlIO_close||5.007003| +PerlIO_eof||5.007003| +PerlIO_error||5.007003| +PerlIO_fileno||5.007003| +PerlIO_fill||5.007003| +PerlIO_flush||5.007003| +PerlIO_get_base||5.007003| +PerlIO_get_bufsiz||5.007003| +PerlIO_get_cnt||5.007003| +PerlIO_get_ptr||5.007003| +PerlIO_read||5.007003| +PerlIO_seek||5.007003| +PerlIO_set_cnt||5.007003| +PerlIO_set_ptrcnt||5.007003| +PerlIO_setlinebuf||5.007003| +PerlIO_stderr||5.007003| +PerlIO_stdin||5.007003| +PerlIO_stdout||5.007003| +PerlIO_tell||5.007003| +PerlIO_unread||5.007003| +PerlIO_write||5.007003| +Poison|5.008000||p +RETVAL|||n +Renewc||| +Renew||| +SAVECLEARSV||| +SAVECOMPPAD||| +SAVEPADSV||| +SAVETMPS||| +SAVE_DEFSV|5.004050||p +SPAGAIN||| +SP||| +START_EXTERN_C|5.005000||p +START_MY_CXT|5.007003||p +STMT_END|||p +STMT_START|||p +ST||| +SVt_IV||| +SVt_NV||| +SVt_PVAV||| +SVt_PVCV||| +SVt_PVHV||| +SVt_PVMG||| +SVt_PV||| +Safefree||| +Slab_Alloc||| +Slab_Free||| +StructCopy||| +SvCUR_set||| +SvCUR||| +SvEND||| +SvGETMAGIC|5.004050||p +SvGROW||| +SvIOK_UV||5.006000| +SvIOK_notUV||5.006000| +SvIOK_off||| +SvIOK_only_UV||5.006000| +SvIOK_only||| +SvIOK_on||| +SvIOKp||| +SvIOK||| +SvIVX||| +SvIV_nomg|5.009001||p +SvIVx||| +SvIV||| +SvIsCOW_shared_hash||5.008003| +SvIsCOW||5.008003| +SvLEN||| +SvLOCK||5.007003| +SvNIOK_off||| +SvNIOKp||| +SvNIOK||| +SvNOK_off||| +SvNOK_only||| +SvNOK_on||| +SvNOKp||| +SvNOK||| +SvNVX||| +SvNVx||| +SvNV||| +SvOK||| +SvOOK||| +SvPOK_off||| +SvPOK_only_UTF8||5.006000| +SvPOK_only||| +SvPOK_on||| +SvPOKp||| +SvPOK||| +SvPVX||| +SvPV_force_nomg|5.007002||p +SvPV_force||| +SvPV_nolen|5.006000||p +SvPV_nomg|5.007002||p +SvPVbyte_force||5.009002| +SvPVbyte_nolen||5.006000| +SvPVbytex_force||5.006000| +SvPVbytex||5.006000| +SvPVbyte|5.006000||p +SvPVutf8_force||5.006000| +SvPVutf8_nolen||5.006000| +SvPVutf8x_force||5.006000| +SvPVutf8x||5.006000| +SvPVutf8||5.006000| +SvPVx||| +SvPV||| +SvREFCNT_dec||| +SvREFCNT_inc||| +SvREFCNT||| +SvROK_off||| +SvROK_on||| +SvROK||| +SvRV||| +SvSETMAGIC||| +SvSHARE||5.007003| +SvSTASH||| +SvSetMagicSV_nosteal||5.004000| +SvSetMagicSV||5.004000| +SvSetSV_nosteal||5.004000| +SvSetSV||| +SvTAINTED_off||5.004000| +SvTAINTED_on||5.004000| +SvTAINTED||5.004000| +SvTAINT||| +SvTRUE||| +SvTYPE||| +SvUNLOCK||5.007003| +SvUOK||5.007001| +SvUPGRADE||| +SvUTF8_off||5.006000| +SvUTF8_on||5.006000| +SvUTF8||5.006000| +SvUVXx|5.004000||p +SvUVX|5.004000||p +SvUV_nomg|5.009001||p +SvUVx|5.004000||p +SvUV|5.004000||p +SvVOK||5.008001| +THIS|||n +UNDERBAR|5.009002||p +UVSIZE|5.006000||p +UVTYPE|5.006000||p +UVXf|5.007001||p +UVof|5.006000||p +UVuf|5.006000||p +UVxf|5.006000||p +XPUSHi||| +XPUSHmortal|5.009002||p +XPUSHn||| +XPUSHp||| +XPUSHs||| +XPUSHu|5.004000||p +XSRETURN_EMPTY||| +XSRETURN_IV||| +XSRETURN_NO||| +XSRETURN_NV||| +XSRETURN_PV||| +XSRETURN_UNDEF||| +XSRETURN_UV|5.008001||p +XSRETURN_YES||| +XSRETURN||| +XST_mIV||| +XST_mNO||| +XST_mNV||| +XST_mPV||| +XST_mUNDEF||| +XST_mUV|5.008001||p +XST_mYES||| +XS_VERSION_BOOTCHECK||| +XS_VERSION||| +XS||| +ZeroD|5.009002||p +Zero||| +_aMY_CXT|5.007003||p +_pMY_CXT|5.007003||p +aMY_CXT_|5.007003||p +aMY_CXT|5.007003||p +aTHX_|5.006000||p +aTHX|5.006000||p +add_data||| +allocmy||| +amagic_call||| +any_dup||| +ao||| +append_elem||| +append_list||| +apply_attrs_my||| +apply_attrs_string||5.006001| +apply_attrs||| +apply||| +asIV||| +asUV||| +atfork_lock||5.007003|n +atfork_unlock||5.007003|n +av_clear||| +av_delete||5.006000| +av_exists||5.006000| +av_extend||| +av_fake||| +av_fetch||| +av_fill||| +av_len||| +av_make||| +av_pop||| +av_push||| +av_reify||| +av_shift||| +av_store||| +av_undef||| +av_unshift||| +ax|||n +bad_type||| +bind_match||| +block_end||| +block_gimme||5.004000| +block_start||| +boolSV|5.004000||p +boot_core_PerlIO||| +boot_core_UNIVERSAL||| +boot_core_xsutils||| +bytes_from_utf8||5.007001| +bytes_to_utf8||5.006001| +cache_re||| +call_argv|5.006000||p +call_atexit||5.006000| +call_body||| +call_list_body||| +call_list||5.004000| +call_method|5.006000||p +call_pv|5.006000||p +call_sv|5.006000||p +calloc||5.007002|n +cando||| +cast_i32||5.006000| +cast_iv||5.006000| +cast_ulong||5.006000| +cast_uv||5.006000| +check_uni||| +checkcomma||| +checkposixcc||| +cl_and||| +cl_anything||| +cl_init_zero||| +cl_init||| +cl_is_anything||| +cl_or||| +closest_cop||| +convert||| +cop_free||| +cr_textfilter||| +croak_nocontext|||vn +croak|||v +csighandler||5.007001|n +custom_op_desc||5.007003| +custom_op_name||5.007003| +cv_ckproto||| +cv_clone||| +cv_const_sv||5.004000| +cv_dump||| +cv_undef||| +cx_dump||5.005000| +cx_dup||| +cxinc||| +dAX|5.007002||p +dITEMS|5.007002||p +dMARK||| +dMY_CXT_SV|5.007003||p +dMY_CXT|5.007003||p +dNOOP|5.006000||p +dORIGMARK||| +dSP||| +dTHR|5.004050||p +dTHXa|5.006000||p +dTHXoa|5.006000||p +dTHX|5.006000||p +dUNDERBAR|5.009002||p +dXSARGS||| +dXSI32||| +deb_curcv||| +deb_nocontext|||vn +deb_stack_all||| +deb_stack_n||| +debop||5.005000| +debprofdump||5.005000| +debprof||| +debstackptrs||5.007003| +debstack||5.007003| +deb||5.007003|v +default_protect|||v +del_he||| +del_sv||| +del_xiv||| +del_xnv||| +del_xpvav||| +del_xpvbm||| +del_xpvcv||| +del_xpvhv||| +del_xpviv||| +del_xpvlv||| +del_xpvmg||| +del_xpvnv||| +del_xpv||| +del_xrv||| +delimcpy||5.004000| +depcom||| +deprecate_old||| +deprecate||| +despatch_signals||5.007001| +die_nocontext|||vn +die_where||| +die|||v +dirp_dup||| +div128||| +djSP||| +do_aexec5||| +do_aexec||| +do_aspawn||| +do_binmode||5.004050| +do_chomp||| +do_chop||| +do_close||| +do_dump_pad||| +do_eof||| +do_exec3||| +do_execfree||| +do_exec||| +do_gv_dump||5.006000| +do_gvgv_dump||5.006000| +do_hv_dump||5.006000| +do_ipcctl||| +do_ipcget||| +do_join||| +do_kv||| +do_magic_dump||5.006000| +do_msgrcv||| +do_msgsnd||| +do_oddball||| +do_op_dump||5.006000| +do_open9||5.006000| +do_openn||5.007001| +do_open||5.004000| +do_pipe||| +do_pmop_dump||5.006000| +do_print||| +do_readline||| +do_seek||| +do_semop||| +do_shmio||| +do_spawn_nowait||| +do_spawn||| +do_sprintf||| +do_sv_dump||5.006000| +do_sysseek||| +do_tell||| +do_trans_complex_utf8||| +do_trans_complex||| +do_trans_count_utf8||| +do_trans_count||| +do_trans_simple_utf8||| +do_trans_simple||| +do_trans||| +do_vecget||| +do_vecset||| +do_vop||| +docatch_body||| +docatch||| +doencodes||| +doeval||| +dofile||| +dofindlabel||| +doform||| +doing_taint||5.008001|n +dooneliner||| +doopen_pm||| +doparseform||| +dopoptoeval||| +dopoptolabel||| +dopoptoloop||| +dopoptosub_at||| +dopoptosub||| +dounwind||| +dowantarray||| +dump_all||5.006000| +dump_eval||5.006000| +dump_fds||| +dump_form||5.006000| +dump_indent||5.006000|v +dump_mstats||| +dump_packsubs||5.006000| +dump_sub||5.006000| +dump_vindent||5.006000| +dumpuntil||| +dup_attrlist||| +emulate_eaccess||| +eval_pv|5.006000||p +eval_sv|5.006000||p +expect_number||| +fbm_compile||5.005000| +fbm_instr||5.005000| +fd_on_nosuid_fs||| +filter_add||| +filter_del||| +filter_gets||| +filter_read||| +find_beginning||| +find_byclass||| +find_in_my_stash||| +find_runcv||| +find_rundefsvoffset||5.009002| +find_script||| +find_uninit_var||| +fold_constants||| +forbid_setid||| +force_ident||| +force_list||| +force_next||| +force_version||| +force_word||| +form_nocontext|||vn +form||5.004000|v +fp_dup||| +fprintf_nocontext|||vn +free_tied_hv_pool||| +free_tmps||| +gen_constant_list||| +get_av|5.006000||p +get_context||5.006000|n +get_cv|5.006000||p +get_db_sub||| +get_debug_opts||| +get_hash_seed||| +get_hv|5.006000||p +get_mstats||| +get_no_modify||| +get_num||| +get_op_descs||5.005000| +get_op_names||5.005000| +get_opargs||| +get_ppaddr||5.006000| +get_sv|5.006000||p +get_vtbl||5.005030| +getcwd_sv||5.007002| +getenv_len||| +gp_dup||| +gp_free||| +gp_ref||| +grok_bin|5.007003||p +grok_hex|5.007003||p +grok_number|5.007002||p +grok_numeric_radix|5.007002||p +grok_oct|5.007003||p +group_end||| +gv_AVadd||| +gv_HVadd||| +gv_IOadd||| +gv_autoload4||5.004000| +gv_check||| +gv_dump||5.006000| +gv_efullname3||5.004000| +gv_efullname4||5.006001| +gv_efullname||| +gv_ename||| +gv_fetchfile||| +gv_fetchmeth_autoload||5.007003| +gv_fetchmethod_autoload||5.004000| +gv_fetchmethod||| +gv_fetchmeth||| +gv_fetchpv||| +gv_fullname3||5.004000| +gv_fullname4||5.006001| +gv_fullname||| +gv_handler||5.007001| +gv_init_sv||| +gv_init||| +gv_share||| +gv_stashpvn|5.006000||p +gv_stashpv||| +gv_stashsv||| +he_dup||| +hfreeentries||| +hsplit||| +hv_assert||5.009001| +hv_clear_placeholders||5.009001| +hv_clear||| +hv_delayfree_ent||5.004000| +hv_delete_common||| +hv_delete_ent||5.004000| +hv_delete||| +hv_exists_ent||5.004000| +hv_exists||| +hv_fetch_common||| +hv_fetch_ent||5.004000| +hv_fetch||| +hv_free_ent||5.004000| +hv_iterinit||| +hv_iterkeysv||5.004000| +hv_iterkey||| +hv_iternext_flags||5.008000| +hv_iternextsv||| +hv_iternext||| +hv_iterval||| +hv_ksplit||5.004000| +hv_magic_check||| +hv_magic||| +hv_notallowed||| +hv_scalar||5.009001| +hv_store_ent||5.004000| +hv_store_flags||5.008000| +hv_store||| +hv_undef||| +ibcmp_locale||5.004000| +ibcmp_utf8||5.007003| +ibcmp||| +incl_perldb||| +incline||| +incpush||| +ingroup||| +init_argv_symbols||| +init_debugger||| +init_i18nl10n||5.006000| +init_i18nl14n||5.006000| +init_ids||| +init_interp||| +init_lexer||| +init_main_stash||| +init_perllib||| +init_postdump_symbols||| +init_predump_symbols||| +init_stacks||5.005000| +init_tm||5.007002| +instr||| +intro_my||| +intuit_method||| +intuit_more||| +invert||| +io_close||| +isALNUM||| +isALPHA||| +isDIGIT||| +isLOWER||| +isSPACE||| +isUPPER||| +is_an_int||| +is_gv_magical||| +is_handle_constructor||| +is_lvalue_sub||5.007001| +is_uni_alnum_lc||5.006000| +is_uni_alnumc_lc||5.006000| +is_uni_alnumc||5.006000| +is_uni_alnum||5.006000| +is_uni_alpha_lc||5.006000| +is_uni_alpha||5.006000| +is_uni_ascii_lc||5.006000| +is_uni_ascii||5.006000| +is_uni_cntrl_lc||5.006000| +is_uni_cntrl||5.006000| +is_uni_digit_lc||5.006000| +is_uni_digit||5.006000| +is_uni_graph_lc||5.006000| +is_uni_graph||5.006000| +is_uni_idfirst_lc||5.006000| +is_uni_idfirst||5.006000| +is_uni_lower_lc||5.006000| +is_uni_lower||5.006000| +is_uni_print_lc||5.006000| +is_uni_print||5.006000| +is_uni_punct_lc||5.006000| +is_uni_punct||5.006000| +is_uni_space_lc||5.006000| +is_uni_space||5.006000| +is_uni_upper_lc||5.006000| +is_uni_upper||5.006000| +is_uni_xdigit_lc||5.006000| +is_uni_xdigit||5.006000| +is_utf8_alnumc||5.006000| +is_utf8_alnum||5.006000| +is_utf8_alpha||5.006000| +is_utf8_ascii||5.006000| +is_utf8_char||5.006000| +is_utf8_cntrl||5.006000| +is_utf8_digit||5.006000| +is_utf8_graph||5.006000| +is_utf8_idcont||5.008000| +is_utf8_idfirst||5.006000| +is_utf8_lower||5.006000| +is_utf8_mark||5.006000| +is_utf8_print||5.006000| +is_utf8_punct||5.006000| +is_utf8_space||5.006000| +is_utf8_string_loc||5.008001| +is_utf8_string||5.006001| +is_utf8_upper||5.006000| +is_utf8_xdigit||5.006000| +isa_lookup||| +items|||n +ix|||n +jmaybe||| +keyword||| +leave_scope||| +lex_end||| +lex_start||| +linklist||| +list_assignment||| +listkids||| +list||| +load_module_nocontext|||vn +load_module||5.006000|v +localize||| +looks_like_number||| +lop||| +mPUSHi|5.009002||p +mPUSHn|5.009002||p +mPUSHp|5.009002||p +mPUSHu|5.009002||p +mXPUSHi|5.009002||p +mXPUSHn|5.009002||p +mXPUSHp|5.009002||p +mXPUSHu|5.009002||p +magic_clear_all_env||| +magic_clearenv||| +magic_clearpack||| +magic_clearsig||| +magic_dump||5.006000| +magic_existspack||| +magic_freeovrld||| +magic_freeregexp||| +magic_getarylen||| +magic_getdefelem||| +magic_getglob||| +magic_getnkeys||| +magic_getpack||| +magic_getpos||| +magic_getsig||| +magic_getsubstr||| +magic_gettaint||| +magic_getuvar||| +magic_getvec||| +magic_get||| +magic_killbackrefs||| +magic_len||| +magic_methcall||| +magic_methpack||| +magic_nextpack||| +magic_regdata_cnt||| +magic_regdatum_get||| +magic_regdatum_set||| +magic_scalarpack||| +magic_set_all_env||| +magic_setamagic||| +magic_setarylen||| +magic_setbm||| +magic_setcollxfrm||| +magic_setdbline||| +magic_setdefelem||| +magic_setenv||| +magic_setfm||| +magic_setglob||| +magic_setisa||| +magic_setmglob||| +magic_setnkeys||| +magic_setpack||| +magic_setpos||| +magic_setregexp||| +magic_setsig||| +magic_setsubstr||| +magic_settaint||| +magic_setutf8||| +magic_setuvar||| +magic_setvec||| +magic_set||| +magic_sizepack||| +magic_wipepack||| +magicname||| +malloced_size|||n +malloc||5.007002|n +markstack_grow||| +measure_struct||| +memEQ|5.004000||p +memNE|5.004000||p +mem_collxfrm||| +mess_alloc||| +mess_nocontext|||vn +mess||5.006000|v +method_common||| +mfree||5.007002|n +mg_clear||| +mg_copy||| +mg_dup||| +mg_find||| +mg_free||| +mg_get||| +mg_length||5.005000| +mg_magical||| +mg_set||| +mg_size||5.005000| +mini_mktime||5.007002| +missingterm||| +mode_from_discipline||| +modkids||| +mod||| +more_he||| +more_sv||| +more_xiv||| +more_xnv||| +more_xpvav||| +more_xpvbm||| +more_xpvcv||| +more_xpvhv||| +more_xpviv||| +more_xpvlv||| +more_xpvmg||| +more_xpvnv||| +more_xpv||| +more_xrv||| +moreswitches||| +mul128||| +mulexp10|||n +my_atof2||5.007002| +my_atof||5.006000| +my_attrs||| +my_bcopy|||n +my_betoh16|||n +my_betoh32|||n +my_betoh64|||n +my_betohi|||n +my_betohl|||n +my_betohs|||n +my_bzero|||n +my_chsize||| +my_exit_jump||| +my_exit||| +my_failure_exit||5.004000| +my_fflush_all||5.006000| +my_fork||5.007003|n +my_htobe16|||n +my_htobe32|||n +my_htobe64|||n +my_htobei|||n +my_htobel|||n +my_htobes|||n +my_htole16|||n +my_htole32|||n +my_htole64|||n +my_htolei|||n +my_htolel|||n +my_htoles|||n +my_htonl||| +my_kid||| +my_letoh16|||n +my_letoh32|||n +my_letoh64|||n +my_letohi|||n +my_letohl|||n +my_letohs|||n +my_lstat||| +my_memcmp||5.004000|n +my_memset|||n +my_ntohl||| +my_pclose||5.004000| +my_popen_list||5.007001| +my_popen||5.004000| +my_setenv||| +my_socketpair||5.007003|n +my_stat||| +my_strftime||5.007002| +my_swabn|||n +my_swap||| +my_unexec||| +my||| +newANONATTRSUB||5.006000| +newANONHASH||| +newANONLIST||| +newANONSUB||| +newASSIGNOP||| +newATTRSUB||5.006000| +newAVREF||| +newAV||| +newBINOP||| +newCONDOP||| +newCONSTSUB|5.006000||p +newCVREF||| +newDEFSVOP||| +newFORM||| +newFOROP||| +newGVOP||| +newGVREF||| +newGVgen||| +newHVREF||| +newHVhv||5.005000| +newHV||| +newIO||| +newLISTOP||| +newLOGOP||| +newLOOPEX||| +newLOOPOP||| +newMYSUB||5.006000| +newNULLLIST||| +newOP||| +newPADOP||5.006000| +newPMOP||| +newPROG||| +newPVOP||| +newRANGE||| +newRV_inc|5.004000||p +newRV_noinc|5.006000||p +newRV||| +newSLICEOP||| +newSTATEOP||| +newSUB||| +newSVOP||| +newSVREF||| +newSViv||| +newSVnv||| +newSVpvf_nocontext|||vn +newSVpvf||5.004000|v +newSVpvn_share||5.007001| +newSVpvn|5.006000||p +newSVpv||| +newSVrv||| +newSVsv||| +newSVuv|5.006000||p +newSV||| +newUNOP||| +newWHILEOP||5.004040| +newXSproto||5.006000| +newXS||5.006000| +new_collate||5.006000| +new_constant||| +new_ctype||5.006000| +new_he||| +new_logop||| +new_numeric||5.006000| +new_stackinfo||5.005000| +new_version||5.009000| +new_xiv||| +new_xnv||| +new_xpvav||| +new_xpvbm||| +new_xpvcv||| +new_xpvhv||| +new_xpviv||| +new_xpvlv||| +new_xpvmg||| +new_xpvnv||| +new_xpv||| +new_xrv||| +next_symbol||| +nextargv||| +nextchar||| +ninstr||| +no_bareword_allowed||| +no_fh_allowed||| +no_op||| +not_a_number||| +nothreadhook||5.008000| +nuke_stacks||| +num_overflow|||n +oopsAV||| +oopsCV||| +oopsHV||| +op_clear||| +op_const_sv||| +op_dump||5.006000| +op_free||| +op_null||5.007002| +open_script||| +pMY_CXT_|5.007003||p +pMY_CXT|5.007003||p +pTHX_|5.006000||p +pTHX|5.006000||p +pack_cat||5.007003| +pack_rec||| +package||| +packlist||5.008001| +pad_add_anon||| +pad_add_name||| +pad_alloc||| +pad_block_start||| +pad_check_dup||| +pad_findlex||| +pad_findmy||| +pad_fixup_inner_anons||| +pad_free||| +pad_leavemy||| +pad_new||| +pad_push||| +pad_reset||| +pad_setsv||| +pad_sv||| +pad_swipe||| +pad_tidy||| +pad_undef||| +parse_body||| +parse_unicode_opts||| +path_is_absolute||| +peep||| +pending_ident||| +perl_alloc_using|||n +perl_alloc|||n +perl_clone_using|||n +perl_clone|||n +perl_construct|||n +perl_destruct||5.007003|n +perl_free|||n +perl_parse||5.006000|n +perl_run|||n +pidgone||| +pmflag||| +pmop_dump||5.006000| +pmruntime||| +pmtrans||| +pop_scope||| +pregcomp||| +pregexec||| +pregfree||| +prepend_elem||| +printf_nocontext|||vn +ptr_table_clear||| +ptr_table_fetch||| +ptr_table_free||| +ptr_table_new||| +ptr_table_split||| +ptr_table_store||| +push_scope||| +put_byte||| +pv_display||5.006000| +pv_uni_display||5.007003| +qerror||| +re_croak2||| +re_dup||| +re_intuit_start||5.006000| +re_intuit_string||5.006000| +realloc||5.007002|n +reentrant_free||| +reentrant_init||| +reentrant_retry|||vn +reentrant_size||| +refkids||| +refto||| +ref||| +reg_node||| +reganode||| +regatom||| +regbranch||| +regclass_swash||5.007003| +regclass||| +regcp_set_to||| +regcppop||| +regcppush||| +regcurly||| +regdump||5.005000| +regexec_flags||5.005000| +reghop3||| +reghopmaybe3||| +reghopmaybe||| +reghop||| +reginclass||| +reginitcolors||5.006000| +reginsert||| +regmatch||| +regnext||5.005000| +regoptail||| +regpiece||| +regpposixcc||| +regprop||| +regrepeat_hard||| +regrepeat||| +regtail||| +regtry||| +reguni||| +regwhite||| +reg||| +repeatcpy||| +report_evil_fh||| +report_uninit||| +require_errno||| +require_pv||5.006000| +rninstr||| +rsignal_restore||| +rsignal_save||| +rsignal_state||5.004000| +rsignal||5.004000| +run_body||| +runops_debug||5.005000| +runops_standard||5.005000| +rxres_free||| +rxres_restore||| +rxres_save||| +safesyscalloc||5.006000|n +safesysfree||5.006000|n +safesysmalloc||5.006000|n +safesysrealloc||5.006000|n +same_dirent||| +save_I16||5.004000| +save_I32||| +save_I8||5.006000| +save_aelem||5.004050| +save_alloc||5.006000| +save_aptr||| +save_ary||| +save_bool||5.008001| +save_clearsv||| +save_delete||| +save_destructor_x||5.006000| +save_destructor||5.006000| +save_freeop||| +save_freepv||| +save_freesv||| +save_generic_pvref||5.006001| +save_generic_svref||5.005030| +save_gp||5.004000| +save_hash||| +save_hek_flags||| +save_helem||5.004050| +save_hints||5.005000| +save_hptr||| +save_int||| +save_item||| +save_iv||5.005000| +save_lines||| +save_list||| +save_long||| +save_magic||| +save_mortalizesv||5.007001| +save_nogv||| +save_op||| +save_padsv||5.007001| +save_pptr||| +save_re_context||5.006000| +save_scalar_at||| +save_scalar||| +save_set_svflags||5.009000| +save_shared_pvref||5.007003| +save_sptr||| +save_svref||| +save_threadsv||5.005000| +save_vptr||5.006000| +savepvn||| +savepv||| +savesharedpv||5.007003| +savestack_grow_cnt||5.008001| +savestack_grow||| +sawparens||| +scalar_mod_type||| +scalarboolean||| +scalarkids||| +scalarseq||| +scalarvoid||| +scalar||| +scan_bin||5.006000| +scan_commit||| +scan_const||| +scan_formline||| +scan_heredoc||| +scan_hex||| +scan_ident||| +scan_inputsymbol||| +scan_num||5.007001| +scan_oct||| +scan_pat||| +scan_str||| +scan_subst||| +scan_trans||| +scan_version||5.009001| +scan_vstring||5.008001| +scan_word||| +scope||| +screaminstr||5.005000| +seed||| +set_context||5.006000|n +set_csh||| +set_numeric_local||5.006000| +set_numeric_radix||5.006000| +set_numeric_standard||5.006000| +setdefout||| +setenv_getix||| +share_hek_flags||| +share_hek||| +si_dup||| +sighandler|||n +simplify_sort||| +skipspace||| +sortsv||5.007003| +ss_dup||| +stack_grow||| +start_glob||| +start_subparse||5.004000| +stdize_locale||| +strEQ||| +strGE||| +strGT||| +strLE||| +strLT||| +strNE||| +str_to_version||5.006000| +strnEQ||| +strnNE||| +study_chunk||| +sub_crush_depth||| +sublex_done||| +sublex_push||| +sublex_start||| +sv_2bool||| +sv_2cv||| +sv_2io||| +sv_2iuv_non_preserve||| +sv_2iv_flags||5.009001| +sv_2iv||| +sv_2mortal||| +sv_2nv||| +sv_2pv_flags||5.007002| +sv_2pv_nolen|5.006000||p +sv_2pvbyte_nolen||| +sv_2pvbyte|5.006000||p +sv_2pvutf8_nolen||5.006000| +sv_2pvutf8||5.006000| +sv_2pv||| +sv_2uv_flags||5.009001| +sv_2uv|5.004000||p +sv_add_arena||| +sv_add_backref||| +sv_backoff||| +sv_bless||| +sv_cat_decode||5.008001| +sv_catpv_mg|5.006000||p +sv_catpvf_mg_nocontext|||pvn +sv_catpvf_mg|5.006000|5.004000|pv +sv_catpvf_nocontext|||vn +sv_catpvf||5.004000|v +sv_catpvn_flags||5.007002| +sv_catpvn_mg|5.006000||p +sv_catpvn_nomg|5.007002||p +sv_catpvn||| +sv_catpv||| +sv_catsv_flags||5.007002| +sv_catsv_mg|5.006000||p +sv_catsv_nomg|5.007002||p +sv_catsv||| +sv_chop||| +sv_clean_all||| +sv_clean_objs||| +sv_clear||| +sv_cmp_locale||5.004000| +sv_cmp||| +sv_collxfrm||| +sv_compile_2op||5.008001| +sv_copypv||5.007003| +sv_dec||| +sv_del_backref||| +sv_derived_from||5.004000| +sv_dump||| +sv_dup||| +sv_eq||| +sv_force_normal_flags||5.007001| +sv_force_normal||5.006000| +sv_free2||| +sv_free_arenas||| +sv_free||| +sv_gets||5.004000| +sv_grow||| +sv_inc||| +sv_insert||| +sv_isa||| +sv_isobject||| +sv_iv||5.005000| +sv_len_utf8||5.006000| +sv_len||| +sv_magicext||5.007003| +sv_magic||| +sv_mortalcopy||| +sv_newmortal||| +sv_newref||| +sv_nolocking||5.007003| +sv_nosharing||5.007003| +sv_nounlocking||5.007003| +sv_nv||5.005000| +sv_peek||5.005000| +sv_pos_b2u||5.006000| +sv_pos_u2b||5.006000| +sv_pvbyten_force||5.006000| +sv_pvbyten||5.006000| +sv_pvbyte||5.006000| +sv_pvn_force_flags||5.007002| +sv_pvn_force|||p +sv_pvn_nomg|5.007003||p +sv_pvn|5.006000||p +sv_pvutf8n_force||5.006000| +sv_pvutf8n||5.006000| +sv_pvutf8||5.006000| +sv_pv||5.006000| +sv_recode_to_utf8||5.007003| +sv_reftype||| +sv_release_COW||| +sv_release_IVX||| +sv_replace||| +sv_report_used||| +sv_reset||| +sv_rvweaken||5.006000| +sv_setiv_mg|5.006000||p +sv_setiv||| +sv_setnv_mg|5.006000||p +sv_setnv||| +sv_setpv_mg|5.006000||p +sv_setpvf_mg_nocontext|||pvn +sv_setpvf_mg|5.006000|5.004000|pv +sv_setpvf_nocontext|||vn +sv_setpvf||5.004000|v +sv_setpviv_mg||5.008001| +sv_setpviv||5.008001| +sv_setpvn_mg|5.006000||p +sv_setpvn||| +sv_setpv||| +sv_setref_iv||| +sv_setref_nv||| +sv_setref_pvn||| +sv_setref_pv||| +sv_setref_uv||5.007001| +sv_setsv_cow||| +sv_setsv_flags||5.007002| +sv_setsv_mg|5.006000||p +sv_setsv_nomg|5.007002||p +sv_setsv||| +sv_setuv_mg|5.006000||p +sv_setuv|5.006000||p +sv_tainted||5.004000| +sv_taint||5.004000| +sv_true||5.005000| +sv_unglob||| +sv_uni_display||5.007003| +sv_unmagic||| +sv_unref_flags||5.007001| +sv_unref||| +sv_untaint||5.004000| +sv_upgrade||| +sv_usepvn_mg|5.006000||p +sv_usepvn||| +sv_utf8_decode||5.006000| +sv_utf8_downgrade||5.006000| +sv_utf8_encode||5.006000| +sv_utf8_upgrade_flags||5.007002| +sv_utf8_upgrade||5.007001| +sv_uv|5.006000||p +sv_vcatpvf_mg|5.006000|5.004000|p +sv_vcatpvfn||5.004000| +sv_vcatpvf|5.006000|5.004000|p +sv_vsetpvf_mg|5.006000|5.004000|p +sv_vsetpvfn||5.004000| +sv_vsetpvf|5.006000|5.004000|p +svtype||| +swallow_bom||| +swash_fetch||5.007002| +swash_init||5.006000| +sys_intern_clear||| +sys_intern_dup||| +sys_intern_init||| +taint_env||| +taint_proper||| +tmps_grow||5.006000| +toLOWER||| +toUPPER||| +to_byte_substr||| +to_uni_fold||5.007003| +to_uni_lower_lc||5.006000| +to_uni_lower||5.007003| +to_uni_title_lc||5.006000| +to_uni_title||5.007003| +to_uni_upper_lc||5.006000| +to_uni_upper||5.007003| +to_utf8_case||5.007003| +to_utf8_fold||5.007003| +to_utf8_lower||5.007003| +to_utf8_substr||| +to_utf8_title||5.007003| +to_utf8_upper||5.007003| +tokeq||| +tokereport||| +too_few_arguments||| +too_many_arguments||| +unlnk||| +unpack_rec||| +unpack_str||5.007003| +unpackstring||5.008001| +unshare_hek_or_pvn||| +unshare_hek||| +unsharepvn||5.004000| +upg_version||5.009000| +usage||| +utf16_textfilter||| +utf16_to_utf8_reversed||5.006001| +utf16_to_utf8||5.006001| +utf16rev_textfilter||| +utf8_distance||5.006000| +utf8_hop||5.006000| +utf8_length||5.007001| +utf8_mg_pos_init||| +utf8_mg_pos||| +utf8_to_bytes||5.006001| +utf8_to_uvchr||5.007001| +utf8_to_uvuni||5.007001| +utf8n_to_uvchr||5.007001| +utf8n_to_uvuni||5.007001| +utilize||| +uvchr_to_utf8_flags||5.007003| +uvchr_to_utf8||5.007001| +uvuni_to_utf8_flags||5.007003| +uvuni_to_utf8||5.007001| +validate_suid||| +vcall_body||| +vcall_list_body||| +vcmp||5.009000| +vcroak||5.006000| +vdeb||5.007003| +vdefault_protect||| +vdie||| +vdocatch_body||| +vform||5.006000| +visit||| +vivify_defelem||| +vivify_ref||| +vload_module||5.006000| +vmess||5.006000| +vnewSVpvf|5.006000|5.004000|p +vnormal||5.009002| +vnumify||5.009000| +vparse_body||| +vrun_body||| +vstringify||5.009000| +vwarner||5.006000| +vwarn||5.006000| +wait4pid||| +warn_nocontext|||vn +warner_nocontext|||vn +warner||5.006000|v +warn|||v +watch||| +whichsig||| +write_to_stderr||| +yyerror||| +yylex||| +yyparse||| +yywarn||| +); + +if (exists $opt{'list-unsupported'}) { + my $f; + for $f (sort { lc $a cmp lc $b } keys %API) { + next unless $API{$f}{todo}; + print "$f ", '.'x(40-length($f)), " ", format_version($API{$f}{todo}), "\n"; + } + exit 0; +} + +# Scan for possible replacement candidates + +my(%replace, %need, %hints, %depends); +my $replace = 0; +my $hint = ''; + +while (<DATA>) { + if ($hint) { + if (m{^\s*\*\s(.*?)\s*$}) { + $hints{$hint} ||= ''; # suppress warning with older perls + $hints{$hint} .= "$1\n"; + } + else { + $hint = ''; + } + } + $hint = $1 if m{^\s*$rccs\sHint:\s+(\w+)\s*$}; + + $replace = $1 if m{^\s*$rccs\s+Replace:\s+(\d+)\s+$rcce\s*$}; + $replace{$2} = $1 if $replace and m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+)}; + $replace{$2} = $1 if m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+).*$rccs\s+Replace\s+$rcce}; + $replace{$1} = $2 if m{^\s*$rccs\s+Replace (\w+) with (\w+)\s+$rcce\s*$}; + + if (m{^\s*$rccs\s+(\w+)\s+depends\s+on\s+(\w+(\s*,\s*\w+)*)\s+$rcce\s*$}) { + push @{$depends{$1}}, map { s/\s+//g; $_ } split /,/, $2; + } + + $need{$1} = 1 if m{^#if\s+defined\(NEED_(\w+)(?:_GLOBAL)?\)}; +} + +if (exists $opt{'list-provided'}) { + my $f; + for $f (sort { lc $a cmp lc $b } keys %API) { + next unless $API{$f}{provided}; + my @flags; + push @flags, 'explicit' if exists $need{$f}; + push @flags, 'depend' if exists $depends{$f}; + push @flags, 'hint' if exists $hints{$f}; + my $flags = @flags ? ' ['.join(', ', @flags).']' : ''; + print "$f$flags\n"; + } + exit 0; +} + +my(%files, %global, %revreplace); +%revreplace = reverse %replace; +my $filename; +my $patch_opened = 0; + +for $filename (@files) { + unless (open IN, "<$filename") { + warn "Unable to read from $filename: $!\n"; + next; + } + + info("Scanning $filename ..."); + + my $c = do { local $/; <IN> }; + close IN; + + my %file = (orig => $c, changes => 0); + + # temporarily remove C comments from the code + my @ccom; + $c =~ s{ + ( + [^"'/]+ + | + (?:"[^"\\]*(?:\\.[^"\\]*)*" [^"'/]*)+ + | + (?:'[^'\\]*(?:\\.[^'\\]*)*' [^"'/]*)+ + ) + | + (/ (?: + \*[^*]*\*+(?:[^$ccs][^*]*\*+)* / + | + /[^\r\n]* + )) + }{ + defined $2 and push @ccom, $2; + defined $1 ? $1 : "$ccs$#ccom$cce"; + }egsx; + + $file{ccom} = \@ccom; + $file{code} = $c; + $file{has_inc_ppport} = ($c =~ /#.*include.*\Q$ppport\E/); + + my $func; + + for $func (keys %API) { + my $match = $func; + $match .= "|$revreplace{$func}" if exists $revreplace{$func}; + if ($c =~ /\b(?:Perl_)?($match)\b/) { + $file{uses_replace}{$1}++ if exists $revreplace{$func} && $1 eq $revreplace{$func}; + $file{uses_Perl}{$func}++ if $c =~ /\bPerl_$func\b/; + if (exists $API{$func}{provided}) { + if (!exists $API{$func}{base} || $API{$func}{base} > $opt{'compat-version'}) { + $file{uses}{$func}++; + my @deps = rec_depend($func); + if (@deps) { + $file{uses_deps}{$func} = \@deps; + for (@deps) { + $file{uses}{$_} = 0 unless exists $file{uses}{$_}; + } + } + for ($func, @deps) { + if (exists $need{$_}) { + $file{needs}{$_} = 'static'; + } + } + } + } + if (exists $API{$func}{todo} && $API{$func}{todo} > $opt{'compat-version'}) { + if ($c =~ /\b$func\b/) { + $file{uses_todo}{$func}++; + } + } + } + } + + while ($c =~ /^$HS*#$HS*define$HS+(NEED_(\w+?)(_GLOBAL)?)\b/mg) { + if (exists $need{$2}) { + $file{defined $3 ? 'needed_global' : 'needed_static'}{$2}++; + } + else { + warning("Possibly wrong #define $1 in $filename"); + } + } + + for (qw(uses needs uses_todo needed_global needed_static)) { + for $func (keys %{$file{$_}}) { + push @{$global{$_}{$func}}, $filename; + } + } + + $files{$filename} = \%file; +} + +# Globally resolve NEED_'s +my $need; +for $need (keys %{$global{needs}}) { + if (@{$global{needs}{$need}} > 1) { + my @targets = @{$global{needs}{$need}}; + my @t = grep $files{$_}{needed_global}{$need}, @targets; + @targets = @t if @t; + @t = grep /\.xs$/i, @targets; + @targets = @t if @t; + my $target = shift @targets; + $files{$target}{needs}{$need} = 'global'; + for (@{$global{needs}{$need}}) { + $files{$_}{needs}{$need} = 'extern' if $_ ne $target; + } + } +} + +for $filename (@files) { + exists $files{$filename} or next; + + info("=== Analyzing $filename ==="); + + my %file = %{$files{$filename}}; + my $func; + my $c = $file{code}; + + for $func (sort keys %{$file{uses_Perl}}) { + if ($API{$func}{varargs}) { + my $changes = ($c =~ s{\b(Perl_$func\s*\(\s*)(?!aTHX_?)(\)|[^\s)]*\))} + { $1 . ($2 eq ')' ? 'aTHX' : 'aTHX_ ') . $2 }ge); + if ($changes) { + warning("Doesn't pass interpreter argument aTHX to Perl_$func"); + $file{changes} += $changes; + } + } + else { + warning("Uses Perl_$func instead of $func"); + $file{changes} += ($c =~ s{\bPerl_$func(\s*)\((\s*aTHX_?)?\s*} + {$func$1(}g); + } + } + + for $func (sort keys %{$file{uses_replace}}) { + warning("Uses $func instead of $replace{$func}"); + $file{changes} += ($c =~ s/\b$func\b/$replace{$func}/g); + } + + for $func (sort keys %{$file{uses}}) { + next unless $file{uses}{$func}; # if it's only a dependency + if (exists $file{uses_deps}{$func}) { + diag("Uses $func, which depends on ", join(', ', @{$file{uses_deps}{$func}})); + } + elsif (exists $replace{$func}) { + warning("Uses $func instead of $replace{$func}"); + $file{changes} += ($c =~ s/\b$func\b/$replace{$func}/g); + } + else { + diag("Uses $func"); + } + hint($func); + } + + for $func (sort keys %{$file{uses_todo}}) { + warning("Uses $func, which may not be portable below perl ", + format_version($API{$func}{todo})); + } + + for $func (sort keys %{$file{needed_static}}) { + my $message = ''; + if (not exists $file{uses}{$func}) { + $message = "No need to define NEED_$func if $func is never used"; + } + elsif (exists $file{needs}{$func} && $file{needs}{$func} ne 'static') { + $message = "No need to define NEED_$func when already needed globally"; + } + if ($message) { + diag($message); + $file{changes} += ($c =~ s/^$HS*#$HS*define$HS+NEED_$func\b.*$LF//mg); + } + } + + for $func (sort keys %{$file{needed_global}}) { + my $message = ''; + if (not exists $global{uses}{$func}) { + $message = "No need to define NEED_${func}_GLOBAL if $func is never used"; + } + elsif (exists $file{needs}{$func}) { + if ($file{needs}{$func} eq 'extern') { + $message = "No need to define NEED_${func}_GLOBAL when already needed globally"; + } + elsif ($file{needs}{$func} eq 'static') { + $message = "No need to define NEED_${func}_GLOBAL when only used in this file"; + } + } + if ($message) { + diag($message); + $file{changes} += ($c =~ s/^$HS*#$HS*define$HS+NEED_${func}_GLOBAL\b.*$LF//mg); + } + } + + $file{needs_inc_ppport} = keys %{$file{uses}}; + + if ($file{needs_inc_ppport}) { + my $pp = ''; + + for $func (sort keys %{$file{needs}}) { + my $type = $file{needs}{$func}; + next if $type eq 'extern'; + my $suffix = $type eq 'global' ? '_GLOBAL' : ''; + unless (exists $file{"needed_$type"}{$func}) { + if ($type eq 'global') { + diag("Files [@{$global{needs}{$func}}] need $func, adding global request"); + } + else { + diag("File needs $func, adding static request"); + } + $pp .= "#define NEED_$func$suffix\n"; + } + } + + if ($pp && ($c =~ s/^(?=$HS*#$HS*define$HS+NEED_\w+)/$pp/m)) { + $pp = ''; + $file{changes}++; + } + + unless ($file{has_inc_ppport}) { + diag("Needs to include '$ppport'"); + $pp .= qq(#include "$ppport"\n) + } + + if ($pp) { + $file{changes} += ($c =~ s/^($HS*#$HS*define$HS+NEED_\w+.*?)^/$1$pp/ms) + || ($c =~ s/^(?=$HS*#$HS*include.*\Q$ppport\E)/$pp/m) + || ($c =~ s/^($HS*#$HS*include.*XSUB.*\s*?)^/$1$pp/m) + || ($c =~ s/^/$pp/); + } + } + else { + if ($file{has_inc_ppport}) { + diag("No need to include '$ppport'"); + $file{changes} += ($c =~ s/^$HS*?#$HS*include.*\Q$ppport\E.*?$LF//m); + } + } + + # put back in our C comments + my $ix; + my $cppc = 0; + my @ccom = @{$file{ccom}}; + for $ix (0 .. $#ccom) { + if (!$opt{cplusplus} && $ccom[$ix] =~ s!^//!!) { + $cppc++; + $file{changes} += $c =~ s/$rccs$ix$rcce/$ccs$ccom[$ix] $cce/; + } + else { + $c =~ s/$rccs$ix$rcce/$ccom[$ix]/; + } + } + + if ($cppc) { + my $s = $cppc != 1 ? 's' : ''; + warning("Uses $cppc C++ style comment$s, which is not portable"); + } + + if ($file{changes}) { + if (exists $opt{copy}) { + my $newfile = "$filename$opt{copy}"; + if (-e $newfile) { + error("'$newfile' already exists, refusing to write copy of '$filename'"); + } + else { + local *F; + if (open F, ">$newfile") { + info("Writing copy of '$filename' with changes to '$newfile'"); + print F $c; + close F; + } + else { + error("Cannot open '$newfile' for writing: $!"); + } + } + } + elsif (exists $opt{patch} || $opt{changes}) { + if (exists $opt{patch}) { + unless ($patch_opened) { + if (open PATCH, ">$opt{patch}") { + $patch_opened = 1; + } + else { + error("Cannot open '$opt{patch}' for writing: $!"); + delete $opt{patch}; + $opt{changes} = 1; + goto fallback; + } + } + mydiff(\*PATCH, $filename, $c); + } + else { +fallback: + info("Suggested changes:"); + mydiff(\*STDOUT, $filename, $c); + } + } + else { + my $s = $file{changes} == 1 ? '' : 's'; + info("$file{changes} potentially required change$s detected"); + } + } + else { + info("Looks good"); + } +} + +close PATCH if $patch_opened; + +exit 0; + + +sub mydiff +{ + local *F = shift; + my($file, $str) = @_; + my $diff; + + if (exists $opt{diff}) { + $diff = run_diff($opt{diff}, $file, $str); + } + + if (!defined $diff and can_use('Text::Diff')) { + $diff = Text::Diff::diff($file, \$str, { STYLE => 'Unified' }); + $diff = <<HEADER . $diff; +--- $file ++++ $file.patched +HEADER + } + + if (!defined $diff) { + $diff = run_diff('diff -u', $file, $str); + } + + if (!defined $diff) { + $diff = run_diff('diff', $file, $str); + } + + if (!defined $diff) { + error("Cannot generate a diff. Please install Text::Diff or use --copy."); + return; + } + + print F $diff; + +} + +sub run_diff +{ + my($prog, $file, $str) = @_; + my $tmp = 'dppptemp'; + my $suf = 'aaa'; + my $diff = ''; + local *F; + + while (-e "$tmp.$suf") { $suf++ } + $tmp = "$tmp.$suf"; + + if (open F, ">$tmp") { + print F $str; + close F; + + if (open F, "$prog $file $tmp |") { + while (<F>) { + s/\Q$tmp\E/$file.patched/; + $diff .= $_; + } + close F; + unlink $tmp; + return $diff; + } + + unlink $tmp; + } + else { + error("Cannot open '$tmp' for writing: $!"); + } + + return undef; +} + +sub can_use +{ + eval "use @_;"; + return $@ eq ''; +} + +sub rec_depend +{ + my $func = shift; + my %seen; + return () unless exists $depends{$func}; + grep !$seen{$_}++, map { ($_, rec_depend($_)) } @{$depends{$func}}; +} + +sub parse_version +{ + my $ver = shift; + + if ($ver =~ /^(\d+)\.(\d+)\.(\d+)$/) { + return ($1, $2, $3); + } + elsif ($ver !~ /^\d+\.[\d_]+$/) { + die "cannot parse version '$ver'\n"; + } + + $ver =~ s/_//g; + $ver =~ s/$/000000/; + + my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/; + + $v = int $v; + $s = int $s; + + if ($r < 5 || ($r == 5 && $v < 6)) { + if ($s % 10) { + die "cannot parse version '$ver'\n"; + } + } + + return ($r, $v, $s); +} + +sub format_version +{ + my $ver = shift; + + $ver =~ s/$/000000/; + my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/; + + $v = int $v; + $s = int $s; + + if ($r < 5 || ($r == 5 && $v < 6)) { + if ($s % 10) { + die "invalid version '$ver'\n"; + } + $s /= 10; + + $ver = sprintf "%d.%03d", $r, $v; + $s > 0 and $ver .= sprintf "_%02d", $s; + + return $ver; + } + + return sprintf "%d.%d.%d", $r, $v, $s; +} + +sub info +{ + $opt{quiet} and return; + print @_, "\n"; +} + +sub diag +{ + $opt{quiet} and return; + $opt{diag} and print @_, "\n"; +} + +sub warning +{ + $opt{quiet} and return; + print "*** ", @_, "\n"; +} + +sub error +{ + print "*** ERROR: ", @_, "\n"; +} + +my %given_hints; +sub hint +{ + $opt{quiet} and return; + $opt{hints} or return; + my $func = shift; + exists $hints{$func} or return; + $given_hints{$func}++ and return; + my $hint = $hints{$func}; + $hint =~ s/^/ /mg; + print " --- hint for $func ---\n", $hint; +} + +sub usage +{ + my($usage) = do { local(@ARGV,$/)=($0); <> } =~ /^=head\d$HS+SYNOPSIS\s*^(.*?)\s*^=/ms; + my %M = ( 'I' => '*' ); + $usage =~ s/^\s*perl\s+\S+/$^X $0/; + $usage =~ s/([A-Z])<([^>]+)>/$M{$1}$2$M{$1}/g; + + print <<ENDUSAGE; + +Usage: $usage + +See perldoc $0 for details. + +ENDUSAGE + + exit 2; +} + +__DATA__ +*/ + +#ifndef _P_P_PORTABILITY_H_ +#define _P_P_PORTABILITY_H_ + +#ifndef DPPP_NAMESPACE +# define DPPP_NAMESPACE DPPP_ +#endif + +#define DPPP_CAT2(x,y) CAT2(x,y) +#define DPPP_(name) DPPP_CAT2(DPPP_NAMESPACE, name) + +#ifndef PERL_REVISION +# if !defined(__PATCHLEVEL_H_INCLUDED__) && !(defined(PATCHLEVEL) && defined(SUBVERSION)) +# define PERL_PATCHLEVEL_H_IMPLICIT +# include <patchlevel.h> +# endif +# if !(defined(PERL_VERSION) || (defined(SUBVERSION) && defined(PATCHLEVEL))) +# include <could_not_find_Perl_patchlevel.h> +# endif +# ifndef PERL_REVISION +# define PERL_REVISION (5) + /* Replace: 1 */ +# define PERL_VERSION PATCHLEVEL +# define PERL_SUBVERSION SUBVERSION + /* Replace PERL_PATCHLEVEL with PERL_VERSION */ + /* Replace: 0 */ +# endif +#endif + +#define PERL_BCDVERSION ((PERL_REVISION * 0x1000000L) + (PERL_VERSION * 0x1000L) + PERL_SUBVERSION) + +/* It is very unlikely that anyone will try to use this with Perl 6 + (or greater), but who knows. + */ +#if PERL_REVISION != 5 +# error ppport.h only works with Perl version 5 +#endif /* PERL_REVISION != 5 */ + +#ifdef I_LIMITS +# include <limits.h> +#endif + +#ifndef PERL_UCHAR_MIN +# define PERL_UCHAR_MIN ((unsigned char)0) +#endif + +#ifndef PERL_UCHAR_MAX +# ifdef UCHAR_MAX +# define PERL_UCHAR_MAX ((unsigned char)UCHAR_MAX) +# else +# ifdef MAXUCHAR +# define PERL_UCHAR_MAX ((unsigned char)MAXUCHAR) +# else +# define PERL_UCHAR_MAX ((unsigned char)~(unsigned)0) +# endif +# endif +#endif + +#ifndef PERL_USHORT_MIN +# define PERL_USHORT_MIN ((unsigned short)0) +#endif + +#ifndef PERL_USHORT_MAX +# ifdef USHORT_MAX +# define PERL_USHORT_MAX ((unsigned short)USHORT_MAX) +# else +# ifdef MAXUSHORT +# define PERL_USHORT_MAX ((unsigned short)MAXUSHORT) +# else +# ifdef USHRT_MAX +# define PERL_USHORT_MAX ((unsigned short)USHRT_MAX) +# else +# define PERL_USHORT_MAX ((unsigned short)~(unsigned)0) +# endif +# endif +# endif +#endif + +#ifndef PERL_SHORT_MAX +# ifdef SHORT_MAX +# define PERL_SHORT_MAX ((short)SHORT_MAX) +# else +# ifdef MAXSHORT /* Often used in <values.h> */ +# define PERL_SHORT_MAX ((short)MAXSHORT) +# else +# ifdef SHRT_MAX +# define PERL_SHORT_MAX ((short)SHRT_MAX) +# else +# define PERL_SHORT_MAX ((short) (PERL_USHORT_MAX >> 1)) +# endif +# endif +# endif +#endif + +#ifndef PERL_SHORT_MIN +# ifdef SHORT_MIN +# define PERL_SHORT_MIN ((short)SHORT_MIN) +# else +# ifdef MINSHORT +# define PERL_SHORT_MIN ((short)MINSHORT) +# else +# ifdef SHRT_MIN +# define PERL_SHORT_MIN ((short)SHRT_MIN) +# else +# define PERL_SHORT_MIN (-PERL_SHORT_MAX - ((3 & -1) == 3)) +# endif +# endif +# endif +#endif + +#ifndef PERL_UINT_MAX +# ifdef UINT_MAX +# define PERL_UINT_MAX ((unsigned int)UINT_MAX) +# else +# ifdef MAXUINT +# define PERL_UINT_MAX ((unsigned int)MAXUINT) +# else +# define PERL_UINT_MAX (~(unsigned int)0) +# endif +# endif +#endif + +#ifndef PERL_UINT_MIN +# define PERL_UINT_MIN ((unsigned int)0) +#endif + +#ifndef PERL_INT_MAX +# ifdef INT_MAX +# define PERL_INT_MAX ((int)INT_MAX) +# else +# ifdef MAXINT /* Often used in <values.h> */ +# define PERL_INT_MAX ((int)MAXINT) +# else +# define PERL_INT_MAX ((int)(PERL_UINT_MAX >> 1)) +# endif +# endif +#endif + +#ifndef PERL_INT_MIN +# ifdef INT_MIN +# define PERL_INT_MIN ((int)INT_MIN) +# else +# ifdef MININT +# define PERL_INT_MIN ((int)MININT) +# else +# define PERL_INT_MIN (-PERL_INT_MAX - ((3 & -1) == 3)) +# endif +# endif +#endif + +#ifndef PERL_ULONG_MAX +# ifdef ULONG_MAX +# define PERL_ULONG_MAX ((unsigned long)ULONG_MAX) +# else +# ifdef MAXULONG +# define PERL_ULONG_MAX ((unsigned long)MAXULONG) +# else +# define PERL_ULONG_MAX (~(unsigned long)0) +# endif +# endif +#endif + +#ifndef PERL_ULONG_MIN +# define PERL_ULONG_MIN ((unsigned long)0L) +#endif + +#ifndef PERL_LONG_MAX +# ifdef LONG_MAX +# define PERL_LONG_MAX ((long)LONG_MAX) +# else +# ifdef MAXLONG +# define PERL_LONG_MAX ((long)MAXLONG) +# else +# define PERL_LONG_MAX ((long) (PERL_ULONG_MAX >> 1)) +# endif +# endif +#endif + +#ifndef PERL_LONG_MIN +# ifdef LONG_MIN +# define PERL_LONG_MIN ((long)LONG_MIN) +# else +# ifdef MINLONG +# define PERL_LONG_MIN ((long)MINLONG) +# else +# define PERL_LONG_MIN (-PERL_LONG_MAX - ((3 & -1) == 3)) +# endif +# endif +#endif + +#if defined(HAS_QUAD) && (defined(convex) || defined(uts)) +# ifndef PERL_UQUAD_MAX +# ifdef ULONGLONG_MAX +# define PERL_UQUAD_MAX ((unsigned long long)ULONGLONG_MAX) +# else +# ifdef MAXULONGLONG +# define PERL_UQUAD_MAX ((unsigned long long)MAXULONGLONG) +# else +# define PERL_UQUAD_MAX (~(unsigned long long)0) +# endif +# endif +# endif + +# ifndef PERL_UQUAD_MIN +# define PERL_UQUAD_MIN ((unsigned long long)0L) +# endif + +# ifndef PERL_QUAD_MAX +# ifdef LONGLONG_MAX +# define PERL_QUAD_MAX ((long long)LONGLONG_MAX) +# else +# ifdef MAXLONGLONG +# define PERL_QUAD_MAX ((long long)MAXLONGLONG) +# else +# define PERL_QUAD_MAX ((long long) (PERL_UQUAD_MAX >> 1)) +# endif +# endif +# endif + +# ifndef PERL_QUAD_MIN +# ifdef LONGLONG_MIN +# define PERL_QUAD_MIN ((long long)LONGLONG_MIN) +# else +# ifdef MINLONGLONG +# define PERL_QUAD_MIN ((long long)MINLONGLONG) +# else +# define PERL_QUAD_MIN (-PERL_QUAD_MAX - ((3 & -1) == 3)) +# endif +# endif +# endif +#endif + +/* This is based on code from 5.003 perl.h */ +#ifdef HAS_QUAD +# ifdef cray +#ifndef IVTYPE +# define IVTYPE int +#endif + +#ifndef IV_MIN +# define IV_MIN PERL_INT_MIN +#endif + +#ifndef IV_MAX +# define IV_MAX PERL_INT_MAX +#endif + +#ifndef UV_MIN +# define UV_MIN PERL_UINT_MIN +#endif + +#ifndef UV_MAX +# define UV_MAX PERL_UINT_MAX +#endif + +# ifdef INTSIZE +#ifndef IVSIZE +# define IVSIZE INTSIZE +#endif + +# endif +# else +# if defined(convex) || defined(uts) +#ifndef IVTYPE +# define IVTYPE long long +#endif + +#ifndef IV_MIN +# define IV_MIN PERL_QUAD_MIN +#endif + +#ifndef IV_MAX +# define IV_MAX PERL_QUAD_MAX +#endif + +#ifndef UV_MIN +# define UV_MIN PERL_UQUAD_MIN +#endif + +#ifndef UV_MAX +# define UV_MAX PERL_UQUAD_MAX +#endif + +# ifdef LONGLONGSIZE +#ifndef IVSIZE +# define IVSIZE LONGLONGSIZE +#endif + +# endif +# else +#ifndef IVTYPE +# define IVTYPE long +#endif + +#ifndef IV_MIN +# define IV_MIN PERL_LONG_MIN +#endif + +#ifndef IV_MAX +# define IV_MAX PERL_LONG_MAX +#endif + +#ifndef UV_MIN +# define UV_MIN PERL_ULONG_MIN +#endif + +#ifndef UV_MAX +# define UV_MAX PERL_ULONG_MAX +#endif + +# ifdef LONGSIZE +#ifndef IVSIZE +# define IVSIZE LONGSIZE +#endif + +# endif +# endif +# endif +#ifndef IVSIZE +# define IVSIZE 8 +#endif + +#ifndef PERL_QUAD_MIN +# define PERL_QUAD_MIN IV_MIN +#endif + +#ifndef PERL_QUAD_MAX +# define PERL_QUAD_MAX IV_MAX +#endif + +#ifndef PERL_UQUAD_MIN +# define PERL_UQUAD_MIN UV_MIN +#endif + +#ifndef PERL_UQUAD_MAX +# define PERL_UQUAD_MAX UV_MAX +#endif + +#else +#ifndef IVTYPE +# define IVTYPE long +#endif + +#ifndef IV_MIN +# define IV_MIN PERL_LONG_MIN +#endif + +#ifndef IV_MAX +# define IV_MAX PERL_LONG_MAX +#endif + +#ifndef UV_MIN +# define UV_MIN PERL_ULONG_MIN +#endif + +#ifndef UV_MAX +# define UV_MAX PERL_ULONG_MAX +#endif + +#endif + +#ifndef IVSIZE +# ifdef LONGSIZE +# define IVSIZE LONGSIZE +# else +# define IVSIZE 4 /* A bold guess, but the best we can make. */ +# endif +#endif +#ifndef UVTYPE +# define UVTYPE unsigned IVTYPE +#endif + +#ifndef UVSIZE +# define UVSIZE IVSIZE +#endif + +#ifndef sv_setuv +# define sv_setuv(sv, uv) \ + STMT_START { \ + UV TeMpUv = uv; \ + if (TeMpUv <= IV_MAX) \ + sv_setiv(sv, TeMpUv); \ + else \ + sv_setnv(sv, (double)TeMpUv); \ + } STMT_END +#endif + +#ifndef newSVuv +# define newSVuv(uv) ((uv) <= IV_MAX ? newSViv((IV)uv) : newSVnv((NV)uv)) +#endif +#ifndef sv_2uv +# define sv_2uv(sv) ((PL_Sv = (sv)), (UV) (SvNOK(PL_Sv) ? SvNV(PL_Sv) : sv_2nv(PL_Sv))) +#endif + +#ifndef SvUVX +# define SvUVX(sv) ((UV)SvIVX(sv)) +#endif + +#ifndef SvUVXx +# define SvUVXx(sv) SvUVX(sv) +#endif + +#ifndef SvUV +# define SvUV(sv) (SvIOK(sv) ? SvUVX(sv) : sv_2uv(sv)) +#endif + +#ifndef SvUVx +# define SvUVx(sv) ((PL_Sv = (sv)), SvUV(PL_Sv)) +#endif + +/* Hint: sv_uv + * Always use the SvUVx() macro instead of sv_uv(). + */ +#ifndef sv_uv +# define sv_uv(sv) SvUVx(sv) +#endif +#ifndef XST_mUV +# define XST_mUV(i,v) (ST(i) = sv_2mortal(newSVuv(v)) ) +#endif + +#ifndef XSRETURN_UV +# define XSRETURN_UV(v) STMT_START { XST_mUV(0,v); XSRETURN(1); } STMT_END +#endif +#ifndef PUSHu +# define PUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); PUSHTARG; } STMT_END +#endif + +#ifndef XPUSHu +# define XPUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); XPUSHTARG; } STMT_END +#endif + +#if (PERL_VERSION < 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION <= 5)) +/* Replace: 1 */ +# define PL_DBsingle DBsingle +# define PL_DBsub DBsub +# define PL_Sv Sv +# define PL_compiling compiling +# define PL_copline copline +# define PL_curcop curcop +# define PL_curstash curstash +# define PL_debstash debstash +# define PL_defgv defgv +# define PL_diehook diehook +# define PL_dirty dirty +# define PL_dowarn dowarn +# define PL_errgv errgv +# define PL_hexdigit hexdigit +# define PL_hints hints +# define PL_na na +# define PL_no_modify no_modify +# define PL_perl_destruct_level perl_destruct_level +# define PL_perldb perldb +# define PL_ppaddr ppaddr +# define PL_rsfp_filters rsfp_filters +# define PL_rsfp rsfp +# define PL_stack_base stack_base +# define PL_stack_sp stack_sp +# define PL_stdingv stdingv +# define PL_sv_arenaroot sv_arenaroot +# define PL_sv_no sv_no +# define PL_sv_undef sv_undef +# define PL_sv_yes sv_yes +# define PL_tainted tainted +# define PL_tainting tainting +/* Replace: 0 */ +#endif + +#ifdef HASATTRIBUTE +# if (defined(__GNUC__) && defined(__cplusplus)) || defined(__INTEL_COMPILER) +# define PERL_UNUSED_DECL +# else +# define PERL_UNUSED_DECL __attribute__((unused)) +# endif +#else +# define PERL_UNUSED_DECL +#endif +#ifndef NOOP +# define NOOP (void)0 +#endif + +#ifndef dNOOP +# define dNOOP extern int Perl___notused PERL_UNUSED_DECL +#endif + +#ifndef NVTYPE +# if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE) +# define NVTYPE long double +# else +# define NVTYPE double +# endif +typedef NVTYPE NV; +#endif + +#ifndef INT2PTR + +# if (IVSIZE == PTRSIZE) && (UVSIZE == PTRSIZE) +# define PTRV UV +# define INT2PTR(any,d) (any)(d) +# else +# if PTRSIZE == LONGSIZE +# define PTRV unsigned long +# else +# define PTRV unsigned +# endif +# define INT2PTR(any,d) (any)(PTRV)(d) +# endif + +# define NUM2PTR(any,d) (any)(PTRV)(d) +# define PTR2IV(p) INT2PTR(IV,p) +# define PTR2UV(p) INT2PTR(UV,p) +# define PTR2NV(p) NUM2PTR(NV,p) + +# if PTRSIZE == LONGSIZE +# define PTR2ul(p) (unsigned long)(p) +# else +# define PTR2ul(p) INT2PTR(unsigned long,p) +# endif + +#endif /* !INT2PTR */ + +#undef START_EXTERN_C +#undef END_EXTERN_C +#undef EXTERN_C +#ifdef __cplusplus +# define START_EXTERN_C extern "C" { +# define END_EXTERN_C } +# define EXTERN_C extern "C" +#else +# define START_EXTERN_C +# define END_EXTERN_C +# define EXTERN_C extern +#endif + +#ifndef PERL_GCC_BRACE_GROUPS_FORBIDDEN +# if defined(__STRICT_ANSI__) && defined(PERL_GCC_PEDANTIC) +# define PERL_GCC_BRACE_GROUPS_FORBIDDEN +# endif +#endif + +#undef STMT_START +#undef STMT_END +#if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) && !defined(__cplusplus) +# define STMT_START (void)( /* gcc supports ``({ STATEMENTS; })'' */ +# define STMT_END ) +#else +# if defined(VOIDFLAGS) && (VOIDFLAGS) && (defined(sun) || defined(__sun__)) && !defined(__GNUC__) +# define STMT_START if (1) +# define STMT_END else (void)0 +# else +# define STMT_START do +# define STMT_END while (0) +# endif +#endif +#ifndef boolSV +# define boolSV(b) ((b) ? &PL_sv_yes : &PL_sv_no) +#endif + +/* DEFSV appears first in 5.004_56 */ +#ifndef DEFSV +# define DEFSV GvSV(PL_defgv) +#endif + +#ifndef SAVE_DEFSV +# define SAVE_DEFSV SAVESPTR(GvSV(PL_defgv)) +#endif + +/* Older perls (<=5.003) lack AvFILLp */ +#ifndef AvFILLp +# define AvFILLp AvFILL +#endif +#ifndef ERRSV +# define ERRSV get_sv("@",FALSE) +#endif +#ifndef newSVpvn +# define newSVpvn(data,len) ((data) \ + ? ((len) ? newSVpv((data), (len)) : newSVpv("", 0)) \ + : newSV(0)) +#endif + +/* Hint: gv_stashpvn + * This function's backport doesn't support the length parameter, but + * rather ignores it. Portability can only be ensured if the length + * parameter is used for speed reasons, but the length can always be + * correctly computed from the string argument. + */ +#ifndef gv_stashpvn +# define gv_stashpvn(str,len,create) gv_stashpv(str,create) +#endif + +/* Replace: 1 */ +#ifndef get_cv +# define get_cv perl_get_cv +#endif + +#ifndef get_sv +# define get_sv perl_get_sv +#endif + +#ifndef get_av +# define get_av perl_get_av +#endif + +#ifndef get_hv +# define get_hv perl_get_hv +#endif + +/* Replace: 0 */ + +#ifdef HAS_MEMCMP +#ifndef memNE +# define memNE(s1,s2,l) (memcmp(s1,s2,l)) +#endif + +#ifndef memEQ +# define memEQ(s1,s2,l) (!memcmp(s1,s2,l)) +#endif + +#else +#ifndef memNE +# define memNE(s1,s2,l) (bcmp(s1,s2,l)) +#endif + +#ifndef memEQ +# define memEQ(s1,s2,l) (!bcmp(s1,s2,l)) +#endif + +#endif +#ifndef MoveD +# define MoveD(s,d,n,t) memmove((char*)(d),(char*)(s), (n) * sizeof(t)) +#endif + +#ifndef CopyD +# define CopyD(s,d,n,t) memcpy((char*)(d),(char*)(s), (n) * sizeof(t)) +#endif + +#ifdef HAS_MEMSET +#ifndef ZeroD +# define ZeroD(d,n,t) memzero((char*)(d), (n) * sizeof(t)) +#endif + +#else +#ifndef ZeroD +# define ZeroD(d,n,t) ((void)memzero((char*)(d), (n) * sizeof(t)),d) +#endif + +#endif +#ifndef Poison +# define Poison(d,n,t) (void)memset((char*)(d), 0xAB, (n) * sizeof(t)) +#endif +#ifndef dUNDERBAR +# define dUNDERBAR dNOOP +#endif + +#ifndef UNDERBAR +# define UNDERBAR DEFSV +#endif +#ifndef dAX +# define dAX I32 ax = MARK - PL_stack_base + 1 +#endif + +#ifndef dITEMS +# define dITEMS I32 items = SP - MARK +#endif +#ifndef dTHR +# define dTHR dNOOP +#endif +#ifndef dTHX +# define dTHX dNOOP +#endif + +#ifndef dTHXa +# define dTHXa(x) dNOOP +#endif +#ifndef pTHX +# define pTHX void +#endif + +#ifndef pTHX_ +# define pTHX_ +#endif + +#ifndef aTHX +# define aTHX +#endif + +#ifndef aTHX_ +# define aTHX_ +#endif +#ifndef dTHXoa +# define dTHXoa(x) dTHXa(x) +#endif +#ifndef PUSHmortal +# define PUSHmortal PUSHs(sv_newmortal()) +#endif + +#ifndef mPUSHp +# define mPUSHp(p,l) sv_setpvn_mg(PUSHmortal, (p), (l)) +#endif + +#ifndef mPUSHn +# define mPUSHn(n) sv_setnv_mg(PUSHmortal, (NV)(n)) +#endif + +#ifndef mPUSHi +# define mPUSHi(i) sv_setiv_mg(PUSHmortal, (IV)(i)) +#endif + +#ifndef mPUSHu +# define mPUSHu(u) sv_setuv_mg(PUSHmortal, (UV)(u)) +#endif +#ifndef XPUSHmortal +# define XPUSHmortal XPUSHs(sv_newmortal()) +#endif + +#ifndef mXPUSHp +# define mXPUSHp(p,l) STMT_START { EXTEND(sp,1); sv_setpvn_mg(PUSHmortal, (p), (l)); } STMT_END +#endif + +#ifndef mXPUSHn +# define mXPUSHn(n) STMT_START { EXTEND(sp,1); sv_setnv_mg(PUSHmortal, (NV)(n)); } STMT_END +#endif + +#ifndef mXPUSHi +# define mXPUSHi(i) STMT_START { EXTEND(sp,1); sv_setiv_mg(PUSHmortal, (IV)(i)); } STMT_END +#endif + +#ifndef mXPUSHu +# define mXPUSHu(u) STMT_START { EXTEND(sp,1); sv_setuv_mg(PUSHmortal, (UV)(u)); } STMT_END +#endif + +/* Replace: 1 */ +#ifndef call_sv +# define call_sv perl_call_sv +#endif + +#ifndef call_pv +# define call_pv perl_call_pv +#endif + +#ifndef call_argv +# define call_argv perl_call_argv +#endif + +#ifndef call_method +# define call_method perl_call_method +#endif +#ifndef eval_sv +# define eval_sv perl_eval_sv +#endif + +/* Replace: 0 */ + +/* Replace perl_eval_pv with eval_pv */ +/* eval_pv depends on eval_sv */ + +#ifndef eval_pv +#if defined(NEED_eval_pv) +static SV* DPPP_(my_eval_pv)(char *p, I32 croak_on_error); +static +#else +extern SV* DPPP_(my_eval_pv)(char *p, I32 croak_on_error); +#endif + +#ifdef eval_pv +# undef eval_pv +#endif +#define eval_pv(a,b) DPPP_(my_eval_pv)(aTHX_ a,b) +#define Perl_eval_pv DPPP_(my_eval_pv) + +#if defined(NEED_eval_pv) || defined(NEED_eval_pv_GLOBAL) + +SV* +DPPP_(my_eval_pv)(char *p, I32 croak_on_error) +{ + dSP; + SV* sv = newSVpv(p, 0); + + PUSHMARK(sp); + eval_sv(sv, G_SCALAR); + SvREFCNT_dec(sv); + + SPAGAIN; + sv = POPs; + PUTBACK; + + if (croak_on_error && SvTRUE(GvSV(errgv))) + croak(SvPVx(GvSV(errgv), na)); + + return sv; +} + +#endif +#endif +#ifndef newRV_inc +# define newRV_inc(sv) newRV(sv) /* Replace */ +#endif + +#ifndef newRV_noinc +#if defined(NEED_newRV_noinc) +static SV * DPPP_(my_newRV_noinc)(SV *sv); +static +#else +extern SV * DPPP_(my_newRV_noinc)(SV *sv); +#endif + +#ifdef newRV_noinc +# undef newRV_noinc +#endif +#define newRV_noinc(a) DPPP_(my_newRV_noinc)(aTHX_ a) +#define Perl_newRV_noinc DPPP_(my_newRV_noinc) + +#if defined(NEED_newRV_noinc) || defined(NEED_newRV_noinc_GLOBAL) +SV * +DPPP_(my_newRV_noinc)(SV *sv) +{ + SV *rv = (SV *)newRV(sv); + SvREFCNT_dec(sv); + return rv; +} +#endif +#endif + +/* Hint: newCONSTSUB + * Returns a CV* as of perl-5.7.1. This return value is not supported + * by Devel::PPPort. + */ + +/* newCONSTSUB from IO.xs is in the core starting with 5.004_63 */ +#if ((PERL_VERSION < 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION < 63))) && ((PERL_VERSION != 4) || (PERL_SUBVERSION != 5)) +#if defined(NEED_newCONSTSUB) +static void DPPP_(my_newCONSTSUB)(HV *stash, char *name, SV *sv); +static +#else +extern void DPPP_(my_newCONSTSUB)(HV *stash, char *name, SV *sv); +#endif + +#ifdef newCONSTSUB +# undef newCONSTSUB +#endif +#define newCONSTSUB(a,b,c) DPPP_(my_newCONSTSUB)(aTHX_ a,b,c) +#define Perl_newCONSTSUB DPPP_(my_newCONSTSUB) + +#if defined(NEED_newCONSTSUB) || defined(NEED_newCONSTSUB_GLOBAL) + +void +DPPP_(my_newCONSTSUB)(HV *stash, char *name, SV *sv) +{ + U32 oldhints = PL_hints; + HV *old_cop_stash = PL_curcop->cop_stash; + HV *old_curstash = PL_curstash; + line_t oldline = PL_curcop->cop_line; + PL_curcop->cop_line = PL_copline; + + PL_hints &= ~HINT_BLOCK_SCOPE; + if (stash) + PL_curstash = PL_curcop->cop_stash = stash; + + newSUB( + +#if ((PERL_VERSION < 3) || ((PERL_VERSION == 3) && (PERL_SUBVERSION < 22))) + start_subparse(), +#elif ((PERL_VERSION == 3) && (PERL_SUBVERSION == 22)) + start_subparse(0), +#else /* 5.003_23 onwards */ + start_subparse(FALSE, 0), +#endif + + newSVOP(OP_CONST, 0, newSVpv(name,0)), + newSVOP(OP_CONST, 0, &PL_sv_no), /* SvPV(&PL_sv_no) == "" -- GMB */ + newSTATEOP(0, Nullch, newSVOP(OP_CONST, 0, sv)) + ); + + PL_hints = oldhints; + PL_curcop->cop_stash = old_cop_stash; + PL_curstash = old_curstash; + PL_curcop->cop_line = oldline; +} +#endif +#endif + +/* + * Boilerplate macros for initializing and accessing interpreter-local + * data from C. All statics in extensions should be reworked to use + * this, if you want to make the extension thread-safe. See ext/re/re.xs + * for an example of the use of these macros. + * + * Code that uses these macros is responsible for the following: + * 1. #define MY_CXT_KEY to a unique string, e.g. "DynaLoader_guts" + * 2. Declare a typedef named my_cxt_t that is a structure that contains + * all the data that needs to be interpreter-local. + * 3. Use the START_MY_CXT macro after the declaration of my_cxt_t. + * 4. Use the MY_CXT_INIT macro such that it is called exactly once + * (typically put in the BOOT: section). + * 5. Use the members of the my_cxt_t structure everywhere as + * MY_CXT.member. + * 6. Use the dMY_CXT macro (a declaration) in all the functions that + * access MY_CXT. + */ + +#if defined(MULTIPLICITY) || defined(PERL_OBJECT) || \ + defined(PERL_CAPI) || defined(PERL_IMPLICIT_CONTEXT) + +#ifndef START_MY_CXT + +/* This must appear in all extensions that define a my_cxt_t structure, + * right after the definition (i.e. at file scope). The non-threads + * case below uses it to declare the data as static. */ +#define START_MY_CXT + +#if (PERL_VERSION < 4 || (PERL_VERSION == 4 && PERL_SUBVERSION < 68 )) +/* Fetches the SV that keeps the per-interpreter data. */ +#define dMY_CXT_SV \ + SV *my_cxt_sv = get_sv(MY_CXT_KEY, FALSE) +#else /* >= perl5.004_68 */ +#define dMY_CXT_SV \ + SV *my_cxt_sv = *hv_fetch(PL_modglobal, MY_CXT_KEY, \ + sizeof(MY_CXT_KEY)-1, TRUE) +#endif /* < perl5.004_68 */ + +/* This declaration should be used within all functions that use the + * interpreter-local data. */ +#define dMY_CXT \ + dMY_CXT_SV; \ + my_cxt_t *my_cxtp = INT2PTR(my_cxt_t*,SvUV(my_cxt_sv)) + +/* Creates and zeroes the per-interpreter data. + * (We allocate my_cxtp in a Perl SV so that it will be released when + * the interpreter goes away.) */ +#define MY_CXT_INIT \ + dMY_CXT_SV; \ + /* newSV() allocates one more than needed */ \ + my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\ + Zero(my_cxtp, 1, my_cxt_t); \ + sv_setuv(my_cxt_sv, PTR2UV(my_cxtp)) + +/* This macro must be used to access members of the my_cxt_t structure. + * e.g. MYCXT.some_data */ +#define MY_CXT (*my_cxtp) + +/* Judicious use of these macros can reduce the number of times dMY_CXT + * is used. Use is similar to pTHX, aTHX etc. */ +#define pMY_CXT my_cxt_t *my_cxtp +#define pMY_CXT_ pMY_CXT, +#define _pMY_CXT ,pMY_CXT +#define aMY_CXT my_cxtp +#define aMY_CXT_ aMY_CXT, +#define _aMY_CXT ,aMY_CXT + +#endif /* START_MY_CXT */ + +#ifndef MY_CXT_CLONE +/* Clones the per-interpreter data. */ +#define MY_CXT_CLONE \ + dMY_CXT_SV; \ + my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\ + Copy(INT2PTR(my_cxt_t*, SvUV(my_cxt_sv)), my_cxtp, 1, my_cxt_t);\ + sv_setuv(my_cxt_sv, PTR2UV(my_cxtp)) +#endif + +#else /* single interpreter */ + +#ifndef START_MY_CXT + +#define START_MY_CXT static my_cxt_t my_cxt; +#define dMY_CXT_SV dNOOP +#define dMY_CXT dNOOP +#define MY_CXT_INIT NOOP +#define MY_CXT my_cxt + +#define pMY_CXT void +#define pMY_CXT_ +#define _pMY_CXT +#define aMY_CXT +#define aMY_CXT_ +#define _aMY_CXT + +#endif /* START_MY_CXT */ + +#ifndef MY_CXT_CLONE +#define MY_CXT_CLONE NOOP +#endif + +#endif + +#ifndef IVdf +# if IVSIZE == LONGSIZE +# define IVdf "ld" +# define UVuf "lu" +# define UVof "lo" +# define UVxf "lx" +# define UVXf "lX" +# else +# if IVSIZE == INTSIZE +# define IVdf "d" +# define UVuf "u" +# define UVof "o" +# define UVxf "x" +# define UVXf "X" +# endif +# endif +#endif + +#ifndef NVef +# if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE) && \ + defined(PERL_PRIfldbl) /* Not very likely, but let's try anyway. */ +# define NVef PERL_PRIeldbl +# define NVff PERL_PRIfldbl +# define NVgf PERL_PRIgldbl +# else +# define NVef "e" +# define NVff "f" +# define NVgf "g" +# endif +#endif + +#ifndef SvPV_nolen + +#if defined(NEED_sv_2pv_nolen) +static char * DPPP_(my_sv_2pv_nolen)(pTHX_ register SV *sv); +static +#else +extern char * DPPP_(my_sv_2pv_nolen)(pTHX_ register SV *sv); +#endif + +#ifdef sv_2pv_nolen +# undef sv_2pv_nolen +#endif +#define sv_2pv_nolen(a) DPPP_(my_sv_2pv_nolen)(aTHX_ a) +#define Perl_sv_2pv_nolen DPPP_(my_sv_2pv_nolen) + +#if defined(NEED_sv_2pv_nolen) || defined(NEED_sv_2pv_nolen_GLOBAL) + +char * +DPPP_(my_sv_2pv_nolen)(pTHX_ register SV *sv) +{ + STRLEN n_a; + return sv_2pv(sv, &n_a); +} + +#endif + +/* Hint: sv_2pv_nolen + * Use the SvPV_nolen() macro instead of sv_2pv_nolen(). + */ + +/* SvPV_nolen depends on sv_2pv_nolen */ +#define SvPV_nolen(sv) \ + ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ + ? SvPVX(sv) : sv_2pv_nolen(sv)) + +#endif + +#ifdef SvPVbyte + +/* Hint: SvPVbyte + * Does not work in perl-5.6.1, ppport.h implements a version + * borrowed from perl-5.7.3. + */ + +#if ((PERL_VERSION < 7) || ((PERL_VERSION == 7) && (PERL_SUBVERSION < 0))) + +#if defined(NEED_sv_2pvbyte) +static char * DPPP_(my_sv_2pvbyte)(pTHX_ register SV *sv, STRLEN *lp); +static +#else +extern char * DPPP_(my_sv_2pvbyte)(pTHX_ register SV *sv, STRLEN *lp); +#endif + +#ifdef sv_2pvbyte +# undef sv_2pvbyte +#endif +#define sv_2pvbyte(a,b) DPPP_(my_sv_2pvbyte)(aTHX_ a,b) +#define Perl_sv_2pvbyte DPPP_(my_sv_2pvbyte) + +#if defined(NEED_sv_2pvbyte) || defined(NEED_sv_2pvbyte_GLOBAL) + +char * +DPPP_(my_sv_2pvbyte)(pTHX_ register SV *sv, STRLEN *lp) +{ + sv_utf8_downgrade(sv,0); + return SvPV(sv,*lp); +} + +#endif + +/* Hint: sv_2pvbyte + * Use the SvPVbyte() macro instead of sv_2pvbyte(). + */ + +#undef SvPVbyte + +/* SvPVbyte depends on sv_2pvbyte */ +#define SvPVbyte(sv, lp) \ + ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8)) == (SVf_POK) \ + ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pvbyte(sv, &lp)) + +#endif + +#else + +# define SvPVbyte SvPV +# define sv_2pvbyte sv_2pv + +#endif + +/* sv_2pvbyte_nolen depends on sv_2pv_nolen */ +#ifndef sv_2pvbyte_nolen +# define sv_2pvbyte_nolen sv_2pv_nolen +#endif + +/* Hint: sv_pvn + * Always use the SvPV() macro instead of sv_pvn(). + */ +#ifndef sv_pvn +# define sv_pvn(sv, len) SvPV(sv, len) +#endif + +/* Hint: sv_pvn + * Always use the SvPV_force() macro instead of sv_pvn_force(). + */ +#ifndef sv_pvn_force +# define sv_pvn_force(sv, len) SvPV_force(sv, len) +#endif + +#if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(vnewSVpvf) +#if defined(NEED_vnewSVpvf) +static SV * DPPP_(my_vnewSVpvf)(pTHX_ const char * pat, va_list * args); +static +#else +extern SV * DPPP_(my_vnewSVpvf)(pTHX_ const char * pat, va_list * args); +#endif + +#ifdef vnewSVpvf +# undef vnewSVpvf +#endif +#define vnewSVpvf(a,b) DPPP_(my_vnewSVpvf)(aTHX_ a,b) +#define Perl_vnewSVpvf DPPP_(my_vnewSVpvf) + +#if defined(NEED_vnewSVpvf) || defined(NEED_vnewSVpvf_GLOBAL) + +SV * +DPPP_(my_vnewSVpvf)(pTHX_ const char *pat, va_list *args) +{ + register SV *sv = newSV(0); + sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); + return sv; +} + +#endif +#endif + +/* sv_vcatpvf depends on sv_vcatpvfn */ +#if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_vcatpvf) +# define sv_vcatpvf(sv, pat, args) sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)) +#endif + +/* sv_vsetpvf depends on sv_vsetpvfn */ +#if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_vsetpvf) +# define sv_vsetpvf(sv, pat, args) sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)) +#endif + +/* sv_catpvf_mg depends on sv_vcatpvfn, sv_catpvf_mg_nocontext */ +#if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_catpvf_mg) +#if defined(NEED_sv_catpvf_mg) +static void DPPP_(my_sv_catpvf_mg)(pTHX_ SV * sv, const char * pat, ...); +static +#else +extern void DPPP_(my_sv_catpvf_mg)(pTHX_ SV * sv, const char * pat, ...); +#endif + +#define Perl_sv_catpvf_mg DPPP_(my_sv_catpvf_mg) + +#if defined(NEED_sv_catpvf_mg) || defined(NEED_sv_catpvf_mg_GLOBAL) + +void +DPPP_(my_sv_catpvf_mg)(pTHX_ SV *sv, const char *pat, ...) +{ + va_list args; + va_start(args, pat); + sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + SvSETMAGIC(sv); + va_end(args); +} + +#endif +#endif + +/* sv_catpvf_mg_nocontext depends on sv_vcatpvfn */ +#ifdef PERL_IMPLICIT_CONTEXT +#if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_catpvf_mg_nocontext) +#if defined(NEED_sv_catpvf_mg_nocontext) +static void DPPP_(my_sv_catpvf_mg_nocontext)(SV * sv, const char * pat, ...); +static +#else +extern void DPPP_(my_sv_catpvf_mg_nocontext)(SV * sv, const char * pat, ...); +#endif + +#define sv_catpvf_mg_nocontext DPPP_(my_sv_catpvf_mg_nocontext) +#define Perl_sv_catpvf_mg_nocontext DPPP_(my_sv_catpvf_mg_nocontext) + +#if defined(NEED_sv_catpvf_mg_nocontext) || defined(NEED_sv_catpvf_mg_nocontext_GLOBAL) + +void +DPPP_(my_sv_catpvf_mg_nocontext)(SV *sv, const char *pat, ...) +{ + dTHX; + va_list args; + va_start(args, pat); + sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + SvSETMAGIC(sv); + va_end(args); +} + +#endif +#endif +#endif + +#ifndef sv_catpvf_mg +# ifdef PERL_IMPLICIT_CONTEXT +# define sv_catpvf_mg Perl_sv_catpvf_mg_nocontext +# else +# define sv_catpvf_mg Perl_sv_catpvf_mg +# endif +#endif + +/* sv_vcatpvf_mg depends on sv_vcatpvfn */ +#if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_vcatpvf_mg) +# define sv_vcatpvf_mg(sv, pat, args) \ + STMT_START { \ + sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); \ + SvSETMAGIC(sv); \ + } STMT_END +#endif + +/* sv_setpvf_mg depends on sv_vsetpvfn, sv_setpvf_mg_nocontext */ +#if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_setpvf_mg) +#if defined(NEED_sv_setpvf_mg) +static void DPPP_(my_sv_setpvf_mg)(pTHX_ SV * sv, const char * pat, ...); +static +#else +extern void DPPP_(my_sv_setpvf_mg)(pTHX_ SV * sv, const char * pat, ...); +#endif + +#define Perl_sv_setpvf_mg DPPP_(my_sv_setpvf_mg) + +#if defined(NEED_sv_setpvf_mg) || defined(NEED_sv_setpvf_mg_GLOBAL) + +void +DPPP_(my_sv_setpvf_mg)(pTHX_ SV *sv, const char *pat, ...) +{ + va_list args; + va_start(args, pat); + sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + SvSETMAGIC(sv); + va_end(args); +} + +#endif +#endif + +/* sv_setpvf_mg_nocontext depends on sv_vsetpvfn */ +#ifdef PERL_IMPLICIT_CONTEXT +#if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_setpvf_mg_nocontext) +#if defined(NEED_sv_setpvf_mg_nocontext) +static void DPPP_(my_sv_setpvf_mg_nocontext)(SV * sv, const char * pat, ...); +static +#else +extern void DPPP_(my_sv_setpvf_mg_nocontext)(SV * sv, const char * pat, ...); +#endif + +#define sv_setpvf_mg_nocontext DPPP_(my_sv_setpvf_mg_nocontext) +#define Perl_sv_setpvf_mg_nocontext DPPP_(my_sv_setpvf_mg_nocontext) + +#if defined(NEED_sv_setpvf_mg_nocontext) || defined(NEED_sv_setpvf_mg_nocontext_GLOBAL) + +void +DPPP_(my_sv_setpvf_mg_nocontext)(SV *sv, const char *pat, ...) +{ + dTHX; + va_list args; + va_start(args, pat); + sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + SvSETMAGIC(sv); + va_end(args); +} + +#endif +#endif +#endif + +#ifndef sv_setpvf_mg +# ifdef PERL_IMPLICIT_CONTEXT +# define sv_setpvf_mg Perl_sv_setpvf_mg_nocontext +# else +# define sv_setpvf_mg Perl_sv_setpvf_mg +# endif +#endif + +/* sv_vsetpvf_mg depends on sv_vsetpvfn */ +#if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_vsetpvf_mg) +# define sv_vsetpvf_mg(sv, pat, args) \ + STMT_START { \ + sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); \ + SvSETMAGIC(sv); \ + } STMT_END +#endif +#ifndef SvGETMAGIC +# define SvGETMAGIC(x) STMT_START { if (SvGMAGICAL(x)) mg_get(x); } STMT_END +#endif +#ifndef PERL_MAGIC_sv +# define PERL_MAGIC_sv '\0' +#endif + +#ifndef PERL_MAGIC_overload +# define PERL_MAGIC_overload 'A' +#endif + +#ifndef PERL_MAGIC_overload_elem +# define PERL_MAGIC_overload_elem 'a' +#endif + +#ifndef PERL_MAGIC_overload_table +# define PERL_MAGIC_overload_table 'c' +#endif + +#ifndef PERL_MAGIC_bm +# define PERL_MAGIC_bm 'B' +#endif + +#ifndef PERL_MAGIC_regdata +# define PERL_MAGIC_regdata 'D' +#endif + +#ifndef PERL_MAGIC_regdatum +# define PERL_MAGIC_regdatum 'd' +#endif + +#ifndef PERL_MAGIC_env +# define PERL_MAGIC_env 'E' +#endif + +#ifndef PERL_MAGIC_envelem +# define PERL_MAGIC_envelem 'e' +#endif + +#ifndef PERL_MAGIC_fm +# define PERL_MAGIC_fm 'f' +#endif + +#ifndef PERL_MAGIC_regex_global +# define PERL_MAGIC_regex_global 'g' +#endif + +#ifndef PERL_MAGIC_isa +# define PERL_MAGIC_isa 'I' +#endif + +#ifndef PERL_MAGIC_isaelem +# define PERL_MAGIC_isaelem 'i' +#endif + +#ifndef PERL_MAGIC_nkeys +# define PERL_MAGIC_nkeys 'k' +#endif + +#ifndef PERL_MAGIC_dbfile +# define PERL_MAGIC_dbfile 'L' +#endif + +#ifndef PERL_MAGIC_dbline +# define PERL_MAGIC_dbline 'l' +#endif + +#ifndef PERL_MAGIC_mutex +# define PERL_MAGIC_mutex 'm' +#endif + +#ifndef PERL_MAGIC_shared +# define PERL_MAGIC_shared 'N' +#endif + +#ifndef PERL_MAGIC_shared_scalar +# define PERL_MAGIC_shared_scalar 'n' +#endif + +#ifndef PERL_MAGIC_collxfrm +# define PERL_MAGIC_collxfrm 'o' +#endif + +#ifndef PERL_MAGIC_tied +# define PERL_MAGIC_tied 'P' +#endif + +#ifndef PERL_MAGIC_tiedelem +# define PERL_MAGIC_tiedelem 'p' +#endif + +#ifndef PERL_MAGIC_tiedscalar +# define PERL_MAGIC_tiedscalar 'q' +#endif + +#ifndef PERL_MAGIC_qr +# define PERL_MAGIC_qr 'r' +#endif + +#ifndef PERL_MAGIC_sig +# define PERL_MAGIC_sig 'S' +#endif + +#ifndef PERL_MAGIC_sigelem +# define PERL_MAGIC_sigelem 's' +#endif + +#ifndef PERL_MAGIC_taint +# define PERL_MAGIC_taint 't' +#endif + +#ifndef PERL_MAGIC_uvar +# define PERL_MAGIC_uvar 'U' +#endif + +#ifndef PERL_MAGIC_uvar_elem +# define PERL_MAGIC_uvar_elem 'u' +#endif + +#ifndef PERL_MAGIC_vstring +# define PERL_MAGIC_vstring 'V' +#endif + +#ifndef PERL_MAGIC_vec +# define PERL_MAGIC_vec 'v' +#endif + +#ifndef PERL_MAGIC_utf8 +# define PERL_MAGIC_utf8 'w' +#endif + +#ifndef PERL_MAGIC_substr +# define PERL_MAGIC_substr 'x' +#endif + +#ifndef PERL_MAGIC_defelem +# define PERL_MAGIC_defelem 'y' +#endif + +#ifndef PERL_MAGIC_glob +# define PERL_MAGIC_glob '*' +#endif + +#ifndef PERL_MAGIC_arylen +# define PERL_MAGIC_arylen '#' +#endif + +#ifndef PERL_MAGIC_pos +# define PERL_MAGIC_pos '.' +#endif + +#ifndef PERL_MAGIC_backref +# define PERL_MAGIC_backref '<' +#endif + +#ifndef PERL_MAGIC_ext +# define PERL_MAGIC_ext '~' +#endif + +/* That's the best we can do... */ +#ifndef SvPV_force_nomg +# define SvPV_force_nomg SvPV_force +#endif + +#ifndef SvPV_nomg +# define SvPV_nomg SvPV +#endif + +#ifndef sv_catpvn_nomg +# define sv_catpvn_nomg sv_catpvn +#endif + +#ifndef sv_catsv_nomg +# define sv_catsv_nomg sv_catsv +#endif + +#ifndef sv_setsv_nomg +# define sv_setsv_nomg sv_setsv +#endif + +#ifndef sv_pvn_nomg +# define sv_pvn_nomg sv_pvn +#endif + +#ifndef SvIV_nomg +# define SvIV_nomg SvIV +#endif + +#ifndef SvUV_nomg +# define SvUV_nomg SvUV +#endif + +#ifndef sv_catpv_mg +# define sv_catpv_mg(sv, ptr) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_catpv(TeMpSv,ptr); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_catpvn_mg +# define sv_catpvn_mg(sv, ptr, len) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_catpvn(TeMpSv,ptr,len); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_catsv_mg +# define sv_catsv_mg(dsv, ssv) \ + STMT_START { \ + SV *TeMpSv = dsv; \ + sv_catsv(TeMpSv,ssv); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_setiv_mg +# define sv_setiv_mg(sv, i) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_setiv(TeMpSv,i); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_setnv_mg +# define sv_setnv_mg(sv, num) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_setnv(TeMpSv,num); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_setpv_mg +# define sv_setpv_mg(sv, ptr) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_setpv(TeMpSv,ptr); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_setpvn_mg +# define sv_setpvn_mg(sv, ptr, len) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_setpvn(TeMpSv,ptr,len); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_setsv_mg +# define sv_setsv_mg(dsv, ssv) \ + STMT_START { \ + SV *TeMpSv = dsv; \ + sv_setsv(TeMpSv,ssv); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_setuv_mg +# define sv_setuv_mg(sv, i) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_setuv(TeMpSv,i); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_usepvn_mg +# define sv_usepvn_mg(sv, ptr, len) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_usepvn(TeMpSv,ptr,len); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifdef USE_ITHREADS +#ifndef CopFILE +# define CopFILE(c) ((c)->cop_file) +#endif + +#ifndef CopFILEGV +# define CopFILEGV(c) (CopFILE(c) ? gv_fetchfile(CopFILE(c)) : Nullgv) +#endif + +#ifndef CopFILE_set +# define CopFILE_set(c,pv) ((c)->cop_file = savepv(pv)) +#endif + +#ifndef CopFILESV +# define CopFILESV(c) (CopFILE(c) ? GvSV(gv_fetchfile(CopFILE(c))) : Nullsv) +#endif + +#ifndef CopFILEAV +# define CopFILEAV(c) (CopFILE(c) ? GvAV(gv_fetchfile(CopFILE(c))) : Nullav) +#endif + +#ifndef CopSTASHPV +# define CopSTASHPV(c) ((c)->cop_stashpv) +#endif + +#ifndef CopSTASHPV_set +# define CopSTASHPV_set(c,pv) ((c)->cop_stashpv = ((pv) ? savepv(pv) : Nullch)) +#endif + +#ifndef CopSTASH +# define CopSTASH(c) (CopSTASHPV(c) ? gv_stashpv(CopSTASHPV(c),GV_ADD) : Nullhv) +#endif + +#ifndef CopSTASH_set +# define CopSTASH_set(c,hv) CopSTASHPV_set(c, (hv) ? HvNAME(hv) : Nullch) +#endif + +#ifndef CopSTASH_eq +# define CopSTASH_eq(c,hv) ((hv) && (CopSTASHPV(c) == HvNAME(hv) \ + || (CopSTASHPV(c) && HvNAME(hv) \ + && strEQ(CopSTASHPV(c), HvNAME(hv))))) +#endif + +#else +#ifndef CopFILEGV +# define CopFILEGV(c) ((c)->cop_filegv) +#endif + +#ifndef CopFILEGV_set +# define CopFILEGV_set(c,gv) ((c)->cop_filegv = (GV*)SvREFCNT_inc(gv)) +#endif + +#ifndef CopFILE_set +# define CopFILE_set(c,pv) CopFILEGV_set((c), gv_fetchfile(pv)) +#endif + +#ifndef CopFILESV +# define CopFILESV(c) (CopFILEGV(c) ? GvSV(CopFILEGV(c)) : Nullsv) +#endif + +#ifndef CopFILEAV +# define CopFILEAV(c) (CopFILEGV(c) ? GvAV(CopFILEGV(c)) : Nullav) +#endif + +#ifndef CopFILE +# define CopFILE(c) (CopFILESV(c) ? SvPVX(CopFILESV(c)) : Nullch) +#endif + +#ifndef CopSTASH +# define CopSTASH(c) ((c)->cop_stash) +#endif + +#ifndef CopSTASH_set +# define CopSTASH_set(c,hv) ((c)->cop_stash = (hv)) +#endif + +#ifndef CopSTASHPV +# define CopSTASHPV(c) (CopSTASH(c) ? HvNAME(CopSTASH(c)) : Nullch) +#endif + +#ifndef CopSTASHPV_set +# define CopSTASHPV_set(c,pv) CopSTASH_set((c), gv_stashpv(pv,GV_ADD)) +#endif + +#ifndef CopSTASH_eq +# define CopSTASH_eq(c,hv) (CopSTASH(c) == (hv)) +#endif + +#endif /* USE_ITHREADS */ +#ifndef IN_PERL_COMPILETIME +# define IN_PERL_COMPILETIME (PL_curcop == &PL_compiling) +#endif + +#ifndef IN_LOCALE_RUNTIME +# define IN_LOCALE_RUNTIME (PL_curcop->op_private & HINT_LOCALE) +#endif + +#ifndef IN_LOCALE_COMPILETIME +# define IN_LOCALE_COMPILETIME (PL_hints & HINT_LOCALE) +#endif + +#ifndef IN_LOCALE +# define IN_LOCALE (IN_PERL_COMPILETIME ? IN_LOCALE_COMPILETIME : IN_LOCALE_RUNTIME) +#endif +#ifndef IS_NUMBER_IN_UV +# define IS_NUMBER_IN_UV 0x01 +#endif + +#ifndef IS_NUMBER_GREATER_THAN_UV_MAX +# define IS_NUMBER_GREATER_THAN_UV_MAX 0x02 +#endif + +#ifndef IS_NUMBER_NOT_INT +# define IS_NUMBER_NOT_INT 0x04 +#endif + +#ifndef IS_NUMBER_NEG +# define IS_NUMBER_NEG 0x08 +#endif + +#ifndef IS_NUMBER_INFINITY +# define IS_NUMBER_INFINITY 0x10 +#endif + +#ifndef IS_NUMBER_NAN +# define IS_NUMBER_NAN 0x20 +#endif + +/* GROK_NUMERIC_RADIX depends on grok_numeric_radix */ +#ifndef GROK_NUMERIC_RADIX +# define GROK_NUMERIC_RADIX(sp, send) grok_numeric_radix(sp, send) +#endif +#ifndef PERL_SCAN_GREATER_THAN_UV_MAX +# define PERL_SCAN_GREATER_THAN_UV_MAX 0x02 +#endif + +#ifndef PERL_SCAN_SILENT_ILLDIGIT +# define PERL_SCAN_SILENT_ILLDIGIT 0x04 +#endif + +#ifndef PERL_SCAN_ALLOW_UNDERSCORES +# define PERL_SCAN_ALLOW_UNDERSCORES 0x01 +#endif + +#ifndef PERL_SCAN_DISALLOW_PREFIX +# define PERL_SCAN_DISALLOW_PREFIX 0x02 +#endif + +#ifndef grok_numeric_radix +#if defined(NEED_grok_numeric_radix) +static bool DPPP_(my_grok_numeric_radix)(pTHX_ const char ** sp, const char * send); +static +#else +extern bool DPPP_(my_grok_numeric_radix)(pTHX_ const char ** sp, const char * send); +#endif + +#ifdef grok_numeric_radix +# undef grok_numeric_radix +#endif +#define grok_numeric_radix(a,b) DPPP_(my_grok_numeric_radix)(aTHX_ a,b) +#define Perl_grok_numeric_radix DPPP_(my_grok_numeric_radix) + +#if defined(NEED_grok_numeric_radix) || defined(NEED_grok_numeric_radix_GLOBAL) +bool +DPPP_(my_grok_numeric_radix)(pTHX_ const char **sp, const char *send) +{ +#ifdef USE_LOCALE_NUMERIC +#ifdef PL_numeric_radix_sv + if (PL_numeric_radix_sv && IN_LOCALE) { + STRLEN len; + char* radix = SvPV(PL_numeric_radix_sv, len); + if (*sp + len <= send && memEQ(*sp, radix, len)) { + *sp += len; + return TRUE; + } + } +#else + /* older perls don't have PL_numeric_radix_sv so the radix + * must manually be requested from locale.h + */ +#include <locale.h> + dTHR; /* needed for older threaded perls */ + struct lconv *lc = localeconv(); + char *radix = lc->decimal_point; + if (radix && IN_LOCALE) { + STRLEN len = strlen(radix); + if (*sp + len <= send && memEQ(*sp, radix, len)) { + *sp += len; + return TRUE; + } + } +#endif /* PERL_VERSION */ +#endif /* USE_LOCALE_NUMERIC */ + /* always try "." if numeric radix didn't match because + * we may have data from different locales mixed */ + if (*sp < send && **sp == '.') { + ++*sp; + return TRUE; + } + return FALSE; +} +#endif +#endif + +/* grok_number depends on grok_numeric_radix */ + +#ifndef grok_number +#if defined(NEED_grok_number) +static int DPPP_(my_grok_number)(pTHX_ const char * pv, STRLEN len, UV * valuep); +static +#else +extern int DPPP_(my_grok_number)(pTHX_ const char * pv, STRLEN len, UV * valuep); +#endif + +#ifdef grok_number +# undef grok_number +#endif +#define grok_number(a,b,c) DPPP_(my_grok_number)(aTHX_ a,b,c) +#define Perl_grok_number DPPP_(my_grok_number) + +#if defined(NEED_grok_number) || defined(NEED_grok_number_GLOBAL) +int +DPPP_(my_grok_number)(pTHX_ const char *pv, STRLEN len, UV *valuep) +{ + const char *s = pv; + const char *send = pv + len; + const UV max_div_10 = UV_MAX / 10; + const char max_mod_10 = UV_MAX % 10; + int numtype = 0; + int sawinf = 0; + int sawnan = 0; + + while (s < send && isSPACE(*s)) + s++; + if (s == send) { + return 0; + } else if (*s == '-') { + s++; + numtype = IS_NUMBER_NEG; + } + else if (*s == '+') + s++; + + if (s == send) + return 0; + + /* next must be digit or the radix separator or beginning of infinity */ + if (isDIGIT(*s)) { + /* UVs are at least 32 bits, so the first 9 decimal digits cannot + overflow. */ + UV value = *s - '0'; + /* This construction seems to be more optimiser friendly. + (without it gcc does the isDIGIT test and the *s - '0' separately) + With it gcc on arm is managing 6 instructions (6 cycles) per digit. + In theory the optimiser could deduce how far to unroll the loop + before checking for overflow. */ + if (++s < send) { + int digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + /* Now got 9 digits, so need to check + each time for overflow. */ + digit = *s - '0'; + while (digit >= 0 && digit <= 9 + && (value < max_div_10 + || (value == max_div_10 + && digit <= max_mod_10))) { + value = value * 10 + digit; + if (++s < send) + digit = *s - '0'; + else + break; + } + if (digit >= 0 && digit <= 9 + && (s < send)) { + /* value overflowed. + skip the remaining digits, don't + worry about setting *valuep. */ + do { + s++; + } while (s < send && isDIGIT(*s)); + numtype |= + IS_NUMBER_GREATER_THAN_UV_MAX; + goto skip_value; + } + } + } + } + } + } + } + } + } + } + } + } + } + } + } + } + } + } + numtype |= IS_NUMBER_IN_UV; + if (valuep) + *valuep = value; + + skip_value: + if (GROK_NUMERIC_RADIX(&s, send)) { + numtype |= IS_NUMBER_NOT_INT; + while (s < send && isDIGIT(*s)) /* optional digits after the radix */ + s++; + } + } + else if (GROK_NUMERIC_RADIX(&s, send)) { + numtype |= IS_NUMBER_NOT_INT | IS_NUMBER_IN_UV; /* valuep assigned below */ + /* no digits before the radix means we need digits after it */ + if (s < send && isDIGIT(*s)) { + do { + s++; + } while (s < send && isDIGIT(*s)); + if (valuep) { + /* integer approximation is valid - it's 0. */ + *valuep = 0; + } + } + else + return 0; + } else if (*s == 'I' || *s == 'i') { + s++; if (s == send || (*s != 'N' && *s != 'n')) return 0; + s++; if (s == send || (*s != 'F' && *s != 'f')) return 0; + s++; if (s < send && (*s == 'I' || *s == 'i')) { + s++; if (s == send || (*s != 'N' && *s != 'n')) return 0; + s++; if (s == send || (*s != 'I' && *s != 'i')) return 0; + s++; if (s == send || (*s != 'T' && *s != 't')) return 0; + s++; if (s == send || (*s != 'Y' && *s != 'y')) return 0; + s++; + } + sawinf = 1; + } else if (*s == 'N' || *s == 'n') { + /* XXX TODO: There are signaling NaNs and quiet NaNs. */ + s++; if (s == send || (*s != 'A' && *s != 'a')) return 0; + s++; if (s == send || (*s != 'N' && *s != 'n')) return 0; + s++; + sawnan = 1; + } else + return 0; + + if (sawinf) { + numtype &= IS_NUMBER_NEG; /* Keep track of sign */ + numtype |= IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT; + } else if (sawnan) { + numtype &= IS_NUMBER_NEG; /* Keep track of sign */ + numtype |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT; + } else if (s < send) { + /* we can have an optional exponent part */ + if (*s == 'e' || *s == 'E') { + /* The only flag we keep is sign. Blow away any "it's UV" */ + numtype &= IS_NUMBER_NEG; + numtype |= IS_NUMBER_NOT_INT; + s++; + if (s < send && (*s == '-' || *s == '+')) + s++; + if (s < send && isDIGIT(*s)) { + do { + s++; + } while (s < send && isDIGIT(*s)); + } + else + return 0; + } + } + while (s < send && isSPACE(*s)) + s++; + if (s >= send) + return numtype; + if (len == 10 && memEQ(pv, "0 but true", 10)) { + if (valuep) + *valuep = 0; + return IS_NUMBER_IN_UV; + } + return 0; +} +#endif +#endif + +/* + * The grok_* routines have been modified to use warn() instead of + * Perl_warner(). Also, 'hexdigit' was the former name of PL_hexdigit, + * which is why the stack variable has been renamed to 'xdigit'. + */ + +#ifndef grok_bin +#if defined(NEED_grok_bin) +static UV DPPP_(my_grok_bin)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result); +static +#else +extern UV DPPP_(my_grok_bin)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result); +#endif + +#ifdef grok_bin +# undef grok_bin +#endif +#define grok_bin(a,b,c,d) DPPP_(my_grok_bin)(aTHX_ a,b,c,d) +#define Perl_grok_bin DPPP_(my_grok_bin) + +#if defined(NEED_grok_bin) || defined(NEED_grok_bin_GLOBAL) +UV +DPPP_(my_grok_bin)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result) +{ + const char *s = start; + STRLEN len = *len_p; + UV value = 0; + NV value_nv = 0; + + const UV max_div_2 = UV_MAX / 2; + bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES; + bool overflowed = FALSE; + + if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) { + /* strip off leading b or 0b. + for compatibility silently suffer "b" and "0b" as valid binary + numbers. */ + if (len >= 1) { + if (s[0] == 'b') { + s++; + len--; + } + else if (len >= 2 && s[0] == '0' && s[1] == 'b') { + s+=2; + len-=2; + } + } + } + + for (; len-- && *s; s++) { + char bit = *s; + if (bit == '0' || bit == '1') { + /* Write it in this wonky order with a goto to attempt to get the + compiler to make the common case integer-only loop pretty tight. + With gcc seems to be much straighter code than old scan_bin. */ + redo: + if (!overflowed) { + if (value <= max_div_2) { + value = (value << 1) | (bit - '0'); + continue; + } + /* Bah. We're just overflowed. */ + warn("Integer overflow in binary number"); + overflowed = TRUE; + value_nv = (NV) value; + } + value_nv *= 2.0; + /* If an NV has not enough bits in its mantissa to + * represent a UV this summing of small low-order numbers + * is a waste of time (because the NV cannot preserve + * the low-order bits anyway): we could just remember when + * did we overflow and in the end just multiply value_nv by the + * right amount. */ + value_nv += (NV)(bit - '0'); + continue; + } + if (bit == '_' && len && allow_underscores && (bit = s[1]) + && (bit == '0' || bit == '1')) + { + --len; + ++s; + goto redo; + } + if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT)) + warn("Illegal binary digit '%c' ignored", *s); + break; + } + + if ( ( overflowed && value_nv > 4294967295.0) +#if UVSIZE > 4 + || (!overflowed && value > 0xffffffff ) +#endif + ) { + warn("Binary number > 0b11111111111111111111111111111111 non-portable"); + } + *len_p = s - start; + if (!overflowed) { + *flags = 0; + return value; + } + *flags = PERL_SCAN_GREATER_THAN_UV_MAX; + if (result) + *result = value_nv; + return UV_MAX; +} +#endif +#endif + +#ifndef grok_hex +#if defined(NEED_grok_hex) +static UV DPPP_(my_grok_hex)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result); +static +#else +extern UV DPPP_(my_grok_hex)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result); +#endif + +#ifdef grok_hex +# undef grok_hex +#endif +#define grok_hex(a,b,c,d) DPPP_(my_grok_hex)(aTHX_ a,b,c,d) +#define Perl_grok_hex DPPP_(my_grok_hex) + +#if defined(NEED_grok_hex) || defined(NEED_grok_hex_GLOBAL) +UV +DPPP_(my_grok_hex)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result) +{ + const char *s = start; + STRLEN len = *len_p; + UV value = 0; + NV value_nv = 0; + + const UV max_div_16 = UV_MAX / 16; + bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES; + bool overflowed = FALSE; + const char *xdigit; + + if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) { + /* strip off leading x or 0x. + for compatibility silently suffer "x" and "0x" as valid hex numbers. + */ + if (len >= 1) { + if (s[0] == 'x') { + s++; + len--; + } + else if (len >= 2 && s[0] == '0' && s[1] == 'x') { + s+=2; + len-=2; + } + } + } + + for (; len-- && *s; s++) { + xdigit = strchr((char *) PL_hexdigit, *s); + if (xdigit) { + /* Write it in this wonky order with a goto to attempt to get the + compiler to make the common case integer-only loop pretty tight. + With gcc seems to be much straighter code than old scan_hex. */ + redo: + if (!overflowed) { + if (value <= max_div_16) { + value = (value << 4) | ((xdigit - PL_hexdigit) & 15); + continue; + } + warn("Integer overflow in hexadecimal number"); + overflowed = TRUE; + value_nv = (NV) value; + } + value_nv *= 16.0; + /* If an NV has not enough bits in its mantissa to + * represent a UV this summing of small low-order numbers + * is a waste of time (because the NV cannot preserve + * the low-order bits anyway): we could just remember when + * did we overflow and in the end just multiply value_nv by the + * right amount of 16-tuples. */ + value_nv += (NV)((xdigit - PL_hexdigit) & 15); + continue; + } + if (*s == '_' && len && allow_underscores && s[1] + && (xdigit = strchr((char *) PL_hexdigit, s[1]))) + { + --len; + ++s; + goto redo; + } + if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT)) + warn("Illegal hexadecimal digit '%c' ignored", *s); + break; + } + + if ( ( overflowed && value_nv > 4294967295.0) +#if UVSIZE > 4 + || (!overflowed && value > 0xffffffff ) +#endif + ) { + warn("Hexadecimal number > 0xffffffff non-portable"); + } + *len_p = s - start; + if (!overflowed) { + *flags = 0; + return value; + } + *flags = PERL_SCAN_GREATER_THAN_UV_MAX; + if (result) + *result = value_nv; + return UV_MAX; +} +#endif +#endif + +#ifndef grok_oct +#if defined(NEED_grok_oct) +static UV DPPP_(my_grok_oct)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result); +static +#else +extern UV DPPP_(my_grok_oct)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result); +#endif + +#ifdef grok_oct +# undef grok_oct +#endif +#define grok_oct(a,b,c,d) DPPP_(my_grok_oct)(aTHX_ a,b,c,d) +#define Perl_grok_oct DPPP_(my_grok_oct) + +#if defined(NEED_grok_oct) || defined(NEED_grok_oct_GLOBAL) +UV +DPPP_(my_grok_oct)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result) +{ + const char *s = start; + STRLEN len = *len_p; + UV value = 0; + NV value_nv = 0; + + const UV max_div_8 = UV_MAX / 8; + bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES; + bool overflowed = FALSE; + + for (; len-- && *s; s++) { + /* gcc 2.95 optimiser not smart enough to figure that this subtraction + out front allows slicker code. */ + int digit = *s - '0'; + if (digit >= 0 && digit <= 7) { + /* Write it in this wonky order with a goto to attempt to get the + compiler to make the common case integer-only loop pretty tight. + */ + redo: + if (!overflowed) { + if (value <= max_div_8) { + value = (value << 3) | digit; + continue; + } + /* Bah. We're just overflowed. */ + warn("Integer overflow in octal number"); + overflowed = TRUE; + value_nv = (NV) value; + } + value_nv *= 8.0; + /* If an NV has not enough bits in its mantissa to + * represent a UV this summing of small low-order numbers + * is a waste of time (because the NV cannot preserve + * the low-order bits anyway): we could just remember when + * did we overflow and in the end just multiply value_nv by the + * right amount of 8-tuples. */ + value_nv += (NV)digit; + continue; + } + if (digit == ('_' - '0') && len && allow_underscores + && (digit = s[1] - '0') && (digit >= 0 && digit <= 7)) + { + --len; + ++s; + goto redo; + } + /* Allow \octal to work the DWIM way (that is, stop scanning + * as soon as non-octal characters are seen, complain only iff + * someone seems to want to use the digits eight and nine). */ + if (digit == 8 || digit == 9) { + if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT)) + warn("Illegal octal digit '%c' ignored", *s); + } + break; + } + + if ( ( overflowed && value_nv > 4294967295.0) +#if UVSIZE > 4 + || (!overflowed && value > 0xffffffff ) +#endif + ) { + warn("Octal number > 037777777777 non-portable"); + } + *len_p = s - start; + if (!overflowed) { + *flags = 0; + return value; + } + *flags = PERL_SCAN_GREATER_THAN_UV_MAX; + if (result) + *result = value_nv; + return UV_MAX; +} +#endif +#endif + +#endif /* _P_P_PORTABILITY_H_ */ + +/* End of File ppport.h */ diff --git a/gnu/usr.bin/perl/ext/XS/APItest/t/call.t b/gnu/usr.bin/perl/ext/XS/APItest/t/call.t new file mode 100755 index 00000000000..b4facd76f44 --- /dev/null +++ b/gnu/usr.bin/perl/ext/XS/APItest/t/call.t @@ -0,0 +1,174 @@ +#!perl -w + +# test the various call-into-perl-from-C functions +# DAPM Aug 2004 + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; + push @INC, "::lib:$MacPerl::Architecture:" if $^O eq 'MacOS'; + require Config; import Config; + if ($Config{'extensions'} !~ /\bXS\/APItest\b/) { + # Look, I'm using this fully-qualified variable more than once! + my $arch = $MacPerl::Architecture; + print "1..0 # Skip: XS::APItest was not built\n"; + exit 0; + } +} + +use warnings; +use strict; + +# Test::More doesn't have fresh_perl_is() yet +# use Test::More tests => 240; + +BEGIN { + require './test.pl'; + plan(240); + use_ok('XS::APItest') +}; + +######################### + +sub f { + shift; + unshift @_, 'b'; + pop @_; + @_, defined wantarray ? wantarray ? 'x' : 'y' : 'z'; +} + +sub d { + no warnings 'misc'; # keep G_KEEPERR from emitting this as a warning + die "its_dead_jim\n"; +} + +my $obj = bless [], 'Foo'; + +sub Foo::meth { + return 'bad_self' unless @_ && ref $_[0] && ref($_[0]) eq 'Foo'; + shift; + shift; + unshift @_, 'b'; + pop @_; + @_, defined wantarray ? wantarray ? 'x' : 'y' : 'z'; +} + +sub Foo::d { + no warnings 'misc'; # keep G_KEEPERR from emitting this as a warning + die "its_dead_jim\n"; +} + +for my $test ( + # flags args expected description + [ G_VOID, [ ], [ qw(z 1) ], '0 args, G_VOID' ], + [ G_VOID, [ qw(a p q) ], [ qw(z 1) ], '3 args, G_VOID' ], + [ G_SCALAR, [ ], [ qw(y 1) ], '0 args, G_SCALAR' ], + [ G_SCALAR, [ qw(a p q) ], [ qw(y 1) ], '3 args, G_SCALAR' ], + [ G_ARRAY, [ ], [ qw(x 1) ], '0 args, G_ARRAY' ], + [ G_ARRAY, [ qw(a p q) ], [ qw(b p x 3) ], '3 args, G_ARRAY' ], + [ G_DISCARD, [ ], [ qw(0) ], '0 args, G_DISCARD' ], + [ G_DISCARD, [ qw(a p q) ], [ qw(0) ], '3 args, G_DISCARD' ], +) +{ + my ($flags, $args, $expected, $description) = @$test; + + ok(eq_array( [ call_sv(\&f, $flags, @$args) ], $expected), + "$description call_sv(\\&f)"); + + ok(eq_array( [ call_sv(*f, $flags, @$args) ], $expected), + "$description call_sv(*f)"); + + ok(eq_array( [ call_sv('f', $flags, @$args) ], $expected), + "$description call_sv('f')"); + + ok(eq_array( [ call_pv('f', $flags, @$args) ], $expected), + "$description call_pv('f')"); + + ok(eq_array( [ eval_sv('f(' . join(',',map"'$_'",@$args) . ')', $flags) ], + $expected), "$description eval_sv('f(args)')"); + + ok(eq_array( [ call_method('meth', $flags, $obj, @$args) ], $expected), + "$description call_method('meth')"); + + for my $keep (0, G_KEEPERR) { + my $desc = $description . ($keep ? ' G_KEEPERR' : ''); + my $exp_err = $keep ? "before\n\t(in cleanup) its_dead_jim\n" + : "its_dead_jim\n"; + $@ = "before\n"; + ok(eq_array( [ call_sv('d', $flags|G_EVAL|$keep, @$args) ], + $flags & (G_ARRAY|G_DISCARD) ? [0] : [ undef, 1 ]), + "$desc G_EVAL call_sv('d')"); + is($@, $exp_err, "$desc G_EVAL call_sv('d') - \$@"); + + $@ = "before\n"; + ok(eq_array( [ call_pv('d', $flags|G_EVAL|$keep, @$args) ], + $flags & (G_ARRAY|G_DISCARD) ? [0] : [ undef, 1 ]), + "$desc G_EVAL call_pv('d')"); + is($@, $exp_err, "$desc G_EVAL call_pv('d') - \$@"); + + $@ = "before\n"; + ok(eq_array( [ eval_sv('d()', $flags|$keep) ], + $flags & (G_ARRAY|G_DISCARD) ? [0] : [ undef, 1 ]), + "$desc eval_sv('d()')"); + is($@, $exp_err, "$desc eval_sv('d()') - \$@"); + + $@ = "before\n"; + ok(eq_array( [ call_method('d', $flags|G_EVAL|$keep, $obj, @$args) ], + $flags & (G_ARRAY|G_DISCARD) ? [0] : [ undef, 1 ]), + "$desc G_EVAL call_method('d')"); + is($@, $exp_err, "$desc G_EVAL call_method('d') - \$@"); + } + + ok(eq_array( [ sub { call_sv('f', $flags|G_NOARGS, "bad") }->(@$args) ], + $expected), "$description G_NOARGS call_sv('f')"); + + ok(eq_array( [ sub { call_pv('f', $flags|G_NOARGS, "bad") }->(@$args) ], + $expected), "$description G_NOARGS call_pv('f')"); + + ok(eq_array( [ sub { eval_sv('f(@_)', $flags|G_NOARGS) }->(@$args) ], + $expected), "$description G_NOARGS eval_sv('f(@_)')"); + + # XXX call_method(G_NOARGS) isn't tested: I'm assuming + # it's not a sensible combination. DAPM. + + ok(eq_array( [ eval { call_sv('d', $flags, @$args)}, $@ ], + [ "its_dead_jim\n" ]), "$description eval { call_sv('d') }"); + + ok(eq_array( [ eval { call_pv('d', $flags, @$args) }, $@ ], + [ "its_dead_jim\n" ]), "$description eval { call_pv('d') }"); + + ok(eq_array( [ eval { eval_sv('d', $flags), $@ }, $@ ], + [ ($flags & (G_ARRAY|G_DISCARD)) ? (0) : (undef, 1), + "its_dead_jim\n", '' ]), + "$description eval { eval_sv('d') }"); + + ok(eq_array( [ eval { call_method('d', $flags, $obj, @$args) }, $@ ], + [ "its_dead_jim\n" ]), "$description eval { call_method('d') }"); + +}; + +is(eval_pv('f()', 0), 'y', "eval_pv('f()', 0)"); +is(eval_pv('f(qw(a b c))', 0), 'y', "eval_pv('f(qw(a b c))', 0)"); +is(eval_pv('d()', 0), undef, "eval_pv('d()', 0)"); +is($@, "its_dead_jim\n", "eval_pv('d()', 0) - \$@"); +is(eval { eval_pv('d()', 1) } , undef, "eval { eval_pv('d()', 1) }"); +is($@, "its_dead_jim\n", "eval { eval_pv('d()', 1) } - \$@"); + +# DAPM 9-Aug-04. A taint test in eval_sv() could die after setting up +# a new jump level but before pushing an eval context, leading to +# stack corruption + +fresh_perl_is(<<'EOF', "x=2", { switches => ['-T'] }, 'eval_sv() taint'); +use XS::APItest; + +my $x = 0; +sub f { + eval { my @a = ($^X . "x" , eval_sv(q(die "inner\n"), 0)) ; }; + $x++; + $a <=> $b; +} + +eval { my @a = sort f 2, 1; $x++}; +print "x=$x\n"; +EOF + diff --git a/gnu/usr.bin/perl/globals.c b/gnu/usr.bin/perl/globals.c index 5c487b9d99f..994ca8da957 100644 --- a/gnu/usr.bin/perl/globals.c +++ b/gnu/usr.bin/perl/globals.c @@ -12,6 +12,24 @@ * Elves, Dwarves, and Men." --Elrond */ +/* This file exists to #include "perl.h" _ONCE_ with + * PERL_IN_GLOBALS_C defined. That causes various global varaiables + * in perl.h and other files it includes to be _defined_ (and initialized) + * rather than just declared. + * + * There is a #include "perlapi.h" which makes use of the fact + * that the object file created from this file will be included by linker + * (to resolve global variables). perlapi.h mention various other "API" + * functions not used by perl itself, but the functions get + * pulled into the perl executable via the refrerence here. + * + * Two printf() like functions have also found their way here. + * Most likely by analogy to the API scheme above (as perl doesn't + * use them) but they probably belong elsewhere the obvious place + * being in perlio.c + * +*/ + #include "INTERN.h" #define PERL_IN_GLOBALS_C #include "perl.h" diff --git a/gnu/usr.bin/perl/hints/aix_4.sh b/gnu/usr.bin/perl/hints/aix_4.sh index 35ae7818838..489ce89a732 100644 --- a/gnu/usr.bin/perl/hints/aix_4.sh +++ b/gnu/usr.bin/perl/hints/aix_4.sh @@ -216,7 +216,11 @@ regcomp_cflags='optimize=' # -bI:$(PERL_INC)/perl.exp Read the exported symbols from the perl binary # -bE:$(BASEEXT).exp Export these symbols. This file contains only one # symbol: boot_$(EXP) can it be auto-generated? -lddlflags="$lddlflags -bhalt:4 -bM:SRE -bI:\$(PERL_INC)/perl.exp -bE:\$(BASEEXT).exp -bnoentry -lc" +if test $usenativedlopen = 'true' ; then + lddlflags="$lddlflags -bhalt:4 -bexpall -G -bnoentry -lc" +else + lddlflags="$lddlflags -bhalt:4 -bM:SRE -bI:\$(PERL_INC)/perl.exp -bE:\$(BASEEXT).exp -bnoentry -lc" + fi case "$use64bitall" in $define|true|[yY]*) use64bitint="$define" ;; @@ -402,6 +406,7 @@ libswanted_uselargefiles="`getconf XBS5_ILP32_OFFBIG_LIBS 2>/dev/null|sed -e 's@ ccflags="`echo $ccflags | sed -e 's@ -b@ -Wl,-b@g'`" ldflags="`echo ' '$ldflags | sed -e 's@ -b@ -Wl,-b@g'`" lddlflags="`echo ' '$lddlflags | sed -e 's@ -b@ -Wl,-b@g'`" + lddlflags="`echo ' '$lddlflags | sed -e 's@ -G @ -Wl,-G @g'`" ld='gcc' echo >&4 "(using ccflags $ccflags)" echo >&4 "(using ldflags $ldflags)" diff --git a/gnu/usr.bin/perl/lib/Carp.t b/gnu/usr.bin/perl/lib/Carp.t index cc2da1744c0..47f83c96c1c 100644 --- a/gnu/usr.bin/perl/lib/Carp.t +++ b/gnu/usr.bin/perl/lib/Carp.t @@ -1,31 +1,33 @@ BEGIN { chdir 't' if -d 't'; @INC = '../lib'; + require './test.pl'; } use Carp qw(carp cluck croak confess); -print "1..9\n"; +plan tests => 19; -print "ok 1\n"; +ok 1; -$SIG{__WARN__} = sub { - print "ok $1\n" - if $_[0] =~ m!ok (\d+)\n at .+\b(?i:carp\.t) line \d+$! }; +{ local $SIG{__WARN__} = sub { + like $_[0], qr/ok (\d+)\n at.+\b(?i:carp\.t) line \d+$/, 'ok 2\n' }; -carp "ok 2\n"; - -$SIG{__WARN__} = sub { - print "ok $1\n" - if $_[0] =~ m!(\d+) at .+\b(?i:carp\.t) line \d+$! }; + carp "ok 2\n"; -carp 3; +} + +{ local $SIG{__WARN__} = sub { + like $_[0], qr/(\d+) at.+\b(?i:carp\.t) line \d+$/, 'carp 3' }; + + carp 3; + +} sub sub_4 { -$SIG{__WARN__} = sub { - print "ok $1\n" - if $_[0] =~ m!^(\d+) at .+\b(?i:carp\.t) line \d+\n\tmain::sub_4\(\) called at .+\b(?i:carp\.t) line \d+$! }; +local $SIG{__WARN__} = sub { + like $_[0], qr/^(\d+) at.+\b(?i:carp\.t) line \d+\n\tmain::sub_4\(\) called at.+\b(?i:carp\.t) line \d+$/, 'cluck 4' }; cluck 4; @@ -33,39 +35,123 @@ cluck 4; sub_4; -$SIG{__DIE__} = sub { - print "ok $1\n" - if $_[0] =~ m!^(\d+) at .+\b(?i:carp\.t) line \d+\n\teval \Q{...}\E called at .+\b(?i:carp\.t) line \d+$! }; +{ local $SIG{__DIE__} = sub { + like $_[0], qr/^(\d+) at.+\b(?i:carp\.t) line \d+\n\teval \Q{...}\E called at.+\b(?i:carp\.t) line \d+$/, 'croak 5' }; -eval { croak 5 }; + eval { croak 5 }; +} sub sub_6 { - $SIG{__DIE__} = sub { - print "ok $1\n" - if $_[0] =~ m!^(\d+) at .+\b(?i:carp\.t) line \d+\n\teval \Q{...}\E called at .+\b(?i:carp\.t) line \d+\n\tmain::sub_6\(\) called at .+\b(?i:carp\.t) line \d+$! }; + local $SIG{__DIE__} = sub { + like $_[0], qr/^(\d+) at.+\b(?i:carp\.t) line \d+\n\teval \Q{...}\E called at.+\b(?i:carp\.t) line \d+\n\tmain::sub_6\(\) called at.+\b(?i:carp\.t) line \d+$/, 'confess 6' }; eval { confess 6 }; } sub_6; -print "ok 7\n"; +ok(1); # test for caller_info API my $eval = "use Carp::Heavy; return Carp::caller_info(0);"; my %info = eval($eval); -print "not " if ($info{sub_name} ne "eval '$eval'"); -print "ok 8\n"; +is($info{sub_name}, "eval '$eval'", 'caller_info API'); # test for '...::CARP_NOT used only once' warning from Carp::Heavy my $warning; eval { BEGIN { $^W = 1; - $SIG{__WARN__} = + local $SIG{__WARN__} = sub { if( defined $^S ){ warn $_[0] } else { $warning = $_[0] } } } - package Z; + package Z; BEGIN { eval { Carp::croak() } } }; -print $warning ? "not ok 9\n#$warning" : "ok 9\n"; +ok !$warning, q/'...::CARP_NOT used only once' warning from Carp::Heavy/; + + +# tests for global variables +sub x { carp @_ } +sub w { cluck @_ } + +# $Carp::Verbose; +{ my $aref = [ + qr/t at \S*(?i:carp.t) line \d+/, + qr/t at \S*(?i:carp.t) line \d+\n\s*main::x\('t'\) called at \S*(?i:carp.t) line \d+/ + ]; + my $i = 0; + + for my $re (@$aref) { + local $Carp::Verbose = $i++; + local $SIG{__WARN__} = sub { + like $_[0], $re, 'Verbose'; + }; + package Z; + main::x('t'); + } +} + +# $Carp::MaxEvalLen +{ my $test_num = 1; + for(0,4) { + my $txt = "Carp::cluck($test_num)"; + local $Carp::MaxEvalLen = $_; + local $SIG{__WARN__} = sub { + "@_"=~/'(.+?)(?:\n|')/s; + is length($1), length($_?substr($txt,0,$_):substr($txt,0)), 'MaxEvalLen'; + }; + eval "$txt"; $test_num++; + } +} + +# $Carp::MaxArgLen +{ + for(0,4) { + my $arg = 'testtest'; + local $Carp::MaxArgLen = $_; + local $SIG{__WARN__} = sub { + "@_"=~/'(.+?)'/; + is length($1), length($_?substr($arg,0,$_):substr($arg,0)), 'MaxArgLen'; + }; + + package Z; + main::w($arg); + } +} + +# $Carp::MaxArgNums +{ my $i = 0; + my $aref = [ + qr/1234 at \S*(?i:carp.t) line \d+\n\s*main::w\(1, 2, 3, 4\) called at \S*(?i:carp.t) line \d+/, + qr/1234 at \S*(?i:carp.t) line \d+\n\s*main::w\(1, 2, \.\.\.\) called at \S*(?i:carp.t) line \d+/, + ]; + + for(@$aref) { + local $Carp::MaxArgNums = $i++; + local $SIG{__WARN__} = sub { + like "@_", $_, 'MaxArgNums'; + }; + + package Z; + main::w(1..4); + } +} + +# $Carp::CarpLevel +{ my $i = 0; + my $aref = [ + qr/1 at \S*(?i:carp.t) line \d+\n\s*main::w\(1\) called at \S*(?i:carp.t) line \d+/, + qr/1 at \S*(?i:carp.t) line \d+$/, + ]; + + for (@$aref) { + local $Carp::CarpLevel = $i++; + local $SIG{__WARN__} = sub { + like "@_", $_, 'CarpLevel'; + }; + + package Z; + main::w(1); + } +} diff --git a/gnu/usr.bin/perl/lib/Config.t b/gnu/usr.bin/perl/lib/Config.t index 502f0aa5e2f..3ed110a0499 100644 --- a/gnu/usr.bin/perl/lib/Config.t +++ b/gnu/usr.bin/perl/lib/Config.t @@ -6,7 +6,7 @@ BEGIN { require "./test.pl"; } -plan tests => 47; +plan 'no_plan'; use_ok('Config'); @@ -40,7 +40,7 @@ ok(!exists $Config{d_bork}, "has no d_bork"); like($Config{ivsize}, qr/^(4|8)$/, "ivsize is 4 or 8 (it is $Config{ivsize})"); -# byteorder is virtual, but it has rules. +# byteorder is virtual, but it has rules. like($Config{byteorder}, qr/^(1234|4321|12345678|87654321)$/, "byteorder is 1234 or 4321 or 12345678 or 87654321 (it is $Config{byteorder})"); @@ -62,56 +62,100 @@ ok(exists $Config{ccflags_nolargefiles}, "has ccflags_nolargefiles"); } } -like(Config::myconfig(), qr/osname=\Q$Config{osname}\E/, "myconfig"); -like(Config::config_sh(), qr/osname='\Q$Config{osname}\E'/, "config_sh"); -like(join("\n", Config::config_re('c.*')), - qr/^c.*?=/, 'config_re' ); +like(Config::myconfig(), qr/osname=\Q$Config{osname}\E/, "myconfig"); +like(Config::config_sh(), qr/osname='\Q$Config{osname}\E'/, "config_sh"); +like(Config::config_sh(), qr/byteorder='[1-8]+'/, + "config_sh has a valid byteorder"); +foreach my $line (Config::config_re('c.*')) { + like($line, qr/^c.*?=.*$/, 'config_re' ); +} my $out = tie *STDOUT, 'FakeOut'; -Config::config_vars('cc'); +Config::config_vars('cc'); # non-regex test of essential cfg-var my $out1 = $$out; $out->clear; -Config::config_vars('d_bork'); +Config::config_vars('d_bork'); # non-regex, non-existent cfg-var my $out2 = $$out; $out->clear; -Config::config_vars('PERL_API_.*'); +Config::config_vars('PERL_API_.*'); # regex, tagged multi-line answer my $out3 = $$out; $out->clear; -Config::config_vars(':PERL_API_.*:'); +Config::config_vars('PERL_API_.*:'); # regex, tagged single-line answer my $out4 = $$out; $out->clear; -Config::config_vars(':PERL_API_REVISION:'); +Config::config_vars(':PERL_API_.*:'); # regex, non-tagged single-line answer my $out5 = $$out; $out->clear; -Config::config_vars('?flags'); +Config::config_vars(':PERL_API_.*'); # regex, non-tagged multi-line answer my $out6 = $$out; $out->clear; +Config::config_vars('PERL_API_REVISION.*:'); # regex, tagged +my $out7 = $$out; +$out->clear; + +Config::config_vars(':PERL_API_REVISION.*'); # regex, non-tagged multi-line answer +my $out8 = $$out; +$out->clear; + +Config::config_vars('PERL_EXPENSIVE_.*:'); # non-matching regex +my $out9 = $$out; +$out->clear; + +Config::config_vars('?flags'); # bogus regex, no explicit warning ! +my $out10 = $$out; +$out->clear; + untie *STDOUT; -like($out1, qr/^cc='\Q$Config{cc}\E';/, "config_vars cc"); -like($out2, qr/^d_bork='UNKNOWN';/, "config_vars d_bork is UNKNOWN"); -is(3, scalar split(/\n/, $out3), "3 PERL_API vars found"); -my @api = $out3 =~ /^PERL_API_(\w+)=(.*);/mg; -is("'5'", $api[1], "1st is 5"); -is("'8'", $api[5], "2nd is 9"); -is("'0'", $api[3], "3rd is 1"); -@api = split(/ /, $out4); -is(3, @api, "trailing colon puts 3 terms on same line"); -unlike($out4, qr/=/, "leading colon suppresses param names"); -is("'5'", $api[0], "revision is 5"); -is("'8'", $api[2], "version is 9"); -is("'0'", $api[1], "subversion is 1"); +like($out1, qr/^cc='\Q$Config{cc}\E';/, "found config_var cc"); +like($out2, qr/^d_bork='UNKNOWN';/, "config_var d_bork is UNKNOWN"); + +# test for leading, trailing colon effects +is(scalar split(/;\n/, $out3), 3, "3 lines found"); +is(scalar split(/;\n/, $out6), 3, "3 lines found"); -is("'5' ", $out5, "leading and trailing colons return just the value"); +is($out4 =~ /(;\n)/s, '', "trailing colon gives 1-line response: $out4"); +is($out5 =~ /(;\n)/s, '', "trailing colon gives 1-line response: $out5"); -like($out6, qr/\bnot\s+found\b/, "config_vars with invalid regexp"); +is(scalar split(/=/, $out3), 4, "found 'tag='"); +is(scalar split(/=/, $out4), 4, "found 'tag='"); + +my @api; + +my @rev = @Config{qw(PERL_API_REVISION PERL_API_VERSION PERL_API_SUBVERSION)}; + +print ("# test tagged responses, multi-line and single-line\n"); +foreach $api ($out3, $out4) { + @api = $api =~ /PERL_API_(\w+)=(.*?)(?:;\n|\s)/mg; + is($api[0], "REVISION", "REVISION tag"); + is($api[4], "VERSION", "VERSION tag"); + is($api[2], "SUBVERSION", "SUBVERSION tag"); + is($api[1], "'$rev[0]'", "REVISION is $rev[0]"); + is($api[5], "'$rev[1]'", "VERSION is $rev[1]"); + is($api[3], "'$rev[2]'", "SUBVERSION is $rev[2]"); +} + +print("# test non-tagged responses, multi-line and single-line\n"); +foreach $api ($out5, $out6) { + @api = split /(?: |;\n)/, $api; + is($api[0], "'$rev[0]'", "revision is $rev[0]"); + is($api[2], "'$rev[1]'", "version is $rev[1]"); + is($api[1], "'$rev[2]'", "subversion is $rev[2]"); +} + +# compare to each other, the outputs for trailing, leading colon +$out7 =~ s/ $//; +is("$out7;\n", "PERL_API_REVISION=$out8", "got expected diffs"); + +like($out9, qr/\bnot\s+found\b/, "$out9 - perl is FREE !"); +like($out10, qr/\bnot\s+found\b/, "config_vars with invalid regexp"); # Read-only. @@ -155,3 +199,12 @@ ok( exists $Config{d_fork}, "still d_fork"); is($Config{sig_num_init} =~ tr/,/,/, $Config{sig_size}, "sig_num_init size"); is($Config{sig_name_init} =~ tr/,/,/, $Config{sig_size}, "sig_name_init size"); + +# Test the troublesome virtual stuff +foreach my $pain (qw(byteorder)) { + # No config var is named with anything that is a regexp metachar" + my @result = Config::config_re($pain); + is (scalar @result, 1, "single result for config_re('$pain')"); + like ($result[0], qr/^$pain=(['"])$Config{$pain}\1$/, # grr ' + "which is the expected result for $pain"); +} diff --git a/gnu/usr.bin/perl/lib/Dumpvalue.t b/gnu/usr.bin/perl/lib/Dumpvalue.t index b22b86d7321..8eb70a34b84 100644 --- a/gnu/usr.bin/perl/lib/Dumpvalue.t +++ b/gnu/usr.bin/perl/lib/Dumpvalue.t @@ -205,7 +205,10 @@ is( $out->read, "\$_<foo = 1\n", 'dumped glob for $_<foo correctly (DB)' ); # test CvGV name SKIP: { - skip( 'no Devel::Peek', 1 ) unless use_ok( 'Devel::Peek' ); + if (" $Config::Config{'extensions'} " !~ m[ Devel/Peek ]) { + skip( 'no Devel::Peek', 2 ); + } + use_ok( 'Devel::Peek' ); is( $d->CvGV_name(\&TieOut::read), 'TieOut::read', 'CvGV_name found sub' ); } diff --git a/gnu/usr.bin/perl/lib/I18N/LangTags/t/20_locales.t b/gnu/usr.bin/perl/lib/I18N/LangTags/t/20_locales.t new file mode 100755 index 00000000000..ae04812ff2a --- /dev/null +++ b/gnu/usr.bin/perl/lib/I18N/LangTags/t/20_locales.t @@ -0,0 +1,38 @@ +require 5; + # Time-stamp: "2004-10-06 23:07:06 ADT" +use strict; +use Test; +BEGIN { plan tests => 22 }; +BEGIN { ok 1 } +use I18N::LangTags (':ALL'); + +print "# Perl v$], I18N::LangTags v$I18N::LangTags::VERSION\n"; +print "# Loaded from ", $INC{'I18N/LangTags.pm'} || "??", "\n"; + +ok lc locale2language_tag('en'), 'en'; +ok lc locale2language_tag('en_US'), 'en-us'; +ok lc locale2language_tag('en_US.ISO8859-1'), 'en-us'; +ok lc(locale2language_tag('C')||''), ''; +ok lc(locale2language_tag('POSIX')||''), ''; + + +ok lc locale2language_tag('eu_mt'), 'eu-mt'; +ok lc locale2language_tag('eu'), 'eu'; +ok lc locale2language_tag('it'), 'it'; +ok lc locale2language_tag('it_IT'), 'it-it'; +ok lc locale2language_tag('it_IT.utf8'), 'it-it'; +ok lc locale2language_tag('it_IT.utf8@euro'), 'it-it'; +ok lc locale2language_tag('it_IT@euro'), 'it-it'; + + +ok lc locale2language_tag('zh_CN.gb18030'), 'zh-cn'; +ok lc locale2language_tag('zh_CN.gbk'), 'zh-cn'; +ok lc locale2language_tag('zh_CN.utf8'), 'zh-cn'; +ok lc locale2language_tag('zh_HK'), 'zh-hk'; +ok lc locale2language_tag('zh_HK.utf8'), 'zh-hk'; +ok lc locale2language_tag('zh_TW'), 'zh-tw'; +ok lc locale2language_tag('zh_TW.euctw'), 'zh-tw'; +ok lc locale2language_tag('zh_TW.utf8'), 'zh-tw'; + +print "# So there!\n"; +ok 1; diff --git a/gnu/usr.bin/perl/lib/open.pm b/gnu/usr.bin/perl/lib/open.pm index 32c5118be9d..45158994619 100644 --- a/gnu/usr.bin/perl/lib/open.pm +++ b/gnu/usr.bin/perl/lib/open.pm @@ -3,64 +3,58 @@ use warnings; use Carp; $open::hint_bits = 0x20000; # HINT_LOCALIZE_HH -our $VERSION = '1.03'; +our $VERSION = '1.04'; + +require 5.008001; # for PerlIO::get_layers() my $locale_encoding; -sub in_locale { $^H & ($locale::hint_bits || 0)} - -sub _get_locale_encoding { - unless (defined $locale_encoding) { - # I18N::Langinfo isn't available everywhere - eval { - require I18N::Langinfo; - I18N::Langinfo->import(qw(langinfo CODESET)); - $locale_encoding = langinfo(CODESET()); - }; - my $country_language; - - no warnings 'uninitialized'; - - if (not $locale_encoding && in_locale()) { - if ($ENV{LC_ALL} =~ /^([^.]+)\.([^.]+)$/) { - ($country_language, $locale_encoding) = ($1, $2); - } elsif ($ENV{LANG} =~ /^([^.]+)\.([^.]+)$/) { - ($country_language, $locale_encoding) = ($1, $2); - } - # LANGUAGE affects only LC_MESSAGES only on glibc - } elsif (not $locale_encoding) { - if ($ENV{LC_ALL} =~ /\butf-?8\b/i || - $ENV{LANG} =~ /\butf-?8\b/i) { - $locale_encoding = 'utf8'; - } - # Could do more heuristics based on the country and language - # parts of LC_ALL and LANG (the parts before the dot (if any)), - # since we have Locale::Country and Locale::Language available. - # TODO: get a database of Language -> Encoding mappings - # (the Estonian database at http://www.eki.ee/letter/ - # would be excellent!) --jhi - } - if (defined $locale_encoding && - lc($locale_encoding) eq 'euc' && - defined $country_language) { - if ($country_language =~ /^ja_JP|japan(?:ese)?$/i) { - $locale_encoding = 'euc-jp'; - } elsif ($country_language =~ /^ko_KR|korean?$/i) { - $locale_encoding = 'euc-kr'; - } elsif ($country_language =~ /^zh_CN|chin(?:a|ese)?$/i) { - $locale_encoding = 'euc-cn'; - } elsif ($country_language =~ /^zh_TW|taiwan(?:ese)?$/i) { - $locale_encoding = 'euc-tw'; - } else { - croak "Locale encoding 'euc' too ambiguous"; - } - } +sub _get_encname { + return ($1, Encode::resolve_alias($1)) if $_[0] =~ /^:?encoding\((.+)\)$/; + return; +} + +sub _drop_oldenc { + # If by the time we arrive here there already is at the top of the + # perlio layer stack an encoding identical to what we would like + # to push via this open pragma, we will pop away the old encoding + # (+utf8) so that we can push ourselves in place (this is easier + # than ignoring pushing ourselves because of the way how ${^OPEN} + # works). So we are looking for something like + # + # stdio encoding(xxx) utf8 + # + # in the existing layer stack, and in the new stack chunk for + # + # :encoding(xxx) + # + # If we find a match, we pop the old stack (once, since + # the utf8 is just a flag on the encoding layer) + my ($h, @new) = @_; + return unless @new >= 1 && $new[-1] =~ /^:encoding\(.+\)$/; + my @old = PerlIO::get_layers($h); + return unless @old >= 3 && + $old[-1] eq 'utf8' && + $old[-2] =~ /^encoding\(.+\)$/; + require Encode; + my ($loname, $lcname) = _get_encname($old[-2]); + unless (defined $lcname) { # Should we trust get_layers()? + require Carp; + Carp::croak("open: Unknown encoding '$loname'"); + } + my ($voname, $vcname) = _get_encname($new[-1]); + unless (defined $vcname) { + require Carp; + Carp::croak("open: Unknown encoding '$voname'"); + } + if ($lcname eq $vcname) { + binmode($h, ":pop"); # utf8 is part of the encoding layer } } sub import { my ($class,@args) = @_; - croak("`use open' needs explicit list of PerlIO layers") unless @args; + croak("open: needs explicit list of PerlIO layers") unless @args; my $std; $^H |= $open::hint_bits; my ($in,$out) = split(/\0/,(${^OPEN} || "\0"), -1); @@ -81,7 +75,8 @@ sub import { $layer =~ s/^://; if ($layer eq 'locale') { require Encode; - _get_locale_encoding() + require encoding; + $locale_encoding = encoding::_get_locale_encoding() unless defined $locale_encoding; (warnings::warnif("layer", "Cannot figure out an encoding to use"), last) unless defined $locale_encoding; @@ -105,19 +100,23 @@ sub import { } } if ($type eq 'IN') { - $in = join(' ',@val); + _drop_oldenc(*STDIN, @val); + $in = join(' ', @val); } elsif ($type eq 'OUT') { - $out = join(' ',@val); + _drop_oldenc(*STDOUT, @val); + $out = join(' ', @val); } elsif ($type eq 'IO') { - $in = $out = join(' ',@val); + _drop_oldenc(*STDIN, @val); + _drop_oldenc(*STDOUT, @val); + $in = $out = join(' ', @val); } else { croak "Unknown PerlIO layer class '$type'"; } } - ${^OPEN} = join("\0",$in,$out) if $in or $out; + ${^OPEN} = join("\0", $in, $out); if ($std) { if ($in) { if ($in =~ /:utf8\b/) { @@ -229,35 +228,9 @@ chosen to be in C<< :encoding(koi8r) >>, a C<:std> will cause only the STDOUT and STDERR to be in C<koi8r>. The C<:locale> subpragma implicitly turns on C<:std>. -The logic of C<:locale> is as follows: - -=over 4 - -=item 1. - -If the platform supports the langinfo(CODESET) interface, the codeset -returned is used as the default encoding for the open pragma. - -=item 2. - -If 1. didn't work but we are under the locale pragma, the environment -variables LC_ALL and LANG (in that order) are matched for encodings -(the part after C<.>, if any), and if any found, that is used -as the default encoding for the open pragma. - -=item 3. - -If 1. and 2. didn't work, the environment variables LC_ALL and LANG -(in that order) are matched for anything looking like UTF-8, and if -any found, C<:utf8> is used as the default encoding for the open -pragma. - -=back - -If your locale environment variables (LC_ALL, LC_CTYPE, LANG) -contain the strings 'UTF-8' or 'UTF8' (case-insensitive matching), -the default encoding of your STDIN, STDOUT, and STDERR, and of -B<any subsequent file open>, is UTF-8. +The logic of C<:locale> is described in full in L</encoding>, +but in short it is first trying nl_langinfo(CODESET) and then +guessing from the LC_ALL and LANG locale environment variables. Directory handles may also support PerlIO layers in the future. diff --git a/gnu/usr.bin/perl/lib/open.t b/gnu/usr.bin/perl/lib/open.t index 55b955bd0fc..554798b9d6e 100644 --- a/gnu/usr.bin/perl/lib/open.t +++ b/gnu/usr.bin/perl/lib/open.t @@ -7,7 +7,7 @@ BEGIN { require Config; import Config; } -use Test::More tests => 17; +use Test::More tests => 16; # open::import expects 'open' as its first argument, but it clashes with open() sub import { @@ -43,17 +43,10 @@ eval q{ use warnings 'layer'; use open IN => ':macguffin' ; }; like( $warn, qr/Unknown PerlIO layer/, 'should warn about unknown layer with bad layer provided' ); -SKIP: { - skip("no perlio, no :utf8", 1) unless (find PerlIO::Layer 'perlio'); - skip("no Encode for locale layer", 1) unless eval { require Encode }; - # now load a real-looking locale - $ENV{LC_ALL} = ' .utf8'; - import( 'IN', 'locale' ); - like( ${^OPEN}, qr/^(:utf8)?:utf8\0/, - 'should set a valid locale layer' ); -} +# open :locale logic changed since open 1.04, new logic +# difficult to test portably. -# and see if it sets the magic variables appropriately +# see if it sets the magic variables appropriately import( 'IN', ':crlf' ); ok( $^H & $open::hint_bits, 'hint bits should be set in $^H after open import' ); diff --git a/gnu/usr.bin/perl/lib/overload.t b/gnu/usr.bin/perl/lib/overload.t index f743a822116..519c6d8810d 100644 --- a/gnu/usr.bin/perl/lib/overload.t +++ b/gnu/usr.bin/perl/lib/overload.t @@ -53,17 +53,24 @@ print "1..",&last,"\n"; sub test { $test++; if (@_ > 1) { + my $comment = ""; + $comment = " # " . $_ [2] if @_ > 2; if ($_[0] eq $_[1]) { - print "ok $test\n"; + print "ok $test$comment\n"; + return 1; } else { - print "not ok $test: '$_[0]' ne '$_[1]'\n"; + $comment .= ": '$_[0]' ne '$_[1]'"; + print "not ok $test$comment\n"; + return 0; } } else { if (shift) { print "ok $test\n"; + return 1; } else { print "not ok $test\n"; - } + return 0; + } } } @@ -1086,11 +1093,11 @@ sub xet { @_ == 2 ? $_[0]->{$_[1]} : package main; my $a = Foo->new; $a->xet('b', 42); -print $a->xet('b') == 42 ? "ok 225\n" : "not ok 225\n"; -print defined eval { $a->{b} } ? "not ok 226\n" : "ok 226\n"; -print $@ =~ /zap/ ? "ok 227\n" : "not ok 227\n"; +test ($a->xet('b'), 42); +test (!defined eval { $a->{b} }); +test ($@ =~ /zap/); -print overload::StrVal(qr/a/) =~ /^Regexp=SCALAR\(0x[0-9a-f]+\)$/ ? "ok 228\n" : "not ok 228\n"; +test (overload::StrVal(qr/a/) =~ /^Regexp=SCALAR\(0x[0-9a-f]+\)$/); { package t229; @@ -1105,8 +1112,52 @@ print overload::StrVal(qr/a/) =~ /^Regexp=SCALAR\(0x[0-9a-f]+\)$/ ? "ok 228\n" : my $y = $x; eval { $y++ }; } - print $warn ? "not ok 229\n" : "ok 229\n"; + main::test (!$warn); +} + +{ + my ($int, $out1, $out2); + { + BEGIN { $int = 0; overload::constant 'integer' => sub {$int++; 17}; } + $out1 = 0; + $out2 = 1; + } + test($int, 2, "#24313"); # 230 + test($out1, 17, "#24313"); # 231 + test($out2, 17, "#24313"); # 232 +} + +{ + package Numify; + use overload (qw(0+ numify fallback 1)); + + sub new { + my $val = $_[1]; + bless \$val, $_[0]; + } + + sub numify { ${$_[0]} } } +# These are all check that overloaded values rather than reference addressess +# are what is getting tested. +my ($two, $one, $un, $deux) = map {new Numify $_} 2, 1, 1, 2; +my ($ein, $zwei) = (1, 2); + +my %map = (one => 1, un => 1, ein => 1, deux => 2, two => 2, zwei => 2); +foreach my $op (qw(<=> == != < <= > >=)) { + foreach my $l (keys %map) { + foreach my $r (keys %map) { + my $ocode = "\$$l $op \$$r"; + my $rcode = "$map{$l} $op $map{$r}"; + + my $got = eval $ocode; + die if $@; + my $expect = eval $rcode; + die if $@; + test ($got, $expect, $ocode) or print "# $rcode\n"; + } + } +} # Last test is: -sub last {229} +sub last {484} diff --git a/gnu/usr.bin/perl/lib/unicore/mktables b/gnu/usr.bin/perl/lib/unicore/mktables index 18f0033506c..58092f19c55 100644 --- a/gnu/usr.bin/perl/lib/unicore/mktables +++ b/gnu/usr.bin/perl/lib/unicore/mktables @@ -1023,6 +1023,7 @@ sub UnicodeData_Txt() push @PVA, "\n", "\%utf8::$name = (\n", simple_dumper (%{$utf8::{$name}}), ");\n"; } + push @PVA, "1;\n"; WriteIfChanged("PVA.pl", @PVA); } diff --git a/gnu/usr.bin/perl/lib/warnings.pm b/gnu/usr.bin/perl/lib/warnings.pm index 14ed715fdc9..862f26d27c9 100644 --- a/gnu/usr.bin/perl/lib/warnings.pm +++ b/gnu/usr.bin/perl/lib/warnings.pm @@ -396,6 +396,8 @@ sub unimport ${^WARNING_BITS} = $mask ; } +my %builtin_type; @builtin_type{qw(SCALAR ARRAY HASH CODE REF GLOB LVALUE Regexp)} = (); + sub __chk { my $category ; @@ -405,10 +407,10 @@ sub __chk if (@_) { # check the category supplied. $category = shift ; - if (ref $category) { - Croaker ("not an object") - if $category !~ /^([^=]+)=/ ; - $category = $1 ; + if (my $type = ref $category) { + Croaker("not an object") + if exists $builtin_type{$type}; + $category = $type; $isobj = 1 ; } $offset = $Offsets{$category}; diff --git a/gnu/usr.bin/perl/locale.c b/gnu/usr.bin/perl/locale.c index 6f5f0166674..a73c5d68d25 100644 --- a/gnu/usr.bin/perl/locale.c +++ b/gnu/usr.bin/perl/locale.c @@ -18,6 +18,10 @@ * nef aear, si nef aearon! */ +/* utility functions for handling locale-specific stuff like what + * character represents the decimal point. + */ + #include "EXTERN.h" #define PERL_IN_LOCALE_C #include "perl.h" @@ -560,6 +564,7 @@ Perl_init_i18nl14n(pTHX_ int printwarn) * The real transformed data begins at offset sizeof(collationix). * Please see sv_collxfrm() to see how this is used. */ + char * Perl_mem_collxfrm(pTHX_ const char *s, STRLEN len, STRLEN *xlen) { diff --git a/gnu/usr.bin/perl/numeric.c b/gnu/usr.bin/perl/numeric.c index 6232f8e74c4..a6d9c90844d 100644 --- a/gnu/usr.bin/perl/numeric.c +++ b/gnu/usr.bin/perl/numeric.c @@ -15,6 +15,12 @@ /* =head1 Numeric functions + +This file contains all the stuff needed by perl for manipulating numeric +values, including such things as replacements for the OS's atof() function + +=cut + */ #include "EXTERN.h" @@ -118,8 +124,10 @@ converts a string representing a binary number to numeric form. On entry I<start> and I<*len> give the string to scan, I<*flags> gives conversion flags, and I<result> should be NULL or a pointer to an NV. The scan stops at the end of the string, or the first invalid character. -On return I<*len> is set to the length scanned string, and I<*flags> gives -output flags. +Unless C<PERL_SCAN_SILENT_ILLDIGIT> is set in I<*flags>, encountering an +invalid character will also trigger a warning. +On return I<*len> is set to the length of the scanned string, +and I<*flags> gives output flags. If the value is <= UV_MAX it is returned as a UV, the output flags are clear, and nothing is written to I<*result>. If the value is > UV_MAX C<grok_bin> @@ -127,7 +135,7 @@ returns UV_MAX, sets C<PERL_SCAN_GREATER_THAN_UV_MAX> in the output flags, and writes the value to I<*result> (or the value is discarded if I<result> is NULL). -The hex number may optionally be prefixed with "0b" or "b" unless +The binary number may optionally be prefixed with "0b" or "b" unless C<PERL_SCAN_DISALLOW_PREFIX> is set in I<*flags> on entry. If C<PERL_SCAN_ALLOW_UNDERSCORES> is set in I<*flags> then the binary number may use '_' characters to separate digits. @@ -231,9 +239,11 @@ converts a string representing a hex number to numeric form. On entry I<start> and I<*len> give the string to scan, I<*flags> gives conversion flags, and I<result> should be NULL or a pointer to an NV. -The scan stops at the end of the string, or the first non-hex-digit character. -On return I<*len> is set to the length scanned string, and I<*flags> gives -output flags. +The scan stops at the end of the string, or the first invalid character. +Unless C<PERL_SCAN_SILENT_ILLDIGIT> is set in I<*flags>, encountering an +invalid character will also trigger a warning. +On return I<*len> is set to the length of the scanned string, +and I<*flags> gives output flags. If the value is <= UV_MAX it is returned as a UV, the output flags are clear, and nothing is written to I<*result>. If the value is > UV_MAX C<grok_hex> @@ -342,6 +352,24 @@ Perl_grok_hex(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result) { /* =for apidoc grok_oct +converts a string representing an octal number to numeric form. + +On entry I<start> and I<*len> give the string to scan, I<*flags> gives +conversion flags, and I<result> should be NULL or a pointer to an NV. +The scan stops at the end of the string, or the first invalid character. +Unless C<PERL_SCAN_SILENT_ILLDIGIT> is set in I<*flags>, encountering an +invalid character will also trigger a warning. +On return I<*len> is set to the length of the scanned string, +and I<*flags> gives output flags. + +If the value is <= UV_MAX it is returned as a UV, the output flags are clear, +and nothing is written to I<*result>. If the value is > UV_MAX C<grok_oct> +returns UV_MAX, sets C<PERL_SCAN_GREATER_THAN_UV_MAX> in the output flags, +and writes the value to I<*result> (or the value is discarded if I<result> +is NULL). + +If C<PERL_SCAN_ALLOW_UNDERSCORES> is set in I<*flags> then the octal +number may use '_' characters to separate digits. =cut */ @@ -396,7 +424,7 @@ Perl_grok_oct(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result) { goto redo; } /* Allow \octal to work the DWIM way (that is, stop scanning - * as soon as non-octal characters are seen, complain only iff + * as soon as non-octal characters are seen, complain only if * someone seems to want to use the digits eight and nine). */ if (digit == 8 || digit == 9) { if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT) && ckWARN(WARN_DIGIT)) diff --git a/gnu/usr.bin/perl/pad.c b/gnu/usr.bin/perl/pad.c index aabb2a1b7ed..b866aaef2eb 100644 --- a/gnu/usr.bin/perl/pad.c +++ b/gnu/usr.bin/perl/pad.c @@ -22,6 +22,11 @@ /* =head1 Pad Data Structures +This file contains the functions that create and manipulate scratchpads, +which are array-of-array data structures attached to a CV (ie a sub) +and which store lexical variables and opcode temporary and per-thread +values. + =for apidoc m|AV *|CvPADLIST|CV *cv CV's can have CvPADLIST(cv) set to point to an AV. diff --git a/gnu/usr.bin/perl/perlapi.h b/gnu/usr.bin/perl/perlapi.h index b5cc9b76ea0..5a5df61f511 100644 --- a/gnu/usr.bin/perl/perlapi.h +++ b/gnu/usr.bin/perl/perlapi.h @@ -1020,6 +1020,8 @@ END_EXTERN_C #define PL_sv_placeholder (*Perl_Gsv_placeholder_ptr(NULL)) #undef PL_thr_key #define PL_thr_key (*Perl_Gthr_key_ptr(NULL)) +#undef PL_use_safe_putenv +#define PL_use_safe_putenv (*Perl_Guse_safe_putenv_ptr(NULL)) #endif /* !PERL_CORE */ #endif /* MULTIPLICITY */ diff --git a/gnu/usr.bin/perl/perlvars.h b/gnu/usr.bin/perl/perlvars.h index 2a697c23f96..e0bebeb4011 100644 --- a/gnu/usr.bin/perl/perlvars.h +++ b/gnu/usr.bin/perl/perlvars.h @@ -69,3 +69,6 @@ PERLVAR(Gsv_placeholder, SV) PERLVARI(Gcsighandlerp, Sighandler_t, &Perl_csighandler) /* Pointer to C-level sighandler */ #endif +#ifndef PERL_USE_SAFE_PUTENV +PERLVARI(Guse_safe_putenv, int, 1) +#endif diff --git a/gnu/usr.bin/perl/pod.lst b/gnu/usr.bin/perl/pod.lst index de777ea0784..8a25ec47901 100644 --- a/gnu/usr.bin/perl/pod.lst +++ b/gnu/usr.bin/perl/pod.lst @@ -120,7 +120,8 @@ h Miscellaneous perlhist Perl history records d perldelta Perl changes since previous version -D perl585delta Perl changes in version 5.8.5 +D perl586delta Perl changes in version 5.8.6 + perl585delta Perl changes in version 5.8.5 perl584delta Perl changes in version 5.8.4 perl583delta Perl changes in version 5.8.3 perl582delta Perl changes in version 5.8.2 diff --git a/gnu/usr.bin/perl/pod/perl573delta.pod b/gnu/usr.bin/perl/pod/perl573delta.pod index 1121eb5ca92..ea496789d34 100644 --- a/gnu/usr.bin/perl/pod/perl573delta.pod +++ b/gnu/usr.bin/perl/pod/perl573delta.pod @@ -103,7 +103,7 @@ document that use utf8 is not the right way most of the time =item 11656 -allow builing perl with -DUSE_UTF8_SCRIPTS which makes UTF-8 +allow building perl with -DUSE_UTF8_SCRIPTS which makes UTF-8 the default script encoding (not the default since that would break all scripts having legacy eight-bit data in them) diff --git a/gnu/usr.bin/perl/pod/perl585delta.pod b/gnu/usr.bin/perl/pod/perl585delta.pod index 6d23f4f6aba..f8e4e1183a2 100644 --- a/gnu/usr.bin/perl/pod/perl585delta.pod +++ b/gnu/usr.bin/perl/pod/perl585delta.pod @@ -1,6 +1,6 @@ =head1 NAME -perldelta - what is new for perl v5.8.5 +perl585delta - what is new for perl v5.8.5 =head1 DESCRIPTION @@ -20,6 +20,8 @@ classes. =head1 Modules and Pragmata +FIXME test 12 in ext/List/Util/t/lln.t at RC1 time + =over 4 =item * @@ -167,7 +169,7 @@ been fixed. The internals of the ithreads implementation were not checking if OS-level thread creation had failed. threads->create() now returns C<undef> in if -thead creation fails instead of crashing perl. +thread creation fails instead of crashing perl. =back diff --git a/gnu/usr.bin/perl/pod/perl586delta.pod b/gnu/usr.bin/perl/pod/perl586delta.pod new file mode 100644 index 00000000000..ab72bea47dc --- /dev/null +++ b/gnu/usr.bin/perl/pod/perl586delta.pod @@ -0,0 +1,170 @@ +=head1 NAME + +perldelta - what is new for perl v5.8.6 + +=head1 DESCRIPTION + +This document describes differences between the 5.8.5 release and +the 5.8.6 release. + +=head1 Incompatible Changes + +There are no changes incompatible with 5.8.5. + +=head1 Core Enhancements + +The perl interpreter is now more tolerant of UTF-16-encoded scripts. + +On Win32, Perl can now use non-IFS compatible LSPs, which allows Perl to +work in conjunction with firewalls such as McAfee Guardian. For full details +see the file F<README.win32>, particularly if you're running Win95. + +=head1 Modules and Pragmata + +=over 4 + +=item * + +With the C<base> pragma, an intermediate class with no fields used to messes +up private fields in the base class. This has been fixed. + +=item * + +Cwd upgraded to version 3.01 (as part of the new PathTools distribution) + +=item * + +Devel::PPPort upgraded to version 3.03 + +=item * + +File::Spec upgraded to version 3.01 (as part of the new PathTools distribution) + +=item * + +Encode upgraded to version 2.08 + +=item * + +ExtUtils::MakeMaker remains at version 6.17, as later stable releases currently +available on CPAN have some issues with core modules on some core platforms. + +=item * + +I18N::LangTags upgraded to version 0.35 + +=item * + +Math::BigInt upgraded to version 1.73 + +=item * + +Math::BigRat upgraded to version 0.13 + +=item * + +MIME::Base64 upgraded to version 3.05 + +=item * + +POSIX::sigprocmask function can now retrieve the current signal mask without +also setting it. + +=item * + +Time::HiRes upgraded to version 1.65 + +=back + +=head1 Utility Changes + +Perl has a new -dt command-line flag, which enables threads support in the +debugger. + +=head1 Performance Enhancements + +C<reverse sort ...> is now optimized to sort in reverse, avoiding the +generation of a temporary intermediate list. + +C<for (reverse @foo)> now iterates in reverse, avoiding the generation of a +temporary reversed list. + +=head1 Selected Bug Fixes + +The regexp engine is now more robust when given invalid utf8 input, as is +sometimes generated by buggy XS modules. + +C<foreach> on threads::shared array used to be able to crash Perl. This bug +has now been fixed. + +A regexp in C<STDOUT>'s destructor used to coredump, because the regexp pad +was already freed. This has been fixed. + +C<goto &> is now more robust - bugs in deep recursion and chained C<goto &> +have been fixed. + +Using C<delete> on an array no longer leaks memory. A C<pop> of an item from a +shared array reference no longer causes a leak. + +C<eval_sv()> failing a taint test could corrupt the stack - this has been +fixed. + +On platforms with 64 bit pointers numeric comparison operators used to +erroneously compare the addresses of references that are overloaded, rather +than using the overloaded values. This has been fixed. + +C<read> into a UTF8-encoded buffer with an offset off the end of the buffer +no longer mis-calculates buffer lengths. + +Although Perl has promised since version 5.8 that C<sort()> would be +stable, the two cases C<sort {$b cmp $a}> and C<<sort {$b <=> $a}>> could +produce non-stable sorts. This is corrected in perl5.8.6. + +Localising C<$^D> no longer generates a diagnostic message about valid -D +flags. + +=head1 New or Changed Diagnostics + +For -t and -T, + Too late for "-T" option +has been changed to the more informative + "-T" is on the #! line, it must also be used on the command line + +=head1 Changed Internals + +From now on all applications embedding perl will behave as if perl +were compiled with -DPERL_USE_SAFE_PUTENV. See "Environment access" in +the F<INSTALL> file for details. + +Most C<C> source files now have comments at the top explaining their purpose, +which should help anyone wishing to get an overview of the implementation. + +=head1 New Tests + +There are significantly more tests for the C<B> suite of modules. + +=head1 Reporting Bugs + +If you find what you think is a bug, you might check the articles +recently posted to the comp.lang.perl.misc newsgroup and the perl +bug database at http://bugs.perl.org. There may also be +information at http://www.perl.org, the Perl Home Page. + +If you believe you have an unreported bug, please run the B<perlbug> +program included with your release. Be sure to trim your bug down +to a tiny but sufficient test case. Your bug report, along with the +output of C<perl -V>, will be sent off to perlbug@perl.org to be +analysed by the Perl porting team. You can browse and search +the Perl 5 bugs at http://bugs.perl.org/ + +=head1 SEE ALSO + +The F<Changes> file for exhaustive details on what changed. + +The F<INSTALL> file for how to build Perl. + +The F<README> file for general stuff. + +The F<Artistic> and F<Copying> files for copyright information. + +=cut diff --git a/gnu/usr.bin/perl/pod/perldebtut.pod b/gnu/usr.bin/perl/pod/perldebtut.pod index 2ead854bd4a..a38349bbe77 100644 --- a/gnu/usr.bin/perl/pod/perldebtut.pod +++ b/gnu/usr.bin/perl/pod/perldebtut.pod @@ -332,7 +332,7 @@ and will merrily dump out nested references, complete objects, partial objects - just about whatever you throw at it: Let's make a quick object and x-plode it, first we'll start the debugger: -it wants some form of input from STDIN, so we give it something non-commital, +it wants some form of input from STDIN, so we give it something non-committal, a zero: > perl -de 0 diff --git a/gnu/usr.bin/perl/pod/perlhack.pod b/gnu/usr.bin/perl/pod/perlhack.pod index 0d7581cc9cc..f0b2ead4d1f 100644 --- a/gnu/usr.bin/perl/pod/perlhack.pod +++ b/gnu/usr.bin/perl/pod/perlhack.pod @@ -38,12 +38,14 @@ releases of Perl are shepherded by a ``pumpking'', a porter responsible for gathering patches, deciding on a patch-by-patch feature-by-feature basis what will and will not go into the release. For instance, Gurusamy Sarathy was the pumpking for the 5.6 release of -Perl, and Jarkko Hietaniemi is the pumpking for the 5.8 release, and -Hugo van der Sanden will be the pumpking for the 5.10 release. +Perl, and Jarkko Hietaniemi was the pumpking for the 5.8 release, and +Hugo van der Sanden and Rafael Garcia-Suarez share the pumpking for +the 5.10 release. In addition, various people are pumpkings for different things. For -instance, Andy Dougherty and Jarkko Hietaniemi share the I<Configure> -pumpkin. +instance, Andy Dougherty and Jarkko Hietaniemi did a grand job as the +I<Configure> pumpkin up till the 5.8 release. For the 5.10 release +H.Merijn Brand took over. Larry sees Perl development along the lines of the US government: there's the Legislature (the porters), the Executive branch (the @@ -1933,6 +1935,14 @@ C<-torture> argument to F<t/harness>. Run all the tests with -Mutf8. Not all tests will succeed. +=item minitest.utf16 test.utf16 + +Runs the tests with UTF-16 encoded scripts, encoded with different +versions of this encoding. + +C<make utest.utf16> runs the test suite with a combination of C<-utf8> and +C<-utf16> arguments to F<t/TEST>. + =item test_harness Run the test suite with the F<t/harness> controlling program, instead of diff --git a/gnu/usr.bin/perl/pod/perlintro.pod b/gnu/usr.bin/perl/pod/perlintro.pod index 7429dfb233e..cb115ecb757 100644 --- a/gnu/usr.bin/perl/pod/perlintro.pod +++ b/gnu/usr.bin/perl/pod/perlintro.pod @@ -560,7 +560,7 @@ The results end up in C<$1>, C<$2> and so on. # a cheap and nasty way to break an email address up into parts - if ($email =~ /([^@])+@(.+)/) { + if ($email =~ /([^@]+)@(.+)/) { print "Username is $1\n"; print "Hostname is $2\n"; } diff --git a/gnu/usr.bin/perl/pod/perlnewmod.pod b/gnu/usr.bin/perl/pod/perlnewmod.pod index 642d005c40f..d8bd4003c6c 100644 --- a/gnu/usr.bin/perl/pod/perlnewmod.pod +++ b/gnu/usr.bin/perl/pod/perlnewmod.pod @@ -73,9 +73,10 @@ want to do in advance. Dig into a bunch of modules to see how they're written. I'd suggest starting with L<Text::Tabs|Text::Tabs>, since it's in the standard -library and is nice and simple, and then looking at something like -L<Time::Zone|Time::Zone>, L<File::Copy|File::Copy> and then some of the -C<Mail::*> modules if you're planning on writing object oriented code. +library and is nice and simple, and then looking at something a little +more complex like L<File::Copy|File::Copy>. For object oriented +code, C<WWW::Mechanize> or the C<Email::*> modules provide some good +examples. These should give you an overall feel for how modules are laid out and written. @@ -84,8 +85,8 @@ written. There are a lot of modules on CPAN, and it's easy to miss one that's similar to what you're planning on contributing. Have a good plough -through the modules list and the F<by-module> directories, and make sure -you're not the one reinventing the wheel! +through the L<http://search.cpan.org> and make sure you're not the one +reinventing the wheel! =item Discuss the need @@ -119,18 +120,29 @@ wanted and not currently available, it's time to start coding. =over 3 -=item Start with F<h2xs> +=item Start with F<module-starter> or F<h2xs> -Originally a utility to convert C header files into XS modules, -L<h2xs|h2xs> has become a useful utility for churning out skeletons for -Perl-only modules as well. If you don't want to use the -L<Autoloader|Autoloader> which splits up big modules into smaller -subroutine-sized chunks, you'll say something like this: +The F<module-starter> utility is distributed as part of the +L<Module::Starter|Module::Starter> CPAN package. It creates a directory +with stubs of all the necessary files to start a new module, according +to recent "best practice" for module development, and is invoked from +the command line, thus: - h2xs -AX -n Net::Acme + module-starter --module=Foo::Bar \ + --author="Your Name" --email=yourname@cpan.org -The C<-A> omits the Autoloader code, C<-X> omits XS elements, and C<-n> -specifies the name of the module. +If you do not wish to install the L<Module::Starter|Module::Starter> +package from CPAN, F<h2xs> is an older tool, originally intended for the +development of XS modules, which comes packaged with the Perl +distribution. + +A typical invocation of L<h2xs|h2xs> for a pure Perl module is: + + h2xs -AX --skip-exporter --use-new-tests -n Foo::Bar + +The C<-A> omits the Autoloader code, C<-X> omits XS elements, +C<--skip-exporter> omits the Exporter code, C<--use-new-tests> sets up a +modern testing environment, and C<-n> specifies the name of the module. =item Use L<strict|strict> and L<warnings|warnings> @@ -164,10 +176,9 @@ your module at fault. =item Use L<Exporter|Exporter> - wisely! -C<h2xs> provides stubs for L<Exporter|Exporter>, which gives you a -standard way of exporting symbols and subroutines from your module into -the caller's namespace. For instance, saying C<use Net::Acme qw(&frob)> -would import the C<frob> subroutine. +L<Exporter|Exporter> gives you a standard way of exporting symbols and +subroutines from your module into the caller's namespace. For instance, +saying C<use Net::Acme qw(&frob)> would import the C<frob> subroutine. The package variable C<@EXPORT> will determine which symbols will get exported when the caller simply says C<use Net::Acme> - you will hardly @@ -180,21 +191,23 @@ export set - look at L<Exporter> for more details. The work isn't over until the paperwork is done, and you're going to need to put in some time writing some documentation for your module. -C<h2xs> will provide a stub for you to fill in; if you're not sure about -the format, look at L<perlpod> for an introduction. Provide a good -synopsis of how your module is used in code, a description, and then -notes on the syntax and function of the individual subroutines or -methods. Use Perl comments for developer notes and POD for end-user -notes. +C<module-starter> or C<h2xs> will provide a stub for you to fill in; if +you're not sure about the format, look at L<perlpod> for an +introduction. Provide a good synopsis of how your module is used in +code, a description, and then notes on the syntax and function of the +individual subroutines or methods. Use Perl comments for developer notes +and POD for end-user notes. =item Write tests You're encouraged to create self-tests for your module to ensure it's working as intended on the myriad platforms Perl supports; if you upload your module to CPAN, a host of testers will build your module and send -you the results of the tests. Again, C<h2xs> provides a test framework -which you can extend - you should do something more than just checking -your module will compile. +you the results of the tests. Again, C<module-starter> and C<h2xs> +provide a test framework which you can extend - you should do something +more than just checking your module will compile. +L<Test::Simple|Test::Simple> and L<Test::More|Test::More> are good +places to start when writing a test suite. =item Write the README @@ -212,15 +225,15 @@ does in detail, and the user-visible changes since the last release. =item Get a CPAN user ID -Every developer publishing modules on CPAN needs a CPAN ID. See the -instructions at C<http://www.cpan.org/modules/04pause.html> (or -equivalent on your nearest mirror) to find out how to do this. +Every developer publishing modules on CPAN needs a CPAN ID. Visit +C<http://pause.perl.org/>, select "Request PAUSE Account", and wait for +your request to be approved by the PAUSE administrators. =item C<perl Makefile.PL; make test; make dist> -Once again, C<h2xs> has done all the work for you. It produces the -standard C<Makefile.PL> you'll have seen when you downloaded and -installs modules, and this produces a Makefile with a C<dist> target. +Once again, C<module-starter> or C<h2xs> has done all the work for you. +They produce the standard C<Makefile.PL> you see when you download and +install modules, and this produces a Makefile with a C<dist> target. Once you've ensured that your module passes its own tests - always a good thing to make sure - you can C<make dist>, and the Makefile will @@ -235,31 +248,9 @@ you can upload your module to CPAN. =item Announce to the modules list Once uploaded, it'll sit unnoticed in your author directory. If you want -it connected to the rest of the CPAN, you'll need to tell the modules -list about it. The best way to do this is to email them a line in the -style of the modules list, like this: - - Net::Acme bdpOP Interface to Acme Frobnicator servers FOOBAR - ^ ^^^^^ ^ ^ - | ||||| Module description Your ID - | ||||| - | ||||\-Public Licence: (p)standard Perl, (g)GPL, (b)BSD, - | |||| (l)LGPL, (a)rtistic, (o)ther - | |||| - | |||\- Interface: (O)OP, (r)eferences, (h)ybrid, (f)unctions - | ||| - | ||\-- Language: (p)ure Perl, C(+)+, (h)ybrid, (C), (o)ther - | || - Module |\--- Support: (d)eveloper, (m)ailing list, (u)senet, (n)one - Name | - \---- Development: (i)dea, (c)onstructions, (a)lpha, (b)eta, - (R)eleased, (M)ature, (S)tandard - -plus a description of the module and why you think it should be -included. If you hear nothing back, that means your module will -probably appear on the modules list at the next update. Don't try -subscribing to C<modules@perl.org>; it's not another mailing list. Just -have patience. +it connected to the rest of the CPAN, you'll need to go to "Register +Namespace" on PAUSE. Once registered, your module will appear in the +by-module and by-category listings on CPAN. =item Announce to clpa @@ -278,9 +269,12 @@ maintaining a software project... Simon Cozens, C<simon@cpan.org> +Updated by Kirrily "Skud" Robert, C<skud@cpan.org> + =head1 SEE ALSO L<perlmod>, L<perlmodlib>, L<perlmodinstall>, L<h2xs>, L<strict>, -L<Carp>, L<Exporter>, L<perlpod>, L<Test>, L<ExtUtils::MakeMaker>, +L<Carp>, L<Exporter>, L<perlpod>, L<Test::Simple>, L<Test::More> +L<ExtUtils::MakeMaker>, L<Module::Build>, L<Module::Starter> http://www.cpan.org/ , Ken Williams' tutorial on building your own module at http://mathforum.org/~ken/perl_modules.html diff --git a/gnu/usr.bin/perl/pod/perlport.pod b/gnu/usr.bin/perl/pod/perlport.pod index 5e7096e13cc..5f32fdd7adf 100644 --- a/gnu/usr.bin/perl/pod/perlport.pod +++ b/gnu/usr.bin/perl/pod/perlport.pod @@ -1102,7 +1102,7 @@ native formats. What C<\n> represents depends on the type of file opened. It usually represents C<\012> but it could also be C<\015>, C<\012>, C<\015\012>, -C<\000>, C<\040>, or nothing depending on the file organiztion and +C<\000>, C<\040>, or nothing depending on the file organization and record format. The VMS::Stdio module provides access to the special fopen() requirements of files with unusual attributes on VMS. diff --git a/gnu/usr.bin/perl/pod/perlretut.pod b/gnu/usr.bin/perl/pod/perlretut.pod index b738c3b2cbe..c0a78a43e49 100644 --- a/gnu/usr.bin/perl/pod/perlretut.pod +++ b/gnu/usr.bin/perl/pod/perlretut.pod @@ -1754,7 +1754,7 @@ letter, the braces can be dropped. For instance, C<\pM> is the character class of Unicode 'marks', for example accent marks. For the full list see L<perlunicode>. -The Unicode has also been separated into various sets of charaters +The Unicode has also been separated into various sets of characters which you can test with C<\p{In...}> (in) and C<\P{In...}> (not in), for example C<\p{Latin}>, C<\p{Greek}>, or C<\P{Katakana}>. For the full list see L<perlunicode>. @@ -2271,7 +2271,7 @@ may surprise you: $pat = qr/(?{ $foo = 1 })/; # precompile code regexp /foo${pat}bar/; # compiles ok -If a regexp has (1) code expressions and interpolating variables,or +If a regexp has (1) code expressions and interpolating variables, or (2) a variable that interpolates a code expression, perl treats the regexp as an error. If the code expression is precompiled into a variable, however, interpolating is ok. The question is, why is this diff --git a/gnu/usr.bin/perl/pod/perltodo.pod b/gnu/usr.bin/perl/pod/perltodo.pod index 5dbe882eb15..219e92ba028 100644 --- a/gnu/usr.bin/perl/pod/perltodo.pod +++ b/gnu/usr.bin/perl/pod/perltodo.pod @@ -225,7 +225,7 @@ Currently perl from p4/rsync ships with a patchlevel.h file that usually defines one local patch, of the form "MAINT12345" or "RC1". The output of perl -v doesn't report that a perl isn't an official release, and this information can get lost in bugs reports. Because of this, the minor version -isn't bumped up util RC time, to minimise the possibility of versions of perl +isn't bumped up until RC time, to minimise the possibility of versions of perl escaping that believe themselves to be newer than they actually are. It would be useful to find an elegant way to have the "this is an interim @@ -275,7 +275,7 @@ for example POSIX passes Exporter some very memory hungry data structures. =head2 Optimize away @_ -The old perltodo notes "Look at the "reification" code in C<av.c>" +The old perltodo notes "Look at the "reification" code in C<av.c>". =head2 switch ops @@ -297,3 +297,9 @@ be useful to have a reasonable general benchmarking suite that roughly represented what current perl programs do, and measurably reported whether tweaks to the core improve, degrade or don't really affect performance, to guide people attempting to optimise the guts of perl. + +=head2 readpipe(LIST) + +system() accepts a LIST syntax (and a PROGRAM LIST syntax) to avoid +running a shell. readpipe() (the function behind qx//) could be similarly +extended. diff --git a/gnu/usr.bin/perl/pod/perltooc.pod b/gnu/usr.bin/perl/pod/perltooc.pod index 78b61357171..6737105011e 100644 --- a/gnu/usr.bin/perl/pod/perltooc.pod +++ b/gnu/usr.bin/perl/pod/perltooc.pod @@ -922,7 +922,7 @@ all privacy in Perl, and it is a powerful form of privacy indeed. It is widely perceived, and indeed has often been written, that Perl provides no data hiding, that it affords the class designer no privacy -nor isolation, merely a rag-tag assortment of weak and unenforcible +nor isolation, merely a rag-tag assortment of weak and unenforceable social conventions instead. This perception is demonstrably false and easily disproven. In the next section, we show how to implement forms of privacy that are far stronger than those provided in nearly any @@ -1106,7 +1106,7 @@ itself access its own class attributes without the mediating intervention of properly designed accessor methods is probably not a good idea after all. Restricting access to class attributes from the class itself is usually -not enforcible even in strongly object-oriented languages. But in Perl, +not enforceable even in strongly object-oriented languages. But in Perl, you can. Here's one way: @@ -1298,7 +1298,7 @@ You can't use file-scoped lexicals in conjunction with the SelfLoader or the AutoLoader, because they alter the lexical scope in which the module's methods wind up getting compiled. -The usual mealy-mouthed package-mungeing doubtless applies to setting +The usual mealy-mouthed package-munging doubtless applies to setting up names of object attributes. For example, C<< $self->{ObData1} >> should probably be C<< $self->{ __PACKAGE__ . "_ObData1" } >>, but that would just confuse the examples. diff --git a/gnu/usr.bin/perl/pp_pack.c b/gnu/usr.bin/perl/pp_pack.c index 7dbc0b87fc7..945f6b24ab5 100644 --- a/gnu/usr.bin/perl/pp_pack.c +++ b/gnu/usr.bin/perl/pp_pack.c @@ -16,6 +16,17 @@ * some salt. */ +/* This file contains pp ("push/pop") functions that + * execute the opcodes that make up a perl program. A typical pp function + * expects to find its arguments on the stack, and usually pushes its + * results onto the stack, hence the 'pp' terminology. Each OP structure + * contains a pointer to the relevant pp_foo() function. + * + * This particular file just contains pp_pack() and pp_unpack(). See the + * other pp*.c files for the rest of the pp_ functions. + */ + + #include "EXTERN.h" #define PERL_IN_PP_PACK_C #include "perl.h" diff --git a/gnu/usr.bin/perl/pp_sort.c b/gnu/usr.bin/perl/pp_sort.c index e45e4d30ccd..028ddf5981e 100644 --- a/gnu/usr.bin/perl/pp_sort.c +++ b/gnu/usr.bin/perl/pp_sort.c @@ -13,6 +13,17 @@ * rear!' the slave-driver shouted. 'Three files up. And stay there... */ +/* This file contains pp ("push/pop") functions that + * execute the opcodes that make up a perl program. A typical pp function + * expects to find its arguments on the stack, and usually pushes its + * results onto the stack, hence the 'pp' terminology. Each OP structure + * contains a pointer to the relevant pp_foo() function. + * + * This particular file just contains pp_sort(), which is complex + * enough to merit its own file! See the other pp*.c files for the rest of + * the pp_ functions. + */ + #include "EXTERN.h" #define PERL_IN_PP_SORT_C #include "perl.h" @@ -335,8 +346,15 @@ typedef struct { IV runs; /* how many runs must be combined into 1 */ } off_runs; /* pseudo-stack element */ + +static I32 +cmp_desc(pTHX_ gptr a, gptr b) +{ + return -PL_sort_RealCmp(aTHX_ a, b); +} + STATIC void -S_mergesortsv(pTHX_ gptr *base, size_t nmemb, SVCOMPARE_t cmp) +S_mergesortsv(pTHX_ gptr *base, size_t nmemb, SVCOMPARE_t cmp, U32 flags) { IV i, run, runs, offset; I32 sense, level; @@ -347,8 +365,16 @@ S_mergesortsv(pTHX_ gptr *base, size_t nmemb, SVCOMPARE_t cmp) gptr small[SMALLSORT]; gptr *which[3]; off_runs stack[60], *stackp; + SVCOMPARE_t savecmp; if (nmemb <= 1) return; /* sorted trivially */ + + if (flags) { + savecmp = PL_sort_RealCmp; /* Save current comparison routine, if any */ + PL_sort_RealCmp = cmp; /* Put comparison routine where cmp_desc can find it */ + cmp = cmp_desc; + } + if (nmemb <= SMALLSORT) aux = small; /* use stack for aux array */ else { New(799,aux,nmemb,gptr); } /* allocate auxilliary array */ level = 0; @@ -531,6 +557,9 @@ S_mergesortsv(pTHX_ gptr *base, size_t nmemb, SVCOMPARE_t cmp) } done: if (aux != small) Safefree(aux); /* free iff allocated */ + if (flags) { + PL_sort_RealCmp = savecmp; /* Restore current comparison routine, if any */ + } return; } @@ -1300,8 +1329,23 @@ cmpindir(pTHX_ gptr a, gptr b) return sense; } +static I32 +cmpindir_desc(pTHX_ gptr a, gptr b) +{ + I32 sense; + gptr *ap = (gptr *)a; + gptr *bp = (gptr *)b; + + /* Reverse the default */ + if ((sense = PL_sort_RealCmp(aTHX_ *ap, *bp))) + return -sense; + /* But don't reverse the stability test. */ + return (ap > bp) ? 1 : ((ap < bp) ? -1 : 0); + +} + STATIC void -S_qsortsv(pTHX_ gptr *list1, size_t nmemb, SVCOMPARE_t cmp) +S_qsortsv(pTHX_ gptr *list1, size_t nmemb, SVCOMPARE_t cmp, U32 flags) { SV *hintsv; @@ -1323,7 +1367,8 @@ S_qsortsv(pTHX_ gptr *list1, size_t nmemb, SVCOMPARE_t cmp) PL_sort_RealCmp = cmp; /* Put comparison routine where cmpindir can find it */ /* sort, with indirection */ - S_qsortsvu(aTHX_ (gptr *)indir, nmemb, cmpindir); + S_qsortsvu(aTHX_ (gptr *)indir, nmemb, + flags ? cmpindir_desc : cmpindir); pp = indir; q = list1; @@ -1366,6 +1411,13 @@ S_qsortsv(pTHX_ gptr *list1, size_t nmemb, SVCOMPARE_t cmp) if (indir != small) { Safefree(indir); } /* restore prevailing comparison routine */ PL_sort_RealCmp = savecmp; + } else if (flags) { + SVCOMPARE_t savecmp = PL_sort_RealCmp; /* Save current comparison routine, if any */ + PL_sort_RealCmp = cmp; /* Put comparison routine where cmp_desc can find it */ + cmp = cmp_desc; + S_qsortsvu(aTHX_ list1, nmemb, cmp); + /* restore prevailing comparison routine */ + PL_sort_RealCmp = savecmp; } else { S_qsortsvu(aTHX_ list1, nmemb, cmp); } @@ -1388,8 +1440,34 @@ See lib/sort.pm for details about controlling the sorting algorithm. void Perl_sortsv(pTHX_ SV **array, size_t nmemb, SVCOMPARE_t cmp) { - void (*sortsvp)(pTHX_ SV **array, size_t nmemb, SVCOMPARE_t cmp) = - S_mergesortsv; + void (*sortsvp)(pTHX_ SV **array, size_t nmemb, SVCOMPARE_t cmp, U32 flags) + = S_mergesortsv; + SV *hintsv; + I32 hints; + + /* Sun's Compiler (cc: WorkShop Compilers 4.2 30 Oct 1996 C 4.2) used + to miscompile this function under optimization -O. If you get test + errors related to picking the correct sort() function, try recompiling + this file without optimiziation. -- A.D. 4/2002. + */ + hints = SORTHINTS(hintsv); + if (hints & HINT_SORT_QUICKSORT) { + sortsvp = S_qsortsv; + } + else { + /* The default as of 5.8.0 is mergesort */ + sortsvp = S_mergesortsv; + } + + sortsvp(aTHX_ array, nmemb, cmp, 0); +} + + +void +S_sortsv_desc(pTHX_ SV **array, size_t nmemb, SVCOMPARE_t cmp) +{ + void (*sortsvp)(pTHX_ SV **array, size_t nmemb, SVCOMPARE_t cmp, U32 flags) + = S_mergesortsv; SV *hintsv; I32 hints; @@ -1407,7 +1485,7 @@ Perl_sortsv(pTHX_ SV **array, size_t nmemb, SVCOMPARE_t cmp) sortsvp = S_mergesortsv; } - sortsvp(aTHX_ array, nmemb, cmp); + sortsvp(aTHX_ array, nmemb, cmp, 1); } PP(pp_sort) @@ -1425,6 +1503,10 @@ PP(pp_sort) bool hasargs = FALSE; I32 is_xsub = 0; I32 sorting_av = 0; + U8 private = PL_op->op_private; + U8 flags = PL_op->op_flags; + void (*sortsvp)(pTHX_ SV **array, size_t nmemb, SVCOMPARE_t cmp) + = Perl_sortsv; if (gimme != G_ARRAY) { SP = MARK; @@ -1433,8 +1515,8 @@ PP(pp_sort) ENTER; SAVEVPTR(PL_sortcop); - if (PL_op->op_flags & OPf_STACKED) { - if (PL_op->op_flags & OPf_SPECIAL) { + if (flags & OPf_STACKED) { + if (flags & OPf_SPECIAL) { OP *kid = cLISTOP->op_first->op_sibling; /* pass pushmark */ kid = kUNOP->op_first; /* pass rv2gv */ kid = kUNOP->op_first; /* pass leave */ @@ -1484,7 +1566,7 @@ PP(pp_sort) /* optimiser converts "@a = sort @a" to "sort \@a"; * in case of tied @a, pessimise: push (@a) onto stack, then assign * result back to @a at the end of this function */ - if (PL_op->op_private & OPpSORT_INPLACE) { + if (private & OPpSORT_INPLACE) { assert( MARK+1 == SP && *SP && SvTYPE(*SP) == SVt_PVAV); (void)POPMARK; /* remove mark associated with ex-OP_AASSIGN */ av = (AV*)(*SP); @@ -1507,6 +1589,10 @@ PP(pp_sort) max = SP - MARK; } + if (private & OPpSORT_DESCEND) { + sortsvp = S_sortsv_desc; + } + /* shuffle stack down, removing optional initial cv (p1!=p2), plus any * nulls; also stringify any args */ for (i=max; i > 0 ; i--) { @@ -1528,6 +1614,7 @@ PP(pp_sort) AvFILLp(av) = max-1; if (max > 1) { + SV **start; if (PL_sortcop) { PERL_CONTEXT *cx; SV** newsp; @@ -1555,7 +1642,7 @@ PP(pp_sort) } PUSHBLOCK(cx, CXt_NULL, PL_stack_base); - if (!(PL_op->op_flags & OPf_SPECIAL)) { + if (!(flags & OPf_SPECIAL)) { cx->cx_type = CXt_SUB; cx->blk_gimme = G_SCALAR; PUSHSUB(cx); @@ -1573,8 +1660,10 @@ PP(pp_sort) CX_CURPAD_SAVE(cx->blk_sub); cx->blk_sub.argarray = av; } - sortsv(p1-max, max, - is_xsub ? sortcv_xsub : hasargs ? sortcv_stacked : sortcv); + + start = p1 - max; + sortsvp(aTHX_ start, max, + is_xsub ? sortcv_xsub : hasargs ? sortcv_stacked : sortcv); POPBLOCK(cx,PL_curpm); PL_stack_sp = newsp; @@ -1583,9 +1672,10 @@ PP(pp_sort) } else { MEXTEND(SP, 20); /* Can't afford stack realloc on signal. */ - sortsv(sorting_av ? AvARRAY(av) : ORIGMARK+1, max, - (PL_op->op_private & OPpSORT_NUMERIC) - ? ( (PL_op->op_private & OPpSORT_INTEGER) + start = sorting_av ? AvARRAY(av) : ORIGMARK+1; + sortsvp(aTHX_ start, max, + (private & OPpSORT_NUMERIC) + ? ( (private & OPpSORT_INTEGER) ? ( overloading ? amagic_i_ncmp : sv_i_ncmp) : ( overloading ? amagic_ncmp : sv_ncmp)) : ( IN_LOCALE_RUNTIME @@ -1593,14 +1683,13 @@ PP(pp_sort) ? amagic_cmp_locale : sv_cmp_locale_static) : ( overloading ? amagic_cmp : sv_cmp_static))); - if (PL_op->op_private & OPpSORT_REVERSE) { - SV **p = sorting_av ? AvARRAY(av) : ORIGMARK+1; - SV **q = p+max-1; - while (p < q) { - SV *tmp = *p; - *p++ = *q; - *q-- = tmp; - } + } + if (private & OPpSORT_REVERSE) { + SV **q = start+max-1; + while (start < q) { + SV *tmp = *start; + *start++ = *q; + *q-- = tmp; } } } diff --git a/gnu/usr.bin/perl/reentr.c b/gnu/usr.bin/perl/reentr.c index 881bd87b7a3..7770e0b81f1 100644 --- a/gnu/usr.bin/perl/reentr.c +++ b/gnu/usr.bin/perl/reentr.c @@ -7,11 +7,17 @@ * License or the Artistic License, as specified in the README file. * * !!!!!!! DO NOT EDIT THIS FILE !!!!!!! - * This file is built by reentrl.pl from data in reentr.pl. + * This file is built by reentr.pl from data in reentr.pl. * * "Saruman," I said, standing away from him, "only one hand at a time can * wield the One, and you know that well, so do not trouble to say we!" * + * This file contains a collection of automatically created wrappers + * (created by running reentr.pl) for reentrant (thread-safe) versions of + * various library calls, such as getpwent_r. The wrapping is done so + * that other files like pp_sys.c calling those library functions need not + * care about the differences between various platforms' idiosyncrasies + * regarding these reentrant interfaces. */ #include "EXTERN.h" diff --git a/gnu/usr.bin/perl/reentr.h b/gnu/usr.bin/perl/reentr.h index 0b67f92a36b..c58a9ef323b 100644 --- a/gnu/usr.bin/perl/reentr.h +++ b/gnu/usr.bin/perl/reentr.h @@ -7,7 +7,7 @@ * License or the Artistic License, as specified in the README file. * * !!!!!!! DO NOT EDIT THIS FILE !!!!!!! - * This file is built by reentrl.pl from data in reentr.pl. + * This file is built by reentr.pl from data in reentr.pl. */ #ifndef REENTR_H diff --git a/gnu/usr.bin/perl/reentr.pl b/gnu/usr.bin/perl/reentr.pl index 0026dda4e7d..fa8b98e9e5f 100644 --- a/gnu/usr.bin/perl/reentr.pl +++ b/gnu/usr.bin/perl/reentr.pl @@ -47,7 +47,7 @@ print <<EOF; * License or the Artistic License, as specified in the README file. * * !!!!!!! DO NOT EDIT THIS FILE !!!!!!! - * This file is built by reentrl.pl from data in reentr.pl. + * This file is built by reentr.pl from data in reentr.pl. */ #ifndef REENTR_H @@ -839,11 +839,17 @@ print <<EOF; * License or the Artistic License, as specified in the README file. * * !!!!!!! DO NOT EDIT THIS FILE !!!!!!! - * This file is built by reentrl.pl from data in reentr.pl. + * This file is built by reentr.pl from data in reentr.pl. * * "Saruman," I said, standing away from him, "only one hand at a time can * wield the One, and you know that well, so do not trouble to say we!" * + * This file contains a collection of automatically created wrappers + * (created by running reentr.pl) for reentrant (thread-safe) versions of + * various library calls, such as getpwent_r. The wrapping is done so + * that other files like pp_sys.c calling those library functions need not + * care about the differences between various platforms' idiosyncrasies + * regarding these reentrant interfaces. */ #include "EXTERN.h" diff --git a/gnu/usr.bin/perl/t/comp/opsubs.t b/gnu/usr.bin/perl/t/comp/opsubs.t new file mode 100755 index 00000000000..75c6012fc3a --- /dev/null +++ b/gnu/usr.bin/perl/t/comp/opsubs.t @@ -0,0 +1,120 @@ +#!./perl -T + +use warnings; +use strict; +$|++; + +=pod + +Even if you have a C<sub q{}>, calling C<q()> will be parsed as the +C<q()> operator. Calling C<&q()> or C<main::q()> gets you the function. +This test verifies this behavior for nine different operators. + +=cut + +use Test::More tests => 36; + +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 + no warnings; + 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')"; +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 + + <kane-xs> bug or feature? + <purl> You decide!!!! + <kane-xs> [kane@coke ~]$ perlc -le'sub y{1};y(1)' + <kane-xs> Transliteration replacement not terminated at -e line 1. + <Nicholas> bug I think + <kane-xs> i'll perlbug + <rgs> feature + <kane-xs> smiles at rgs + <kane-xs> done + <rgs> will be closed at not a bug, + <rgs> like the previous reports of this one + <Nicholas> feature being first class and second class keywords? + <rgs> you have similar ones with q, qq, qr, qx, tr, s and m + <rgs> one could say 1st class keywords, yes + <rgs> and I forgot qw + <kane-xs> hmm silly... + <Nicholas> it's acutally operators, isn't it? + <Nicholas> as in you can't call a subroutine with the same name as an + operator unless you have the & ? + <kane-xs> or fqpn (fully qualified package name) + <kane-xs> main::y() works just fine + <kane-xs> as does &y; but not y() + <Andy> If that's a feature, then let's write a test that it continues + to work like that. + +=cut diff --git a/gnu/usr.bin/perl/t/io/layers.t b/gnu/usr.bin/perl/t/io/layers.t index d0e37a3c8db..e2c63a957c3 100644 --- a/gnu/usr.bin/perl/t/io/layers.t +++ b/gnu/usr.bin/perl/t/io/layers.t @@ -34,6 +34,8 @@ my $FASTSTDIO = $Config{d_faststdio} && $Config{usefaststdio} ? 1 : 0; my $NTEST = 43 - (($DOSISH || !$FASTSTDIO) ? 7 : 0) - ($DOSISH ? 5 : 0); +sub PerlIO::F_UTF8 () { 0x00008000 } # from perliol.h + plan tests => $NTEST; print <<__EOH__; diff --git a/gnu/usr.bin/perl/t/op/splice.t b/gnu/usr.bin/perl/t/op/splice.t index 6d9b71f0647..1ffcb498a7f 100644 --- a/gnu/usr.bin/perl/t/op/splice.t +++ b/gnu/usr.bin/perl/t/op/splice.t @@ -1,6 +1,6 @@ #!./perl -print "1..12\n"; +print "1..18\n"; @a = (1..10); @@ -52,3 +52,33 @@ $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"; diff --git a/gnu/usr.bin/perl/t/run/fresh_perl.t b/gnu/usr.bin/perl/t/run/fresh_perl.t index 0f5073dcaa9..6f99451c519 100644 --- a/gnu/usr.bin/perl/t/run/fresh_perl.t +++ b/gnu/usr.bin/perl/t/run/fresh_perl.t @@ -855,3 +855,20 @@ print glob(q(./"TEST")); EXPECT ./"TEST" ./"TEST" +######## "Segfault using HTML::Entities", Richard Jolly <richardjolly@mac.com>, <A3C7D27E-C9F4-11D8-B294-003065AE00B6@mac.com> in perl-unicode@perl.org +-lw +# SKIP: " $Config::Config{'extensions'} " !~ m[ Encode ] # Perl configured without Encode module +BEGIN { + eval 'require Encode'; + if ($@) { exit 0 } # running minitest? +} +# Test case cut down by jhi +$SIG{__WARN__} = sub { $@ = shift }; +use Encode; +my $t = "\xE9"; +Encode::_utf8_on($t); +$t =~ s/([^a])//ge; +$@ =~ s/ at .*/ at/; +print $@ +EXPECT +Malformed UTF-8 character (unexpected end of string) at diff --git a/gnu/usr.bin/perl/t/test.pl b/gnu/usr.bin/perl/t/test.pl index 94071292715..a35eb83693b 100644 --- a/gnu/usr.bin/perl/t/test.pl +++ b/gnu/usr.bin/perl/t/test.pl @@ -5,6 +5,7 @@ $Level = 1; my $test = 1; my $planned; +my $noplan; $TODO = 0; $NO_ENDING = 0; @@ -13,18 +14,27 @@ sub plan { my $n; if (@_ == 1) { $n = shift; + if ($n eq 'no_plan') { + undef $n; + $noplan = 1; + } } else { my %plan = @_; $n = $plan{tests}; } - print STDOUT "1..$n\n"; + print STDOUT "1..$n\n" unless $noplan; $planned = $n; } END { my $ran = $test - 1; - if (!$NO_ENDING && defined $planned && $planned != $ran) { - print STDERR "# Looks like you planned $planned tests but ran $ran.\n"; + 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"; + } } } @@ -285,6 +295,9 @@ 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; diff --git a/gnu/usr.bin/perl/t/uni/class.t b/gnu/usr.bin/perl/t/uni/class.t index 130b720eacc..66f3962c1bf 100644 --- a/gnu/usr.bin/perl/t/uni/class.t +++ b/gnu/usr.bin/perl/t/uni/class.t @@ -112,10 +112,17 @@ for my $p ('gc', 'sc') { } # test extra properties (ASCII_Hex_Digit, Bidi_Control, etc.) +SKIP: { - # Aargh. Nasty case insensitive filesystems mean that Cf.pl will cause a -e - # test for cf.pl to return true. So need to read the filenames explicitly - # to get a case sensitive test + skip "Can't reliably derive class names from file names", 544 if $^O eq 'VMS'; + + # On case tolerant filesystems, Cf.pl will cause a -e test for cf.pl to + # return true. Try to work around this by reading the filenames explicitly + # to get a case sensitive test. N.B. This will fail if filename case is + # not preserved because you might go looking for a class name of CF or cf + # when you really want Cf. Storing case sensitive data in filenames is + # simply not portable. + my %files; my $dirname = File::Spec->catdir($updir => lib => unicore => lib => gc_sc); diff --git a/gnu/usr.bin/perl/utf8.c b/gnu/usr.bin/perl/utf8.c index 6155fabe3cd..7571e293dda 100644 --- a/gnu/usr.bin/perl/utf8.c +++ b/gnu/usr.bin/perl/utf8.c @@ -29,6 +29,12 @@ static char unees[] = "Malformed UTF-8 character (unexpected end of string)"; /* =head1 Unicode Support +This file contains various utility functions for manipulating UTF8-encoded +strings. For the uninitiated, this is a method of representing arbitrary +Unicode characters as a variable number of bytes, in such a way that +characters in the ASCII range are unmodified, and a zero byte never appears +within non-zero characters. + =for apidoc A|U8 *|uvuni_to_utf8_flags|U8 *d|UV uv|UV flags Adds the UTF-8 representation of the Unicode codepoint C<uv> to the end @@ -862,8 +868,14 @@ Perl_utf16_to_utf8(pTHX_ U8* p, U8* d, I32 bytelen, I32 *newlen) U8* pend; U8* dstart = d; + if (bytelen == 1 && p[0] == 0) { /* Be understanding. */ + d[0] = 0; + *newlen = 1; + return d; + } + if (bytelen & 1) - Perl_croak(aTHX_ "panic: utf16_to_utf8: odd bytelen"); + Perl_croak(aTHX_ "panic: utf16_to_utf8: odd bytelen %d", bytelen); pend = p + bytelen; @@ -1916,7 +1928,7 @@ If the pe1 and pe2 are non-NULL, the scanning pointers will be copied in there (they will point at the beginning of the I<next> character). If the pointers behind pe1 or pe2 are non-NULL, they are the end pointers beyond which scanning will not continue under any -circustances. If the byte lengths l1 and l2 are non-zero, s1+l1 and +circumstances. If the byte lengths l1 and l2 are non-zero, s1+l1 and s2+l2 will be used as goal end pointers that will also stop the scan, and which qualify towards defining a successful match: all the scans that define an explicit length must reach their goal pointers for diff --git a/gnu/usr.bin/perl/vms/descrip_mms.template b/gnu/usr.bin/perl/vms/descrip_mms.template index 42c9435e263..3ad8f91e508 100644 --- a/gnu/usr.bin/perl/vms/descrip_mms.template +++ b/gnu/usr.bin/perl/vms/descrip_mms.template @@ -325,17 +325,11 @@ CRTLOPTS =,$(CRTL)/Options $(CC) $(CFLAGS) $(MMS$SOURCE_NAME).c .endif -unidatafiles1 = [.lib.unicore]Canonical.pl [.lib.unicore]Exact.pl -unidatafiles2 = [.lib.unicore]Properties [.lib.unicore]Decomposition.pl -unidatafiles3 = [.lib.unicore]CombiningClass.pl [.lib.unicore]Name.pl -unidatafiles4 = [.lib.unicore]PVA.pl -unidatafiles = $(unidatafiles1) $(unidatafiles2) $(unidatafiles3) $(unidatafiles4) - # Directories of Unicode data files generated by mktables unidatadirs = lib/unicore/To lib/unicore/lib # Modules which must be installed before we can build extensions -LIBPREREQ = $(ARCHDIR)Config.pm [.lib.VMS]Filespec.pm [.lib]DynaLoader.pm [.lib]XSLoader.pm [.lib]lib.pm [.lib.ExtUtils]XSSymSet.pm $(ARCHDIR)vmspipe.com [.lib]re.pm $(unidatafiles) +LIBPREREQ = $(ARCHDIR)Config.pm [.lib.VMS]Filespec.pm [.lib]DynaLoader.pm [.lib]XSLoader.pm [.lib]lib.pm [.lib.ExtUtils]XSSymSet.pm $(ARCHDIR)vmspipe.com [.lib]re.pm unidatafiles.ts utils1 = [.lib.pod]perldoc.com [.lib.ExtUtils]Miniperl.pm [.utils]c2ph.com [.utils]h2ph.com utils2 = [.utils]h2xs.com [.utils]libnetcfg.com [.lib]perlbug.com [.lib]perlcc.com [.utils]dprofpp.com @@ -372,28 +366,29 @@ extra.pods : miniperl pod0 = [.lib.pod]perl.pod [.lib.pod]perl5004delta.pod [.lib.pod]perl5005delta.pod [.lib.pod]perl561delta.pod [.lib.pod]perl56delta.pod pod1 = [.lib.pod]perl570delta.pod [.lib.pod]perl571delta.pod [.lib.pod]perl572delta.pod [.lib.pod]perl573delta.pod [.lib.pod]perl581delta.pod -pod2 = [.lib.pod]perl582delta.pod [.lib.pod]perl583delta.pod [.lib.pod]perl584delta.pod [.lib.pod]perl585delta.pod [.lib.pod]perl58delta.pod -pod3 = [.lib.pod]perlaix.pod [.lib.pod]perlamiga.pod [.lib.pod]perlapi.pod [.lib.pod]perlapio.pod [.lib.pod]perlapollo.pod [.lib.pod]perlartistic.pod -pod4 = [.lib.pod]perlbeos.pod [.lib.pod]perlbook.pod [.lib.pod]perlboot.pod [.lib.pod]perlbot.pod [.lib.pod]perlbs2000.pod [.lib.pod]perlcall.pod -pod5 = [.lib.pod]perlce.pod [.lib.pod]perlcheat.pod [.lib.pod]perlclib.pod [.lib.pod]perlcn.pod [.lib.pod]perlcompile.pod [.lib.pod]perlcygwin.pod -pod6 = [.lib.pod]perldata.pod [.lib.pod]perldbmfilter.pod [.lib.pod]perldebguts.pod [.lib.pod]perldebtut.pod [.lib.pod]perldebug.pod [.lib.pod]perldelta.pod -pod7 = [.lib.pod]perldgux.pod [.lib.pod]perldiag.pod [.lib.pod]perldoc.pod [.lib.pod]perldos.pod [.lib.pod]perldsc.pod [.lib.pod]perlebcdic.pod -pod8 = [.lib.pod]perlembed.pod [.lib.pod]perlepoc.pod [.lib.pod]perlfaq.pod [.lib.pod]perlfaq1.pod [.lib.pod]perlfaq2.pod [.lib.pod]perlfaq3.pod -pod9 = [.lib.pod]perlfaq4.pod [.lib.pod]perlfaq5.pod [.lib.pod]perlfaq6.pod [.lib.pod]perlfaq7.pod [.lib.pod]perlfaq8.pod [.lib.pod]perlfaq9.pod -pod10 = [.lib.pod]perlfilter.pod [.lib.pod]perlfork.pod [.lib.pod]perlform.pod [.lib.pod]perlfreebsd.pod [.lib.pod]perlfunc.pod [.lib.pod]perlgpl.pod -pod11 = [.lib.pod]perlguts.pod [.lib.pod]perlhack.pod [.lib.pod]perlhist.pod [.lib.pod]perlhpux.pod [.lib.pod]perlhurd.pod [.lib.pod]perlintern.pod -pod12 = [.lib.pod]perlintro.pod [.lib.pod]perliol.pod [.lib.pod]perlipc.pod [.lib.pod]perlirix.pod [.lib.pod]perljp.pod [.lib.pod]perlko.pod -pod13 = [.lib.pod]perllexwarn.pod [.lib.pod]perllocale.pod [.lib.pod]perllol.pod [.lib.pod]perlmachten.pod [.lib.pod]perlmacos.pod [.lib.pod]perlmacosx.pod -pod14 = [.lib.pod]perlmint.pod [.lib.pod]perlmod.pod [.lib.pod]perlmodinstall.pod [.lib.pod]perlmodlib.pod [.lib.pod]perlmodstyle.pod [.lib.pod]perlmpeix.pod -pod15 = [.lib.pod]perlnetware.pod [.lib.pod]perlnewmod.pod [.lib.pod]perlnumber.pod [.lib.pod]perlobj.pod [.lib.pod]perlop.pod [.lib.pod]perlopentut.pod -pod16 = [.lib.pod]perlos2.pod [.lib.pod]perlos390.pod [.lib.pod]perlos400.pod [.lib.pod]perlothrtut.pod [.lib.pod]perlpacktut.pod [.lib.pod]perlplan9.pod -pod17 = [.lib.pod]perlpod.pod [.lib.pod]perlpodspec.pod [.lib.pod]perlport.pod [.lib.pod]perlqnx.pod [.lib.pod]perlre.pod [.lib.pod]perlref.pod -pod18 = [.lib.pod]perlreftut.pod [.lib.pod]perlrequick.pod [.lib.pod]perlreref.pod [.lib.pod]perlretut.pod [.lib.pod]perlrun.pod [.lib.pod]perlsec.pod -pod19 = [.lib.pod]perlsolaris.pod [.lib.pod]perlstyle.pod [.lib.pod]perlsub.pod [.lib.pod]perlsyn.pod [.lib.pod]perlthrtut.pod [.lib.pod]perltie.pod -pod20 = [.lib.pod]perltoc.pod [.lib.pod]perltodo.pod [.lib.pod]perltooc.pod [.lib.pod]perltoot.pod [.lib.pod]perltrap.pod [.lib.pod]perltru64.pod -pod21 = [.lib.pod]perltw.pod [.lib.pod]perlunicode.pod [.lib.pod]perluniintro.pod [.lib.pod]perlutil.pod [.lib.pod]perluts.pod [.lib.pod]perlvar.pod -pod22 = [.lib.pod]perlvmesa.pod [.lib.pod]perlvms.pod [.lib.pod]perlvos.pod [.lib.pod]perlwin32.pod [.lib.pod]perlxs.pod [.lib.pod]perlxstut.pod -pod = $(pod0) $(pod1) $(pod2) $(pod3) $(pod4) $(pod5) $(pod6) $(pod7) $(pod8) $(pod9) $(pod10) $(pod11) $(pod12) $(pod13) $(pod14) $(pod15) $(pod16) $(pod17) $(pod18) $(pod19) $(pod20) $(pod21) $(pod22) +pod2 = [.lib.pod]perl582delta.pod [.lib.pod]perl583delta.pod [.lib.pod]perl584delta.pod [.lib.pod]perl585delta.pod [.lib.pod]perl586delta.pod +pod3 = [.lib.pod]perl58delta.pod [.lib.pod]perlaix.pod [.lib.pod]perlamiga.pod [.lib.pod]perlapi.pod [.lib.pod]perlapio.pod [.lib.pod]perlapollo.pod +pod4 = [.lib.pod]perlartistic.pod [.lib.pod]perlbeos.pod [.lib.pod]perlbook.pod [.lib.pod]perlboot.pod [.lib.pod]perlbot.pod [.lib.pod]perlbs2000.pod +pod5 = [.lib.pod]perlcall.pod [.lib.pod]perlce.pod [.lib.pod]perlcheat.pod [.lib.pod]perlclib.pod [.lib.pod]perlcn.pod [.lib.pod]perlcompile.pod +pod6 = [.lib.pod]perlcygwin.pod [.lib.pod]perldata.pod [.lib.pod]perldbmfilter.pod [.lib.pod]perldebguts.pod [.lib.pod]perldebtut.pod +pod7 = [.lib.pod]perldebug.pod [.lib.pod]perldelta.pod [.lib.pod]perldgux.pod [.lib.pod]perldiag.pod [.lib.pod]perldoc.pod [.lib.pod]perldos.pod +pod8 = [.lib.pod]perldsc.pod [.lib.pod]perlebcdic.pod [.lib.pod]perlembed.pod [.lib.pod]perlepoc.pod [.lib.pod]perlfaq.pod [.lib.pod]perlfaq1.pod +pod9 = [.lib.pod]perlfaq2.pod [.lib.pod]perlfaq3.pod [.lib.pod]perlfaq4.pod [.lib.pod]perlfaq5.pod [.lib.pod]perlfaq6.pod [.lib.pod]perlfaq7.pod +pod10 = [.lib.pod]perlfaq8.pod [.lib.pod]perlfaq9.pod [.lib.pod]perlfilter.pod [.lib.pod]perlfork.pod [.lib.pod]perlform.pod [.lib.pod]perlfreebsd.pod +pod11 = [.lib.pod]perlfunc.pod [.lib.pod]perlgpl.pod [.lib.pod]perlguts.pod [.lib.pod]perlhack.pod [.lib.pod]perlhist.pod [.lib.pod]perlhpux.pod +pod12 = [.lib.pod]perlhurd.pod [.lib.pod]perlintern.pod [.lib.pod]perlintro.pod [.lib.pod]perliol.pod [.lib.pod]perlipc.pod [.lib.pod]perlirix.pod +pod13 = [.lib.pod]perljp.pod [.lib.pod]perlko.pod [.lib.pod]perllexwarn.pod [.lib.pod]perllocale.pod [.lib.pod]perllol.pod [.lib.pod]perlmachten.pod +pod14 = [.lib.pod]perlmacos.pod [.lib.pod]perlmacosx.pod [.lib.pod]perlmint.pod [.lib.pod]perlmod.pod [.lib.pod]perlmodinstall.pod [.lib.pod]perlmodlib.pod +pod15 = [.lib.pod]perlmodstyle.pod [.lib.pod]perlmpeix.pod [.lib.pod]perlnetware.pod [.lib.pod]perlnewmod.pod [.lib.pod]perlnumber.pod [.lib.pod]perlobj.pod +pod16 = [.lib.pod]perlop.pod [.lib.pod]perlopentut.pod [.lib.pod]perlos2.pod [.lib.pod]perlos390.pod [.lib.pod]perlos400.pod [.lib.pod]perlothrtut.pod +pod17 = [.lib.pod]perlpacktut.pod [.lib.pod]perlplan9.pod [.lib.pod]perlpod.pod [.lib.pod]perlpodspec.pod [.lib.pod]perlport.pod [.lib.pod]perlqnx.pod +pod18 = [.lib.pod]perlre.pod [.lib.pod]perlref.pod [.lib.pod]perlreftut.pod [.lib.pod]perlrequick.pod [.lib.pod]perlreref.pod [.lib.pod]perlretut.pod +pod19 = [.lib.pod]perlrun.pod [.lib.pod]perlsec.pod [.lib.pod]perlsolaris.pod [.lib.pod]perlstyle.pod [.lib.pod]perlsub.pod [.lib.pod]perlsyn.pod +pod20 = [.lib.pod]perlthrtut.pod [.lib.pod]perltie.pod [.lib.pod]perltoc.pod [.lib.pod]perltodo.pod [.lib.pod]perltooc.pod [.lib.pod]perltoot.pod +pod21 = [.lib.pod]perltrap.pod [.lib.pod]perltru64.pod [.lib.pod]perltw.pod [.lib.pod]perlunicode.pod [.lib.pod]perluniintro.pod [.lib.pod]perlutil.pod +pod22 = [.lib.pod]perluts.pod [.lib.pod]perlvar.pod [.lib.pod]perlvmesa.pod [.lib.pod]perlvms.pod [.lib.pod]perlvos.pod [.lib.pod]perlwin32.pod +pod23 = [.lib.pod]perlxs.pod [.lib.pod]perlxstut.pod +pod = $(pod0) $(pod1) $(pod2) $(pod3) $(pod4) $(pod5) $(pod6) $(pod7) $(pod8) $(pod9) $(pod10) $(pod11) $(pod12) $(pod13) $(pod14) $(pod15) $(pod16) $(pod17) $(pod18) $(pod19) $(pod20) $(pod21) $(pod22) $(pod23) # Would be useful to automate the generation of this rule from pod/buildtoc # Plus its corresponding delete in the clean target. @@ -482,10 +477,10 @@ $(ARCHDIR)Config.pm : [.lib]Config.pm $(ARCHDIR)vmspipe.com : vmspipe.com Copy $(MMS$SOURCE) $(ARCHDIR) -# Aargh. I don't know how (if) it's possible to change directory -# So make the perl script do it -$(unidatafiles) : $(MINIPERL_EXE) [.lib]Config.pm [.lib.unicore]mktables - $(MINIPERL) [.lib.unicore]mktables "-C" lib "-C" unicore +unidatafiles.ts : $(MINIPERL_EXE) [.lib]Config.pm [.lib.unicore]mktables + $(MINIPERL) [.lib.unicore]mktables "-C" [.lib.unicore] + @ If F$Search("$(MMS$TARGET)").nes."" Then Delete/NoLog/NoConfirm $(MMS$TARGET);* + @ Copy/NoConfirm _NLA0: $(MMS$TARGET) [.ext.dynaloader]dl_vms.c : [.ext.dynaloader]dl_vms.xs $(ARCHDIR)Config.pm [.lib.ExtUtils]XSSymSet.pm $(MINIPERL_EXE) $(XSUBPP) $(MMS$SOURCE) >$(MMS$TARGET) @@ -715,6 +710,10 @@ preplibrary : $(MINIPERL_EXE) $(LIBPREREQ) @ If F$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod] Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pod] +[.lib.pod]perl586delta.pod : [.pod]perl586delta.pod + @ If F$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod] + Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pod] + [.lib.pod]perl58delta.pod : [.pod]perl58delta.pod @ If F$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod] Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pod] @@ -1272,6 +1271,12 @@ check : test @ Continue test : all [.t.lib]vmsfspec.t [.t.lib]vms_dclsym.t [.t.lib]vms_stdio.t + @ PERL_TEST_DRIVER == "TEST." + - @[.VMS]Test.Com "$(E)" "$(__DEBUG__)" + @ $(MINIPERL) -e "print ""Ran tests"";" > [.t]rantests. + +test_harness : all [.t.lib]vmsfspec.t [.t.lib]vms_dclsym.t [.t.lib]vms_stdio.t + @ PERL_TEST_DRIVER == "harness." - @[.VMS]Test.Com "$(E)" "$(__DEBUG__)" @ $(MINIPERL) -e "print ""Ran tests"";" > [.t]rantests. @@ -1663,7 +1668,8 @@ realclean : clean - If F$Search("Config.H").nes."" Then Delete/NoConfirm/Log Config.H;* - If F$Search("Config.SH").nes."" Then Delete/NoConfirm/Log Config.SH;* - $(MINIPERL) -e "use File::Path; rmtree(\@ARGV,1,0);" config - - $(MINIPERL) -e "foreach (@ARGV) {unlink qq{$_;*} or warn qq{unlink $_: $!}}" $(unidatafiles) + - If F$Search("[.lib.unicore]*.pl").nes."" Then Delete/NoConfirm/Log [.lib.unicore]*.pl;* + - If F$Search("[.lib.unicore]Properties.").nes."" Then Delete/NoConfirm/Log [.lib.unicore]Properties.;* - $(MINIPERL) -e "use File::Path; rmtree(\@ARGV,1,0);" $(unidatadirs) - If F$Search("Descrip.MMS").nes."" Then Delete/NoConfirm/Log Descrip.MMS;* - If F$Search("make_ext.Com").nes."" Then Delete/NoConfirm/Log make_ext.Com;* diff --git a/gnu/usr.bin/perl/warnings.pl b/gnu/usr.bin/perl/warnings.pl index 471e99d4db3..3c80ba960cc 100644 --- a/gnu/usr.bin/perl/warnings.pl +++ b/gnu/usr.bin/perl/warnings.pl @@ -708,6 +708,8 @@ sub unimport ${^WARNING_BITS} = $mask ; } +my %builtin_type; @builtin_type{qw(SCALAR ARRAY HASH CODE REF GLOB LVALUE Regexp)} = (); + sub __chk { my $category ; @@ -717,10 +719,10 @@ sub __chk if (@_) { # check the category supplied. $category = shift ; - if (ref $category) { - Croaker ("not an object") - if $category !~ /^([^=]+)=/ ; - $category = $1 ; + if (my $type = ref $category) { + Croaker("not an object") + if exists $builtin_type{$type}; + $category = $type; $isobj = 1 ; } $offset = $Offsets{$category}; diff --git a/gnu/usr.bin/perl/win32/config_H.vc64 b/gnu/usr.bin/perl/win32/config_H.vc64 index 94a820e5c13..088f2321bae 100644 --- a/gnu/usr.bin/perl/win32/config_H.vc64 +++ b/gnu/usr.bin/perl/win32/config_H.vc64 @@ -1344,7 +1344,7 @@ * This symbol contains the ~name expanded version of ARCHLIB, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ -#define ARCHLIB "c:\\perl\\5.8.5\\lib\\MSWin32-x86-multi-thread" /**/ +#define ARCHLIB "c:\\perl\\5.8.6\\lib\\MSWin32-x86-multi-thread" /**/ /*#define ARCHLIB_EXP "" /**/ /* BIN: @@ -1355,8 +1355,8 @@ * This symbol is the filename expanded version of the BIN symbol, for * programs that do not want to deal with that at run-time. */ -#define BIN "c:\\perl\\5.8.5\\bin\\MSWin32-x86-multi-thread" /**/ -#define BIN_EXP "c:\\perl\\5.8.5\\bin\\MSWin32-x86-multi-thread" /**/ +#define BIN "c:\\perl\\5.8.6\\bin\\MSWin32-x86-multi-thread" /**/ +#define BIN_EXP "c:\\perl\\5.8.6\\bin\\MSWin32-x86-multi-thread" /**/ /* PERL_INC_VERSION_LIST: * This variable specifies the list of subdirectories in over @@ -1393,8 +1393,8 @@ * This symbol contains the ~name expanded version of PRIVLIB, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ -#define PRIVLIB "c:\\perl\\5.8.5\\lib" /**/ -#define PRIVLIB_EXP (win32_get_privlib("5.8.5")) /**/ +#define PRIVLIB "c:\\perl\\5.8.6\\lib" /**/ +#define PRIVLIB_EXP (win32_get_privlib("5.8.6")) /**/ /* SITEARCH: * This symbol contains the name of the private library for this package. @@ -1411,7 +1411,7 @@ * This symbol contains the ~name expanded version of SITEARCH, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ -#define SITEARCH "c:\\perl\\site\\5.8.5\\lib\\MSWin32-x86-multi-thread" /**/ +#define SITEARCH "c:\\perl\\site\\5.8.6\\lib\\MSWin32-x86-multi-thread" /**/ /*#define SITEARCH_EXP "" /**/ /* SITELIB: @@ -1434,8 +1434,8 @@ * removed. The elements in inc_version_list (inc_version_list.U) can * be tacked onto this variable to generate a list of directories to search. */ -#define SITELIB "c:\\perl\\site\\5.8.5\\lib" /**/ -#define SITELIB_EXP (win32_get_sitelib("5.8.5")) /**/ +#define SITELIB "c:\\perl\\site\\5.8.6\\lib" /**/ +#define SITELIB_EXP (win32_get_sitelib("5.8.6")) /**/ #define SITELIB_STEM "" /**/ /* PERL_VENDORARCH: diff --git a/gnu/usr.bin/perl/win32/sync_ext.pl b/gnu/usr.bin/perl/win32/sync_ext.pl index e482b69838d..c0ef13b8ce1 100644 --- a/gnu/usr.bin/perl/win32/sync_ext.pl +++ b/gnu/usr.bin/perl/win32/sync_ext.pl @@ -2,6 +2,13 @@ Synchronize filename cases for extensions. +This script could be used to perform following renaming: +if there exist file, for example, "FiLeNaME.c" and +filename.obj then it renames "filename.obj" to "FiLeNaME.obj". +There is a problem when some compilers (e.g.Borland) generate +such .obj files and then "make" process will not treat them +as dependant and already maked files. + This script takes two arguments - first and second extensions to synchronize filename cases with. |