diff options
Diffstat (limited to 'gnu/usr.bin')
| -rw-r--r-- | gnu/usr.bin/perl/cpan/Term-ReadKey/Changes | 314 | ||||
| -rw-r--r-- | gnu/usr.bin/perl/cpan/Term-ReadKey/Configure.pm | 871 | ||||
| -rw-r--r-- | gnu/usr.bin/perl/cpan/Term-ReadKey/MANIFEST | 15 | ||||
| -rw-r--r-- | gnu/usr.bin/perl/cpan/Term-ReadKey/MANIFEST.SKIP | 3 | ||||
| -rw-r--r-- | gnu/usr.bin/perl/cpan/Term-ReadKey/META.json | 49 | ||||
| -rw-r--r-- | gnu/usr.bin/perl/cpan/Term-ReadKey/META.yml | 26 | ||||
| -rw-r--r-- | gnu/usr.bin/perl/cpan/Term-ReadKey/Makefile.PL | 86 | ||||
| -rw-r--r-- | gnu/usr.bin/perl/cpan/Term-ReadKey/README | 145 | ||||
| -rw-r--r-- | gnu/usr.bin/perl/cpan/Term-ReadKey/ReadKey.pm | 654 | ||||
| -rw-r--r-- | gnu/usr.bin/perl/cpan/Term-ReadKey/ReadKey.xs | 1923 | ||||
| -rw-r--r-- | gnu/usr.bin/perl/cpan/Term-ReadKey/example/test.pl | 366 | ||||
| -rw-r--r-- | gnu/usr.bin/perl/cpan/Term-ReadKey/genchars.pl | 488 | ||||
| -rw-r--r-- | gnu/usr.bin/perl/cpan/Term-ReadKey/ppport.h | 7452 | ||||
| -rw-r--r-- | gnu/usr.bin/perl/cpan/Term-ReadKey/t/01_basic.t | 7 | ||||
| -rw-r--r-- | gnu/usr.bin/perl/cpan/Term-ReadKey/t/02_terminal_functions.t | 86 |
15 files changed, 12485 insertions, 0 deletions
diff --git a/gnu/usr.bin/perl/cpan/Term-ReadKey/Changes b/gnu/usr.bin/perl/cpan/Term-ReadKey/Changes new file mode 100644 index 00000000000..6372ca39004 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/Term-ReadKey/Changes @@ -0,0 +1,314 @@ +2015-06-04 Jonathan Stowe <jns+git@gellyfish.co.uk> + + * .gitignore, Changes, META.yml, README, ReadKey.pm: Up version + +2015-06-04 Jonathan Stowe <jns+git@gellyfish.co.uk> + + * .gitignore: Add .bs file to .gitignore + +2015-06-04 Jonathan Stowe <jns@gellyfish.co.uk> + + * : Merge pull request #6 from ntyni/master Make genchars.pl output reproducible by sorting hash keys + +2015-04-30 Jonathan Stowe <jns+git@gellyfish.co.uk> + + * Makefile.PL: Fix for "[rt.cpan.org #100932] Parallel build fails" + from Petr Pisar + +2015-04-30 Jonathan Stowe <jns+git@gellyfish.co.uk> + + * MANIFEST.SKIP: Add .git directory to the MANIFEST.SKIP + +2015-04-13 Jonathan Stowe <jns+git@gellyfish.co.uk> + + * MANIFEST, MANIFEST.SKIP: Add new artefacts + +2015-04-13 Jonathan Stowe <jns+git@gellyfish.co.uk> + + * .travis.yml: Add travis-ci testing + +2015-04-13 Jonathan Stowe <jns+git@gellyfish.co.uk> + + * .gitignore: Add .gitignore + +2015-04-13 Jonathan Stowe <jns@gellyfish.co.uk> + + * : Merge pull request #5 from + sdeseille/Create_T_directory_and_split_test.pl Create t directory and split test.pl + +2015-04-11 Sébastien Deseille <sebastien.deseille@gmail.com> + + * README: Update README to reflect the move of test.pl in example + subdirectory + +2015-04-11 Sébastien Deseille <sebastien.deseille@gmail.com> + + * README: Revert "Update README to reflect the move of test.pl in + example subdirectory" This reverts commit 09402dcd68d8d0417e0eb2f9ea0aeaf4b4c72e9a. + +2015-04-11 Sébastien Deseille <sebastien.deseille@gmail.com> + + * README: Update README to reflect the move of test.pl in example + subdirectory + +2015-04-11 Sébastien Deseille <sebastien.deseille@gmail.com> + + * example/test.pl, test.pl: Move test.pl in example's subdirectory + in order to keep the possibility to use its interactive mode + +2015-04-11 Sébastien Deseille <sebastien.deseille@gmail.com> + + * t/02_terminal_functions.t: Finished to implement all tests from + test.pl + +2015-04-11 Sébastien Deseille <sebastien.deseille@gmail.com> + + * t/02_terminal_functions.t: Add test to Check TerminalSize OUT + +2015-04-11 Sébastien Deseille <sebastien.deseille@gmail.com> + + * t/02_terminal_functions.t: Add test to Check non-blocking read + +2015-04-10 Sébastien Deseille <sebastien.deseille@gmail.com> + + * t/02_terminal_functions.t: Add second test about Comparing + TerminalSize + +2015-04-10 Sébastien Deseille <sebastien.deseille@gmail.com> + + * t/01_basic.t: Add first test to validate module loading + +2015-04-03 Jonathan Stowe <jns@gellyfish.co.uk> + + * : Merge pull request #3 from kmx/master no resize, no stty on MS Windows + +2014-05-10 Jonathan Stowe <jns+git@gellyfish.co.uk> + + * Changes: Update changes with git2cl (some manual reordering) + +2014-05-10 Jonathan Stowe <jns+git@gellyfish.co.uk> + + * Makefile.PL: Makefile.PL more specific + +2014-05-10 Jonathan Stowe <jns+git@gellyfish.co.uk> + + * : Merge pull request #2 from jacquesg/warnings Fix some warnings + +2014-03-09 Jonathan Stowe <jns+git@gellyfish.co.uk> + + * Configure.pm, META.yml, Makefile.PL: Don't index Configure.pm + +2014-03-03 Jonathan Stowe <jns+git@gellyfish.co.uk> + + * Changes, README, ReadKey.pm: Added documentation patch as per + Chris Marshall Bumped version + +2013-10-28 Jonathan Stowe <jns+git@gellyfish.co.uk> + + * README: Some changes to README + +2013-10-28 Brian Wightman <MidLifeXis@wightmanfam.org> + + * ReadKey.pm: Promote SUPPORT and LICENSE to top-level head sections SUPPORT and LICENSE sections were in item sections, but outside of + an over/back block. + +2013-10-27 Jonathan Stowe <jns@gellyfish.co.uk> + + * Makefile.PL, README, ReadKey.pm, ReadKey.xs, genchars.pl: Change + licensing Fix some warnings + +2013-10-26 Jonathan Stowe <jns@gellyfish.co.uk> + + * ReadKey.pm: Applied patch from rt #35669 + +2013-10-26 Jonathan Stowe <jns@gellyfish.co.uk> + + * Makefile.PL, ReadKey.xs: Applied change from rt #26235 Also fixed + repo name + +2013-10-26 Jonathan Stowe <jns@gellyfish.co.uk> + + * ReadKey.pm: Patch from rt #35671 + +2013-10-26 Jonathan Stowe <jns@gellyfish.co.uk> + + * ppport.h: Updated ppport.h as per #78831 + +2013-10-26 Jonathan Stowe <jns@gellyfish.co.uk> + + * Makefile.PL: Changed distname per RT #87885 Added additional + metadata + +2013-10-26 Jonathan Stowe <jns@gellyfish.co.uk> + + * ReadKey.pm: Added changes for RT #86584 + +2013-10-26 Jonathan Stowe <jns@gellyfish.co.uk> + + * ReadKey.pm: Added patch from jpeacock@cpan.org for RT #88266 + +2011-04-19 Jonathan Stowe <jns@gellyfish.co.uk> + + * Changes: Added Changes + +2011-04-19 Jonathan Stowe <jns@gellyfish.co.uk> + + * : commit 40ba6a2a80ae495b921ab416f6b024014daac25e Author: Stas + Grabois <CENSORED> Date: Tue Jun 24 01:57:37 2008 -0800 + +2006-01-13 jonathan <jonathan@d4a3e428-c23c-0410-a93a-b1ce904c0fb3> + + * MANIFEST, Makefile.PL: Added Changes git-svn-id: http://jstowe.googlecode.com/svn/trunk/TermReadKey@74 + d4a3e428-c23c-0410-a93a-b1ce904c0fb3 + +2005-01-11 jonathan <jonathan@d4a3e428-c23c-0410-a93a-b1ce904c0fb3> + + * test.pl: Skip tests if /dev/tty for automated testing git-svn-id: http://jstowe.googlecode.com/svn/trunk/TermReadKey@53 + d4a3e428-c23c-0410-a93a-b1ce904c0fb3 + +2005-01-11 jonathan <jonathan@d4a3e428-c23c-0410-a93a-b1ce904c0fb3> + + * ReadKey.pm: Fixed POD git-svn-id: http://jstowe.googlecode.com/svn/trunk/TermReadKey@52 + d4a3e428-c23c-0410-a93a-b1ce904c0fb3 + +2005-01-11 jonathan <jonathan@d4a3e428-c23c-0410-a93a-b1ce904c0fb3> + + * README, ReadKey.pm, ReadKey.xs, genchars.pl, ppport.h: * Updated ppport.h * Fixed example in synopsis * termio branch not updated git-svn-id: http://jstowe.googlecode.com/svn/trunk/TermReadKey@51 + d4a3e428-c23c-0410-a93a-b1ce904c0fb3 + +2004-03-02 jonathan <jonathan@d4a3e428-c23c-0410-a93a-b1ce904c0fb3> + + * Put back in CVS git-svn-id: http://jstowe.googlecode.com/svn/trunk/TermReadKey@19 + d4a3e428-c23c-0410-a93a-b1ce904c0fb3 + +2005-01-12 Jonathan Stowe <jns@gellyfish.co.uk> + + * Configure.pm, MANIFEST, META.yml, Makefile.PL, README, + ReadKey.pm, ReadKey.xs, genchars.pl, ppport.h, test.pl: import + TermReadKey 2.30 from CPAN git-cpan-module: TermReadKey git-cpan-version: 2.30 + git-cpan-authorid: JSTOWE git-cpan-file: + authors/id/J/JS/JSTOWE/TermReadKey-2.30.tar.gz + +2002-07-28 Jonathan Stowe <jns@gellyfish.co.uk> + + * README, ReadKey.pm, ReadKey.xs, ppport.h, test.pl: import + TermReadKey 2.21 from CPAN git-cpan-module: TermReadKey git-cpan-version: 2.21 + git-cpan-authorid: JSTOWE git-cpan-file: + authors/id/J/JS/JSTOWE/TermReadKey-2.21.tar.gz + +2002-05-24 Jonathan Stowe <jns@gellyfish.co.uk> + + * README, ReadKey.pm, ReadKey.xs: import TermReadKey 2.20 from CPAN git-cpan-module: TermReadKey git-cpan-version: 2.20 + git-cpan-authorid: JSTOWE git-cpan-file: + authors/id/J/JS/JSTOWE/TermReadKey-2.20.tar.gz + +2002-03-21 Jonathan Stowe <jns@gellyfish.co.uk> + + * README, ReadKey.pm, ReadKey.xs: import TermReadKey 2.19 from CPAN git-cpan-module: TermReadKey git-cpan-version: 2.19 + git-cpan-authorid: JSTOWE git-cpan-file: + authors/id/J/JS/JSTOWE/TermReadKey-2.19.tar.gz + +2002-02-10 Jonathan Stowe <jns@gellyfish.co.uk> + + * Configure.pm, Makefile.PL, README, ReadKey.pm, ReadKey.xs, + genchars.pl: import TermReadKey 2.18 from CPAN git-cpan-module: TermReadKey git-cpan-version: 2.18 + git-cpan-authorid: JSTOWE git-cpan-file: + authors/id/J/JS/JSTOWE/TermReadKey-2.18.tar.gz + +2002-01-25 Jonathan Stowe <jns@gellyfish.co.uk> + + * Makefile.PL, README, ReadKey.pm, ReadKey.xs, test.pl: import + TermReadKey 2.17 from CPAN git-cpan-module: TermReadKey git-cpan-version: 2.17 + git-cpan-authorid: JSTOWE git-cpan-file: + authors/id/J/JS/JSTOWE/TermReadKey-2.17.tar.gz + +2001-11-29 Jonathan Stowe <jns@gellyfish.co.uk> + + * ReadKey.pm, ReadKey.xs, genchars.pl, ppport.h: import TermReadKey + 2.16 from CPAN git-cpan-module: TermReadKey git-cpan-version: 2.16 + git-cpan-authorid: JSTOWE git-cpan-file: + authors/id/J/JS/JSTOWE/TermReadKey-2.16.tar.gz + +2001-11-07 Jonathan Stowe <jns@gellyfish.co.uk> + + * ReadKey.pm, ReadKey.xs: import TermReadKey 2.15 from CPAN git-cpan-module: TermReadKey git-cpan-version: 2.15 + git-cpan-authorid: JSTOWE git-cpan-file: + authors/id/J/JS/JSTOWE/TermReadKey-2.15.tar.gz + +1999-03-29 Kenneth Albanowski <kjahds@kjahds.com> + + * Makefile.PL, ReadKey.pm, ReadKey.xs, ppport.h: import TermReadKey + 2.14 from CPAN git-cpan-module: TermReadKey git-cpan-version: 2.14 + git-cpan-authorid: KJALB git-cpan-file: + authors/id/K/KJ/KJALB/TermReadKey-2.14.tar.gz + +1999-03-24 Kenneth Albanowski <kjahds@kjahds.com> + + * MANIFEST, Makefile.PL, README, ReadKey.pm, ReadKey.xs, + genchars.pl, ppport.h: import TermReadKey 2.13 from CPAN git-cpan-module: TermReadKey git-cpan-version: 2.13 + git-cpan-authorid: KJALB git-cpan-file: + authors/id/K/KJ/KJALB/TermReadKey-2.13.tar.gz + +1998-01-07 Kenneth Albanowski <kjahds@kjahds.com> + + * Makefile.PL, README, ReadKey.pm, ReadKey.xs, test.pl: import + TermReadKey 2.12 from CPAN git-cpan-module: TermReadKey git-cpan-version: 2.12 + git-cpan-authorid: KJALB git-cpan-file: + authors/id/K/KJ/KJALB/TermReadKey-2.12.tar.gz + +1997-12-13 Kenneth Albanowski <kjahds@kjahds.com> + + * Makefile.PL, README, ReadKey.pm, ReadKey.xs, test.pl: import + TermReadKey 2.11 from CPAN git-cpan-module: TermReadKey git-cpan-version: 2.11 + git-cpan-authorid: KJALB git-cpan-file: + authors/id/K/KJ/KJALB/TermReadKey-2.11.tar.gz + +1997-10-07 Kenneth Albanowski <kjahds@kjahds.com> + + * Makefile.PL, ReadKey.pm, ReadKey.xs, genchars.pl: import + TermReadKey 2.09 from CPAN git-cpan-module: TermReadKey git-cpan-version: 2.09 + git-cpan-authorid: KJALB git-cpan-file: + authors/id/K/KJ/KJALB/TermReadKey-2.09.tar.gz + +1997-10-06 Kenneth Albanowski <kjahds@kjahds.com> + + * Makefile.PL, README, ReadKey.pm, ReadKey.xs: import TermReadKey + 2.08 from CPAN git-cpan-module: TermReadKey git-cpan-version: 2.08 + git-cpan-authorid: KJALB git-cpan-file: + authors/id/K/KJ/KJALB/TermReadKey-2.08.tar.gz + +1997-01-27 Kenneth Albanowski <kjahds@kjahds.com> + + * Makefile.PL, ReadKey.pm, ReadKey.xs: import TermReadKey 2.07 from + CPAN git-cpan-module: TermReadKey git-cpan-version: 2.07 + git-cpan-authorid: KJALB git-cpan-file: + authors/id/K/KJ/KJALB/TermReadKey-2.07.tar.gz + +1996-11-25 Kenneth Albanowski <kjahds@kjahds.com> + + * Makefile.PL, README, ReadKey.pm, ReadKey.xs, test.pl: import + TermReadKey 2.06 from CPAN git-cpan-module: TermReadKey git-cpan-version: 2.06 + git-cpan-authorid: KJALB git-cpan-file: + authors/id/K/KJ/KJALB/TermReadKey-2.06.tar.gz + +1996-03-14 Kenneth Albanowski <kjahds@kjahds.com> + + * Makefile.PL, README, ReadKey.pm, ReadKey.xs: import TermReadKey + 2.05 from CPAN git-cpan-module: TermReadKey git-cpan-version: 2.05 + git-cpan-authorid: KJALB git-cpan-file: + authors/id/K/KJ/KJALB/TermReadKey-2.05.tar.gz + +1995-10-11 Kenneth Albanowski <kjahds@kjahds.com> + + * Makefile.PL, README, ReadKey.xs: import TermReadKey 2.04 from CPAN git-cpan-module: TermReadKey git-cpan-version: 2.04 + git-cpan-authorid: KJALB git-cpan-file: + authors/id/K/KJ/KJALB/TermReadKey-2.04.tar.gz + +1995-09-29 Kenneth Albanowski <kjahds@kjahds.com> + + * Configure.pm, MANIFEST, Makefile.PL, README, ReadKey.pm, + ReadKey.xs, genchars.pl, test.pl: initial import of TermReadKey 2.03 + from CPAN git-cpan-module: TermReadKey git-cpan-version: 2.03 + git-cpan-authorid: KJALB git-cpan-file: + authors/id/K/KJ/KJALB/TermReadKey-2.03.tar.gz + diff --git a/gnu/usr.bin/perl/cpan/Term-ReadKey/Configure.pm b/gnu/usr.bin/perl/cpan/Term-ReadKey/Configure.pm new file mode 100644 index 00000000000..98fa0d413fd --- /dev/null +++ b/gnu/usr.bin/perl/cpan/Term-ReadKey/Configure.pm @@ -0,0 +1,871 @@ +#!/usr/bin/perl + +# Configure.pm. Version 1.00 Copyright (C) 1995, Kenneth Albanowski +# +# You are welcome to use this code in your own perl modules, I just +# request that you don't distribute modified copies without making it clear +# that you have changed something. If you have a change you think is worth +# merging into the original, please contact me at kjahds@kjahds.com or +# CIS:70705,126 +# +# $Id: Configure.pm,v 1.1 2016/05/07 16:03:09 espie Exp $ +# + +# Todo: clean up redudant code in CPP, Compile, Link, and Execute +# + +# for when no_index is not enough +package +Configure; + +use strict; + +use vars qw(@EXPORT @ISA); + +use Carp; +require Exporter; +@ISA = qw(Exporter); + +@EXPORT = qw( CPP + Compile + Link + Execute + FindHeader + FindLib + Apply + ApplyHeaders + ApplyLibs + ApplyHeadersAndLibs + ApplyHeadersAndLibsAndExecute + CheckHeader + CheckStructure + CheckField + CheckHSymbol + CheckSymbol + CheckLSymbol + GetSymbol + GetTextSymbol + GetNumericSymbol + GetConstants); + +use Cwd; +use Config; + +my ($C_usrinc, $C_libpth, $C_cppstdin, $C_cppflags, $C_cppminus, +$C_ccflags,$C_ldflags,$C_cc,$C_libs) = + @Config{qw( usrinc libpth cppstdin cppflags cppminus + ccflags ldflags cc libs)}; + +my $Verbose = 0; + +=head1 NAME + +Configure.pm - provide auto-configuration utilities + +=head1 SUMMARY + +This perl module provides tools to figure out what is present in the C +compilation environment. This is intended mostly for perl extensions to use +to configure themselves. There are a number of functions, with widely varying +levels of specificity, so here is a summary of what the functions can do: + + +CheckHeader: Look for headers. + +CheckStructure: Look for a structure. + +CheckField: Look for a field in a structure. + +CheckHSymbol: Look for a symbol in a header. + +CheckLSymbol: Look for a symbol in a library. + +CheckSymbol: Look for a symbol in a header and library. + +GetTextSymbol: Get the contents of a symbol as text. + +GetNumericSymbol: Get the contents of a symbol as a number. + +Apply: Try compiling code with a set of headers and libs. + +ApplyHeaders: Try compiling code with a set of headers. + +ApplyLibraries: Try linking code with a set of libraries. + +ApplyHeadersAndLibaries: You get the idea. + +ApplyHeadersAndLibariesAnExecute: You get the idea. + +CPP: Feed some code through the C preproccessor. + +Compile: Try to compile some C code. + +Link: Try to compile & link some C code. + +Execute: Try to compile, link, & execute some C code. + +=head1 FUNCTIONS + +=cut + +# Here we go into the actual functions + +=head2 CPP + +Takes one or more arguments. The first is a string containing a C program. +Embedded newlines are legal, the text simply being stuffed into a temporary +file. The result is then fed to the C preproccessor (that preproccessor being +previously determined by perl's Configure script.) Any additional arguments +provided are passed to the preprocessing command. + +In a scalar context, the return value is either undef, if something went wrong, +or the text returned by the preprocessor. In an array context, two values are +returned: the numeric exit status and the output of the preproccessor. + +=cut + +sub CPP { # Feed code to preproccessor, returning error value and output + + my($code,@options) = @_; + my($options) = join(" ",@options); + my($file) = "tmp$$"; + my($in,$out) = ($file.".c",$file.".o"); + + open(F,">$in"); + print F $code; + close(F); + + print "Preprocessing |$code|\n" if $Verbose; + my($result) = scalar(`$C_cppstdin $C_cppflags $C_cppminus $options < $in 2>/dev/null`); + print "Executing '$C_cppstdin $C_cppflags $C_cppminus $options < $in 2>/dev/null'\n" if $Verbose; + + + my($error) = $?; + print "Returned |$result|\n" if $Verbose; + unlink($in,$out); + return ($error ? undef : $result) unless wantarray; + ($error,$result); +} + +=head2 Compile + +Takes one or more arguments. The first is a string containing a C program. +Embedded newlines are legal, the text simply being stuffed into a temporary +file. The result is then fed to the C compiler (that compiler being +previously determined by perl's Configure script.) Any additional arguments +provided are passed to the compiler command. + +In a scalar context, either 0 or 1 will be returned, with 1 indicating a +successful compilation. In an array context, three values are returned: the +numeric exit status of the compiler, a string consisting of the output +generated by the compiler, and a numeric value that is false if a ".o" file +wasn't produced by the compiler, error status or no. + +=cut + +sub Compile { # Feed code to compiler. On error, return status and text + my($code,@options) = @_; + my($options)=join(" ",@options); + my($file) = "tmp$$"; + my($in,$out) = ($file.".c",$file.".o"); + + open(F,">$in"); + print F $code; + close(F); + print "Compiling |$code|\n" if $Verbose; + my($result) = scalar(`$C_cc $C_ccflags -c $in $C_ldflags $C_libs $options 2>&1`); + print "Executing '$C_cc $C_ccflags -c $in $C_ldflags $C_libs $options 2>&1'\n" if $Verbose; + my($error) = $?; + my($error2) = ! -e $out; + unlink($in,$out); + return (($error || $error2) ? 0 : 1) unless wantarray; + ($error,$result,$error2); +} + +=head2 Link + +Takes one or more arguments. The first is a string containing a C program. +Embedded newlines are legal, the text simply being stuffed into a temporary +file. The result is then fed to the C compiler and linker (that compiler and +linker being previously determined by perl's Configure script.) Any +additional arguments provided are passed to the compilation/link command. + +In a scalar context, either 0 or 1 is returned, with 1 indicating a +successful compilation. In an array context, two values are returned: the +numeric exit status of the compiler/linker, and a string consisting of the +output generated by the compiler/linker. + +Note that this command I<only> compiles and links the C code. It does not +attempt to execute it. + +=cut + +sub Link { # Feed code to compiler and linker. On error, return status and text + my($code,@options) = @_; + my($options) = join(" ",@options); + my($file) = "tmp$$"; + my($in,$out) = $file.".c",$file.".o"; + + open(F,">$in"); + print F $code; + close(F); + print "Linking |$code|\n" if $Verbose; + my($result) = scalar(`$C_cc $C_ccflags -o $file $in $C_ldflags $C_libs $options 2>&1`); + print "Executing '$C_cc $C_ccflags -o $file $in $C_ldflags $C_libs $options 2>&1'\n" if $Verbose; + my($error)=$?; + print "Error linking: $error, |$result|\n" if $Verbose; + unlink($in,$out,$file); + return (($error || $result ne "")?0:1) unless wantarray; + ($error,$result); +} + +=head2 Execute + +Takes one or more arguments. The first is a string containing a C program. +Embedded newlines are legal, the text simply being stuffed into a temporary +file. The result is then fed to the C compiler and linker (that compiler and +linker being previously determined by perl's metaconfig script.) and then +executed. Any additional arguments provided are passed to the +compilation/link command. (There is no way to feed arguments to the program +being executed.) + +In a scalar context, the return value is either undef, indicating the +compilation or link failed, or that the executed program returned a nonzero +status. Otherwise, the return value is the text output by the program. + +In an array context, an array consisting of three values is returned: the +first value is 0 or 1, 1 if the compile/link succeeded. The second value either +the exist status of the compiler or program, and the third is the output text. + +=cut + +sub Execute { #Compile, link, and execute. + + my($code,@options) = @_; + my($options)=join(" ",@options); + my($file) = "tmp$$"; + my($in,$out) = $file.".c",$file.".o"; + + open(F,">$in"); + print F $code; + close(F); + print "Executing |$code|\n" if $Verbose; + my($result) = scalar(`$C_cc $C_ccflags -o $file $in $C_ldflags $C_libs $options 2>&1`); + print "Executing '$C_cc $C_ccflags -o $file $in $C_ldflags $C_libs $options 2>&1'\n" if $Verbose; + my($error) = $?; + unlink($in,$out); + if(!$error) { + my($result2) = scalar(`./$file`); + $error = $?; + unlink($file); + return ($error?undef:$result2) unless wantarray; + print "Executed successfully, status $error, link $result, exec |$result2|\n" if $Verbose; + (1,$error,$result2); + } else { + print "Link failed, status $error, message |$result|\n" if $Verbose; + return undef unless wantarray; + (0,$error,$result); + } +} + +=head2 FindHeader + +Takes an unlimited number of arguments, consisting of both header names in +the form "header.h", or directory specifications such as "-I/usr/include/bsd". +For each supplied header, FindHeader will attempt to find the complete path. +The return value is an array consisting of all the headers that were located. + +=cut + +sub FindHeader { #For each supplied header name, find full path + my(@headers) = grep(!/^-I/,@_); + my(@I) = grep(/^-I/,@_); + my($h); + for $h (@headers) { + print "Searching for $h... " if $Verbose; + if($h eq "") {$h=undef; next} + if( -f $h) {next} + if( -f $Config{"usrinc"}."/".$h) { + $h = $Config{"usrinc"}."/".$h; + print "Found as $h.\n" if $Verbose; + } else { + my $text; + if($text = CPP("#include <$h>",join(" ",@I))) { + grepcpp: + for (split(/\s+/,(grep(/^\s*#.*$h/,split(/\n/,$text)))[0])) { + if(/$h/) { + s/^\"(.*)\"$/$1/; + s/^\'(.*)\'$/$1/; + $h = $_; + print "Found as $h.\n" if $Verbose; + last grepcpp; + } + } + } else { + $h = undef; # remove header from resulting list + print "Not found.\n" if $Verbose; + } + } + } + grep($_,@headers); +} + +=head2 FindLib + +Takes an unlimited number of arguments, consisting of both library names in +the form "-llibname", "/usr/lib/libxyz.a" or "dld", or directory +specifications such as "-L/usr/lib/foo". For each supplied library, FindLib +will attempt to find the complete path. The return value is an array +consisting of the full paths to all of the libraries that were located. + +=cut + +sub FindLib { #For each supplied library name, find full path + my(@libs) = grep(!/^-L/,@_); + my(@L) = (grep(/^-L/,@_),split(" ",$Config{"libpth"})); + grep(s/^-L//,@L); + my($l); + my($so) = $Config{"so"}; + my($found); + #print "Libaries I am searching for: ",join(",",@libs),"\n"; + #print "Directories: ",join(",",@L),"\n"; + my $lib; + for $lib (@libs) { + print "Searching for $lib... " if $Verbose; + $found=0; + $lib =~ s/^-l//; + if($lib eq "") {$lib=undef; next} + next if -f $lib; + my $path; + for $path (@L) { + my ( $fullname, @fullname ); + print "Searching $path for $lib...\n" if $Verbose; + if (@fullname=<${path}/lib${lib}.${so}.[0-9]*>){ + $fullname=$fullname[-1]; #ATTN: 10 looses against 9! + } elsif (-f ($fullname="$path/lib$lib.$so")){ + } elsif (-f ($fullname="$path/lib${lib}_s.a") + && ($lib .= "_s") ){ # we must explicitly ask for _s version + } elsif (-f ($fullname="$path/lib$lib.a")){ + } elsif (-f ($fullname="$path/Slib$lib.a")){ + } else { + warn "$lib not found in $path\n" if $Verbose; + next; + } + warn "'-l$lib' found at $fullname\n" if $Verbose; + $lib = $fullname; + $found=1; + } + if(!$found) { + $lib = undef; # Remove lib if not found + print "Not found.\n" if $Verbose; + } + } + grep($_,@libs); +} + + +=head2 + +Apply takes a chunk of code, a series of libraries and headers, and attempts +to apply them, in series, to a given perl command. In a scalar context, the +return value of the first set of headers and libraries that produces a +non-zero return value from the command is returned. In an array context, the +header and library set it returned. + +This is best explained by some examples: + + Apply(\&Compile,"main(){}","sgtty.h",""); + +In a scalar context either C<undef> or C<1>. In an array context, +this returns C<()> or C<("sgtty.h","")>. + + Apply(\&Link,"main(){int i=COLOR_PAIRS;}","curses.h","-lcurses", + "ncurses.h","-lncurses","ncurses/ncurses.h","-lncurses"); + +In a scalar context, this returns either C<undef>, C<1>. In an array context, +this returns C<("curses.h","-lcurses")>, C<("ncurses.h","-lncurses")>, +C<("ncurses/ncurses.h","-lncurses")>, or C<()>. + +If we had instead said +C<Apply(\&Execute,'main(){printf("%d",(int)COLOR_PAIRS)',...)> then in a scalar +context either C<undef> or the value of COLOR_PAIRS would be returned. + +Note that you can also supply multiple headers and/or libraries at one time, +like this: + + Apply(\&Compile,"main(){fcntl(0,F_GETFD);}","fcntl.h","", + "ioctl.h fcntl.h","","sys/ioctl.h fcntl.h"",""); + +So if fcntl needs ioctl or sys/ioctl loaded first, this will catch it. In an +array context, C<()>, C<("fcntl.h","")>, C<("ioctl.h fcntl.h","")>, or +C<("sys/ioctl.h fcntl.h","")> could be returned. + +You can also use nested arrays to get exactly the same effect. The returned +array will always consist of a string, though, with elements separated by +spaces. + + Apply(\&Compile,"main(){fcntl(0,F_GETFD);}",["fcntl.h"],"", + ["ioctl.h","fcntl.h"],"",["sys/ioctl.h","fcntl.h"],""); + +Note that there are many functions that provide simpler ways of doing these +things, from GetNumericSymbol to get the value of a symbol, to ApplyHeaders +which doesn't ask for libraries. + +=cut + +sub Apply { # + my($cmd,$code,@lookup) = @_; + my(@l,@h,$i,$ret); + for ($i=0;$i<@lookup;$i+=2) { + if( ref($lookup[$i]) eq "ARRAY" ) { + @h = @{$lookup[$i]}; + } else { + @h = split(/\s+/,$lookup[$i]); + } + if( ref($lookup[$i+1]) eq "ARRAY" ) { + @l = @{$lookup[$i+1]}; + } else { + @l = split(/\s+/,$lookup[$i+1]); + } + + if($ret=&{$cmd == \&Link && !@l?\&Compile:$cmd}(join("",map($_?"#include <$_>\n":"",grep(!/^-I/,@h))). + $code,grep(/^-I/,@h),@l)) { + print "Ret=|$ret|\n" if $Verbose; + return $ret unless wantarray; + return (join(" ",@h),join(" ",@l)); + } + } + return 0 unless wantarray; + (); +} + +=head2 ApplyHeadersAndLibs + +This function takes the same sort of arguments as Apply, it just sends them +directly to Link. + +=cut + +sub ApplyHeadersAndLibs { # + my($code,@lookup) = @_; + Apply \&Link,$code,@lookup; +} + +=head2 ApplyHeadersAndLibsAndExecute + +This function is similar to Apply and ApplyHeadersAndLibs, but it always +uses Execute. + +=cut + +sub ApplyHeadersAndLibsAndExecute { # + my($code,@lookup) = @_; + Apply \&Execute,$code,@lookup; +} + +=head2 ApplyHeaders + +If you are only checking headers, and don't need to look at libs, then +you will probably want to use ApplyHeaders. The return value is the same +in a scalar context, but in an array context the returned array will only +consists of the headers, spread out. + +=cut + +sub ApplyHeaders { + my($code,@headers) = @_; + return scalar(ApplyHeadersAndLibs $code, map(($_,""),@headers)) + unless wantarray; + split(/\s+/,(ApplyHeadersAndLibs $code, map(($_,""),@headers))[0]); +} + +=head2 ApplyLibs + +If you are only checking libraries, and don't need to look at headers, then +you will probably want to use ApplyLibs. The return value is the same +in a scalar context, but in an array context the returned array will only +consists of the libraries, spread out. + +=cut + +sub ApplyLibs { + my($code,@libs) = @_; + return scalar(ApplyHeadersAndLibs $code, map(("",$_),@libs)) + unless wantarray; + split(/\s+/,(ApplyHeadersAndLibs $code, map(("",$_),@libs))[0]); +} + +=head2 CheckHeader + +Takes an unlimited number of arguments, consiting of headers in the +Apply style. The first set that is fully accepted +by the compiler is returned. + +=cut + +sub CheckHeader { #Find a header (or set of headers) that exists + ApplyHeaders("main(){}",@_); +} + +=head2 CheckStructure + +Takes the name of a structure, and an unlimited number of further arguments +consisting of header groups. The first group that defines that structure +properly will be returned. B<undef> will be returned if nothing succeeds. + +=cut + +sub CheckStructure { # Check existance of a structure. + my($structname,@headers) = @_; + ApplyHeaders("main(){ struct $structname s;}",@headers); +} + +=head2 CheckField + +Takes the name of a structure, the name of a field, and an unlimited number +of further arguments consisting of header groups. The first group that +defines a structure that contains the field will be returned. B<undef> will +be returned if nothing succeeds. + +=cut + +sub CheckField { # Check for the existance of specified field in structure + my($structname,$fieldname,@headers) = @_; + ApplyHeaders("main(){ struct $structname s1; struct $structname s2; + s1.$fieldname = s2.$fieldname; }",@headers); +} + +=head2 CheckLSymbol + +Takes the name of a symbol, and an unlimited number of further arguments +consisting of library groups. The first group of libraries that defines +that symbol will be returned. B<undef> will be returned if nothing succeeds. + +=cut + +sub CheckLSymbol { # Check for linkable symbol + my($symbol,@libs) = @_; + ApplyLibs("main() { void * f = (void *)($symbol); }",@libs); +} + +=head2 CheckSymbol + +Takes the name of a symbol, and an unlimited number of further arguments +consisting of header and library groups, in the Apply format. The first +group of headers and libraries that defines that symbol will be returned. +B<undef> will be returned if nothing succeeds. + +=cut + +sub CheckSymbol { # Check for linkable/header symbol + my($symbol,@lookup) = @_; + ApplyHeadersAndLibs("main() { void * f = (void *)($symbol); }",@lookup); +} + +=head2 CheckHSymbol + +Takes the name of a symbol, and an unlimited number of further arguments +consisting of header groups. The first group of headers that defines +that symbol will be returned. B<undef> will be returned if nothing succeeds. + +=cut + +sub CheckHSymbol { # Check for header symbol + my($symbol,@headers) = @_; + ApplyHeaders("main() { void * f = (void *)($symbol); }",@headers); +} + +=head2 CheckHPrototype (unexported) + +An experimental routine that takes a name of a function, a nested array +consisting of the prototype, and then the normal header groups. It attempts +to deduce whether the given prototype matches what the header supplies. +Basically, it doesn't work. Or maybe it does. I wouldn't reccomend it, +though. + +=cut + +sub CheckHPrototype { # Check for header prototype. + # Note: This function is extremely picky about "const int" versus "int", + # and depends on having an extremely snotty compiler. Anything but GCC + # may fail, and even GCC may not work properly. In any case, if the + # names function doesn't exist, this call will _succeed_. Caveat Utilitor. + my($function,$proto,@headers) = @_; + my(@proto) = @{$proto}; + ApplyHeaders("main() { extern ".$proto[0]." $function(". + join(",",@proto[1..$#proto])."); }",@headers); +} + +=head2 GetSymbol + +Takes the name of a symbol, a printf command, a cast, and an unlimited +number of further arguments consisting of header and library groups, in the +Apply. The first group of headers and libraries that defines that symbol +will be used to get the contents of the symbol in the format, and return it. +B<undef> will be returned if nothing defines that symbol. + +Example: + + GetSymbol("__LINE__","ld","long","",""); + +=cut + +sub GetSymbol { # Check for linkable/header symbol + my($symbol,$printf,$cast,@lookup) = @_,"",""; + scalar(ApplyHeadersAndLibsAndExecute( + "main(){ printf(\"\%$printf\",($cast)($symbol));exit(0);}",@lookup)); +} + +=head2 GetTextSymbol + +Takes the name of a symbol, and an unlimited number of further arguments +consisting of header and library groups, in the ApplyHeadersAndLibs format. +The first group of headers and libraries that defines that symbol will be +used to get the contents of the symbol in text format, and return it. +B<undef> will be returned if nothing defines that symbol. + +Note that the symbol I<must> actually be text, either a char* or a constant +string. Otherwise, the results are undefined. + +=cut + +sub GetTextSymbol { # Check for linkable/header symbol + my($symbol,@lookup) = @_,"",""; + my($result) = GetSymbol($symbol,"s","char*",@lookup); + $result .= "" if defined($result); + $result; +} + +=head2 GetNumericSymbol + +Takes the name of a symbol, and an unlimited number of further arguments +consisting of header and library groups, in the ApplyHeadersAndLibs format. +The first group of headers and libraries that defines that symbol will be +used to get the contents of the symbol in numeric format, and return it. +B<undef> will be returned if nothing defines that symbol. + +Note that the symbol I<must> actually be numeric, in a format compatible +with a float. Otherwise, the results are undefined. + +=cut + +sub GetNumericSymbol { # Check for linkable/header symbol + my($symbol,@lookup) = @_,"",""; + my($result) = GetSymbol($symbol,"f","float",@lookup); + $result += 0 if defined($result); + $result; +} + +=head2 GetConstants + +Takes a list of header names (possibly including -I directives) and attempts +to grep the specified files for constants, a constant being something #defined +with a name that matches /[A-Z0-9_]+/. Returns the list of names. + +=cut + +sub GetConstants { # Try to grep constants out of a header + my(@headers) = @_; + @headers = FindHeader(@headers); + my %seen; + my(%results); + map($seen{$_}=1,@headers); + while(@headers) { + $_=shift(@headers); + next if !defined($_); + open(SEARCHHEADER,"<$_"); + while(<SEARCHHEADER>) { + if(/^\s*#\s*define\s+([A-Z_][A-Za-z0-9_]+)\s+/) { + $results{$1} = 1; + } elsif(/^\s*#\s*include\s+[<"]?([^">]+)[>"]?/) { + my(@include) = FindHeader($1); + @include = grep(!$seen{$_},map(defined($_)?$_:(),@include)); + push(@headers,@include); + map($seen{$_}=1,@include); + } + } + close(SEARCHHEADER); + } + keys %results; +} + + +=head2 DeducePrototype (unexported) + +This one is B<really> experimental. The idea is to figure out some basic +characteristics of the compiler, and then attempt to "feel out" the prototype +of a function. Eventually, it may work. It is guaranteed to be very slow, +and it may simply not be capable of working on some systems. + +=cut + +my $firstdeduce = 1; +sub DeducePrototype { + + my (@types, $checkreturn, $checknilargs, $checkniletcargs, $checkreturnnil); + + if($firstdeduce) { + $firstdeduce=0; + my $checknumber=!Compile("extern int func(int a,int b); + extern int func(int a,int b,int c); + main(){}"); + $checkreturn=!Compile("extern int func(int a,int b); + extern long func(int a,int b); + main(){}"); + my $checketc= !Compile("extern int func(int a,int b); + extern long func(int a,...); + main(){}"); + my $checknumberetc=!Compile("extern int func(int a,int b); + extern int func(int a,int b,...); + main(){}"); + my $checketcnumber=!Compile("extern int func(int a,int b,int c,...); + extern int func(int a,int b,...); + main(){}"); + my $checkargtypes=!Compile("extern int func(int a); + extern int func(long a); + main(){}"); + my $checkargsnil=!Compile("extern int func(); + extern int func(int a,int b,int c); + main(){}"); + $checknilargs=!Compile("extern int func(int a,int b,int c); + extern int func(); + main(){}"); + my $checkargsniletc=!Compile("extern int func(...); + extern int func(int a,int b,int c); + main(){}"); + $checkniletcargs=!Compile("extern int func(int a,int b,int c); + extern int func(...); + main(){}"); + + my $checkconst=!Compile("extern int func(const int * a); + extern int func(int * a); + main(){ }"); + + my $checksign=!Compile("extern int func(int a); + extern int func(unsigned int a); + main(){ }"); + + $checkreturnnil=!Compile("extern func(int a); + extern void func(int a); + main(){ }"); + + @types = sort grep(Compile("main(){$_ a;}"), + "void","int","long int","unsigned int","unsigned long int","long long int", + "long long","unsigned long long", + "unsigned long long int","float","long float", + "double","long double", + "char","unsigned char","short int","unsigned short int"); + + if(Compile("main(){flurfie a;}")) { @types = (); } + + $Verbose=0; + + # Attempt to remove duplicate types (if any) from type list + my ( $i, $j ); + if($checkargtypes) { + for ($i=0;$i<=$#types;$i++) { + for ($j=$i+1;$j<=$#types;$j++) { + next if $j==$i; + if(Compile("extern void func($types[$i]); + extern void func($types[$j]); main(){}")) { + print "Removing type $types[$j] because it equals $types[$i]\n"; + splice(@types,$j,1); + $j--; + } + } + } + } elsif($checkreturn) { + for ($i=0;$i<=$#types;$i++) { + for ($j=$i+1;$j<=$#types;$j++) { + next if $j==$i; + if(Compile("$types[$i] func(void); + extern $types[$j] func(void); main(){}")) { + print "Removing type $types[$j] because it equals $types[$i]\n"; + splice(@types,$j,1); + $j--; + } + } + } + } + $Verbose=1; + + print "Detect differing numbers of arguments: $checknumber\n"; + print "Detect differing return types: $checkreturn\n"; + print "Detect differing argument types if one is ...: $checketc\n"; + print "Detect differing numbers of arguments if ... is involved: $checknumberetc\n"; + print "Detect differing numbers of arguments if ... is involved #2: $checketcnumber\n"; + print "Detect differing argument types: $checkargtypes\n"; + print "Detect differing argument types if first has no defined args: $checkargsnil\n"; + print "Detect differing argument types if second has no defined args: $checknilargs\n"; + print "Detect differing argument types if first has only ...: $checkargsniletc\n"; + print "Detect differing argument types if second has only ...: $checkniletcargs\n"; + print "Detect differing argument types by constness: $checkconst\n"; + print "Detect differing argument types by signedness: $checksign\n"; + print "Detect differing return types if one is not defined: $checkreturnnil\n"; + print "Types known: ",join(",",@types),"\n"; + + } + + my($function,@headers) = @_; + @headers = CheckHSymbol($function,@headers); + return undef if !@headers; + + my $rettype = undef; + my @args = (); + my @validcount = (); + + # Can we check the return type without worry about arguements? + if($checkreturn and (!$checknilargs or !$checkniletcargs)) { + for (@types) { + if(ApplyHeaders("extern $_ $function(". ($checknilargs?"...":"").");main(){}",[@headers])) { + $rettype = $_; # Great, we found the return type. + last; + } + } + } + + if(!defined($rettype) and $checkreturnnil) { + die "No way to deduce function prototype in a rational amount of time"; + } + + my $numargs=-1; + my $varargs=0; + for (0..32) { + if(ApplyHeaders("main(){ $function(".join(",",("0") x $_).");}",@headers)) { + $numargs=$_; + if(ApplyHeaders("main(){ $function(".join(",",("0") x ($_+1)).");}",@headers)) { + $varargs=1; + } + last + } + } + + die "Unable to deduce number of arguments" if $numargs==-1; + + if($varargs) { $args[$numargs]="..."; } + + # OK, now we know how many arguments the thing takes. + + + if(@args>0 and !defined($rettype)) { + for (@types) { + if(defined(ApplyHeaders("extern $_ $function(".join(",",@args).");main(){}",[@headers]))) { + $rettype = $_; # Great, we found the return type. + last; + } + } + } + + print "Return type: $rettype\nArguments: ",join(",",@args),"\n"; + print "Valid number of arguments: $numargs\n"; + print "Accepts variable number of args: $varargs\n"; +} + + +#$Verbose=1; + +#print scalar(join("|",CheckHeader("sgtty.h"))),"\n"; +#print scalar(join("|",FindHeader(CheckHeader("sgtty.h")))),"\n"; +#print scalar(join("|",CheckSymbol("COLOR_PAIRS","curses.h","-lcurses","ncurses.h","-lncurses","ncurses/ncurses.h","ncurses/libncurses.a"))),"\n"; +#print scalar(join("|",GetNumericSymbol("PRIO_USER","sys/resource.h",""))),"\n"; + diff --git a/gnu/usr.bin/perl/cpan/Term-ReadKey/MANIFEST b/gnu/usr.bin/perl/cpan/Term-ReadKey/MANIFEST new file mode 100644 index 00000000000..b4c40774254 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/Term-ReadKey/MANIFEST @@ -0,0 +1,15 @@ +Configure.pm +MANIFEST +MANIFEST.SKIP +Makefile.PL +README +ReadKey.pm +ReadKey.xs +genchars.pl +ppport.h +example/test.pl +t/01_basic.t +t/02_terminal_functions.t +Changes +META.yml Module meta-data (added by MakeMaker) +META.json Module JSON meta-data (added by MakeMaker) diff --git a/gnu/usr.bin/perl/cpan/Term-ReadKey/MANIFEST.SKIP b/gnu/usr.bin/perl/cpan/Term-ReadKey/MANIFEST.SKIP new file mode 100644 index 00000000000..422a152da8d --- /dev/null +++ b/gnu/usr.bin/perl/cpan/Term-ReadKey/MANIFEST.SKIP @@ -0,0 +1,3 @@ +.gitignore +.travis.yml +.git diff --git a/gnu/usr.bin/perl/cpan/Term-ReadKey/META.json b/gnu/usr.bin/perl/cpan/Term-ReadKey/META.json new file mode 100644 index 00000000000..bcc2fdac4e9 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/Term-ReadKey/META.json @@ -0,0 +1,49 @@ +{ + "abstract" : "unknown", + "author" : [ + "unknown" + ], + "dynamic_config" : 1, + "generated_by" : "ExtUtils::MakeMaker version 6.98, CPAN::Meta::Converter version 2.142060", + "license" : [ + "perl_5" + ], + "meta-spec" : { + "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", + "version" : "2" + }, + "name" : "TermReadKey", + "no_index" : { + "directory" : [ + "t", + "inc" + ], + "file" : [ + "Configure.pm" + ], + "package" : [ + "Configure" + ] + }, + "prereqs" : { + "build" : { + "requires" : { + "ExtUtils::MakeMaker" : "0" + } + }, + "configure" : { + "requires" : { + "ExtUtils::MakeMaker" : "0" + } + } + }, + "release_status" : "stable", + "resources" : { + "repository" : { + "type" : "git", + "url" : "https://github.com/jonathanstowe/TermReadKey.git", + "web" : "https://github.com/jonathanstowe/TermReadKey" + } + }, + "version" : "2.33" +} diff --git a/gnu/usr.bin/perl/cpan/Term-ReadKey/META.yml b/gnu/usr.bin/perl/cpan/Term-ReadKey/META.yml new file mode 100644 index 00000000000..89dde468ca5 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/Term-ReadKey/META.yml @@ -0,0 +1,26 @@ +--- +abstract: unknown +author: + - unknown +build_requires: + ExtUtils::MakeMaker: '0' +configure_requires: + ExtUtils::MakeMaker: '0' +dynamic_config: 1 +generated_by: 'ExtUtils::MakeMaker version 6.98, CPAN::Meta::Converter version 2.142060' +license: perl +meta-spec: + url: http://module-build.sourceforge.net/META-spec-v1.4.html + version: '1.4' +name: TermReadKey +no_index: + directory: + - t + - inc + file: + - Configure.pm + package: + - Configure +resources: + repository: https://github.com/jonathanstowe/TermReadKey.git +version: '2.33' diff --git a/gnu/usr.bin/perl/cpan/Term-ReadKey/Makefile.PL b/gnu/usr.bin/perl/cpan/Term-ReadKey/Makefile.PL new file mode 100644 index 00000000000..4c97e22a897 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/Term-ReadKey/Makefile.PL @@ -0,0 +1,86 @@ + +use ExtUtils::MakeMaker; +use Carp; + +my $mm_version = $ExtUtils::MakeMaker::VERSION || $ExtUtils::MakeMaker::Version; +if( $mm_version < 3.5 ) { + croak("Sorry, but MakeMaker 3.5 or better is needed to build this package."); +} + +&WriteMakefile( + NAME => 'Term::ReadKey', + DISTNAME => 'TermReadKey', + LICENSE => 'perl', + META_MERGE => { + no_index => { + file => [qw(Configure.pm)], + package => [qw(Configure)], + }, + 'meta-spec' => { version => 2 }, + resources => { + repository => { + type => 'git', + url => 'https://github.com/jonathanstowe/TermReadKey.git', + web => 'https://github.com/jonathanstowe/TermReadKey', + }, + }, + }, + VERSION_FROM => 'ReadKey.pm', + XSPROTOARG => '-noprototypes', + PM => { "ReadKey.pm" => '$(INST_LIBDIR)/ReadKey.pm'}, + + 'dist' => { COMPRESS=>"gzip", SUFFIX=>"gz" }, + "test" => { + "TESTS" => "t/*.t" + } + +# Uncomment these to allow testing of sgtty under Linux. Not needed normally. +# INC => "-I/usr/include/bsd", +# LIBS => "-lbsd" +); + +sub MY::realclean { + my $self = shift; + $_ = $self->MM::realclean(); + s/\t/\trm -f cchars.h\n\t/; + $_; +} + +sub MY::top_targets { + my $self = shift; + $_ = $self->MM::top_targets(); + $_ .= " + +sgtty cchars.h: genchars.pl + \$(PERL) -I. -I\$(PERL_LIB) genchars.pl + +distcc: genchars.pl + \$(PERL) -I. -I\$(PERL_LIB) genchars.pl dist + +ReadKey.c: cchars.h + +"; + $_; + +} + +sub MY::test { + my $self = shift; + $_ = $self->MM::test(); + s#example/test.pl#-w example/test.pl#; + $_; +} + +sub MY::test_interactive +{ + return "Fooo"; +} + +sub MY::pure_site_install +{ + my $self = shift; + my $new = $self->MM::test(); + + $new .= "\n\t./register_module Your::Module"; + return $new; +} diff --git a/gnu/usr.bin/perl/cpan/Term-ReadKey/README b/gnu/usr.bin/perl/cpan/Term-ReadKey/README new file mode 100644 index 00000000000..8769c8d1da3 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/Term-ReadKey/README @@ -0,0 +1,145 @@ + Term::ReadKey 2.33 - Change terminal modes, and perform non-blocking reads. + + Copyright (C) 1994-1999 Kenneth Albanowski. + 2001-2015 Jonathan Stowe and others + +This package is dual licensed. You can either choose to license it under +the original terms which were: + + Unlimited distribution and/or modification is allowed as long as this + copyright notice remains intact. + +Or the standard Perl terms: + + This module is free software; you can redistribute it and/or modify it + under the terms of the Artistic License. For details, see the full + text of the license in the file "Artistic" that should have been provided + with the version of perl you are using. + + This program is distributed in the hope that it will be useful, but + without any warranty; without even the implied warranty of merchantability + or fitness for a particular purpose. + + + +This module, ReadKey, provides ioctl control for terminals and Win32 +consoles so the input modes can be changed (thus allowing reads of a single +character at a time), and also provides non-blocking reads of stdin, as well +as several other terminal related features, including retrieval/modification +of the screen size, and retrieval/modification of the control characters. +Installation requires MakeMaker 3.5 or higher (MakeMaker 3.7 is included +with perl 5.001, so now is a good time to upgrade if you haven't already.) + +To install, unpack somewhere, type "perl Makefile.PL", and then "make test". +If the compilation and the tests are successful, then change to root and run +"make install". + +As of 2.17 the interactive test has been removed as the default for the +convenience of automated installers, CPAN-Testers and so on. The non +interactive tests whilst confirming that the module has built correctly +and has a good chance of working correctly cannot determine whether the +effect as observed on the screen is correct so you might want to run: + + perl -Mblib example/test.pl interactive + +before you run 'make install'. + +Also from 2.17 this module has to provide its own support for compilers +that can't take function prototypes as with Perl 5.8.0 this last vestige +of support for non-ANSI compilers will disappear. The requirement for +an ANSI C compiler has been present since Perl 5.005 so it is likely that +at some point in the future this module will follow that requirement too. +If you have any difficulties with older Perl's please contact the maintainer. + +The module has support for Win32 since version 2.10. Version 2.17 has been +tested with ActivePerl build 623 and Visual Studio 6 and found to work +as expected, but do not be surprised if it fails with another compiler +or distribution. There are some limitations, with the ReadLine call +being unavailable, and ReadKey possibly generating bad results if you +are reading from multiple consoles, and key repeat is used. For Win32 +users without a C compiler there is a precompiled version of this module +available as a package for ActivePerl, it is probably a few versions +behind the latest release but has been reported to work well. + +VERY IMPORTANT: In 2.00, the ReadKey/ReadLine arguments changed. Now, if +you want a call that is non-blocking and returns immediately if no +character is waiting, please call it with -1, instead of 1. Positive +arguments now indicate a timeout, so 1 would wait a second before timing +out. + +As older versions will accept -1, it is reccomended to change all code +that uses ReadMode. + + +The terminal mode function is controlled by the "ReadMode" function, which +takes a single numeric argument, and an optional filehandle. This argument +should be one of the following: + + 0: (Reset) Restore original settings. + + 1: (Cooked) Change to what is commonly the default mode, echo on, + buffered, signals enabled, Xon/Xoff possibly enabled, and 8-bit mode + possibly disabled. + + 2: (Cooked-Invisible) Same as 1, just with echo off. Nice for reading + passwords. + + 3: (CBreak) Echo off, unbuffered, signals enabled, Xon/Xoff possibly + enabled, and 8-bit mode possibly enabled. + + 4: (Raw) Echo off, unbuffered, signals disabled, Xon/Xoff disabled, + and 8-bit mode possibly disabled. + + 5: (Really-Raw) Echo off, unbuffered, signals disabled, Xon/Xoff + disabled, 8-bit mode enabled if parity permits, and CR to CR/LF + translation turned off. + +If you just need to read a key at a time, then modes 3 or 4 are probably +sufficient. Mode 4 is a tad more flexible, but needs a bit more work to +control. If you use ReadMode 3, then you should install a SIGINT or END +handler to reset the terminal (via ReadMode 0) if the user aborts the +program via ^C. (For any mode, an END handler consisting of "ReadMode 0" is +actually a good idea.) + +Non-blocking support is provided via the ReadKey and ReadLine functions. If +they are passed no argument, or an argument of zero, they will act like a +normal getc(STDIN) or scalar(<STDIN>). If they are passed a negative +argument, then they will immediatly return undef if no input is present. If +passed a positive argument, then they will wait until that time in seconds +has passed before returning undef. In most situations, you will probably +want to use "ReadKey -1". + +Note that a non-blocking ReadLine probably won't do what you expect, +although it is perfectly predictable, and that the ReadMode will have to be +1 or 0 for it to make sense at all. + +A routine is also provided to get the current terminal size, +"GetTerminalSize". This will either return a four value array containing the +width and height of the screen in characters and then in pixels, or nothing +( if the OS can't return that info). SetTerminalSize allows the stored +settings to be modified. Note that this does _not_ change the physical size +of the screen, it will only change the size reported by GetTerminalSize, and +other programs that check the terminal size in the same manner. + +GetControlChars returns a hash containing all of the valid control +characters, such as ("INTERRUPT" => "\x3", etc.). SetControlChars takes an +array (or a hash) as a parameter that should consist of similar name/value +pairs and will modify the control character settings. + +Note that it is entirely possible that there are portability problems with +the routines in ReadKey.xs. If you find any problems, including compilation +failures, or control characters not supported by Set/GetControlChars, +_please_ tell me about them, by mailing the maintainer at jns@gellyfish.co.uk, + or lastly contacting perl5-porters@perl.org. Any problems +will get fixed if at all possible, but that's not going to happen if I don't +know about them. + +The code is available at https://github.com/jonathanstowe/TermReadKey so +as ever patches are kindly welcomed, especially for platforms such as +Windows that I am unable to test on. + +Oh, you may also be interested in the Configure.pm module. It provides tools +to make porting stuff easier -- calling the compiler, finding headers, etc. +It contains documentation inside it, and you are welcome to use it in your +own modules. If you make use of it, I'd be grateful for a message sent to +the above address. diff --git a/gnu/usr.bin/perl/cpan/Term-ReadKey/ReadKey.pm b/gnu/usr.bin/perl/cpan/Term-ReadKey/ReadKey.pm new file mode 100644 index 00000000000..a2642e130cc --- /dev/null +++ b/gnu/usr.bin/perl/cpan/Term-ReadKey/ReadKey.pm @@ -0,0 +1,654 @@ +package Term::ReadKey; + +=head1 NAME + +Term::ReadKey - A perl module for simple terminal control + +=head1 SYNOPSIS + + use Term::ReadKey; + ReadMode 4; # Turn off controls keys + while (not defined ($key = ReadKey(-1))) { + # No key yet + } + print "Get key $key\n"; + ReadMode 0; # Reset tty mode before exiting + +=head1 DESCRIPTION + +Term::ReadKey is a compiled perl module dedicated to providing simple +control over terminal driver modes (cbreak, raw, cooked, etc.,) support for +non-blocking reads, if the architecture allows, and some generalized handy +functions for working with terminals. One of the main goals is to have the +functions as portable as possible, so you can just plug in "use +Term::ReadKey" on any architecture and have a good likelihood of it working. + +Version 2.30.01: +Added handling of arrows, page up/down, home/end, insert/delete keys +under Win32. These keys emit xterm-compatible sequences. +Works with Term::ReadLine::Perl. + +=over 4 + +=item ReadMode MODE [, Filehandle] + +Takes an integer argument or a string synonym (case insensitive), which +can currently be one of the following values: + + INT SYNONYM DESCRIPTION + + 0 'restore' Restore original settings. + + 1 'normal' Change to what is commonly the default mode, + echo on, buffered, signals enabled, Xon/Xoff + possibly enabled, and 8-bit mode possibly disabled. + + 2 'noecho' Same as 1, just with echo off. Nice for + reading passwords. + + 3 'cbreak' Echo off, unbuffered, signals enabled, Xon/Xoff + possibly enabled, and 8-bit mode possibly enabled. + + 4 'raw' Echo off, unbuffered, signals disabled, Xon/Xoff + disabled, and 8-bit mode possibly disabled. + + 5 'ultra-raw' Echo off, unbuffered, signals disabled, Xon/Xoff + disabled, 8-bit mode enabled if parity permits, + and CR to CR/LF translation turned off. + + +These functions are automatically applied to the STDIN handle if no +other handle is supplied. Modes 0 and 5 have some special properties +worth mentioning: not only will mode 0 restore original settings, but it +cause the next ReadMode call to save a new set of default settings. Mode +5 is similar to mode 4, except no CR/LF translation is performed, and if +possible, parity will be disabled (only if not being used by the terminal, +however. It is no different from mode 4 under Windows.) + +If you just need to read a key at a time, then modes 3 or 4 are probably +sufficient. Mode 4 is a tad more flexible, but needs a bit more work to +control. If you use ReadMode 3, then you should install a SIGINT or END +handler to reset the terminal (via ReadMode 0) if the user aborts the +program via C<^C>. (For any mode, an END handler consisting of "ReadMode 0" +is actually a good idea.) + +If you are executing another program that may be changing the terminal mode, +you will either want to say + + ReadMode 1; # same as ReadMode 'normal' + system('someprogram'); + ReadMode 1; + +which resets the settings after the program has run, or: + + $somemode=1; + ReadMode 0; # same as ReadMode 'restore' + system('someprogram'); + ReadMode 1; + +which records any changes the program may have made, before resetting the +mode. + +=item ReadKey MODE [, Filehandle] + +Takes an integer argument, which can currently be one of the following +values: + + 0 Perform a normal read using getc + -1 Perform a non-blocked read + >0 Perform a timed read + +If the filehandle is not supplied, it will default to STDIN. If there is +nothing waiting in the buffer during a non-blocked read, then undef will be +returned. In most situations, you will probably want to use C<ReadKey -1>. + +I<NOTE> that if the OS does not provide any known mechanism for non-blocking +reads, then a C<ReadKey -1> can die with a fatal error. This will hopefully +not be common. + +If MODE is greater then zero, then ReadKey will use it as a timeout value in +seconds (fractional seconds are allowed), and won't return C<undef> until +that time expires. + +I<NOTE>, again, that some OS's may not support this timeout behaviour. + +If MODE is less then zero, then this is treated as a timeout +of zero, and thus will return immediately if no character is waiting. A MODE +of zero, however, will act like a normal getc. + +I<NOTE>, there are currently some limitations with this call under Windows. +It may be possible that non-blocking reads will fail when reading repeating +keys from more then one console. + + +=item ReadLine MODE [, Filehandle] + +Takes an integer argument, which can currently be one of the following +values: + + 0 Perform a normal read using scalar(<FileHandle>) + -1 Perform a non-blocked read + >0 Perform a timed read + +If there is nothing waiting in the buffer during a non-blocked read, then +undef will be returned. + +I<NOTE>, that if the OS does not provide any known mechanism for +non-blocking reads, then a C<ReadLine 1> can die with a fatal +error. This will hopefully not be common. + +I<NOTE> that a non-blocking test is only performed for the first character +in the line, not the entire line. This call will probably B<not> do what +you assume, especially with C<ReadMode> MODE values higher then 1. For +example, pressing Space and then Backspace would appear to leave you +where you started, but any timeouts would now be suspended. + +B<This call is currently not available under Windows>. + +=item GetTerminalSize [Filehandle] + +Returns either an empty array if this operation is unsupported, or a four +element array containing: the width of the terminal in characters, the +height of the terminal in character, the width in pixels, and the height in +pixels. (The pixel size will only be valid in some environments.) + +I<NOTE>, under Windows, this function must be called with an B<output> +filehandle, such as C<STDOUT>, or a handle opened to C<CONOUT$>. + +=item SetTerminalSize WIDTH,HEIGHT,XPIX,YPIX [, Filehandle] + +Return -1 on failure, 0 otherwise. + +I<NOTE> that this terminal size is only for B<informative> value, and +changing the size via this mechanism will B<not> change the size of +the screen. For example, XTerm uses a call like this when +it resizes the screen. If any of the new measurements vary from the old, the +OS will probably send a SIGWINCH signal to anything reading that tty or pty. + +B<This call does not work under Windows>. + +=item GetSpeeds [, Filehandle] + +Returns either an empty array if the operation is unsupported, or a two +value array containing the terminal in and out speeds, in B<decimal>. E.g, +an in speed of 9600 baud and an out speed of 4800 baud would be returned as +(9600,4800). Note that currently the in and out speeds will always be +identical in some OS's. + +B<No speeds are reported under Windows>. + +=item GetControlChars [, Filehandle] + +Returns an array containing key/value pairs suitable for a hash. The pairs +consist of a key, the name of the control character/signal, and the value +of that character, as a single character. + +B<This call does nothing under Windows>. + +Each key will be an entry from the following list: + + DISCARD + DSUSPEND + EOF + EOL + EOL2 + ERASE + ERASEWORD + INTERRUPT + KILL + MIN + QUIT + QUOTENEXT + REPRINT + START + STATUS + STOP + SUSPEND + SWITCH + TIME + +Thus, the following will always return the current interrupt character, +regardless of platform. + + %keys = GetControlChars; + $int = $keys{INTERRUPT}; + +=item SetControlChars [, Filehandle] + +Takes an array containing key/value pairs, as a hash will produce. The pairs +should consist of a key that is the name of a legal control +character/signal, and the value should be either a single character, or a +number in the range 0-255. SetControlChars will die with a runtime error if +an invalid character name is passed or there is an error changing the +settings. The list of valid names is easily available via + + %cchars = GetControlChars(); + @cnames = keys %cchars; + +B<This call does nothing under Windows>. + +=back + +=head1 AUTHOR + +Kenneth Albanowski <kjahds@kjahds.com> + +Currently maintained by Jonathan Stowe <jns@gellyfish.co.uk> + +=head1 SUPPORT + +The code is maintained at + + https://github.com/jonathanstowe/TermReadKey + +Please feel free to fork and suggest patches. + + +=head1 LICENSE + +Prior to the 2.31 release the license statement was: + + Copyright (C) 1994-1999 Kenneth Albanowski. + 2001-2005 Jonathan Stowe and others + + Unlimited distribution and/or modification is allowed as long as this + copyright notice remains intact. + +And was only stated in the README file. + +Because I believe the original author's intent was to be more open than the +other commonly used licenses I would like to leave that in place. However if +you or your lawyers require something with some more words you can optionally +choose to license this under the standard Perl license: + + This module is free software; you can redistribute it and/or modify it + under the terms of the Artistic License. For details, see the full + text of the license in the file "Artistic" that should have been provided + with the version of perl you are using. + + This program is distributed in the hope that it will be useful, but + without any warranty; without even the implied warranty of merchantability + or fitness for a particular purpose. + + +=cut + +use vars qw($VERSION); + +$VERSION = '2.33'; + +require Exporter; +require AutoLoader; +require DynaLoader; +use Carp; + +@ISA = qw(Exporter AutoLoader DynaLoader); + +# Items to export into callers namespace by default +# (move infrequently used names to @EXPORT_OK below) + +@EXPORT = qw( + ReadKey + ReadMode + ReadLine + GetTerminalSize + SetTerminalSize + GetSpeed + GetControlChars + SetControlChars +); + +@EXPORT_OK = qw(); + +bootstrap Term::ReadKey; + +# Preloaded methods go here. Autoload methods go after __END__, and are +# processed by the autosplit program. + +# Should we use LINES and COLUMNS to try and get the terminal size? +# Change this to zero if you have systems where these are commonly +# set to erroneous values. (But if either are near zero, they won't be +# used anyhow.) + +$UseEnv = 1; + +$CurrentMode = 0; + +%modes = ( # lowercase is canonical + original => 0, + restore => 0, + normal => 1, + noecho => 2, + cbreak => 3, + raw => 4, + 'ultra-raw' => 5 +); + +sub ReadMode +{ + my ($mode) = $modes{ lc $_[0] }; # lowercase is canonical + my ($fh) = normalizehandle( ( @_ > 1 ? $_[1] : \*STDIN ) ); + if ( defined($mode) ) { $CurrentMode = $mode } + elsif ( $_[0] =~ /^\d/ ) { $CurrentMode = $_[0] } + else { croak("Unknown terminal mode `$_[0]'"); } + SetReadMode($CurrentMode, $fh); +} + +sub normalizehandle +{ + my ($file) = @_; + + # print "Handle = $file\n"; + if ( ref($file) ) { return $file; } # Reference is fine + + # if($file =~ /^\*/) { return $file; } # Type glob is good + if ( ref( \$file ) eq 'GLOB' ) { return $file; } # Glob is good + + # print "Caller = ",(caller(1))[0],"\n"; + return \*{ ( ( caller(1) )[0] ) . "::$file" }; +} + +sub GetTerminalSize +{ + my ($file) = normalizehandle( ( @_ > 1 ? $_[1] : \*STDOUT ) ); + my (@results) = (); + my (@fail); + + if ( &termsizeoptions() & 1 ) # VIO + { + @results = GetTermSizeVIO($file); + push( @fail, "VIOGetMode call" ); + } + elsif ( &termsizeoptions() & 2 ) # GWINSZ + { + @results = GetTermSizeGWINSZ($file); + push( @fail, "TIOCGWINSZ ioctl" ); + } + elsif ( &termsizeoptions() & 4 ) # GSIZE + { + @results = GetTermSizeGSIZE($file); + push( @fail, "TIOCGSIZE ioctl" ); + } + elsif ( &termsizeoptions() & 8 ) # WIN32 + { + @results = GetTermSizeWin32($file); + push( @fail, "Win32 GetConsoleScreenBufferInfo call" ); + } + else + { + @results = (); + } + + if ( @results < 4 and $UseEnv ) + { + my ($C) = defined( $ENV{COLUMNS} ) ? $ENV{COLUMNS} : 0; + my ($L) = defined( $ENV{LINES} ) ? $ENV{LINES} : 0; + if ( ( $C >= 2 ) and ( $L >= 2 ) ) + { + @results = ( $C + 0, $L + 0, 0, 0 ); + } + push( @fail, "COLUMNS and LINES environment variables" ); + } + + if ( @results < 4 && $^O ne 'MSWin32') + { + my ($prog) = "resize"; + + # Workaround for Solaris path silliness + if ( -f "/usr/openwin/bin/resize" ) { + $prog = "/usr/openwin/bin/resize"; + } + + my ($resize) = scalar(`$prog 2>/dev/null`); + if ( + defined $resize + and ( $resize =~ /COLUMNS\s*=\s*(\d+)/ + or $resize =~ /setenv\s+COLUMNS\s+'?(\d+)/ ) + ) + { + $results[0] = $1; + if ( $resize =~ /LINES\s*=\s*(\d+)/ + or $resize =~ /setenv\s+LINES\s+'?(\d+)/ ) + { + $results[1] = $1; + @results[ 2, 3 ] = ( 0, 0 ); + } + else + { + @results = (); + } + } + else + { + @results = (); + } + push( @fail, "resize program" ); + } + + if ( @results < 4 && $^O ne 'MSWin32' ) + { + my ($prog) = "stty size"; + + my ($stty) = scalar(`$prog 2>/dev/null`); + if ( + defined $stty + and ( $stty =~ /(\d+) (\d+)/ ) + ) + { + $results[0] = $2; + $results[1] = $1; + @results[ 2, 3 ] = ( 0, 0 ); + } + else + { + @results = (); + } + push( @fail, "stty program" ); + } + + if ( @results != 4 ) + { + warn "Unable to get Terminal Size." + . join( "", map( " The $_ didn't work.", @fail ) ); + return undef; + } + + @results; +} + +if ( &blockoptions() & 1 ) # Use nodelay +{ + if ( &blockoptions() & 2 ) #poll + { + eval <<'DONE'; + sub ReadKey { + my($File) = normalizehandle((@_>1?$_[1]:\*STDIN)); + if (defined $_[0] && $_[0] > 0) { + if ($_[0]) { + return undef if &pollfile($File,$_[0]) == 0; + } + } + if (defined $_[0] && $_[0] < 0) { + &setnodelay($File,1); + } + my ($value) = getc $File; + if (defined $_[0] && $_[0] < 0) { + &setnodelay($File,0); + } + $value; + } + sub ReadLine { + my($File) = normalizehandle((@_>1?$_[1]:\*STDIN)); + + if (defined $_[0] && $_[0] > 0) { + if ($_[0]) { + return undef if &pollfile($File,$_[0]) == 0; + } + } + if (defined $_[0] && $_[0] < 0) { + &setnodelay($File,1) + }; + my ($value) = scalar(<$File>); + if ( defined $_[0] && $_[0]<0 ) { + &setnodelay($File,0) + }; + $value; + } +DONE + } + elsif ( &blockoptions() & 4 ) #select + { + eval <<'DONE'; + sub ReadKey { + my($File) = normalizehandle((@_>1?$_[1]:\*STDIN)); + if(defined $_[0] && $_[0]>0) { + if($_[0]) {return undef if &selectfile($File,$_[0])==0} + } + if(defined $_[0] && $_[0]<0) {&setnodelay($File,1);} + my($value) = getc $File; + if(defined $_[0] && $_[0]<0) {&setnodelay($File,0);} + $value; + } + sub ReadLine { + my($File) = normalizehandle((@_>1?$_[1]:\*STDIN)); + if(defined $_[0] && $_[0]>0) { + if($_[0]) {return undef if &selectfile($File,$_[0])==0} + } + if(defined $_[0] && $_[0]<0) {&setnodelay($File,1)}; + my($value)=scalar(<$File>); + if(defined $_[0] && $_[0]<0) {&setnodelay($File,0)}; + $value; + } +DONE + } + else + { #nothing + eval <<'DONE'; + sub ReadKey { + my($File) = normalizehandle((@_>1?$_[1]:\*STDIN)); + if(defined $_[0] && $_[0]>0) { + # Nothing better seems to exist, so I just use time-of-day + # to timeout the read. This isn't very exact, though. + $starttime=time; + $endtime=$starttime+$_[0]; + &setnodelay($File,1); + my($value)=undef; + while(time<$endtime) { # This won't catch wraparound! + $value = getc $File; + last if defined($value); + } + &setnodelay($File,0); + return $value; + } + if(defined $_[0] && $_[0]<0) {&setnodelay($File,1);} + my($value) = getc $File; + if(defined $_[0] && $_[0]<0) {&setnodelay($File,0);} + $value; + } + sub ReadLine { + my($File) = normalizehandle((@_>1?$_[1]:\*STDIN)); + if(defined $_[0] && $_[0]>0) { + # Nothing better seems to exist, so I just use time-of-day + # to timeout the read. This isn't very exact, though. + $starttime=time; + $endtime=$starttime+$_[0]; + &setnodelay($File,1); + my($value)=undef; + while(time<$endtime) { # This won't catch wraparound! + $value = scalar(<$File>); + last if defined($value); + } + &setnodelay($File,0); + return $value; + } + if(defined $_[0] && $_[0]<0) {&setnodelay($File,1)}; + my($value)=scalar(<$File>); + if(defined $_[0] && $_[0]<0) {&setnodelay($File,0)}; + $value; + } +DONE + } +} +elsif ( &blockoptions() & 2 ) # Use poll +{ + eval <<'DONE'; + sub ReadKey { + my($File) = normalizehandle((@_>1?$_[1]:\*STDIN)); + if(defined $_[0] && $_[0] != 0) { + return undef if &pollfile($File,$_[0]) == 0 + } + getc $File; + } + sub ReadLine { + my($File) = normalizehandle((@_>1?$_[1]:\*STDIN)); + if(defined $_[0] && $_[0]!=0) { + return undef if &pollfile($File,$_[0]) == 0; + } + scalar(<$File>); + } +DONE +} +elsif ( &blockoptions() & 4 ) # Use select +{ + eval <<'DONE'; + sub ReadKey { + my($File) = normalizehandle((@_>1?$_[1]:\*STDIN)); + if(defined $_[0] && $_[0] !=0 ) { + return undef if &selectfile($File,$_[0])==0 + } + getc $File; + } + sub ReadLine { + my($File) = normalizehandle((@_>1?$_[1]:\*STDIN)); + if(defined $_[0] && $_[0] != 0) { + return undef if &selectfile($File,$_[0]) == 0; + } + scalar(<$File>); + } +DONE +} +elsif ( &blockoptions() & 8 ) # Use Win32 +{ + eval <<'DONE'; + sub ReadKey { + my($File) = normalizehandle((@_>1?$_[1]:\*STDIN)); + if ($_[0] || $CurrentMode >= 3) { + Win32PeekChar($File, $_[0]); + } else { + getc $File; + } + #if ($_[0]!=0) {return undef if !Win32PeekChar($File, $_[0])}; + #getc $File; + } + sub ReadLine { + my($File) = normalizehandle((@_>1?$_[1]:\*STDIN)); + #if ($_[0]!=0) {return undef if !Win32PeekChar($File, $_[0])}; + #scalar(<$File>); + if($_[0]) + {croak("Non-blocking ReadLine is not supported on this architecture")} + scalar(<$File>); + } +DONE +} +else +{ + eval <<'DONE'; + sub ReadKey { + my($File) = normalizehandle((@_>1?$_[1]:\*STDIN)); + if($_[0]) + {croak("Non-blocking ReadKey is not supported on this architecture")} + getc $File; + } + sub ReadLine { + my($File) = normalizehandle((@_>1?$_[1]:\*STDIN)); + if($_[0]) + {croak("Non-blocking ReadLine is not supported on this architecture")} + scalar(<$File>); + } +DONE +} + +package Term::ReadKey; # return to package ReadKey so AutoSplit is happy +1; + +__END__; diff --git a/gnu/usr.bin/perl/cpan/Term-ReadKey/ReadKey.xs b/gnu/usr.bin/perl/cpan/Term-ReadKey/ReadKey.xs new file mode 100644 index 00000000000..29c83b9ad4b --- /dev/null +++ b/gnu/usr.bin/perl/cpan/Term-ReadKey/ReadKey.xs @@ -0,0 +1,1923 @@ +/* -*-C-*- */ + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" +#include "ppport.h" + +#define InputStream PerlIO * + +/******************************************************************* + + Copyright (C) 1994,1995,1996,1997 Kenneth Albanowski. Unlimited + distribution and/or modification is allowed as long as this copyright + notice remains intact. + + Written by Kenneth Albanowski on Thu Oct 6 11:42:20 EDT 1994 + Contact at kjahds@kjahds.com or CIS:70705,126 + + Maintained by Jonathan Stowe <jns@gellyfish.com> + + $Id: ReadKey.xs,v 1.1.1.1 2016/05/07 16:03:09 espie Exp $ + + Version 2.21, Sun Jul 28 12:57:56 BST 2002 + Fix to improve the chances of automated testing succeeding + + Version 2.20, Tue May 21 07:52:47 BST 2002 + Patch from Autrijus Tang fixing Win32 Breakage with bleadperl + + Version 2.19, Thu Mar 21 07:25:31 GMT 2002 + Added check for definedness of $_[0] in comparisons in ReadKey, ReadLine + after reports of warnings. + + Version 2.18, Sun Feb 10 13:06:57 GMT 2002 + Altered prototyping style after reports of compile failures on + Windows. + + Version 2.17, Fri Jan 25 06:58:47 GMT 2002 + The '_' macro for non-ANSI compatibility was removed in 5.7.2 + + Version 2.16, Thu Nov 29 21:19:03 GMT 2001 + It appears that the genchars.pl bit of the patch didnt apply + Applied the new ppport.h from Devel::PPPort + + Version 2.15, Sun Nov 4 15:02:37 GMT 2001 (jns) + Applied the patch in + http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2001-01/msg01588.html + for PerlIO compatibility. + + Version 2.14, Sun Mar 28 23:26:13 EST 1999 + ppport.h 1.007 fixed for 5.005_55. + + Version 2.13, Wed Mar 24 20:46:06 EST 1999 + Adapted to ppport.h 1.006. + + Version 2.12, Wed Jan 7 10:33:11 EST 1998 + Slightly modified test and error reporting for Win32. + + Version 2.11, Sun Dec 14 00:39:12 EST 1997 + First attempt at Win32 support. + + Version 2.10, skipped + + Version 2.09, Tue Oct 7 13:07:43 EDT 1997 + Grr. Added explicit detection of sys/poll.h and poll.h. + + Version 2.08, Mon Oct 6 16:07:44 EDT 1997 + Changed poll.h to sys/poll.h. + + Version 2.07, Sun Jan 26 19:11:56 EST 1997 + Added $VERSION to .pm. + + Version 2.06, Tue Nov 26 01:47:09 EST 1996 + Added PERLIO support and removed duplicate declaration in .pm. + + Version 2.05, Tue Mar 12 19:08:33 EST 1996 + Changed poll support so it works. Cleaned up .pm a little. + + Version 2.04, Tue Oct 10 05:35:48 EDT 1995 + Whoops. Changed GetTermSize back so that GSIZE code won't be + compiled if GWINSZ is being used. Also took ts_xxx and ts_yyy + out of GSIZE. + + Version 2.03, Thu Sep 21 21:53:16 EDT 1995 + Fixed up debugging info in Readkey.pm, and changed TermSizeVIO + to use _scrsize(). Hopefully this is GO for both Solaris and OS/2. + + Version 2.02, Mon Sep 18 22:17:57 EDT 1995 + Workaround for Solaris bug wasn't sufficient. Modularlized + GetTermSize into perl code, and added support for the + `resize` executable. Hard coded path for Solaris machines. + + Version 2.01, Wed Sep 13 22:22:23 EDT 1995 + Change error reporting around in getscreensize so that if + an ioctl fails but getenv succeeds, no warning will be + printed. This is an attempt to work around a Solaris bug where + TIOCGWINSZ fails in telnet sessions. + + Version 2.00, Mon Sep 4 06:37:24 EDT 1995 + Added timeouts to select/poll, added USE_STDIO_PTR support + (required for recent perl revisions), and fixed up compilation + under OS/2. + + Version 1.99, Fri Aug 11 20:18:11 EDT 1995 + Add file handles to ReadMode. + + Version 1.97, Mon Apr 10 21:41:52 EDT 1995 + Changed mode 5 to disable UC & delays. Added more ECHO flags. + Tested termio[s] & sgtty. + Added termoptions so test.pl can give more info. + + Version 1.96, + Mucked with filehandle selection in ReadKey.pm. + + Version 1.95, + Cleaning up for distribution. + + Version 1.94, + Dealt with get/settermsize sillyness. + + Version 1.91, Sat Mar 11 23:47:04 EST 1995: + Andy's patches, and a bit of termsize finesse. + + Version 1.9, Thu Mar 9 14:11:49 EST 1995: + Modifying for portability. Prototypes, singed chars, etc. + + Version 1.8, Mon Jan 9 23:18:14 EST 1995: + Added use of Configure.pm. No changes to ReadKey. + + Version 1.7, Fri Dec 16 13:48:14 EST 1994: + Getting closer to release. Added new readmode 2. Had to bump up other + modes, unfortunately. This is the _last_ time I do that. If I have to + bump up the modes again, I'm switching to a different scheme. + + Version 1.6, Wed Dec 14 17:36:59 EST 1994: + Completly reorganized the control-char support (twice!) so that + it is automatically ported by the preproccessor for termio[s], or + by an included script for sgtty. Logical defaults for sgtty are included + too. Added Sun TermSize support. (Hope I got it right.) + + Version 1.5, Fri Dec 9 16:07:49 EST 1994: + Added SetTermSize, GetSpeeds, Get/SetControlChars, PerlIO support. + + Version 1.01, Thu Oct 20 23:32:39 EDT 1994: + Added Select_fd_set_t casts to select() call. + + Version 1.0: First "real" release. Everything seems cool. + + +*******************************************************************/ + +/*** + + Things to do: + + Make sure the GetSpeed function is doing it's best to separate ispeed + from ospeed. + + Separate the stty stuff from ReadMode, so that stty -a can be easily + used, among other things. + +***/ + + + +/* Using these defines, you can elide anything you know + won't work properly */ + +/* Methods of doing non-blocking reads */ + +/*#define DONT_USE_SELECT*/ +/*#define DONT_USE_POLL*/ +/*#define DONT_USE_NODELAY*/ + + +/* Terminal I/O packages */ + +/*#define DONT_USE_TERMIOS*/ +/*#define DONT_USE_TERMIO*/ +/*#define DONT_USE_SGTTY*/ + +/* IOCTLs that can be used for GetTerminalSize */ + +/*#define DONT_USE_GWINSZ*/ +/*#define DONT_USE_GSIZE*/ + +/* IOCTLs that can be used for SetTerminalSize */ + +/*#define DONT_USE_SWINSZ*/ +/*#define DONT_USE_SSIZE*/ + + +/* This bit is for OS/2 */ + +#ifdef OS2 +# define I_FCNTL +# define HAS_FCNTL + +# define O_NODELAY O_NDELAY + +# define DONT_USE_SELECT +# define DONT_USE_POLL + +# define DONT_USE_TERMIOS +# define DONT_USE_SGTTY +# define I_TERMIO +# define CC_TERMIO + +/* This flag should be off in the lflags when we enable termio mode */ +# define TRK_IDEFAULT IDEFAULT + +# define INCL_SUB +# define INCL_DOS + +# include <os2.h> +# include <stdlib.h> + +# define VIOMODE +#else + /* no os2 */ +#endif + +/* This bit is for Windows 95/NT */ + +#ifdef WIN32 +# define DONT_USE_TERMIO +# define DONT_USE_TERMIOS +# define DONT_USE_SGTTY +# define DONT_USE_POLL +# define DONT_USE_SELECT +# define DONT_USE_NODELAY +# define USE_WIN32 +# include <io.h> +# if defined(_get_osfhandle) && (PERL_VERSION == 4) && (PERL_SUBVERSION < 5) +# undef _get_osfhandle +# if defined(_MSC_VER) +# define level _cnt +# endif +# endif +#endif + +/* This bit for NeXT */ + +#ifdef _NEXT_SOURCE + /* fcntl with O_NDELAY (FNDELAY, actually) is broken on NeXT */ +# define DONT_USE_NODELAY +#endif + +#if !defined(DONT_USE_NODELAY) +# ifdef HAS_FCNTL +# define Have_nodelay +# ifdef I_FCNTL +# include <fcntl.h> +# endif +# ifdef I_SYS_FILE +# include <sys/file.h> +# endif +# ifdef I_UNISTD +# include <unistd.h> +# endif + +/* If any other headers are needed for fcntl or O_NODELAY, they need to get + included right here */ + +# if !defined(O_NODELAY) +# if !defined(FNDELAY) +# undef Have_nodelay +# else +# define O_NODELAY FNDELAY +# endif +# else +# define O_NODELAY O_NDELAY +# endif +# endif +#endif + +#if !defined(DONT_USE_SELECT) +# ifdef HAS_SELECT +# ifdef I_SYS_SELECT +# include <sys/select.h> +# endif + +/* If any other headers are likely to be needed for select, they need to be + included right here */ + +# define Have_select +# endif +#endif + +#if !defined(DONT_USE_POLL) +# ifdef HAS_POLL +# ifdef HAVE_POLL_H +# include <poll.h> +# define Have_poll +# endif +# ifdef HAVE_SYS_POLL_H +# include <sys/poll.h> +# define Have_poll +# endif +# endif +#endif + +#ifdef DONT_USE_TERMIOS +# ifdef I_TERMIOS +# undef I_TERMIOS +# endif +#endif +#ifdef DONT_USE_TERMIO +# ifdef I_TERMIO +# undef I_TERMIO +# endif +#endif +#ifdef DONT_USE_SGTTY +# ifdef I_SGTTY +# undef I_SGTTY +# endif +#endif + +/* Pre-POSIX SVR3 systems sometimes define struct winsize in + sys/ptem.h. However, sys/ptem.h needs a type mblk_t (?) which + is defined in <sys/stream.h>. + No, Configure (dist3.051) doesn't know how to check for this. +*/ +#ifdef I_SYS_STREAM +# include <sys/stream.h> +#endif +#ifdef I_SYS_PTEM +# include <sys/ptem.h> +#endif + +#ifdef I_TERMIOS +# include <termios.h> +#else +# ifdef I_TERMIO +# include <termio.h> +# else +# ifdef I_SGTTY +# include <sgtty.h> +# endif +# endif +#endif + +#ifdef I_TERMIOS +# define CC_TERMIOS +#else +# ifdef I_TERMIO +# define CC_TERMIO +# else +# ifdef I_SGTTY +# define CC_SGTTY +# endif +# endif +#endif + +#ifndef TRK_IDEFAULT +/* This flag should be off in the lflags when we enable termio mode */ +# define TRK_IDEFAULT 0 +#endif + +/* Fix up the disappearance of the '_' macro in Perl 5.7.2 */ + +#ifndef _ +# ifdef CAN_PROTOTYPE +# define _(args) args +# else +# define _(args) () +# endif +#endif + +#define DisableFlush (1) /* Should flushing mode changes be enabled? + I think not for now. */ + + +#define STDIN PerlIO_stdin() + +#include "cchars.h" + + +int GetTermSizeVIO _((PerlIO * file, + int * retwidth, int * retheight, + int * xpix, int * ypix)); + +int GetTermSizeGWINSZ _((PerlIO * file, + int * retwidth, int * retheight, + int * xpix, int * ypix)); + +int GetTermSizeGSIZE _((PerlIO * file, + int * retwidth, int * retheight, + int * xpix, int * ypix)); + +int GetTermSizeWin32 _((PerlIO * file, + int * retwidth, int * retheight, + int * xpix, int * ypix)); + +int SetTerminalSize _((PerlIO * file, + int width, int height, + int xpix, int ypix)); + +void ReadMode _((PerlIO * file,int mode)); + +int pollfile _((PerlIO * file, double delay)); + +int setnodelay _((PerlIO * file, int mode)); + +int selectfile _((PerlIO * file, double delay)); + +int Win32PeekChar _((PerlIO * file, double delay, char * key)); + +int getspeed _((PerlIO * file, I32 *in, I32 * out )); + + +#ifdef VIOMODE +int GetTermSizeVIO(PerlIO *file,int *retwidth,int *retheight,int *xpix,int *ypix) +{ + /*int handle=PerlIO_fileno(file); + + static VIOMODEINFO *modeinfo = NULL; + + if (modeinfo == NULL) + modeinfo = (VIOMODEINFO *)malloc(sizeof(VIOMODEINFO)); + + VioGetMode(modeinfo,0); + *retheight = modeinfo->row ?: 25; + *retwidth = modeinfo->col ?: 80;*/ + int buf[2]; + + _scrsize(&buf[0]); + + *retwidth = buf[0]; *retheight = buf[1]; + + *xpix = *ypix = 0; + return 0; +} +#else +int GetTermSizeVIO(PerlIO *file,int * retwidth,int *retheight, int *xpix,int *ypix) +{ + croak("TermSizeVIO is not implemented on this architecture"); + return 0; +} +#endif + + +#if defined(TIOCGWINSZ) && !defined(DONT_USE_GWINSZ) +int GetTermSizeGWINSZ(PerlIO *file,int *retwidth,int *retheight,int *xpix,int *ypix) +{ + int handle=PerlIO_fileno(file); + struct winsize w; + + if (ioctl (handle, TIOCGWINSZ, &w) == 0) { + *retwidth=w.ws_col; *retheight=w.ws_row; + *xpix=w.ws_xpixel; *ypix=w.ws_ypixel; return 0; + } + else { + return -1; /* failure */ + } + +} +#else +int GetTermSizeGWINSZ(PerlIO *file,int *retwidth,int *retheight,int *xpix,int *ypix) +{ + croak("TermSizeGWINSZ is not implemented on this architecture"); + return 0; +} +#endif + +#if (!defined(TIOCGWINSZ) || defined(DONT_USE_GWINSZ)) && (defined(TIOCGSIZE) && !defined(DONT_USE_GSIZE)) +int GetTermSizeGSIZE(PerlIO *file,int *retwidth,int *retheight,int *xpix,int *ypix) +{ + int handle=PerlIO_fileno(file); + + struct ttysize w; + + if (ioctl (handle, TIOCGSIZE, &w) == 0) { + *retwidth=w.ts_cols; *retheight=w.ts_lines; + *xpix=0/*w.ts_xxx*/; *ypix=0/*w.ts_yyy*/; return 0; + } + else { + return -1; /* failure */ + } +} +#else +int GetTermSizeGSIZE(PerlIO *file,int *retwidth,int *retheight,int *xpix,int *ypix) +{ + croak("TermSizeGSIZE is not implemented on this architecture"); + return 0; +} +#endif + +#ifdef USE_WIN32 +int GetTermSizeWin32(PerlIO *file,int *retwidth,int *retheight,int *xpix,int *ypix) +{ + int handle=PerlIO_fileno(file); + HANDLE whnd = (HANDLE)_get_osfhandle(handle); + CONSOLE_SCREEN_BUFFER_INFO info; + + if (GetConsoleScreenBufferInfo(whnd, &info)) { + /* Logic: return maximum possible screen width, but return + only currently selected height */ + if (retwidth) + *retwidth = info.dwMaximumWindowSize.X; + /*info.srWindow.Right - info.srWindow.Left;*/ + if (retheight) + *retheight = info.srWindow.Bottom - info.srWindow.Top; + if (xpix) + *xpix = 0; + if (ypix) + *ypix = 0; + return 0; + } else + return -1; +} +#else +int GetTermSizeWin32(PerlIO *file,int *retwidth,int *retheight,int *xpix,int *ypix) +{ + croak("TermSizeWin32 is not implemented on this architecture"); + return 0; +} +#endif /* USE_WIN32 */ + + +int termsizeoptions() { + return 0 +#ifdef VIOMODE + | 1 +#endif +#if defined(TIOCGWINSZ) && !defined(DONT_USE_GWINSZ) + | 2 +#endif +#if defined(TIOCGSIZE) && !defined(DONT_USE_GSIZE) + | 4 +#endif +#if defined(USE_WIN32) + | 8 +#endif + ; +} + + +int SetTerminalSize(PerlIO *file,int width,int height,int xpix,int ypix) +{ + char buffer[10]; + int handle=PerlIO_fileno(file); + +#ifdef VIOMODE + return -1; +#else + +#if defined(TIOCSWINSZ) && !defined(DONT_USE_SWINSZ) + struct winsize w; + + w.ws_col=width; + w.ws_row=height; + w.ws_xpixel=xpix; + w.ws_ypixel=ypix; + if (ioctl (handle, TIOCSWINSZ, &w) == 0) { + sprintf(buffer,"%d",width); /* Be polite to our children */ + my_setenv("COLUMNS",buffer); + sprintf(buffer,"%d",height); + my_setenv("LINES",buffer); + return 0; + } + else { + croak("TIOCSWINSZ ioctl call to set terminal size failed: %s",Strerror(errno)); + return -1; + } +#else +# if defined(TIOCSSIZE) && !defined(DONT_USE_SSIZE) + struct ttysize w; + + w.ts_lines=height; + w.ts_cols=width; + w.ts_xxx=xpix; + w.ts_yyy=ypix; + if (ioctl (handle, TIOCSSIZE, &w) == 0) { + sprintf(buffer,"%d",width); + my_setenv("COLUMNS",buffer); + sprintf(buffer,"%d",height); + my_setenv("LINES",buffer); + return 0; + } + else { + croak("TIOCSSIZE ioctl call to set terminal size failed: %s",Strerror(errno)); + return -1; + } +# else + /*sprintf(buffer,"%d",width) * Should we could do this and then * + my_setenv("COLUMNS",buffer) * said we succeeded? * + sprintf(buffer,"%d",height); + my_setenv("LINES",buffer)*/ + + return -1; /* Fail */ +# endif +#endif +#endif + +} + +I32 terminal_speeds[] = { +#ifdef B50 + 50, B50, +#endif +#ifdef B75 + 75, B75, +#endif +#ifdef B110 + 110, B110, +#endif +#ifdef B134 + 134, B134, +#endif +#ifdef B150 + 150, B150, +#endif +#ifdef B200 + 200, B200, +#endif +#ifdef B300 + 300, B300, +#endif +#ifdef B600 + 600, B600, +#endif +#ifdef B1200 + 1200, B1200, +#endif +#ifdef B1800 + 1800, B1800, +#endif +#ifdef B2400 + 2400, B2400, +#endif +#ifdef B4800 + 4800, B4800, +#endif +#ifdef B9600 + 9600, B9600, +#endif +#ifdef B19200 + 19200, B19200, +#endif +#ifdef B38400 + 38400, B38400, +#endif +#ifdef B57600 + 57600, B57600, +#endif +#ifdef B115200 + 115200, B115200, +#endif +#ifdef EXTA + 19200, EXTA, +#endif +#ifdef EXTB + 38400, EXTB, +#endif +#ifdef B0 + 0, B0, +#endif + -1,-1 +}; + +int getspeed(PerlIO *file,I32 *in, I32 *out) +{ + int handle=PerlIO_fileno(file); + int i; +# ifdef I_TERMIOS + /* Posixy stuff */ + + struct termios buf; + tcgetattr(handle,&buf); + + *in = *out = -1; + *in = cfgetispeed(&buf); + *out = cfgetospeed(&buf); + for(i=0;terminal_speeds[i]!=-1;i+=2) { + if(*in == terminal_speeds[i+1]) + { *in = terminal_speeds[i]; break; } + } + for(i=0;terminal_speeds[i]!=-1;i+=2) { + if(*out == terminal_speeds[i+1]) + { *out = terminal_speeds[i]; break; } + } + return 0; + +# else +# ifdef I_TERMIO + /* SysV stuff */ + struct termio buf; + + ioctl(handle,TCGETA,&buf); + + *in=*out=-1; + for(i=0;terminal_speeds[i]!=-1;i+=2) { + if((buf.c_cflag & CBAUD) == terminal_speeds[i+1]) + { *in=*out=terminal_speeds[i]; break; } + } + return 0; + +# else +# ifdef I_SGTTY + /* BSD stuff */ + struct sgttyb buf; + + ioctl(handle,TIOCGETP,&buf); + + *in=*out=-1; + + for(i=0;terminal_speeds[i]!=-1;i+=2) + if(buf.sg_ospeed == terminal_speeds[i+1]) + { *out = terminal_speeds[i]; break; } + + for(i=0;terminal_speeds[i]!=-1;i+=2) + if(buf.sg_ispeed == terminal_speeds[i+1]) + { *in = terminal_speeds[i]; break; } + + return 0; + + +# else + + /* No termio, termios or sgtty. I suppose we can try stty, + but it would be nice if you could get a better OS */ + + return -1; + +# endif +# endif +# endif +} + +#ifdef WIN32 +struct tbuffer { DWORD Mode; }; +#else +#ifdef I_TERMIOS +#define USE_TERMIOS +#define tbuffer termios +#else +#ifdef I_TERMIO +#define USE_TERMIO +#define tbuffer termio +#else +#ifdef I_SGTTY +#define USE_SGTTY +struct tbuffer { + struct sgttyb buf; +#if defined(TIOCGETC) + struct tchars tchar; +#endif +#if defined(TIOCGLTC) + struct ltchars ltchar; +#endif +#if defined(TIOCLGET) + int local; +#endif +}; +#else +#define USE_STTY +struct tbuffer { + int dummy; +}; +#endif +#endif +#endif +#endif + +HV * filehash; /* Used to store the original terminal settings for each handle*/ +HV * modehash; /* Used to record the current terminal "mode" for each handle*/ + +void ReadMode(PerlIO *file,int mode) +{ + dTHR; + int handle; + int firsttime; + int oldmode; + struct tbuffer work; + struct tbuffer savebuf; + + + handle=PerlIO_fileno(file); + + firsttime=!hv_exists(filehash, (char*)&handle, sizeof(int)); + + +# ifdef WIN32 + + if (!GetConsoleMode((HANDLE)_get_osfhandle(handle), &work.Mode)) + croak("GetConsoleMode failed, LastError=|%d|",GetLastError()); + +# endif /* WIN32 */ + +# ifdef USE_TERMIOS + /* Posixy stuff */ + + tcgetattr(handle,&work); + + + +#endif +#ifdef USE_TERMIO + /* SysV stuff */ + + ioctl(handle,TCGETA,&work); + + +#endif +#ifdef USE_SGTTY + /* BSD stuff */ + + ioctl(handle,TIOCGETP,&work.buf); +# if defined(TIOCGETC) + ioctl(handle,TIOCGETC,&work.tchar); +# endif +# if defined(TIOCLGET) + ioctl(handle,TIOCLGET,&work.local); +# endif +# if defined(TIOCGLTC) + ioctl(handle,TIOCGLTC,&work.ltchar); +# endif + + +#endif + + + if(firsttime) { + firsttime=0; + memcpy((void*)&savebuf,(void*)&work,sizeof(struct tbuffer)); + if(!hv_store(filehash,(char*)&handle,sizeof(int), + newSVpv((char*)&savebuf,sizeof(struct tbuffer)),0)) + croak("Unable to stash terminal settings.\n"); + if(!hv_store(modehash,(char*)&handle,sizeof(int),newSViv(0),0)) + croak("Unable to stash terminal settings.\n"); + } else { + SV ** temp; + if(!(temp=hv_fetch(filehash,(char*)&handle,sizeof(int),0))) + croak("Unable to retrieve stashed terminal settings.\n"); + memcpy(&savebuf,SvPV(*temp,PL_na),sizeof(struct tbuffer)); + if(!(temp=hv_fetch(modehash,(char*)&handle,sizeof(int),0))) + croak("Unable to retrieve stashed terminal mode.\n"); + oldmode=SvIV(*temp); + } + +#ifdef WIN32 + + switch (mode) { + case 5: + /* Should 5 disable ENABLE_WRAP_AT_EOL_OUTPUT? */ + case 4: + work.Mode &= ~(ENABLE_ECHO_INPUT|ENABLE_PROCESSED_INPUT|ENABLE_LINE_INPUT|ENABLE_PROCESSED_OUTPUT); + work.Mode |= 0; + break; + case 3: + work.Mode &= ~(ENABLE_LINE_INPUT|ENABLE_ECHO_INPUT); + work.Mode |= ENABLE_PROCESSED_INPUT|ENABLE_PROCESSED_OUTPUT; + break; + case 2: + work.Mode &= ~(ENABLE_ECHO_INPUT); + work.Mode |= ENABLE_LINE_INPUT|ENABLE_PROCESSED_INPUT|ENABLE_PROCESSED_OUTPUT; + break; + case 1: + work.Mode &= ~(0); + work.Mode |= ENABLE_ECHO_INPUT|ENABLE_LINE_INPUT|ENABLE_PROCESSED_INPUT|ENABLE_PROCESSED_OUTPUT; + break; + case 0: + work = savebuf; + firsttime = 1; + break; + } + + if (!SetConsoleMode((HANDLE)_get_osfhandle(handle), work.Mode)) + croak("SetConsoleMode failed, LastError=|%d|",GetLastError()); + +#endif /* WIN32 */ + + +#ifdef USE_TERMIOS + + +/* What, me worry about standards? */ + +# if !defined (VMIN) +# define VMIN VEOF +# endif + +# if !defined (VTIME) +# define VTIME VEOL +# endif + +# if !defined (IXANY) +# define IXANY (0) +# endif + +#ifndef IEXTEN +#ifdef IDEFAULT +#define IEXTEN IDEFAULT +#endif +#endif + +/* XXX Is ONLCR in POSIX?. The value of '4' seems to be the same for + both SysV and Sun, so it's probably rather general, and I'm not + aware of a POSIX way to do this otherwise. +*/ +#ifndef ONLCR +# define ONLCR 4 +#endif + +#ifndef IMAXBEL +#define IMAXBEL 0 +#endif +#ifndef ECHOE +#define ECHOE 0 +#endif +#ifndef ECHOK +#define ECHOK 0 +#endif +#ifndef ECHONL +#define ECHONL 0 +#endif +#ifndef ECHOPRT +#define ECHOPRT 0 +#endif +#ifndef FLUSHO +#define FLUSHO 0 +#endif +#ifndef PENDIN +#define PENDIN 0 +#endif +#ifndef ECHOKE +#define ECHOKE 0 +#endif +#ifndef ONLCR +#define ONLCR 0 +#endif +#ifndef OCRNL +#define OCRNL 0 +#endif +#ifndef ONLRET +#define ONLRET 0 +#endif +#ifndef IUCLC +#define IUCLC 0 +#endif +#ifndef OPOST +#define OPOST 0 +#endif +#ifndef OLCUC +#define OLCUC 0 +#endif +#ifndef ECHOCTL +#define ECHOCTL 0 +#endif +#ifndef XCASE +#define XCASE 0 +#endif +#ifndef BRKINT +#define BRKINT 0 +#endif + + + if(mode==5) { + /*\ + * Disable everything except parity if needed. + \*/ + + /* Hopefully, this should put the tty into unbuffered mode + with signals and control characters (both posixy and normal) + disabled, along with flow control. Echo should be off. + CR/LF is not translated, along with 8-bit/parity */ + + memcpy((void*)&work,(void*)&savebuf,sizeof(struct tbuffer)); + + work.c_lflag &= ~(ICANON|ISIG|IEXTEN ); + work.c_lflag &= ~(ECHO|ECHOE|ECHOK|ECHONL|ECHOCTL); + work.c_lflag &= ~(ECHOPRT|ECHOKE|FLUSHO|PENDIN|XCASE); + work.c_lflag |= NOFLSH; + work.c_iflag &= ~(IXOFF|IXON|IXANY|ICRNL|IMAXBEL|BRKINT); + + if(((work.c_iflag & INPCK) != INPCK) || + ((work.c_cflag & PARENB) != PARENB)) { + work.c_iflag &= ~ISTRIP; + work.c_iflag |= IGNPAR; + work.c_iflag &= ~PARMRK; + } + work.c_oflag &= ~(OPOST |ONLCR|OCRNL|ONLRET); + + work.c_cc[VTIME] = 0; + work.c_cc[VMIN] = 1; + } + else if(mode==4) { + /* Hopefully, this should put the tty into unbuffered mode + with signals and control characters (both posixy and normal) + disabled, along with flow control. Echo should be off. + About the only thing left unchanged is 8-bit/parity */ + + memcpy((void*)&work,(void*)&savebuf,sizeof(struct tbuffer)); + + /*work.c_iflag = savebuf.c_iflag;*/ + work.c_lflag &= ~(ICANON | ISIG | IEXTEN | ECHO); + work.c_lflag &= ~(ECHOE | ECHOK | ECHONL|ECHOCTL|ECHOPRT|ECHOKE); + work.c_iflag &= ~(IXON | IXANY | BRKINT); + work.c_oflag = savebuf.c_oflag; + work.c_cc[VTIME] = 0; + work.c_cc[VMIN] = 1; + } + else if(mode==3) + { + /* This should be an unbuffered mode with signals and control + characters enabled, as should be flow control. Echo should + still be off */ + + memcpy((void*)&work,(void*)&savebuf,sizeof(struct tbuffer)); + + work.c_iflag = savebuf.c_iflag; + work.c_lflag &= ~(ICANON | ECHO); + work.c_lflag &= ~(ECHOE | ECHOK | ECHONL|ECHOCTL|ECHOPRT|ECHOKE); + work.c_lflag |= ISIG | IEXTEN; + /*work.c_iflag &= ~(IXON | IXOFF | IXANY); + work.c_iflag |= savebuf.c_iflag & (IXON|IXOFF|IXANY); + work.c_oflag = savebuf.c_oflag;*/ + work.c_cc[VTIME] = 0; + work.c_cc[VMIN] = 1; + } + else if(mode==2) + { + /* This should be an unbuffered mode with signals and control + characters enabled, as should be flow control. Echo should + still be off */ + + memcpy((void*)&work,(void*)&savebuf,sizeof(struct tbuffer)); + + work.c_iflag = savebuf.c_iflag; + work.c_lflag |= ICANON|ISIG|IEXTEN; + work.c_lflag &= ~ECHO; + work.c_lflag &= ~(ECHOE | ECHOK | ECHONL|ECHOCTL|ECHOPRT|ECHOKE); + /*work.c_iflag &= ~(IXON |IXOFF|IXANY); + work.c_iflag |= savebuf.c_iflag & (IXON|IXOFF|IXANY); + work.c_oflag = savebuf.c_oflag; + work.c_cc[VTIME] = savebuf.c_cc[VTIME]; + work.c_cc[VMIN] = savebuf.c_cc[VMIN];*/ + } + else if(mode==1) + { + /* This should be an unbuffered mode with signals and control + characters enabled, as should be flow control. Echo should + still be off */ + + memcpy((void*)&work,(void*)&savebuf,sizeof(struct tbuffer)); + + work.c_iflag = savebuf.c_iflag; + work.c_lflag |= ICANON|ECHO|ISIG|IEXTEN; + /*work.c_iflag &= ~(IXON |IXOFF|IXANY); + work.c_iflag |= savebuf.c_iflag & (IXON|IXOFF|IXANY); + work.c_oflag = savebuf.c_oflag; + work.c_cc[VTIME] = savebuf.c_cc[VTIME]; + work.c_cc[VMIN] = savebuf.c_cc[VMIN];*/ + } + else if(mode==0){ + /*work.c_lflag &= ~BITMASK; + work.c_lflag |= savebuf.c_lflag & BITMASK; + work.c_oflag = savebuf.c_oflag; + work.c_cc[VTIME] = savebuf.c_cc[VTIME]; + work.c_cc[VMIN] = savebuf.c_cc[VMIN]; + work.c_iflag = savebuf.c_iflag; + work.c_iflag &= ~(IXON|IXOFF|IXANY); + work.c_iflag |= savebuf.c_iflag & (IXON|IXOFF|IXANY);*/ + memcpy((void*)&work,(void*)&savebuf,sizeof(struct tbuffer)); + /*Copy(&work,&savebuf,1,sizeof(struct tbuffer));*/ + + firsttime=1; + } + else + { + croak("ReadMode %d is not implemented on this architecture.",mode); + return; + } + + + /* If switching from a "lower power" mode to a higher one, keep the + data that may be in the queue, as it can easily be type-ahead. On + switching to a lower mode from a higher one, however, flush the queue + so that raw keystrokes won't hit an unexpecting program */ + + if(DisableFlush || oldmode<=mode) + tcsetattr(handle,TCSANOW,&work); + else + tcsetattr(handle,TCSAFLUSH,&work); + + /*tcsetattr(handle,TCSANOW,&work);*/ /* It might be better to FLUSH + when changing gears to a lower mode, + and only use NOW for higher modes. + */ + + +#endif +#ifdef USE_TERMIO + +/* What, me worry about standards? */ + +# if !defined (IXANY) +# define IXANY (0) +# endif + +#ifndef ECHOE +#define ECHOE 0 +#endif +#ifndef ECHOK +#define ECHOK 0 +#endif +#ifndef ECHONL +#define ECHONL 0 +#endif +#ifndef XCASE +#define XCASE 0 +#endif +#ifndef BRKINT +#define BRKINT 0 +#endif + + + + if(mode==5) { + /* This mode should be echo disabled, signals disabled, + flow control disabled, and unbuffered. CR/LF translation + is off, and 8 bits if possible */ + + memcpy((void*)&work,(void*)&savebuf,sizeof(struct tbuffer)); + + work.c_lflag &= ~(ECHO | ISIG | ICANON | XCASE); + work.c_lflag &= ~(ECHOE | ECHOK | ECHONL | TRK_IDEFAULT); + work.c_iflag &= ~(IXON | IXOFF | IXANY | ICRNL | BRKINT); + if((work.c_cflag | PARENB)!=PARENB ) { + work.c_iflag &= ~(ISTRIP|INPCK); + work.c_iflag |= IGNPAR; + } + work.c_oflag &= ~(OPOST|ONLCR); + work.c_cc[VMIN] = 1; + work.c_cc[VTIME] = 1; + } + else if(mode==4) { + /* This mode should be echo disabled, signals disabled, + flow control disabled, and unbuffered. Parity is not + touched. */ + + memcpy((void*)&work,(void*)&savebuf,sizeof(struct tbuffer)); + + work.c_lflag &= ~(ECHO | ISIG | ICANON); + work.c_lflag &= ~(ECHOE | ECHOK | ECHONL TRK_IDEFAULT); + work.c_iflag = savebuf.c_iflag; + work.c_iflag &= ~(IXON | IXOFF | IXANY | BRKINT); + work.c_oflag = savebuf.c_oflag; + work.c_cc[VMIN] = 1; + work.c_cc[VTIME] = 1; + } + else if(mode==3) { + /* This mode tries to have echo off, signals enabled, + flow control as per the original setting, and unbuffered. */ + + memcpy((void*)&work,(void*)&savebuf,sizeof(struct tbuffer)); + + work.c_lflag &= ~(ECHO | ICANON); + work.c_lflag &= ~(ECHOE | ECHOK | ECHONL | TRK_IDEFAULT); + work.c_lflag |= ISIG; + work.c_iflag = savebuf.c_iflag; + work.c_iflag &= ~(IXON | IXOFF | IXANY); + work.c_iflag |= savebuf.c_iflag & (IXON|IXOFF|IXANY); + work.c_oflag = savebuf.c_oflag; + work.c_cc[VMIN] = 1; + work.c_cc[VTIME] = 1; + } + else if(mode==2) { + /* This mode tries to set echo on, signals on, and buffering + on, with flow control set to whatever it was originally. */ + + memcpy((void*)&work,(void*)&savebuf,sizeof(struct tbuffer)); + + work.c_lflag |= (ISIG | ICANON); + work.c_lflag &= ~ECHO; + work.c_lflag &= ~(ECHOE | ECHOK | ECHONL | TRK_IDEFAULT); + work.c_iflag = savebuf.c_iflag; + work.c_iflag &= ~(IXON | IXOFF | IXANY); + work.c_iflag |= savebuf.c_iflag & (IXON|IXOFF|IXANY); + work.c_oflag = savebuf.c_oflag; + work.c_cc[VMIN] = savebuf.c_cc[VMIN]; + work.c_cc[VTIME] = savebuf.c_cc[VTIME]; + + /* This assumes turning ECHO and ICANON back on is + sufficient to re-enable cooked mode. If this is a + problem, complain to me */ + + /* What the heck. We're already saving the entire buf, so + I'm now going to reset VMIN and VTIME too. Hope this works + properly */ + + } + else if(mode==1) { + /* This mode tries to set echo on, signals on, and buffering + on, with flow control set to whatever it was originally. */ + + memcpy((void*)&work,(void*)&savebuf,sizeof(struct tbuffer)); + + work.c_lflag |= (ECHO | ISIG | ICANON); + work.c_iflag &= ~TRK_IDEFAULT; + work.c_iflag = savebuf.c_iflag; + work.c_iflag &= ~(IXON | IXOFF | IXANY); + work.c_iflag |= savebuf.c_iflag & (IXON|IXOFF|IXANY); + work.c_oflag = savebuf.c_oflag; + work.c_cc[VMIN] = savebuf.c_cc[VMIN]; + work.c_cc[VTIME] = savebuf.c_cc[VTIME]; + + /* This assumes turning ECHO and ICANON back on is + sufficient to re-enable cooked mode. If this is a + problem, complain to me */ + + /* What the heck. We're already saving the entire buf, so + I'm now going to reset VMIN and VTIME too. Hope this works + properly */ + } + else if(mode==0) { + /* Put things back the way they were */ + + /*work.c_lflag = savebuf.c_lflag; + work.c_iflag = savebuf.c_iflag; + work.c_oflag = savebuf.c_oflag; + work.c_cc[VMIN] = savebuf.c_cc[VMIN]; + work.c_cc[VTIME] = savebuf.c_cc[VTIME];*/ + memcpy((void*)&work,(void*)&savebuf,sizeof(struct tbuffer)); + firsttime=1; + } + else + { + croak("ReadMode %d is not implemented on this architecture.",mode); + return; + } + + + if(DisableFlush || oldmode<=mode) + ioctl(handle,TCSETA,&work); + else + ioctl(handle,TCSETAF,&work); + +#endif +#ifdef USE_SGTTY + + + if(mode==5) { + /* Unbuffered, echo off, signals off, flow control off */ + /* CR-CR/LF mode off too, and 8-bit path enabled. */ +# if defined(TIOCLGET) && defined(LPASS8) + if((work.buf.sg_flags & (EVENP|ODDP))==0 || + (work.buf.sg_flags & (EVENP|ODDP))==(EVENP|ODDP)) + work.local |= LPASS8; /* If parity isn't being used, use 8 bits */ +# endif + work.buf.sg_flags &= ~(ECHO|CRMOD); + work.buf.sg_flags |= (RAW|CBREAK); +# if defined(TIOCGETC) + work.tchar.t_intrc = -1; + work.tchar.t_quitc = -1; + work.tchar.t_startc= -1; + work.tchar.t_stopc = -1; + work.tchar.t_eofc = -1; + work.tchar.t_brkc = -1; +# endif +# if defined(TIOCGLTC) + work.ltchar.t_suspc= -1; + work.ltchar.t_dsuspc= -1; + work.ltchar.t_rprntc= -1; + work.ltchar.t_flushc= -1; + work.ltchar.t_werasc= -1; + work.ltchar.t_lnextc= -1; +# endif + } + else if(mode==4) { + /* Unbuffered, echo off, signals off, flow control off */ + work.buf.sg_flags &= ~(ECHO|RAW); + work.buf.sg_flags |= (CBREAK|CRMOD); +# if defined(TIOCLGET) + work.local=savebuf.local; +# endif +# if defined(TIOCGETC) + work.tchar.t_intrc = -1; + work.tchar.t_quitc = -1; + work.tchar.t_startc= -1; + work.tchar.t_stopc = -1; + work.tchar.t_eofc = -1; + work.tchar.t_brkc = -1; +# endif +# if defined(TIOCGLTC) + work.ltchar.t_suspc= -1; + work.ltchar.t_dsuspc= -1; + work.ltchar.t_rprntc= -1; + work.ltchar.t_flushc= -1; + work.ltchar.t_werasc= -1; + work.ltchar.t_lnextc= -1; +# endif + } + else if(mode==3) { + /* Unbuffered, echo off, signals on, flow control on */ + work.buf.sg_flags &= ~(RAW|ECHO); + work.buf.sg_flags |= CBREAK|CRMOD; +# if defined(TIOCLGET) + work.local=savebuf.local; +# endif +# if defined(TIOCGLTC) + work.tchar = savebuf.tchar; +# endif +# if defined(TIOCGLTC) + work.ltchar = savebuf.ltchar; +# endif + } + else if(mode==2) { + /* Buffered, echo on, signals on, flow control on */ + work.buf.sg_flags &= ~(RAW|CBREAK); + work.buf.sg_flags |= CRMOD; + work.buf.sg_flags &= ~ECHO; +# if defined(TIOCLGET) + work.local=savebuf.local; +# endif +# if defined(TIOCGLTC) + work.tchar = savebuf.tchar; +# endif +# if defined(TIOCGLTC) + work.ltchar = savebuf.ltchar; +# endif + } + else if(mode==1) { + /* Buffered, echo on, signals on, flow control on */ + work.buf.sg_flags &= ~(RAW|CBREAK); + work.buf.sg_flags |= ECHO|CRMOD; +# if defined(TIOCLGET) + work.local=savebuf.local; +# endif +# if defined(TIOCGLTC) + work.tchar = savebuf.tchar; +# endif +# if defined(TIOCGLTC) + work.ltchar = savebuf.ltchar; +# endif + } + else if(mode==0){ + /* Original settings */ +#if 0 + work.buf.sg_flags &= ~(RAW|CBREAK|ECHO|CRMOD); + work.buf.sg_flags |= savebuf.sg_flags & (RAW|CBREAK|ECHO|CRMOD); +# if defined(TIOCLGET) + work.local=savebuf.local; +# endif +# if defined(TIOCGLTC) + work.tchar = savebuf.tchar; +# endif +# if defined(TIOCGLTC) + work.ltchar = savebuf.ltchar; +# endif +#endif + memcpy((void*)&work,(void*)&savebuf,sizeof(struct tbuffer)); + firsttime=1; + } + else + { + croak("ReadMode %d is not implemented on this architecture.",mode); + return; + } +#if defined(TIOCLSET) + ioctl(handle,TIOCLSET,&work.local); +#endif +#if defined(TIOCSETC) + ioctl(handle,TIOCSETC,&work.tchar); +#endif +# if defined(TIOCGLTC) + ioctl(handle,TIOCSLTC,&work.ltchar); +# endif + if(DisableFlush || oldmode<=mode) + ioctl(handle,TIOCSETN,&work.buf); + else + ioctl(handle,TIOCSETP,&work.buf); +#endif +#ifdef USE_STTY + + /* No termio, termios or sgtty. I suppose we can try stty, + but it would be nice if you could get a better OS */ + + if(mode==5) + system("/bin/stty raw -cbreak -isig -echo -ixon -onlcr -icrnl -brkint"); + else if(mode==4) + system("/bin/stty -raw cbreak -isig -echo -ixon onlcr icrnl -brkint"); + else if(mode==3) + system("/bin/stty -raw cbreak isig -echo ixon onlcr icrnl brkint"); + else if(mode==2) + system("/bin/stty -raw -cbreak isig echo ixon onlcr icrnl brkint"); + else if(mode==1) + system("/bin/stty -raw -cbreak isig -echo ixon onlcr icrnl brkint"); + else if(mode==0) + system("/bin/stty -raw -cbreak isig echo ixon onlcr icrnl brkint"); + + /* Those probably won't work, but they couldn't hurt + at this point */ + +#endif + + /*warn("Mode set to %d.\n",mode);*/ + + if( firsttime ) { + (void)hv_delete(filehash,(char*)&handle,sizeof(int),0); + (void)hv_delete(modehash,(char*)&handle,sizeof(int),0); + } else { + if(!hv_store(modehash,(char*)&handle,sizeof(int), + newSViv(mode),0)) + croak("Unable to stash terminal settings.\n"); + } + +} + +#ifdef USE_PERLIO + +/* Make use of a recent addition to Perl, if possible */ +# define FCOUNT(f) PerlIO_get_cnt(f) +#else + + /* Make use of a recent addition to Configure, if possible */ +# ifdef USE_STDIO_PTR +# define FCOUNT(f) PerlIO_get_cnt(f) +# else + /* This bit borrowed from pp_sys.c. Complain to Larry if it's broken. */ + /* If any of this works PerlIO_get_cnt() will too ... NI-S */ +# if defined(USE_STD_STDIO) || defined(atarist) /* this will work with atariST */ +# define FBASE(f) ((f)->_base) +# define FSIZE(f) ((f)->_cnt + ((f)->_ptr - (f)->_base)) +# define FPTR(f) ((f)->_ptr) +# define FCOUNT(f) ((f)->_cnt) +# else +# if defined(USE_LINUX_STDIO) +# define FBASE(f) ((f)->_IO_read_base) +# define FSIZE(f) ((f)->_IO_read_end - FBASE(f)) +# define FPTR(f) ((f)->_IO_read_ptr) +# define FCOUNT(f) ((f)->_IO_read_end - FPTR(f)) +# endif +# endif +# endif +#endif + +/* This is for the best, I'm afraid. */ +#if !defined(FCOUNT) +# ifdef Have_select +# undef Have_select +# endif +# ifdef Have_poll +# undef Have_poll +# endif +#endif + +/* Note! If your machine has a bolixed up select() call that doesn't +understand this syntax, either fix the checkwaiting call below, or define +DONT_USE_SELECT. */ + +#ifdef Have_select +int selectfile(PerlIO *file,double delay) +{ + struct timeval t; + int handle=PerlIO_fileno(file); + + /*char buf[32]; + Select_fd_set_t fd=(Select_fd_set_t)&buf[0];*/ + + fd_set fd; + if (PerlIO_fast_gets(file) && PerlIO_get_cnt(file) > 0) + return 1; + + /*t.tv_sec=t.tv_usec=0;*/ + + if (delay < 0.0) + delay = 0.0; + t.tv_sec = (long)delay; + delay -= (double)t.tv_sec; + t.tv_usec = (long)(delay * 1000000.0); + + FD_ZERO(&fd); + FD_SET(handle,&fd); + if(select(handle+1,(Select_fd_set_t)&fd, + (Select_fd_set_t)0, + (Select_fd_set_t)&fd, &t)) return -1; + else return 0; +} + +#else +int selectfile(PerlIO *file, double delay) +{ + croak("select is not supported on this architecture"); + return 0; +} +#endif + +#ifdef Have_nodelay +int setnodelay(PerlIO *file, int mode) +{ + int handle=PerlIO_fileno(file); + int flags; + flags=fcntl(handle,F_GETFL,0); + if(mode) + flags|=O_NODELAY; + else + flags&=~O_NODELAY; + fcntl(handle,F_SETFL,flags); + return 0; +} + +#else +int setnodelay(PerlIO *file, int mode) +{ + croak("setnodelay is not supported on this architecture"); + return 0; +} +#endif + +#ifdef Have_poll +int pollfile(PerlIO *file,double delay) +{ + int handle=PerlIO_fileno(file); + struct pollfd fds; + if (PerlIO_fast_gets(f) && PerlIO_get_cnt(f) > 0) + return 1; + if(delay<0.0) delay = 0.0; + fds.fd=handle; + fds.events=POLLIN; + fds.revents=0; + return (poll(&fds,1,(long)(delay * 1000.0))>0); +} +#else +int pollfile(PerlIO *file,double delay) +{ + croak("pollfile is not supported on this architecture"); + return 0; +} +#endif + +#ifdef WIN32 + +/* + + This portion of the Win32 code is partially borrowed from a version of PDCurses. + +*/ + +typedef struct { + int repeatCount; + int vKey; + int vScan; + int ascii; + int control; +} win32_key_event_t; + +#define KEY_PUSH(I, K) { events[I].repeatCount = 1; events[I].ascii = K; } +#define KEY_PUSH3(K1, K2, K3) \ + do { \ + eventCount = 0; \ + KEY_PUSH(2, K1); \ + KEY_PUSH(1, K2); \ + KEY_PUSH(0, K3); \ + eventCount = 3; \ + goto again; \ + } while (0) + +#define KEY_PUSH4(K1, K2, K3, K4) \ + do { \ + eventCount = 0; \ + KEY_PUSH(3, K1); \ + KEY_PUSH(2, K2); \ + KEY_PUSH(1, K3); \ + KEY_PUSH(0, K4); \ + eventCount = 4; \ + goto again; \ + } while (0) + +int Win32PeekChar(PerlIO *file,double delay,char *key) +{ + int handle; + HANDLE whnd; + INPUT_RECORD record; + DWORD readRecords; + +#if 0 + static int keyCount = 0; + static char lastKey = 0; +#endif + +#define MAX_EVENTS 4 + static int eventCount = 0; + static win32_key_event_t events[MAX_EVENTS]; + int keyCount; + + file = STDIN; + + handle = PerlIO_fileno(file); + whnd = /*GetStdHandle(STD_INPUT_HANDLE)*/(HANDLE)_get_osfhandle(handle); + + +again: +#if 0 + if (keyCount > 0) { + keyCount--; + *key = lastKey; + return TRUE; + } +#endif + + /* printf("eventCount: %d\n", eventCount); */ + if (eventCount) { + /* printf("key %d; repeatCount %d\n", *key, events[eventCount - 1].repeatCount); */ + *key = events[eventCount - 1].ascii; + events[eventCount - 1].repeatCount--; + if (events[eventCount - 1].repeatCount <= 0) { + eventCount--; + } + return TRUE; + } + + if (delay > 0) { + if (WaitForSingleObject(whnd, delay * 1000.0) != WAIT_OBJECT_0) + { + return FALSE; + } + } + + if (delay != 0) { + PeekConsoleInput(whnd, &record, 1, &readRecords); + if (readRecords == 0) { + return(FALSE); + } + } + + ReadConsoleInput(whnd, &record, 1, &readRecords); + switch(record.EventType) + { + case KEY_EVENT: + /* printf("\nkeyDown = %d, repeat = %d, vKey = %d, vScan = %d, ASCII = %d, Control = %d\n", + record.Event.KeyEvent.bKeyDown, + record.Event.KeyEvent.wRepeatCount, + record.Event.KeyEvent.wVirtualKeyCode, + record.Event.KeyEvent.wVirtualScanCode, + record.Event.KeyEvent.uChar.AsciiChar, + record.Event.KeyEvent.dwControlKeyState); */ + + if (record.Event.KeyEvent.bKeyDown == FALSE) + goto again; /* throw away KeyUp events */ + + if (record.Event.KeyEvent.wVirtualKeyCode == 38) { /* up */ + KEY_PUSH3(27, 91, 65); + } + if (record.Event.KeyEvent.wVirtualKeyCode == 40) { /* down */ + KEY_PUSH3(27, 91, 66); + } + if (record.Event.KeyEvent.wVirtualKeyCode == 39) { /* right */ + KEY_PUSH3(27, 91, 67); + } + if (record.Event.KeyEvent.wVirtualKeyCode == 37) { /* left */ + KEY_PUSH3(27, 91, 68); + } + if (record.Event.KeyEvent.wVirtualKeyCode == 33) { /* page up */ + KEY_PUSH3(27, 79, 121); + } + if (record.Event.KeyEvent.wVirtualKeyCode == 34) { /* page down */ + KEY_PUSH3(27, 79, 115); + } + if (record.Event.KeyEvent.wVirtualKeyCode == 36) { /* home */ + KEY_PUSH4(27, 91, 49, 126); + } + if (record.Event.KeyEvent.wVirtualKeyCode == 35) { /* end */ + KEY_PUSH4(27, 91, 52, 126); + } + if (record.Event.KeyEvent.wVirtualKeyCode == 45) { /* insert */ + KEY_PUSH4(27, 91, 50, 126); + } + if (record.Event.KeyEvent.wVirtualKeyCode == 46) { /* delete */ + KEY_PUSH4(27, 91, 51, 126); + } + + if (record.Event.KeyEvent.wVirtualKeyCode == 16 + || record.Event.KeyEvent.wVirtualKeyCode == 17 + || record.Event.KeyEvent.wVirtualKeyCode == 18 + || record.Event.KeyEvent.wVirtualKeyCode == 20 + || record.Event.KeyEvent.wVirtualKeyCode == 144 + || record.Event.KeyEvent.wVirtualKeyCode == 145) + goto again; /* throw away shift/alt/ctrl key only key events */ + keyCount = record.Event.KeyEvent.wRepeatCount; + break; + default: + keyCount = 0; + goto again; + break; + } + + *key = record.Event.KeyEvent.uChar.AsciiChar; + keyCount--; + + if (keyCount) { + events[0].repeatCount = keyCount; + events[0].ascii = *key; + eventCount = 1; + } + + return(TRUE); + + /* again: + return (FALSE); + */ + + +} +#else +int Win32PeekChar(PerlIO *file, double delay,char *key) +{ + croak("Win32PeekChar is not supported on this architecture"); + return 0; +} +#endif + + +int blockoptions() { + return 0 +#ifdef Have_nodelay + | 1 +#endif +#ifdef Have_poll + | 2 +#endif +#ifdef Have_select + | 4 +#endif +#ifdef USE_WIN32 + | 8 +#endif + ; +} + +int termoptions() { + int i=0; +#ifdef USE_TERMIOS + i=1; +#endif +#ifdef USE_TERMIO + i=2; +#endif +#ifdef USE_SGTTY + i=3; +#endif +#ifdef USE_STTY + i=4; +#endif +#ifdef USE_WIN32 + i=5; +#endif + return i; +} + + + +MODULE = Term::ReadKey PACKAGE = Term::ReadKey + +int +selectfile(file,delay) + InputStream file + double delay + +# Clever, eh? +void +SetReadMode(mode,file=STDIN) + int mode + InputStream file + CODE: + { + ReadMode(file,mode); + } + +int +setnodelay(file,mode) + InputStream file + int mode + +int +pollfile(file,delay) + InputStream file + double delay + +SV * +Win32PeekChar(file, delay) + InputStream file + double delay + CODE: + { + char key; + if (Win32PeekChar(file, delay, &key)) + RETVAL = newSVpv(&key, 1); + else + RETVAL = newSVsv(&PL_sv_undef); + } + OUTPUT: + RETVAL + +int +blockoptions() + +int +termoptions() + +int +termsizeoptions() + +void +GetTermSizeWin32(file=STDIN) + InputStream file + PPCODE: + { + int x,y,xpix,ypix; + if( GetTermSizeWin32(file,&x,&y,&xpix,&ypix)==0) + { + EXTEND(sp, 4); + PUSHs(sv_2mortal(newSViv((IV)x))); + PUSHs(sv_2mortal(newSViv((IV)y))); + PUSHs(sv_2mortal(newSViv((IV)xpix))); + PUSHs(sv_2mortal(newSViv((IV)ypix))); + } + else + { + ST(0) = sv_newmortal(); + } + } + +void +GetTermSizeVIO(file=STDIN) + InputStream file + PPCODE: + { + int x,y,xpix,ypix; + if( GetTermSizeVIO(file,&x,&y,&xpix,&ypix)==0) + { + EXTEND(sp, 4); + PUSHs(sv_2mortal(newSViv((IV)x))); + PUSHs(sv_2mortal(newSViv((IV)y))); + PUSHs(sv_2mortal(newSViv((IV)xpix))); + PUSHs(sv_2mortal(newSViv((IV)ypix))); + } + else + { + ST(0) = sv_newmortal(); + } + } + +void +GetTermSizeGWINSZ(file=STDIN) + InputStream file + PPCODE: + { + int x,y,xpix,ypix; + if( GetTermSizeGWINSZ(file,&x,&y,&xpix,&ypix)==0) + { + EXTEND(sp, 4); + PUSHs(sv_2mortal(newSViv((IV)x))); + PUSHs(sv_2mortal(newSViv((IV)y))); + PUSHs(sv_2mortal(newSViv((IV)xpix))); + PUSHs(sv_2mortal(newSViv((IV)ypix))); + } + else + { + ST(0) = sv_newmortal(); + } + } + +void +GetTermSizeGSIZE(file=STDIN) + InputStream file + PPCODE: + { + int x,y,xpix,ypix; + if( GetTermSizeGSIZE(file,&x,&y,&xpix,&ypix)==0) + { + EXTEND(sp, 4); + PUSHs(sv_2mortal(newSViv((IV)x))); + PUSHs(sv_2mortal(newSViv((IV)y))); + PUSHs(sv_2mortal(newSViv((IV)xpix))); + PUSHs(sv_2mortal(newSViv((IV)ypix))); + } + else + { + ST(0) = sv_newmortal(); + } + } + +int +SetTerminalSize(width,height,xpix,ypix,file=STDIN) + int width + int height + int xpix + int ypix + InputStream file + CODE: + { + RETVAL=SetTerminalSize(file,width,height,xpix,ypix); + } + OUTPUT: + RETVAL + +void +GetSpeed(file=STDIN) + InputStream file + PPCODE: + { + I32 in,out; + if(items!=0) { + croak("Usage: Term::ReadKey::GetSpeed()"); + } + if(getspeed(file,&in,&out)) { + /* Failure */ + ST( 0) = sv_newmortal(); + } else { + EXTEND(sp, 2); + PUSHs(sv_2mortal(newSViv((IV)in))); + PUSHs(sv_2mortal(newSViv((IV)out))); + } + } + + + +BOOT: +newXS("Term::ReadKey::GetControlChars", XS_Term__ReadKey_GetControlChars, file); +newXS("Term::ReadKey::SetControlChars", XS_Term__ReadKey_SetControlChars, file); +filehash=newHV(); +modehash=newHV(); diff --git a/gnu/usr.bin/perl/cpan/Term-ReadKey/example/test.pl b/gnu/usr.bin/perl/cpan/Term-ReadKey/example/test.pl new file mode 100644 index 00000000000..359e75bad08 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/Term-ReadKey/example/test.pl @@ -0,0 +1,366 @@ +#!/usr/bin/perl -w + +#use strict vars; + +#use Term::ReadKey qw( ReadMode ReadKey ); +#my $x; +#ReadMode 3; +#print "Read 1\n"; +#$x = ReadKey(0); +#print "X=$x\n"; +#print "Read 2\n"; +#$x = ReadKey(0); +#print "X=$x\n"; +#ReadMode 0; +#__END__; + +my $interactive = ( @ARGV && $ARGV[0] =~ /interactive/ ); + +BEGIN { print "1 .. 8\n"; } +END { print "not ok 1\n" unless $loaded } +use Term::ReadKey; + +$loaded = 1; +print "ok 1\n"; + +use Fcntl; + +if ( not exists $ENV{COLUMNS} ) +{ + $ENV{COLUMNS} = 80; + $ENV{LINES} = 24; +} + +if ( $^O =~ /Win32/i ) +{ + sysopen( IN, 'CONIN$', O_RDWR ) or die "Unable to open console input:$!"; + sysopen( OUT, 'CONOUT$', O_RDWR ) or die "Unable to open console output:$!"; +} +else +{ + + if ( open( IN, "</dev/tty" ) ) + { + *OUT = *IN; + die "Foo" unless -t OUT; + } + else + { + + # Okay we are going to cheat a skip + foreach my $skip ( 2 .. 8 ) + { + print "ok $skip # skip /dev/tty is absent\n"; + } + exit; + } +} + +*IN = *IN; # Make single-use warning go away +$| = 1; + +my $size1 = join( ",", GetTerminalSize( \IN ) ); +my $size2 = join( ",", GetTerminalSize("IN") ); +my $size3 = join( ",", GetTerminalSize(*IN) ); +my $size4 = join( ",", GetTerminalSize( \*IN ) ); + +if ( ( $size1 eq $size2 ) && ( $size2 eq $size3 ) && ( $size3 eq $size4 ) ) +{ + print "ok 2\n"; +} +else +{ + print "not ok 2\n"; +} + +sub makenicelist +{ + my (@list) = @_; + my ( $i, $result ); + $result = ""; + for ( $i = 0 ; $i < @list ; $i++ ) + { + $result .= ", " if $i > 0; + $result .= "and " if $i == @list - 1 and @list > 1; + $result .= $list[$i]; + } + $result; +} + +sub makenice +{ + my ($char) = $_[0]; + if ( ord($char) < 32 ) { $char = "^" . pack( "c", ord($char) + 64 ) } + elsif ( ord($char) > 126 ) { $char = ord($char) } + $char; +} + +sub makeunnice +{ + my ($char) = $_[0]; + $char =~ s/^\^(.)$/pack("c",ord($1)-64)/eg; + $char =~ s/(\d{1,3})/pack("c",$1+0)/eg; + $char; +} + +my $response; + +eval { + + if ( &Term::ReadKey::termoptions() == 1 ) + { + $response = + "Term::ReadKey is using TERMIOS, as opposed to TERMIO or SGTTY.\n"; + } + elsif ( &Term::ReadKey::termoptions() == 2 ) + { + $response = + "Term::ReadKey is using TERMIO, as opposed to TERMIOS or SGTTY.\n"; + } + elsif ( &Term::ReadKey::termoptions() == 3 ) + { + $response = + "Term::ReadKey is using SGTTY, as opposed to TERMIOS or TERMIO.\n"; + } + elsif ( &Term::ReadKey::termoptions() == 4 ) + { + $response = +"Term::ReadKey is trying to make do with stty; facilites may be limited.\n"; + } + elsif ( &Term::ReadKey::termoptions() == 5 ) + { + $response = "Term::ReadKey is using Win32 functions.\n"; + } + else + { + $response = + "Term::ReadKey could not find any way to manipulate the terminal.\n"; + } + + print "ok 3\n"; +}; + +print "not ok 3\n" if $@; + +print $response if $interactive; + +eval { + push( @modes, "O_NODELAY" ) if &Term::ReadKey::blockoptions() & 1; + push( @modes, "poll()" ) if &Term::ReadKey::blockoptions() & 2; + push( @modes, "select()" ) if &Term::ReadKey::blockoptions() & 4; + push( @modes, "Win32" ) if &Term::ReadKey::blockoptions() & 8; + + print "ok 4\n"; +}; + +print "not ok 4\n" if $@; + +if ($interactive) +{ + if ( &Term::ReadKey::blockoptions() == 0 ) + { + print "No methods found to implement non-blocking reads.\n"; + print +" (If your computer supports poll(), you might like to read through ReadKey.xs)\n"; + } + else + { + print "Non-blocking reads possible via ", makenicelist(@modes), ".\n"; + print $modes[0] . " will be used. " if @modes > 0; + print $modes[1] . " will be used for timed reads." + if @modes > 1 + and $modes[0] eq "O_NODELAY"; + print "\n"; + } +} + +eval { + @size = GetTerminalSize(OUT); + print "ok 5\n"; +}; + +print "not ok 5\n" if $@; + +if ($interactive) +{ + if ( !@size ) + { + print + "GetTerminalSize was incapable of finding the size of your terminal."; + } + else + { + print "Using GetTerminalSize, it appears that your terminal is\n"; + print "$size[0] characters wide by $size[1] high.\n\n"; + } + +} + +eval { + @speeds = GetSpeed(); + print "ok 6\n"; +}; + +print "not ok 6\n" if $@; + +if ($interactive) +{ + if (@speeds) + { + print "Apparently, you are connected at ", join( "/", @speeds ), + " baud.\n"; + } + else + { + print "GetSpeed couldn't tell your connection baud rate.\n\n"; + } + print "\n"; +} + +eval { + %chars = GetControlChars(IN); + print "ok 7\n"; +}; + +print "not ok 7\n" if $@; + +%origchars = %chars; + +if ($interactive) +{ + for $c ( keys %chars ) { $chars{$c} = makenice( $chars{$c} ) } + + print "Control chars = (", + join( ', ', map( "$_ => $chars{$_}", keys %chars ) ), ")\n"; +} + +eval { + SetControlChars( %origchars, IN ); + print "ok 8\n"; +}; + +print "not ok 8\n" if $@; + +#SetControlChars("FOOFOO"=>"Q"); +#SetControlChars("INTERRUPT"=>"\x5"); + +END { ReadMode 0, IN; } # Just if something goes weird + +exit(0) unless $interactive; + +print "\nAnd now for the interactive tests.\n"; + +print + "\nThis is ReadMode 1. It's guarranteed to give you cooked input. All the\n"; +print "signals and editing characters may be used as usual.\n"; + +ReadMode 1, IN; + +print "\nYou may enter some text here: "; + +$t = ReadLine 0, IN; + +chop $t; + +print "\nYou entered `$t'.\n"; + +ReadMode 2, IN; + +print + "\nThis is ReadMode 2. It's just like #1, but echo is turned off. Great\n"; +print "for passwords.\n"; + +print "\nYou may enter some invisible text here: "; + +$t = ReadLine 0, IN; + +chop $t; + +print "\nYou entered `$t'.\n"; + +ReadMode 3, IN; + +print + "\nI won't demonstrate ReadMode 3 here. It's your standard cbreak mode,\n"; +print + "with editing characters disabled, single character at a time input, but\n"; +print "with the control characters still enabled.\n"; + +print "\n"; + +print +"I'm now putting the terminal into ReadMode 4 and using non-blocking reads.\n"; +print + "All signals should be disabled, including xon-xoff. You should only be\n"; +print "able to exit this loop via 'q'.\n"; + +ReadMode 4, IN; +$k = ""; + +#$in = *STDIN; +$in = \*IN; # or *IN or "IN" +while ( $k ne "q" ) +{ + print "Press a key, or \"q\" to stop: "; + $count = 0; + + #print "IN = $in\n"; + $count++ while !defined( $k = ReadKey( -1, $in ) ); + + #print "IN2 = $in\n"; + print "\nYou pressed `", makenice($k), + "' after the loop rolled over $count times\n"; +} +ReadMode 0, IN; + +print "\nHere is a similar loop which times out after two seconds:\n"; + +ReadMode 4, IN; +$k = ""; + +#$in = *STDIN; +$in = \*IN; # or *IN or "IN" +while ( $k ne "q" ) +{ + print "Press a key, or \"q\" to stop: "; + $count = 0; + + #print "IN = $in\n"; + print "Timeout! " while !defined( $k = ReadKey( 2, $in ) ); + + #print "IN2 = $in\n"; + print "\nYou pressed `", makenice($k), "'\n"; +} + +print + "\nLastly, ReadMode 5, which also affects output (except under Win32).\n\n"; + +ReadMode 5, IN; + +print +"This should be a diagonal line (except under Win32): *\n*\n*\n\*\n*\n*\r\n\r\n"; +print "And this should be a moving spot:\r\n\r\n"; + +$width = ( GetTerminalSize(OUT) )[0]; +$width /= 2; +$width--; +if ( $width < 10 ) { $width = 10; } + +for ( $i = 0 ; $i < 20 ; $i += .15 ) +{ + print "\r"; + print( " " x ( ( cos($i) + 1 ) * $width ) ); + print "*"; + select( undef, undef, undef, 0.01 ); + print "\r"; + print( " " x ( ( cos($i) + 1 ) * $width ) ); + print " "; +} +print "\r "; + +print "\n\r\n"; + +ReadMode 0, IN; + +print "That's all, folks!\n"; + diff --git a/gnu/usr.bin/perl/cpan/Term-ReadKey/genchars.pl b/gnu/usr.bin/perl/cpan/Term-ReadKey/genchars.pl new file mode 100644 index 00000000000..696c55b929c --- /dev/null +++ b/gnu/usr.bin/perl/cpan/Term-ReadKey/genchars.pl @@ -0,0 +1,488 @@ +#!/usr/bin/perl + +# +# $Id: genchars.pl,v 1.1.1.1 2016/05/07 16:03:08 espie Exp $ +# +############################## +$version="1.97"; +############################## +use Config; + +use Configure; + +#sub report { +# my($prog)=join(" ",@_); +# +# my($ccflags, $ldflags, $cc, $rm) = @Config{'ccflags', 'ldflags', 'cc', 'rm'}; +# my($command, $ret); +# +# $command = $prog; +# open(F, ">temp$$.c") || die "Can't make temp file temp$$.c! $!\n"; +# print F $command; +# close F; +# +# $command = "$cc $ccflags -o temp$$ temp$$.c $ldfcrs $libcrs $ldflags -lbsd"; +# $command .= " >/dev/null 2>&1"; +# $ret = system $command; +# #if(!$ret) { system "temp$$" } +# unlink "temp$$", "temp$$.o", "temp$$.c"; +# +# return $ret; +#} + +open(CCHARS,">cchars.h") || die "Fatal error, Unable to write to cchars.h!"; + +#print "Checking for termio...\n"; +#$TERMIO = !report( "#include <termio.h>\n struct termios s; main(){}"); +#print " Termio ",($TERMIO?"":"NOT "),"found.\n"; + +#print "Checking for termios...\n"; +#$TERMIOS = !report( "#include <termios.h>\n struct termio s; main(){}"); +#print " Termios ",($TERMIOS?"":"NOT "),"found.\n"; + +#print "Checking for sgtty...\n"; +#$SGTTY = !report( "#include <sgtty.h>\n struct sgttyb s; main(){}"); +#print " Sgtty ",($SGTTY?"":"NOT "),"found.\n"; + +#print "Termio=$TERMIO, Termios=$TERMIOS, Sgtty=$SGTTY\n"; + +# Control characters used for termio and termios +%possible = ( VINTR => "INTERRUPT", + VQUIT => "QUIT", + VERASE => "ERASE", + VKILL => "KILL", + VEOF => "EOF", + VTIME => "TIME", + VMIN => "MIN", + VSWTC => "SWITCH", + VSWTCH => "SWITCH", + VSTART => "START", + VSTOP => "STOP", + VSUSP => "SUSPEND", + VDSUSP => "DSUSPEND", + VEOL => "EOL", + VREPRINT => "REPRINT", + VDISCARD => "DISCARD", + VFLUSH => "DISCARD", + VWERASE => "ERASEWORD", + VLNEXT => "QUOTENEXT", + VQUOTE => "QUOTENEXT", + VEOL2 => "EOL2", + VSTATUS => "STATUS", +); + +# Control characters for sgtty +%possible2 = ( "intrc" => "INTERRUPT", + "quitc" => "QUIT", + "eofc" => "EOF", + "startc"=> "START", + "stopc" => "STOP", + "brkc" => "EOL", + "eolc" => "EOL", + "suspc" => "SUSPEND", + "dsuspc"=> "DSUSPEND", + "rprntc"=> "REPRINT", + "flushc"=> "DISCARD", + "lnextc"=> "QUOTENEXT", + "werasc"=> "ERASEWORD", +); + +print CCHARS " + +/* Written by genchars.pl version $version */ + +"; + +print CCHARS "#define HAVE_POLL_H\n" if CheckHeader("poll.h"); +print CCHARS "#define HAVE_SYS_POLL_H\n" if CheckHeader("sys/poll.h"); + +print "\n"; +if(1) { + @values = sort { $possible{$a} cmp $possible{$b} or $a cmp $b } keys %possible; + + print "Writing termio/termios section of cchars.h... "; + print CCHARS " + +#ifdef CC_TERMIOS +# define TermStructure struct termios +# ifdef NCCS +# define LEGALMAXCC NCCS +# else +# ifdef NCC +# define LEGALMAXCC NCC +# endif +# endif +#else +# ifdef CC_TERMIO +# define TermStructure struct termio +# ifdef NCC +# define LEGALMAXCC NCC +# else +# ifdef NCCS +# define LEGALMAXCC NCCS +# endif +# endif +# endif +#endif + +#if !defined(LEGALMAXCC) +# define LEGALMAXCC 126 +#endif + +#if defined(CC_TERMIO) || defined(CC_TERMIOS) + +char * cc_names[] = { ".join('',map(" +#if defined($_) && ($_ < LEGALMAXCC) + \"$possible{$_}\", "." +#else "." + \"\", "." +#endif ", @values ))." +}; + +const int MAXCC = 0 ",join('',map(" +#if defined($_) && ($_ < LEGALMAXCC) + +1 /* $possible{$_} */ +#endif ", @values ))." + ; + +XS(XS_Term__ReadKey_GetControlChars) +{ + dXSARGS; + if (items < 0 || items > 1) { + croak(\"Usage: Term::ReadKey::GetControlChars()\"); + } + SP -= items; + { + PerlIO * file; + TermStructure s; + if (items < 1) + file = STDIN; + else { + file = IoIFP(sv_2io(ST(0))); + } + +#ifdef CC_TERMIOS + if(tcgetattr(PerlIO_fileno(file),&s)) +#else +# ifdef CC_TERMIO + if(ioctl(PerlIO_fileno(file),TCGETA,&s)) +# endif +#endif + croak(\"Unable to read terminal settings in GetControlChars\"); + else { + EXTEND(sp,MAXCC*2); ".join('',map(" +#if defined($values[$_]) && ($values[$_] < LEGALMAXCC) "." +PUSHs(sv_2mortal(newSVpv(cc_names[$_],strlen(cc_names[$_])))); /* $possible{$values[$_]} */ +PUSHs(sv_2mortal(newSVpv((char*)&s.c_cc[$values[$_]],1))); "." +#endif " ,0..$#values))." + + } + PUTBACK; + return; + } +} + +XS(XS_Term__ReadKey_SetControlChars) +{ + dXSARGS; + /*if ((items % 2) != 0) { + croak(\"Usage: Term::ReadKey::SetControlChars(%charpairs,file=STDIN)\"); + }*/ + SP -= items; + { + TermStructure s; + PerlIO * file; + if ((items % 2) == 1) + file = IoIFP(sv_2io(ST(items-1))); + else { + file = STDIN; + } + +#ifdef CC_TERMIOS + if(tcgetattr(PerlIO_fileno(file),&s)) +#else +# ifdef CC_TERMIO + if(ioctl(PerlIO_fileno(file),TCGETA,&s)) +# endif +#endif + croak(\"Unable to read terminal settings in SetControlChars\"); + else { + int i; + char * name, value; + for(i=0;i+1<items;i+=2) { + name = SvPV(ST(i),PL_na); + if( SvIOKp(ST(i+1)) || SvNOKp(ST(i+1)) )/* If Int or Float */ + value = (char)SvIV(ST(i+1)); /* Store int value */ + else /* Otherwise */ + value = SvPV(ST(i+1),PL_na)[0]; /* Use first char of PV */ + + if (0) ; ".join('',map(" +#if defined($values[$_]) && ($values[$_] < LEGALMAXCC) "." + else if(strcmp(name,cc_names[$_])==0) /* $possible{$values[$_]} */ + s.c_cc[$values[$_]] = value; "." +#endif ",0..$#values))." + else + croak(\"Invalid control character passed to SetControlChars\"); + + } +#ifdef CC_TERMIOS + if(tcsetattr(PerlIO_fileno(file),TCSANOW,&s)) +#else +# ifdef CC_TERMIO + if(ioctl(PerlIO_fileno(file),TCSETA,&s)) +# endif +#endif + croak(\"Unable to write terminal settings in SetControlChars\"); + } + } + XSRETURN(1); +} + + +#endif + +"; + + print "Done.\n"; + +} + +undef %billy; + +if(@ARGV) { # If any argument is supplied on the command-line don't check sgtty + $SGTTY=0; #skip tests +} else { + print "Checking for sgtty...\n"; + + $SGTTY = CheckStructure "sgttyb","sgtty.h"; +# $SGTTY = !Compile(" +##include <sgtty.h> +#struct sgttyb s; +#main(){ +#ioctl(0,TIOCGETP,&s); +#}"); + +#} + +# $SGTTY = !report(" +##include <sgtty.h> +#struct sgttyb s; +#main(){ +#ioctl(0,TIOCGETP,&s); +#}"); + + print " Sgtty ",($SGTTY?"":"NOT "),"found.\n"; +} + +$billy{"ERASE"} = "s1.sg_erase"; +$billy{"KILL"} = "s1.sg_kill"; +$tchars=$ltchars=0; + +if($SGTTY) { + + print "Checking sgtty...\n"; + + $tchars = CheckStructure "tchars","sgtty.h"; +# $tchars = !report( ' +##include <sgtty.h> +#struct tchars t; +#main() { ioctl(0,TIOCGETC,&t); } +#'); + print " tchars structure found.\n" if $tchars; + + $ltchars = CheckStructure "ltchars","sgtty.h"; +# $ltchars = !report( ' +##include <sgtty.h> +#struct ltchars t; +#main() { ioctl(0,TIOCGLTC,&t); } +#'); + + print " ltchars structure found.\n" if $ltchars; + + + print "Checking symbols\n"; + + + for $c (sort keys %possible2) { + +# if($tchars and !report(" +##include <sgtty.h> +#struct tchars s2; +#main () { char c = s2.t_$c; } +#")) { + if($tchars and CheckField("tchars","t_$c","sgtty.h")) { + + print " t_$c ($possible2{$c}) found in tchars\n"; + $billy{$possible2{$c}} = "s2.t_$c"; + } + +# elsif($ltchars and !report(" +##include <sgtty.h> +#struct ltchars s3; +#main () { char c = s3.t_$c; } +#")) { + elsif($ltchars and CheckField("ltchars","t_$c","sgtty.h")) { + print " t_$c ($possible2{$c}) found in ltchars\n"; + $billy{$possible2{$c}} = "s3.t_$c"; + } + + } + + + #undef @names; + #undef @values; + #for $v (sort keys %billy) { + # push(@names,$billy{$v}); + # push(@values,$v); + #} + + #$numchars = keys %billy; + +} + +@values = sort keys %billy; + + $struct = " +struct termstruct { + struct sgttyb s1; +"; + $struct .= " + struct tchars s2; +" if $tchars; + $struct .= " + struct ltchars s3; +" if $ltchars; + $struct .= " +};"; + +print "Writing sgtty section of cchars.h... "; + + print CCHARS " + +#ifdef CC_SGTTY +$struct +#define TermStructure struct termstruct + +char * cc_names[] = { ".join('',map(" + \"$_\", ", @values ))." +}; + +#define MAXCC ". ($#values+1)." + +XS(XS_Term__ReadKey_GetControlChars) +{ + dXSARGS; + if (items < 0 || items > 1) { + croak(\"Usage: Term::ReadKey::GetControlChars()\"); + } + SP -= items; + { + PerlIO * file; + TermStructure s; + if (items < 1) + file = STDIN; + else { + file = IoIFP(sv_2io(ST(0))); + } + if(ioctl(fileno(PerlIO_file),TIOCGETP,&s.s1) ".($tchars?" + ||ioctl(fileno(PerlIO_file),TIOCGETC,&s.s2) ":'').($ltchars?" + ||ioctl(fileno(PerlIO_file),TIOCGLTC,&s.s3) ":'')." + ) + croak(\"Unable to read terminal settings in GetControlChars\"); + else { + int i; + EXTEND(sp,MAXCC*2); ".join('',map(" +PUSHs(sv_2mortal(newSVpv(cc_names[$_],strlen(cc_names[$_])))); /* $values[$_] */ +PUSHs(sv_2mortal(newSVpv(&s.$billy{$values[$_]},1))); ",0..$#values))." + + } + PUTBACK; + return; + } +} + +XS(XS_Term__ReadKey_SetControlChars) +{ + dXSARGS; + /*if ((items % 2) != 0) { + croak(\"Usage: Term::ReadKey::SetControlChars(%charpairs,file=STDIN)\"); + }*/ + SP -= items; + { + PerlIO * file; + TermStructure s; + if ((items%2)==0) + file = STDIN; + else { + file = IoIFP(sv_2io(ST(items-1))); + } + + if(ioctl(PerlIO_fileno(file),TIOCGETP,&s.s1) ".($tchars?" + ||ioctl(fileno(PerlIO_file),TIOCGETC,&s.s2) ":'').($ltchars?" + ||ioctl(fileno(PerlIO_file),TIOCGLTC,&s.s3) ":'')." + ) + croak(\"Unable to read terminal settings in SetControlChars\"); + else { + int i; + char * name, value; + for(i=0;i+1<items;i+=2) { + name = SvPV(ST(i),PL_na); + if( SvIOKp(ST(i+1)) || SvNOKp(ST(i+1)) )/* If Int or Float */ + value = (char)SvIV(ST(i+1)); /* Store int value */ + else /* Otherwise */ + value = SvPV(ST(i+1),PL_na)[0]; /* Use first char of PV */ + + if (0) ; ".join('',map(" + else if(strcmp(name,cc_names[$_])==0) /* $values[$_] */ + s.$billy{$values[$_]} = value; ",0..$#values))." + else + croak(\"Invalid control character passed to SetControlChars\"); + + } + if(ioctl(fileno(PerlIO_file),TIOCSETN,&s.s1) ".($tchars?" + ||ioctl(fileno(PerlIO_file),TIOCSETC,&s.s2) ":'').($ltchars?" + ||ioctl(fileno(PerlIO_file),TIOCSLTC,&s.s3) ":'')." + ) croak(\"Unable to write terminal settings in SetControlChars\"); + } + } + XSRETURN(1); +} + +#endif + +#if !defined(CC_TERMIO) && !defined(CC_TERMIOS) && !defined(CC_SGTTY) +#define TermStructure int +XS(XS_Term__ReadKey_GetControlChars) +{ + dXSARGS; + if (items <0 || items>1) { + croak(\"Usage: Term::ReadKey::GetControlChars([FileHandle])\"); + } + SP -= items; + { + ST(0) = sv_newmortal(); + PUTBACK; + return; + } +} + +XS(XS_Term__ReadKey_SetControlChars) +{ + dXSARGS; + if (items < 0 || items > 1) { + croak(\"Invalid control character passed to SetControlChars\"); + } + SP -= items; + XSRETURN(1); +} + +#endif + +"; + +print "Done.\n"; + + + + + diff --git a/gnu/usr.bin/perl/cpan/Term-ReadKey/ppport.h b/gnu/usr.bin/perl/cpan/Term-ReadKey/ppport.h new file mode 100644 index 00000000000..99b6fa6e351 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/Term-ReadKey/ppport.h @@ -0,0 +1,7452 @@ +#if 0 +<<'SKIP'; +#endif +/* +---------------------------------------------------------------------- + + ppport.h -- Perl/Pollution/Portability Version 3.21 + + Automatically created by Devel::PPPort running under perl 5.014004. + + 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.21 + +=head1 SYNOPSIS + + perl ppport.h [options] [source files] + + Searches current directory for files if no [source files] are given + + --help show short help + + --version show version + + --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 + --nofilter don't filter input files + + --strip strip all script and doc functionality from + ppport.h + + --list-provided list provided API + --list-unsupported list unsupported API + --api-info=name show Perl API portability information + +=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.11.5. + +=head1 OPTIONS + +=head2 --help + +Display a brief usage summary. + +=head2 --version + +Display the version of F<ppport.h>. + +=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. Note that this does not +automagially add a dot between the original filename and the +suffix. If you want the dot, you have to include it in the option +argument. + +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 +down 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. Warnings will still be displayed. + +=head2 --nochanges + +Don't suggest any changes. Only give diagnostic output and hints +unless these are also deactivated. + +=head2 --nofilter + +Don't filter the list of input files. By default, files not looking +like source code (i.e. not *.xs, *.c, *.cc, *.cpp or *.h) are skipped. + +=head2 --strip + +Strip all script and documentation functionality from F<ppport.h>. +This reduces the size of F<ppport.h> dramatically and may be useful +if you want to include F<ppport.h> in smaller modules without +increasing their distribution size too much. + +The stripped F<ppport.h> will have a C<--unstrip> option that allows +you to undo the stripping, but only if an appropriate C<Devel::PPPort> +module is installed. + +=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 or warnings 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. + +=head2 --api-info=I<name> + +Show portability information for API elements matching I<name>. +If I<name> is surrounded by slashes, it is interpreted as a regular +expression. + +=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 or variables 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 or variables 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 or variables, you want either C<static> or global +variants. + +For a C<static> function or variable (used only in a single source +file), use: + + #define NEED_function + #define NEED_variable + +For a global function or variable (used in multiple source files), +use: + + #define NEED_function_GLOBAL + #define NEED_variable_GLOBAL + +Note that you mustn't have more than one global request for the +same function or variable in your project. + + Function / Variable Static Request Global Request + ----------------------------------------------------------------------------------------- + PL_parser NEED_PL_parser NEED_PL_parser_GLOBAL + PL_signals NEED_PL_signals NEED_PL_signals_GLOBAL + 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 + load_module() NEED_load_module NEED_load_module_GLOBAL + my_snprintf() NEED_my_snprintf NEED_my_snprintf_GLOBAL + my_sprintf() NEED_my_sprintf NEED_my_sprintf_GLOBAL + my_strlcat() NEED_my_strlcat NEED_my_strlcat_GLOBAL + my_strlcpy() NEED_my_strlcpy NEED_my_strlcpy_GLOBAL + newCONSTSUB() NEED_newCONSTSUB NEED_newCONSTSUB_GLOBAL + newRV_noinc() NEED_newRV_noinc NEED_newRV_noinc_GLOBAL + newSV_type() NEED_newSV_type NEED_newSV_type_GLOBAL + newSVpvn_flags() NEED_newSVpvn_flags NEED_newSVpvn_flags_GLOBAL + newSVpvn_share() NEED_newSVpvn_share NEED_newSVpvn_share_GLOBAL + pv_display() NEED_pv_display NEED_pv_display_GLOBAL + pv_escape() NEED_pv_escape NEED_pv_escape_GLOBAL + pv_pretty() NEED_pv_pretty NEED_pv_pretty_GLOBAL + sv_2pv_flags() NEED_sv_2pv_flags NEED_sv_2pv_flags_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_pvn_force_flags() NEED_sv_pvn_force_flags NEED_sv_pvn_force_flags_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 + vload_module() NEED_vload_module NEED_vload_module_GLOBAL + vnewSVpvf() NEED_vnewSVpvf NEED_vnewSVpvf_GLOBAL + warner() NEED_warner NEED_warner_GLOBAL + +To avoid namespace conflicts, you can change the namespace of the +explicitly exported functions / variables 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. + +If you want to create patched copies of your files instead, use: + + perl ppport.h --copy=.new + +To display portability information for the C<newSVpvn> function, +use: + + perl ppport.h --api-info=newSVpvn + +Since the argument to C<--api-info> can be a regular expression, +you can use + + perl ppport.h --api-info=/_nomg$/ + +to display portability information for all C<_nomg> functions or + + perl ppport.h --api-info=/./ + +to display information for all known API elements. + +=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-2013, 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; + +# Disable broken TRIE-optimization +BEGIN { eval '${^RE_TRIE_MAXBUF} = -1' if $] >= 5.009004 && $] <= 5.009005 } + +my $VERSION = 3.21; + +my %opt = ( + quiet => 0, + diag => 1, + hints => 1, + changes => 1, + cplusplus => 0, + filter => 1, + strip => 0, + version => 0, +); + +my($ppport) = $0 =~ /([\w.]+)$/; +my $LF = '(?:\r\n|[\r\n])'; # line feed +my $HS = "[ \t]"; # horizontal whitespace + +# Never use C comments in this file! +my $ccs = '/'.'*'; +my $cce = '*'.'/'; +my $rccs = quotemeta $ccs; +my $rcce = quotemeta $cce; + +eval { + require Getopt::Long; + Getopt::Long::GetOptions(\%opt, qw( + help quiet diag! filter! hints! changes! cplusplus strip version + patch=s copy=s diff=s compat-version=s + list-provided list-unsupported api-info=s + )) or usage(); +}; + +if ($@ and grep /^-/, @ARGV) { + usage() if "@ARGV" =~ /^--?h(?:elp)?$/; + die "Getopt::Long not found. Please don't use any options.\n"; +} + +if ($opt{version}) { + print "This is $0 $VERSION.\n"; + exit 0; +} + +usage() if $opt{help}; +strip() if $opt{strip}; + +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 || $s >= 1000; + $opt{'compat-version'} = sprintf "%d.%03d%03d", $r, $v, $s; +} +else { + $opt{'compat-version'} = 5; +} + +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||| +BhkDISABLE||5.019003| +BhkENABLE||5.019003| +BhkENTRY_set||5.019003| +BhkENTRY||| +BhkFLAGS||| +CALL_BLOCK_HOOKS||| +CLASS|||n +CPERLscope|5.005000||p +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|5.004050|p +Copy||5.004050| +CvPADLIST||5.008001| +CvSTASH||| +CvWEAKOUTSIDE||| +DEFSV_set|5.010001||p +DEFSV|5.004050||p +END_EXTERN_C|5.005000||p +ENTER||| +ERRSV|5.004050||p +EXTEND||| +EXTERN_C|5.005000||p +F0convert|||n +FREETMPS||| +GIMME_V||5.004000|n +GIMME|||n +GROK_NUMERIC_RADIX|5.007002||p +G_ARRAY||| +G_DISCARD||| +G_EVAL||| +G_METHOD|5.006001||p +G_NOARGS||| +G_SCALAR||| +G_VOID||5.004000| +GetVars||| +GvAV||| +GvCV||| +GvHV||| +GvSVn|5.009003||p +GvSV||| +Gv_AMupdate||5.011000| +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| +HeUTF8||5.010001| +HeVAL||5.004000| +HvENAMELEN||5.015004| +HvENAMEUTF8||5.015004| +HvENAME||5.013007| +HvNAMELEN_get|5.009003||p +HvNAMELEN||5.015004| +HvNAMEUTF8||5.015004| +HvNAME_get|5.009003||p +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||| +LINKLIST||5.013006| +LVRET||| +MARK||| +MULTICALL||5.019003| +MY_CXT_CLONE|5.009002||p +MY_CXT_INIT|5.007003||p +MY_CXT|5.007003||p +MoveD|5.009002|5.004050|p +Move||5.004050| +NOOP|5.005000||p +NUM2PTR|5.006000||p +NVTYPE|5.006000||p +NVef|5.006001||p +NVff|5.006001||p +NVgf|5.006001||p +Newxc|5.009003||p +Newxz|5.009003||p +Newx|5.009003||p +Nullav||| +Nullch||| +Nullcv||| +Nullhv||| +Nullsv||| +OP_CLASS||5.013007| +OP_DESC||5.007003| +OP_NAME||5.007003| +ORIGMARK||| +PAD_BASE_SV||| +PAD_CLONE_VARS||| +PAD_COMPNAME_FLAGS||| +PAD_COMPNAME_GEN_set||| +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||| +PERLIO_FUNCS_CAST|5.009003||p +PERLIO_FUNCS_DECL|5.009003||p +PERL_ABS|5.008001||p +PERL_BCDVERSION|5.019002||p +PERL_GCC_BRACE_GROUPS_FORBIDDEN|5.008001||p +PERL_HASH|5.004000||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.019002||p +PERL_MAGIC_isaelem|5.007002||p +PERL_MAGIC_isa|5.007002||p +PERL_MAGIC_mutex|5.019002||p +PERL_MAGIC_nkeys|5.007002||p +PERL_MAGIC_overload_elem|5.019002||p +PERL_MAGIC_overload_table|5.007002||p +PERL_MAGIC_overload|5.019002||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_PV_ESCAPE_ALL|5.009004||p +PERL_PV_ESCAPE_FIRSTCHAR|5.009004||p +PERL_PV_ESCAPE_NOBACKSLASH|5.009004||p +PERL_PV_ESCAPE_NOCLEAR|5.009004||p +PERL_PV_ESCAPE_QUOTE|5.009004||p +PERL_PV_ESCAPE_RE|5.009005||p +PERL_PV_ESCAPE_UNI_DETECT|5.009004||p +PERL_PV_ESCAPE_UNI|5.009004||p +PERL_PV_PRETTY_DUMP|5.009004||p +PERL_PV_PRETTY_ELLIPSES|5.010000||p +PERL_PV_PRETTY_LTGT|5.009004||p +PERL_PV_PRETTY_NOCLEAR|5.010000||p +PERL_PV_PRETTY_QUOTE|5.009004||p +PERL_PV_PRETTY_REGPROP|5.009004||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_SIGNALS_UNSAFE_FLAG|5.008001||p +PERL_SUBVERSION|5.006000||p +PERL_SYS_INIT3||5.010000| +PERL_SYS_INIT||5.010000| +PERL_SYS_TERM||5.019003| +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_ARG|5.009003||p +PERL_UNUSED_CONTEXT|5.009004||p +PERL_UNUSED_DECL|5.007002||p +PERL_UNUSED_VAR|5.007002||p +PERL_UQUAD_MAX|5.004000||p +PERL_UQUAD_MIN|5.004000||p +PERL_USE_GCC_BRACE_GROUPS|5.009004||p +PERL_USHORT_MAX|5.004000||p +PERL_USHORT_MIN|5.004000||p +PERL_VERSION|5.006000||p +PL_DBsignal|5.005000||p +PL_DBsingle|||pn +PL_DBsub|||pn +PL_DBtrace|||pn +PL_Sv|5.005000||p +PL_bufend|5.019002||p +PL_bufptr|5.019002||p +PL_check||5.006000| +PL_compiling|5.004050||p +PL_comppad_name||5.017004| +PL_comppad||5.008001| +PL_copline|5.019002||p +PL_curcop|5.004050||p +PL_curpad||5.005000| +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_error_count|5.019002||p +PL_expect|5.019002||p +PL_hexdigit|5.005000||p +PL_hints|5.005000||p +PL_in_my_stash|5.019002||p +PL_in_my|5.019002||p +PL_keyword_plugin||5.011002| +PL_last_in_gv|||n +PL_laststatval|5.005000||p +PL_lex_state|5.019002||p +PL_lex_stuff|5.019002||p +PL_linestr|5.019002||p +PL_modglobal||5.005000|n +PL_na|5.004050||pn +PL_no_modify|5.006000||p +PL_ofsgv|||n +PL_opfreehook||5.011000|n +PL_parser|5.009005|5.009005|p +PL_peepp||5.007003|n +PL_perl_destruct_level|5.004050||p +PL_perldb|5.004050||p +PL_ppaddr|5.006000||p +PL_rpeepp||5.013005|n +PL_rsfp_filters|5.019002||p +PL_rsfp|5.019002||p +PL_rs|||n +PL_signals|5.008001||p +PL_stack_base|5.004050||p +PL_stack_sp|5.004050||p +PL_statcache|5.005000||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 +PL_tokenbuf|5.019002||p +POP_MULTICALL||5.019003| +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 +PTR2nat|5.009003||p +PTR2ul|5.007001||p +PTRV|5.006000||p +PUSHMARK||| +PUSH_MULTICALL||5.019003| +PUSHi||| +PUSHmortal|5.009002||p +PUSHn||| +PUSHp||| +PUSHs||| +PUSHu|5.004000||p +PUTBACK||| +PadARRAY||5.019003| +PadMAX||5.019003| +PadlistARRAY||5.019003| +PadlistMAX||5.019003| +PadlistNAMESARRAY||5.019003| +PadlistNAMESMAX||5.019003| +PadlistNAMES||5.019003| +PadlistREFCNT||5.017004| +PadnameIsOUR||| +PadnameIsSTATE||| +PadnameLEN||5.019003| +PadnameOURSTASH||| +PadnameOUTER||| +PadnamePV||5.019003| +PadnameSV||5.019003| +PadnameTYPE||| +PadnameUTF8||5.019003| +PadnamelistARRAY||5.019003| +PadnamelistMAX||5.019003| +PerlIO_clearerr||5.007003| +PerlIO_close||5.007003| +PerlIO_context_layers||5.009004| +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| +Perl_signbit||5.009005|n +PoisonFree|5.009004||p +PoisonNew|5.009004||p +PoisonWith|5.009004||p +Poison|5.008000||p +READ_XDIGIT||5.017006| +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 +STR_WITH_LEN|5.009003||p +ST||| +SV_CONST_RETURN|5.009003||p +SV_COW_DROP_PV|5.008001||p +SV_COW_SHARED_HASH_KEYS|5.009005||p +SV_GMAGIC|5.007002||p +SV_HAS_TRAILING_NUL|5.009004||p +SV_IMMEDIATE_UNREF|5.007001||p +SV_MUTABLE_RETURN|5.009003||p +SV_NOSTEAL|5.009002||p +SV_SMAGIC|5.009003||p +SV_UTF8_NO_ENCODING|5.008001||p +SVfARG|5.009005||p +SVf_UTF8|5.006000||p +SVf|5.006000||p +SVt_INVLIST||5.019002| +SVt_IV||| +SVt_NULL||| +SVt_NV||| +SVt_PVAV||| +SVt_PVCV||| +SVt_PVFM||| +SVt_PVGV||| +SVt_PVHV||| +SVt_PVIO||| +SVt_PVIV||| +SVt_PVLV||| +SVt_PVMG||| +SVt_PVNV||| +SVt_PV||| +SVt_REGEXP||5.011000| +Safefree||| +Slab_Alloc||| +Slab_Free||| +Slab_to_ro||| +Slab_to_rw||| +StructCopy||| +SvCUR_set||| +SvCUR||| +SvEND||| +SvGAMAGIC||5.006001| +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 +SvIV_set||| +SvIVx||| +SvIV||| +SvIsCOW_shared_hash||5.008003| +SvIsCOW||5.008003| +SvLEN_set||| +SvLEN||| +SvLOCK||5.007003| +SvMAGIC_set|5.009003||p +SvNIOK_off||| +SvNIOKp||| +SvNIOK||| +SvNOK_off||| +SvNOK_only||| +SvNOK_on||| +SvNOKp||| +SvNOK||| +SvNVX||| +SvNV_nomg||5.013002| +SvNV_set||| +SvNVx||| +SvNV||| +SvOK||| +SvOOK_offset||5.011000| +SvOOK||| +SvPOK_off||| +SvPOK_only_UTF8||5.006000| +SvPOK_only||| +SvPOK_on||| +SvPOKp||| +SvPOK||| +SvPVX_const|5.009003||p +SvPVX_mutable|5.009003||p +SvPVX||| +SvPV_const|5.009003||p +SvPV_flags_const_nolen|5.009003||p +SvPV_flags_const|5.009003||p +SvPV_flags_mutable|5.009003||p +SvPV_flags|5.007002||p +SvPV_force_flags_mutable|5.009003||p +SvPV_force_flags_nolen|5.009003||p +SvPV_force_flags|5.007002||p +SvPV_force_mutable|5.009003||p +SvPV_force_nolen|5.009003||p +SvPV_force_nomg_nolen|5.009003||p +SvPV_force_nomg|5.007002||p +SvPV_force|||p +SvPV_mutable|5.009003||p +SvPV_nolen_const|5.009003||p +SvPV_nolen|5.006000||p +SvPV_nomg_const_nolen|5.009003||p +SvPV_nomg_const|5.009003||p +SvPV_nomg_nolen|5.013007||p +SvPV_nomg|5.007002||p +SvPV_renew|5.009003||p +SvPV_set||| +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_NN||5.017007| +SvREFCNT_dec||| +SvREFCNT_inc_NN|5.009004||p +SvREFCNT_inc_simple_NN|5.009004||p +SvREFCNT_inc_simple_void_NN|5.009004||p +SvREFCNT_inc_simple_void|5.009004||p +SvREFCNT_inc_simple|5.009004||p +SvREFCNT_inc_void_NN|5.009004||p +SvREFCNT_inc_void|5.009004||p +SvREFCNT_inc|||p +SvREFCNT||| +SvROK_off||| +SvROK_on||| +SvROK||| +SvRV_set|5.009003||p +SvRV||| +SvRXOK||5.009005| +SvRX||5.009005| +SvSETMAGIC||| +SvSHARED_HASH|5.009003||p +SvSHARE||5.007003| +SvSTASH_set|5.009003||p +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||| +SvTHINKFIRST||| +SvTRUE_nomg||5.013006| +SvTRUE||| +SvTYPE||| +SvUNLOCK||5.007003| +SvUOK|5.007001|5.006000|p +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 +SvUV_set|5.009003||p +SvUVx|5.004000||p +SvUV|5.004000||p +SvVOK||5.008001| +SvVSTRING_mg|5.009004||p +THIS|||n +UNDERBAR|5.009002||p +UTF8_MAXBYTES|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 +WARN_ALL|5.006000||p +WARN_AMBIGUOUS|5.006000||p +WARN_ASSERTIONS|5.019002||p +WARN_BAREWORD|5.006000||p +WARN_CLOSED|5.006000||p +WARN_CLOSURE|5.006000||p +WARN_DEBUGGING|5.006000||p +WARN_DEPRECATED|5.006000||p +WARN_DIGIT|5.006000||p +WARN_EXEC|5.006000||p +WARN_EXITING|5.006000||p +WARN_GLOB|5.006000||p +WARN_INPLACE|5.006000||p +WARN_INTERNAL|5.006000||p +WARN_IO|5.006000||p +WARN_LAYER|5.008000||p +WARN_MALLOC|5.006000||p +WARN_MISC|5.006000||p +WARN_NEWLINE|5.006000||p +WARN_NUMERIC|5.006000||p +WARN_ONCE|5.006000||p +WARN_OVERFLOW|5.006000||p +WARN_PACK|5.006000||p +WARN_PARENTHESIS|5.006000||p +WARN_PIPE|5.006000||p +WARN_PORTABLE|5.006000||p +WARN_PRECEDENCE|5.006000||p +WARN_PRINTF|5.006000||p +WARN_PROTOTYPE|5.006000||p +WARN_QW|5.006000||p +WARN_RECURSION|5.006000||p +WARN_REDEFINE|5.006000||p +WARN_REGEXP|5.006000||p +WARN_RESERVED|5.006000||p +WARN_SEMICOLON|5.006000||p +WARN_SEVERE|5.006000||p +WARN_SIGNAL|5.006000||p +WARN_SUBSTR|5.006000||p +WARN_SYNTAX|5.006000||p +WARN_TAINT|5.006000||p +WARN_THREADS|5.008000||p +WARN_UNINITIALIZED|5.006000||p +WARN_UNOPENED|5.006000||p +WARN_UNPACK|5.006000||p +WARN_UNTIE|5.006000||p +WARN_UTF8|5.006000||p +WARN_VOID|5.006000||p +WIDEST_UTYPE|5.015004||p +XCPT_CATCH|5.009002||p +XCPT_RETHROW|5.009002|5.007001|p +XCPT_TRY_END|5.009002|5.004000|p +XCPT_TRY_START|5.009002|5.004000|p +XPUSHi||| +XPUSHmortal|5.009002||p +XPUSHn||| +XPUSHp||| +XPUSHs||| +XPUSHu|5.004000||p +XSPROTO|5.010000||p +XSRETURN_EMPTY||| +XSRETURN_IV||| +XSRETURN_NO||| +XSRETURN_NV||| +XSRETURN_PV||| +XSRETURN_UNDEF||| +XSRETURN_UV|5.008001||p +XSRETURN_YES||| +XSRETURN|||p +XST_mIV||| +XST_mNO||| +XST_mNV||| +XST_mPV||| +XST_mUNDEF||| +XST_mUV|5.008001||p +XST_mYES||| +XS_APIVERSION_BOOTCHECK||5.013004| +XS_EXTERNAL||5.019003| +XS_INTERNAL||5.019003| +XS_VERSION_BOOTCHECK||| +XS_VERSION||| +XSprePUSH|5.006000||p +XS||| +XopDISABLE||5.019003| +XopENABLE||5.019003| +XopENTRY_set||5.019003| +XopENTRY||5.019003| +XopFLAGS||5.013007| +ZeroD|5.009002||p +Zero||| +_aMY_CXT|5.007003||p +_add_range_to_invlist||| +_append_range_to_invlist||| +_core_swash_init||| +_get_swash_invlist||| +_invlist_array_init||| +_invlist_contains_cp||| +_invlist_contents||| +_invlist_dump||| +_invlist_intersection_maybe_complement_2nd||| +_invlist_intersection||| +_invlist_invert_prop||| +_invlist_invert||| +_invlist_len||| +_invlist_populate_swatch||| +_invlist_search||| +_invlist_subtract||| +_invlist_union_maybe_complement_2nd||| +_invlist_union||| +_is_uni_FOO||5.017008| +_is_uni_perl_idcont||5.017008| +_is_uni_perl_idstart||5.017007| +_is_utf8_FOO||5.017008| +_is_utf8_mark||5.017008| +_is_utf8_perl_idcont||5.017008| +_is_utf8_perl_idstart||5.017007| +_new_invlist_C_array||| +_new_invlist||| +_pMY_CXT|5.007003||p +_swash_inversion_hash||| +_swash_to_invlist||| +_to_fold_latin1||| +_to_uni_fold_flags||5.013011| +_to_upper_title_latin1||| +_to_utf8_fold_flags||5.015006| +_to_utf8_lower_flags||5.015006| +_to_utf8_title_flags||5.015006| +_to_utf8_upper_flags||5.015006| +aMY_CXT_|5.007003||p +aMY_CXT|5.007003||p +aTHXR_|5.019002||p +aTHXR|5.019002||p +aTHX_|5.006000||p +aTHX|5.006000||p +aassign_common_vars||| +add_cp_to_invlist||| +add_data|||n +add_utf16_textfilter||| +addmad||| +adjust_size_and_find_bucket|||n +adjust_stack_on_leave||| +alloc_maybe_populate_EXACT||| +alloccopstash||| +allocmy||| +amagic_call||| +amagic_cmp_locale||| +amagic_cmp||| +amagic_deref_call||5.013007| +amagic_i_ncmp||| +amagic_is_enabled||| +amagic_ncmp||| +anonymise_cv_maybe||| +any_dup||| +ao||| +append_madprops||| +apply_attrs_my||| +apply_attrs_string||5.006001| +apply_attrs||| +apply||| +assert_uft8_cache_coherent||| +atfork_lock||5.007003|n +atfork_unlock||5.007003|n +av_arylen_p||5.009003| +av_clear||| +av_create_and_push||5.009005| +av_create_and_unshift_one||5.009005| +av_delete||5.006000| +av_exists||5.006000| +av_extend_guts||| +av_extend||| +av_fetch||| +av_fill||| +av_iter_p||5.011000| +av_len||| +av_make||| +av_pop||| +av_push||| +av_reify||| +av_shift||| +av_store||| +av_tindex||5.017009| +av_top_index||5.017009| +av_undef||| +av_unshift||| +ax|||n +bad_type_gv||| +bad_type_pv||| +bind_match||| +block_end||| +block_gimme||5.004000| +block_start||| +blockhook_register||5.013003| +boolSV|5.004000||p +boot_core_PerlIO||| +boot_core_UNIVERSAL||| +boot_core_mro||| +bytes_cmp_utf8||5.013007| +bytes_from_utf8||5.007001| +bytes_to_uni|||n +bytes_to_utf8||5.006001| +call_argv|5.006000||p +call_atexit||5.006000| +call_list||5.004000| +call_method|5.006000||p +call_pv|5.006000||p +call_sv|5.006000||p +caller_cx||5.013005| +calloc||5.007002|n +cando||| +cast_i32||5.006000| +cast_iv||5.006000| +cast_ulong||5.006000| +cast_uv||5.006000| +check_locale_boundary_crossing||| +check_type_and_open||| +check_uni||| +check_utf8_print||| +checkcomma||| +ckWARN|5.006000||p +ck_entersub_args_core||| +ck_entersub_args_list||5.013006| +ck_entersub_args_proto_or_list||5.013006| +ck_entersub_args_proto||5.013006| +ck_warner_d||5.011001|v +ck_warner||5.011001|v +ckwarn_common||| +ckwarn_d||5.009003| +ckwarn||5.009003| +cl_and|||n +cl_anything|||n +cl_init|||n +cl_is_anything|||n +cl_or|||n +clear_placeholders||| +clone_params_del|||n +clone_params_new|||n +closest_cop||| +compute_EXACTish||| +convert||| +cop_fetch_label||5.015001| +cop_free||| +cop_hints_2hv||5.013007| +cop_hints_fetch_pvn||5.013007| +cop_hints_fetch_pvs||5.013007| +cop_hints_fetch_pv||5.013007| +cop_hints_fetch_sv||5.013007| +cop_store_label||5.015001| +cophh_2hv||5.013007| +cophh_copy||5.013007| +cophh_delete_pvn||5.013007| +cophh_delete_pvs||5.013007| +cophh_delete_pv||5.013007| +cophh_delete_sv||5.013007| +cophh_fetch_pvn||5.013007| +cophh_fetch_pvs||5.013007| +cophh_fetch_pv||5.013007| +cophh_fetch_sv||5.013007| +cophh_free||5.013007| +cophh_new_empty||5.019003| +cophh_store_pvn||5.013007| +cophh_store_pvs||5.013007| +cophh_store_pv||5.013007| +cophh_store_sv||5.013007| +core_prototype||| +core_regclass_swash||| +coresub_op||| +could_it_be_a_POSIX_class||| +cr_textfilter||| +create_eval_scope||| +croak_memory_wrap||5.019003|n +croak_no_mem|||n +croak_no_modify||5.013003|n +croak_nocontext|||vn +croak_popstack|||n +croak_sv||5.013001| +croak_xs_usage||5.010001|n +croak|||v +csighandler||5.009003|n +curmad||| +current_re_engine||| +curse||| +custom_op_desc||5.007003| +custom_op_name||5.007003| +custom_op_register||5.013007| +custom_op_xop||5.013007| +cv_ckproto_len_flags||| +cv_clone_into||| +cv_clone||| +cv_const_sv_or_av||| +cv_const_sv||5.004000| +cv_dump||| +cv_forget_slab||| +cv_get_call_checker||5.013006| +cv_set_call_checker||5.013006| +cv_undef||| +cvgv_set||| +cvstash_set||| +cx_dump||5.005000| +cx_dup||| +cxinc||| +dAXMARK|5.009003||p +dAX|5.007002||p +dITEMS|5.007002||p +dMARK||| +dMULTICALL||5.009003| +dMY_CXT_SV|5.007003||p +dMY_CXT|5.007003||p +dNOOP|5.006000||p +dORIGMARK||| +dSP||| +dTHR|5.004050||p +dTHXR|5.019002||p +dTHXa|5.006000||p +dTHXoa|5.006000||p +dTHX|5.006000||p +dUNDERBAR|5.009002||p +dVAR|5.009003||p +dXCPT|5.009002||p +dXSARGS||| +dXSI32||| +dXSTARG|5.006000||p +deb_curcv||| +deb_nocontext|||vn +deb_stack_all||| +deb_stack_n||| +debop||5.005000| +debprofdump||5.005000| +debprof||| +debstackptrs||5.007003| +debstack||5.007003| +debug_start_match||| +deb||5.007003|v +defelem_target||| +del_sv||| +delete_eval_scope||| +delimcpy||5.004000|n +deprecate_commaless_var_list||| +despatch_signals||5.007001| +destroy_matcher||| +die_nocontext|||vn +die_sv||5.013001| +die_unwind||| +die|||v +dirp_dup||| +div128||| +djSP||| +do_aexec5||| +do_aexec||| +do_aspawn||| +do_binmode||5.004050| +do_chomp||| +do_close||| +do_delete_local||| +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_magic_dump||5.006000| +do_msgrcv||| +do_msgsnd||| +do_ncmp||| +do_oddball||| +do_op_dump||5.006000| +do_op_xmldump||| +do_open9||5.006000| +do_openn||5.007001| +do_open||5.004000| +do_pmop_dump||5.006000| +do_pmop_xmldump||| +do_print||| +do_readline||| +do_seek||| +do_semop||| +do_shmio||| +do_smartmatch||| +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||| +doeval||| +dofile||| +dofindlabel||| +doform||| +doing_taint||5.008001|n +dooneliner||| +doopen_pm||| +doparseform||| +dopoptoeval||| +dopoptogiven||| +dopoptolabel||| +dopoptoloop||| +dopoptosub_at||| +dopoptowhen||| +doref||5.009003| +dounwind||| +dowantarray||| +dump_all_perl||| +dump_all||5.006000| +dump_eval||5.006000| +dump_exec_pos||| +dump_fds||| +dump_form||5.006000| +dump_indent||5.006000|v +dump_mstats||| +dump_packsubs_perl||| +dump_packsubs||5.006000| +dump_sub_perl||| +dump_sub||5.006000| +dump_sv_child||| +dump_trie_interim_list||| +dump_trie_interim_table||| +dump_trie||| +dump_vindent||5.006000| +dumpuntil||| +dup_attrlist||| +emulate_cop_io||| +eval_pv|5.006000||p +eval_sv|5.006000||p +exec_failed||| +expect_number||| +fbm_compile||5.005000| +fbm_instr||5.005000| +feature_is_enabled||| +filter_add||| +filter_del||| +filter_gets||| +filter_read||| +finalize_optree||| +finalize_op||| +find_and_forget_pmops||| +find_array_subscript||| +find_beginning||| +find_byclass||| +find_hash_subscript||| +find_in_my_stash||| +find_lexical_cv||| +find_runcv_where||| +find_runcv||5.008001| +find_rundefsv2||| +find_rundefsvoffset||5.009002| +find_rundefsv||5.013002| +find_script||| +find_uninit_var||| +first_symbol|||n +foldEQ_latin1||5.013008|n +foldEQ_locale||5.013002|n +foldEQ_utf8_flags||5.013010| +foldEQ_utf8||5.013002| +foldEQ||5.013002|n +fold_constants||| +forbid_setid||| +force_ident_maybe_lex||| +force_ident||| +force_list||| +force_next||| +force_strict_version||| +force_version||| +force_word||| +forget_pmop||| +form_nocontext|||vn +form_short_octal_warning||| +form||5.004000|v +fp_dup||| +fprintf_nocontext|||vn +free_global_struct||| +free_tied_hv_pool||| +free_tmps||| +gen_constant_list||| +get_and_check_backslash_N_name||| +get_aux_mg||| +get_av|5.006000||p +get_context||5.006000|n +get_cvn_flags|5.009005||p +get_cvs|5.011000||p +get_cv|5.006000||p +get_db_sub||| +get_debug_opts||| +get_hash_seed||| +get_hv|5.006000||p +get_invlist_iter_addr||| +get_invlist_offset_addr||| +get_invlist_previous_index_addr||| +get_mstats||| +get_no_modify||| +get_num||| +get_op_descs||5.005000| +get_op_names||5.005000| +get_opargs||| +get_ppaddr||5.006000| +get_re_arg||| +get_sv|5.006000||p +get_vtbl||5.005030| +getcwd_sv||5.007002| +getenv_len||| +glob_2number||| +glob_assign_glob||| +glob_assign_ref||| +gp_dup||| +gp_free||| +gp_ref||| +grok_bin|5.007003||p +grok_bslash_N||| +grok_bslash_c||| +grok_bslash_o||| +grok_bslash_x||| +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_SVadd||| +gv_add_by_type||5.011000| +gv_autoload4||5.004000| +gv_autoload_pvn||5.015004| +gv_autoload_pv||5.015004| +gv_autoload_sv||5.015004| +gv_check||| +gv_const_sv||5.009003| +gv_dump||5.006000| +gv_efullname3||5.004000| +gv_efullname4||5.006001| +gv_efullname||| +gv_ename||| +gv_fetchfile_flags||5.009005| +gv_fetchfile||| +gv_fetchmeth_autoload||5.007003| +gv_fetchmeth_pv_autoload||5.015004| +gv_fetchmeth_pvn_autoload||5.015004| +gv_fetchmeth_pvn||5.015004| +gv_fetchmeth_pv||5.015004| +gv_fetchmeth_sv_autoload||5.015004| +gv_fetchmeth_sv||5.015004| +gv_fetchmethod_autoload||5.004000| +gv_fetchmethod_pv_flags||5.015004| +gv_fetchmethod_pvn_flags||5.015004| +gv_fetchmethod_sv_flags||5.015004| +gv_fetchmethod||| +gv_fetchmeth||| +gv_fetchpvn_flags|5.009002||p +gv_fetchpvs|5.009004||p +gv_fetchpv||| +gv_fetchsv|5.009002||p +gv_fullname3||5.004000| +gv_fullname4||5.006001| +gv_fullname||| +gv_handler||5.007001| +gv_init_pvn||5.015004| +gv_init_pv||5.015004| +gv_init_svtype||| +gv_init_sv||5.015004| +gv_init||| +gv_magicalize_isa||| +gv_name_set||5.009004| +gv_stashpvn|5.004000||p +gv_stashpvs|5.009003||p +gv_stashpv||| +gv_stashsv||| +gv_try_downgrade||| +handle_regex_sets||| +he_dup||| +hek_dup||| +hfree_next_entry||| +hfreeentries||| +hsplit||| +hv_assert||| +hv_auxinit||| +hv_backreferences_p||| +hv_clear_placeholders||5.009001| +hv_clear||| +hv_common_key_len||5.010000| +hv_common||5.010000| +hv_copy_hints_hv||5.009004| +hv_delayfree_ent||5.004000| +hv_delete_common||| +hv_delete_ent||5.004000| +hv_delete||| +hv_eiter_p||5.009003| +hv_eiter_set||5.009003| +hv_ename_add||| +hv_ename_delete||| +hv_exists_ent||5.004000| +hv_exists||| +hv_fetch_ent||5.004000| +hv_fetchs|5.009003||p +hv_fetch||| +hv_fill||5.013002| +hv_free_ent_ret||| +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_kill_backrefs||| +hv_ksplit||5.004000| +hv_magic_check|||n +hv_magic||| +hv_name_set||5.009003| +hv_notallowed||| +hv_placeholders_get||5.009003| +hv_placeholders_p||| +hv_placeholders_set||5.009003| +hv_rand_set||5.017011| +hv_riter_p||5.009003| +hv_riter_set||5.009003| +hv_scalar||5.009001| +hv_store_ent||5.004000| +hv_store_flags||5.008000| +hv_stores|5.009004||p +hv_store||| +hv_undef_flags||| +hv_undef||| +ibcmp_locale||5.004000| +ibcmp_utf8||5.007003| +ibcmp||| +incline||| +incpush_if_exists||| +incpush_use_sep||| +incpush||| +ingroup||| +init_argv_symbols||| +init_constants||| +init_dbargs||| +init_debugger||| +init_global_struct||| +init_i18nl10n||5.006000| +init_i18nl14n||5.006000| +init_ids||| +init_interp||| +init_main_stash||| +init_perllib||| +init_postdump_symbols||| +init_predump_symbols||| +init_stacks||5.005000| +init_tm||5.007002| +inplace_aassign||| +instr|||n +intro_my||| +intuit_method||| +intuit_more||| +invert||| +invlist_array||| +invlist_clone||| +invlist_extend||| +invlist_highest||| +invlist_is_iterating||| +invlist_iterfinish||| +invlist_iterinit||| +invlist_iternext||| +invlist_max||| +invlist_previous_index||| +invlist_set_len||| +invlist_set_previous_index||| +invlist_trim||| +invoke_exception_hook||| +io_close||| +isALNUMC|5.006000||p +isALNUM_lazy||| +isALPHANUMERIC||5.017008| +isALPHA||| +isASCII|5.006000|5.006000|p +isBLANK|5.006001||p +isCNTRL|5.006000|5.006000|p +isDIGIT||| +isFOO_lc||| +isFOO_utf8_lc||| +isGRAPH|5.006000||p +isGV_with_GP|5.009004||p +isIDCONT||5.017008| +isIDFIRST_lazy||| +isIDFIRST||| +isLOWER||| +isOCTAL||5.013005| +isPRINT|5.004000||p +isPSXSPC|5.006001||p +isPUNCT|5.006000||p +isSPACE||| +isUPPER||| +isWORDCHAR||5.013006| +isXDIGIT|5.006000||p +is_an_int||| +is_ascii_string||5.011000|n +is_cur_LC_category_utf8||| +is_handle_constructor|||n +is_list_assignment||| +is_lvalue_sub||5.007001| +is_uni_alnum_lc||5.006000| +is_uni_alnumc_lc||5.017007| +is_uni_alnumc||5.017007| +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_blank_lc||5.017002| +is_uni_blank||5.017002| +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.017007| +is_utf8_alnum||5.006000| +is_utf8_alpha||5.006000| +is_utf8_ascii||5.006000| +is_utf8_blank||5.017002| +is_utf8_char_buf||5.015008|n +is_utf8_char_slow|||n +is_utf8_char||5.006000|n +is_utf8_cntrl||5.006000| +is_utf8_common||| +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_perl_space||5.011001| +is_utf8_perl_word||5.011001| +is_utf8_posix_digit||5.011001| +is_utf8_print||5.006000| +is_utf8_punct||5.006000| +is_utf8_space||5.006000| +is_utf8_string_loclen||5.009003|n +is_utf8_string_loc||5.008001|n +is_utf8_string||5.006001|n +is_utf8_upper||5.006000| +is_utf8_xdigit||5.006000| +is_utf8_xidcont||5.013010| +is_utf8_xidfirst||5.013010| +isa_lookup||| +items|||n +ix|||n +jmaybe||| +join_exact||| +keyword_plugin_standard||| +keyword||| +leave_scope||| +lex_bufutf8||5.011002| +lex_discard_to||5.011002| +lex_grow_linestr||5.011002| +lex_next_chunk||5.011002| +lex_peek_unichar||5.011002| +lex_read_space||5.011002| +lex_read_to||5.011002| +lex_read_unichar||5.011002| +lex_start||5.009005| +lex_stuff_pvn||5.011002| +lex_stuff_pvs||5.013005| +lex_stuff_pv||5.013006| +lex_stuff_sv||5.011002| +lex_unstuff||5.011002| +listkids||| +list||| +load_module_nocontext|||vn +load_module|5.006000||pv +localize||| +looks_like_bool||| +looks_like_number||| +lop||| +mPUSHi|5.009002||p +mPUSHn|5.009002||p +mPUSHp|5.009002||p +mPUSHs|5.010001||p +mPUSHu|5.009002||p +mXPUSHi|5.009002||p +mXPUSHn|5.009002||p +mXPUSHp|5.009002||p +mXPUSHs|5.010001||p +mXPUSHu|5.009002||p +mad_free||| +madlex||| +madparse||| +magic_clear_all_env||| +magic_cleararylen_p||| +magic_clearenv||| +magic_clearhints||| +magic_clearhint||| +magic_clearisa||| +magic_clearpack||| +magic_clearsig||| +magic_copycallchecker||| +magic_dump||5.006000| +magic_existspack||| +magic_freearylen_p||| +magic_freeovrld||| +magic_getarylen||| +magic_getdefelem||| +magic_getnkeys||| +magic_getpack||| +magic_getpos||| +magic_getsig||| +magic_getsubstr||| +magic_gettaint||| +magic_getuvar||| +magic_getvec||| +magic_get||| +magic_killbackrefs||| +magic_methcall1||| +magic_methcall|||v +magic_methpack||| +magic_nextpack||| +magic_regdata_cnt||| +magic_regdatum_get||| +magic_regdatum_set||| +magic_scalarpack||| +magic_set_all_env||| +magic_setarylen||| +magic_setcollxfrm||| +magic_setdbline||| +magic_setdefelem||| +magic_setenv||| +magic_sethint||| +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||| +make_matcher||| +make_trie_failtable||| +make_trie||| +malloc_good_size|||n +malloced_size|||n +malloc||5.007002|n +markstack_grow||| +matcher_matches_sv||| +mayberelocate||| +measure_struct||| +memEQs|5.009005||p +memEQ|5.004000||p +memNEs|5.009005||p +memNE|5.004000||p +mem_collxfrm||| +mem_log_common|||n +mess_alloc||| +mess_nocontext|||vn +mess_sv||5.013001| +mess||5.006000|v +method_common||| +mfree||5.007002|n +mg_clear||| +mg_copy||| +mg_dup||| +mg_find_mglob||| +mg_findext||5.013008| +mg_find||| +mg_free_type||5.013006| +mg_free||| +mg_get||| +mg_length||5.005000| +mg_localize||| +mg_magical||| +mg_set||| +mg_size||5.005000| +mini_mktime||5.007002| +minus_v||| +missingterm||| +mode_from_discipline||| +modkids||| +more_bodies||| +more_sv||| +moreswitches||| +mro_clean_isarev||| +mro_gather_and_rename||| +mro_get_from_name||5.010001| +mro_get_linear_isa_dfs||| +mro_get_linear_isa||5.009005| +mro_get_private_data||5.010001| +mro_isa_changed_in||| +mro_meta_dup||| +mro_meta_init||| +mro_method_changed_in||5.009005| +mro_package_moved||| +mro_register||5.010001| +mro_set_mro||5.010001| +mro_set_private_data||5.010001| +mul128||| +mulexp10|||n +my_atof2||5.007002| +my_atof||5.006000| +my_attrs||| +my_bcopy|||n +my_bzero|||n +my_chsize||| +my_clearenv||| +my_cxt_index||| +my_cxt_init||| +my_dirfd||5.009005| +my_exit_jump||| +my_exit||| +my_failure_exit||5.004000| +my_fflush_all||5.006000| +my_fork||5.007003|n +my_kid||| +my_lstat_flags||| +my_lstat||5.019003| +my_memcmp|||n +my_memset||5.004000|n +my_pclose||5.004000| +my_popen_list||5.007001| +my_popen||5.004000| +my_setenv||| +my_snprintf|5.009004||pvn +my_socketpair||5.007003|n +my_sprintf|5.009003||pvn +my_stat_flags||| +my_stat||5.019003| +my_strftime||5.007002| +my_strlcat|5.009004||pn +my_strlcpy|5.009004||pn +my_unexec||| +my_vsnprintf||5.009004|n +need_utf8|||n +newANONATTRSUB||5.006000| +newANONHASH||| +newANONLIST||| +newANONSUB||| +newASSIGNOP||| +newATTRSUB_flags||| +newATTRSUB||5.006000| +newAVREF||| +newAV||| +newBINOP||| +newCONDOP||| +newCONSTSUB_flags||5.015006| +newCONSTSUB|5.004050||p +newCVREF||| +newDEFSVOP||| +newFORM||| +newFOROP||5.013007| +newGIVENOP||5.009003| +newGIVWHENOP||| +newGP||| +newGVOP||| +newGVREF||| +newGVgen_flags||5.015004| +newGVgen||| +newHVREF||| +newHVhv||5.005000| +newHV||| +newIO||| +newLISTOP||| +newLOGOP||| +newLOOPEX||| +newLOOPOP||| +newMADPROP||| +newMADsv||| +newMYSUB||5.017004| +newNULLLIST||| +newOP||| +newPADOP||| +newPMOP||| +newPROG||| +newPVOP||| +newRANGE||| +newRV_inc|5.004000||p +newRV_noinc|5.004000||p +newRV||| +newSLICEOP||| +newSTATEOP||| +newSTUB||| +newSUB||| +newSVOP||| +newSVREF||| +newSV_type|5.009005||p +newSVhek||5.009003| +newSViv||| +newSVnv||| +newSVpadname||5.017004| +newSVpv_share||5.013006| +newSVpvf_nocontext|||vn +newSVpvf||5.004000|v +newSVpvn_flags|5.010001||p +newSVpvn_share|5.007001||p +newSVpvn_utf8|5.010001||p +newSVpvn|5.004050||p +newSVpvs_flags|5.010001||p +newSVpvs_share|5.009003||p +newSVpvs|5.009003||p +newSVpv||| +newSVrv||| +newSVsv||| +newSVuv|5.006000||p +newSV||| +newTOKEN||| +newUNOP||| +newWHENOP||5.009003| +newWHILEOP||5.013007| +newXS_flags||5.009004| +newXS_len_flags||| +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_warnings_bitfield||| +next_symbol||| +nextargv||| +nextchar||| +ninstr|||n +no_bareword_allowed||| +no_fh_allowed||| +no_op||| +not_a_number||| +not_incrementable||| +nothreadhook||5.008000| +nuke_stacks||| +num_overflow|||n +oopsAV||| +oopsHV||| +op_append_elem||5.013006| +op_append_list||5.013006| +op_clear||| +op_const_sv||| +op_contextualize||5.013006| +op_dump||5.006000| +op_free||| +op_getmad_weak||| +op_getmad||| +op_integerize||| +op_linklist||5.013006| +op_lvalue_flags||| +op_lvalue||5.013007| +op_null||5.007002| +op_prepend_elem||5.013006| +op_refcnt_dec||| +op_refcnt_inc||| +op_refcnt_lock||5.009002| +op_refcnt_unlock||5.009002| +op_scope||5.013007| +op_std_init||| +op_unscope||| +op_xmldump||| +open_script||| +opslab_force_free||| +opslab_free_nopad||| +opslab_free||| +pMY_CXT_|5.007003||p +pMY_CXT|5.007003||p +pTHX_|5.006000||p +pTHX|5.006000||p +packWARN|5.007003||p +pack_cat||5.007003| +pack_rec||| +package_version||| +package||| +packlist||5.008001| +pad_add_anon||5.008001| +pad_add_name_pvn||5.015001| +pad_add_name_pvs||5.015001| +pad_add_name_pv||5.015001| +pad_add_name_sv||5.015001| +pad_alloc_name||| +pad_alloc||| +pad_block_start||| +pad_check_dup||| +pad_compname_type||5.009003| +pad_findlex||| +pad_findmy_pvn||5.015001| +pad_findmy_pvs||5.015001| +pad_findmy_pv||5.015001| +pad_findmy_sv||5.015001| +pad_fixup_inner_anons||| +pad_free||| +pad_leavemy||| +pad_new||5.008001| +pad_peg|||n +pad_push||| +pad_reset||| +pad_setsv||| +pad_sv||| +pad_swipe||| +pad_tidy||5.008001| +padlist_dup||| +padlist_store||| +parse_arithexpr||5.013008| +parse_barestmt||5.013007| +parse_block||5.013007| +parse_body||| +parse_fullexpr||5.013008| +parse_fullstmt||5.013005| +parse_ident||| +parse_label||5.013007| +parse_listexpr||5.013008| +parse_lparen_question_flags||| +parse_stmtseq||5.013006| +parse_termexpr||5.013008| +parse_unicode_opts||| +parser_dup||| +parser_free_nexttoke_ops||| +parser_free||| +path_is_searchable|||n +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||| +pm_description||| +pmop_dump||5.006000| +pmop_xmldump||| +pmruntime||| +pmtrans||| +pop_scope||| +populate_isa|||v +pregcomp||5.009005| +pregexec||| +pregfree2||5.011000| +pregfree||| +prepend_madprops||| +prescan_version||5.011004| +printbuf||| +printf_nocontext|||vn +process_special_blocks||| +ptr_hash|||n +ptr_table_clear||5.009005| +ptr_table_fetch||5.009005| +ptr_table_find|||n +ptr_table_free||5.009005| +ptr_table_new||5.009005| +ptr_table_split||5.009005| +ptr_table_store||5.009005| +push_scope||| +put_byte||| +put_latin1_charclass_innards||| +pv_display|5.006000||p +pv_escape|5.009004||p +pv_pretty|5.009004||p +pv_uni_display||5.007003| +qerror||| +qsortsvu||| +re_compile||5.009005| +re_croak2||| +re_dup_guts||| +re_intuit_start||5.019001| +re_intuit_string||5.006000| +re_op_compile||| +readpipe_override||| +realloc||5.007002|n +reentrant_free||5.019003| +reentrant_init||5.019003| +reentrant_retry||5.019003|vn +reentrant_size||5.019003| +ref_array_or_hash||| +refcounted_he_chain_2hv||| +refcounted_he_fetch_pvn||| +refcounted_he_fetch_pvs||| +refcounted_he_fetch_pv||| +refcounted_he_fetch_sv||| +refcounted_he_free||| +refcounted_he_inc||| +refcounted_he_new_pvn||| +refcounted_he_new_pvs||| +refcounted_he_new_pv||| +refcounted_he_new_sv||| +refcounted_he_value||| +refkids||| +refto||| +ref||5.019003| +reg_check_named_buff_matched||| +reg_named_buff_all||5.009005| +reg_named_buff_exists||5.009005| +reg_named_buff_fetch||5.009005| +reg_named_buff_firstkey||5.009005| +reg_named_buff_iter||| +reg_named_buff_nextkey||5.009005| +reg_named_buff_scalar||5.009005| +reg_named_buff||| +reg_node||| +reg_numbered_buff_fetch||| +reg_numbered_buff_length||| +reg_numbered_buff_store||| +reg_qr_package||| +reg_recode||| +reg_scan_name||| +reg_skipcomment||| +reg_temp_copy||| +reganode||| +regatom||| +regbranch||| +regclass_swash||5.009004| +regclass||| +regcppop||| +regcppush||| +regcurly||| +regdump_extflags||| +regdump_intflags||| +regdump||5.005000| +regdupe_internal||| +regexec_flags||5.005000| +regfree_internal||5.009005| +reghop3|||n +reghop4|||n +reghopmaybe3|||n +reginclass||| +reginitcolors||5.006000| +reginsert||| +regmatch||| +regnext||5.005000| +regpatws|||n +regpiece||| +regpposixcc||| +regprop||| +regrepeat||| +regtail_study||| +regtail||| +regtry||| +reguni||| +regwhite|||n +reg||| +repeatcpy|||n +report_evil_fh||| +report_redefined_cv||| +report_uninit||| +report_wrongway_fh||| +require_pv||5.006000| +require_tie_mod||| +restore_magic||| +rninstr|||n +rpeep||| +rsignal_restore||| +rsignal_save||| +rsignal_state||5.004000| +rsignal||5.004000| +run_body||| +run_user_filter||| +runops_debug||5.005000| +runops_standard||5.005000| +rv2cv_op_cv||5.013006| +rvpv_dup||| +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_adelete||5.011000| +save_aelem_flags||5.011000| +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_hdelete||5.011000| +save_hek_flags|||n +save_helem_flags||5.011000| +save_helem||5.004050| +save_hints||5.010001| +save_hptr||| +save_int||| +save_item||| +save_iv||5.005000| +save_lines||| +save_list||| +save_long||| +save_magic_flags||| +save_mortalizesv||5.007001| +save_nogv||| +save_op||5.005000| +save_padsv_and_mortalize||5.010001| +save_pptr||| +save_pushi32ptr||5.010001| +save_pushptri32ptr||| +save_pushptrptr||5.010001| +save_pushptr||5.010001| +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_vptr||5.006000| +savepvn||| +savepvs||5.009003| +savepv||| +savesharedpvn||5.009005| +savesharedpvs||5.013006| +savesharedpv||5.007003| +savesharedsvpv||5.013006| +savestack_grow_cnt||5.008001| +savestack_grow||| +savesvpv||5.009002| +sawparens||| +scalar_mod_type|||n +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.009005| +scan_word||| +screaminstr||5.005000| +search_const||| +seed||5.008001| +sequence_num||| +set_context||5.006000|n +set_numeric_local||5.006000| +set_numeric_radix||5.006000| +set_numeric_standard||5.006000| +setdefout||| +share_hek_flags||| +share_hek||5.004000| +si_dup||| +sighandler|||n +simplify_sort||| +skipspace0||| +skipspace1||| +skipspace2||| +skipspace_flags||| +softref2xv||| +sortcv_stacked||| +sortcv_xsub||| +sortcv||| +sortsv_flags||5.009003| +sortsv||5.007003| +space_join_names_mortal||| +ss_dup||| +stack_grow||| +start_force||| +start_glob||| +start_subparse||5.004000| +stdize_locale||| +strEQ||| +strGE||| +strGT||| +strLE||| +strLT||| +strNE||| +str_to_version||5.006000| +strip_return||| +strnEQ||| +strnNE||| +study_chunk||| +sub_crush_depth||| +sublex_done||| +sublex_push||| +sublex_start||| +sv_2bool_flags||5.013006| +sv_2bool||| +sv_2cv||| +sv_2io||| +sv_2iuv_common||| +sv_2iuv_non_preserve||| +sv_2iv_flags||5.009001| +sv_2iv||| +sv_2mortal||| +sv_2num||| +sv_2nv_flags||5.013001| +sv_2pv_flags|5.007002||p +sv_2pv_nolen|5.006000||p +sv_2pvbyte_nolen|5.006000||p +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_flags||5.013006| +sv_catpv_mg|5.004050||p +sv_catpv_nomg||5.013006| +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.004050||p +sv_catpvn_nomg|5.007002||p +sv_catpvn||| +sv_catpvs_flags||5.013006| +sv_catpvs_mg||5.013006| +sv_catpvs_nomg||5.013006| +sv_catpvs|5.009003||p +sv_catpv||| +sv_catsv_flags||5.007002| +sv_catsv_mg|5.004050||p +sv_catsv_nomg|5.007002||p +sv_catsv||| +sv_catxmlpvn||| +sv_catxmlpv||| +sv_catxmlsv||| +sv_chop||| +sv_clean_all||| +sv_clean_objs||| +sv_clear||| +sv_cmp_flags||5.013006| +sv_cmp_locale_flags||5.013006| +sv_cmp_locale||5.004000| +sv_cmp||| +sv_collxfrm_flags||5.013006| +sv_collxfrm||| +sv_copypv_flags||5.017002| +sv_copypv_nomg||5.017002| +sv_copypv||| +sv_dec_nomg||5.013002| +sv_dec||| +sv_del_backref||| +sv_derived_from_pvn||5.015004| +sv_derived_from_pv||5.015004| +sv_derived_from_sv||5.015004| +sv_derived_from||5.004000| +sv_destroyable||5.010000| +sv_display||| +sv_does_pvn||5.015004| +sv_does_pv||5.015004| +sv_does_sv||5.015004| +sv_does||5.009004| +sv_dump||| +sv_dup_common||| +sv_dup_inc_multiple||| +sv_dup_inc||| +sv_dup||| +sv_eq_flags||5.013006| +sv_eq||| +sv_exp_grow||| +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_i_ncmp||| +sv_inc_nomg||5.013002| +sv_inc||| +sv_insert_flags||5.010001| +sv_insert||| +sv_isa||| +sv_isobject||| +sv_iv||5.005000| +sv_kill_backrefs||| +sv_len_utf8_nomg||| +sv_len_utf8||5.006000| +sv_len||| +sv_magic_portable|5.019003|5.004000|p +sv_magicext_mglob||| +sv_magicext||5.007003| +sv_magic||| +sv_mortalcopy_flags||| +sv_mortalcopy||| +sv_ncmp||| +sv_newmortal||| +sv_newref||| +sv_nolocking||5.007003| +sv_nosharing||5.007003| +sv_nounlocking||| +sv_nv||5.005000| +sv_peek||5.005000| +sv_pos_b2u_flags||5.019003| +sv_pos_b2u_midway||| +sv_pos_b2u||5.006000| +sv_pos_u2b_cached||| +sv_pos_u2b_flags||5.011005| +sv_pos_u2b_forwards|||n +sv_pos_u2b_midway|||n +sv_pos_u2b||5.006000| +sv_pvbyten_force||5.006000| +sv_pvbyten||5.006000| +sv_pvbyte||5.006000| +sv_pvn_force_flags|5.007002||p +sv_pvn_force||| +sv_pvn_nomg|5.007003|5.005000|p +sv_pvn||5.005000| +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_ref||| +sv_release_COW||| +sv_replace||| +sv_report_used||| +sv_resetpvn||| +sv_reset||| +sv_rvweaken||5.006000| +sv_sethek||| +sv_setiv_mg|5.004050||p +sv_setiv||| +sv_setnv_mg|5.006000||p +sv_setnv||| +sv_setpv_mg|5.004050||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.004050||p +sv_setpvn||| +sv_setpvs_mg||5.013006| +sv_setpvs|5.009004||p +sv_setpv||| +sv_setref_iv||| +sv_setref_nv||| +sv_setref_pvn||| +sv_setref_pvs||5.019003| +sv_setref_pv||| +sv_setref_uv||5.007001| +sv_setsv_cow||| +sv_setsv_flags||5.007002| +sv_setsv_mg|5.004050||p +sv_setsv_nomg|5.007002||p +sv_setsv||| +sv_setuv_mg|5.004050||p +sv_setuv|5.004000||p +sv_tainted||5.004000| +sv_taint||5.004000| +sv_true||5.005000| +sv_unglob||| +sv_uni_display||5.007003| +sv_unmagicext||5.013008| +sv_unmagic||| +sv_unref_flags||5.007001| +sv_unref||| +sv_untaint||5.004000| +sv_upgrade||| +sv_usepvn_flags||5.009004| +sv_usepvn_mg|5.004050||p +sv_usepvn||| +sv_utf8_decode||5.006000| +sv_utf8_downgrade||5.006000| +sv_utf8_encode||5.006000| +sv_utf8_upgrade_flags_grow||5.011000| +sv_utf8_upgrade_flags||5.007002| +sv_utf8_upgrade_nomg||5.007002| +sv_utf8_upgrade||5.007001| +sv_uv|5.005000||p +sv_vcatpvf_mg|5.006000|5.004000|p +sv_vcatpvfn_flags||5.017002| +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 +sv_xmlpeek||| +svtype||| +swallow_bom||| +swash_fetch||5.007002| +swash_init||5.006000| +swatch_get||| +sys_init3||5.010000|n +sys_init||5.010000|n +sys_intern_clear||| +sys_intern_dup||| +sys_intern_init||| +sys_term||5.010000|n +taint_env||| +taint_proper||| +tied_method|||v +tmps_grow||5.006000| +toFOLD_uni||5.007003| +toFOLD_utf8||5.019001| +toFOLD||5.019001| +toLOWER_L1||5.019001| +toLOWER_LC||5.004000| +toLOWER_uni||5.007003| +toLOWER_utf8||5.015007| +toLOWER||| +toTITLE_uni||5.007003| +toTITLE_utf8||5.015007| +toTITLE||5.019001| +toUPPER_uni||5.007003| +toUPPER_utf8||5.015007| +toUPPER||5.004000| +to_byte_substr||| +to_lower_latin1||| +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.015007| +to_utf8_lower||5.015007| +to_utf8_substr||| +to_utf8_title||5.015007| +to_utf8_upper||5.015007| +token_free||| +token_getmad||| +tokenize_use||| +tokeq||| +tokereport||| +too_few_arguments_pv||| +too_few_arguments_sv||| +too_many_arguments_pv||| +too_many_arguments_sv||| +translate_substr_offsets||| +try_amagic_bin||| +try_amagic_un||| +uiv_2buf|||n +unlnk||| +unpack_rec||| +unpack_str||5.007003| +unpackstring||5.008001| +unreferenced_to_tmp_stack||| +unshare_hek_or_pvn||| +unshare_hek||| +unsharepvn||5.004000| +unwind_handler_stack||| +update_debugger_info||| +upg_version||5.009005| +usage||| +utf16_textfilter||| +utf16_to_utf8_reversed||5.006001| +utf16_to_utf8||5.006001| +utf8_distance||5.006000| +utf8_hop||5.006000| +utf8_length||5.007001| +utf8_mg_len_cache_update||| +utf8_mg_pos_cache_update||| +utf8_to_bytes||5.006001| +utf8_to_uvchr_buf||5.015009| +utf8_to_uvchr||5.007001| +utf8_to_uvuni_buf||5.015009| +utf8_to_uvuni||5.007001| +utf8n_to_uvchr||| +utf8n_to_uvuni||5.007001| +utilize||| +uvchr_to_utf8_flags||5.007003| +uvchr_to_utf8||| +uvuni_to_utf8_flags||5.007003| +uvuni_to_utf8||5.007001| +valid_utf8_to_uvchr||| +valid_utf8_to_uvuni||5.015009| +validate_proto||| +validate_suid||| +varname||| +vcmp||5.009000| +vcroak||5.006000| +vdeb||5.007003| +vform||5.006000| +visit||| +vivify_defelem||| +vivify_ref||| +vload_module|5.006000||p +vmess||5.006000| +vnewSVpvf|5.006000|5.004000|p +vnormal||5.009002| +vnumify||5.009000| +vstringify||5.009000| +vverify||5.009003| +vwarner||5.006000| +vwarn||5.006000| +wait4pid||| +warn_nocontext|||vn +warn_sv||5.013001| +warner_nocontext|||vn +warner|5.006000|5.004000|pv +warn|||v +was_lvalue_sub||| +watch||| +whichsig_pvn||5.015004| +whichsig_pv||5.015004| +whichsig_sv||5.015004| +whichsig||| +win32_croak_not_implemented|||n +with_queued_errors||| +wrap_op_checker||5.015008| +write_to_stderr||| +xmldump_all_perl||| +xmldump_all||| +xmldump_attr||| +xmldump_eval||| +xmldump_form||| +xmldump_indent|||v +xmldump_packsubs_perl||| +xmldump_packsubs||| +xmldump_sub_perl||| +xmldump_sub||| +xmldump_vindent||| +xs_apiversion_bootcheck||| +xs_version_bootcheck||| +yyerror_pvn||| +yyerror_pv||| +yyerror||| +yylex||| +yyparse||| +yyunlex||| +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, %warnings, %depends); +my $replace = 0; +my($hint, $define, $function); + +sub find_api +{ + my $code = shift; + $code =~ s{ + / (?: \*[^*]*\*+(?:[^$ccs][^*]*\*+)* / | /[^\r\n]*) + | "[^"\\]*(?:\\.[^"\\]*)*" + | '[^'\\]*(?:\\.[^'\\]*)*' }{}egsx; + grep { exists $API{$_} } $code =~ /(\w+)/mg; +} + +while (<DATA>) { + if ($hint) { + my $h = $hint->[0] eq 'Hint' ? \%hints : \%warnings; + if (m{^\s*\*\s(.*?)\s*$}) { + for (@{$hint->[1]}) { + $h->{$_} ||= ''; # suppress warning with older perls + $h->{$_} .= "$1\n"; + } + } + else { undef $hint } + } + + $hint = [$1, [split /,?\s+/, $2]] + if m{^\s*$rccs\s+(Hint|Warning):\s+(\w+(?:,?\s+\w+)*)\s*$}; + + if ($define) { + if ($define->[1] =~ /\\$/) { + $define->[1] .= $_; + } + else { + if (exists $API{$define->[0]} && $define->[1] !~ /^DPPP_\(/) { + my @n = find_api($define->[1]); + push @{$depends{$define->[0]}}, @n if @n + } + undef $define; + } + } + + $define = [$1, $2] if m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(.*)}; + + if ($function) { + if (/^}/) { + if (exists $API{$function->[0]}) { + my @n = find_api($function->[1]); + push @{$depends{$function->[0]}}, @n if @n + } + undef $function; + } + else { + $function->[1] .= $_; + } + } + + $function = [$1, ''] if m{^DPPP_\(my_(\w+)\)}; + + $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*,\s*\w+)*)\s+depends\s+on\s+(\w+(\s*,\s*\w+)*)\s+$rcce\s*$}) { + my @deps = map { s/\s+//g; $_ } split /,/, $3; + my $d; + for $d (map { s/\s+//g; $_ } split /,/, $1) { + push @{$depends{$d}}, @deps; + } + } + + $need{$1} = 1 if m{^#if\s+defined\(NEED_(\w+)(?:_GLOBAL)?\)}; +} + +for (values %depends) { + my %s; + $_ = [sort grep !$s{$_}++, @$_]; +} + +if (exists $opt{'api-info'}) { + my $f; + my $count = 0; + my $match = $opt{'api-info'} =~ m!^/(.*)/$! ? $1 : "^\Q$opt{'api-info'}\E\$"; + for $f (sort { lc $a cmp lc $b } keys %API) { + next unless $f =~ /$match/; + print "\n=== $f ===\n\n"; + my $info = 0; + if ($API{$f}{base} || $API{$f}{todo}) { + my $base = format_version($API{$f}{base} || $API{$f}{todo}); + print "Supported at least starting from perl-$base.\n"; + $info++; + } + if ($API{$f}{provided}) { + my $todo = $API{$f}{todo} ? format_version($API{$f}{todo}) : "5.003"; + print "Support by $ppport provided back to perl-$todo.\n"; + print "Support needs to be explicitly requested by NEED_$f.\n" if exists $need{$f}; + print "Depends on: ", join(', ', @{$depends{$f}}), ".\n" if exists $depends{$f}; + print "\n$hints{$f}" if exists $hints{$f}; + print "\nWARNING:\n$warnings{$f}" if exists $warnings{$f}; + $info++; + } + print "No portability information available.\n" unless $info; + $count++; + } + $count or print "Found no API matching '$opt{'api-info'}'."; + print "\n"; + exit 0; +} + +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}; + push @flags, 'warning' if exists $warnings{$f}; + my $flags = @flags ? ' ['.join(', ', @flags).']' : ''; + print "$f$flags\n"; + } + exit 0; +} + +my @files; +my @srcext = qw( .xs .c .h .cc .cpp -c.inc -xs.inc ); +my $srcext = join '|', map { quotemeta $_ } @srcext; + +if (@ARGV) { + my %seen; + for (@ARGV) { + if (-e) { + if (-f) { + push @files, $_ unless $seen{$_}++; + } + else { warn "'$_' is not a file.\n" } + } + else { + my @new = grep { -f } glob $_ + or warn "'$_' does not exist.\n"; + push @files, grep { !$seen{$_}++ } @new; + } + } +} +else { + eval { + require File::Find; + File::Find::find(sub { + $File::Find::name =~ /($srcext)$/i + and push @files, $File::Find::name; + }, '.'); + }; + if ($@) { + @files = map { glob "*$_" } @srcext; + } +} + +if (!@ARGV || $opt{filter}) { + my(@in, @out); + my %xsc = map { /(.*)\.xs$/ ? ("$1.c" => 1, "$1.cc" => 1) : () } @files; + for (@files) { + my $out = exists $xsc{$_} || /\b\Q$ppport\E$/i || !/($srcext)$/i; + push @{ $out ? \@out : \@in }, $_; + } + if (@ARGV && @out) { + warning("Skipping the following files (use --nofilter to avoid this):\n| ", join "\n| ", @out); + } + @files = @in; +} + +die "No input files given!\n" unless @files; + +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/XS comments and strings from the code + my @ccom; + + $c =~ s{ + ( ^$HS*\#$HS*include\b[^\r\n]+\b(?:\Q$ppport\E|XSUB\.h)\b[^\r\n]* + | ^$HS*\#$HS*(?:define|elif|if(?:def)?)\b[^\r\n]* ) + | ( ^$HS*\#[^\r\n]* + | "[^"\\]*(?:\\.[^"\\]*)*" + | '[^'\\]*(?:\\.[^'\\]*)*' + | / (?: \*[^*]*\*+(?:[^$ccs][^*]*\*+)* / | /[^\r\n]* ) ) + }{ defined $2 and push @ccom, $2; + defined $1 ? $1 : "$ccs$#ccom$cce" }mgsex; + + $file{ccom} = \@ccom; + $file{code} = $c; + $file{has_inc_ppport} = $c =~ /^$HS*#$HS*include[^\r\n]+\b\Q$ppport\E\b/m; + + 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}) { + $file{uses_provided}{$func}++; + 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) { + $file{needs}{$_} = 'static' if exists $need{$_}; + } + } + } + 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}; + my $warnings = 0; + + for $func (sort keys %{$file{uses_Perl}}) { + if ($API{$func}{varargs}) { + unless ($API{$func}{nothxarg}) { + 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_provided}}) { + if ($file{uses}{$func}) { + if (exists $file{uses_deps}{$func}) { + diag("Uses $func, which depends on ", join(', ', @{$file{uses_deps}{$func}})); + } + else { + diag("Uses $func"); + } + } + $warnings += hint($func); + } + + unless ($opt{quiet}) { + for $func (sort keys %{$file{uses_todo}}) { + print "*** WARNING: Uses $func, which may not be portable below perl ", + format_version($API{$func}{todo}), ", even with '$ppport'\n"; + $warnings++; + } + } + + 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"); + } + + my $s = $warnings != 1 ? 's' : ''; + my $warn = $warnings ? " ($warnings warning$s)" : ''; + info("Analysis completed$warn"); + + 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 try_use { eval "use @_;"; return $@ eq '' } + +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 try_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 rec_depend +{ + my($func, $seen) = @_; + return () unless exists $depends{$func}; + $seen = {%{$seen||{}}}; + return () if $seen->{$func}++; + my %s; + grep !$s{$_}++, map { ($_, rec_depend($_, $seen)) } @{$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; +my %given_warnings; +sub hint +{ + $opt{quiet} and return; + my $func = shift; + my $rv = 0; + if (exists $warnings{$func} && !$given_warnings{$func}++) { + my $warn = $warnings{$func}; + $warn =~ s!^!*** !mg; + print "*** WARNING: $func\n", $warn; + $rv++; + } + if ($opt{hints} && exists $hints{$func} && !$given_hints{$func}++) { + my $hint = $hints{$func}; + $hint =~ s/^/ /mg; + print " --- hint for $func ---\n", $hint; + } + $rv; +} + +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; +} + +sub strip +{ + my $self = do { local(@ARGV,$/)=($0); <> }; + my($copy) = $self =~ /^=head\d\s+COPYRIGHT\s*^(.*?)^=\w+/ms; + $copy =~ s/^(?=\S+)/ /gms; + $self =~ s/^$HS+Do NOT edit.*?(?=^-)/$copy/ms; + $self =~ s/^SKIP.*(?=^__DATA__)/SKIP +if (\@ARGV && \$ARGV[0] eq '--unstrip') { + eval { require Devel::PPPort }; + \$@ and die "Cannot require Devel::PPPort, please install.\\n"; + if (eval \$Devel::PPPort::VERSION < $VERSION) { + die "$0 was originally generated with Devel::PPPort $VERSION.\\n" + . "Your Devel::PPPort is only version \$Devel::PPPort::VERSION.\\n" + . "Please install a newer version, or --unstrip will not work.\\n"; + } + Devel::PPPort::WriteFile(\$0); + exit 0; +} +print <<END; + +Sorry, but this is a stripped version of \$0. + +To be able to use its original script and doc functionality, +please try to regenerate this file using: + + \$^X \$0 --unstrip + +END +/ms; + my($pl, $c) = $self =~ /(.*^__DATA__)(.*)/ms; + $c =~ s{ + / (?: \*[^*]*\*+(?:[^$ccs][^*]*\*+)* / | /[^\r\n]*) + | ( "[^"\\]*(?:\\.[^"\\]*)*" + | '[^'\\]*(?:\\.[^'\\]*)*' ) + | ($HS+) }{ defined $2 ? ' ' : ($1 || '') }gsex; + $c =~ s!\s+$!!mg; + $c =~ s!^$LF!!mg; + $c =~ s!^\s*#\s*!#!mg; + $c =~ s!^\s+!!mg; + + open OUT, ">$0" or die "cannot strip $0: $!\n"; + print OUT "$pl$c\n"; + + exit 0; +} + +__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 _dpppDEC2BCD(dec) ((((dec)/100)<<8)|((((dec)%100)/10)<<4)|((dec)%10)) +#define PERL_BCDVERSION ((_dpppDEC2BCD(PERL_REVISION)<<24)|(_dpppDEC2BCD(PERL_VERSION)<<12)|_dpppDEC2BCD(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 */ +#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 + +#if (PERL_BCDVERSION < 0x5006000) +# ifdef USE_THREADS +# define aTHXR thr +# define aTHXR_ thr, +# else +# define aTHXR +# define aTHXR_ +# endif +# define dTHXR dTHR +#else +# define aTHXR aTHX +# define aTHXR_ aTHX_ +# define dTHXR dTHX +#endif +#ifndef dTHXoa +# define dTHXoa(x) dTHXa(x) +#endif + +#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 LONGSIZE +# define LONGSIZE 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 LONGSIZE +# define LONGSIZE 4 +#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 + +#if !defined(SvUOK) && defined(SvIOK_UV) +# define SvUOK(sv) SvIOK_UV(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 + +#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 memEQs +# define memEQs(s1, l, s2) \ + (sizeof(s2)-1 == l && memEQ(s1, (s2 ""), (sizeof(s2)-1))) +#endif + +#ifndef memNEs +# define memNEs(s1, l, s2) !memEQs(s1, l, s2) +#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 PoisonWith +# define PoisonWith(d,n,t,b) (void)memset((char*)(d), (U8)(b), (n) * sizeof(t)) +#endif + +#ifndef PoisonNew +# define PoisonNew(d,n,t) PoisonWith(d,n,t,0xAB) +#endif + +#ifndef PoisonFree +# define PoisonFree(d,n,t) PoisonWith(d,n,t,0xEF) +#endif + +#ifndef Poison +# define Poison(d,n,t) PoisonFree(d,n,t) +#endif +#ifndef Newx +# define Newx(v,n,t) New(0,v,n,t) +#endif + +#ifndef Newxc +# define Newxc(v,n,t,c) Newc(0,v,n,t,c) +#endif + +#ifndef Newxz +# define Newxz(v,n,t) Newz(0,v,n,t) +#endif + +#ifndef PERL_UNUSED_DECL +# 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 +#endif + +#ifndef PERL_UNUSED_ARG +# if defined(lint) && defined(S_SPLINT_S) /* www.splint.org */ +# include <note.h> +# define PERL_UNUSED_ARG(x) NOTE(ARGUNUSED(x)) +# else +# define PERL_UNUSED_ARG(x) ((void)x) +# endif +#endif + +#ifndef PERL_UNUSED_VAR +# define PERL_UNUSED_VAR(x) ((void)x) +#endif + +#ifndef PERL_UNUSED_CONTEXT +# ifdef USE_ITHREADS +# define PERL_UNUSED_CONTEXT PERL_UNUSED_ARG(my_perl) +# else +# define PERL_UNUSED_CONTEXT +# endif +#endif +#ifndef NOOP +# define NOOP /*EMPTY*/(void)0 +#endif + +#ifndef dNOOP +# define dNOOP extern int /*@unused@*/ 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 +#endif + +#ifndef PTR2ul +# if PTRSIZE == LONGSIZE +# define PTR2ul(p) (unsigned long)(p) +# else +# define PTR2ul(p) INT2PTR(unsigned long,p) +# endif +#endif +#ifndef PTR2nat +# define PTR2nat(p) (PTRV)(p) +#endif + +#ifndef NUM2PTR +# define NUM2PTR(any,d) (any)PTR2nat(d) +#endif + +#ifndef PTR2IV +# define PTR2IV(p) INT2PTR(IV,p) +#endif + +#ifndef PTR2UV +# define PTR2UV(p) INT2PTR(UV,p) +#endif + +#ifndef PTR2NV +# define PTR2NV(p) NUM2PTR(NV,p) +#endif + +#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 + +#if defined(PERL_GCC_PEDANTIC) +# ifndef PERL_GCC_BRACE_GROUPS_FORBIDDEN +# define PERL_GCC_BRACE_GROUPS_FORBIDDEN +# endif +#endif + +#if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) && !defined(__cplusplus) +# ifndef PERL_USE_GCC_BRACE_GROUPS +# define PERL_USE_GCC_BRACE_GROUPS +# endif +#endif + +#undef STMT_START +#undef STMT_END +#ifdef PERL_USE_GCC_BRACE_GROUPS +# 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 + +#ifndef DEFSV_set +# define DEFSV_set(sv) (DEFSV = (sv)) +#endif + +/* Older perls (<=5.003) lack AvFILLp */ +#ifndef AvFILLp +# define AvFILLp AvFILL +#endif +#ifndef ERRSV +# define ERRSV get_sv("@",FALSE) +#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 */ +#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 dXSTARG +# define dXSTARG SV * targ = sv_newmortal() +#endif +#ifndef dAXMARK +# define dAXMARK I32 ax = POPMARK; \ + register SV ** const mark = PL_stack_base + ax++ +#endif +#ifndef XSprePUSH +# define XSprePUSH (sp = PL_stack_base + ax - 1) +#endif + +#if (PERL_BCDVERSION < 0x5005000) +# undef XSRETURN +# define XSRETURN(off) \ + STMT_START { \ + PL_stack_sp = PL_stack_base + ax + ((off) - 1); \ + return; \ + } STMT_END +#endif +#ifndef XSPROTO +# define XSPROTO(name) void name(pTHX_ CV* cv) +#endif + +#ifndef SVfARG +# define SVfARG(p) ((void*)(p)) +#endif +#ifndef PERL_ABS +# define PERL_ABS(x) ((x) < 0 ? -(x) : (x)) +#endif +#ifndef dVAR +# define dVAR dNOOP +#endif +#ifndef SVf +# define SVf "_" +#endif +#ifndef UTF8_MAXBYTES +# define UTF8_MAXBYTES UTF8_MAXLEN +#endif +#ifndef CPERLscope +# define CPERLscope(x) x +#endif +#ifndef PERL_HASH +# define PERL_HASH(hash,str,len) \ + STMT_START { \ + const char *s_PeRlHaSh = str; \ + I32 i_PeRlHaSh = len; \ + U32 hash_PeRlHaSh = 0; \ + while (i_PeRlHaSh--) \ + hash_PeRlHaSh = hash_PeRlHaSh * 33 + *s_PeRlHaSh++; \ + (hash) = hash_PeRlHaSh; \ + } STMT_END +#endif + +#ifndef PERLIO_FUNCS_DECL +# ifdef PERLIO_FUNCS_CONST +# define PERLIO_FUNCS_DECL(funcs) const PerlIO_funcs funcs +# define PERLIO_FUNCS_CAST(funcs) (PerlIO_funcs*)(funcs) +# else +# define PERLIO_FUNCS_DECL(funcs) PerlIO_funcs funcs +# define PERLIO_FUNCS_CAST(funcs) (funcs) +# endif +#endif + +/* provide these typedefs for older perls */ +#if (PERL_BCDVERSION < 0x5009003) + +# ifdef ARGSproto +typedef OP* (CPERLscope(*Perl_ppaddr_t))(ARGSproto); +# else +typedef OP* (CPERLscope(*Perl_ppaddr_t))(pTHX); +# endif + +typedef OP* (CPERLscope(*Perl_check_t)) (pTHX_ OP*); + +#endif +#ifndef isPSXSPC +# define isPSXSPC(c) (isSPACE(c) || (c) == '\v') +#endif + +#ifndef isBLANK +# define isBLANK(c) ((c) == ' ' || (c) == '\t') +#endif + +#ifdef EBCDIC +#ifndef isALNUMC +# define isALNUMC(c) isalnum(c) +#endif + +#ifndef isASCII +# define isASCII(c) isascii(c) +#endif + +#ifndef isCNTRL +# define isCNTRL(c) iscntrl(c) +#endif + +#ifndef isGRAPH +# define isGRAPH(c) isgraph(c) +#endif + +#ifndef isPRINT +# define isPRINT(c) isprint(c) +#endif + +#ifndef isPUNCT +# define isPUNCT(c) ispunct(c) +#endif + +#ifndef isXDIGIT +# define isXDIGIT(c) isxdigit(c) +#endif + +#else +# if (PERL_BCDVERSION < 0x5010000) +/* Hint: isPRINT + * The implementation in older perl versions includes all of the + * isSPACE() characters, which is wrong. The version provided by + * Devel::PPPort always overrides a present buggy version. + */ +# undef isPRINT +# endif + +#ifdef HAS_QUAD +# define WIDEST_UTYPE U64TYPE +#else +# define WIDEST_UTYPE U32 +#endif +#ifndef isALNUMC +# define isALNUMC(c) (isALPHA(c) || isDIGIT(c)) +#endif + +#ifndef isASCII +# define isASCII(c) ((WIDEST_UTYPE) (c) <= 127) +#endif + +#ifndef isCNTRL +# define isCNTRL(c) ((WIDEST_UTYPE) (c) < ' ' || (c) == 127) +#endif + +#ifndef isGRAPH +# define isGRAPH(c) (isALNUM(c) || isPUNCT(c)) +#endif + +#ifndef isPRINT +# define isPRINT(c) (((c) >= 32 && (c) < 127)) +#endif + +#ifndef isPUNCT +# define isPUNCT(c) (((c) >= 33 && (c) <= 47) || ((c) >= 58 && (c) <= 64) || ((c) >= 91 && (c) <= 96) || ((c) >= 123 && (c) <= 126)) +#endif + +#ifndef isXDIGIT +# define isXDIGIT(c) (isDIGIT(c) || ((c) >= 'a' && (c) <= 'f') || ((c) >= 'A' && (c) <= 'F')) +#endif + +#endif + +#ifndef PERL_SIGNALS_UNSAFE_FLAG + +#define PERL_SIGNALS_UNSAFE_FLAG 0x0001 + +#if (PERL_BCDVERSION < 0x5008000) +# define D_PPP_PERL_SIGNALS_INIT PERL_SIGNALS_UNSAFE_FLAG +#else +# define D_PPP_PERL_SIGNALS_INIT 0 +#endif + +#if defined(NEED_PL_signals) +static U32 DPPP_(my_PL_signals) = D_PPP_PERL_SIGNALS_INIT; +#elif defined(NEED_PL_signals_GLOBAL) +U32 DPPP_(my_PL_signals) = D_PPP_PERL_SIGNALS_INIT; +#else +extern U32 DPPP_(my_PL_signals); +#endif +#define PL_signals DPPP_(my_PL_signals) + +#endif + +/* Hint: PL_ppaddr + * Calling an op via PL_ppaddr requires passing a context argument + * for threaded builds. Since the context argument is different for + * 5.005 perls, you can use aTHXR (supplied by ppport.h), which will + * automatically be defined as the correct argument. + */ + +#if (PERL_BCDVERSION <= 0x5005005) +/* Replace: 1 */ +# define PL_ppaddr ppaddr +# define PL_no_modify no_modify +/* Replace: 0 */ +#endif + +#if (PERL_BCDVERSION <= 0x5004005) +/* Replace: 1 */ +# define PL_DBsignal DBsignal +# define PL_DBsingle DBsingle +# define PL_DBsub DBsub +# define PL_DBtrace DBtrace +# define PL_Sv Sv +# define PL_bufend bufend +# define PL_bufptr bufptr +# 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_error_count error_count +# define PL_expect expect +# define PL_hexdigit hexdigit +# define PL_hints hints +# define PL_in_my in_my +# define PL_laststatval laststatval +# define PL_lex_state lex_state +# define PL_lex_stuff lex_stuff +# define PL_linestr linestr +# define PL_na na +# define PL_perl_destruct_level perl_destruct_level +# define PL_perldb perldb +# define PL_rsfp_filters rsfp_filters +# define PL_rsfp rsfp +# define PL_stack_base stack_base +# define PL_stack_sp stack_sp +# define PL_statcache statcache +# 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 +# define PL_tokenbuf tokenbuf +/* Replace: 0 */ +#endif + +/* Warning: PL_parser + * For perl versions earlier than 5.9.5, this is an always + * non-NULL dummy. Also, it cannot be dereferenced. Don't + * use it if you can avoid is and unless you absolutely know + * what you're doing. + * If you always check that PL_parser is non-NULL, you can + * define DPPP_PL_parser_NO_DUMMY to avoid the creation of + * a dummy parser structure. + */ + +#if (PERL_BCDVERSION >= 0x5009005) +# ifdef DPPP_PL_parser_NO_DUMMY +# define D_PPP_my_PL_parser_var(var) ((PL_parser ? PL_parser : \ + (croak("panic: PL_parser == NULL in %s:%d", \ + __FILE__, __LINE__), (yy_parser *) NULL))->var) +# else +# ifdef DPPP_PL_parser_NO_DUMMY_WARNING +# define D_PPP_parser_dummy_warning(var) +# else +# define D_PPP_parser_dummy_warning(var) \ + warn("warning: dummy PL_" #var " used in %s:%d", __FILE__, __LINE__), +# endif +# define D_PPP_my_PL_parser_var(var) ((PL_parser ? PL_parser : \ + (D_PPP_parser_dummy_warning(var) &DPPP_(dummy_PL_parser)))->var) +#if defined(NEED_PL_parser) +static yy_parser DPPP_(dummy_PL_parser); +#elif defined(NEED_PL_parser_GLOBAL) +yy_parser DPPP_(dummy_PL_parser); +#else +extern yy_parser DPPP_(dummy_PL_parser); +#endif + +# endif + +/* PL_expect, PL_copline, PL_rsfp, PL_rsfp_filters, PL_linestr, PL_bufptr, PL_bufend, PL_lex_state, PL_lex_stuff, PL_tokenbuf depends on PL_parser */ +/* Warning: PL_expect, PL_copline, PL_rsfp, PL_rsfp_filters, PL_linestr, PL_bufptr, PL_bufend, PL_lex_state, PL_lex_stuff, PL_tokenbuf + * Do not use this variable unless you know exactly what you're + * doint. It is internal to the perl parser and may change or even + * be removed in the future. As of perl 5.9.5, you have to check + * for (PL_parser != NULL) for this variable to have any effect. + * An always non-NULL PL_parser dummy is provided for earlier + * perl versions. + * If PL_parser is NULL when you try to access this variable, a + * dummy is being accessed instead and a warning is issued unless + * you define DPPP_PL_parser_NO_DUMMY_WARNING. + * If DPPP_PL_parser_NO_DUMMY is defined, the code trying to access + * this variable will croak with a panic message. + */ + +# define PL_expect D_PPP_my_PL_parser_var(expect) +# define PL_copline D_PPP_my_PL_parser_var(copline) +# define PL_rsfp D_PPP_my_PL_parser_var(rsfp) +# define PL_rsfp_filters D_PPP_my_PL_parser_var(rsfp_filters) +# define PL_linestr D_PPP_my_PL_parser_var(linestr) +# define PL_bufptr D_PPP_my_PL_parser_var(bufptr) +# define PL_bufend D_PPP_my_PL_parser_var(bufend) +# define PL_lex_state D_PPP_my_PL_parser_var(lex_state) +# define PL_lex_stuff D_PPP_my_PL_parser_var(lex_stuff) +# define PL_tokenbuf D_PPP_my_PL_parser_var(tokenbuf) +# define PL_in_my D_PPP_my_PL_parser_var(in_my) +# define PL_in_my_stash D_PPP_my_PL_parser_var(in_my_stash) +# define PL_error_count D_PPP_my_PL_parser_var(error_count) + + +#else + +/* ensure that PL_parser != NULL and cannot be dereferenced */ +# define PL_parser ((void *) 1) + +#endif +#ifndef mPUSHs +# define mPUSHs(s) PUSHs(sv_2mortal(s)) +#endif + +#ifndef PUSHmortal +# define PUSHmortal PUSHs(sv_newmortal()) +#endif + +#ifndef mPUSHp +# define mPUSHp(p,l) sv_setpvn(PUSHmortal, (p), (l)) +#endif + +#ifndef mPUSHn +# define mPUSHn(n) sv_setnv(PUSHmortal, (NV)(n)) +#endif + +#ifndef mPUSHi +# define mPUSHi(i) sv_setiv(PUSHmortal, (IV)(i)) +#endif + +#ifndef mPUSHu +# define mPUSHu(u) sv_setuv(PUSHmortal, (UV)(u)) +#endif +#ifndef mXPUSHs +# define mXPUSHs(s) XPUSHs(sv_2mortal(s)) +#endif + +#ifndef XPUSHmortal +# define XPUSHmortal XPUSHs(sv_newmortal()) +#endif + +#ifndef mXPUSHp +# define mXPUSHp(p,l) STMT_START { EXTEND(sp,1); sv_setpvn(PUSHmortal, (p), (l)); } STMT_END +#endif + +#ifndef mXPUSHn +# define mXPUSHn(n) STMT_START { EXTEND(sp,1); sv_setnv(PUSHmortal, (NV)(n)); } STMT_END +#endif + +#ifndef mXPUSHi +# define mXPUSHi(i) STMT_START { EXTEND(sp,1); sv_setiv(PUSHmortal, (IV)(i)); } STMT_END +#endif + +#ifndef mXPUSHu +# define mXPUSHu(u) STMT_START { EXTEND(sp,1); sv_setuv(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 */ +#ifndef PERL_LOADMOD_DENY +# define PERL_LOADMOD_DENY 0x1 +#endif + +#ifndef PERL_LOADMOD_NOIMPORT +# define PERL_LOADMOD_NOIMPORT 0x2 +#endif + +#ifndef PERL_LOADMOD_IMPORT_OPS +# define PERL_LOADMOD_IMPORT_OPS 0x4 +#endif + +#ifndef G_METHOD +# define G_METHOD 64 +# ifdef call_sv +# undef call_sv +# endif +# if (PERL_BCDVERSION < 0x5006000) +# define call_sv(sv, flags) ((flags) & G_METHOD ? perl_call_method((char *) SvPV_nolen_const(sv), \ + (flags) & ~G_METHOD) : perl_call_sv(sv, flags)) +# else +# define call_sv(sv, flags) ((flags) & G_METHOD ? Perl_call_method(aTHX_ (char *) SvPV_nolen_const(sv), \ + (flags) & ~G_METHOD) : Perl_call_sv(aTHX_ sv, flags)) +# endif +#endif + +/* Replace perl_eval_pv with eval_pv */ + +#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 vload_module +#if defined(NEED_vload_module) +static void DPPP_(my_vload_module)(U32 flags, SV *name, SV *ver, va_list *args); +static +#else +extern void DPPP_(my_vload_module)(U32 flags, SV *name, SV *ver, va_list *args); +#endif + +#ifdef vload_module +# undef vload_module +#endif +#define vload_module(a,b,c,d) DPPP_(my_vload_module)(aTHX_ a,b,c,d) +#define Perl_vload_module DPPP_(my_vload_module) + +#if defined(NEED_vload_module) || defined(NEED_vload_module_GLOBAL) + +void +DPPP_(my_vload_module)(U32 flags, SV *name, SV *ver, va_list *args) +{ + dTHR; + dVAR; + OP *veop, *imop; + + OP * const modname = newSVOP(OP_CONST, 0, name); + /* 5.005 has a somewhat hacky force_normal that doesn't croak on + SvREADONLY() if PL_compling is true. Current perls take care in + ck_require() to correctly turn off SvREADONLY before calling + force_normal_flags(). This seems a better fix than fudging PL_compling + */ + SvREADONLY_off(((SVOP*)modname)->op_sv); + modname->op_private |= OPpCONST_BARE; + if (ver) { + veop = newSVOP(OP_CONST, 0, ver); + } + else + veop = NULL; + if (flags & PERL_LOADMOD_NOIMPORT) { + imop = sawparens(newNULLLIST()); + } + else if (flags & PERL_LOADMOD_IMPORT_OPS) { + imop = va_arg(*args, OP*); + } + else { + SV *sv; + imop = NULL; + sv = va_arg(*args, SV*); + while (sv) { + imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv)); + sv = va_arg(*args, SV*); + } + } + { + const line_t ocopline = PL_copline; + COP * const ocurcop = PL_curcop; + const int oexpect = PL_expect; + +#if (PERL_BCDVERSION >= 0x5004000) + utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0), + veop, modname, imop); +#else + utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(), + modname, imop); +#endif + PL_expect = oexpect; + PL_copline = ocopline; + PL_curcop = ocurcop; + } +} + +#endif +#endif + +#ifndef load_module +#if defined(NEED_load_module) +static void DPPP_(my_load_module)(U32 flags, SV *name, SV *ver, ...); +static +#else +extern void DPPP_(my_load_module)(U32 flags, SV *name, SV *ver, ...); +#endif + +#ifdef load_module +# undef load_module +#endif +#define load_module DPPP_(my_load_module) +#define Perl_load_module DPPP_(my_load_module) + +#if defined(NEED_load_module) || defined(NEED_load_module_GLOBAL) + +void +DPPP_(my_load_module)(U32 flags, SV *name, SV *ver, ...) +{ + va_list args; + va_start(args, ver); + vload_module(flags, name, ver, &args); + va_end(args); +} + +#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_BCDVERSION < 0x5004063) && (PERL_BCDVERSION != 0x5004005) +#if defined(NEED_newCONSTSUB) +static void DPPP_(my_newCONSTSUB)(HV *stash, const char *name, SV *sv); +static +#else +extern void DPPP_(my_newCONSTSUB)(HV *stash, const 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) + +/* This is just a trick to avoid a dependency of newCONSTSUB on PL_parser */ +/* (There's no PL_parser in perl < 5.005, so this is completely safe) */ +#define D_PPP_PL_copline PL_copline + +void +DPPP_(my_newCONSTSUB)(HV *stash, const 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 = D_PPP_PL_copline; + + PL_hints &= ~HINT_BLOCK_SCOPE; + if (stash) + PL_curstash = PL_curcop->cop_stash = stash; + + newSUB( + +#if (PERL_BCDVERSION < 0x5003022) + start_subparse(), +#elif (PERL_BCDVERSION == 0x5003022) + start_subparse(0), +#else /* 5.003_23 onwards */ + start_subparse(FALSE, 0), +#endif + + newSVOP(OP_CONST, 0, newSVpv((char *) 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_BCDVERSION < 0x5004068) +/* 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" +# elif IVSIZE == INTSIZE +# define IVdf "d" +# define UVuf "u" +# define UVof "o" +# define UVxf "x" +# define UVXf "X" +# else +# error "cannot define IV/UV formats" +# endif +#endif + +#ifndef NVef +# if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE) && \ + defined(PERL_PRIfldbl) && (PERL_BCDVERSION != 0x5006000) + /* 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 SvREFCNT_inc +# ifdef PERL_USE_GCC_BRACE_GROUPS +# define SvREFCNT_inc(sv) \ + ({ \ + SV * const _sv = (SV*)(sv); \ + if (_sv) \ + (SvREFCNT(_sv))++; \ + _sv; \ + }) +# else +# define SvREFCNT_inc(sv) \ + ((PL_Sv=(SV*)(sv)) ? (++(SvREFCNT(PL_Sv)),PL_Sv) : NULL) +# endif +#endif + +#ifndef SvREFCNT_inc_simple +# ifdef PERL_USE_GCC_BRACE_GROUPS +# define SvREFCNT_inc_simple(sv) \ + ({ \ + if (sv) \ + (SvREFCNT(sv))++; \ + (SV *)(sv); \ + }) +# else +# define SvREFCNT_inc_simple(sv) \ + ((sv) ? (SvREFCNT(sv)++,(SV*)(sv)) : NULL) +# endif +#endif + +#ifndef SvREFCNT_inc_NN +# ifdef PERL_USE_GCC_BRACE_GROUPS +# define SvREFCNT_inc_NN(sv) \ + ({ \ + SV * const _sv = (SV*)(sv); \ + SvREFCNT(_sv)++; \ + _sv; \ + }) +# else +# define SvREFCNT_inc_NN(sv) \ + (PL_Sv=(SV*)(sv),++(SvREFCNT(PL_Sv)),PL_Sv) +# endif +#endif + +#ifndef SvREFCNT_inc_void +# ifdef PERL_USE_GCC_BRACE_GROUPS +# define SvREFCNT_inc_void(sv) \ + ({ \ + SV * const _sv = (SV*)(sv); \ + if (_sv) \ + (void)(SvREFCNT(_sv)++); \ + }) +# else +# define SvREFCNT_inc_void(sv) \ + (void)((PL_Sv=(SV*)(sv)) ? ++(SvREFCNT(PL_Sv)) : 0) +# endif +#endif +#ifndef SvREFCNT_inc_simple_void +# define SvREFCNT_inc_simple_void(sv) STMT_START { if (sv) SvREFCNT(sv)++; } STMT_END +#endif + +#ifndef SvREFCNT_inc_simple_NN +# define SvREFCNT_inc_simple_NN(sv) (++SvREFCNT(sv), (SV*)(sv)) +#endif + +#ifndef SvREFCNT_inc_void_NN +# define SvREFCNT_inc_void_NN(sv) (void)(++SvREFCNT((SV*)(sv))) +#endif + +#ifndef SvREFCNT_inc_simple_void_NN +# define SvREFCNT_inc_simple_void_NN(sv) (void)(++SvREFCNT((SV*)(sv))) +#endif + +#ifndef newSV_type + +#if defined(NEED_newSV_type) +static SV* DPPP_(my_newSV_type)(pTHX_ svtype const t); +static +#else +extern SV* DPPP_(my_newSV_type)(pTHX_ svtype const t); +#endif + +#ifdef newSV_type +# undef newSV_type +#endif +#define newSV_type(a) DPPP_(my_newSV_type)(aTHX_ a) +#define Perl_newSV_type DPPP_(my_newSV_type) + +#if defined(NEED_newSV_type) || defined(NEED_newSV_type_GLOBAL) + +SV* +DPPP_(my_newSV_type)(pTHX_ svtype const t) +{ + SV* const sv = newSV(0); + sv_upgrade(sv, t); + return sv; +} + +#endif + +#endif + +#if (PERL_BCDVERSION < 0x5006000) +# define D_PPP_CONSTPV_ARG(x) ((char *) (x)) +#else +# define D_PPP_CONSTPV_ARG(x) (x) +#endif +#ifndef newSVpvn +# define newSVpvn(data,len) ((data) \ + ? ((len) ? newSVpv((data), (len)) : newSVpv("", 0)) \ + : newSV(0)) +#endif +#ifndef newSVpvn_utf8 +# define newSVpvn_utf8(s, len, u) newSVpvn_flags((s), (len), (u) ? SVf_UTF8 : 0) +#endif +#ifndef SVf_UTF8 +# define SVf_UTF8 0 +#endif + +#ifndef newSVpvn_flags + +#if defined(NEED_newSVpvn_flags) +static SV * DPPP_(my_newSVpvn_flags)(pTHX_ const char *s, STRLEN len, U32 flags); +static +#else +extern SV * DPPP_(my_newSVpvn_flags)(pTHX_ const char *s, STRLEN len, U32 flags); +#endif + +#ifdef newSVpvn_flags +# undef newSVpvn_flags +#endif +#define newSVpvn_flags(a,b,c) DPPP_(my_newSVpvn_flags)(aTHX_ a,b,c) +#define Perl_newSVpvn_flags DPPP_(my_newSVpvn_flags) + +#if defined(NEED_newSVpvn_flags) || defined(NEED_newSVpvn_flags_GLOBAL) + +SV * +DPPP_(my_newSVpvn_flags)(pTHX_ const char *s, STRLEN len, U32 flags) +{ + SV *sv = newSVpvn(D_PPP_CONSTPV_ARG(s), len); + SvFLAGS(sv) |= (flags & SVf_UTF8); + return (flags & SVs_TEMP) ? sv_2mortal(sv) : sv; +} + +#endif + +#endif + +/* Backwards compatibility stuff... :-( */ +#if !defined(NEED_sv_2pv_flags) && defined(NEED_sv_2pv_nolen) +# define NEED_sv_2pv_flags +#endif +#if !defined(NEED_sv_2pv_flags_GLOBAL) && defined(NEED_sv_2pv_nolen_GLOBAL) +# define NEED_sv_2pv_flags_GLOBAL +#endif + +/* Hint: sv_2pv_nolen + * Use the SvPV_nolen() or SvPV_nolen_const() macros instead of sv_2pv_nolen(). + */ +#ifndef sv_2pv_nolen +# define sv_2pv_nolen(sv) SvPV_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_BCDVERSION < 0x5007000) + +#if defined(NEED_sv_2pvbyte) +static char * DPPP_(my_sv_2pvbyte)(pTHX_ SV *sv, STRLEN *lp); +static +#else +extern char * DPPP_(my_sv_2pvbyte)(pTHX_ 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_ 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 + +#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 +#ifndef sv_2pvbyte_nolen +# define sv_2pvbyte_nolen(sv) sv_2pv_nolen(sv) +#endif + +/* Hint: sv_pvn + * Always use the SvPV() macro instead of sv_pvn(). + */ + +/* Hint: sv_pvn_force + * Always use the SvPV_force() macro instead of sv_pvn_force(). + */ + +/* If these are undefined, they're not handled by the core anyway */ +#ifndef SV_IMMEDIATE_UNREF +# define SV_IMMEDIATE_UNREF 0 +#endif + +#ifndef SV_GMAGIC +# define SV_GMAGIC 0 +#endif + +#ifndef SV_COW_DROP_PV +# define SV_COW_DROP_PV 0 +#endif + +#ifndef SV_UTF8_NO_ENCODING +# define SV_UTF8_NO_ENCODING 0 +#endif + +#ifndef SV_NOSTEAL +# define SV_NOSTEAL 0 +#endif + +#ifndef SV_CONST_RETURN +# define SV_CONST_RETURN 0 +#endif + +#ifndef SV_MUTABLE_RETURN +# define SV_MUTABLE_RETURN 0 +#endif + +#ifndef SV_SMAGIC +# define SV_SMAGIC 0 +#endif + +#ifndef SV_HAS_TRAILING_NUL +# define SV_HAS_TRAILING_NUL 0 +#endif + +#ifndef SV_COW_SHARED_HASH_KEYS +# define SV_COW_SHARED_HASH_KEYS 0 +#endif + +#if (PERL_BCDVERSION < 0x5007002) + +#if defined(NEED_sv_2pv_flags) +static char * DPPP_(my_sv_2pv_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags); +static +#else +extern char * DPPP_(my_sv_2pv_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags); +#endif + +#ifdef sv_2pv_flags +# undef sv_2pv_flags +#endif +#define sv_2pv_flags(a,b,c) DPPP_(my_sv_2pv_flags)(aTHX_ a,b,c) +#define Perl_sv_2pv_flags DPPP_(my_sv_2pv_flags) + +#if defined(NEED_sv_2pv_flags) || defined(NEED_sv_2pv_flags_GLOBAL) + +char * +DPPP_(my_sv_2pv_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags) +{ + STRLEN n_a = (STRLEN) flags; + return sv_2pv(sv, lp ? lp : &n_a); +} + +#endif + +#if defined(NEED_sv_pvn_force_flags) +static char * DPPP_(my_sv_pvn_force_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags); +static +#else +extern char * DPPP_(my_sv_pvn_force_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags); +#endif + +#ifdef sv_pvn_force_flags +# undef sv_pvn_force_flags +#endif +#define sv_pvn_force_flags(a,b,c) DPPP_(my_sv_pvn_force_flags)(aTHX_ a,b,c) +#define Perl_sv_pvn_force_flags DPPP_(my_sv_pvn_force_flags) + +#if defined(NEED_sv_pvn_force_flags) || defined(NEED_sv_pvn_force_flags_GLOBAL) + +char * +DPPP_(my_sv_pvn_force_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags) +{ + STRLEN n_a = (STRLEN) flags; + return sv_pvn_force(sv, lp ? lp : &n_a); +} + +#endif + +#endif + +#if (PERL_BCDVERSION < 0x5008008) || ( (PERL_BCDVERSION >= 0x5009000) && (PERL_BCDVERSION < 0x5009003) ) +# define DPPP_SVPV_NOLEN_LP_ARG &PL_na +#else +# define DPPP_SVPV_NOLEN_LP_ARG 0 +#endif +#ifndef SvPV_const +# define SvPV_const(sv, lp) SvPV_flags_const(sv, lp, SV_GMAGIC) +#endif + +#ifndef SvPV_mutable +# define SvPV_mutable(sv, lp) SvPV_flags_mutable(sv, lp, SV_GMAGIC) +#endif +#ifndef SvPV_flags +# define SvPV_flags(sv, lp, flags) \ + ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ + ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pv_flags(sv, &lp, flags)) +#endif +#ifndef SvPV_flags_const +# define SvPV_flags_const(sv, lp, flags) \ + ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ + ? ((lp = SvCUR(sv)), SvPVX_const(sv)) : \ + (const char*) sv_2pv_flags(sv, &lp, flags|SV_CONST_RETURN)) +#endif +#ifndef SvPV_flags_const_nolen +# define SvPV_flags_const_nolen(sv, flags) \ + ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ + ? SvPVX_const(sv) : \ + (const char*) sv_2pv_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, flags|SV_CONST_RETURN)) +#endif +#ifndef SvPV_flags_mutable +# define SvPV_flags_mutable(sv, lp, flags) \ + ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ + ? ((lp = SvCUR(sv)), SvPVX_mutable(sv)) : \ + sv_2pv_flags(sv, &lp, flags|SV_MUTABLE_RETURN)) +#endif +#ifndef SvPV_force +# define SvPV_force(sv, lp) SvPV_force_flags(sv, lp, SV_GMAGIC) +#endif + +#ifndef SvPV_force_nolen +# define SvPV_force_nolen(sv) SvPV_force_flags_nolen(sv, SV_GMAGIC) +#endif + +#ifndef SvPV_force_mutable +# define SvPV_force_mutable(sv, lp) SvPV_force_flags_mutable(sv, lp, SV_GMAGIC) +#endif + +#ifndef SvPV_force_nomg +# define SvPV_force_nomg(sv, lp) SvPV_force_flags(sv, lp, 0) +#endif + +#ifndef SvPV_force_nomg_nolen +# define SvPV_force_nomg_nolen(sv) SvPV_force_flags_nolen(sv, 0) +#endif +#ifndef SvPV_force_flags +# define SvPV_force_flags(sv, lp, flags) \ + ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \ + ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_pvn_force_flags(sv, &lp, flags)) +#endif +#ifndef SvPV_force_flags_nolen +# define SvPV_force_flags_nolen(sv, flags) \ + ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \ + ? SvPVX(sv) : sv_pvn_force_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, flags)) +#endif +#ifndef SvPV_force_flags_mutable +# define SvPV_force_flags_mutable(sv, lp, flags) \ + ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \ + ? ((lp = SvCUR(sv)), SvPVX_mutable(sv)) \ + : sv_pvn_force_flags(sv, &lp, flags|SV_MUTABLE_RETURN)) +#endif +#ifndef SvPV_nolen +# define SvPV_nolen(sv) \ + ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ + ? SvPVX(sv) : sv_2pv_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, SV_GMAGIC)) +#endif +#ifndef SvPV_nolen_const +# define SvPV_nolen_const(sv) \ + ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ + ? SvPVX_const(sv) : sv_2pv_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, SV_GMAGIC|SV_CONST_RETURN)) +#endif +#ifndef SvPV_nomg +# define SvPV_nomg(sv, lp) SvPV_flags(sv, lp, 0) +#endif + +#ifndef SvPV_nomg_const +# define SvPV_nomg_const(sv, lp) SvPV_flags_const(sv, lp, 0) +#endif + +#ifndef SvPV_nomg_const_nolen +# define SvPV_nomg_const_nolen(sv) SvPV_flags_const_nolen(sv, 0) +#endif + +#ifndef SvPV_nomg_nolen +# define SvPV_nomg_nolen(sv) ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ + ? SvPVX(sv) : sv_2pv_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, 0)) +#endif +#ifndef SvPV_renew +# define SvPV_renew(sv,n) STMT_START { SvLEN_set(sv, n); \ + SvPV_set((sv), (char *) saferealloc( \ + (Malloc_t)SvPVX(sv), (MEM_SIZE)((n)))); \ + } STMT_END +#endif +#ifndef SvMAGIC_set +# define SvMAGIC_set(sv, val) \ + STMT_START { assert(SvTYPE(sv) >= SVt_PVMG); \ + (((XPVMG*) SvANY(sv))->xmg_magic = (val)); } STMT_END +#endif + +#if (PERL_BCDVERSION < 0x5009003) +#ifndef SvPVX_const +# define SvPVX_const(sv) ((const char*) (0 + SvPVX(sv))) +#endif + +#ifndef SvPVX_mutable +# define SvPVX_mutable(sv) (0 + SvPVX(sv)) +#endif +#ifndef SvRV_set +# define SvRV_set(sv, val) \ + STMT_START { assert(SvTYPE(sv) >= SVt_RV); \ + (((XRV*) SvANY(sv))->xrv_rv = (val)); } STMT_END +#endif + +#else +#ifndef SvPVX_const +# define SvPVX_const(sv) ((const char*)((sv)->sv_u.svu_pv)) +#endif + +#ifndef SvPVX_mutable +# define SvPVX_mutable(sv) ((sv)->sv_u.svu_pv) +#endif +#ifndef SvRV_set +# define SvRV_set(sv, val) \ + STMT_START { assert(SvTYPE(sv) >= SVt_RV); \ + ((sv)->sv_u.svu_rv = (val)); } STMT_END +#endif + +#endif +#ifndef SvSTASH_set +# define SvSTASH_set(sv, val) \ + STMT_START { assert(SvTYPE(sv) >= SVt_PVMG); \ + (((XPVMG*) SvANY(sv))->xmg_stash = (val)); } STMT_END +#endif + +#if (PERL_BCDVERSION < 0x5004000) +#ifndef SvUV_set +# define SvUV_set(sv, val) \ + STMT_START { assert(SvTYPE(sv) == SVt_IV || SvTYPE(sv) >= SVt_PVIV); \ + (((XPVIV*) SvANY(sv))->xiv_iv = (IV) (val)); } STMT_END +#endif + +#else +#ifndef SvUV_set +# define SvUV_set(sv, val) \ + STMT_START { assert(SvTYPE(sv) == SVt_IV || SvTYPE(sv) >= SVt_PVIV); \ + (((XPVUV*) SvANY(sv))->xuv_uv = (val)); } STMT_END +#endif + +#endif + +#if (PERL_BCDVERSION >= 0x5004000) && !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 + +#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vcatpvf) +# define sv_vcatpvf(sv, pat, args) sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)) +#endif + +#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vsetpvf) +# define sv_vsetpvf(sv, pat, args) sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)) +#endif + +#if (PERL_BCDVERSION >= 0x5004000) && !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 + +#ifdef PERL_IMPLICIT_CONTEXT +#if (PERL_BCDVERSION >= 0x5004000) && !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 + +/* sv_catpvf_mg depends on sv_catpvf_mg_nocontext */ +#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 + +#if (PERL_BCDVERSION >= 0x5004000) && !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 + +#if (PERL_BCDVERSION >= 0x5004000) && !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 + +#ifdef PERL_IMPLICIT_CONTEXT +#if (PERL_BCDVERSION >= 0x5004000) && !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 + +/* sv_setpvf_mg depends on sv_setpvf_mg_nocontext */ +#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 + +#if (PERL_BCDVERSION >= 0x5004000) && !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 + +/* Hint: newSVpvn_share + * The SVs created by this function only mimic the behaviour of + * shared PVs without really being shared. Only use if you know + * what you're doing. + */ + +#ifndef newSVpvn_share + +#if defined(NEED_newSVpvn_share) +static SV * DPPP_(my_newSVpvn_share)(pTHX_ const char *src, I32 len, U32 hash); +static +#else +extern SV * DPPP_(my_newSVpvn_share)(pTHX_ const char *src, I32 len, U32 hash); +#endif + +#ifdef newSVpvn_share +# undef newSVpvn_share +#endif +#define newSVpvn_share(a,b,c) DPPP_(my_newSVpvn_share)(aTHX_ a,b,c) +#define Perl_newSVpvn_share DPPP_(my_newSVpvn_share) + +#if defined(NEED_newSVpvn_share) || defined(NEED_newSVpvn_share_GLOBAL) + +SV * +DPPP_(my_newSVpvn_share)(pTHX_ const char *src, I32 len, U32 hash) +{ + SV *sv; + if (len < 0) + len = -len; + if (!hash) + PERL_HASH(hash, (char*) src, len); + sv = newSVpvn((char *) src, len); + sv_upgrade(sv, SVt_PVIV); + SvIVX(sv) = hash; + SvREADONLY_on(sv); + SvPOK_on(sv); + return sv; +} + +#endif + +#endif +#ifndef SvSHARED_HASH +# define SvSHARED_HASH(sv) (0 + SvUVX(sv)) +#endif +#ifndef HvNAME_get +# define HvNAME_get(hv) HvNAME(hv) +#endif +#ifndef HvNAMELEN_get +# define HvNAMELEN_get(hv) (HvNAME_get(hv) ? (I32)strlen(HvNAME_get(hv)) : 0) +#endif +#ifndef GvSVn +# define GvSVn(gv) GvSV(gv) +#endif + +#ifndef isGV_with_GP +# define isGV_with_GP(gv) isGV(gv) +#endif + +#ifndef gv_fetchpvn_flags +# define gv_fetchpvn_flags(name, len, flags, svt) gv_fetchpv(name, flags, svt) +#endif + +#ifndef gv_fetchsv +# define gv_fetchsv(name, flags, svt) gv_fetchpv(SvPV_nolen_const(name), flags, svt) +#endif +#ifndef get_cvn_flags +# define get_cvn_flags(name, namelen, flags) get_cv(name, flags) +#endif +#ifndef WARN_ALL +# define WARN_ALL 0 +#endif + +#ifndef WARN_CLOSURE +# define WARN_CLOSURE 1 +#endif + +#ifndef WARN_DEPRECATED +# define WARN_DEPRECATED 2 +#endif + +#ifndef WARN_EXITING +# define WARN_EXITING 3 +#endif + +#ifndef WARN_GLOB +# define WARN_GLOB 4 +#endif + +#ifndef WARN_IO +# define WARN_IO 5 +#endif + +#ifndef WARN_CLOSED +# define WARN_CLOSED 6 +#endif + +#ifndef WARN_EXEC +# define WARN_EXEC 7 +#endif + +#ifndef WARN_LAYER +# define WARN_LAYER 8 +#endif + +#ifndef WARN_NEWLINE +# define WARN_NEWLINE 9 +#endif + +#ifndef WARN_PIPE +# define WARN_PIPE 10 +#endif + +#ifndef WARN_UNOPENED +# define WARN_UNOPENED 11 +#endif + +#ifndef WARN_MISC +# define WARN_MISC 12 +#endif + +#ifndef WARN_NUMERIC +# define WARN_NUMERIC 13 +#endif + +#ifndef WARN_ONCE +# define WARN_ONCE 14 +#endif + +#ifndef WARN_OVERFLOW +# define WARN_OVERFLOW 15 +#endif + +#ifndef WARN_PACK +# define WARN_PACK 16 +#endif + +#ifndef WARN_PORTABLE +# define WARN_PORTABLE 17 +#endif + +#ifndef WARN_RECURSION +# define WARN_RECURSION 18 +#endif + +#ifndef WARN_REDEFINE +# define WARN_REDEFINE 19 +#endif + +#ifndef WARN_REGEXP +# define WARN_REGEXP 20 +#endif + +#ifndef WARN_SEVERE +# define WARN_SEVERE 21 +#endif + +#ifndef WARN_DEBUGGING +# define WARN_DEBUGGING 22 +#endif + +#ifndef WARN_INPLACE +# define WARN_INPLACE 23 +#endif + +#ifndef WARN_INTERNAL +# define WARN_INTERNAL 24 +#endif + +#ifndef WARN_MALLOC +# define WARN_MALLOC 25 +#endif + +#ifndef WARN_SIGNAL +# define WARN_SIGNAL 26 +#endif + +#ifndef WARN_SUBSTR +# define WARN_SUBSTR 27 +#endif + +#ifndef WARN_SYNTAX +# define WARN_SYNTAX 28 +#endif + +#ifndef WARN_AMBIGUOUS +# define WARN_AMBIGUOUS 29 +#endif + +#ifndef WARN_BAREWORD +# define WARN_BAREWORD 30 +#endif + +#ifndef WARN_DIGIT +# define WARN_DIGIT 31 +#endif + +#ifndef WARN_PARENTHESIS +# define WARN_PARENTHESIS 32 +#endif + +#ifndef WARN_PRECEDENCE +# define WARN_PRECEDENCE 33 +#endif + +#ifndef WARN_PRINTF +# define WARN_PRINTF 34 +#endif + +#ifndef WARN_PROTOTYPE +# define WARN_PROTOTYPE 35 +#endif + +#ifndef WARN_QW +# define WARN_QW 36 +#endif + +#ifndef WARN_RESERVED +# define WARN_RESERVED 37 +#endif + +#ifndef WARN_SEMICOLON +# define WARN_SEMICOLON 38 +#endif + +#ifndef WARN_TAINT +# define WARN_TAINT 39 +#endif + +#ifndef WARN_THREADS +# define WARN_THREADS 40 +#endif + +#ifndef WARN_UNINITIALIZED +# define WARN_UNINITIALIZED 41 +#endif + +#ifndef WARN_UNPACK +# define WARN_UNPACK 42 +#endif + +#ifndef WARN_UNTIE +# define WARN_UNTIE 43 +#endif + +#ifndef WARN_UTF8 +# define WARN_UTF8 44 +#endif + +#ifndef WARN_VOID +# define WARN_VOID 45 +#endif + +#ifndef WARN_ASSERTIONS +# define WARN_ASSERTIONS 46 +#endif +#ifndef packWARN +# define packWARN(a) (a) +#endif + +#ifndef ckWARN +# ifdef G_WARN_ON +# define ckWARN(a) (PL_dowarn & G_WARN_ON) +# else +# define ckWARN(a) PL_dowarn +# endif +#endif + +#if (PERL_BCDVERSION >= 0x5004000) && !defined(warner) +#if defined(NEED_warner) +static void DPPP_(my_warner)(U32 err, const char *pat, ...); +static +#else +extern void DPPP_(my_warner)(U32 err, const char *pat, ...); +#endif + +#define Perl_warner DPPP_(my_warner) + +#if defined(NEED_warner) || defined(NEED_warner_GLOBAL) + +void +DPPP_(my_warner)(U32 err, const char *pat, ...) +{ + SV *sv; + va_list args; + + PERL_UNUSED_ARG(err); + + va_start(args, pat); + sv = vnewSVpvf(pat, &args); + va_end(args); + sv_2mortal(sv); + warn("%s", SvPV_nolen(sv)); +} + +#define warner Perl_warner + +#define Perl_warner_nocontext Perl_warner + +#endif +#endif + +/* concatenating with "" ensures that only literal strings are accepted as argument + * note that STR_WITH_LEN() can't be used as argument to macros or functions that + * under some configurations might be macros + */ +#ifndef STR_WITH_LEN +# define STR_WITH_LEN(s) (s ""), (sizeof(s)-1) +#endif +#ifndef newSVpvs +# define newSVpvs(str) newSVpvn(str "", sizeof(str) - 1) +#endif + +#ifndef newSVpvs_flags +# define newSVpvs_flags(str, flags) newSVpvn_flags(str "", sizeof(str) - 1, flags) +#endif + +#ifndef newSVpvs_share +# define newSVpvs_share(str) newSVpvn_share(str "", sizeof(str) - 1, 0) +#endif + +#ifndef sv_catpvs +# define sv_catpvs(sv, str) sv_catpvn(sv, str "", sizeof(str) - 1) +#endif + +#ifndef sv_setpvs +# define sv_setpvs(sv, str) sv_setpvn(sv, str "", sizeof(str) - 1) +#endif + +#ifndef hv_fetchs +# define hv_fetchs(hv, key, lval) hv_fetch(hv, key "", sizeof(key) - 1, lval) +#endif + +#ifndef hv_stores +# define hv_stores(hv, key, val) hv_store(hv, key "", sizeof(key) - 1, val, 0) +#endif +#ifndef gv_fetchpvs +# define gv_fetchpvs(name, flags, svt) gv_fetchpvn_flags(name "", sizeof(name) - 1, flags, svt) +#endif + +#ifndef gv_stashpvs +# define gv_stashpvs(name, flags) gv_stashpvn(name "", sizeof(name) - 1, flags) +#endif +#ifndef get_cvs +# define get_cvs(name, flags) get_cvn_flags(name "", sizeof(name)-1, flags) +#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 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 +#ifndef SvVSTRING_mg +# define SvVSTRING_mg(sv) (SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_vstring) : NULL) +#endif + +/* Hint: sv_magic_portable + * This is a compatibility function that is only available with + * Devel::PPPort. It is NOT in the perl core. + * Its purpose is to mimic the 5.8.0 behaviour of sv_magic() when + * it is being passed a name pointer with namlen == 0. In that + * case, perl 5.8.0 and later store the pointer, not a copy of it. + * The compatibility can be provided back to perl 5.004. With + * earlier versions, the code will not compile. + */ + +#if (PERL_BCDVERSION < 0x5004000) + + /* code that uses sv_magic_portable will not compile */ + +#elif (PERL_BCDVERSION < 0x5008000) + +# define sv_magic_portable(sv, obj, how, name, namlen) \ + STMT_START { \ + SV *SvMp_sv = (sv); \ + char *SvMp_name = (char *) (name); \ + I32 SvMp_namlen = (namlen); \ + if (SvMp_name && SvMp_namlen == 0) \ + { \ + MAGIC *mg; \ + sv_magic(SvMp_sv, obj, how, 0, 0); \ + mg = SvMAGIC(SvMp_sv); \ + mg->mg_len = -42; /* XXX: this is the tricky part */ \ + mg->mg_ptr = SvMp_name; \ + } \ + else \ + { \ + sv_magic(SvMp_sv, obj, how, SvMp_name, SvMp_namlen); \ + } \ + } STMT_END + +#else + +# define sv_magic_portable(a, b, c, d, e) sv_magic(a, b, c, d, e) + +#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 +#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 +#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 + +#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_ const char * start, STRLEN * len_p, I32 * flags, NV * result); +static +#else +extern UV DPPP_(my_grok_bin)(pTHX_ const 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_ const 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_ const char * start, STRLEN * len_p, I32 * flags, NV * result); +static +#else +extern UV DPPP_(my_grok_hex)(pTHX_ const 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_ const 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_ const char * start, STRLEN * len_p, I32 * flags, NV * result); +static +#else +extern UV DPPP_(my_grok_oct)(pTHX_ const 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_ const 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 + +#if !defined(my_snprintf) +#if defined(NEED_my_snprintf) +static int DPPP_(my_my_snprintf)(char * buffer, const Size_t len, const char * format, ...); +static +#else +extern int DPPP_(my_my_snprintf)(char * buffer, const Size_t len, const char * format, ...); +#endif + +#define my_snprintf DPPP_(my_my_snprintf) +#define Perl_my_snprintf DPPP_(my_my_snprintf) + +#if defined(NEED_my_snprintf) || defined(NEED_my_snprintf_GLOBAL) + +int +DPPP_(my_my_snprintf)(char *buffer, const Size_t len, const char *format, ...) +{ + dTHX; + int retval; + va_list ap; + va_start(ap, format); +#ifdef HAS_VSNPRINTF + retval = vsnprintf(buffer, len, format, ap); +#else + retval = vsprintf(buffer, format, ap); +#endif + va_end(ap); + if (retval < 0 || (len > 0 && (Size_t)retval >= len)) + Perl_croak(aTHX_ "panic: my_snprintf buffer overflow"); + return retval; +} + +#endif +#endif + +#if !defined(my_sprintf) +#if defined(NEED_my_sprintf) +static int DPPP_(my_my_sprintf)(char * buffer, const char * pat, ...); +static +#else +extern int DPPP_(my_my_sprintf)(char * buffer, const char * pat, ...); +#endif + +#define my_sprintf DPPP_(my_my_sprintf) +#define Perl_my_sprintf DPPP_(my_my_sprintf) + +#if defined(NEED_my_sprintf) || defined(NEED_my_sprintf_GLOBAL) + +int +DPPP_(my_my_sprintf)(char *buffer, const char* pat, ...) +{ + va_list args; + va_start(args, pat); + vsprintf(buffer, pat, args); + va_end(args); + return strlen(buffer); +} + +#endif +#endif + +#ifdef NO_XSLOCKS +# ifdef dJMPENV +# define dXCPT dJMPENV; int rEtV = 0 +# define XCPT_TRY_START JMPENV_PUSH(rEtV); if (rEtV == 0) +# define XCPT_TRY_END JMPENV_POP; +# define XCPT_CATCH if (rEtV != 0) +# define XCPT_RETHROW JMPENV_JUMP(rEtV) +# else +# define dXCPT Sigjmp_buf oldTOP; int rEtV = 0 +# define XCPT_TRY_START Copy(top_env, oldTOP, 1, Sigjmp_buf); rEtV = Sigsetjmp(top_env, 1); if (rEtV == 0) +# define XCPT_TRY_END Copy(oldTOP, top_env, 1, Sigjmp_buf); +# define XCPT_CATCH if (rEtV != 0) +# define XCPT_RETHROW Siglongjmp(top_env, rEtV) +# endif +#endif + +#if !defined(my_strlcat) +#if defined(NEED_my_strlcat) +static Size_t DPPP_(my_my_strlcat)(char * dst, const char * src, Size_t size); +static +#else +extern Size_t DPPP_(my_my_strlcat)(char * dst, const char * src, Size_t size); +#endif + +#define my_strlcat DPPP_(my_my_strlcat) +#define Perl_my_strlcat DPPP_(my_my_strlcat) + +#if defined(NEED_my_strlcat) || defined(NEED_my_strlcat_GLOBAL) + +Size_t +DPPP_(my_my_strlcat)(char *dst, const char *src, Size_t size) +{ + Size_t used, length, copy; + + used = strlen(dst); + length = strlen(src); + if (size > 0 && used < size - 1) { + copy = (length >= size - used) ? size - used - 1 : length; + memcpy(dst + used, src, copy); + dst[used + copy] = '\0'; + } + return used + length; +} +#endif +#endif + +#if !defined(my_strlcpy) +#if defined(NEED_my_strlcpy) +static Size_t DPPP_(my_my_strlcpy)(char * dst, const char * src, Size_t size); +static +#else +extern Size_t DPPP_(my_my_strlcpy)(char * dst, const char * src, Size_t size); +#endif + +#define my_strlcpy DPPP_(my_my_strlcpy) +#define Perl_my_strlcpy DPPP_(my_my_strlcpy) + +#if defined(NEED_my_strlcpy) || defined(NEED_my_strlcpy_GLOBAL) + +Size_t +DPPP_(my_my_strlcpy)(char *dst, const char *src, Size_t size) +{ + Size_t length, copy; + + length = strlen(src); + if (size > 0) { + copy = (length >= size) ? size - 1 : length; + memcpy(dst, src, copy); + dst[copy] = '\0'; + } + return length; +} + +#endif +#endif +#ifndef PERL_PV_ESCAPE_QUOTE +# define PERL_PV_ESCAPE_QUOTE 0x0001 +#endif + +#ifndef PERL_PV_PRETTY_QUOTE +# define PERL_PV_PRETTY_QUOTE PERL_PV_ESCAPE_QUOTE +#endif + +#ifndef PERL_PV_PRETTY_ELLIPSES +# define PERL_PV_PRETTY_ELLIPSES 0x0002 +#endif + +#ifndef PERL_PV_PRETTY_LTGT +# define PERL_PV_PRETTY_LTGT 0x0004 +#endif + +#ifndef PERL_PV_ESCAPE_FIRSTCHAR +# define PERL_PV_ESCAPE_FIRSTCHAR 0x0008 +#endif + +#ifndef PERL_PV_ESCAPE_UNI +# define PERL_PV_ESCAPE_UNI 0x0100 +#endif + +#ifndef PERL_PV_ESCAPE_UNI_DETECT +# define PERL_PV_ESCAPE_UNI_DETECT 0x0200 +#endif + +#ifndef PERL_PV_ESCAPE_ALL +# define PERL_PV_ESCAPE_ALL 0x1000 +#endif + +#ifndef PERL_PV_ESCAPE_NOBACKSLASH +# define PERL_PV_ESCAPE_NOBACKSLASH 0x2000 +#endif + +#ifndef PERL_PV_ESCAPE_NOCLEAR +# define PERL_PV_ESCAPE_NOCLEAR 0x4000 +#endif + +#ifndef PERL_PV_ESCAPE_RE +# define PERL_PV_ESCAPE_RE 0x8000 +#endif + +#ifndef PERL_PV_PRETTY_NOCLEAR +# define PERL_PV_PRETTY_NOCLEAR PERL_PV_ESCAPE_NOCLEAR +#endif +#ifndef PERL_PV_PRETTY_DUMP +# define PERL_PV_PRETTY_DUMP PERL_PV_PRETTY_ELLIPSES|PERL_PV_PRETTY_QUOTE +#endif + +#ifndef PERL_PV_PRETTY_REGPROP +# define PERL_PV_PRETTY_REGPROP PERL_PV_PRETTY_ELLIPSES|PERL_PV_PRETTY_LTGT|PERL_PV_ESCAPE_RE +#endif + +/* Hint: pv_escape + * Note that unicode functionality is only backported to + * those perl versions that support it. For older perl + * versions, the implementation will fall back to bytes. + */ + +#ifndef pv_escape +#if defined(NEED_pv_escape) +static char * DPPP_(my_pv_escape)(pTHX_ SV * dsv, char const * const str, const STRLEN count, const STRLEN max, STRLEN * const escaped, const U32 flags); +static +#else +extern char * DPPP_(my_pv_escape)(pTHX_ SV * dsv, char const * const str, const STRLEN count, const STRLEN max, STRLEN * const escaped, const U32 flags); +#endif + +#ifdef pv_escape +# undef pv_escape +#endif +#define pv_escape(a,b,c,d,e,f) DPPP_(my_pv_escape)(aTHX_ a,b,c,d,e,f) +#define Perl_pv_escape DPPP_(my_pv_escape) + +#if defined(NEED_pv_escape) || defined(NEED_pv_escape_GLOBAL) + +char * +DPPP_(my_pv_escape)(pTHX_ SV *dsv, char const * const str, + const STRLEN count, const STRLEN max, + STRLEN * const escaped, const U32 flags) +{ + const char esc = flags & PERL_PV_ESCAPE_RE ? '%' : '\\'; + const char dq = flags & PERL_PV_ESCAPE_QUOTE ? '"' : esc; + char octbuf[32] = "%123456789ABCDF"; + STRLEN wrote = 0; + STRLEN chsize = 0; + STRLEN readsize = 1; +#if defined(is_utf8_string) && defined(utf8_to_uvchr) + bool isuni = flags & PERL_PV_ESCAPE_UNI ? 1 : 0; +#endif + const char *pv = str; + const char * const end = pv + count; + octbuf[0] = esc; + + if (!(flags & PERL_PV_ESCAPE_NOCLEAR)) + sv_setpvs(dsv, ""); + +#if defined(is_utf8_string) && defined(utf8_to_uvchr) + if ((flags & PERL_PV_ESCAPE_UNI_DETECT) && is_utf8_string((U8*)pv, count)) + isuni = 1; +#endif + + for (; pv < end && (!max || wrote < max) ; pv += readsize) { + const UV u = +#if defined(is_utf8_string) && defined(utf8_to_uvchr) + isuni ? utf8_to_uvchr((U8*)pv, &readsize) : +#endif + (U8)*pv; + const U8 c = (U8)u & 0xFF; + + if (u > 255 || (flags & PERL_PV_ESCAPE_ALL)) { + if (flags & PERL_PV_ESCAPE_FIRSTCHAR) + chsize = my_snprintf(octbuf, sizeof octbuf, + "%"UVxf, u); + else + chsize = my_snprintf(octbuf, sizeof octbuf, + "%cx{%"UVxf"}", esc, u); + } else if (flags & PERL_PV_ESCAPE_NOBACKSLASH) { + chsize = 1; + } else { + if (c == dq || c == esc || !isPRINT(c)) { + chsize = 2; + switch (c) { + case '\\' : /* fallthrough */ + case '%' : if (c == esc) + octbuf[1] = esc; + else + chsize = 1; + break; + case '\v' : octbuf[1] = 'v'; break; + case '\t' : octbuf[1] = 't'; break; + case '\r' : octbuf[1] = 'r'; break; + case '\n' : octbuf[1] = 'n'; break; + case '\f' : octbuf[1] = 'f'; break; + case '"' : if (dq == '"') + octbuf[1] = '"'; + else + chsize = 1; + break; + default: chsize = my_snprintf(octbuf, sizeof octbuf, + pv < end && isDIGIT((U8)*(pv+readsize)) + ? "%c%03o" : "%c%o", esc, c); + } + } else { + chsize = 1; + } + } + if (max && wrote + chsize > max) { + break; + } else if (chsize > 1) { + sv_catpvn(dsv, octbuf, chsize); + wrote += chsize; + } else { + char tmp[2]; + my_snprintf(tmp, sizeof tmp, "%c", c); + sv_catpvn(dsv, tmp, 1); + wrote++; + } + if (flags & PERL_PV_ESCAPE_FIRSTCHAR) + break; + } + if (escaped != NULL) + *escaped= pv - str; + return SvPVX(dsv); +} + +#endif +#endif + +#ifndef pv_pretty +#if defined(NEED_pv_pretty) +static char * DPPP_(my_pv_pretty)(pTHX_ SV * dsv, char const * const str, const STRLEN count, const STRLEN max, char const * const start_color, char const * const end_color, const U32 flags); +static +#else +extern char * DPPP_(my_pv_pretty)(pTHX_ SV * dsv, char const * const str, const STRLEN count, const STRLEN max, char const * const start_color, char const * const end_color, const U32 flags); +#endif + +#ifdef pv_pretty +# undef pv_pretty +#endif +#define pv_pretty(a,b,c,d,e,f,g) DPPP_(my_pv_pretty)(aTHX_ a,b,c,d,e,f,g) +#define Perl_pv_pretty DPPP_(my_pv_pretty) + +#if defined(NEED_pv_pretty) || defined(NEED_pv_pretty_GLOBAL) + +char * +DPPP_(my_pv_pretty)(pTHX_ SV *dsv, char const * const str, const STRLEN count, + const STRLEN max, char const * const start_color, char const * const end_color, + const U32 flags) +{ + const U8 dq = (flags & PERL_PV_PRETTY_QUOTE) ? '"' : '%'; + STRLEN escaped; + + if (!(flags & PERL_PV_PRETTY_NOCLEAR)) + sv_setpvs(dsv, ""); + + if (dq == '"') + sv_catpvs(dsv, "\""); + else if (flags & PERL_PV_PRETTY_LTGT) + sv_catpvs(dsv, "<"); + + if (start_color != NULL) + sv_catpv(dsv, D_PPP_CONSTPV_ARG(start_color)); + + pv_escape(dsv, str, count, max, &escaped, flags | PERL_PV_ESCAPE_NOCLEAR); + + if (end_color != NULL) + sv_catpv(dsv, D_PPP_CONSTPV_ARG(end_color)); + + if (dq == '"') + sv_catpvs(dsv, "\""); + else if (flags & PERL_PV_PRETTY_LTGT) + sv_catpvs(dsv, ">"); + + if ((flags & PERL_PV_PRETTY_ELLIPSES) && escaped < count) + sv_catpvs(dsv, "..."); + + return SvPVX(dsv); +} + +#endif +#endif + +#ifndef pv_display +#if defined(NEED_pv_display) +static char * DPPP_(my_pv_display)(pTHX_ SV * dsv, const char * pv, STRLEN cur, STRLEN len, STRLEN pvlim); +static +#else +extern char * DPPP_(my_pv_display)(pTHX_ SV * dsv, const char * pv, STRLEN cur, STRLEN len, STRLEN pvlim); +#endif + +#ifdef pv_display +# undef pv_display +#endif +#define pv_display(a,b,c,d,e) DPPP_(my_pv_display)(aTHX_ a,b,c,d,e) +#define Perl_pv_display DPPP_(my_pv_display) + +#if defined(NEED_pv_display) || defined(NEED_pv_display_GLOBAL) + +char * +DPPP_(my_pv_display)(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim) +{ + pv_pretty(dsv, pv, cur, pvlim, NULL, NULL, PERL_PV_PRETTY_DUMP); + if (len > cur && pv[cur] == '\0') + sv_catpvs(dsv, "\\0"); + return SvPVX(dsv); +} + +#endif +#endif + +#endif /* _P_P_PORTABILITY_H_ */ + +/* End of File ppport.h */ diff --git a/gnu/usr.bin/perl/cpan/Term-ReadKey/t/01_basic.t b/gnu/usr.bin/perl/cpan/Term-ReadKey/t/01_basic.t new file mode 100644 index 00000000000..292f96b792c --- /dev/null +++ b/gnu/usr.bin/perl/cpan/Term-ReadKey/t/01_basic.t @@ -0,0 +1,7 @@ +use strict; +use warnings; + + +use Test::More tests => 1; + +use_ok 'Term::ReadKey'; diff --git a/gnu/usr.bin/perl/cpan/Term-ReadKey/t/02_terminal_functions.t b/gnu/usr.bin/perl/cpan/Term-ReadKey/t/02_terminal_functions.t new file mode 100644 index 00000000000..09fe2e4b67d --- /dev/null +++ b/gnu/usr.bin/perl/cpan/Term-ReadKey/t/02_terminal_functions.t @@ -0,0 +1,86 @@ +use strict; +use warnings; + + +use Test::More tests => 7; + +use Term::ReadKey; +use Fcntl; + +if ( not exists $ENV{COLUMNS} ){ + $ENV{COLUMNS} = 80; + $ENV{LINES} = 24; +} + +SKIP: +{ + eval { + if ( $^O =~ /Win32/i ){ + sysopen( IN, 'CONIN$', O_RDWR ) or die "Unable to open console input:$!"; + sysopen( OUT, 'CONOUT$', O_RDWR ) or die "Unable to open console output:$!"; + } + else{ + if ( open( IN, "</dev/tty" ) ){ + *OUT = *IN; + die "Foo" unless -t OUT; + } + else{ + die "/dev/tty is absent\n"; + } + } + }; + skip( 'Because Term::ReadKey need at least a tty to be useful', 1 ) if $@; + *IN = *IN; # Make single-use warning go away + $| = 1; + no strict "subs"; + my $size1 = join( ",", GetTerminalSize( \IN ) ); + my $size2 = join( ",", GetTerminalSize("IN") ); + my $size3 = join( ",", GetTerminalSize(*IN) ); + my $size4 = join( ",", GetTerminalSize( \*IN ) ); + + my $size_result=0; + if ( ( $size1 eq $size2 ) && ( $size2 eq $size3 ) && ( $size3 eq $size4 ) ){ + $size_result = 1; + } + is($size_result, 1, "Comparing TerminalSize IN"); + + my $usable_terminal=0; + for (my $i = 1; $i < 6; $i++){ + if ( &Term::ReadKey::termoptions() == $i ){ + $usable_terminal = 1; + last; + } + } + is($usable_terminal, 1, "Manipulating the terminal."); + + my @modes; + eval { + push( @modes, "O_NODELAY" ) if &Term::ReadKey::blockoptions() & 1; + push( @modes, "poll()" ) if &Term::ReadKey::blockoptions() & 2; + push( @modes, "select()" ) if &Term::ReadKey::blockoptions() & 4; + push( @modes, "Win32" ) if &Term::ReadKey::blockoptions() & 8; + }; + is($@, '', "Check non-blocking read"); + + eval { + my @size = GetTerminalSize(OUT); + }; + is($@, '', "Check TerminalSize OUT"); + + eval { + my @speeds = GetSpeed(); + }; + is($@, '', "Check Terminal communication speed"); + + my %chars; + eval { + %chars = GetControlChars(IN); + }; + is($@, '', "Validate GetControlChars function"); + + my %origchars = %chars; + eval { + SetControlChars( %origchars, IN ); + }; + is($@, '', "Validate SetControlChars function"); +} |