[Midnightbsd-cvs] src [6445] trunk/contrib/perl/ext: perl 5.18.1 merge
laffer1 at midnightbsd.org
laffer1 at midnightbsd.org
Mon Dec 2 16:32:28 EST 2013
Revision: 6445
http://svnweb.midnightbsd.org/src/?rev=6445
Author: laffer1
Date: 2013-12-02 16:32:26 -0500 (Mon, 02 Dec 2013)
Log Message:
-----------
perl 5.18.1 merge
Modified Paths:
--------------
trunk/contrib/perl/ext/B/B/Concise.pm
trunk/contrib/perl/ext/B/B/Terse.pm
trunk/contrib/perl/ext/B/B/Xref.pm
trunk/contrib/perl/ext/B/B.pm
trunk/contrib/perl/ext/B/B.xs
trunk/contrib/perl/ext/B/Makefile.PL
trunk/contrib/perl/ext/B/t/OptreeCheck.pm
trunk/contrib/perl/ext/B/t/b.t
trunk/contrib/perl/ext/B/t/concise-xs.t
trunk/contrib/perl/ext/B/t/concise.t
trunk/contrib/perl/ext/B/t/f_map.t
trunk/contrib/perl/ext/B/t/f_sort.t
trunk/contrib/perl/ext/B/t/optree_check.t
trunk/contrib/perl/ext/B/t/optree_constants.t
trunk/contrib/perl/ext/B/t/optree_misc.t
trunk/contrib/perl/ext/B/t/optree_samples.t
trunk/contrib/perl/ext/B/t/optree_sort.t
trunk/contrib/perl/ext/B/t/optree_specials.t
trunk/contrib/perl/ext/B/t/optree_varinit.t
trunk/contrib/perl/ext/B/t/pragma.t
trunk/contrib/perl/ext/B/t/walkoptree.t
trunk/contrib/perl/ext/B/t/xref.t
trunk/contrib/perl/ext/B/typemap
trunk/contrib/perl/ext/Devel-Peek/Changes
trunk/contrib/perl/ext/Devel-Peek/Peek.pm
trunk/contrib/perl/ext/Devel-Peek/Peek.xs
trunk/contrib/perl/ext/Devel-Peek/t/Peek.t
trunk/contrib/perl/ext/DynaLoader/DynaLoader_pm.PL
trunk/contrib/perl/ext/DynaLoader/dl_aix.xs
trunk/contrib/perl/ext/DynaLoader/dl_dld.xs
trunk/contrib/perl/ext/DynaLoader/dl_dllload.xs
trunk/contrib/perl/ext/DynaLoader/dl_hpux.xs
trunk/contrib/perl/ext/DynaLoader/dl_next.xs
trunk/contrib/perl/ext/DynaLoader/dl_vms.xs
trunk/contrib/perl/ext/DynaLoader/dl_win32.xs
trunk/contrib/perl/ext/DynaLoader/dlutils.c
trunk/contrib/perl/ext/DynaLoader/t/DynaLoader.t
trunk/contrib/perl/ext/Errno/Errno_pm.PL
trunk/contrib/perl/ext/File-Glob/Glob.pm
trunk/contrib/perl/ext/File-Glob/Glob.xs
trunk/contrib/perl/ext/File-Glob/bsd_glob.c
trunk/contrib/perl/ext/File-Glob/bsd_glob.h
trunk/contrib/perl/ext/File-Glob/t/basic.t
trunk/contrib/perl/ext/File-Glob/t/taint.t
trunk/contrib/perl/ext/GDBM_File/GDBM_File.pm
trunk/contrib/perl/ext/GDBM_File/GDBM_File.xs
trunk/contrib/perl/ext/GDBM_File/typemap
trunk/contrib/perl/ext/Hash-Util/Util.xs
trunk/contrib/perl/ext/Hash-Util/lib/Hash/Util.pm
trunk/contrib/perl/ext/Hash-Util/t/Util.t
trunk/contrib/perl/ext/Hash-Util-FieldHash/lib/Hash/Util/FieldHash.pm
trunk/contrib/perl/ext/Hash-Util-FieldHash/t/11_hashassign.t
trunk/contrib/perl/ext/I18N-Langinfo/Langinfo.pm
trunk/contrib/perl/ext/IPC-Open3/lib/IPC/Open3.pm
trunk/contrib/perl/ext/IPC-Open3/t/IPC-Open3.t
trunk/contrib/perl/ext/IPC-Open3/t/fd.t
trunk/contrib/perl/ext/NDBM_File/typemap
trunk/contrib/perl/ext/ODBM_File/ODBM_File.pm
trunk/contrib/perl/ext/ODBM_File/ODBM_File.xs
trunk/contrib/perl/ext/ODBM_File/typemap
trunk/contrib/perl/ext/Opcode/Opcode.pm
trunk/contrib/perl/ext/Opcode/Opcode.xs
trunk/contrib/perl/ext/POSIX/POSIX.xs
trunk/contrib/perl/ext/POSIX/lib/POSIX.pm
trunk/contrib/perl/ext/POSIX/lib/POSIX.pod
trunk/contrib/perl/ext/POSIX/t/is.t
trunk/contrib/perl/ext/POSIX/t/math.t
trunk/contrib/perl/ext/POSIX/t/posix.t
trunk/contrib/perl/ext/POSIX/t/sigaction.t
trunk/contrib/perl/ext/POSIX/t/sysconf.t
trunk/contrib/perl/ext/POSIX/t/taint.t
trunk/contrib/perl/ext/POSIX/t/termios.t
trunk/contrib/perl/ext/POSIX/t/time.t
trunk/contrib/perl/ext/POSIX/t/waitpid.t
trunk/contrib/perl/ext/POSIX/typemap
trunk/contrib/perl/ext/PerlIO-encoding/encoding.pm
trunk/contrib/perl/ext/PerlIO-encoding/encoding.xs
trunk/contrib/perl/ext/PerlIO-encoding/t/encoding.t
trunk/contrib/perl/ext/PerlIO-scalar/scalar.pm
trunk/contrib/perl/ext/PerlIO-scalar/scalar.xs
trunk/contrib/perl/ext/PerlIO-scalar/t/scalar.t
trunk/contrib/perl/ext/PerlIO-via/via.pm
trunk/contrib/perl/ext/Pod-Html/t/htmlescp.t
trunk/contrib/perl/ext/Pod-Html/t/htmllink.t
trunk/contrib/perl/ext/Pod-Html/t/htmlview.pod
trunk/contrib/perl/ext/Pod-Html/t/htmlview.t
trunk/contrib/perl/ext/Pod-Html/t/pod2html-lib.pl
trunk/contrib/perl/ext/SDBM_File/sdbm/README
trunk/contrib/perl/ext/SDBM_File/sdbm/dba.c
trunk/contrib/perl/ext/SDBM_File/sdbm/dbd.c
trunk/contrib/perl/ext/SDBM_File/sdbm/dbe.c
trunk/contrib/perl/ext/SDBM_File/sdbm/dbu.c
trunk/contrib/perl/ext/SDBM_File/sdbm/hash.c
trunk/contrib/perl/ext/SDBM_File/sdbm/pair.c
trunk/contrib/perl/ext/SDBM_File/sdbm/readme.ms
trunk/contrib/perl/ext/SDBM_File/sdbm/sdbm.3
trunk/contrib/perl/ext/SDBM_File/sdbm/sdbm.c
trunk/contrib/perl/ext/SDBM_File/sdbm/sdbm.h
trunk/contrib/perl/ext/SDBM_File/sdbm/util.c
trunk/contrib/perl/ext/SDBM_File/typemap
trunk/contrib/perl/ext/Sys-Hostname/Hostname.pm
trunk/contrib/perl/ext/Sys-Hostname/t/Hostname.t
trunk/contrib/perl/ext/Tie-Hash-NamedCapture/NamedCapture.pm
trunk/contrib/perl/ext/Tie-Hash-NamedCapture/NamedCapture.xs
trunk/contrib/perl/ext/VMS-Stdio/Stdio.xs
trunk/contrib/perl/ext/Win32CORE/Win32CORE.c
trunk/contrib/perl/ext/Win32CORE/Win32CORE.pm
trunk/contrib/perl/ext/XS-APItest/APItest.pm
trunk/contrib/perl/ext/XS-APItest/APItest.xs
trunk/contrib/perl/ext/XS-APItest/Makefile.PL
trunk/contrib/perl/ext/XS-APItest/XSUB-redefined-macros.xs
trunk/contrib/perl/ext/XS-APItest/XSUB-undef-XS_VERSION.xs
trunk/contrib/perl/ext/XS-APItest/core_or_not.inc
trunk/contrib/perl/ext/XS-APItest/t/call.t
trunk/contrib/perl/ext/XS-APItest/t/call_checker.t
trunk/contrib/perl/ext/XS-APItest/t/eval-filter.t
trunk/contrib/perl/ext/XS-APItest/t/grok.t
trunk/contrib/perl/ext/XS-APItest/t/hash.t
trunk/contrib/perl/ext/XS-APItest/t/labelconst.t
trunk/contrib/perl/ext/XS-APItest/t/magic.t
trunk/contrib/perl/ext/XS-APItest/t/multicall.t
trunk/contrib/perl/ext/XS-APItest/t/op.t
trunk/contrib/perl/ext/XS-APItest/t/peep.t
trunk/contrib/perl/ext/XS-APItest/t/svpv_magic.t
trunk/contrib/perl/ext/XS-APItest/t/svsetsv.t
trunk/contrib/perl/ext/XS-APItest/t/swaplabel.t
trunk/contrib/perl/ext/XS-APItest/t/utf8.t
trunk/contrib/perl/ext/XS-APItest/t/xs_special_subs_require.t
trunk/contrib/perl/ext/XS-APItest/t/xsub_h.t
trunk/contrib/perl/ext/XS-Typemap/Typemap.pm
trunk/contrib/perl/ext/XS-Typemap/Typemap.xs
trunk/contrib/perl/ext/XS-Typemap/t/Typemap.t
Added Paths:
-----------
trunk/contrib/perl/ext/Attribute-Handlers/
trunk/contrib/perl/ext/B/B/Debug.pm
trunk/contrib/perl/ext/B/B/Deparse.pm
trunk/contrib/perl/ext/B/B/Lint/
trunk/contrib/perl/ext/B/B/Lint.pm
trunk/contrib/perl/ext/B/defsubs_h.PL
trunk/contrib/perl/ext/B/t/debug.t
trunk/contrib/perl/ext/B/t/deparse.t
trunk/contrib/perl/ext/B/t/lint.t
trunk/contrib/perl/ext/B/t/pluglib/
trunk/contrib/perl/ext/Compress/
trunk/contrib/perl/ext/Compress-Raw-Bzip2/
trunk/contrib/perl/ext/Compress-Raw-Zlib/
trunk/contrib/perl/ext/Cwd/
trunk/contrib/perl/ext/DB_File/
trunk/contrib/perl/ext/Data/
trunk/contrib/perl/ext/Data-Dumper/
trunk/contrib/perl/ext/Devel/
trunk/contrib/perl/ext/Devel-DProf/
trunk/contrib/perl/ext/Devel-PPPort/
trunk/contrib/perl/ext/Digest/
trunk/contrib/perl/ext/Digest-MD5/
trunk/contrib/perl/ext/Digest-SHA/
trunk/contrib/perl/ext/DynaLoader/XSLoader_pm.PL
trunk/contrib/perl/ext/DynaLoader/dl_mac.xs
trunk/contrib/perl/ext/DynaLoader/t/XSLoader.t
trunk/contrib/perl/ext/Encode/
trunk/contrib/perl/ext/File/
trunk/contrib/perl/ext/File-DosGlob/
trunk/contrib/perl/ext/File-Glob/t/rt114984.t
trunk/contrib/perl/ext/Filter/
trunk/contrib/perl/ext/Filter-Util-Call/
trunk/contrib/perl/ext/GDBM_File/t/fatal.t
trunk/contrib/perl/ext/Hash/
trunk/contrib/perl/ext/I18N/
trunk/contrib/perl/ext/I18N-Langinfo/fallback/
trunk/contrib/perl/ext/IO/
trunk/contrib/perl/ext/IO-Compress/
trunk/contrib/perl/ext/IO_Compress_Base/
trunk/contrib/perl/ext/IO_Compress_Zlib/
trunk/contrib/perl/ext/IPC/
trunk/contrib/perl/ext/IPC-Open3/lib/IPC/Open2.pm
trunk/contrib/perl/ext/IPC-Open3/t/IPC-Open2.t
trunk/contrib/perl/ext/IPC-SysV/
trunk/contrib/perl/ext/List/
trunk/contrib/perl/ext/List-Util/
trunk/contrib/perl/ext/MIME/
trunk/contrib/perl/ext/MIME-Base64/
trunk/contrib/perl/ext/Math/
trunk/contrib/perl/ext/Math-BigInt-FastCalc/
trunk/contrib/perl/ext/Module-Pluggable/
trunk/contrib/perl/ext/NDBM_File/hints/gnu.pl
trunk/contrib/perl/ext/ODBM_File/hints/gnu.pl
trunk/contrib/perl/ext/Opcode/Makefile.PL
trunk/contrib/perl/ext/Opcode/Safe.pm
trunk/contrib/perl/ext/POSIX/POSIX.pm
trunk/contrib/perl/ext/POSIX/POSIX.pod
trunk/contrib/perl/ext/POSIX/t/export.t
trunk/contrib/perl/ext/POSIX/t/sigset.t
trunk/contrib/perl/ext/POSIX/t/unimplemented.t
trunk/contrib/perl/ext/POSIX/t/usage.t
trunk/contrib/perl/ext/POSIX/t/wrappers.t
trunk/contrib/perl/ext/PerlIO/
trunk/contrib/perl/ext/PerlIO-mmap/
trunk/contrib/perl/ext/Pod-Functions/
trunk/contrib/perl/ext/Pod-Html/bin/
trunk/contrib/perl/ext/Pod-Html/lib/
trunk/contrib/perl/ext/Pod-Html/t/cache.pod
trunk/contrib/perl/ext/Pod-Html/t/cache.t
trunk/contrib/perl/ext/Pod-Html/t/crossref.pod
trunk/contrib/perl/ext/Pod-Html/t/crossref.t
trunk/contrib/perl/ext/Pod-Html/t/crossref2.t
trunk/contrib/perl/ext/Pod-Html/t/crossref3.t
trunk/contrib/perl/ext/Pod-Html/t/eol.t
trunk/contrib/perl/ext/Pod-Html/t/feature.pod
trunk/contrib/perl/ext/Pod-Html/t/feature.t
trunk/contrib/perl/ext/Pod-Html/t/feature2.pod
trunk/contrib/perl/ext/Pod-Html/t/feature2.t
trunk/contrib/perl/ext/Pod-Html/t/htmldir1.pod
trunk/contrib/perl/ext/Pod-Html/t/htmldir1.t
trunk/contrib/perl/ext/Pod-Html/t/htmldir2.pod
trunk/contrib/perl/ext/Pod-Html/t/htmldir2.t
trunk/contrib/perl/ext/Pod-Html/t/htmldir3.pod
trunk/contrib/perl/ext/Pod-Html/t/htmldir3.t
trunk/contrib/perl/ext/Pod-Html/t/htmldir4.pod
trunk/contrib/perl/ext/Pod-Html/t/htmldir4.t
trunk/contrib/perl/ext/Pod-Html/t/htmldir5.pod
trunk/contrib/perl/ext/Pod-Html/t/htmldir5.t
trunk/contrib/perl/ext/Pod-Html/t/poderr.pod
trunk/contrib/perl/ext/Pod-Html/t/poderr.t
trunk/contrib/perl/ext/Pod-Html/t/podnoerr.pod
trunk/contrib/perl/ext/Pod-Html/t/podnoerr.t
trunk/contrib/perl/ext/Pod-Html/testdir/
trunk/contrib/perl/ext/Safe/
trunk/contrib/perl/ext/Storable/
trunk/contrib/perl/ext/Sys/
trunk/contrib/perl/ext/Sys-Syslog/
trunk/contrib/perl/ext/Test-Harness/
trunk/contrib/perl/ext/Text/
trunk/contrib/perl/ext/Text-Soundex/
trunk/contrib/perl/ext/Time/
trunk/contrib/perl/ext/Time-HiRes/
trunk/contrib/perl/ext/Time-Piece/
trunk/contrib/perl/ext/Unicode/
trunk/contrib/perl/ext/Unicode-Normalize/
trunk/contrib/perl/ext/Win32/
trunk/contrib/perl/ext/Win32API/
trunk/contrib/perl/ext/Win32API-File/
trunk/contrib/perl/ext/XS/
trunk/contrib/perl/ext/XS-APItest/t/addissub.t
trunk/contrib/perl/ext/XS-APItest/t/autoload.t
trunk/contrib/perl/ext/XS-APItest/t/callregexec.t
trunk/contrib/perl/ext/XS-APItest/t/check_warnings.t
trunk/contrib/perl/ext/XS-APItest/t/clone-with-stack.t
trunk/contrib/perl/ext/XS-APItest/t/coplabel.t
trunk/contrib/perl/ext/XS-APItest/t/copstash.t
trunk/contrib/perl/ext/XS-APItest/t/fetch_pad_names.t
trunk/contrib/perl/ext/XS-APItest/t/gotosub.t
trunk/contrib/perl/ext/XS-APItest/t/gv_autoload4.t
trunk/contrib/perl/ext/XS-APItest/t/gv_fetchmeth.t
trunk/contrib/perl/ext/XS-APItest/t/gv_fetchmeth_autoload.t
trunk/contrib/perl/ext/XS-APItest/t/gv_fetchmethod_flags.t
trunk/contrib/perl/ext/XS-APItest/t/gv_init.t
trunk/contrib/perl/ext/XS-APItest/t/handy.t
trunk/contrib/perl/ext/XS-APItest/t/labelconst_utf8.aux
trunk/contrib/perl/ext/XS-APItest/t/lexsub.t
trunk/contrib/perl/ext/XS-APItest/t/lvalue.t
trunk/contrib/perl/ext/XS-APItest/t/mro.t
trunk/contrib/perl/ext/XS-APItest/t/newCONSTSUB.t
trunk/contrib/perl/ext/XS-APItest/t/pad_scalar.t
trunk/contrib/perl/ext/XS-APItest/t/sort.t
trunk/contrib/perl/ext/XS-APItest/t/sviscow.t
trunk/contrib/perl/ext/XS-APItest/t/svpv.t
trunk/contrib/perl/ext/XS-APItest/t/sym-hook.t
trunk/contrib/perl/ext/XS-APItest/t/underscore_length.t
trunk/contrib/perl/ext/XS-APItest/t/whichsig.t
trunk/contrib/perl/ext/arybase/
trunk/contrib/perl/ext/threads-shared/
trunk/contrib/perl/ext/util/
Property Changed:
----------------
trunk/contrib/perl/ext/B/B/Concise.pm
trunk/contrib/perl/ext/B/B/Showlex.pm
trunk/contrib/perl/ext/B/B/Terse.pm
trunk/contrib/perl/ext/B/B/Xref.pm
trunk/contrib/perl/ext/B/B.pm
trunk/contrib/perl/ext/B/B.xs
trunk/contrib/perl/ext/B/Makefile.PL
trunk/contrib/perl/ext/B/O.pm
trunk/contrib/perl/ext/B/hints/darwin.pl
trunk/contrib/perl/ext/B/hints/openbsd.pl
trunk/contrib/perl/ext/B/t/OptreeCheck.pm
trunk/contrib/perl/ext/B/t/b.t
trunk/contrib/perl/ext/B/t/concise-xs.t
trunk/contrib/perl/ext/B/t/concise.t
trunk/contrib/perl/ext/B/t/f_map
trunk/contrib/perl/ext/B/t/f_map.t
trunk/contrib/perl/ext/B/t/f_sort
trunk/contrib/perl/ext/B/t/f_sort.t
trunk/contrib/perl/ext/B/t/o.t
trunk/contrib/perl/ext/B/t/optree_check.t
trunk/contrib/perl/ext/B/t/optree_concise.t
trunk/contrib/perl/ext/B/t/optree_constants.t
trunk/contrib/perl/ext/B/t/optree_misc.t
trunk/contrib/perl/ext/B/t/optree_samples.t
trunk/contrib/perl/ext/B/t/optree_sort.t
trunk/contrib/perl/ext/B/t/optree_specials.t
trunk/contrib/perl/ext/B/t/optree_varinit.t
trunk/contrib/perl/ext/B/t/pragma.t
trunk/contrib/perl/ext/B/t/showlex.t
trunk/contrib/perl/ext/B/t/terse.t
trunk/contrib/perl/ext/B/t/walkoptree.t
trunk/contrib/perl/ext/B/t/xref.t
trunk/contrib/perl/ext/B/typemap
trunk/contrib/perl/ext/Devel-Peek/Changes
trunk/contrib/perl/ext/Devel-Peek/Makefile.PL
trunk/contrib/perl/ext/Devel-Peek/Peek.pm
trunk/contrib/perl/ext/Devel-Peek/Peek.xs
trunk/contrib/perl/ext/Devel-Peek/t/Peek.t
trunk/contrib/perl/ext/DynaLoader/DynaLoader_pm.PL
trunk/contrib/perl/ext/DynaLoader/Makefile.PL
trunk/contrib/perl/ext/DynaLoader/README
trunk/contrib/perl/ext/DynaLoader/dl_aix.xs
trunk/contrib/perl/ext/DynaLoader/dl_beos.xs
trunk/contrib/perl/ext/DynaLoader/dl_dld.xs
trunk/contrib/perl/ext/DynaLoader/dl_dllload.xs
trunk/contrib/perl/ext/DynaLoader/dl_dlopen.xs
trunk/contrib/perl/ext/DynaLoader/dl_dyld.xs
trunk/contrib/perl/ext/DynaLoader/dl_hpux.xs
trunk/contrib/perl/ext/DynaLoader/dl_mpeix.xs
trunk/contrib/perl/ext/DynaLoader/dl_next.xs
trunk/contrib/perl/ext/DynaLoader/dl_none.xs
trunk/contrib/perl/ext/DynaLoader/dl_symbian.xs
trunk/contrib/perl/ext/DynaLoader/dl_vmesa.xs
trunk/contrib/perl/ext/DynaLoader/dl_vms.xs
trunk/contrib/perl/ext/DynaLoader/dl_win32.xs
trunk/contrib/perl/ext/DynaLoader/dlutils.c
trunk/contrib/perl/ext/DynaLoader/hints/aix.pl
trunk/contrib/perl/ext/DynaLoader/hints/gnukfreebsd.pl
trunk/contrib/perl/ext/DynaLoader/hints/gnuknetbsd.pl
trunk/contrib/perl/ext/DynaLoader/hints/linux.pl
trunk/contrib/perl/ext/DynaLoader/hints/netbsd.pl
trunk/contrib/perl/ext/DynaLoader/hints/openbsd.pl
trunk/contrib/perl/ext/DynaLoader/t/DynaLoader.t
trunk/contrib/perl/ext/Errno/ChangeLog
trunk/contrib/perl/ext/Errno/Errno_pm.PL
trunk/contrib/perl/ext/Errno/Makefile.PL
trunk/contrib/perl/ext/Errno/t/Errno.t
trunk/contrib/perl/ext/Fcntl/Fcntl.pm
trunk/contrib/perl/ext/Fcntl/Fcntl.xs
trunk/contrib/perl/ext/Fcntl/Makefile.PL
trunk/contrib/perl/ext/Fcntl/t/autoload.t
trunk/contrib/perl/ext/Fcntl/t/fcntl.t
trunk/contrib/perl/ext/Fcntl/t/mode.t
trunk/contrib/perl/ext/Fcntl/t/syslfs.t
trunk/contrib/perl/ext/File-Glob/Changes
trunk/contrib/perl/ext/File-Glob/Glob.pm
trunk/contrib/perl/ext/File-Glob/Glob.xs
trunk/contrib/perl/ext/File-Glob/Makefile.PL
trunk/contrib/perl/ext/File-Glob/TODO
trunk/contrib/perl/ext/File-Glob/bsd_glob.c
trunk/contrib/perl/ext/File-Glob/bsd_glob.h
trunk/contrib/perl/ext/File-Glob/t/basic.t
trunk/contrib/perl/ext/File-Glob/t/case.t
trunk/contrib/perl/ext/File-Glob/t/global.t
trunk/contrib/perl/ext/File-Glob/t/taint.t
trunk/contrib/perl/ext/FileCache/lib/FileCache.pm
trunk/contrib/perl/ext/FileCache/t/01open.t
trunk/contrib/perl/ext/FileCache/t/02maxopen.t
trunk/contrib/perl/ext/FileCache/t/03append.t
trunk/contrib/perl/ext/FileCache/t/04twoarg.t
trunk/contrib/perl/ext/FileCache/t/05override.t
trunk/contrib/perl/ext/FileCache/t/06export.t
trunk/contrib/perl/ext/FileCache/t/07noimport.t
trunk/contrib/perl/ext/GDBM_File/GDBM_File.pm
trunk/contrib/perl/ext/GDBM_File/GDBM_File.xs
trunk/contrib/perl/ext/GDBM_File/Makefile.PL
trunk/contrib/perl/ext/GDBM_File/hints/sco.pl
trunk/contrib/perl/ext/GDBM_File/t/gdbm.t
trunk/contrib/perl/ext/GDBM_File/typemap
trunk/contrib/perl/ext/Hash-Util/Changes
trunk/contrib/perl/ext/Hash-Util/Makefile.PL
trunk/contrib/perl/ext/Hash-Util/Util.xs
trunk/contrib/perl/ext/Hash-Util/lib/Hash/Util.pm
trunk/contrib/perl/ext/Hash-Util/t/Util.t
trunk/contrib/perl/ext/Hash-Util-FieldHash/Changes
trunk/contrib/perl/ext/Hash-Util-FieldHash/FieldHash.xs
trunk/contrib/perl/ext/Hash-Util-FieldHash/lib/Hash/Util/FieldHash.pm
trunk/contrib/perl/ext/Hash-Util-FieldHash/t/01_load.t
trunk/contrib/perl/ext/Hash-Util-FieldHash/t/02_function.t
trunk/contrib/perl/ext/Hash-Util-FieldHash/t/03_class.t
trunk/contrib/perl/ext/Hash-Util-FieldHash/t/04_thread.t
trunk/contrib/perl/ext/Hash-Util-FieldHash/t/05_perlhook.t
trunk/contrib/perl/ext/Hash-Util-FieldHash/t/10_hash.t
trunk/contrib/perl/ext/Hash-Util-FieldHash/t/11_hashassign.t
trunk/contrib/perl/ext/Hash-Util-FieldHash/t/12_hashwarn.t
trunk/contrib/perl/ext/I18N-Langinfo/Langinfo.pm
trunk/contrib/perl/ext/I18N-Langinfo/Langinfo.xs
trunk/contrib/perl/ext/I18N-Langinfo/Makefile.PL
trunk/contrib/perl/ext/I18N-Langinfo/t/Langinfo.t
trunk/contrib/perl/ext/IPC-Open2/lib/IPC/Open2.pm
trunk/contrib/perl/ext/IPC-Open2/t/IPC-Open2.t
trunk/contrib/perl/ext/IPC-Open3/lib/IPC/Open3.pm
trunk/contrib/perl/ext/IPC-Open3/t/IPC-Open3.t
trunk/contrib/perl/ext/IPC-Open3/t/fd.t
trunk/contrib/perl/ext/NDBM_File/Makefile.PL
trunk/contrib/perl/ext/NDBM_File/NDBM_File.pm
trunk/contrib/perl/ext/NDBM_File/NDBM_File.xs
trunk/contrib/perl/ext/NDBM_File/hints/cygwin.pl
trunk/contrib/perl/ext/NDBM_File/hints/dec_osf.pl
trunk/contrib/perl/ext/NDBM_File/hints/dynixptx.pl
trunk/contrib/perl/ext/NDBM_File/hints/gnukfreebsd.pl
trunk/contrib/perl/ext/NDBM_File/hints/gnuknetbsd.pl
trunk/contrib/perl/ext/NDBM_File/hints/linux.pl
trunk/contrib/perl/ext/NDBM_File/hints/sco.pl
trunk/contrib/perl/ext/NDBM_File/hints/solaris.pl
trunk/contrib/perl/ext/NDBM_File/hints/svr4.pl
trunk/contrib/perl/ext/NDBM_File/t/ndbm.t
trunk/contrib/perl/ext/NDBM_File/typemap
trunk/contrib/perl/ext/ODBM_File/Makefile.PL
trunk/contrib/perl/ext/ODBM_File/ODBM_File.pm
trunk/contrib/perl/ext/ODBM_File/ODBM_File.xs
trunk/contrib/perl/ext/ODBM_File/hints/cygwin.pl
trunk/contrib/perl/ext/ODBM_File/hints/dec_osf.pl
trunk/contrib/perl/ext/ODBM_File/hints/gnukfreebsd.pl
trunk/contrib/perl/ext/ODBM_File/hints/gnuknetbsd.pl
trunk/contrib/perl/ext/ODBM_File/hints/hpux.pl
trunk/contrib/perl/ext/ODBM_File/hints/linux.pl
trunk/contrib/perl/ext/ODBM_File/hints/sco.pl
trunk/contrib/perl/ext/ODBM_File/hints/solaris.pl
trunk/contrib/perl/ext/ODBM_File/hints/svr4.pl
trunk/contrib/perl/ext/ODBM_File/hints/ultrix.pl
trunk/contrib/perl/ext/ODBM_File/t/odbm.t
trunk/contrib/perl/ext/ODBM_File/typemap
trunk/contrib/perl/ext/Opcode/Opcode.pm
trunk/contrib/perl/ext/Opcode/Opcode.xs
trunk/contrib/perl/ext/Opcode/ops.pm
trunk/contrib/perl/ext/Opcode/t/Opcode.t
trunk/contrib/perl/ext/Opcode/t/ops.t
trunk/contrib/perl/ext/POSIX/Makefile.PL
trunk/contrib/perl/ext/POSIX/POSIX.xs
trunk/contrib/perl/ext/POSIX/hints/bsdos.pl
trunk/contrib/perl/ext/POSIX/hints/dynixptx.pl
trunk/contrib/perl/ext/POSIX/hints/freebsd.pl
trunk/contrib/perl/ext/POSIX/hints/gnukfreebsd.pl
trunk/contrib/perl/ext/POSIX/hints/gnuknetbsd.pl
trunk/contrib/perl/ext/POSIX/hints/linux.pl
trunk/contrib/perl/ext/POSIX/hints/mint.pl
trunk/contrib/perl/ext/POSIX/hints/netbsd.pl
trunk/contrib/perl/ext/POSIX/hints/next_3.pl
trunk/contrib/perl/ext/POSIX/hints/openbsd.pl
trunk/contrib/perl/ext/POSIX/hints/sunos_4.pl
trunk/contrib/perl/ext/POSIX/hints/svr4.pl
trunk/contrib/perl/ext/POSIX/hints/uts.pl
trunk/contrib/perl/ext/POSIX/lib/POSIX.pm
trunk/contrib/perl/ext/POSIX/lib/POSIX.pod
trunk/contrib/perl/ext/POSIX/t/is.t
trunk/contrib/perl/ext/POSIX/t/math.t
trunk/contrib/perl/ext/POSIX/t/posix.t
trunk/contrib/perl/ext/POSIX/t/sigaction.t
trunk/contrib/perl/ext/POSIX/t/sysconf.t
trunk/contrib/perl/ext/POSIX/t/taint.t
trunk/contrib/perl/ext/POSIX/t/termios.t
trunk/contrib/perl/ext/POSIX/t/time.t
trunk/contrib/perl/ext/POSIX/t/waitpid.t
trunk/contrib/perl/ext/POSIX/typemap
trunk/contrib/perl/ext/PerlIO-encoding/MANIFEST
trunk/contrib/perl/ext/PerlIO-encoding/encoding.pm
trunk/contrib/perl/ext/PerlIO-encoding/encoding.xs
trunk/contrib/perl/ext/PerlIO-encoding/t/encoding.t
trunk/contrib/perl/ext/PerlIO-encoding/t/fallback.t
trunk/contrib/perl/ext/PerlIO-encoding/t/nolooping.t
trunk/contrib/perl/ext/PerlIO-scalar/scalar.pm
trunk/contrib/perl/ext/PerlIO-scalar/scalar.xs
trunk/contrib/perl/ext/PerlIO-scalar/t/scalar.t
trunk/contrib/perl/ext/PerlIO-scalar/t/scalar_ungetc.t
trunk/contrib/perl/ext/PerlIO-via/hints/aix.pl
trunk/contrib/perl/ext/PerlIO-via/t/via.t
trunk/contrib/perl/ext/PerlIO-via/via.pm
trunk/contrib/perl/ext/PerlIO-via/via.xs
trunk/contrib/perl/ext/Pod-Html/Html.pm
trunk/contrib/perl/ext/Pod-Html/pod2html.PL
trunk/contrib/perl/ext/Pod-Html/t/htmlescp.pod
trunk/contrib/perl/ext/Pod-Html/t/htmlescp.t
trunk/contrib/perl/ext/Pod-Html/t/htmllink.pod
trunk/contrib/perl/ext/Pod-Html/t/htmllink.t
trunk/contrib/perl/ext/Pod-Html/t/htmlview.pod
trunk/contrib/perl/ext/Pod-Html/t/htmlview.t
trunk/contrib/perl/ext/Pod-Html/t/pod2html-lib.pl
trunk/contrib/perl/ext/SDBM_File/Makefile.PL
trunk/contrib/perl/ext/SDBM_File/SDBM_File.pm
trunk/contrib/perl/ext/SDBM_File/SDBM_File.xs
trunk/contrib/perl/ext/SDBM_File/sdbm/CHANGES
trunk/contrib/perl/ext/SDBM_File/sdbm/COMPARE
trunk/contrib/perl/ext/SDBM_File/sdbm/Makefile.PL
trunk/contrib/perl/ext/SDBM_File/sdbm/README
trunk/contrib/perl/ext/SDBM_File/sdbm/README.too
trunk/contrib/perl/ext/SDBM_File/sdbm/biblio
trunk/contrib/perl/ext/SDBM_File/sdbm/dba.c
trunk/contrib/perl/ext/SDBM_File/sdbm/dbd.c
trunk/contrib/perl/ext/SDBM_File/sdbm/dbe.1
trunk/contrib/perl/ext/SDBM_File/sdbm/dbe.c
trunk/contrib/perl/ext/SDBM_File/sdbm/dbu.c
trunk/contrib/perl/ext/SDBM_File/sdbm/grind
trunk/contrib/perl/ext/SDBM_File/sdbm/hash.c
trunk/contrib/perl/ext/SDBM_File/sdbm/linux.patches
trunk/contrib/perl/ext/SDBM_File/sdbm/makefile.sdbm
trunk/contrib/perl/ext/SDBM_File/sdbm/pair.c
trunk/contrib/perl/ext/SDBM_File/sdbm/pair.h
trunk/contrib/perl/ext/SDBM_File/sdbm/readme.ms
trunk/contrib/perl/ext/SDBM_File/sdbm/sdbm.3
trunk/contrib/perl/ext/SDBM_File/sdbm/sdbm.c
trunk/contrib/perl/ext/SDBM_File/sdbm/sdbm.h
trunk/contrib/perl/ext/SDBM_File/sdbm/tune.h
trunk/contrib/perl/ext/SDBM_File/sdbm/util.c
trunk/contrib/perl/ext/SDBM_File/t/sdbm.t
trunk/contrib/perl/ext/SDBM_File/typemap
trunk/contrib/perl/ext/Socket/Makefile.PL
trunk/contrib/perl/ext/Socket/Socket.pm
trunk/contrib/perl/ext/Socket/Socket.xs
trunk/contrib/perl/ext/Socket/t/Socket.t
trunk/contrib/perl/ext/Socket/t/getaddrinfo.t
trunk/contrib/perl/ext/Socket/t/getnameinfo.t
trunk/contrib/perl/ext/Socket/t/socketpair.t
trunk/contrib/perl/ext/Sys-Hostname/Hostname.pm
trunk/contrib/perl/ext/Sys-Hostname/Hostname.xs
trunk/contrib/perl/ext/Sys-Hostname/t/Hostname.t
trunk/contrib/perl/ext/Tie-Hash-NamedCapture/NamedCapture.pm
trunk/contrib/perl/ext/Tie-Hash-NamedCapture/NamedCapture.xs
trunk/contrib/perl/ext/Tie-Hash-NamedCapture/t/tiehash.t
trunk/contrib/perl/ext/Tie-Memoize/lib/Tie/Memoize.pm
trunk/contrib/perl/ext/Tie-Memoize/t/Tie-Memoize.t
trunk/contrib/perl/ext/VMS-DCLsym/0README.txt
trunk/contrib/perl/ext/VMS-DCLsym/DCLsym.pm
trunk/contrib/perl/ext/VMS-DCLsym/DCLsym.xs
trunk/contrib/perl/ext/VMS-DCLsym/Makefile.PL
trunk/contrib/perl/ext/VMS-DCLsym/t/vms_dclsym.t
trunk/contrib/perl/ext/VMS-Stdio/0README.txt
trunk/contrib/perl/ext/VMS-Stdio/Makefile.PL
trunk/contrib/perl/ext/VMS-Stdio/Stdio.pm
trunk/contrib/perl/ext/VMS-Stdio/Stdio.xs
trunk/contrib/perl/ext/VMS-Stdio/t/vms_stdio.t
trunk/contrib/perl/ext/Win32CORE/Makefile.PL
trunk/contrib/perl/ext/Win32CORE/Win32CORE.c
trunk/contrib/perl/ext/Win32CORE/Win32CORE.pm
trunk/contrib/perl/ext/Win32CORE/t/win32core.t
trunk/contrib/perl/ext/XS-APItest/APItest.pm
trunk/contrib/perl/ext/XS-APItest/APItest.xs
trunk/contrib/perl/ext/XS-APItest/MANIFEST
trunk/contrib/perl/ext/XS-APItest/Makefile.PL
trunk/contrib/perl/ext/XS-APItest/README
trunk/contrib/perl/ext/XS-APItest/XSUB-redefined-macros.xs
trunk/contrib/perl/ext/XS-APItest/XSUB-undef-XS_VERSION.xs
trunk/contrib/perl/ext/XS-APItest/core.c
trunk/contrib/perl/ext/XS-APItest/core_or_not.inc
trunk/contrib/perl/ext/XS-APItest/exception.c
trunk/contrib/perl/ext/XS-APItest/notcore.c
trunk/contrib/perl/ext/XS-APItest/numeric.xs
trunk/contrib/perl/ext/XS-APItest/t/BHK.pm
trunk/contrib/perl/ext/XS-APItest/t/Block.pm
trunk/contrib/perl/ext/XS-APItest/t/Markers.pm
trunk/contrib/perl/ext/XS-APItest/t/Null.pm
trunk/contrib/perl/ext/XS-APItest/t/arrayexpr.t
trunk/contrib/perl/ext/XS-APItest/t/blockasexpr.t
trunk/contrib/perl/ext/XS-APItest/t/blockhooks-csc.t
trunk/contrib/perl/ext/XS-APItest/t/blockhooks.t
trunk/contrib/perl/ext/XS-APItest/t/call.t
trunk/contrib/perl/ext/XS-APItest/t/call_checker.t
trunk/contrib/perl/ext/XS-APItest/t/caller.t
trunk/contrib/perl/ext/XS-APItest/t/cleanup.t
trunk/contrib/perl/ext/XS-APItest/t/cophh.t
trunk/contrib/perl/ext/XS-APItest/t/copyhints.t
trunk/contrib/perl/ext/XS-APItest/t/customop.t
trunk/contrib/perl/ext/XS-APItest/t/eval-filter.t
trunk/contrib/perl/ext/XS-APItest/t/exception.t
trunk/contrib/perl/ext/XS-APItest/t/grok.t
trunk/contrib/perl/ext/XS-APItest/t/hash.t
trunk/contrib/perl/ext/XS-APItest/t/keyword_multiline.t
trunk/contrib/perl/ext/XS-APItest/t/keyword_plugin.t
trunk/contrib/perl/ext/XS-APItest/t/labelconst.aux
trunk/contrib/perl/ext/XS-APItest/t/labelconst.t
trunk/contrib/perl/ext/XS-APItest/t/loopblock.t
trunk/contrib/perl/ext/XS-APItest/t/looprest.t
trunk/contrib/perl/ext/XS-APItest/t/magic.t
trunk/contrib/perl/ext/XS-APItest/t/magic_chain.t
trunk/contrib/perl/ext/XS-APItest/t/multicall.t
trunk/contrib/perl/ext/XS-APItest/t/my_cxt.t
trunk/contrib/perl/ext/XS-APItest/t/my_exit.t
trunk/contrib/perl/ext/XS-APItest/t/op.t
trunk/contrib/perl/ext/XS-APItest/t/op_contextualize.t
trunk/contrib/perl/ext/XS-APItest/t/op_list.t
trunk/contrib/perl/ext/XS-APItest/t/overload.t
trunk/contrib/perl/ext/XS-APItest/t/peep.t
trunk/contrib/perl/ext/XS-APItest/t/pmflag.t
trunk/contrib/perl/ext/XS-APItest/t/postinc.t
trunk/contrib/perl/ext/XS-APItest/t/printf.t
trunk/contrib/perl/ext/XS-APItest/t/ptr_table.t
trunk/contrib/perl/ext/XS-APItest/t/push.t
trunk/contrib/perl/ext/XS-APItest/t/refs.t
trunk/contrib/perl/ext/XS-APItest/t/rmagical.t
trunk/contrib/perl/ext/XS-APItest/t/rv2cv_op_cv.t
trunk/contrib/perl/ext/XS-APItest/t/savehints.t
trunk/contrib/perl/ext/XS-APItest/t/scopelessblock.t
trunk/contrib/perl/ext/XS-APItest/t/stmtasexpr.t
trunk/contrib/perl/ext/XS-APItest/t/stmtsasexpr.t
trunk/contrib/perl/ext/XS-APItest/t/stuff_modify_bug.t
trunk/contrib/perl/ext/XS-APItest/t/stuff_svcur_bug.t
trunk/contrib/perl/ext/XS-APItest/t/svpeek.t
trunk/contrib/perl/ext/XS-APItest/t/svpv_magic.t
trunk/contrib/perl/ext/XS-APItest/t/svsetsv.t
trunk/contrib/perl/ext/XS-APItest/t/swaplabel.t
trunk/contrib/perl/ext/XS-APItest/t/swaptwostmts.t
trunk/contrib/perl/ext/XS-APItest/t/temp_lv_sub.t
trunk/contrib/perl/ext/XS-APItest/t/utf16_to_utf8.t
trunk/contrib/perl/ext/XS-APItest/t/utf8.t
trunk/contrib/perl/ext/XS-APItest/t/xs_special_subs.t
trunk/contrib/perl/ext/XS-APItest/t/xs_special_subs_require.t
trunk/contrib/perl/ext/XS-APItest/t/xsub_h.t
trunk/contrib/perl/ext/XS-APItest/typemap
trunk/contrib/perl/ext/XS-Typemap/Makefile.PL
trunk/contrib/perl/ext/XS-Typemap/README
trunk/contrib/perl/ext/XS-Typemap/Typemap.pm
trunk/contrib/perl/ext/XS-Typemap/Typemap.xs
trunk/contrib/perl/ext/XS-Typemap/stdio.c
trunk/contrib/perl/ext/XS-Typemap/t/Typemap.t
trunk/contrib/perl/ext/XS-Typemap/typemap
Modified: trunk/contrib/perl/ext/B/B/Concise.pm
===================================================================
--- trunk/contrib/perl/ext/B/B/Concise.pm 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/B/B/Concise.pm 2013-12-02 21:32:26 UTC (rev 6445)
@@ -14,7 +14,7 @@
use Exporter (); # use #5
-our $VERSION = "0.83";
+our $VERSION = "0.95";
our @ISA = qw(Exporter);
our @EXPORT_OK = qw( set_style set_style_standard add_callback
concise_subref concise_cv concise_main
@@ -47,8 +47,7 @@
"(?(#seq)?)#noise#arg(?([#targarg])?)"],
"debug" =>
["#class (#addr)\n\top_next\t\t#nextaddr\n\top_sibling\t#sibaddr\n\t"
- . "op_ppaddr\tPL_ppaddr[OP_#NAME]\n\top_type\t\t#typenum\n" .
- ($] > 5.009 ? '' : "\top_seq\t\t#seqnum\n")
+ . "op_ppaddr\tPL_ppaddr[OP_#NAME]\n\top_type\t\t#typenum\n"
. "\top_flags\t#flagval\n\top_private\t#privval\t#hintsval\n"
. "(?(\top_first\t#firstaddr\n)?)(?(\top_last\t\t#lastaddr\n)?)"
. "(?(\top_sv\t\t#svaddr\n)?)",
@@ -137,7 +136,7 @@
my $codeobj = svref_2object($coderef);
return concise_stashref(@_)
- unless ref $codeobj eq 'B::CV';
+ unless ref($codeobj) =~ '^B::(?:CV|FM)\z';
concise_cv_obj($order, $codeobj, $name);
}
@@ -356,22 +355,30 @@
}
else {
# convert function names to subrefs
- my $objref;
if (ref $objname) {
print $walkHandle "B::Concise::compile($objname)\n"
if $banner;
- $objref = $objname;
+ concise_subref($order, ($objname)x2);
+ next;
} else {
$objname = "main::" . $objname unless $objname =~ /::/;
- print $walkHandle "$objname:\n";
no strict 'refs';
- unless (exists &$objname) {
+ my $glob = \*$objname;
+ unless (*$glob{CODE} || *$glob{FORMAT}) {
+ print $walkHandle "$objname:\n" if $banner;
print $walkHandle "err: unknown function ($objname)\n";
return;
}
- $objref = \&$objname;
+ if (my $objref = *$glob{CODE}) {
+ print $walkHandle "$objname:\n" if $banner;
+ concise_subref($order, $objref, $objname);
+ }
+ if (my $objref = *$glob{FORMAT}) {
+ print $walkHandle "$objname (FORMAT):\n"
+ if $banner;
+ concise_subref($order, $objref, $objname);
+ }
}
- concise_subref($order, $objref, $objname);
}
}
for my $pkg (@render_packs) {
@@ -502,15 +509,9 @@
push @$targ, $ar;
push @todo, [$op->pmreplstart, $ar];
} elsif ($name =~ /^enter(loop|iter)$/) {
- if ($] > 5.009) {
- $labels{${$op->nextop}} = "NEXT";
- $labels{${$op->lastop}} = "LAST";
- $labels{${$op->redoop}} = "REDO";
- } else {
- $labels{$op->nextop->seq} = "NEXT";
- $labels{$op->lastop->seq} = "LAST";
- $labels{$op->redoop->seq} = "REDO";
- }
+ $labels{${$op->nextop}} = "NEXT";
+ $labels{${$op->lastop}} = "LAST";
+ $labels{${$op->redoop}} = "REDO";
}
}
}
@@ -595,12 +596,13 @@
$priv{$_}{128} = "LVINTRO"
for ("pos", "substr", "vec", "threadsv", "gvsv", "rv2sv", "rv2hv", "rv2gv",
"rv2av", "rv2arylen", "aelem", "helem", "aslice", "hslice", "padsv",
- "padav", "padhv", "enteriter");
+ "padav", "padhv", "enteriter", "entersub", "padrange", "pushmark");
$priv{$_}{64} = "REFC" for ("leave", "leavesub", "leavesublv", "leavewrite");
$priv{"aassign"}{64} = "COMMON";
-$priv{"aassign"}{32} = $] < 5.009 ? "PHASH" : "STATE";
+$priv{"aassign"}{32} = "STATE";
$priv{"sassign"}{32} = "STATE";
$priv{"sassign"}{64} = "BKWARD";
+$priv{"sassign"}{128}= "CV2GV";
$priv{$_}{64} = "RTIME" for ("match", "subst", "substcont", "qr");
@{$priv{"trans"}}{1,2,4,8,16,64} = ("<UTF", ">UTF", "IDENT", "SQUASH", "DEL",
"COMPL", "GROWS");
@@ -611,12 +613,17 @@
@{$priv{$_}}{32,64,96} = ("DREFAV", "DREFHV", "DREFSV")
for (qw(rv2gv rv2sv padsv aelem helem));
$priv{$_}{16} = "STATE" for ("padav", "padhv", "padsv");
-@{$priv{"entersub"}}{16,32,64} = ("DBG","TARG","NOMOD");
-@{$priv{$_}}{4,8,128} = ("INARGS","AMPER","NO()") for ("entersub", "rv2cv");
+@{$priv{rv2gv}}{4,16} = qw "NOINIT FAKE";
+@{$priv{"entersub"}}{1,4,16,32,64} = qw( INARGS TARG DBG DEREF );
+@{$priv{rv2cv}}{1,8,128} = ("CONST","AMPER","NO()");
$priv{"gv"}{32} = "EARLYCV";
$priv{"aelem"}{16} = $priv{"helem"}{16} = "LVDEFER";
$priv{$_}{16} = "OURINTR" for ("gvsv", "rv2sv", "rv2av", "rv2hv", "r2gv",
"enteriter");
+$priv{$_}{8} = 'LVSUB' for qw(rv2av rv2gv rv2hv padav padhv aelem helem
+ aslice hslice av2arylen keys rkeys substr pos vec);
+@{$priv{$_}}{32,64} = ('BOOL','BOOL?') for 'rv2hv', 'padhv';
+$priv{substr}{16} = 'REPL1ST';
$priv{$_}{16} = "TARGMY"
for (map(($_,"s$_"),"chop", "chomp"),
map(($_,"i_$_"), "postinc", "postdec", "multiply", "divide", "modulo",
@@ -630,7 +637,8 @@
"exec", "kill", "getppid", "getpgrp", "setpgrp", "getpriority",
"setpriority", "time", "sleep");
$priv{$_}{4} = "REVERSED" for ("enteriter", "iter");
-@{$priv{"const"}}{4,8,16,32,64,128} = ("SHORT","STRICT","ENTERED",'$[',"BARE","WARN");
+@{$priv{"const"}}{2,4,8,16,64,128} =
+ ("NOVER","SHORT","STRICT","ENTERED","BARE","FOLD");
$priv{"flip"}{64} = $priv{"flop"}{64} = "LINENUM";
$priv{"list"}{64} = "GUESSED";
$priv{"delete"}{64} = "SLICE";
@@ -643,26 +651,25 @@
$priv{"exit"}{128} = "VMS";
$priv{$_}{2} = "FTACCESS"
for ("ftrread", "ftrwrite", "ftrexec", "fteread", "ftewrite", "fteexec");
-$priv{"entereval"}{2} = "HAS_HH";
-if ($] >= 5.009) {
- # Stacked filetests are post 5.8.x
- $priv{$_}{4} = "FTSTACKED"
- for ("ftrread", "ftrwrite", "ftrexec", "fteread", "ftewrite", "fteexec",
- "ftis", "fteowned", "ftrowned", "ftzero", "ftsize", "ftmtime",
- "ftatime", "ftctime", "ftsock", "ftchr", "ftblk", "ftfile", "ftdir",
- "ftpipe", "ftlink", "ftsuid", "ftsgid", "ftsvtx", "fttty", "fttext",
- "ftbinary");
- # Lexical $_ is post 5.8.x
- $priv{$_}{2} = "GREPLEX"
- for ("mapwhile", "mapstart", "grepwhile", "grepstart");
-}
+@{$priv{"entereval"}}{2,4,8,16} = qw "HAS_HH UNI BYTES COPHH";
+@{$priv{$_}}{4,8,16} = ("FTSTACKED","FTSTACKING","FTAFTERt")
+for ("ftrread", "ftrwrite", "ftrexec", "fteread", "ftewrite", "fteexec",
+ "ftis", "fteowned", "ftrowned", "ftzero", "ftsize", "ftmtime",
+ "ftatime", "ftctime", "ftsock", "ftchr", "ftblk", "ftfile", "ftdir",
+ "ftpipe", "ftlink", "ftsuid", "ftsgid", "ftsvtx", "fttty", "fttext",
+ "ftbinary");
+$priv{$_}{2} = "GREPLEX"
+for ("mapwhile", "mapstart", "grepwhile", "grepstart");
+$priv{$_}{128} = '+1' for qw "caller wantarray runcv";
+@{$priv{coreargs}}{1,2,64,128} = ('DREF1','DREF2','$MOD','MARK');
+$priv{$_}{128} = 'UTF' for qw "last redo next goto dump";
our %hints; # used to display each COP's op_hints values
# strict refs, subs, vars
- at hints{2,512,1024} = ('$', '&', '*');
-# integers, locale, bytes, arybase
- at hints{1,4,8,16,32} = ('i', 'l', 'b', '[');
+ at hints{2,512,1024,32,64,128} = ('$', '&', '*', 'x$', 'x&', 'x*');
+# integers, locale, bytes
+ at hints{1,4,8,16} = ('i', 'l', 'b');
# block scope, localise %^H, $^OPEN (in), $^OPEN (out)
@hints{256,131072,262144,524288} = ('{','%','<','>');
# overload new integer, float, binary, string, re
@@ -725,13 +732,14 @@
}
if (class($sv) eq "SPECIAL") {
$hr->{svval} .= ["Null", "sv_undef", "sv_yes", "sv_no"]->[$$sv];
- } elsif ($preferpv && $sv->FLAGS & SVf_POK) {
+ } elsif ($preferpv
+ && ($sv->FLAGS & SVf_POK || class($sv) eq "REGEXP")) {
$hr->{svval} .= cstring($sv->PV);
} elsif ($sv->FLAGS & SVf_NOK) {
$hr->{svval} .= $sv->NV;
} elsif ($sv->FLAGS & SVf_IOK) {
$hr->{svval} .= $sv->int_value;
- } elsif ($sv->FLAGS & SVf_POK) {
+ } elsif ($sv->FLAGS & SVf_POK || class($sv) eq "REGEXP") {
$hr->{svval} .= cstring($sv->PV);
} elsif (class($sv) eq "HV") {
$hr->{svval} .= 'HASH';
@@ -779,38 +787,44 @@
$h{targarglife} = $h{targarg} = "$h{targ} $refs";
}
} elsif ($h{targ}) {
- my $padname = (($curcv->PADLIST->ARRAY)[0]->ARRAY)[$h{targ}];
- if (defined $padname and class($padname) ne "SPECIAL") {
- $h{targarg} = $padname->PVX;
- if ($padname->FLAGS & SVf_FAKE) {
- if ($] < 5.009) {
- $h{targarglife} = "$h{targarg}:FAKE";
- } else {
+ my $count = $h{name} eq 'padrange' ? ($op->private & 127) : 1;
+ my (@targarg, @targarglife);
+ for my $i (0..$count-1) {
+ my ($targarg, $targarglife);
+ my $padname = (($curcv->PADLIST->ARRAY)[0]->ARRAY)[$h{targ}+$i];
+ if (defined $padname and class($padname) ne "SPECIAL") {
+ $targarg = $padname->PVX;
+ if ($padname->FLAGS & SVf_FAKE) {
# These changes relate to the jumbo closure fix.
# See changes 19939 and 20005
my $fake = '';
$fake .= 'a'
- if $padname->PARENT_FAKELEX_FLAGS & PAD_FAKELEX_ANON;
+ if $padname->PARENT_FAKELEX_FLAGS & PAD_FAKELEX_ANON;
$fake .= 'm'
- if $padname->PARENT_FAKELEX_FLAGS & PAD_FAKELEX_MULTI;
+ if $padname->PARENT_FAKELEX_FLAGS & PAD_FAKELEX_MULTI;
$fake .= ':' . $padname->PARENT_PAD_INDEX
if $curcv->CvFLAGS & CVf_ANON;
- $h{targarglife} = "$h{targarg}:FAKE:$fake";
+ $targarglife = "$targarg:FAKE:$fake";
}
+ else {
+ my $intro = $padname->COP_SEQ_RANGE_LOW - $cop_seq_base;
+ my $finish = int($padname->COP_SEQ_RANGE_HIGH) - $cop_seq_base;
+ $finish = "end" if $finish == 999999999 - $cop_seq_base;
+ $targarglife = "$targarg:$intro,$finish";
+ }
+ } else {
+ $targarglife = $targarg = "t" . ($h{targ}+$i);
}
- else {
- my $intro = $padname->COP_SEQ_RANGE_LOW - $cop_seq_base;
- my $finish = int($padname->COP_SEQ_RANGE_HIGH) - $cop_seq_base;
- $finish = "end" if $finish == 999999999 - $cop_seq_base;
- $h{targarglife} = "$h{targarg}:$intro,$finish";
- }
- } else {
- $h{targarglife} = $h{targarg} = "t" . $h{targ};
+ push @targarg, $targarg;
+ push @targarglife, $targarglife;
}
+ $h{targarg} = join '; ', @targarg;
+ $h{targarglife} = join '; ', @targarglife;
}
$h{arg} = "";
$h{svclass} = $h{svaddr} = $h{svval} = "";
if ($h{class} eq "PMOP") {
+ my $extra = '';
my $precomp = $op->precomp;
if (defined $precomp) {
$precomp = cstring($precomp); # Escape literal control sequences
@@ -818,25 +832,30 @@
} else {
$precomp = "";
}
- my $pmreplroot = $op->pmreplroot;
- my $pmreplstart;
- if (ref($pmreplroot) eq "B::GV") {
+ if ($op->name eq 'subst') {
+ if (class($op->pmreplstart) ne "NULL") {
+ undef $lastnext;
+ $extra = " replstart->" . seq($op->pmreplstart);
+ }
+ }
+ elsif ($op->name eq 'pushre') {
# with C<@stash_array = split(/pat/, str);>,
# *stash_array is stored in /pat/'s pmreplroot.
- $h{arg} = "($precomp => \@" . $pmreplroot->NAME . ")";
- } elsif (!ref($pmreplroot) and $pmreplroot) {
- # same as the last case, except the value is actually a
- # pad offset for where the GV is kept (this happens under
- # ithreads)
- my $gv = (($curcv->PADLIST->ARRAY)[1]->ARRAY)[$pmreplroot];
- $h{arg} = "($precomp => \@" . $gv->NAME . ")";
- } elsif ($ {$op->pmreplstart}) {
- undef $lastnext;
- $pmreplstart = "replstart->" . seq($op->pmreplstart);
- $h{arg} = "(" . join(" ", $precomp, $pmreplstart) . ")";
- } else {
- $h{arg} = "($precomp)";
+ my $gv = $op->pmreplroot;
+ if (!ref($gv)) {
+ # threaded: the value is actually a pad offset for where
+ # the GV is kept (op_pmtargetoff)
+ if ($gv) {
+ $gv = (($curcv->PADLIST->ARRAY)[1]->ARRAY)[$gv]->NAME;
+ }
+ }
+ else {
+ # unthreaded: its a GV (if it exists)
+ $gv = (ref($gv) eq "B::GV") ? $gv->NAME : undef;
+ }
+ $extra = " => \@$gv" if $gv;
}
+ $h{arg} = "($precomp$extra)";
} elsif ($h{class} eq "PVOP" and $h{name} !~ '^transr?\z') {
$h{arg} = '("' . $op->pv . '")';
$h{svval} = '"' . $op->pv . '"';
@@ -850,9 +869,7 @@
my $ln = $op->line;
$loc .= ":$ln";
my($stash, $cseq) = ($op->stash->NAME, $op->cop_seq - $cop_seq_base);
- my $arybase = $op->arybase;
- $arybase = $arybase ? ' $[=' . $arybase : "";
- $h{arg} = "($label$stash $cseq $loc$arybase)";
+ $h{arg} = "($label$stash $cseq $loc)";
if ($show_src) {
fill_srclines($pathnm) unless exists $srclines{$pathnm};
# Would love to retain Jim's use of // but this code needs to be
@@ -883,13 +900,8 @@
}
$h{seq} = $h{hyphseq} = seq($op);
$h{seq} = "" if $h{seq} eq "-";
- if ($] > 5.009) {
- $h{opt} = $op->opt;
- $h{label} = $labels{$$op};
- } else {
- $h{seqnum} = $op->seq;
- $h{label} = $labels{$op->seq};
- }
+ $h{opt} = $op->opt;
+ $h{label} = $labels{$$op};
$h{next} = $op->next;
$h{next} = (class($h{next}) eq "NULL") ? "(end)" : seq($h{next});
$h{nextaddr} = sprintf("%#x", $ {$op->next});
@@ -1122,7 +1134,8 @@
=head1 OPTIONS
Arguments that don't start with a hyphen are taken to be the names of
-subroutines to render; if no such functions are specified, the main
+subroutines or formats to render; if no
+such functions are specified, the main
body of the program (outside any subroutines, and not including use'd
or require'd files) is rendered. Passing C<BEGIN>, C<UNITCHECK>,
C<CHECK>, C<INIT>, or C<END> will cause all of the corresponding
@@ -1255,7 +1268,7 @@
=item B<-littleendian>
-Print seqence numbers with the least significant digit first. This is
+Print sequence numbers with the least significant digit first. This is
obviously mutually exclusive with bigendian.
=back
@@ -1541,10 +1554,12 @@
$ strict refs
& strict subs
* strict vars
+ x$ explicit use/no strict refs
+ x& explicit use/no strict subs
+ x* explicit use/no strict vars
i integers
l locale
b bytes
- [ arybase
{ block scope
% localise %^H
< open in
Property changes on: trunk/contrib/perl/ext/B/B/Concise.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Copied: trunk/contrib/perl/ext/B/B/Debug.pm (from rev 6437, vendor/perl/5.18.1/ext/B/B/Debug.pm)
===================================================================
--- trunk/contrib/perl/ext/B/B/Debug.pm (rev 0)
+++ trunk/contrib/perl/ext/B/B/Debug.pm 2013-12-02 21:32:26 UTC (rev 6445)
@@ -0,0 +1,420 @@
+package B::Debug;
+
+our $VERSION = '1.11';
+
+use strict;
+require 5.006;
+use B qw(peekop class walkoptree walkoptree_exec
+ main_start main_root cstring sv_undef);
+use Config;
+my (@optype, @specialsv_name);
+require B;
+if ($] < 5.009) {
+ require B::Asmdata;
+ B::Asmdata->import qw(@optype @specialsv_name);
+} else {
+ B->import qw(@optype @specialsv_name);
+}
+my $have_B_Flags;
+if (!$ENV{PERL_CORE}){ # avoid CORE test crashes
+ eval { require B::Flags and $have_B_Flags++ };
+}
+my %done_gv;
+
+sub _printop {
+ my $op = shift;
+ my $addr = ${$op} ? $op->ppaddr : '';
+ $addr =~ s/^PL_ppaddr// if $addr;
+ return sprintf "0x%x %s %s", ${$op}, ${$op} ? class($op) : '', $addr;
+}
+
+sub B::OP::debug {
+ my ($op) = @_;
+ printf <<'EOT', class($op), $$op, $op->ppaddr, _printop($op->next), _printop($op->sibling), $op->targ, $op->type;
+%s (0x%lx)
+ op_ppaddr %s
+ op_next %s
+ op_sibling %s
+ op_targ %d
+ op_type %d
+EOT
+ if ($] > 5.009) {
+ printf <<'EOT', $op->opt;
+ op_opt %d
+EOT
+ } else {
+ printf <<'EOT', $op->seq;
+ op_seq %d
+EOT
+ }
+ if ($have_B_Flags) {
+ printf <<'EOT', $op->flags, $op->flagspv, $op->private, $op->privatepv;
+ op_flags %d %s
+ op_private %d %s
+EOT
+ } else {
+ printf <<'EOT', $op->flags, $op->private;
+ op_flags %d
+ op_private %d
+EOT
+ }
+}
+
+sub B::UNOP::debug {
+ my ($op) = @_;
+ $op->B::OP::debug();
+ printf "\top_first\t%s\n", _printop($op->first);
+}
+
+sub B::BINOP::debug {
+ my ($op) = @_;
+ $op->B::UNOP::debug();
+ printf "\top_last \t%s\n", _printop($op->last);
+}
+
+sub B::LOOP::debug {
+ my ($op) = @_;
+ $op->B::BINOP::debug();
+ printf <<'EOT', _printop($op->redoop), _printop($op->nextop), _printop($op->lastop);
+ op_redoop %s
+ op_nextop %s
+ op_lastop %s
+EOT
+}
+
+sub B::LOGOP::debug {
+ my ($op) = @_;
+ $op->B::UNOP::debug();
+ printf "\top_other\t%s\n", _printop($op->other);
+}
+
+sub B::LISTOP::debug {
+ my ($op) = @_;
+ $op->B::BINOP::debug();
+ printf "\top_children\t%d\n", $op->children;
+}
+
+sub B::PMOP::debug {
+ my ($op) = @_;
+ $op->B::LISTOP::debug();
+ printf "\top_pmreplroot\t0x%x\n", $] < 5.008 ? ${$op->pmreplroot} : $op->pmreplroot;
+ printf "\top_pmreplstart\t0x%x\n", ${$op->pmreplstart};
+ printf "\top_pmnext\t0x%x\n", ${$op->pmnext} if $] < 5.009005;
+ if ($Config{'useithreads'}) {
+ printf "\top_pmstashpv\t%s\n", cstring($op->pmstashpv);
+ printf "\top_pmoffset\t%d\n", $op->pmoffset;
+ } else {
+ printf "\top_pmstash\t%s\n", cstring($op->pmstash);
+ }
+ printf "\top_precomp\t%s\n", cstring($op->precomp);
+ printf "\top_pmflags\t0x%x\n", $op->pmflags;
+ printf "\top_reflags\t0x%x\n", $op->reflags if $] >= 5.009;
+ printf "\top_pmpermflags\t0x%x\n", $op->pmpermflags if $] < 5.009;
+ printf "\top_pmdynflags\t0x%x\n", $op->pmdynflags if $] < 5.009;
+ $op->pmreplroot->debug if $] < 5.008;
+}
+
+sub B::COP::debug {
+ my ($op) = @_;
+ $op->B::OP::debug();
+ my $cop_io = class($op->io) eq 'SPECIAL' ? '' : $op->io->as_string;
+ printf <<'EOT', $op->label, $op->stashpv, $op->file, $op->cop_seq, $op->arybase, $op->line, ${$op->warnings}, cstring($cop_io);
+ cop_label "%s"
+ cop_stashpv "%s"
+ cop_file "%s"
+ cop_seq %d
+ cop_arybase %d
+ cop_line %d
+ cop_warnings 0x%x
+ cop_io %s
+EOT
+}
+
+sub B::SVOP::debug {
+ my ($op) = @_;
+ $op->B::OP::debug();
+ printf "\top_sv\t\t0x%x\n", ${$op->sv};
+ $op->sv->debug;
+}
+
+sub B::PVOP::debug {
+ my ($op) = @_;
+ $op->B::OP::debug();
+ printf "\top_pv\t\t%s\n", cstring($op->pv);
+}
+
+sub B::PADOP::debug {
+ my ($op) = @_;
+ $op->B::OP::debug();
+ printf "\top_padix\t%ld\n", $op->padix;
+}
+
+sub B::NULL::debug {
+ my ($sv) = @_;
+ if ($$sv == ${sv_undef()}) {
+ print "&sv_undef\n";
+ } else {
+ printf "NULL (0x%x)\n", $$sv;
+ }
+}
+
+sub B::SV::debug {
+ my ($sv) = @_;
+ if (!$$sv) {
+ print class($sv), " = NULL\n";
+ return;
+ }
+ printf <<'EOT', class($sv), $$sv, $sv->REFCNT, $sv->FLAGS;
+%s (0x%x)
+ REFCNT %d
+ FLAGS 0x%x
+EOT
+}
+
+sub B::RV::debug {
+ my ($rv) = @_;
+ B::SV::debug($rv);
+ printf <<'EOT', ${$rv->RV};
+ RV 0x%x
+EOT
+ $rv->RV->debug;
+}
+
+sub B::PV::debug {
+ my ($sv) = @_;
+ $sv->B::SV::debug();
+ my $pv = $sv->PV();
+ printf <<'EOT', cstring($pv), length($pv);
+ xpv_pv %s
+ xpv_cur %d
+EOT
+}
+
+sub B::IV::debug {
+ my ($sv) = @_;
+ $sv->B::SV::debug();
+ printf "\txiv_iv\t\t%d\n", $sv->IV;
+}
+
+sub B::NV::debug {
+ my ($sv) = @_;
+ $sv->B::IV::debug();
+ printf "\txnv_nv\t\t%s\n", $sv->NV;
+}
+
+sub B::PVIV::debug {
+ my ($sv) = @_;
+ $sv->B::PV::debug();
+ printf "\txiv_iv\t\t%d\n", $sv->IV;
+}
+
+sub B::PVNV::debug {
+ my ($sv) = @_;
+ $sv->B::PVIV::debug();
+ printf "\txnv_nv\t\t%s\n", $sv->NV;
+}
+
+sub B::PVLV::debug {
+ my ($sv) = @_;
+ $sv->B::PVNV::debug();
+ printf "\txlv_targoff\t%d\n", $sv->TARGOFF;
+ printf "\txlv_targlen\t%u\n", $sv->TARGLEN;
+ printf "\txlv_type\t%s\n", cstring(chr($sv->TYPE));
+}
+
+sub B::BM::debug {
+ my ($sv) = @_;
+ $sv->B::PVNV::debug();
+ printf "\txbm_useful\t%d\n", $sv->USEFUL;
+ printf "\txbm_previous\t%u\n", $sv->PREVIOUS;
+ printf "\txbm_rare\t%s\n", cstring(chr($sv->RARE));
+}
+
+sub B::CV::debug {
+ my ($sv) = @_;
+ $sv->B::PVNV::debug();
+ my ($stash) = $sv->STASH;
+ my ($start) = $sv->START;
+ my ($root) = $sv->ROOT;
+ my ($padlist) = $sv->PADLIST;
+ my ($file) = $sv->FILE;
+ my ($gv) = $sv->GV;
+ printf <<'EOT', $$stash, $$start, $$root, $$gv, $file, $sv->DEPTH, $padlist, ${$sv->OUTSIDE}, $sv->OUTSIDE_SEQ;
+ STASH 0x%x
+ START 0x%x
+ ROOT 0x%x
+ GV 0x%x
+ FILE %s
+ DEPTH %d
+ PADLIST 0x%x
+ OUTSIDE 0x%x
+ OUTSIDE_SEQ %d
+EOT
+ $start->debug if $start;
+ $root->debug if $root;
+ $gv->debug if $gv;
+ $padlist->debug if $padlist;
+}
+
+sub B::AV::debug {
+ my ($av) = @_;
+ $av->B::SV::debug;
+ # tied arrays may leave out FETCHSIZE
+ my (@array) = eval { $av->ARRAY; };
+ print "\tARRAY\t\t(", join(", ", map("0x" . $$_, @array)), ")\n";
+ my $fill = eval { scalar(@array) };
+ if ($Config{'useithreads'}) {
+ printf <<'EOT', $fill, $av->MAX, $av->OFF;
+ FILL %d
+ MAX %d
+ OFF %d
+EOT
+ } else {
+ printf <<'EOT', $fill, $av->MAX;
+ FILL %d
+ MAX %d
+EOT
+ }
+ printf <<'EOT', $av->AvFLAGS if $] < 5.009;
+ AvFLAGS %d
+EOT
+}
+
+sub B::GV::debug {
+ my ($gv) = @_;
+ if ($done_gv{$$gv}++) {
+ printf "GV %s::%s\n", $gv->STASH->NAME, $gv->SAFENAME;
+ return;
+ }
+ my ($sv) = $gv->SV;
+ my ($av) = $gv->AV;
+ my ($cv) = $gv->CV;
+ $gv->B::SV::debug;
+ printf <<'EOT', $gv->SAFENAME, $gv->STASH->NAME, $gv->STASH, $$sv, $gv->GvREFCNT, $gv->FORM, $$av, ${$gv->HV}, ${$gv->EGV}, $$cv, $gv->CVGEN, $gv->LINE, $gv->FILE, $gv->GvFLAGS;
+ NAME %s
+ STASH %s (0x%x)
+ SV 0x%x
+ GvREFCNT %d
+ FORM 0x%x
+ AV 0x%x
+ HV 0x%x
+ EGV 0x%x
+ CV 0x%x
+ CVGEN %d
+ LINE %d
+ FILE %s
+ GvFLAGS 0x%x
+EOT
+ $sv->debug if $sv;
+ $av->debug if $av;
+ $cv->debug if $cv;
+}
+
+sub B::SPECIAL::debug {
+ my $sv = shift;
+ print $specialsv_name[$$sv], "\n";
+}
+
+sub compile {
+ my $order = shift;
+ B::clearsym();
+ if ($order && $order eq "exec") {
+ return sub { walkoptree_exec(main_start, "debug") }
+ } else {
+ return sub { walkoptree(main_root, "debug") }
+ }
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+B::Debug - Walk Perl syntax tree, printing debug info about ops
+
+=head1 SYNOPSIS
+
+ perl -MO=Debug[,OPTIONS] foo.pl
+
+=head1 DESCRIPTION
+
+See F<ext/B/README> and the newer L<B::Concise>, L<B::Terse>.
+
+=head1 OPTIONS
+
+With option -exec, walks tree in execute order,
+otherwise in basic order.
+
+=head1 Changes
+
+ 1.11 2008-07-14 rurban
+ avoid B::Flags in CORE tests not to crash on old XS in @INC
+
+ 1.10 2008-06-28 rurban
+ require 5.006; Test::More not possible in 5.00505
+ our => my
+
+ 1.09 2008-06-18 rurban
+ minor META.yml syntax fix
+ 5.8.0 ending nextstate test failure: be more tolerant
+ PREREQ_PM Test::More
+
+ 1.08 2008-06-17 rurban
+ support 5.00558 - 5.6.2
+
+ 1.07 2008-06-16 rurban
+ debug.t: fix strawberry perl quoting issue
+
+ 1.06 2008-06-11 rurban
+ added B::Flags output
+ dual-life CPAN as B-Debug-1.06 and CORE
+ protect scalar(@array) if tied arrays leave out FETCHSIZE
+
+ 1.05_03 2008-04-16 rurban
+ ithread fixes in B::AV
+ B-C-1.04_??
+
+ B-C-1.04_09 2008-02-24 rurban
+ support 5.8 (import Asmdata)
+
+ 1.05_02 2008-02-21 rurban
+ added _printop
+ B-C-1.04_08 and CORE
+
+ 1.05_01 2008-02-05 rurban
+ 5.10 fix for op->seq
+ B-C-1.04_04
+
+=head1 AUTHOR
+
+Malcolm Beattie, C<mbeattie at sable.ox.ac.uk>
+Reini Urban C<rurban at cpan.org>
+
+=head1 LICENSE
+
+Copyright (c) 1996, 1997 Malcolm Beattie
+Copyright (c) 2008 Reini Urban
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of either:
+
+ a) the GNU General Public License as published by the Free
+ Software Foundation; either version 1, or (at your option) any
+ later version, or
+
+ b) the "Artistic License" which comes with this kit.
+
+ 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. See either
+ the GNU General Public License or the Artistic License for more details.
+
+ You should have received a copy of the Artistic License with this kit,
+ in the file named "Artistic". If not, you can get one from the Perl
+ distribution. You should also have received a copy of the GNU General
+ Public License, in the file named "Copying". If not, you can get one
+ from the Perl distribution or else write to the Free Software Foundation,
+ Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA.
+
+=cut
Copied: trunk/contrib/perl/ext/B/B/Deparse.pm (from rev 6437, vendor/perl/5.18.1/ext/B/B/Deparse.pm)
===================================================================
--- trunk/contrib/perl/ext/B/B/Deparse.pm (rev 0)
+++ trunk/contrib/perl/ext/B/B/Deparse.pm 2013-12-02 21:32:26 UTC (rev 6445)
@@ -0,0 +1,4858 @@
+# B::Deparse.pm
+# Copyright (c) 1998-2000, 2002, 2003, 2004, 2005, 2006 Stephen McCamant.
+# All rights reserved.
+# This module is free software; you can redistribute and/or modify
+# it under the same terms as Perl itself.
+
+# This is based on the module of the same name by Malcolm Beattie,
+# but essentially none of his code remains.
+
+package B::Deparse;
+use Carp;
+use B qw(class main_root main_start main_cv svref_2object opnumber perlstring
+ OPf_WANT OPf_WANT_VOID OPf_WANT_SCALAR OPf_WANT_LIST
+ OPf_KIDS OPf_REF OPf_STACKED OPf_SPECIAL OPf_MOD OPpPAD_STATE
+ OPpLVAL_INTRO OPpOUR_INTRO OPpENTERSUB_AMPER OPpSLICE OPpCONST_BARE
+ OPpTRANS_SQUASH OPpTRANS_DELETE OPpTRANS_COMPLEMENT OPpTARGET_MY
+ OPpCONST_ARYBASE OPpEXISTS_SUB OPpSORT_NUMERIC OPpSORT_INTEGER
+ OPpSORT_REVERSE OPpSORT_INPLACE OPpSORT_DESCEND OPpITER_REVERSED
+ SVf_IOK SVf_NOK SVf_ROK SVf_POK SVpad_OUR SVf_FAKE SVs_RMG SVs_SMG
+ CVf_METHOD CVf_LVALUE
+ PMf_KEEP PMf_GLOBAL PMf_CONTINUE PMf_EVAL PMf_ONCE
+ PMf_MULTILINE PMf_SINGLELINE PMf_FOLD PMf_EXTENDED),
+ ($] < 5.009 ? 'PMf_SKIPWHITE' : 'RXf_SKIPWHITE'),
+ ($] < 5.011 ? 'CVf_LOCKED' : ());
+$VERSION = 0.89;
+use strict;
+use vars qw/$AUTOLOAD/;
+use warnings ();
+
+BEGIN {
+ # Easiest way to keep this code portable between 5.12.x and 5.10.x looks to
+ # be to fake up a dummy CVf_LOCKED that will never actually be true.
+ *CVf_LOCKED = sub () {0} unless defined &CVf_LOCKED;
+}
+
+# Changes between 0.50 and 0.51:
+# - fixed nulled leave with live enter in sort { }
+# - fixed reference constants (\"str")
+# - handle empty programs gracefully
+# - handle infinte loops (for (;;) {}, while (1) {})
+# - differentiate between `for my $x ...' and `my $x; for $x ...'
+# - various minor cleanups
+# - moved globals into an object
+# - added `-u', like B::C
+# - package declarations using cop_stash
+# - subs, formats and code sorted by cop_seq
+# Changes between 0.51 and 0.52:
+# - added pp_threadsv (special variables under USE_5005THREADS)
+# - added documentation
+# Changes between 0.52 and 0.53:
+# - many changes adding precedence contexts and associativity
+# - added `-p' and `-s' output style options
+# - various other minor fixes
+# Changes between 0.53 and 0.54:
+# - added support for new `for (1..100)' optimization,
+# thanks to Gisle Aas
+# Changes between 0.54 and 0.55:
+# - added support for new qr// construct
+# - added support for new pp_regcreset OP
+# Changes between 0.55 and 0.56:
+# - tested on base/*.t, cmd/*.t, comp/*.t, io/*.t
+# - fixed $# on non-lexicals broken in last big rewrite
+# - added temporary fix for change in opcode of OP_STRINGIFY
+# - fixed problem in 0.54's for() patch in `for (@ary)'
+# - fixed precedence in conditional of ?:
+# - tweaked list paren elimination in `my($x) = @_'
+# - made continue-block detection trickier wrt. null ops
+# - fixed various prototype problems in pp_entersub
+# - added support for sub prototypes that never get GVs
+# - added unquoting for special filehandle first arg in truncate
+# - print doubled rv2gv (a bug) as `*{*GV}' instead of illegal `**GV'
+# - added semicolons at the ends of blocks
+# - added -l `#line' declaration option -- fixes cmd/subval.t 27,28
+# Changes between 0.56 and 0.561:
+# - fixed multiply-declared my var in pp_truncate (thanks to Sarathy)
+# - used new B.pm symbolic constants (done by Nick Ing-Simmons)
+# Changes between 0.561 and 0.57:
+# - stylistic changes to symbolic constant stuff
+# - handled scope in s///e replacement code
+# - added unquote option for expanding "" into concats, etc.
+# - split method and proto parts of pp_entersub into separate functions
+# - various minor cleanups
+# Changes after 0.57:
+# - added parens in \&foo (patch by Albert Dvornik)
+# Changes between 0.57 and 0.58:
+# - fixed `0' statements that weren't being printed
+# - added methods for use from other programs
+# (based on patches from James Duncan and Hugo van der Sanden)
+# - added -si and -sT to control indenting (also based on a patch from Hugo)
+# - added -sv to print something else instead of '???'
+# - preliminary version of utf8 tr/// handling
+# Changes after 0.58:
+# - uses of $op->ppaddr changed to new $op->name (done by Sarathy)
+# - added support for Hugo's new OP_SETSTATE (like nextstate)
+# Changes between 0.58 and 0.59
+# - added support for Chip's OP_METHOD_NAMED
+# - added support for Ilya's OPpTARGET_MY optimization
+# - elided arrows before `()' subscripts when possible
+# Changes between 0.59 and 0.60
+# - support for method attribues was added
+# - some warnings fixed
+# - separate recognition of constant subs
+# - rewrote continue block handling, now recoginizing for loops
+# - added more control of expanding control structures
+# Changes between 0.60 and 0.61 (mostly by Robin Houston)
+# - many bug-fixes
+# - support for pragmas and 'use'
+# - support for the little-used $[ variable
+# - support for __DATA__ sections
+# - UTF8 support
+# - BEGIN, CHECK, INIT and END blocks
+# - scoping of subroutine declarations fixed
+# - compile-time output from the input program can be suppressed, so that the
+# output is just the deparsed code. (a change to O.pm in fact)
+# - our() declarations
+# - *all* the known bugs are now listed in the BUGS section
+# - comprehensive test mechanism (TEST -deparse)
+# Changes between 0.62 and 0.63 (mostly by Rafael Garcia-Suarez)
+# - bug-fixes
+# - new switch -P
+# - support for command-line switches (-l, -0, etc.)
+# Changes between 0.63 and 0.64
+# - support for //, CHECK blocks, and assertions
+# - improved handling of foreach loops and lexicals
+# - option to use Data::Dumper for constants
+# - more bug fixes
+# - discovered lots more bugs not yet fixed
+#
+# ...
+#
+# Changes between 0.72 and 0.73
+# - support new switch constructs
+
+# Todo:
+# (See also BUGS section at the end of this file)
+#
+# - finish tr/// changes
+# - add option for even more parens (generalize \&foo change)
+# - left/right context
+# - copy comments (look at real text with $^P?)
+# - avoid semis in one-statement blocks
+# - associativity of &&=, ||=, ?:
+# - ',' => '=>' (auto-unquote?)
+# - break long lines ("\r" as discretionary break?)
+# - configurable syntax highlighting: ANSI color, HTML, TeX, etc.
+# - more style options: brace style, hex vs. octal, quotes, ...
+# - print big ints as hex/octal instead of decimal (heuristic?)
+# - handle `my $x if 0'?
+# - version using op_next instead of op_first/sibling?
+# - avoid string copies (pass arrays, one big join?)
+# - here-docs?
+
+# Current test.deparse failures
+# comp/hints 6 - location of BEGIN blocks wrt. block openings
+# run/switchI 1 - missing -I switches entirely
+# perl -Ifoo -e 'print @INC'
+# op/caller 2 - warning mask propagates backwards before warnings::register
+# 'use warnings; BEGIN {${^WARNING_BITS} eq "U"x12;} use warnings::register'
+# op/getpid 2 - can't assign to shared my() declaration (threads only)
+# 'my $x : shared = 5'
+# op/override 7 - parens on overriden require change v-string interpretation
+# 'BEGIN{*CORE::GLOBAL::require=sub {}} require v5.6'
+# c.f. 'BEGIN { *f = sub {0} }; f 2'
+# op/pat 774 - losing Unicode-ness of Latin1-only strings
+# 'use charnames ":short"; $x="\N{latin:a with acute}"'
+# op/recurse 12 - missing parens on recursive call makes it look like method
+# 'sub f { f($x) }'
+# op/subst 90 - inconsistent handling of utf8 under "use utf8"
+# op/taint 29 - "use re 'taint'" deparsed in the wrong place wrt. block open
+# op/tiehandle compile - "use strict" deparsed in the wrong place
+# uni/tr_ several
+# ext/B/t/xref 11 - line numbers when we add newlines to one-line subs
+# ext/Data/Dumper/t/dumper compile
+# ext/DB_file/several
+# ext/Encode/several
+# ext/Ernno/Errno warnings
+# ext/IO/lib/IO/t/io_sel 23
+# ext/PerlIO/t/encoding compile
+# ext/POSIX/t/posix 6
+# ext/Socket/Socket 8
+# ext/Storable/t/croak compile
+# lib/Attribute/Handlers/t/multi compile
+# lib/bignum/ several
+# lib/charnames 35
+# lib/constant 32
+# lib/English 40
+# lib/ExtUtils/t/bytes 4
+# lib/File/DosGlob compile
+# lib/Filter/Simple/t/data 1
+# lib/Math/BigInt/t/constant 1
+# lib/Net/t/config Deparse-warning
+# lib/overload compile
+# lib/Switch/ several
+# lib/Symbol 4
+# lib/Test/Simple several
+# lib/Term/Complete
+# lib/Tie/File/t/29_downcopy 5
+# lib/vars 22
+
+# Object fields (were globals):
+#
+# avoid_local:
+# (local($a), local($b)) and local($a, $b) have the same internal
+# representation but the short form looks better. We notice we can
+# use a large-scale local when checking the list, but need to prevent
+# individual locals too. This hash holds the addresses of OPs that
+# have already had their local-ness accounted for. The same thing
+# is done with my().
+#
+# curcv:
+# CV for current sub (or main program) being deparsed
+#
+# curcvlex:
+# Cached hash of lexical variables for curcv: keys are names,
+# each value is an array of pairs, indicating the cop_seq of scopes
+# in which a var of that name is valid.
+#
+# curcop:
+# COP for statement being deparsed
+#
+# curstash:
+# name of the current package for deparsed code
+#
+# subs_todo:
+# array of [cop_seq, CV, is_format?] for subs and formats we still
+# want to deparse
+#
+# protos_todo:
+# as above, but [name, prototype] for subs that never got a GV
+#
+# subs_done, forms_done:
+# keys are addresses of GVs for subs and formats we've already
+# deparsed (or at least put into subs_todo)
+#
+# subs_declared
+# keys are names of subs for which we've printed declarations.
+# That means we can omit parentheses from the arguments.
+#
+# subs_deparsed
+# Keeps track of fully qualified names of all deparsed subs.
+#
+# parens: -p
+# linenums: -l
+# unquote: -q
+# cuddle: ` ' or `\n', depending on -sC
+# indent_size: -si
+# use_tabs: -sT
+# ex_const: -sv
+
+# A little explanation of how precedence contexts and associativity
+# work:
+#
+# deparse() calls each per-op subroutine with an argument $cx (short
+# for context, but not the same as the cx* in the perl core), which is
+# a number describing the op's parents in terms of precedence, whether
+# they're inside an expression or at statement level, etc. (see
+# chart below). When ops with children call deparse on them, they pass
+# along their precedence. Fractional values are used to implement
+# associativity (`($x + $y) + $z' => `$x + $y + $y') and related
+# parentheses hacks. The major disadvantage of this scheme is that
+# it doesn't know about right sides and left sides, so say if you
+# assign a listop to a variable, it can't tell it's allowed to leave
+# the parens off the listop.
+
+# Precedences:
+# 26 [TODO] inside interpolation context ("")
+# 25 left terms and list operators (leftward)
+# 24 left ->
+# 23 nonassoc ++ --
+# 22 right **
+# 21 right ! ~ \ and unary + and -
+# 20 left =~ !~
+# 19 left * / % x
+# 18 left + - .
+# 17 left << >>
+# 16 nonassoc named unary operators
+# 15 nonassoc < > <= >= lt gt le ge
+# 14 nonassoc == != <=> eq ne cmp
+# 13 left &
+# 12 left | ^
+# 11 left &&
+# 10 left ||
+# 9 nonassoc .. ...
+# 8 right ?:
+# 7 right = += -= *= etc.
+# 6 left , =>
+# 5 nonassoc list operators (rightward)
+# 4 right not
+# 3 left and
+# 2 left or xor
+# 1 statement modifiers
+# 0.5 statements, but still print scopes as do { ... }
+# 0 statement level
+
+# Nonprinting characters with special meaning:
+# \cS - steal parens (see maybe_parens_unop)
+# \n - newline and indent
+# \t - increase indent
+# \b - decrease indent (`outdent')
+# \f - flush left (no indent)
+# \cK - kill following semicolon, if any
+
+sub null {
+ my $op = shift;
+ return class($op) eq "NULL";
+}
+
+sub todo {
+ my $self = shift;
+ my($cv, $is_form) = @_;
+ return unless ($cv->FILE eq $0 || exists $self->{files}{$cv->FILE});
+ my $seq;
+ if ($cv->OUTSIDE_SEQ) {
+ $seq = $cv->OUTSIDE_SEQ;
+ } elsif (!null($cv->START) and is_state($cv->START)) {
+ $seq = $cv->START->cop_seq;
+ } else {
+ $seq = 0;
+ }
+ push @{$self->{'subs_todo'}}, [$seq, $cv, $is_form];
+ unless ($is_form || class($cv->STASH) eq 'SPECIAL') {
+ $self->{'subs_deparsed'}{$cv->STASH->NAME."::".$cv->GV->NAME} = 1;
+ }
+}
+
+sub next_todo {
+ my $self = shift;
+ my $ent = shift @{$self->{'subs_todo'}};
+ my $cv = $ent->[1];
+ my $gv = $cv->GV;
+ my $name = $self->gv_name($gv);
+ if ($ent->[2]) {
+ return "format $name =\n"
+ . $self->deparse_format($ent->[1]). "\n";
+ } else {
+ $self->{'subs_declared'}{$name} = 1;
+ if ($name eq "BEGIN") {
+ my $use_dec = $self->begin_is_use($cv);
+ if (defined ($use_dec) and $self->{'expand'} < 5) {
+ return () if 0 == length($use_dec);
+ return $use_dec;
+ }
+ }
+ my $l = '';
+ if ($self->{'linenums'}) {
+ my $line = $gv->LINE;
+ my $file = $gv->FILE;
+ $l = "\n\f#line $line \"$file\"\n";
+ }
+ my $p = '';
+ if (class($cv->STASH) ne "SPECIAL") {
+ my $stash = $cv->STASH->NAME;
+ if ($stash ne $self->{'curstash'}) {
+ $p = "package $stash;\n";
+ $name = "$self->{'curstash'}::$name" unless $name =~ /::/;
+ $self->{'curstash'} = $stash;
+ }
+ $name =~ s/^\Q$stash\E::(?!\z|.*::)//;
+ }
+ return "${p}${l}sub $name " . $self->deparse_sub($cv);
+ }
+}
+
+# Return a "use" declaration for this BEGIN block, if appropriate
+sub begin_is_use {
+ my ($self, $cv) = @_;
+ my $root = $cv->ROOT;
+ local @$self{qw'curcv curcvlex'} = ($cv);
+#require B::Debug;
+#B::walkoptree($cv->ROOT, "debug");
+ my $lineseq = $root->first;
+ return if $lineseq->name ne "lineseq";
+
+ my $req_op = $lineseq->first->sibling;
+ return if $req_op->name ne "require";
+
+ my $module;
+ if ($req_op->first->private & OPpCONST_BARE) {
+ # Actually it should always be a bareword
+ $module = $self->const_sv($req_op->first)->PV;
+ $module =~ s[/][::]g;
+ $module =~ s/.pm$//;
+ }
+ else {
+ $module = $self->const($self->const_sv($req_op->first), 6);
+ }
+
+ my $version;
+ my $version_op = $req_op->sibling;
+ return if class($version_op) eq "NULL";
+ if ($version_op->name eq "lineseq") {
+ # We have a version parameter; skip nextstate & pushmark
+ my $constop = $version_op->first->next->next;
+
+ return unless $self->const_sv($constop)->PV eq $module;
+ $constop = $constop->sibling;
+ $version = $self->const_sv($constop);
+ if (class($version) eq "IV") {
+ $version = $version->int_value;
+ } elsif (class($version) eq "NV") {
+ $version = $version->NV;
+ } elsif (class($version) ne "PVMG") {
+ # Includes PVIV and PVNV
+ $version = $version->PV;
+ } else {
+ # version specified as a v-string
+ $version = 'v'.join '.', map ord, split //, $version->PV;
+ }
+ $constop = $constop->sibling;
+ return if $constop->name ne "method_named";
+ return if $self->const_sv($constop)->PV ne "VERSION";
+ }
+
+ $lineseq = $version_op->sibling;
+ return if $lineseq->name ne "lineseq";
+ my $entersub = $lineseq->first->sibling;
+ if ($entersub->name eq "stub") {
+ return "use $module $version ();\n" if defined $version;
+ return "use $module ();\n";
+ }
+ return if $entersub->name ne "entersub";
+
+ # See if there are import arguments
+ my $args = '';
+
+ my $svop = $entersub->first->sibling; # Skip over pushmark
+ return unless $self->const_sv($svop)->PV eq $module;
+
+ # Pull out the arguments
+ for ($svop=$svop->sibling; $svop->name ne "method_named";
+ $svop = $svop->sibling) {
+ $args .= ", " if length($args);
+ $args .= $self->deparse($svop, 6);
+ }
+
+ my $use = 'use';
+ my $method_named = $svop;
+ return if $method_named->name ne "method_named";
+ my $method_name = $self->const_sv($method_named)->PV;
+
+ if ($method_name eq "unimport") {
+ $use = 'no';
+ }
+
+ # Certain pragmas are dealt with using hint bits,
+ # so we ignore them here
+ if ($module eq 'strict' || $module eq 'integer'
+ || $module eq 'bytes' || $module eq 'warnings'
+ || $module eq 'feature') {
+ return "";
+ }
+
+ if (defined $version && length $args) {
+ return "$use $module $version ($args);\n";
+ } elsif (defined $version) {
+ return "$use $module $version;\n";
+ } elsif (length $args) {
+ return "$use $module ($args);\n";
+ } else {
+ return "$use $module;\n";
+ }
+}
+
+sub stash_subs {
+ my ($self, $pack) = @_;
+ my (@ret, $stash);
+ if (!defined $pack) {
+ $pack = '';
+ $stash = \%::;
+ }
+ else {
+ $pack =~ s/(::)?$/::/;
+ no strict 'refs';
+ $stash = \%$pack;
+ }
+ my %stash = svref_2object($stash)->ARRAY;
+ while (my ($key, $val) = each %stash) {
+ my $class = class($val);
+ if ($class eq "PV") {
+ # Just a prototype. As an ugly but fairly effective way
+ # to find out if it belongs here is to see if the AUTOLOAD
+ # (if any) for the stash was defined in one of our files.
+ my $A = $stash{"AUTOLOAD"};
+ if (defined ($A) && class($A) eq "GV" && defined($A->CV)
+ && class($A->CV) eq "CV") {
+ my $AF = $A->FILE;
+ next unless $AF eq $0 || exists $self->{'files'}{$AF};
+ }
+ push @{$self->{'protos_todo'}}, [$pack . $key, $val->PV];
+ } elsif ($class eq "IV") {
+ # Just a name. As above.
+ my $A = $stash{"AUTOLOAD"};
+ if (defined ($A) && class($A) eq "GV" && defined($A->CV)
+ && class($A->CV) eq "CV") {
+ my $AF = $A->FILE;
+ next unless $AF eq $0 || exists $self->{'files'}{$AF};
+ }
+ push @{$self->{'protos_todo'}}, [$pack . $key, undef];
+ } elsif ($class eq "GV") {
+ if (class(my $cv = $val->CV) ne "SPECIAL") {
+ next if $self->{'subs_done'}{$$val}++;
+ next if $$val != ${$cv->GV}; # Ignore imposters
+ $self->todo($cv, 0);
+ }
+ if (class(my $cv = $val->FORM) ne "SPECIAL") {
+ next if $self->{'forms_done'}{$$val}++;
+ next if $$val != ${$cv->GV}; # Ignore imposters
+ $self->todo($cv, 1);
+ }
+ if (class($val->HV) ne "SPECIAL" && $key =~ /::$/) {
+ $self->stash_subs($pack . $key)
+ unless $pack eq '' && $key eq 'main::';
+ # avoid infinite recursion
+ }
+ }
+ }
+}
+
+sub print_protos {
+ my $self = shift;
+ my $ar;
+ my @ret;
+ foreach $ar (@{$self->{'protos_todo'}}) {
+ my $proto = (defined $ar->[1] ? " (". $ar->[1] . ")" : "");
+ push @ret, "sub " . $ar->[0] . "$proto;\n";
+ }
+ delete $self->{'protos_todo'};
+ return @ret;
+}
+
+sub style_opts {
+ my $self = shift;
+ my $opts = shift;
+ my $opt;
+ while (length($opt = substr($opts, 0, 1))) {
+ if ($opt eq "C") {
+ $self->{'cuddle'} = " ";
+ $opts = substr($opts, 1);
+ } elsif ($opt eq "i") {
+ $opts =~ s/^i(\d+)//;
+ $self->{'indent_size'} = $1;
+ } elsif ($opt eq "T") {
+ $self->{'use_tabs'} = 1;
+ $opts = substr($opts, 1);
+ } elsif ($opt eq "v") {
+ $opts =~ s/^v([^.]*)(.|$)//;
+ $self->{'ex_const'} = $1;
+ }
+ }
+}
+
+sub new {
+ my $class = shift;
+ my $self = bless {}, $class;
+ $self->{'cuddle'} = "\n";
+ $self->{'curcop'} = undef;
+ $self->{'curstash'} = "main";
+ $self->{'ex_const'} = "'???'";
+ $self->{'expand'} = 0;
+ $self->{'files'} = {};
+ $self->{'indent_size'} = 4;
+ $self->{'linenums'} = 0;
+ $self->{'parens'} = 0;
+ $self->{'subs_todo'} = [];
+ $self->{'unquote'} = 0;
+ $self->{'use_dumper'} = 0;
+ $self->{'use_tabs'} = 0;
+
+ $self->{'ambient_arybase'} = 0;
+ $self->{'ambient_warnings'} = undef; # Assume no lexical warnings
+ $self->{'ambient_hints'} = 0;
+ $self->{'ambient_hinthash'} = undef;
+ $self->init();
+
+ while (my $arg = shift @_) {
+ if ($arg eq "-d") {
+ $self->{'use_dumper'} = 1;
+ require Data::Dumper;
+ } elsif ($arg =~ /^-f(.*)/) {
+ $self->{'files'}{$1} = 1;
+ } elsif ($arg eq "-l") {
+ $self->{'linenums'} = 1;
+ } elsif ($arg eq "-p") {
+ $self->{'parens'} = 1;
+ } elsif ($arg eq "-P") {
+ $self->{'noproto'} = 1;
+ } elsif ($arg eq "-q") {
+ $self->{'unquote'} = 1;
+ } elsif (substr($arg, 0, 2) eq "-s") {
+ $self->style_opts(substr $arg, 2);
+ } elsif ($arg =~ /^-x(\d)$/) {
+ $self->{'expand'} = $1;
+ }
+ }
+ return $self;
+}
+
+{
+ # Mask out the bits that L<warnings::register> uses
+ my $WARN_MASK;
+ BEGIN {
+ $WARN_MASK = $warnings::Bits{all} | $warnings::DeadBits{all};
+ }
+ sub WARN_MASK () {
+ return $WARN_MASK;
+ }
+}
+
+# Initialise the contextual information, either from
+# defaults provided with the ambient_pragmas method,
+# or from perl's own defaults otherwise.
+sub init {
+ my $self = shift;
+
+ $self->{'arybase'} = $self->{'ambient_arybase'};
+ $self->{'warnings'} = defined ($self->{'ambient_warnings'})
+ ? $self->{'ambient_warnings'} & WARN_MASK
+ : undef;
+ $self->{'hints'} = $self->{'ambient_hints'};
+ $self->{'hints'} &= 0xFF if $] < 5.009;
+ $self->{'hinthash'} = $self->{'ambient_hinthash'};
+
+ # also a convenient place to clear out subs_declared
+ delete $self->{'subs_declared'};
+}
+
+sub compile {
+ my(@args) = @_;
+ return sub {
+ my $self = B::Deparse->new(@args);
+ # First deparse command-line args
+ if (defined $^I) { # deparse -i
+ print q(BEGIN { $^I = ).perlstring($^I).qq(; }\n);
+ }
+ if ($^W) { # deparse -w
+ print qq(BEGIN { \$^W = $^W; }\n);
+ }
+ if ($/ ne "\n" or defined $O::savebackslash) { # deparse -l and -0
+ my $fs = perlstring($/) || 'undef';
+ my $bs = perlstring($O::savebackslash) || 'undef';
+ print qq(BEGIN { \$/ = $fs; \$\\ = $bs; }\n);
+ }
+ my @BEGINs = B::begin_av->isa("B::AV") ? B::begin_av->ARRAY : ();
+ my @UNITCHECKs = B::unitcheck_av->isa("B::AV")
+ ? B::unitcheck_av->ARRAY
+ : ();
+ my @CHECKs = B::check_av->isa("B::AV") ? B::check_av->ARRAY : ();
+ my @INITs = B::init_av->isa("B::AV") ? B::init_av->ARRAY : ();
+ my @ENDs = B::end_av->isa("B::AV") ? B::end_av->ARRAY : ();
+ for my $block (@BEGINs, @UNITCHECKs, @CHECKs, @INITs, @ENDs) {
+ $self->todo($block, 0);
+ }
+ $self->stash_subs();
+ local($SIG{"__DIE__"}) =
+ sub {
+ if ($self->{'curcop'}) {
+ my $cop = $self->{'curcop'};
+ my($line, $file) = ($cop->line, $cop->file);
+ print STDERR "While deparsing $file near line $line,\n";
+ }
+ };
+ $self->{'curcv'} = main_cv;
+ $self->{'curcvlex'} = undef;
+ print $self->print_protos;
+ @{$self->{'subs_todo'}} =
+ sort {$a->[0] <=> $b->[0]} @{$self->{'subs_todo'}};
+ print $self->indent($self->deparse_root(main_root)), "\n"
+ unless null main_root;
+ my @text;
+ while (scalar(@{$self->{'subs_todo'}})) {
+ push @text, $self->next_todo;
+ }
+ print $self->indent(join("", @text)), "\n" if @text;
+
+ # Print __DATA__ section, if necessary
+ no strict 'refs';
+ my $laststash = defined $self->{'curcop'}
+ ? $self->{'curcop'}->stash->NAME : $self->{'curstash'};
+ if (defined *{$laststash."::DATA"}{IO}) {
+ print "package $laststash;\n"
+ unless $laststash eq $self->{'curstash'};
+ print "__DATA__\n";
+ print readline(*{$laststash."::DATA"});
+ }
+ }
+}
+
+sub coderef2text {
+ my $self = shift;
+ my $sub = shift;
+ croak "Usage: ->coderef2text(CODEREF)" unless UNIVERSAL::isa($sub, "CODE");
+
+ $self->init();
+ return $self->indent($self->deparse_sub(svref_2object($sub)));
+}
+
+sub ambient_pragmas {
+ my $self = shift;
+ my ($arybase, $hint_bits, $warning_bits, $hinthash) = (0, 0);
+
+ while (@_ > 1) {
+ my $name = shift();
+ my $val = shift();
+
+ if ($name eq 'strict') {
+ require strict;
+
+ if ($val eq 'none') {
+ $hint_bits &= ~strict::bits(qw/refs subs vars/);
+ next();
+ }
+
+ my @names;
+ if ($val eq "all") {
+ @names = qw/refs subs vars/;
+ }
+ elsif (ref $val) {
+ @names = @$val;
+ }
+ else {
+ @names = split' ', $val;
+ }
+ $hint_bits |= strict::bits(@names);
+ }
+
+ elsif ($name eq '$[') {
+ $arybase = $val;
+ }
+
+ elsif ($name eq 'integer'
+ || $name eq 'bytes'
+ || $name eq 'utf8') {
+ require "$name.pm";
+ if ($val) {
+ $hint_bits |= ${$::{"${name}::"}{"hint_bits"}};
+ }
+ else {
+ $hint_bits &= ~${$::{"${name}::"}{"hint_bits"}};
+ }
+ }
+
+ elsif ($name eq 're') {
+ require re;
+ if ($val eq 'none') {
+ $hint_bits &= ~re::bits(qw/taint eval/);
+ next();
+ }
+
+ my @names;
+ if ($val eq 'all') {
+ @names = qw/taint eval/;
+ }
+ elsif (ref $val) {
+ @names = @$val;
+ }
+ else {
+ @names = split' ',$val;
+ }
+ $hint_bits |= re::bits(@names);
+ }
+
+ elsif ($name eq 'warnings') {
+ if ($val eq 'none') {
+ $warning_bits = $warnings::NONE;
+ next();
+ }
+
+ my @names;
+ if (ref $val) {
+ @names = @$val;
+ }
+ else {
+ @names = split/\s+/, $val;
+ }
+
+ $warning_bits = $warnings::NONE if !defined ($warning_bits);
+ $warning_bits |= warnings::bits(@names);
+ }
+
+ elsif ($name eq 'warning_bits') {
+ $warning_bits = $val;
+ }
+
+ elsif ($name eq 'hint_bits') {
+ $hint_bits = $val;
+ }
+
+ elsif ($name eq '%^H') {
+ $hinthash = $val;
+ }
+
+ else {
+ croak "Unknown pragma type: $name";
+ }
+ }
+ if (@_) {
+ croak "The ambient_pragmas method expects an even number of args";
+ }
+
+ $self->{'ambient_arybase'} = $arybase;
+ $self->{'ambient_warnings'} = $warning_bits;
+ $self->{'ambient_hints'} = $hint_bits;
+ $self->{'ambient_hinthash'} = $hinthash;
+}
+
+# This method is the inner loop, so try to keep it simple
+sub deparse {
+ my $self = shift;
+ my($op, $cx) = @_;
+
+ Carp::confess("Null op in deparse") if !defined($op)
+ || class($op) eq "NULL";
+ my $meth = "pp_" . $op->name;
+ return $self->$meth($op, $cx);
+}
+
+sub indent {
+ my $self = shift;
+ my $txt = shift;
+ my @lines = split(/\n/, $txt);
+ my $leader = "";
+ my $level = 0;
+ my $line;
+ for $line (@lines) {
+ my $cmd = substr($line, 0, 1);
+ if ($cmd eq "\t" or $cmd eq "\b") {
+ $level += ($cmd eq "\t" ? 1 : -1) * $self->{'indent_size'};
+ if ($self->{'use_tabs'}) {
+ $leader = "\t" x ($level / 8) . " " x ($level % 8);
+ } else {
+ $leader = " " x $level;
+ }
+ $line = substr($line, 1);
+ }
+ if (substr($line, 0, 1) eq "\f") {
+ $line = substr($line, 1); # no indent
+ } else {
+ $line = $leader . $line;
+ }
+ $line =~ s/\cK;?//g;
+ }
+ return join("\n", @lines);
+}
+
+sub deparse_sub {
+ my $self = shift;
+ my $cv = shift;
+ my $proto = "";
+Carp::confess("NULL in deparse_sub") if !defined($cv) || $cv->isa("B::NULL");
+Carp::confess("SPECIAL in deparse_sub") if $cv->isa("B::SPECIAL");
+ local $self->{'curcop'} = $self->{'curcop'};
+ if ($cv->FLAGS & SVf_POK) {
+ $proto = "(". $cv->PV . ") ";
+ }
+ if ($cv->CvFLAGS & (CVf_METHOD|CVf_LOCKED|CVf_LVALUE)) {
+ $proto .= ": ";
+ $proto .= "lvalue " if $cv->CvFLAGS & CVf_LVALUE;
+ $proto .= "locked " if $cv->CvFLAGS & CVf_LOCKED;
+ $proto .= "method " if $cv->CvFLAGS & CVf_METHOD;
+ }
+
+ local($self->{'curcv'}) = $cv;
+ local($self->{'curcvlex'});
+ local(@$self{qw'curstash warnings hints hinthash'})
+ = @$self{qw'curstash warnings hints hinthash'};
+ my $body;
+ if (not null $cv->ROOT) {
+ my $lineseq = $cv->ROOT->first;
+ if ($lineseq->name eq "lineseq") {
+ my @ops;
+ for(my$o=$lineseq->first; $$o; $o=$o->sibling) {
+ push @ops, $o;
+ }
+ $body = $self->lineseq(undef, @ops).";";
+ my $scope_en = $self->find_scope_en($lineseq);
+ if (defined $scope_en) {
+ my $subs = join"", $self->seq_subs($scope_en);
+ $body .= ";\n$subs" if length($subs);
+ }
+ }
+ else {
+ $body = $self->deparse($cv->ROOT->first, 0);
+ }
+ }
+ else {
+ my $sv = $cv->const_sv;
+ if ($$sv) {
+ # uh-oh. inlinable sub... format it differently
+ return $proto . "{ " . $self->const($sv, 0) . " }\n";
+ } else { # XSUB? (or just a declaration)
+ return "$proto;\n";
+ }
+ }
+ return $proto ."{\n\t$body\n\b}" ."\n";
+}
+
+sub deparse_format {
+ my $self = shift;
+ my $form = shift;
+ my @text;
+ local($self->{'curcv'}) = $form;
+ local($self->{'curcvlex'});
+ local($self->{'in_format'}) = 1;
+ local(@$self{qw'curstash warnings hints hinthash'})
+ = @$self{qw'curstash warnings hints hinthash'};
+ my $op = $form->ROOT;
+ my $kid;
+ return "\f." if $op->first->name eq 'stub'
+ || $op->first->name eq 'nextstate';
+ $op = $op->first->first; # skip leavewrite, lineseq
+ while (not null $op) {
+ $op = $op->sibling; # skip nextstate
+ my @exprs;
+ $kid = $op->first->sibling; # skip pushmark
+ push @text, "\f".$self->const_sv($kid)->PV;
+ $kid = $kid->sibling;
+ for (; not null $kid; $kid = $kid->sibling) {
+ push @exprs, $self->deparse($kid, 0);
+ }
+ push @text, "\f".join(", ", @exprs)."\n" if @exprs;
+ $op = $op->sibling;
+ }
+ return join("", @text) . "\f.";
+}
+
+sub is_scope {
+ my $op = shift;
+ return $op->name eq "leave" || $op->name eq "scope"
+ || $op->name eq "lineseq"
+ || ($op->name eq "null" && class($op) eq "UNOP"
+ && (is_scope($op->first) || $op->first->name eq "enter"));
+}
+
+sub is_state {
+ my $name = $_[0]->name;
+ return $name eq "nextstate" || $name eq "dbstate" || $name eq "setstate";
+}
+
+sub is_miniwhile { # check for one-line loop (`foo() while $y--')
+ my $op = shift;
+ return (!null($op) and null($op->sibling)
+ and $op->name eq "null" and class($op) eq "UNOP"
+ and (($op->first->name =~ /^(and|or)$/
+ and $op->first->first->sibling->name eq "lineseq")
+ or ($op->first->name eq "lineseq"
+ and not null $op->first->first->sibling
+ and $op->first->first->sibling->name eq "unstack")
+ ));
+}
+
+# Check if the op and its sibling are the initialization and the rest of a
+# for (..;..;..) { ... } loop
+sub is_for_loop {
+ my $op = shift;
+ # This OP might be almost anything, though it won't be a
+ # nextstate. (It's the initialization, so in the canonical case it
+ # will be an sassign.) The sibling is a lineseq whose first child
+ # is a nextstate and whose second is a leaveloop.
+ my $lseq = $op->sibling;
+ if (!is_state $op and !null($lseq) and $lseq->name eq "lineseq") {
+ if ($lseq->first && !null($lseq->first) && is_state($lseq->first)
+ && (my $sib = $lseq->first->sibling)) {
+ return (!null($sib) && $sib->name eq "leaveloop");
+ }
+ }
+ return 0;
+}
+
+sub is_scalar {
+ my $op = shift;
+ return ($op->name eq "rv2sv" or
+ $op->name eq "padsv" or
+ $op->name eq "gv" or # only in array/hash constructs
+ $op->flags & OPf_KIDS && !null($op->first)
+ && $op->first->name eq "gvsv");
+}
+
+sub maybe_parens {
+ my $self = shift;
+ my($text, $cx, $prec) = @_;
+ if ($prec < $cx # unary ops nest just fine
+ or $prec == $cx and $cx != 4 and $cx != 16 and $cx != 21
+ or $self->{'parens'})
+ {
+ $text = "($text)";
+ # In a unop, let parent reuse our parens; see maybe_parens_unop
+ $text = "\cS" . $text if $cx == 16;
+ return $text;
+ } else {
+ return $text;
+ }
+}
+
+# same as above, but get around the `if it looks like a function' rule
+sub maybe_parens_unop {
+ my $self = shift;
+ my($name, $kid, $cx) = @_;
+ if ($cx > 16 or $self->{'parens'}) {
+ $kid = $self->deparse($kid, 1);
+ if ($name eq "umask" && $kid =~ /^\d+$/) {
+ $kid = sprintf("%#o", $kid);
+ }
+ return "$name($kid)";
+ } else {
+ $kid = $self->deparse($kid, 16);
+ if ($name eq "umask" && $kid =~ /^\d+$/) {
+ $kid = sprintf("%#o", $kid);
+ }
+ if (substr($kid, 0, 1) eq "\cS") {
+ # use kid's parens
+ return $name . substr($kid, 1);
+ } elsif (substr($kid, 0, 1) eq "(") {
+ # avoid looks-like-a-function trap with extra parens
+ # (`+' can lead to ambiguities)
+ return "$name(" . $kid . ")";
+ } else {
+ return "$name $kid";
+ }
+ }
+}
+
+sub maybe_parens_func {
+ my $self = shift;
+ my($func, $text, $cx, $prec) = @_;
+ if ($prec <= $cx or substr($text, 0, 1) eq "(" or $self->{'parens'}) {
+ return "$func($text)";
+ } else {
+ return "$func $text";
+ }
+}
+
+sub maybe_local {
+ my $self = shift;
+ my($op, $cx, $text) = @_;
+ my $our_intro = ($op->name =~ /^(gv|rv2)[ash]v$/) ? OPpOUR_INTRO : 0;
+ if ($op->private & (OPpLVAL_INTRO|$our_intro)
+ and not $self->{'avoid_local'}{$$op}) {
+ my $our_local = ($op->private & OPpLVAL_INTRO) ? "local" : "our";
+ if( $our_local eq 'our' ) {
+ # XXX This assertion fails code with non-ASCII identifiers,
+ # like ./ext/Encode/t/jperl.t
+ die "Unexpected our($text)\n" unless $text =~ /^\W(\w+::)*\w+\z/;
+ $text =~ s/(\w+::)+//;
+ }
+ if (want_scalar($op)) {
+ return "$our_local $text";
+ } else {
+ return $self->maybe_parens_func("$our_local", $text, $cx, 16);
+ }
+ } else {
+ return $text;
+ }
+}
+
+sub maybe_targmy {
+ my $self = shift;
+ my($op, $cx, $func, @args) = @_;
+ if ($op->private & OPpTARGET_MY) {
+ my $var = $self->padname($op->targ);
+ my $val = $func->($self, $op, 7, @args);
+ return $self->maybe_parens("$var = $val", $cx, 7);
+ } else {
+ return $func->($self, $op, $cx, @args);
+ }
+}
+
+sub padname_sv {
+ my $self = shift;
+ my $targ = shift;
+ return $self->{'curcv'}->PADLIST->ARRAYelt(0)->ARRAYelt($targ);
+}
+
+sub maybe_my {
+ my $self = shift;
+ my($op, $cx, $text) = @_;
+ if ($op->private & OPpLVAL_INTRO and not $self->{'avoid_local'}{$$op}) {
+ my $my = $op->private & OPpPAD_STATE ? "state" : "my";
+ if (want_scalar($op)) {
+ return "$my $text";
+ } else {
+ return $self->maybe_parens_func($my, $text, $cx, 16);
+ }
+ } else {
+ return $text;
+ }
+}
+
+# The following OPs don't have functions:
+
+# pp_padany -- does not exist after parsing
+
+sub AUTOLOAD {
+ if ($AUTOLOAD =~ s/^.*::pp_//) {
+ warn "unexpected OP_".uc $AUTOLOAD;
+ return "XXX";
+ } else {
+ die "Undefined subroutine $AUTOLOAD called";
+ }
+}
+
+sub DESTROY {} # Do not AUTOLOAD
+
+# $root should be the op which represents the root of whatever
+# we're sequencing here. If it's undefined, then we don't append
+# any subroutine declarations to the deparsed ops, otherwise we
+# append appropriate declarations.
+sub lineseq {
+ my($self, $root, @ops) = @_;
+ my($expr, @exprs);
+
+ my $out_cop = $self->{'curcop'};
+ my $out_seq = defined($out_cop) ? $out_cop->cop_seq : undef;
+ my $limit_seq;
+ if (defined $root) {
+ $limit_seq = $out_seq;
+ my $nseq;
+ $nseq = $self->find_scope_st($root->sibling) if ${$root->sibling};
+ $limit_seq = $nseq if !defined($limit_seq)
+ or defined($nseq) && $nseq < $limit_seq;
+ }
+ $limit_seq = $self->{'limit_seq'}
+ if defined($self->{'limit_seq'})
+ && (!defined($limit_seq) || $self->{'limit_seq'} < $limit_seq);
+ local $self->{'limit_seq'} = $limit_seq;
+
+ $self->walk_lineseq($root, \@ops,
+ sub { push @exprs, $_[0]} );
+
+ my $body = join(";\n", grep {length} @exprs);
+ my $subs = "";
+ if (defined $root && defined $limit_seq && !$self->{'in_format'}) {
+ $subs = join "\n", $self->seq_subs($limit_seq);
+ }
+ return join(";\n", grep {length} $body, $subs);
+}
+
+sub scopeop {
+ my($real_block, $self, $op, $cx) = @_;
+ my $kid;
+ my @kids;
+
+ local(@$self{qw'curstash warnings hints hinthash'})
+ = @$self{qw'curstash warnings hints hinthash'} if $real_block;
+ if ($real_block) {
+ $kid = $op->first->sibling; # skip enter
+ if (is_miniwhile($kid)) {
+ my $top = $kid->first;
+ my $name = $top->name;
+ if ($name eq "and") {
+ $name = "while";
+ } elsif ($name eq "or") {
+ $name = "until";
+ } else { # no conditional -> while 1 or until 0
+ return $self->deparse($top->first, 1) . " while 1";
+ }
+ my $cond = $top->first;
+ my $body = $cond->sibling->first; # skip lineseq
+ $cond = $self->deparse($cond, 1);
+ $body = $self->deparse($body, 1);
+ return "$body $name $cond";
+ }
+ } else {
+ $kid = $op->first;
+ }
+ for (; !null($kid); $kid = $kid->sibling) {
+ push @kids, $kid;
+ }
+ if ($cx > 0) { # inside an expression, (a do {} while for lineseq)
+ return "do {\n\t" . $self->lineseq($op, @kids) . "\n\b}";
+ } else {
+ my $lineseq = $self->lineseq($op, @kids);
+ return (length ($lineseq) ? "$lineseq;" : "");
+ }
+}
+
+sub pp_scope { scopeop(0, @_); }
+sub pp_lineseq { scopeop(0, @_); }
+sub pp_leave { scopeop(1, @_); }
+
+# This is a special case of scopeop and lineseq, for the case of the
+# main_root. The difference is that we print the output statements as
+# soon as we get them, for the sake of impatient users.
+sub deparse_root {
+ my $self = shift;
+ my($op) = @_;
+ local(@$self{qw'curstash warnings hints hinthash'})
+ = @$self{qw'curstash warnings hints hinthash'};
+ my @kids;
+ return if null $op->first; # Can happen, e.g., for Bytecode without -k
+ for (my $kid = $op->first->sibling; !null($kid); $kid = $kid->sibling) {
+ push @kids, $kid;
+ }
+ $self->walk_lineseq($op, \@kids,
+ sub { print $self->indent($_[0].';');
+ print "\n" unless $_[1] == $#kids;
+ });
+}
+
+sub walk_lineseq {
+ my ($self, $op, $kids, $callback) = @_;
+ my @kids = @$kids;
+ for (my $i = 0; $i < @kids; $i++) {
+ my $expr = "";
+ if (is_state $kids[$i]) {
+ $expr = $self->deparse($kids[$i++], 0);
+ if ($i > $#kids) {
+ $callback->($expr, $i);
+ last;
+ }
+ }
+ if (is_for_loop($kids[$i])) {
+ $callback->($expr . $self->for_loop($kids[$i], 0), $i++);
+ next;
+ }
+ $expr .= $self->deparse($kids[$i], (@kids != 1)/2);
+ $expr =~ s/;\n?\z//;
+ $callback->($expr, $i);
+ }
+}
+
+# The BEGIN {} is used here because otherwise this code isn't executed
+# when you run B::Deparse on itself.
+my %globalnames;
+BEGIN { map($globalnames{$_}++, "SIG", "STDIN", "STDOUT", "STDERR", "INC",
+ "ENV", "ARGV", "ARGVOUT", "_"); }
+
+sub gv_name {
+ my $self = shift;
+ my $gv = shift;
+Carp::confess() unless ref($gv) eq "B::GV";
+ my $stash = $gv->STASH->NAME;
+ my $name = $gv->SAFENAME;
+ if ($stash eq 'main' && $name =~ /^::/) {
+ $stash = '::';
+ }
+ elsif (($stash eq 'main' && $globalnames{$name})
+ or ($stash eq $self->{'curstash'} && !$globalnames{$name}
+ && ($stash eq 'main' || $name !~ /::/))
+ or $name =~ /^[^A-Za-z_:]/)
+ {
+ $stash = "";
+ } else {
+ $stash = $stash . "::";
+ }
+ if ($name =~ /^(\^..|{)/) {
+ $name = "{$name}"; # ${^WARNING_BITS}, etc and ${
+ }
+ return $stash . $name;
+}
+
+# Return the name to use for a stash variable.
+# If a lexical with the same name is in scope, it may need to be
+# fully-qualified.
+sub stash_variable {
+ my ($self, $prefix, $name) = @_;
+
+ return "$prefix$name" if $name =~ /::/;
+
+ unless ($prefix eq '$' || $prefix eq '@' || #'
+ $prefix eq '%' || $prefix eq '$#') {
+ return "$prefix$name";
+ }
+
+ my $v = ($prefix eq '$#' ? '@' : $prefix) . $name;
+ return $prefix .$self->{'curstash'}.'::'. $name if $self->lex_in_scope($v);
+ return "$prefix$name";
+}
+
+sub lex_in_scope {
+ my ($self, $name) = @_;
+ $self->populate_curcvlex() if !defined $self->{'curcvlex'};
+
+ return 0 if !defined($self->{'curcop'});
+ my $seq = $self->{'curcop'}->cop_seq;
+ return 0 if !exists $self->{'curcvlex'}{$name};
+ for my $a (@{$self->{'curcvlex'}{$name}}) {
+ my ($st, $en) = @$a;
+ return 1 if $seq > $st && $seq <= $en;
+ }
+ return 0;
+}
+
+sub populate_curcvlex {
+ my $self = shift;
+ for (my $cv = $self->{'curcv'}; class($cv) eq "CV"; $cv = $cv->OUTSIDE) {
+ my $padlist = $cv->PADLIST;
+ # an undef CV still in lexical chain
+ next if class($padlist) eq "SPECIAL";
+ my @padlist = $padlist->ARRAY;
+ my @ns = $padlist[0]->ARRAY;
+
+ for (my $i=0; $i<@ns; ++$i) {
+ next if class($ns[$i]) eq "SPECIAL";
+ next if $ns[$i]->FLAGS & SVpad_OUR; # Skip "our" vars
+ if (class($ns[$i]) eq "PV") {
+ # Probably that pesky lexical @_
+ next;
+ }
+ my $name = $ns[$i]->PVX;
+ my ($seq_st, $seq_en) =
+ ($ns[$i]->FLAGS & SVf_FAKE)
+ ? (0, 999999)
+ : ($ns[$i]->COP_SEQ_RANGE_LOW, $ns[$i]->COP_SEQ_RANGE_HIGH);
+
+ push @{$self->{'curcvlex'}{$name}}, [$seq_st, $seq_en];
+ }
+ }
+}
+
+sub find_scope_st { ((find_scope(@_))[0]); }
+sub find_scope_en { ((find_scope(@_))[1]); }
+
+# Recurses down the tree, looking for pad variable introductions and COPs
+sub find_scope {
+ my ($self, $op, $scope_st, $scope_en) = @_;
+ carp("Undefined op in find_scope") if !defined $op;
+ return ($scope_st, $scope_en) unless $op->flags & OPf_KIDS;
+
+ my @queue = ($op);
+ while(my $op = shift @queue ) {
+ for (my $o=$op->first; $$o; $o=$o->sibling) {
+ if ($o->name =~ /^pad.v$/ && $o->private & OPpLVAL_INTRO) {
+ my $s = int($self->padname_sv($o->targ)->COP_SEQ_RANGE_LOW);
+ my $e = $self->padname_sv($o->targ)->COP_SEQ_RANGE_HIGH;
+ $scope_st = $s if !defined($scope_st) || $s < $scope_st;
+ $scope_en = $e if !defined($scope_en) || $e > $scope_en;
+ return ($scope_st, $scope_en);
+ }
+ elsif (is_state($o)) {
+ my $c = $o->cop_seq;
+ $scope_st = $c if !defined($scope_st) || $c < $scope_st;
+ $scope_en = $c if !defined($scope_en) || $c > $scope_en;
+ return ($scope_st, $scope_en);
+ }
+ elsif ($o->flags & OPf_KIDS) {
+ unshift (@queue, $o);
+ }
+ }
+ }
+
+ return ($scope_st, $scope_en);
+}
+
+# Returns a list of subs which should be inserted before the COP
+sub cop_subs {
+ my ($self, $op, $out_seq) = @_;
+ my $seq = $op->cop_seq;
+ # If we have nephews, then our sequence number indicates
+ # the cop_seq of the end of some sort of scope.
+ if (class($op->sibling) ne "NULL" && $op->sibling->flags & OPf_KIDS
+ and my $nseq = $self->find_scope_st($op->sibling) ) {
+ $seq = $nseq;
+ }
+ $seq = $out_seq if defined($out_seq) && $out_seq < $seq;
+ return $self->seq_subs($seq);
+}
+
+sub seq_subs {
+ my ($self, $seq) = @_;
+ my @text;
+#push @text, "# ($seq)\n";
+
+ return "" if !defined $seq;
+ while (scalar(@{$self->{'subs_todo'}})
+ and $seq > $self->{'subs_todo'}[0][0]) {
+ push @text, $self->next_todo;
+ }
+ return @text;
+}
+
+# Notice how subs and formats are inserted between statements here;
+# also $[ assignments and pragmas.
+sub pp_nextstate {
+ my $self = shift;
+ my($op, $cx) = @_;
+ $self->{'curcop'} = $op;
+ my @text;
+ push @text, $self->cop_subs($op);
+ push @text, $op->label . ": " if $op->label;
+ my $stash = $op->stashpv;
+ if ($stash ne $self->{'curstash'}) {
+ push @text, "package $stash;\n";
+ $self->{'curstash'} = $stash;
+ }
+
+ if ($self->{'arybase'} != $op->arybase) {
+ push @text, '$[ = '. $op->arybase .";\n";
+ $self->{'arybase'} = $op->arybase;
+ }
+
+ my $warnings = $op->warnings;
+ my $warning_bits;
+ if ($warnings->isa("B::SPECIAL") && $$warnings == 4) {
+ $warning_bits = $warnings::Bits{"all"} & WARN_MASK;
+ }
+ elsif ($warnings->isa("B::SPECIAL") && $$warnings == 5) {
+ $warning_bits = $warnings::NONE;
+ }
+ elsif ($warnings->isa("B::SPECIAL")) {
+ $warning_bits = undef;
+ }
+ else {
+ $warning_bits = $warnings->PV & WARN_MASK;
+ }
+
+ if (defined ($warning_bits) and
+ !defined($self->{warnings}) || $self->{'warnings'} ne $warning_bits) {
+ push @text, declare_warnings($self->{'warnings'}, $warning_bits);
+ $self->{'warnings'} = $warning_bits;
+ }
+
+ if ($self->{'hints'} != $op->hints) {
+ push @text, declare_hints($self->{'hints'}, $op->hints);
+ $self->{'hints'} = $op->hints;
+ }
+
+ # hack to check that the hint hash hasn't changed
+ if ($] > 5.009 &&
+ "@{[sort %{$self->{'hinthash'} || {}}]}"
+ ne "@{[sort %{$op->hints_hash->HASH || {}}]}") {
+ push @text, declare_hinthash($self->{'hinthash'}, $op->hints_hash->HASH, $self->{indent_size});
+ $self->{'hinthash'} = $op->hints_hash->HASH;
+ }
+
+ # This should go after of any branches that add statements, to
+ # increase the chances that it refers to the same line it did in
+ # the original program.
+ if ($self->{'linenums'}) {
+ push @text, "\f#line " . $op->line .
+ ' "' . $op->file, qq'"\n';
+ }
+
+ return join("", @text);
+}
+
+sub declare_warnings {
+ my ($from, $to) = @_;
+ if (($to & WARN_MASK) eq (warnings::bits("all") & WARN_MASK)) {
+ return "use warnings;\n";
+ }
+ elsif (($to & WARN_MASK) eq ("\0"x length($to) & WARN_MASK)) {
+ return "no warnings;\n";
+ }
+ return "BEGIN {\${^WARNING_BITS} = ".perlstring($to)."}\n";
+}
+
+sub declare_hints {
+ my ($from, $to) = @_;
+ my $use = $to & ~$from;
+ my $no = $from & ~$to;
+ my $decls = "";
+ for my $pragma (hint_pragmas($use)) {
+ $decls .= "use $pragma;\n";
+ }
+ for my $pragma (hint_pragmas($no)) {
+ $decls .= "no $pragma;\n";
+ }
+ return $decls;
+}
+
+# Internal implementation hints that the core sets automatically, so don't need
+# (or want) to be passed back to the user
+my %ignored_hints = (
+ 'open<' => 1,
+ 'open>' => 1,
+ ':' => 1,
+);
+
+sub declare_hinthash {
+ my ($from, $to, $indent) = @_;
+ my @decls;
+ for my $key (keys %$to) {
+ next if $ignored_hints{$key};
+ if (!defined $from->{$key} or $from->{$key} ne $to->{$key}) {
+ push @decls, qq(\$^H{'$key'} = q($to->{$key}););
+ }
+ }
+ for my $key (keys %$from) {
+ next if $ignored_hints{$key};
+ if (!exists $to->{$key}) {
+ push @decls, qq(delete \$^H{'$key'};);
+ }
+ }
+ @decls or return '';
+ return join("\n" . (" " x $indent), "BEGIN {", @decls) . "\n}\n";
+}
+
+sub hint_pragmas {
+ my ($bits) = @_;
+ my @pragmas;
+ push @pragmas, "integer" if $bits & 0x1;
+ push @pragmas, "strict 'refs'" if $bits & 0x2;
+ push @pragmas, "bytes" if $bits & 0x8;
+ return @pragmas;
+}
+
+sub pp_dbstate { pp_nextstate(@_) }
+sub pp_setstate { pp_nextstate(@_) }
+
+sub pp_unstack { return "" } # see also leaveloop
+
+sub baseop {
+ my $self = shift;
+ my($op, $cx, $name) = @_;
+ return $name;
+}
+
+sub pp_stub {
+ my $self = shift;
+ my($op, $cx, $name) = @_;
+ if ($cx >= 1) {
+ return "()";
+ }
+ else {
+ return "();";
+ }
+}
+sub pp_wantarray { baseop(@_, "wantarray") }
+sub pp_fork { baseop(@_, "fork") }
+sub pp_wait { maybe_targmy(@_, \&baseop, "wait") }
+sub pp_getppid { maybe_targmy(@_, \&baseop, "getppid") }
+sub pp_time { maybe_targmy(@_, \&baseop, "time") }
+sub pp_tms { baseop(@_, "times") }
+sub pp_ghostent { baseop(@_, "gethostent") }
+sub pp_gnetent { baseop(@_, "getnetent") }
+sub pp_gprotoent { baseop(@_, "getprotoent") }
+sub pp_gservent { baseop(@_, "getservent") }
+sub pp_ehostent { baseop(@_, "endhostent") }
+sub pp_enetent { baseop(@_, "endnetent") }
+sub pp_eprotoent { baseop(@_, "endprotoent") }
+sub pp_eservent { baseop(@_, "endservent") }
+sub pp_gpwent { baseop(@_, "getpwent") }
+sub pp_spwent { baseop(@_, "setpwent") }
+sub pp_epwent { baseop(@_, "endpwent") }
+sub pp_ggrent { baseop(@_, "getgrent") }
+sub pp_sgrent { baseop(@_, "setgrent") }
+sub pp_egrent { baseop(@_, "endgrent") }
+sub pp_getlogin { baseop(@_, "getlogin") }
+
+sub POSTFIX () { 1 }
+
+# I couldn't think of a good short name, but this is the category of
+# symbolic unary operators with interesting precedence
+
+sub pfixop {
+ my $self = shift;
+ my($op, $cx, $name, $prec, $flags) = (@_, 0);
+ my $kid = $op->first;
+ $kid = $self->deparse($kid, $prec);
+ return $self->maybe_parens(($flags & POSTFIX) ? "$kid$name" : "$name$kid",
+ $cx, $prec);
+}
+
+sub pp_preinc { pfixop(@_, "++", 23) }
+sub pp_predec { pfixop(@_, "--", 23) }
+sub pp_postinc { maybe_targmy(@_, \&pfixop, "++", 23, POSTFIX) }
+sub pp_postdec { maybe_targmy(@_, \&pfixop, "--", 23, POSTFIX) }
+sub pp_i_preinc { pfixop(@_, "++", 23) }
+sub pp_i_predec { pfixop(@_, "--", 23) }
+sub pp_i_postinc { maybe_targmy(@_, \&pfixop, "++", 23, POSTFIX) }
+sub pp_i_postdec { maybe_targmy(@_, \&pfixop, "--", 23, POSTFIX) }
+sub pp_complement { maybe_targmy(@_, \&pfixop, "~", 21) }
+
+sub pp_negate { maybe_targmy(@_, \&real_negate) }
+sub real_negate {
+ my $self = shift;
+ my($op, $cx) = @_;
+ if ($op->first->name =~ /^(i_)?negate$/) {
+ # avoid --$x
+ $self->pfixop($op, $cx, "-", 21.5);
+ } else {
+ $self->pfixop($op, $cx, "-", 21);
+ }
+}
+sub pp_i_negate { pp_negate(@_) }
+
+sub pp_not {
+ my $self = shift;
+ my($op, $cx) = @_;
+ if ($cx <= 4) {
+ $self->pfixop($op, $cx, "not ", 4);
+ } else {
+ $self->pfixop($op, $cx, "!", 21);
+ }
+}
+
+sub unop {
+ my $self = shift;
+ my($op, $cx, $name) = @_;
+ my $kid;
+ if ($op->flags & OPf_KIDS) {
+ $kid = $op->first;
+ my $builtinname = $name;
+ $builtinname =~ /^CORE::/ or $builtinname = "CORE::$name";
+ if (defined prototype($builtinname)
+ && prototype($builtinname) =~ /^;?\*/
+ && $kid->name eq "rv2gv") {
+ $kid = $kid->first;
+ }
+
+ return $self->maybe_parens_unop($name, $kid, $cx);
+ } else {
+ return $name . ($op->flags & OPf_SPECIAL ? "()" : "");
+ }
+}
+
+sub pp_chop { maybe_targmy(@_, \&unop, "chop") }
+sub pp_chomp { maybe_targmy(@_, \&unop, "chomp") }
+sub pp_schop { maybe_targmy(@_, \&unop, "chop") }
+sub pp_schomp { maybe_targmy(@_, \&unop, "chomp") }
+sub pp_defined { unop(@_, "defined") }
+sub pp_undef { unop(@_, "undef") }
+sub pp_study { unop(@_, "study") }
+sub pp_ref { unop(@_, "ref") }
+sub pp_pos { maybe_local(@_, unop(@_, "pos")) }
+
+sub pp_sin { maybe_targmy(@_, \&unop, "sin") }
+sub pp_cos { maybe_targmy(@_, \&unop, "cos") }
+sub pp_rand { maybe_targmy(@_, \&unop, "rand") }
+sub pp_srand { unop(@_, "srand") }
+sub pp_exp { maybe_targmy(@_, \&unop, "exp") }
+sub pp_log { maybe_targmy(@_, \&unop, "log") }
+sub pp_sqrt { maybe_targmy(@_, \&unop, "sqrt") }
+sub pp_int { maybe_targmy(@_, \&unop, "int") }
+sub pp_hex { maybe_targmy(@_, \&unop, "hex") }
+sub pp_oct { maybe_targmy(@_, \&unop, "oct") }
+sub pp_abs { maybe_targmy(@_, \&unop, "abs") }
+
+sub pp_length { maybe_targmy(@_, \&unop, "length") }
+sub pp_ord { maybe_targmy(@_, \&unop, "ord") }
+sub pp_chr { maybe_targmy(@_, \&unop, "chr") }
+
+sub pp_each { unop(@_, "each") }
+sub pp_values { unop(@_, "values") }
+sub pp_keys { unop(@_, "keys") }
+sub pp_aeach { unop(@_, "each") }
+sub pp_avalues { unop(@_, "values") }
+sub pp_akeys { unop(@_, "keys") }
+sub pp_pop { unop(@_, "pop") }
+sub pp_shift { unop(@_, "shift") }
+
+sub pp_caller { unop(@_, "caller") }
+sub pp_reset { unop(@_, "reset") }
+sub pp_exit { unop(@_, "exit") }
+sub pp_prototype { unop(@_, "prototype") }
+
+sub pp_close { unop(@_, "close") }
+sub pp_fileno { unop(@_, "fileno") }
+sub pp_umask { unop(@_, "umask") }
+sub pp_untie { unop(@_, "untie") }
+sub pp_tied { unop(@_, "tied") }
+sub pp_dbmclose { unop(@_, "dbmclose") }
+sub pp_getc { unop(@_, "getc") }
+sub pp_eof { unop(@_, "eof") }
+sub pp_tell { unop(@_, "tell") }
+sub pp_getsockname { unop(@_, "getsockname") }
+sub pp_getpeername { unop(@_, "getpeername") }
+
+sub pp_chdir { maybe_targmy(@_, \&unop, "chdir") }
+sub pp_chroot { maybe_targmy(@_, \&unop, "chroot") }
+sub pp_readlink { unop(@_, "readlink") }
+sub pp_rmdir { maybe_targmy(@_, \&unop, "rmdir") }
+sub pp_readdir { unop(@_, "readdir") }
+sub pp_telldir { unop(@_, "telldir") }
+sub pp_rewinddir { unop(@_, "rewinddir") }
+sub pp_closedir { unop(@_, "closedir") }
+sub pp_getpgrp { maybe_targmy(@_, \&unop, "getpgrp") }
+sub pp_localtime { unop(@_, "localtime") }
+sub pp_gmtime { unop(@_, "gmtime") }
+sub pp_alarm { unop(@_, "alarm") }
+sub pp_sleep { maybe_targmy(@_, \&unop, "sleep") }
+
+sub pp_dofile { unop(@_, "do") }
+sub pp_entereval { unop(@_, "eval") }
+
+sub pp_ghbyname { unop(@_, "gethostbyname") }
+sub pp_gnbyname { unop(@_, "getnetbyname") }
+sub pp_gpbyname { unop(@_, "getprotobyname") }
+sub pp_shostent { unop(@_, "sethostent") }
+sub pp_snetent { unop(@_, "setnetent") }
+sub pp_sprotoent { unop(@_, "setprotoent") }
+sub pp_sservent { unop(@_, "setservent") }
+sub pp_gpwnam { unop(@_, "getpwnam") }
+sub pp_gpwuid { unop(@_, "getpwuid") }
+sub pp_ggrnam { unop(@_, "getgrnam") }
+sub pp_ggrgid { unop(@_, "getgrgid") }
+
+sub pp_lock { unop(@_, "lock") }
+
+sub pp_continue { unop(@_, "continue"); }
+sub pp_break {
+ my ($self, $op) = @_;
+ return "" if $op->flags & OPf_SPECIAL;
+ unop(@_, "break");
+}
+
+sub givwhen {
+ my $self = shift;
+ my($op, $cx, $givwhen) = @_;
+
+ my $enterop = $op->first;
+ my ($head, $block);
+ if ($enterop->flags & OPf_SPECIAL) {
+ $head = "default";
+ $block = $self->deparse($enterop->first, 0);
+ }
+ else {
+ my $cond = $enterop->first;
+ my $cond_str = $self->deparse($cond, 1);
+ $head = "$givwhen ($cond_str)";
+ $block = $self->deparse($cond->sibling, 0);
+ }
+
+ return "$head {\n".
+ "\t$block\n".
+ "\b}\cK";
+}
+
+sub pp_leavegiven { givwhen(@_, "given"); }
+sub pp_leavewhen { givwhen(@_, "when"); }
+
+sub pp_exists {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my $arg;
+ if ($op->private & OPpEXISTS_SUB) {
+ # Checking for the existence of a subroutine
+ return $self->maybe_parens_func("exists",
+ $self->pp_rv2cv($op->first, 16), $cx, 16);
+ }
+ if ($op->flags & OPf_SPECIAL) {
+ # Array element, not hash element
+ return $self->maybe_parens_func("exists",
+ $self->pp_aelem($op->first, 16), $cx, 16);
+ }
+ return $self->maybe_parens_func("exists", $self->pp_helem($op->first, 16),
+ $cx, 16);
+}
+
+sub pp_delete {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my $arg;
+ if ($op->private & OPpSLICE) {
+ if ($op->flags & OPf_SPECIAL) {
+ # Deleting from an array, not a hash
+ return $self->maybe_parens_func("delete",
+ $self->pp_aslice($op->first, 16),
+ $cx, 16);
+ }
+ return $self->maybe_parens_func("delete",
+ $self->pp_hslice($op->first, 16),
+ $cx, 16);
+ } else {
+ if ($op->flags & OPf_SPECIAL) {
+ # Deleting from an array, not a hash
+ return $self->maybe_parens_func("delete",
+ $self->pp_aelem($op->first, 16),
+ $cx, 16);
+ }
+ return $self->maybe_parens_func("delete",
+ $self->pp_helem($op->first, 16),
+ $cx, 16);
+ }
+}
+
+sub pp_require {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my $opname = $op->flags & OPf_SPECIAL ? 'CORE::require' : 'require';
+ if (class($op) eq "UNOP" and $op->first->name eq "const"
+ and $op->first->private & OPpCONST_BARE)
+ {
+ my $name = $self->const_sv($op->first)->PV;
+ $name =~ s[/][::]g;
+ $name =~ s/\.pm//g;
+ return "$opname $name";
+ } else {
+ $self->unop($op, $cx, $opname);
+ }
+}
+
+sub pp_scalar {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my $kid = $op->first;
+ if (not null $kid->sibling) {
+ # XXX Was a here-doc
+ return $self->dquote($op);
+ }
+ $self->unop(@_, "scalar");
+}
+
+
+sub padval {
+ my $self = shift;
+ my $targ = shift;
+ return $self->{'curcv'}->PADLIST->ARRAYelt(1)->ARRAYelt($targ);
+}
+
+sub anon_hash_or_list {
+ my $self = shift;
+ my($op, $cx) = @_;
+
+ my($pre, $post) = @{{"anonlist" => ["[","]"],
+ "anonhash" => ["{","}"]}->{$op->name}};
+ my($expr, @exprs);
+ $op = $op->first->sibling; # skip pushmark
+ for (; !null($op); $op = $op->sibling) {
+ $expr = $self->deparse($op, 6);
+ push @exprs, $expr;
+ }
+ if ($pre eq "{" and $cx < 1) {
+ # Disambiguate that it's not a block
+ $pre = "+{";
+ }
+ return $pre . join(", ", @exprs) . $post;
+}
+
+sub pp_anonlist {
+ my $self = shift;
+ my ($op, $cx) = @_;
+ if ($op->flags & OPf_SPECIAL) {
+ return $self->anon_hash_or_list($op, $cx);
+ }
+ warn "Unexpected op pp_" . $op->name() . " without OPf_SPECIAL";
+ return 'XXX';
+}
+
+*pp_anonhash = \&pp_anonlist;
+
+sub pp_refgen {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my $kid = $op->first;
+ if ($kid->name eq "null") {
+ $kid = $kid->first;
+ if (!null($kid->sibling) and
+ $kid->sibling->name eq "anoncode") {
+ return $self->e_anoncode({ code => $self->padval($kid->sibling->targ) });
+ } elsif ($kid->name eq "pushmark") {
+ my $sib_name = $kid->sibling->name;
+ if ($sib_name =~ /^(pad|rv2)[ah]v$/
+ and not $kid->sibling->flags & OPf_REF)
+ {
+ # The @a in \(@a) isn't in ref context, but only when the
+ # parens are there.
+ return "\\(" . $self->pp_list($op->first) . ")";
+ } elsif ($sib_name eq 'entersub') {
+ my $text = $self->deparse($kid->sibling, 1);
+ # Always show parens for \(&func()), but only with -p otherwise
+ $text = "($text)" if $self->{'parens'}
+ or $kid->sibling->private & OPpENTERSUB_AMPER;
+ return "\\$text";
+ }
+ }
+ }
+ $self->pfixop($op, $cx, "\\", 20);
+}
+
+sub e_anoncode {
+ my ($self, $info) = @_;
+ my $text = $self->deparse_sub($info->{code});
+ return "sub " . $text;
+}
+
+sub pp_srefgen { pp_refgen(@_) }
+
+sub pp_readline {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my $kid = $op->first;
+ $kid = $kid->first if $kid->name eq "rv2gv"; # <$fh>
+ return "<" . $self->deparse($kid, 1) . ">" if is_scalar($kid);
+ return $self->unop($op, $cx, "readline");
+}
+
+sub pp_rcatline {
+ my $self = shift;
+ my($op) = @_;
+ return "<" . $self->gv_name($self->gv_or_padgv($op)) . ">";
+}
+
+# Unary operators that can occur as pseudo-listops inside double quotes
+sub dq_unop {
+ my $self = shift;
+ my($op, $cx, $name, $prec, $flags) = (@_, 0, 0);
+ my $kid;
+ if ($op->flags & OPf_KIDS) {
+ $kid = $op->first;
+ # If there's more than one kid, the first is an ex-pushmark.
+ $kid = $kid->sibling if not null $kid->sibling;
+ return $self->maybe_parens_unop($name, $kid, $cx);
+ } else {
+ return $name . ($op->flags & OPf_SPECIAL ? "()" : "");
+ }
+}
+
+sub pp_ucfirst { dq_unop(@_, "ucfirst") }
+sub pp_lcfirst { dq_unop(@_, "lcfirst") }
+sub pp_uc { dq_unop(@_, "uc") }
+sub pp_lc { dq_unop(@_, "lc") }
+sub pp_quotemeta { maybe_targmy(@_, \&dq_unop, "quotemeta") }
+
+sub loopex {
+ my $self = shift;
+ my ($op, $cx, $name) = @_;
+ if (class($op) eq "PVOP") {
+ return "$name " . $op->pv;
+ } elsif (class($op) eq "OP") {
+ return $name;
+ } elsif (class($op) eq "UNOP") {
+ # Note -- loop exits are actually exempt from the
+ # looks-like-a-func rule, but a few extra parens won't hurt
+ return $self->maybe_parens_unop($name, $op->first, $cx);
+ }
+}
+
+sub pp_last { loopex(@_, "last") }
+sub pp_next { loopex(@_, "next") }
+sub pp_redo { loopex(@_, "redo") }
+sub pp_goto { loopex(@_, "goto") }
+sub pp_dump { loopex(@_, "dump") }
+
+sub ftst {
+ my $self = shift;
+ my($op, $cx, $name) = @_;
+ if (class($op) eq "UNOP") {
+ # Genuine `-X' filetests are exempt from the LLAFR, but not
+ # l?stat(); for the sake of clarity, give'em all parens
+ return $self->maybe_parens_unop($name, $op->first, $cx);
+ } elsif (class($op) =~ /^(SV|PAD)OP$/) {
+ return $self->maybe_parens_func($name, $self->pp_gv($op, 1), $cx, 16);
+ } else { # I don't think baseop filetests ever survive ck_ftst, but...
+ return $name;
+ }
+}
+
+sub pp_lstat { ftst(@_, "lstat") }
+sub pp_stat { ftst(@_, "stat") }
+sub pp_ftrread { ftst(@_, "-R") }
+sub pp_ftrwrite { ftst(@_, "-W") }
+sub pp_ftrexec { ftst(@_, "-X") }
+sub pp_fteread { ftst(@_, "-r") }
+sub pp_ftewrite { ftst(@_, "-w") }
+sub pp_fteexec { ftst(@_, "-x") }
+sub pp_ftis { ftst(@_, "-e") }
+sub pp_fteowned { ftst(@_, "-O") }
+sub pp_ftrowned { ftst(@_, "-o") }
+sub pp_ftzero { ftst(@_, "-z") }
+sub pp_ftsize { ftst(@_, "-s") }
+sub pp_ftmtime { ftst(@_, "-M") }
+sub pp_ftatime { ftst(@_, "-A") }
+sub pp_ftctime { ftst(@_, "-C") }
+sub pp_ftsock { ftst(@_, "-S") }
+sub pp_ftchr { ftst(@_, "-c") }
+sub pp_ftblk { ftst(@_, "-b") }
+sub pp_ftfile { ftst(@_, "-f") }
+sub pp_ftdir { ftst(@_, "-d") }
+sub pp_ftpipe { ftst(@_, "-p") }
+sub pp_ftlink { ftst(@_, "-l") }
+sub pp_ftsuid { ftst(@_, "-u") }
+sub pp_ftsgid { ftst(@_, "-g") }
+sub pp_ftsvtx { ftst(@_, "-k") }
+sub pp_fttty { ftst(@_, "-t") }
+sub pp_fttext { ftst(@_, "-T") }
+sub pp_ftbinary { ftst(@_, "-B") }
+
+sub SWAP_CHILDREN () { 1 }
+sub ASSIGN () { 2 } # has OP= variant
+sub LIST_CONTEXT () { 4 } # Assignment is in list context
+
+my(%left, %right);
+
+sub assoc_class {
+ my $op = shift;
+ my $name = $op->name;
+ if ($name eq "concat" and $op->first->name eq "concat") {
+ # avoid spurious `=' -- see comment in pp_concat
+ return "concat";
+ }
+ if ($name eq "null" and class($op) eq "UNOP"
+ and $op->first->name =~ /^(and|x?or)$/
+ and null $op->first->sibling)
+ {
+ # Like all conditional constructs, OP_ANDs and OP_ORs are topped
+ # with a null that's used as the common end point of the two
+ # flows of control. For precedence purposes, ignore it.
+ # (COND_EXPRs have these too, but we don't bother with
+ # their associativity).
+ return assoc_class($op->first);
+ }
+ return $name . ($op->flags & OPf_STACKED ? "=" : "");
+}
+
+# Left associative operators, like `+', for which
+# $a + $b + $c is equivalent to ($a + $b) + $c
+
+BEGIN {
+ %left = ('multiply' => 19, 'i_multiply' => 19,
+ 'divide' => 19, 'i_divide' => 19,
+ 'modulo' => 19, 'i_modulo' => 19,
+ 'repeat' => 19,
+ 'add' => 18, 'i_add' => 18,
+ 'subtract' => 18, 'i_subtract' => 18,
+ 'concat' => 18,
+ 'left_shift' => 17, 'right_shift' => 17,
+ 'bit_and' => 13,
+ 'bit_or' => 12, 'bit_xor' => 12,
+ 'and' => 3,
+ 'or' => 2, 'xor' => 2,
+ );
+}
+
+sub deparse_binop_left {
+ my $self = shift;
+ my($op, $left, $prec) = @_;
+ if ($left{assoc_class($op)} && $left{assoc_class($left)}
+ and $left{assoc_class($op)} == $left{assoc_class($left)})
+ {
+ return $self->deparse($left, $prec - .00001);
+ } else {
+ return $self->deparse($left, $prec);
+ }
+}
+
+# Right associative operators, like `=', for which
+# $a = $b = $c is equivalent to $a = ($b = $c)
+
+BEGIN {
+ %right = ('pow' => 22,
+ 'sassign=' => 7, 'aassign=' => 7,
+ 'multiply=' => 7, 'i_multiply=' => 7,
+ 'divide=' => 7, 'i_divide=' => 7,
+ 'modulo=' => 7, 'i_modulo=' => 7,
+ 'repeat=' => 7,
+ 'add=' => 7, 'i_add=' => 7,
+ 'subtract=' => 7, 'i_subtract=' => 7,
+ 'concat=' => 7,
+ 'left_shift=' => 7, 'right_shift=' => 7,
+ 'bit_and=' => 7,
+ 'bit_or=' => 7, 'bit_xor=' => 7,
+ 'andassign' => 7,
+ 'orassign' => 7,
+ );
+}
+
+sub deparse_binop_right {
+ my $self = shift;
+ my($op, $right, $prec) = @_;
+ if ($right{assoc_class($op)} && $right{assoc_class($right)}
+ and $right{assoc_class($op)} == $right{assoc_class($right)})
+ {
+ return $self->deparse($right, $prec - .00001);
+ } else {
+ return $self->deparse($right, $prec);
+ }
+}
+
+sub binop {
+ my $self = shift;
+ my ($op, $cx, $opname, $prec, $flags) = (@_, 0);
+ my $left = $op->first;
+ my $right = $op->last;
+ my $eq = "";
+ if ($op->flags & OPf_STACKED && $flags & ASSIGN) {
+ $eq = "=";
+ $prec = 7;
+ }
+ if ($flags & SWAP_CHILDREN) {
+ ($left, $right) = ($right, $left);
+ }
+ $left = $self->deparse_binop_left($op, $left, $prec);
+ $left = "($left)" if $flags & LIST_CONTEXT
+ && $left !~ /^(my|our|local|)[\@\(]/;
+ $right = $self->deparse_binop_right($op, $right, $prec);
+ return $self->maybe_parens("$left $opname$eq $right", $cx, $prec);
+}
+
+sub pp_add { maybe_targmy(@_, \&binop, "+", 18, ASSIGN) }
+sub pp_multiply { maybe_targmy(@_, \&binop, "*", 19, ASSIGN) }
+sub pp_subtract { maybe_targmy(@_, \&binop, "-",18, ASSIGN) }
+sub pp_divide { maybe_targmy(@_, \&binop, "/", 19, ASSIGN) }
+sub pp_modulo { maybe_targmy(@_, \&binop, "%", 19, ASSIGN) }
+sub pp_i_add { maybe_targmy(@_, \&binop, "+", 18, ASSIGN) }
+sub pp_i_multiply { maybe_targmy(@_, \&binop, "*", 19, ASSIGN) }
+sub pp_i_subtract { maybe_targmy(@_, \&binop, "-", 18, ASSIGN) }
+sub pp_i_divide { maybe_targmy(@_, \&binop, "/", 19, ASSIGN) }
+sub pp_i_modulo { maybe_targmy(@_, \&binop, "%", 19, ASSIGN) }
+sub pp_pow { maybe_targmy(@_, \&binop, "**", 22, ASSIGN) }
+
+sub pp_left_shift { maybe_targmy(@_, \&binop, "<<", 17, ASSIGN) }
+sub pp_right_shift { maybe_targmy(@_, \&binop, ">>", 17, ASSIGN) }
+sub pp_bit_and { maybe_targmy(@_, \&binop, "&", 13, ASSIGN) }
+sub pp_bit_or { maybe_targmy(@_, \&binop, "|", 12, ASSIGN) }
+sub pp_bit_xor { maybe_targmy(@_, \&binop, "^", 12, ASSIGN) }
+
+sub pp_eq { binop(@_, "==", 14) }
+sub pp_ne { binop(@_, "!=", 14) }
+sub pp_lt { binop(@_, "<", 15) }
+sub pp_gt { binop(@_, ">", 15) }
+sub pp_ge { binop(@_, ">=", 15) }
+sub pp_le { binop(@_, "<=", 15) }
+sub pp_ncmp { binop(@_, "<=>", 14) }
+sub pp_i_eq { binop(@_, "==", 14) }
+sub pp_i_ne { binop(@_, "!=", 14) }
+sub pp_i_lt { binop(@_, "<", 15) }
+sub pp_i_gt { binop(@_, ">", 15) }
+sub pp_i_ge { binop(@_, ">=", 15) }
+sub pp_i_le { binop(@_, "<=", 15) }
+sub pp_i_ncmp { binop(@_, "<=>", 14) }
+
+sub pp_seq { binop(@_, "eq", 14) }
+sub pp_sne { binop(@_, "ne", 14) }
+sub pp_slt { binop(@_, "lt", 15) }
+sub pp_sgt { binop(@_, "gt", 15) }
+sub pp_sge { binop(@_, "ge", 15) }
+sub pp_sle { binop(@_, "le", 15) }
+sub pp_scmp { binop(@_, "cmp", 14) }
+
+sub pp_sassign { binop(@_, "=", 7, SWAP_CHILDREN) }
+sub pp_aassign { binop(@_, "=", 7, SWAP_CHILDREN | LIST_CONTEXT) }
+
+sub pp_smartmatch {
+ my ($self, $op, $cx) = @_;
+ if ($op->flags & OPf_SPECIAL) {
+ return $self->deparse($op->last, $cx);
+ }
+ else {
+ binop(@_, "~~", 14);
+ }
+}
+
+# `.' is special because concats-of-concats are optimized to save copying
+# by making all but the first concat stacked. The effect is as if the
+# programmer had written `($a . $b) .= $c', except legal.
+sub pp_concat { maybe_targmy(@_, \&real_concat) }
+sub real_concat {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my $left = $op->first;
+ my $right = $op->last;
+ my $eq = "";
+ my $prec = 18;
+ if ($op->flags & OPf_STACKED and $op->first->name ne "concat") {
+ $eq = "=";
+ $prec = 7;
+ }
+ $left = $self->deparse_binop_left($op, $left, $prec);
+ $right = $self->deparse_binop_right($op, $right, $prec);
+ return $self->maybe_parens("$left .$eq $right", $cx, $prec);
+}
+
+# `x' is weird when the left arg is a list
+sub pp_repeat {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my $left = $op->first;
+ my $right = $op->last;
+ my $eq = "";
+ my $prec = 19;
+ if ($op->flags & OPf_STACKED) {
+ $eq = "=";
+ $prec = 7;
+ }
+ if (null($right)) { # list repeat; count is inside left-side ex-list
+ my $kid = $left->first->sibling; # skip pushmark
+ my @exprs;
+ for (; !null($kid->sibling); $kid = $kid->sibling) {
+ push @exprs, $self->deparse($kid, 6);
+ }
+ $right = $kid;
+ $left = "(" . join(", ", @exprs). ")";
+ } else {
+ $left = $self->deparse_binop_left($op, $left, $prec);
+ }
+ $right = $self->deparse_binop_right($op, $right, $prec);
+ return $self->maybe_parens("$left x$eq $right", $cx, $prec);
+}
+
+sub range {
+ my $self = shift;
+ my ($op, $cx, $type) = @_;
+ my $left = $op->first;
+ my $right = $left->sibling;
+ $left = $self->deparse($left, 9);
+ $right = $self->deparse($right, 9);
+ return $self->maybe_parens("$left $type $right", $cx, 9);
+}
+
+sub pp_flop {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my $flip = $op->first;
+ my $type = ($flip->flags & OPf_SPECIAL) ? "..." : "..";
+ return $self->range($flip->first, $cx, $type);
+}
+
+# one-line while/until is handled in pp_leave
+
+sub logop {
+ my $self = shift;
+ my ($op, $cx, $lowop, $lowprec, $highop, $highprec, $blockname) = @_;
+ my $left = $op->first;
+ my $right = $op->first->sibling;
+ if ($cx < 1 and is_scope($right) and $blockname
+ and $self->{'expand'} < 7)
+ { # if ($a) {$b}
+ $left = $self->deparse($left, 1);
+ $right = $self->deparse($right, 0);
+ return "$blockname ($left) {\n\t$right\n\b}\cK";
+ } elsif ($cx < 1 and $blockname and not $self->{'parens'}
+ and $self->{'expand'} < 7) { # $b if $a
+ $right = $self->deparse($right, 1);
+ $left = $self->deparse($left, 1);
+ return "$right $blockname $left";
+ } elsif ($cx > $lowprec and $highop) { # $a && $b
+ $left = $self->deparse_binop_left($op, $left, $highprec);
+ $right = $self->deparse_binop_right($op, $right, $highprec);
+ return $self->maybe_parens("$left $highop $right", $cx, $highprec);
+ } else { # $a and $b
+ $left = $self->deparse_binop_left($op, $left, $lowprec);
+ $right = $self->deparse_binop_right($op, $right, $lowprec);
+ return $self->maybe_parens("$left $lowop $right", $cx, $lowprec);
+ }
+}
+
+sub pp_and { logop(@_, "and", 3, "&&", 11, "if") }
+sub pp_or { logop(@_, "or", 2, "||", 10, "unless") }
+sub pp_dor { logop(@_, "err", 2, "//", 10, "") }
+
+# xor is syntactically a logop, but it's really a binop (contrary to
+# old versions of opcode.pl). Syntax is what matters here.
+sub pp_xor { logop(@_, "xor", 2, "", 0, "") }
+
+sub logassignop {
+ my $self = shift;
+ my ($op, $cx, $opname) = @_;
+ my $left = $op->first;
+ my $right = $op->first->sibling->first; # skip sassign
+ $left = $self->deparse($left, 7);
+ $right = $self->deparse($right, 7);
+ return $self->maybe_parens("$left $opname $right", $cx, 7);
+}
+
+sub pp_andassign { logassignop(@_, "&&=") }
+sub pp_orassign { logassignop(@_, "||=") }
+sub pp_dorassign { logassignop(@_, "//=") }
+
+sub listop {
+ my $self = shift;
+ my($op, $cx, $name) = @_;
+ my(@exprs);
+ my $parens = ($cx >= 5) || $self->{'parens'};
+ my $kid = $op->first->sibling;
+ return $name if null $kid;
+ my $first;
+ $name = "socketpair" if $name eq "sockpair";
+ my $proto = prototype("CORE::$name");
+ if (defined $proto
+ && $proto =~ /^;?\*/
+ && $kid->name eq "rv2gv") {
+ $first = $self->deparse($kid->first, 6);
+ }
+ else {
+ $first = $self->deparse($kid, 6);
+ }
+ if ($name eq "chmod" && $first =~ /^\d+$/) {
+ $first = sprintf("%#o", $first);
+ }
+ $first = "+$first" if not $parens and substr($first, 0, 1) eq "(";
+ push @exprs, $first;
+ $kid = $kid->sibling;
+ if (defined $proto && $proto =~ /^\*\*/ && $kid->name eq "rv2gv") {
+ push @exprs, $self->deparse($kid->first, 6);
+ $kid = $kid->sibling;
+ }
+ for (; !null($kid); $kid = $kid->sibling) {
+ push @exprs, $self->deparse($kid, 6);
+ }
+ if ($parens) {
+ return "$name(" . join(", ", @exprs) . ")";
+ } else {
+ return "$name " . join(", ", @exprs);
+ }
+}
+
+sub pp_bless { listop(@_, "bless") }
+sub pp_atan2 { maybe_targmy(@_, \&listop, "atan2") }
+sub pp_substr { maybe_local(@_, listop(@_, "substr")) }
+sub pp_vec { maybe_local(@_, listop(@_, "vec")) }
+sub pp_index { maybe_targmy(@_, \&listop, "index") }
+sub pp_rindex { maybe_targmy(@_, \&listop, "rindex") }
+sub pp_sprintf { maybe_targmy(@_, \&listop, "sprintf") }
+sub pp_formline { listop(@_, "formline") } # see also deparse_format
+sub pp_crypt { maybe_targmy(@_, \&listop, "crypt") }
+sub pp_unpack { listop(@_, "unpack") }
+sub pp_pack { listop(@_, "pack") }
+sub pp_join { maybe_targmy(@_, \&listop, "join") }
+sub pp_splice { listop(@_, "splice") }
+sub pp_push { maybe_targmy(@_, \&listop, "push") }
+sub pp_unshift { maybe_targmy(@_, \&listop, "unshift") }
+sub pp_reverse { listop(@_, "reverse") }
+sub pp_warn { listop(@_, "warn") }
+sub pp_die { listop(@_, "die") }
+# Actually, return is exempt from the LLAFR (see examples in this very
+# module!), but for consistency's sake, ignore that fact
+sub pp_return { listop(@_, "return") }
+sub pp_open { listop(@_, "open") }
+sub pp_pipe_op { listop(@_, "pipe") }
+sub pp_tie { listop(@_, "tie") }
+sub pp_binmode { listop(@_, "binmode") }
+sub pp_dbmopen { listop(@_, "dbmopen") }
+sub pp_sselect { listop(@_, "select") }
+sub pp_select { listop(@_, "select") }
+sub pp_read { listop(@_, "read") }
+sub pp_sysopen { listop(@_, "sysopen") }
+sub pp_sysseek { listop(@_, "sysseek") }
+sub pp_sysread { listop(@_, "sysread") }
+sub pp_syswrite { listop(@_, "syswrite") }
+sub pp_send { listop(@_, "send") }
+sub pp_recv { listop(@_, "recv") }
+sub pp_seek { listop(@_, "seek") }
+sub pp_fcntl { listop(@_, "fcntl") }
+sub pp_ioctl { listop(@_, "ioctl") }
+sub pp_flock { maybe_targmy(@_, \&listop, "flock") }
+sub pp_socket { listop(@_, "socket") }
+sub pp_sockpair { listop(@_, "sockpair") }
+sub pp_bind { listop(@_, "bind") }
+sub pp_connect { listop(@_, "connect") }
+sub pp_listen { listop(@_, "listen") }
+sub pp_accept { listop(@_, "accept") }
+sub pp_shutdown { listop(@_, "shutdown") }
+sub pp_gsockopt { listop(@_, "getsockopt") }
+sub pp_ssockopt { listop(@_, "setsockopt") }
+sub pp_chown { maybe_targmy(@_, \&listop, "chown") }
+sub pp_unlink { maybe_targmy(@_, \&listop, "unlink") }
+sub pp_chmod { maybe_targmy(@_, \&listop, "chmod") }
+sub pp_utime { maybe_targmy(@_, \&listop, "utime") }
+sub pp_rename { maybe_targmy(@_, \&listop, "rename") }
+sub pp_link { maybe_targmy(@_, \&listop, "link") }
+sub pp_symlink { maybe_targmy(@_, \&listop, "symlink") }
+sub pp_mkdir { maybe_targmy(@_, \&listop, "mkdir") }
+sub pp_open_dir { listop(@_, "opendir") }
+sub pp_seekdir { listop(@_, "seekdir") }
+sub pp_waitpid { maybe_targmy(@_, \&listop, "waitpid") }
+sub pp_system { maybe_targmy(@_, \&listop, "system") }
+sub pp_exec { maybe_targmy(@_, \&listop, "exec") }
+sub pp_kill { maybe_targmy(@_, \&listop, "kill") }
+sub pp_setpgrp { maybe_targmy(@_, \&listop, "setpgrp") }
+sub pp_getpriority { maybe_targmy(@_, \&listop, "getpriority") }
+sub pp_setpriority { maybe_targmy(@_, \&listop, "setpriority") }
+sub pp_shmget { listop(@_, "shmget") }
+sub pp_shmctl { listop(@_, "shmctl") }
+sub pp_shmread { listop(@_, "shmread") }
+sub pp_shmwrite { listop(@_, "shmwrite") }
+sub pp_msgget { listop(@_, "msgget") }
+sub pp_msgctl { listop(@_, "msgctl") }
+sub pp_msgsnd { listop(@_, "msgsnd") }
+sub pp_msgrcv { listop(@_, "msgrcv") }
+sub pp_semget { listop(@_, "semget") }
+sub pp_semctl { listop(@_, "semctl") }
+sub pp_semop { listop(@_, "semop") }
+sub pp_ghbyaddr { listop(@_, "gethostbyaddr") }
+sub pp_gnbyaddr { listop(@_, "getnetbyaddr") }
+sub pp_gpbynumber { listop(@_, "getprotobynumber") }
+sub pp_gsbyname { listop(@_, "getservbyname") }
+sub pp_gsbyport { listop(@_, "getservbyport") }
+sub pp_syscall { listop(@_, "syscall") }
+
+sub pp_glob {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my $text = $self->dq($op->first->sibling); # skip pushmark
+ if ($text =~ /^\$?(\w|::|\`)+$/ # could look like a readline
+ or $text =~ /[<>]/) {
+ return 'glob(' . single_delim('qq', '"', $text) . ')';
+ } else {
+ return '<' . $text . '>';
+ }
+}
+
+# Truncate is special because OPf_SPECIAL makes a bareword first arg
+# be a filehandle. This could probably be better fixed in the core
+# by moving the GV lookup into ck_truc.
+
+sub pp_truncate {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my(@exprs);
+ my $parens = ($cx >= 5) || $self->{'parens'};
+ my $kid = $op->first->sibling;
+ my $fh;
+ if ($op->flags & OPf_SPECIAL) {
+ # $kid is an OP_CONST
+ $fh = $self->const_sv($kid)->PV;
+ } else {
+ $fh = $self->deparse($kid, 6);
+ $fh = "+$fh" if not $parens and substr($fh, 0, 1) eq "(";
+ }
+ my $len = $self->deparse($kid->sibling, 6);
+ if ($parens) {
+ return "truncate($fh, $len)";
+ } else {
+ return "truncate $fh, $len";
+ }
+}
+
+sub indirop {
+ my $self = shift;
+ my($op, $cx, $name) = @_;
+ my($expr, @exprs);
+ my $kid = $op->first->sibling;
+ my $indir = "";
+ if ($op->flags & OPf_STACKED) {
+ $indir = $kid;
+ $indir = $indir->first; # skip rv2gv
+ if (is_scope($indir)) {
+ $indir = "{" . $self->deparse($indir, 0) . "}";
+ $indir = "{;}" if $indir eq "{}";
+ } elsif ($indir->name eq "const" && $indir->private & OPpCONST_BARE) {
+ $indir = $self->const_sv($indir)->PV;
+ } else {
+ $indir = $self->deparse($indir, 24);
+ }
+ $indir = $indir . " ";
+ $kid = $kid->sibling;
+ }
+ if ($name eq "sort" && $op->private & (OPpSORT_NUMERIC | OPpSORT_INTEGER)) {
+ $indir = ($op->private & OPpSORT_DESCEND) ? '{$b <=> $a} '
+ : '{$a <=> $b} ';
+ }
+ elsif ($name eq "sort" && $op->private & OPpSORT_DESCEND) {
+ $indir = '{$b cmp $a} ';
+ }
+ for (; !null($kid); $kid = $kid->sibling) {
+ $expr = $self->deparse($kid, 6);
+ push @exprs, $expr;
+ }
+ my $name2 = $name;
+ if ($name eq "sort" && $op->private & OPpSORT_REVERSE) {
+ $name2 = 'reverse sort';
+ }
+ if ($name eq "sort" && ($op->private & OPpSORT_INPLACE)) {
+ return "$exprs[0] = $name2 $indir $exprs[0]";
+ }
+
+ my $args = $indir . join(", ", @exprs);
+ if ($indir ne "" and $name eq "sort") {
+ # We don't want to say "sort(f 1, 2, 3)", since perl -w will
+ # give bareword warnings in that case. Therefore if context
+ # requires, we'll put parens around the outside "(sort f 1, 2,
+ # 3)". Unfortunately, we'll currently think the parens are
+ # necessary more often that they really are, because we don't
+ # distinguish which side of an assignment we're on.
+ if ($cx >= 5) {
+ return "($name2 $args)";
+ } else {
+ return "$name2 $args";
+ }
+ } else {
+ return $self->maybe_parens_func($name2, $args, $cx, 5);
+ }
+
+}
+
+sub pp_prtf { indirop(@_, "printf") }
+sub pp_print { indirop(@_, "print") }
+sub pp_say { indirop(@_, "say") }
+sub pp_sort { indirop(@_, "sort") }
+
+sub mapop {
+ my $self = shift;
+ my($op, $cx, $name) = @_;
+ my($expr, @exprs);
+ my $kid = $op->first; # this is the (map|grep)start
+ $kid = $kid->first->sibling; # skip a pushmark
+ my $code = $kid->first; # skip a null
+ if (is_scope $code) {
+ $code = "{" . $self->deparse($code, 0) . "} ";
+ } else {
+ $code = $self->deparse($code, 24) . ", ";
+ }
+ $kid = $kid->sibling;
+ for (; !null($kid); $kid = $kid->sibling) {
+ $expr = $self->deparse($kid, 6);
+ push @exprs, $expr if defined $expr;
+ }
+ return $self->maybe_parens_func($name, $code . join(", ", @exprs), $cx, 5);
+}
+
+sub pp_mapwhile { mapop(@_, "map") }
+sub pp_grepwhile { mapop(@_, "grep") }
+sub pp_mapstart { baseop(@_, "map") }
+sub pp_grepstart { baseop(@_, "grep") }
+
+sub pp_list {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my($expr, @exprs);
+ my $kid = $op->first->sibling; # skip pushmark
+ my $lop;
+ my $local = "either"; # could be local(...), my(...), state(...) or our(...)
+ for ($lop = $kid; !null($lop); $lop = $lop->sibling) {
+ # This assumes that no other private flags equal 128, and that
+ # OPs that store things other than flags in their op_private,
+ # like OP_AELEMFAST, won't be immediate children of a list.
+ #
+ # OP_ENTERSUB can break this logic, so check for it.
+ # I suspect that open and exit can too.
+
+ if (!($lop->private & (OPpLVAL_INTRO|OPpOUR_INTRO)
+ or $lop->name eq "undef")
+ or $lop->name eq "entersub"
+ or $lop->name eq "exit"
+ or $lop->name eq "open")
+ {
+ $local = ""; # or not
+ last;
+ }
+ if ($lop->name =~ /^pad[ash]v$/) {
+ if ($lop->private & OPpPAD_STATE) { # state()
+ ($local = "", last) if $local =~ /^(?:local|our|my)$/;
+ $local = "state";
+ } else { # my()
+ ($local = "", last) if $local =~ /^(?:local|our|state)$/;
+ $local = "my";
+ }
+ } elsif ($lop->name =~ /^(gv|rv2)[ash]v$/
+ && $lop->private & OPpOUR_INTRO
+ or $lop->name eq "null" && $lop->first->name eq "gvsv"
+ && $lop->first->private & OPpOUR_INTRO) { # our()
+ ($local = "", last) if $local =~ /^(?:my|local|state)$/;
+ $local = "our";
+ } elsif ($lop->name ne "undef"
+ # specifically avoid the "reverse sort" optimisation,
+ # where "reverse" is nullified
+ && !($lop->name eq 'sort' && ($lop->flags & OPpSORT_REVERSE)))
+ {
+ # local()
+ ($local = "", last) if $local =~ /^(?:my|our|state)$/;
+ $local = "local";
+ }
+ }
+ $local = "" if $local eq "either"; # no point if it's all undefs
+ return $self->deparse($kid, $cx) if null $kid->sibling and not $local;
+ for (; !null($kid); $kid = $kid->sibling) {
+ if ($local) {
+ if (class($kid) eq "UNOP" and $kid->first->name eq "gvsv") {
+ $lop = $kid->first;
+ } else {
+ $lop = $kid;
+ }
+ $self->{'avoid_local'}{$$lop}++;
+ $expr = $self->deparse($kid, 6);
+ delete $self->{'avoid_local'}{$$lop};
+ } else {
+ $expr = $self->deparse($kid, 6);
+ }
+ push @exprs, $expr;
+ }
+ if ($local) {
+ return "$local(" . join(", ", @exprs) . ")";
+ } else {
+ return $self->maybe_parens( join(", ", @exprs), $cx, 6);
+ }
+}
+
+sub is_ifelse_cont {
+ my $op = shift;
+ return ($op->name eq "null" and class($op) eq "UNOP"
+ and $op->first->name =~ /^(and|cond_expr)$/
+ and is_scope($op->first->first->sibling));
+}
+
+sub pp_cond_expr {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my $cond = $op->first;
+ my $true = $cond->sibling;
+ my $false = $true->sibling;
+ my $cuddle = $self->{'cuddle'};
+ unless ($cx < 1 and (is_scope($true) and $true->name ne "null") and
+ (is_scope($false) || is_ifelse_cont($false))
+ and $self->{'expand'} < 7) {
+ $cond = $self->deparse($cond, 8);
+ $true = $self->deparse($true, 6);
+ $false = $self->deparse($false, 8);
+ return $self->maybe_parens("$cond ? $true : $false", $cx, 8);
+ }
+
+ $cond = $self->deparse($cond, 1);
+ $true = $self->deparse($true, 0);
+ my $head = "if ($cond) {\n\t$true\n\b}";
+ my @elsifs;
+ while (!null($false) and is_ifelse_cont($false)) {
+ my $newop = $false->first;
+ my $newcond = $newop->first;
+ my $newtrue = $newcond->sibling;
+ $false = $newtrue->sibling; # last in chain is OP_AND => no else
+ if ($newcond->name eq "lineseq")
+ {
+ # lineseq to ensure correct line numbers in elsif()
+ # Bug #37302 fixed by change #33710.
+ $newcond = $newcond->first->sibling;
+ }
+ $newcond = $self->deparse($newcond, 1);
+ $newtrue = $self->deparse($newtrue, 0);
+ push @elsifs, "elsif ($newcond) {\n\t$newtrue\n\b}";
+ }
+ if (!null($false)) {
+ $false = $cuddle . "else {\n\t" .
+ $self->deparse($false, 0) . "\n\b}\cK";
+ } else {
+ $false = "\cK";
+ }
+ return $head . join($cuddle, "", @elsifs) . $false;
+}
+
+sub pp_once {
+ my ($self, $op, $cx) = @_;
+ my $cond = $op->first;
+ my $true = $cond->sibling;
+
+ return $self->deparse($true, $cx);
+}
+
+sub loop_common {
+ my $self = shift;
+ my($op, $cx, $init) = @_;
+ my $enter = $op->first;
+ my $kid = $enter->sibling;
+ local(@$self{qw'curstash warnings hints hinthash'})
+ = @$self{qw'curstash warnings hints hinthash'};
+ my $head = "";
+ my $bare = 0;
+ my $body;
+ my $cond = undef;
+ if ($kid->name eq "lineseq") { # bare or infinite loop
+ if ($kid->last->name eq "unstack") { # infinite
+ $head = "while (1) "; # Can't use for(;;) if there's a continue
+ $cond = "";
+ } else {
+ $bare = 1;
+ }
+ $body = $kid;
+ } elsif ($enter->name eq "enteriter") { # foreach
+ my $ary = $enter->first->sibling; # first was pushmark
+ my $var = $ary->sibling;
+ if ($ary->name eq 'null' and $enter->private & OPpITER_REVERSED) {
+ # "reverse" was optimised away
+ $ary = listop($self, $ary->first->sibling, 1, 'reverse');
+ } elsif ($enter->flags & OPf_STACKED
+ and not null $ary->first->sibling->sibling)
+ {
+ $ary = $self->deparse($ary->first->sibling, 9) . " .. " .
+ $self->deparse($ary->first->sibling->sibling, 9);
+ } else {
+ $ary = $self->deparse($ary, 1);
+ }
+ if (null $var) {
+ if ($enter->flags & OPf_SPECIAL) { # thread special var
+ $var = $self->pp_threadsv($enter, 1);
+ } else { # regular my() variable
+ $var = $self->pp_padsv($enter, 1);
+ }
+ } elsif ($var->name eq "rv2gv") {
+ $var = $self->pp_rv2sv($var, 1);
+ if ($enter->private & OPpOUR_INTRO) {
+ # our declarations don't have package names
+ $var =~ s/^(.).*::/$1/;
+ $var = "our $var";
+ }
+ } elsif ($var->name eq "gv") {
+ $var = "\$" . $self->deparse($var, 1);
+ }
+ $body = $kid->first->first->sibling; # skip OP_AND and OP_ITER
+ if (!is_state $body->first and $body->first->name ne "stub") {
+ confess unless $var eq '$_';
+ $body = $body->first;
+ return $self->deparse($body, 2) . " foreach ($ary)";
+ }
+ $head = "foreach $var ($ary) ";
+ } elsif ($kid->name eq "null") { # while/until
+ $kid = $kid->first;
+ my $name = {"and" => "while", "or" => "until"}->{$kid->name};
+ $cond = $self->deparse($kid->first, 1);
+ $head = "$name ($cond) ";
+ $body = $kid->first->sibling;
+ } elsif ($kid->name eq "stub") { # bare and empty
+ return "{;}"; # {} could be a hashref
+ }
+ # If there isn't a continue block, then the next pointer for the loop
+ # will point to the unstack, which is kid's last child, except
+ # in a bare loop, when it will point to the leaveloop. When neither of
+ # these conditions hold, then the second-to-last child is the continue
+ # block (or the last in a bare loop).
+ my $cont_start = $enter->nextop;
+ my $cont;
+ if ($$cont_start != $$op && ${$cont_start} != ${$body->last}) {
+ if ($bare) {
+ $cont = $body->last;
+ } else {
+ $cont = $body->first;
+ while (!null($cont->sibling->sibling)) {
+ $cont = $cont->sibling;
+ }
+ }
+ my $state = $body->first;
+ my $cuddle = $self->{'cuddle'};
+ my @states;
+ for (; $$state != $$cont; $state = $state->sibling) {
+ push @states, $state;
+ }
+ $body = $self->lineseq(undef, @states);
+ if (defined $cond and not is_scope $cont and $self->{'expand'} < 3) {
+ $head = "for ($init; $cond; " . $self->deparse($cont, 1) .") ";
+ $cont = "\cK";
+ } else {
+ $cont = $cuddle . "continue {\n\t" .
+ $self->deparse($cont, 0) . "\n\b}\cK";
+ }
+ } else {
+ return "" if !defined $body;
+ if (length $init) {
+ $head = "for ($init; $cond;) ";
+ }
+ $cont = "\cK";
+ $body = $self->deparse($body, 0);
+ }
+ $body =~ s/;?$/;\n/;
+
+ return $head . "{\n\t" . $body . "\b}" . $cont;
+}
+
+sub pp_leaveloop { shift->loop_common(@_, "") }
+
+sub for_loop {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my $init = $self->deparse($op, 1);
+ return $self->loop_common($op->sibling->first->sibling, $cx, $init);
+}
+
+sub pp_leavetry {
+ my $self = shift;
+ return "eval {\n\t" . $self->pp_leave(@_) . "\n\b}";
+}
+
+BEGIN { eval "sub OP_CONST () {" . opnumber("const") . "}" }
+BEGIN { eval "sub OP_STRINGIFY () {" . opnumber("stringify") . "}" }
+BEGIN { eval "sub OP_RV2SV () {" . opnumber("rv2sv") . "}" }
+BEGIN { eval "sub OP_LIST () {" . opnumber("list") . "}" }
+
+sub pp_null {
+ my $self = shift;
+ my($op, $cx) = @_;
+ if (class($op) eq "OP") {
+ # old value is lost
+ return $self->{'ex_const'} if $op->targ == OP_CONST;
+ } elsif ($op->first->name eq "pushmark") {
+ return $self->pp_list($op, $cx);
+ } elsif ($op->first->name eq "enter") {
+ return $self->pp_leave($op, $cx);
+ } elsif ($op->first->name eq "leave") {
+ return $self->pp_leave($op->first, $cx);
+ } elsif ($op->first->name eq "scope") {
+ return $self->pp_scope($op->first, $cx);
+ } elsif ($op->targ == OP_STRINGIFY) {
+ return $self->dquote($op, $cx);
+ } elsif (!null($op->first->sibling) and
+ $op->first->sibling->name eq "readline" and
+ $op->first->sibling->flags & OPf_STACKED) {
+ return $self->maybe_parens($self->deparse($op->first, 7) . " = "
+ . $self->deparse($op->first->sibling, 7),
+ $cx, 7);
+ } elsif (!null($op->first->sibling) and
+ $op->first->sibling->name eq "trans" and
+ $op->first->sibling->flags & OPf_STACKED) {
+ return $self->maybe_parens($self->deparse($op->first, 20) . " =~ "
+ . $self->deparse($op->first->sibling, 20),
+ $cx, 20);
+ } elsif ($op->flags & OPf_SPECIAL && $cx < 1 && !$op->targ) {
+ return "do {\n\t". $self->deparse($op->first, $cx) ."\n\b};";
+ } elsif (!null($op->first->sibling) and
+ $op->first->sibling->name eq "null" and
+ class($op->first->sibling) eq "UNOP" and
+ $op->first->sibling->first->flags & OPf_STACKED and
+ $op->first->sibling->first->name eq "rcatline") {
+ return $self->maybe_parens($self->deparse($op->first, 18) . " .= "
+ . $self->deparse($op->first->sibling, 18),
+ $cx, 18);
+ } else {
+ return $self->deparse($op->first, $cx);
+ }
+}
+
+sub padname {
+ my $self = shift;
+ my $targ = shift;
+ return $self->padname_sv($targ)->PVX;
+}
+
+sub padany {
+ my $self = shift;
+ my $op = shift;
+ return substr($self->padname($op->targ), 1); # skip $/@/%
+}
+
+sub pp_padsv {
+ my $self = shift;
+ my($op, $cx) = @_;
+ return $self->maybe_my($op, $cx, $self->padname($op->targ));
+}
+
+sub pp_padav { pp_padsv(@_) }
+sub pp_padhv { pp_padsv(@_) }
+
+my @threadsv_names;
+
+BEGIN {
+ @threadsv_names = ("_", "1", "2", "3", "4", "5", "6", "7", "8", "9",
+ "&", "`", "'", "+", "/", ".", ",", "\\", '"', ";",
+ "^", "-", "%", "=", "|", "~", ":", "^A", "^E",
+ "!", "@");
+}
+
+sub pp_threadsv {
+ my $self = shift;
+ my($op, $cx) = @_;
+ return $self->maybe_local($op, $cx, "\$" . $threadsv_names[$op->targ]);
+}
+
+sub gv_or_padgv {
+ my $self = shift;
+ my $op = shift;
+ if (class($op) eq "PADOP") {
+ return $self->padval($op->padix);
+ } else { # class($op) eq "SVOP"
+ return $op->gv;
+ }
+}
+
+sub pp_gvsv {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my $gv = $self->gv_or_padgv($op);
+ return $self->maybe_local($op, $cx, $self->stash_variable("\$",
+ $self->gv_name($gv)));
+}
+
+sub pp_gv {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my $gv = $self->gv_or_padgv($op);
+ return $self->gv_name($gv);
+}
+
+sub pp_aelemfast {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my $name;
+ if ($op->flags & OPf_SPECIAL) { # optimised PADAV
+ $name = $self->padname($op->targ);
+ $name =~ s/^@/\$/;
+ }
+ else {
+ my $gv = $self->gv_or_padgv($op);
+ $name = $self->gv_name($gv);
+ $name = $self->{'curstash'}."::$name"
+ if $name !~ /::/ && $self->lex_in_scope('@'.$name);
+ $name = '$' . $name;
+ }
+
+ return $name . "[" . ($op->private + $self->{'arybase'}) . "]";
+}
+
+sub rv2x {
+ my $self = shift;
+ my($op, $cx, $type) = @_;
+
+ if (class($op) eq 'NULL' || !$op->can("first")) {
+ carp("Unexpected op in pp_rv2x");
+ return 'XXX';
+ }
+ my $kid = $op->first;
+ if ($kid->name eq "gv") {
+ return $self->stash_variable($type, $self->deparse($kid, 0));
+ } elsif (is_scalar $kid) {
+ my $str = $self->deparse($kid, 0);
+ if ($str =~ /^\$([^\w\d])\z/) {
+ # "$$+" isn't a legal way to write the scalar dereference
+ # of $+, since the lexer can't tell you aren't trying to
+ # do something like "$$ + 1" to get one more than your
+ # PID. Either "${$+}" or "$${+}" are workable
+ # disambiguations, but if the programmer did the former,
+ # they'd be in the "else" clause below rather than here.
+ # It's not clear if this should somehow be unified with
+ # the code in dq and re_dq that also adds lexer
+ # disambiguation braces.
+ $str = '$' . "{$1}"; #'
+ }
+ return $type . $str;
+ } else {
+ return $type . "{" . $self->deparse($kid, 0) . "}";
+ }
+}
+
+sub pp_rv2sv { maybe_local(@_, rv2x(@_, "\$")) }
+sub pp_rv2hv { maybe_local(@_, rv2x(@_, "%")) }
+sub pp_rv2gv { maybe_local(@_, rv2x(@_, "*")) }
+
+# skip rv2av
+sub pp_av2arylen {
+ my $self = shift;
+ my($op, $cx) = @_;
+ if ($op->first->name eq "padav") {
+ return $self->maybe_local($op, $cx, '$#' . $self->padany($op->first));
+ } else {
+ return $self->maybe_local($op, $cx,
+ $self->rv2x($op->first, $cx, '$#'));
+ }
+}
+
+# skip down to the old, ex-rv2cv
+sub pp_rv2cv {
+ my ($self, $op, $cx) = @_;
+ if (!null($op->first) && $op->first->name eq 'null' &&
+ $op->first->targ eq OP_LIST)
+ {
+ return $self->rv2x($op->first->first->sibling, $cx, "&")
+ }
+ else {
+ return $self->rv2x($op, $cx, "")
+ }
+}
+
+sub list_const {
+ my $self = shift;
+ my($cx, @list) = @_;
+ my @a = map $self->const($_, 6), @list;
+ if (@a == 0) {
+ return "()";
+ } elsif (@a == 1) {
+ return $a[0];
+ } elsif ( @a > 2 and !grep(!/^-?\d+$/, @a)) {
+ # collapse (-1,0,1,2) into (-1..2)
+ my ($s, $e) = @a[0,-1];
+ my $i = $s;
+ return $self->maybe_parens("$s..$e", $cx, 9)
+ unless grep $i++ != $_, @a;
+ }
+ return $self->maybe_parens(join(", ", @a), $cx, 6);
+}
+
+sub pp_rv2av {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my $kid = $op->first;
+ if ($kid->name eq "const") { # constant list
+ my $av = $self->const_sv($kid);
+ return $self->list_const($cx, $av->ARRAY);
+ } else {
+ return $self->maybe_local($op, $cx, $self->rv2x($op, $cx, "\@"));
+ }
+ }
+
+sub is_subscriptable {
+ my $op = shift;
+ if ($op->name =~ /^[ahg]elem/) {
+ return 1;
+ } elsif ($op->name eq "entersub") {
+ my $kid = $op->first;
+ return 0 unless null $kid->sibling;
+ $kid = $kid->first;
+ $kid = $kid->sibling until null $kid->sibling;
+ return 0 if is_scope($kid);
+ $kid = $kid->first;
+ return 0 if $kid->name eq "gv";
+ return 0 if is_scalar($kid);
+ return is_subscriptable($kid);
+ } else {
+ return 0;
+ }
+}
+
+sub elem_or_slice_array_name
+{
+ my $self = shift;
+ my ($array, $left, $padname, $allow_arrow) = @_;
+
+ if ($array->name eq $padname) {
+ return $self->padany($array);
+ } elsif (is_scope($array)) { # ${expr}[0]
+ return "{" . $self->deparse($array, 0) . "}";
+ } elsif ($array->name eq "gv") {
+ $array = $self->gv_name($self->gv_or_padgv($array));
+ if ($array !~ /::/) {
+ my $prefix = ($left eq '[' ? '@' : '%');
+ $array = $self->{curstash}.'::'.$array
+ if $self->lex_in_scope($prefix . $array);
+ }
+ return $array;
+ } elsif (!$allow_arrow || is_scalar $array) { # $x[0], $$x[0], ...
+ return $self->deparse($array, 24);
+ } else {
+ return undef;
+ }
+}
+
+sub elem_or_slice_single_index
+{
+ my $self = shift;
+ my ($idx) = @_;
+
+ $idx = $self->deparse($idx, 1);
+
+ # Outer parens in an array index will confuse perl
+ # if we're interpolating in a regular expression, i.e.
+ # /$x$foo[(-1)]/ is *not* the same as /$x$foo[-1]/
+ #
+ # If $self->{parens}, then an initial '(' will
+ # definitely be paired with a final ')'. If
+ # !$self->{parens}, the misleading parens won't
+ # have been added in the first place.
+ #
+ # [You might think that we could get "(...)...(...)"
+ # where the initial and final parens do not match
+ # each other. But we can't, because the above would
+ # only happen if there's an infix binop between the
+ # two pairs of parens, and *that* means that the whole
+ # expression would be parenthesized as well.]
+ #
+ $idx =~ s/^\((.*)\)$/$1/ if $self->{'parens'};
+
+ # Hash-element braces will autoquote a bareword inside themselves.
+ # We need to make sure that C<$hash{warn()}> doesn't come out as
+ # C<$hash{warn}>, which has a quite different meaning. Currently
+ # B::Deparse will always quote strings, even if the string was a
+ # bareword in the original (i.e. the OPpCONST_BARE flag is ignored
+ # for constant strings.) So we can cheat slightly here - if we see
+ # a bareword, we know that it is supposed to be a function call.
+ #
+ $idx =~ s/^([A-Za-z_]\w*)$/$1()/;
+
+ return $idx;
+}
+
+sub elem {
+ my $self = shift;
+ my ($op, $cx, $left, $right, $padname) = @_;
+ my($array, $idx) = ($op->first, $op->first->sibling);
+
+ $idx = $self->elem_or_slice_single_index($idx);
+
+ unless ($array->name eq $padname) { # Maybe this has been fixed
+ $array = $array->first; # skip rv2av (or ex-rv2av in _53+)
+ }
+ if (my $array_name=$self->elem_or_slice_array_name
+ ($array, $left, $padname, 1)) {
+ return "\$" . $array_name . $left . $idx . $right;
+ } else {
+ # $x[20][3]{hi} or expr->[20]
+ my $arrow = is_subscriptable($array) ? "" : "->";
+ return $self->deparse($array, 24) . $arrow . $left . $idx . $right;
+ }
+
+}
+
+sub pp_aelem { maybe_local(@_, elem(@_, "[", "]", "padav")) }
+sub pp_helem { maybe_local(@_, elem(@_, "{", "}", "padhv")) }
+
+sub pp_gelem {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my($glob, $part) = ($op->first, $op->last);
+ $glob = $glob->first; # skip rv2gv
+ $glob = $glob->first if $glob->name eq "rv2gv"; # this one's a bug
+ my $scope = is_scope($glob);
+ $glob = $self->deparse($glob, 0);
+ $part = $self->deparse($part, 1);
+ return "*" . ($scope ? "{$glob}" : $glob) . "{$part}";
+}
+
+sub slice {
+ my $self = shift;
+ my ($op, $cx, $left, $right, $regname, $padname) = @_;
+ my $last;
+ my(@elems, $kid, $array, $list);
+ if (class($op) eq "LISTOP") {
+ $last = $op->last;
+ } else { # ex-hslice inside delete()
+ for ($kid = $op->first; !null $kid->sibling; $kid = $kid->sibling) {}
+ $last = $kid;
+ }
+ $array = $last;
+ $array = $array->first
+ if $array->name eq $regname or $array->name eq "null";
+ $array = $self->elem_or_slice_array_name($array,$left,$padname,0);
+ $kid = $op->first->sibling; # skip pushmark
+ if ($kid->name eq "list") {
+ $kid = $kid->first->sibling; # skip list, pushmark
+ for (; !null $kid; $kid = $kid->sibling) {
+ push @elems, $self->deparse($kid, 6);
+ }
+ $list = join(", ", @elems);
+ } else {
+ $list = $self->elem_or_slice_single_index($kid);
+ }
+ return "\@" . $array . $left . $list . $right;
+}
+
+sub pp_aslice { maybe_local(@_, slice(@_, "[", "]", "rv2av", "padav")) }
+sub pp_hslice { maybe_local(@_, slice(@_, "{", "}", "rv2hv", "padhv")) }
+
+sub pp_lslice {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my $idx = $op->first;
+ my $list = $op->last;
+ my(@elems, $kid);
+ $list = $self->deparse($list, 1);
+ $idx = $self->deparse($idx, 1);
+ return "($list)" . "[$idx]";
+}
+
+sub want_scalar {
+ my $op = shift;
+ return ($op->flags & OPf_WANT) == OPf_WANT_SCALAR;
+}
+
+sub want_list {
+ my $op = shift;
+ return ($op->flags & OPf_WANT) == OPf_WANT_LIST;
+}
+
+sub _method {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my $kid = $op->first->sibling; # skip pushmark
+ my($meth, $obj, @exprs);
+ if ($kid->name eq "list" and want_list $kid) {
+ # When an indirect object isn't a bareword but the args are in
+ # parens, the parens aren't part of the method syntax (the LLAFR
+ # doesn't apply), but they make a list with OPf_PARENS set that
+ # doesn't get flattened by the append_elem that adds the method,
+ # making a (object, arg1, arg2, ...) list where the object
+ # usually is. This can be distinguished from
+ # `($obj, $arg1, $arg2)->meth()' (which is legal if $arg2 is an
+ # object) because in the later the list is in scalar context
+ # as the left side of -> always is, while in the former
+ # the list is in list context as method arguments always are.
+ # (Good thing there aren't method prototypes!)
+ $meth = $kid->sibling;
+ $kid = $kid->first->sibling; # skip pushmark
+ $obj = $kid;
+ $kid = $kid->sibling;
+ for (; not null $kid; $kid = $kid->sibling) {
+ push @exprs, $kid;
+ }
+ } else {
+ $obj = $kid;
+ $kid = $kid->sibling;
+ for (; !null ($kid->sibling) && $kid->name ne "method_named";
+ $kid = $kid->sibling) {
+ push @exprs, $kid
+ }
+ $meth = $kid;
+ }
+
+ if ($meth->name eq "method_named") {
+ $meth = $self->const_sv($meth)->PV;
+ } else {
+ $meth = $meth->first;
+ if ($meth->name eq "const") {
+ # As of 5.005_58, this case is probably obsoleted by the
+ # method_named case above
+ $meth = $self->const_sv($meth)->PV; # needs to be bare
+ }
+ }
+
+ return { method => $meth, variable_method => ref($meth),
+ object => $obj, args => \@exprs };
+}
+
+# compat function only
+sub method {
+ my $self = shift;
+ my $info = $self->_method(@_);
+ return $self->e_method( $self->_method(@_) );
+}
+
+sub e_method {
+ my ($self, $info) = @_;
+ my $obj = $self->deparse($info->{object}, 24);
+
+ my $meth = $info->{method};
+ $meth = $self->deparse($meth, 1) if $info->{variable_method};
+ my $args = join(", ", map { $self->deparse($_, 6) } @{$info->{args}} );
+ my $kid = $obj . "->" . $meth;
+ if (length $args) {
+ return $kid . "(" . $args . ")"; # parens mandatory
+ } else {
+ return $kid;
+ }
+}
+
+# returns "&" if the prototype doesn't match the args,
+# or ("", $args_after_prototype_demunging) if it does.
+sub check_proto {
+ my $self = shift;
+ return "&" if $self->{'noproto'};
+ my($proto, @args) = @_;
+ my($arg, $real);
+ my $doneok = 0;
+ my @reals;
+ # An unbackslashed @ or % gobbles up the rest of the args
+ 1 while $proto =~ s/(?<!\\)([@%])[^\]]+$/$1/;
+ while ($proto) {
+ $proto =~ s/^(\\?[\$\@&%*_]|\\\[[\$\@&%*]+\]|;)//;
+ my $chr = $1;
+ if ($chr eq "") {
+ return "&" if @args;
+ } elsif ($chr eq ";") {
+ $doneok = 1;
+ } elsif ($chr eq "@" or $chr eq "%") {
+ push @reals, map($self->deparse($_, 6), @args);
+ @args = ();
+ } else {
+ $arg = shift @args;
+ last unless $arg;
+ if ($chr eq "\$" || $chr eq "_") {
+ if (want_scalar $arg) {
+ push @reals, $self->deparse($arg, 6);
+ } else {
+ return "&";
+ }
+ } elsif ($chr eq "&") {
+ if ($arg->name =~ /^(s?refgen|undef)$/) {
+ push @reals, $self->deparse($arg, 6);
+ } else {
+ return "&";
+ }
+ } elsif ($chr eq "*") {
+ if ($arg->name =~ /^s?refgen$/
+ and $arg->first->first->name eq "rv2gv")
+ {
+ $real = $arg->first->first; # skip refgen, null
+ if ($real->first->name eq "gv") {
+ push @reals, $self->deparse($real, 6);
+ } else {
+ push @reals, $self->deparse($real->first, 6);
+ }
+ } else {
+ return "&";
+ }
+ } elsif (substr($chr, 0, 1) eq "\\") {
+ $chr =~ tr/\\[]//d;
+ if ($arg->name =~ /^s?refgen$/ and
+ !null($real = $arg->first) and
+ ($chr =~ /\$/ && is_scalar($real->first)
+ or ($chr =~ /@/
+ && class($real->first->sibling) ne 'NULL'
+ && $real->first->sibling->name
+ =~ /^(rv2|pad)av$/)
+ or ($chr =~ /%/
+ && class($real->first->sibling) ne 'NULL'
+ && $real->first->sibling->name
+ =~ /^(rv2|pad)hv$/)
+ #or ($chr =~ /&/ # This doesn't work
+ # && $real->first->name eq "rv2cv")
+ or ($chr =~ /\*/
+ && $real->first->name eq "rv2gv")))
+ {
+ push @reals, $self->deparse($real, 6);
+ } else {
+ return "&";
+ }
+ }
+ }
+ }
+ return "&" if $proto and !$doneok; # too few args and no `;'
+ return "&" if @args; # too many args
+ return ("", join ", ", @reals);
+}
+
+sub pp_entersub {
+ my $self = shift;
+ my($op, $cx) = @_;
+ return $self->e_method($self->_method($op, $cx))
+ unless null $op->first->sibling;
+ my $prefix = "";
+ my $amper = "";
+ my($kid, @exprs);
+ if ($op->flags & OPf_SPECIAL && !($op->flags & OPf_MOD)) {
+ $prefix = "do ";
+ } elsif ($op->private & OPpENTERSUB_AMPER) {
+ $amper = "&";
+ }
+ $kid = $op->first;
+ $kid = $kid->first->sibling; # skip ex-list, pushmark
+ for (; not null $kid->sibling; $kid = $kid->sibling) {
+ push @exprs, $kid;
+ }
+ my $simple = 0;
+ my $proto = undef;
+ if (is_scope($kid)) {
+ $amper = "&";
+ $kid = "{" . $self->deparse($kid, 0) . "}";
+ } elsif ($kid->first->name eq "gv") {
+ my $gv = $self->gv_or_padgv($kid->first);
+ if (class($gv->CV) ne "SPECIAL") {
+ $proto = $gv->CV->PV if $gv->CV->FLAGS & SVf_POK;
+ }
+ $simple = 1; # only calls of named functions can be prototyped
+ $kid = $self->deparse($kid, 24);
+ if (!$amper) {
+ if ($kid eq 'main::') {
+ $kid = '::';
+ } elsif ($kid !~ /^(?:\w|::)(?:[\w\d]|::(?!\z))*\z/) {
+ $kid = single_delim("q", "'", $kid) . '->';
+ }
+ }
+ } elsif (is_scalar ($kid->first) && $kid->first->name ne 'rv2cv') {
+ $amper = "&";
+ $kid = $self->deparse($kid, 24);
+ } else {
+ $prefix = "";
+ my $arrow = is_subscriptable($kid->first) ? "" : "->";
+ $kid = $self->deparse($kid, 24) . $arrow;
+ }
+
+ # Doesn't matter how many prototypes there are, if
+ # they haven't happened yet!
+ my $declared;
+ {
+ no strict 'refs';
+ no warnings 'uninitialized';
+ $declared = exists $self->{'subs_declared'}{$kid}
+ || (
+ defined &{ ${$self->{'curstash'}."::"}{$kid} }
+ && !exists
+ $self->{'subs_deparsed'}{$self->{'curstash'}."::".$kid}
+ && defined prototype $self->{'curstash'}."::".$kid
+ );
+ if (!$declared && defined($proto)) {
+ # Avoid "too early to check prototype" warning
+ ($amper, $proto) = ('&');
+ }
+ }
+
+ my $args;
+ if ($declared and defined $proto and not $amper) {
+ ($amper, $args) = $self->check_proto($proto, @exprs);
+ if ($amper eq "&") {
+ $args = join(", ", map($self->deparse($_, 6), @exprs));
+ }
+ } else {
+ $args = join(", ", map($self->deparse($_, 6), @exprs));
+ }
+ if ($prefix or $amper) {
+ if ($op->flags & OPf_STACKED) {
+ return $prefix . $amper . $kid . "(" . $args . ")";
+ } else {
+ return $prefix . $amper. $kid;
+ }
+ } else {
+ # glob() invocations can be translated into calls of
+ # CORE::GLOBAL::glob with a second parameter, a number.
+ # Reverse this.
+ if ($kid eq "CORE::GLOBAL::glob") {
+ $kid = "glob";
+ $args =~ s/\s*,[^,]+$//;
+ }
+
+ # It's a syntax error to call CORE::GLOBAL::foo without a prefix,
+ # so it must have been translated from a keyword call. Translate
+ # it back.
+ $kid =~ s/^CORE::GLOBAL:://;
+
+ my $dproto = defined($proto) ? $proto : "undefined";
+ if (!$declared) {
+ return "$kid(" . $args . ")";
+ } elsif ($dproto eq "") {
+ return $kid;
+ } elsif ($dproto eq "\$" and is_scalar($exprs[0])) {
+ # is_scalar is an excessively conservative test here:
+ # really, we should be comparing to the precedence of the
+ # top operator of $exprs[0] (ala unop()), but that would
+ # take some major code restructuring to do right.
+ return $self->maybe_parens_func($kid, $args, $cx, 16);
+ } elsif ($dproto ne '$' and defined($proto) || $simple) { #'
+ return $self->maybe_parens_func($kid, $args, $cx, 5);
+ } else {
+ return "$kid(" . $args . ")";
+ }
+ }
+}
+
+sub pp_enterwrite { unop(@_, "write") }
+
+# escape things that cause interpolation in double quotes,
+# but not character escapes
+sub uninterp {
+ my($str) = @_;
+ $str =~ s/(^|\G|[^\\])((?:\\\\)*)([\$\@]|\\[uUlLQE])/$1$2\\$3/g;
+ return $str;
+}
+
+{
+my $bal;
+BEGIN {
+ use re "eval";
+ # Matches any string which is balanced with respect to {braces}
+ $bal = qr(
+ (?:
+ [^\\{}]
+ | \\\\
+ | \\[{}]
+ | \{(??{$bal})\}
+ )*
+ )x;
+}
+
+# the same, but treat $|, $), $( and $ at the end of the string differently
+sub re_uninterp {
+ my($str) = @_;
+
+ $str =~ s/
+ ( ^|\G # $1
+ | [^\\]
+ )
+
+ ( # $2
+ (?:\\\\)*
+ )
+
+ ( # $3
+ (\(\?\??\{$bal\}\)) # $4
+ | [\$\@]
+ (?!\||\)|\(|$)
+ | \\[uUlLQE]
+ )
+
+ /defined($4) && length($4) ? "$1$2$4" : "$1$2\\$3"/xeg;
+
+ return $str;
+}
+
+# This is for regular expressions with the /x modifier
+# We have to leave comments unmangled.
+sub re_uninterp_extended {
+ my($str) = @_;
+
+ $str =~ s/
+ ( ^|\G # $1
+ | [^\\]
+ )
+
+ ( # $2
+ (?:\\\\)*
+ )
+
+ ( # $3
+ ( \(\?\??\{$bal\}\) # $4 (skip over (?{}) and (??{}) blocks)
+ | \#[^\n]* # (skip over comments)
+ )
+ | [\$\@]
+ (?!\||\)|\(|$|\s)
+ | \\[uUlLQE]
+ )
+
+ /defined($4) && length($4) ? "$1$2$4" : "$1$2\\$3"/xeg;
+
+ return $str;
+}
+}
+
+my %unctrl = # portable to to EBCDIC
+ (
+ "\c@" => '\c@', # unused
+ "\cA" => '\cA',
+ "\cB" => '\cB',
+ "\cC" => '\cC',
+ "\cD" => '\cD',
+ "\cE" => '\cE',
+ "\cF" => '\cF',
+ "\cG" => '\cG',
+ "\cH" => '\cH',
+ "\cI" => '\cI',
+ "\cJ" => '\cJ',
+ "\cK" => '\cK',
+ "\cL" => '\cL',
+ "\cM" => '\cM',
+ "\cN" => '\cN',
+ "\cO" => '\cO',
+ "\cP" => '\cP',
+ "\cQ" => '\cQ',
+ "\cR" => '\cR',
+ "\cS" => '\cS',
+ "\cT" => '\cT',
+ "\cU" => '\cU',
+ "\cV" => '\cV',
+ "\cW" => '\cW',
+ "\cX" => '\cX',
+ "\cY" => '\cY',
+ "\cZ" => '\cZ',
+ "\c[" => '\c[', # unused
+ "\c\\" => '\c\\', # unused
+ "\c]" => '\c]', # unused
+ "\c_" => '\c_', # unused
+ );
+
+# character escapes, but not delimiters that might need to be escaped
+sub escape_str { # ASCII, UTF8
+ my($str) = @_;
+ $str =~ s/(.)/ord($1) > 255 ? sprintf("\\x{%x}", ord($1)) : $1/eg;
+ $str =~ s/\a/\\a/g;
+# $str =~ s/\cH/\\b/g; # \b means something different in a regex
+ $str =~ s/\t/\\t/g;
+ $str =~ s/\n/\\n/g;
+ $str =~ s/\e/\\e/g;
+ $str =~ s/\f/\\f/g;
+ $str =~ s/\r/\\r/g;
+ $str =~ s/([\cA-\cZ])/$unctrl{$1}/ge;
+ $str =~ s/([[:^print:]])/sprintf("\\%03o", ord($1))/ge;
+ return $str;
+}
+
+# For regexes with the /x modifier.
+# Leave whitespace unmangled.
+sub escape_extended_re {
+ my($str) = @_;
+ $str =~ s/(.)/ord($1) > 255 ? sprintf("\\x{%x}", ord($1)) : $1/eg;
+ $str =~ s/([[:^print:]])/
+ ($1 =~ y! \t\n!!) ? $1 : sprintf("\\%03o", ord($1))/ge;
+ $str =~ s/\n/\n\f/g;
+ return $str;
+}
+
+# Don't do this for regexen
+sub unback {
+ my($str) = @_;
+ $str =~ s/\\/\\\\/g;
+ return $str;
+}
+
+# Remove backslashes which precede literal control characters,
+# to avoid creating ambiguity when we escape the latter.
+sub re_unback {
+ my($str) = @_;
+
+ # the insane complexity here is due to the behaviour of "\c\"
+ $str =~ s/(^|[^\\]|\\c\\)(?<!\\c)\\(\\\\)*(?=[[:^print:]])/$1$2/g;
+ return $str;
+}
+
+sub balanced_delim {
+ my($str) = @_;
+ my @str = split //, $str;
+ my($ar, $open, $close, $fail, $c, $cnt, $last_bs);
+ for $ar (['[',']'], ['(',')'], ['<','>'], ['{','}']) {
+ ($open, $close) = @$ar;
+ $fail = 0; $cnt = 0; $last_bs = 0;
+ for $c (@str) {
+ if ($c eq $open) {
+ $fail = 1 if $last_bs;
+ $cnt++;
+ } elsif ($c eq $close) {
+ $fail = 1 if $last_bs;
+ $cnt--;
+ if ($cnt < 0) {
+ # qq()() isn't ")("
+ $fail = 1;
+ last;
+ }
+ }
+ $last_bs = $c eq '\\';
+ }
+ $fail = 1 if $cnt != 0;
+ return ($open, "$open$str$close") if not $fail;
+ }
+ return ("", $str);
+}
+
+sub single_delim {
+ my($q, $default, $str) = @_;
+ return "$default$str$default" if $default and index($str, $default) == -1;
+ if ($q ne 'qr') {
+ (my $succeed, $str) = balanced_delim($str);
+ return "$q$str" if $succeed;
+ }
+ for my $delim ('/', '"', '#') {
+ return "$q$delim" . $str . $delim if index($str, $delim) == -1;
+ }
+ if ($default) {
+ $str =~ s/$default/\\$default/g;
+ return "$default$str$default";
+ } else {
+ $str =~ s[/][\\/]g;
+ return "$q/$str/";
+ }
+}
+
+my $max_prec;
+BEGIN { $max_prec = int(0.999 + 8*length(pack("F", 42))*log(2)/log(10)); }
+
+# Split a floating point number into an integer mantissa and a binary
+# exponent. Assumes you've already made sure the number isn't zero or
+# some weird infinity or NaN.
+sub split_float {
+ my($f) = @_;
+ my $exponent = 0;
+ if ($f == int($f)) {
+ while ($f % 2 == 0) {
+ $f /= 2;
+ $exponent++;
+ }
+ } else {
+ while ($f != int($f)) {
+ $f *= 2;
+ $exponent--;
+ }
+ }
+ my $mantissa = sprintf("%.0f", $f);
+ return ($mantissa, $exponent);
+}
+
+sub const {
+ my $self = shift;
+ my($sv, $cx) = @_;
+ if ($self->{'use_dumper'}) {
+ return $self->const_dumper($sv, $cx);
+ }
+ if (class($sv) eq "SPECIAL") {
+ # sv_undef, sv_yes, sv_no
+ return ('undef', '1', $self->maybe_parens("!1", $cx, 21))[$$sv-1];
+ }
+ if (class($sv) eq "NULL") {
+ return 'undef';
+ }
+ # convert a version object into the "v1.2.3" string in its V magic
+ if ($sv->FLAGS & SVs_RMG) {
+ for (my $mg = $sv->MAGIC; $mg; $mg = $mg->MOREMAGIC) {
+ return $mg->PTR if $mg->TYPE eq 'V';
+ }
+ }
+
+ if ($sv->FLAGS & SVf_IOK) {
+ my $str = $sv->int_value;
+ $str = $self->maybe_parens($str, $cx, 21) if $str < 0;
+ return $str;
+ } elsif ($sv->FLAGS & SVf_NOK) {
+ my $nv = $sv->NV;
+ if ($nv == 0) {
+ if (pack("F", $nv) eq pack("F", 0)) {
+ # positive zero
+ return "0";
+ } else {
+ # negative zero
+ return $self->maybe_parens("-.0", $cx, 21);
+ }
+ } elsif (1/$nv == 0) {
+ if ($nv > 0) {
+ # positive infinity
+ return $self->maybe_parens("9**9**9", $cx, 22);
+ } else {
+ # negative infinity
+ return $self->maybe_parens("-9**9**9", $cx, 21);
+ }
+ } elsif ($nv != $nv) {
+ # NaN
+ if (pack("F", $nv) eq pack("F", sin(9**9**9))) {
+ # the normal kind
+ return "sin(9**9**9)";
+ } elsif (pack("F", $nv) eq pack("F", -sin(9**9**9))) {
+ # the inverted kind
+ return $self->maybe_parens("-sin(9**9**9)", $cx, 21);
+ } else {
+ # some other kind
+ my $hex = unpack("h*", pack("F", $nv));
+ return qq'unpack("F", pack("h*", "$hex"))';
+ }
+ }
+ # first, try the default stringification
+ my $str = "$nv";
+ if ($str != $nv) {
+ # failing that, try using more precision
+ $str = sprintf("%.${max_prec}g", $nv);
+# if (pack("F", $str) ne pack("F", $nv)) {
+ if ($str != $nv) {
+ # not representable in decimal with whatever sprintf()
+ # and atof() Perl is using here.
+ my($mant, $exp) = split_float($nv);
+ return $self->maybe_parens("$mant * 2**$exp", $cx, 19);
+ }
+ }
+ $str = $self->maybe_parens($str, $cx, 21) if $nv < 0;
+ return $str;
+ } elsif ($sv->FLAGS & SVf_ROK && $sv->can("RV")) {
+ my $ref = $sv->RV;
+ if (class($ref) eq "AV") {
+ return "[" . $self->list_const(2, $ref->ARRAY) . "]";
+ } elsif (class($ref) eq "HV") {
+ my %hash = $ref->ARRAY;
+ my @elts;
+ for my $k (sort keys %hash) {
+ push @elts, "$k => " . $self->const($hash{$k}, 6);
+ }
+ return "{" . join(", ", @elts) . "}";
+ } elsif (class($ref) eq "CV") {
+ return "sub " . $self->deparse_sub($ref);
+ }
+ if ($ref->FLAGS & SVs_SMG) {
+ for (my $mg = $ref->MAGIC; $mg; $mg = $mg->MOREMAGIC) {
+ if ($mg->TYPE eq 'r') {
+ my $re = re_uninterp(escape_str(re_unback($mg->precomp)));
+ return single_delim("qr", "", $re);
+ }
+ }
+ }
+
+ return $self->maybe_parens("\\" . $self->const($ref, 20), $cx, 20);
+ } elsif ($sv->FLAGS & SVf_POK) {
+ my $str = $sv->PV;
+ if ($str =~ /[[:^print:]]/) {
+ return single_delim("qq", '"', uninterp escape_str unback $str);
+ } else {
+ return single_delim("q", "'", unback $str);
+ }
+ } else {
+ return "undef";
+ }
+}
+
+sub const_dumper {
+ my $self = shift;
+ my($sv, $cx) = @_;
+ my $ref = $sv->object_2svref();
+ my $dumper = Data::Dumper->new([$$ref], ['$v']);
+ $dumper->Purity(1)->Terse(1)->Deparse(1)->Indent(0)->Useqq(1)->Sortkeys(1);
+ my $str = $dumper->Dump();
+ if ($str =~ /^\$v/) {
+ return '${my ' . $str . ' \$v}';
+ } else {
+ return $str;
+ }
+}
+
+sub const_sv {
+ my $self = shift;
+ my $op = shift;
+ my $sv = $op->sv;
+ # the constant could be in the pad (under useithreads)
+ $sv = $self->padval($op->targ) unless $$sv;
+ return $sv;
+}
+
+sub pp_const {
+ my $self = shift;
+ my($op, $cx) = @_;
+ if ($op->private & OPpCONST_ARYBASE) {
+ return '$[';
+ }
+# if ($op->private & OPpCONST_BARE) { # trouble with `=>' autoquoting
+# return $self->const_sv($op)->PV;
+# }
+ my $sv = $self->const_sv($op);
+ return $self->const($sv, $cx);
+}
+
+sub dq {
+ my $self = shift;
+ my $op = shift;
+ my $type = $op->name;
+ if ($type eq "const") {
+ return '$[' if $op->private & OPpCONST_ARYBASE;
+ return uninterp(escape_str(unback($self->const_sv($op)->as_string)));
+ } elsif ($type eq "concat") {
+ my $first = $self->dq($op->first);
+ my $last = $self->dq($op->last);
+
+ # Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]", "$foo\::bar"
+ ($last =~ /^[A-Z\\\^\[\]_?]/ &&
+ $first =~ s/([\$@])\^$/${1}{^}/) # "${^}W" etc
+ || ($last =~ /^[:'{\[\w_]/ && #'
+ $first =~ s/([\$@])([A-Za-z_]\w*)$/${1}{$2}/);
+
+ return $first . $last;
+ } elsif ($type eq "uc") {
+ return '\U' . $self->dq($op->first->sibling) . '\E';
+ } elsif ($type eq "lc") {
+ return '\L' . $self->dq($op->first->sibling) . '\E';
+ } elsif ($type eq "ucfirst") {
+ return '\u' . $self->dq($op->first->sibling);
+ } elsif ($type eq "lcfirst") {
+ return '\l' . $self->dq($op->first->sibling);
+ } elsif ($type eq "quotemeta") {
+ return '\Q' . $self->dq($op->first->sibling) . '\E';
+ } elsif ($type eq "join") {
+ return $self->deparse($op->last, 26); # was join($", @ary)
+ } else {
+ return $self->deparse($op, 26);
+ }
+}
+
+sub pp_backtick {
+ my $self = shift;
+ my($op, $cx) = @_;
+ # skip pushmark if it exists (readpipe() vs ``)
+ my $child = $op->first->sibling->isa('B::NULL')
+ ? $op->first : $op->first->sibling;
+ return single_delim("qx", '`', $self->dq($child));
+}
+
+sub dquote {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my $kid = $op->first->sibling; # skip ex-stringify, pushmark
+ return $self->deparse($kid, $cx) if $self->{'unquote'};
+ $self->maybe_targmy($kid, $cx,
+ sub {single_delim("qq", '"', $self->dq($_[1]))});
+}
+
+# OP_STRINGIFY is a listop, but it only ever has one arg
+sub pp_stringify { maybe_targmy(@_, \&dquote) }
+
+# tr/// and s/// (and tr[][], tr[]//, tr###, etc)
+# note that tr(from)/to/ is OK, but not tr/from/(to)
+sub double_delim {
+ my($from, $to) = @_;
+ my($succeed, $delim);
+ if ($from !~ m[/] and $to !~ m[/]) {
+ return "/$from/$to/";
+ } elsif (($succeed, $from) = balanced_delim($from) and $succeed) {
+ if (($succeed, $to) = balanced_delim($to) and $succeed) {
+ return "$from$to";
+ } else {
+ for $delim ('/', '"', '#') { # note no `'' -- s''' is special
+ return "$from$delim$to$delim" if index($to, $delim) == -1;
+ }
+ $to =~ s[/][\\/]g;
+ return "$from/$to/";
+ }
+ } else {
+ for $delim ('/', '"', '#') { # note no '
+ return "$delim$from$delim$to$delim"
+ if index($to . $from, $delim) == -1;
+ }
+ $from =~ s[/][\\/]g;
+ $to =~ s[/][\\/]g;
+ return "/$from/$to/";
+ }
+}
+
+# Only used by tr///, so backslashes hyphens
+sub pchr { # ASCII
+ my($n) = @_;
+ if ($n == ord '\\') {
+ return '\\\\';
+ } elsif ($n == ord "-") {
+ return "\\-";
+ } elsif ($n >= ord(' ') and $n <= ord('~')) {
+ return chr($n);
+ } elsif ($n == ord "\a") {
+ return '\\a';
+ } elsif ($n == ord "\b") {
+ return '\\b';
+ } elsif ($n == ord "\t") {
+ return '\\t';
+ } elsif ($n == ord "\n") {
+ return '\\n';
+ } elsif ($n == ord "\e") {
+ return '\\e';
+ } elsif ($n == ord "\f") {
+ return '\\f';
+ } elsif ($n == ord "\r") {
+ return '\\r';
+ } elsif ($n >= ord("\cA") and $n <= ord("\cZ")) {
+ return '\\c' . chr(ord("@") + $n);
+ } else {
+# return '\x' . sprintf("%02x", $n);
+ return '\\' . sprintf("%03o", $n);
+ }
+}
+
+sub collapse {
+ my(@chars) = @_;
+ my($str, $c, $tr) = ("");
+ for ($c = 0; $c < @chars; $c++) {
+ $tr = $chars[$c];
+ $str .= pchr($tr);
+ if ($c <= $#chars - 2 and $chars[$c + 1] == $tr + 1 and
+ $chars[$c + 2] == $tr + 2)
+ {
+ for (; $c <= $#chars-1 and $chars[$c + 1] == $chars[$c] + 1; $c++)
+ {}
+ $str .= "-";
+ $str .= pchr($chars[$c]);
+ }
+ }
+ return $str;
+}
+
+sub tr_decode_byte {
+ my($table, $flags) = @_;
+ my(@table) = unpack("s*", $table);
+ splice @table, 0x100, 1; # Number of subsequent elements
+ my($c, $tr, @from, @to, @delfrom, $delhyphen);
+ if ($table[ord "-"] != -1 and
+ $table[ord("-") - 1] == -1 || $table[ord("-") + 1] == -1)
+ {
+ $tr = $table[ord "-"];
+ $table[ord "-"] = -1;
+ if ($tr >= 0) {
+ @from = ord("-");
+ @to = $tr;
+ } else { # -2 ==> delete
+ $delhyphen = 1;
+ }
+ }
+ for ($c = 0; $c < @table; $c++) {
+ $tr = $table[$c];
+ if ($tr >= 0) {
+ push @from, $c; push @to, $tr;
+ } elsif ($tr == -2) {
+ push @delfrom, $c;
+ }
+ }
+ @from = (@from, @delfrom);
+ if ($flags & OPpTRANS_COMPLEMENT) {
+ my @newfrom = ();
+ my %from;
+ @from{@from} = (1) x @from;
+ for ($c = 0; $c < 256; $c++) {
+ push @newfrom, $c unless $from{$c};
+ }
+ @from = @newfrom;
+ }
+ unless ($flags & OPpTRANS_DELETE || !@to) {
+ pop @to while $#to and $to[$#to] == $to[$#to -1];
+ }
+ my($from, $to);
+ $from = collapse(@from);
+ $to = collapse(@to);
+ $from .= "-" if $delhyphen;
+ return ($from, $to);
+}
+
+sub tr_chr {
+ my $x = shift;
+ if ($x == ord "-") {
+ return "\\-";
+ } elsif ($x == ord "\\") {
+ return "\\\\";
+ } else {
+ return chr $x;
+ }
+}
+
+# XXX This doesn't yet handle all cases correctly either
+
+sub tr_decode_utf8 {
+ my($swash_hv, $flags) = @_;
+ my %swash = $swash_hv->ARRAY;
+ my $final = undef;
+ $final = $swash{'FINAL'}->IV if exists $swash{'FINAL'};
+ my $none = $swash{"NONE"}->IV;
+ my $extra = $none + 1;
+ my(@from, @delfrom, @to);
+ my $line;
+ foreach $line (split /\n/, $swash{'LIST'}->PV) {
+ my($min, $max, $result) = split(/\t/, $line);
+ $min = hex $min;
+ if (length $max) {
+ $max = hex $max;
+ } else {
+ $max = $min;
+ }
+ $result = hex $result;
+ if ($result == $extra) {
+ push @delfrom, [$min, $max];
+ } else {
+ push @from, [$min, $max];
+ push @to, [$result, $result + $max - $min];
+ }
+ }
+ for my $i (0 .. $#from) {
+ if ($from[$i][0] == ord '-') {
+ unshift @from, splice(@from, $i, 1);
+ unshift @to, splice(@to, $i, 1);
+ last;
+ } elsif ($from[$i][1] == ord '-') {
+ $from[$i][1]--;
+ $to[$i][1]--;
+ unshift @from, ord '-';
+ unshift @to, ord '-';
+ last;
+ }
+ }
+ for my $i (0 .. $#delfrom) {
+ if ($delfrom[$i][0] == ord '-') {
+ push @delfrom, splice(@delfrom, $i, 1);
+ last;
+ } elsif ($delfrom[$i][1] == ord '-') {
+ $delfrom[$i][1]--;
+ push @delfrom, ord '-';
+ last;
+ }
+ }
+ if (defined $final and $to[$#to][1] != $final) {
+ push @to, [$final, $final];
+ }
+ push @from, @delfrom;
+ if ($flags & OPpTRANS_COMPLEMENT) {
+ my @newfrom;
+ my $next = 0;
+ for my $i (0 .. $#from) {
+ push @newfrom, [$next, $from[$i][0] - 1];
+ $next = $from[$i][1] + 1;
+ }
+ @from = ();
+ for my $range (@newfrom) {
+ if ($range->[0] <= $range->[1]) {
+ push @from, $range;
+ }
+ }
+ }
+ my($from, $to, $diff);
+ for my $chunk (@from) {
+ $diff = $chunk->[1] - $chunk->[0];
+ if ($diff > 1) {
+ $from .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]);
+ } elsif ($diff == 1) {
+ $from .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]);
+ } else {
+ $from .= tr_chr($chunk->[0]);
+ }
+ }
+ for my $chunk (@to) {
+ $diff = $chunk->[1] - $chunk->[0];
+ if ($diff > 1) {
+ $to .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]);
+ } elsif ($diff == 1) {
+ $to .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]);
+ } else {
+ $to .= tr_chr($chunk->[0]);
+ }
+ }
+ #$final = sprintf("%04x", $final) if defined $final;
+ #$none = sprintf("%04x", $none) if defined $none;
+ #$extra = sprintf("%04x", $extra) if defined $extra;
+ #print STDERR "final: $final\n none: $none\nextra: $extra\n";
+ #print STDERR $swash{'LIST'}->PV;
+ return (escape_str($from), escape_str($to));
+}
+
+sub pp_trans {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my($from, $to);
+ if (class($op) eq "PVOP") {
+ ($from, $to) = tr_decode_byte($op->pv, $op->private);
+ } else { # class($op) eq "SVOP"
+ ($from, $to) = tr_decode_utf8($op->sv->RV, $op->private);
+ }
+ my $flags = "";
+ $flags .= "c" if $op->private & OPpTRANS_COMPLEMENT;
+ $flags .= "d" if $op->private & OPpTRANS_DELETE;
+ $to = "" if $from eq $to and $flags eq "";
+ $flags .= "s" if $op->private & OPpTRANS_SQUASH;
+ return "tr" . double_delim($from, $to) . $flags;
+}
+
+sub re_dq_disambiguate {
+ my ($first, $last) = @_;
+ # Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]"
+ ($last =~ /^[A-Z\\\^\[\]_?]/ &&
+ $first =~ s/([\$@])\^$/${1}{^}/) # "${^}W" etc
+ || ($last =~ /^[{\[\w_]/ &&
+ $first =~ s/([\$@])([A-Za-z_]\w*)$/${1}{$2}/);
+ return $first . $last;
+}
+
+# Like dq(), but different
+sub re_dq {
+ my $self = shift;
+ my ($op, $extended) = @_;
+
+ my $type = $op->name;
+ if ($type eq "const") {
+ return '$[' if $op->private & OPpCONST_ARYBASE;
+ my $unbacked = re_unback($self->const_sv($op)->as_string);
+ return re_uninterp_extended(escape_extended_re($unbacked))
+ if $extended;
+ return re_uninterp(escape_str($unbacked));
+ } elsif ($type eq "concat") {
+ my $first = $self->re_dq($op->first, $extended);
+ my $last = $self->re_dq($op->last, $extended);
+ return re_dq_disambiguate($first, $last);
+ } elsif ($type eq "uc") {
+ return '\U' . $self->re_dq($op->first->sibling, $extended) . '\E';
+ } elsif ($type eq "lc") {
+ return '\L' . $self->re_dq($op->first->sibling, $extended) . '\E';
+ } elsif ($type eq "ucfirst") {
+ return '\u' . $self->re_dq($op->first->sibling, $extended);
+ } elsif ($type eq "lcfirst") {
+ return '\l' . $self->re_dq($op->first->sibling, $extended);
+ } elsif ($type eq "quotemeta") {
+ return '\Q' . $self->re_dq($op->first->sibling, $extended) . '\E';
+ } elsif ($type eq "join") {
+ return $self->deparse($op->last, 26); # was join($", @ary)
+ } else {
+ return $self->deparse($op, 26);
+ }
+}
+
+sub pure_string {
+ my ($self, $op) = @_;
+ return 0 if null $op;
+ my $type = $op->name;
+
+ if ($type eq 'const') {
+ return 1;
+ }
+ elsif ($type =~ /^[ul]c(first)?$/ || $type eq 'quotemeta') {
+ return $self->pure_string($op->first->sibling);
+ }
+ elsif ($type eq 'join') {
+ my $join_op = $op->first->sibling; # Skip pushmark
+ return 0 unless $join_op->name eq 'null' && $join_op->targ eq OP_RV2SV;
+
+ my $gvop = $join_op->first;
+ return 0 unless $gvop->name eq 'gvsv';
+ return 0 unless '"' eq $self->gv_name($self->gv_or_padgv($gvop));
+
+ return 0 unless ${$join_op->sibling} eq ${$op->last};
+ return 0 unless $op->last->name =~ /^(?:[ah]slice|(?:rv2|pad)av)$/;
+ }
+ elsif ($type eq 'concat') {
+ return $self->pure_string($op->first)
+ && $self->pure_string($op->last);
+ }
+ elsif (is_scalar($op) || $type =~ /^[ah]elem$/) {
+ return 1;
+ }
+ elsif ($type eq "null" and $op->can('first') and not null $op->first and
+ $op->first->name eq "null" and $op->first->can('first')
+ and not null $op->first->first and
+ $op->first->first->name eq "aelemfast") {
+ return 1;
+ }
+ else {
+ return 0;
+ }
+
+ return 1;
+}
+
+sub regcomp {
+ my $self = shift;
+ my($op, $cx, $extended) = @_;
+ my $kid = $op->first;
+ $kid = $kid->first if $kid->name eq "regcmaybe";
+ $kid = $kid->first if $kid->name eq "regcreset";
+ if ($kid->name eq "null" and !null($kid->first)
+ and $kid->first->name eq 'pushmark')
+ {
+ my $str = '';
+ $kid = $kid->first->sibling;
+ while (!null($kid)) {
+ my $first = $str;
+ my $last = $self->re_dq($kid, $extended);
+ $str = re_dq_disambiguate($first, $last);
+ $kid = $kid->sibling;
+ }
+ return $str, 1;
+ }
+
+ return ($self->re_dq($kid, $extended), 1) if $self->pure_string($kid);
+ return ($self->deparse($kid, $cx), 0);
+}
+
+sub pp_regcomp {
+ my ($self, $op, $cx) = @_;
+ return (($self->regcomp($op, $cx, 0))[0]);
+}
+
+# osmic acid -- see osmium tetroxide
+
+my %matchwords;
+map($matchwords{join "", sort split //, $_} = $_, 'cig', 'cog', 'cos', 'cogs',
+ 'cox', 'go', 'is', 'ism', 'iso', 'mig', 'mix', 'osmic', 'ox', 'sic',
+ 'sig', 'six', 'smog', 'so', 'soc', 'sog', 'xi');
+
+sub matchop {
+ my $self = shift;
+ my($op, $cx, $name, $delim) = @_;
+ my $kid = $op->first;
+ my ($binop, $var, $re) = ("", "", "");
+ if ($op->flags & OPf_STACKED) {
+ $binop = 1;
+ $var = $self->deparse($kid, 20);
+ $kid = $kid->sibling;
+ }
+ my $quote = 1;
+ my $extended = ($op->pmflags & PMf_EXTENDED);
+ if (null $kid) {
+ my $unbacked = re_unback($op->precomp);
+ if ($extended) {
+ $re = re_uninterp_extended(escape_extended_re($unbacked));
+ } else {
+ $re = re_uninterp(escape_str(re_unback($op->precomp)));
+ }
+ } elsif ($kid->name ne 'regcomp') {
+ carp("found ".$kid->name." where regcomp expected");
+ } else {
+ ($re, $quote) = $self->regcomp($kid, 21, $extended);
+ }
+ my $flags = "";
+ $flags .= "c" if $op->pmflags & PMf_CONTINUE;
+ $flags .= "g" if $op->pmflags & PMf_GLOBAL;
+ $flags .= "i" if $op->pmflags & PMf_FOLD;
+ $flags .= "m" if $op->pmflags & PMf_MULTILINE;
+ $flags .= "o" if $op->pmflags & PMf_KEEP;
+ $flags .= "s" if $op->pmflags & PMf_SINGLELINE;
+ $flags .= "x" if $op->pmflags & PMf_EXTENDED;
+ $flags = $matchwords{$flags} if $matchwords{$flags};
+ if ($op->pmflags & PMf_ONCE) { # only one kind of delimiter works here
+ $re =~ s/\?/\\?/g;
+ $re = "?$re?";
+ } elsif ($quote) {
+ $re = single_delim($name, $delim, $re);
+ }
+ $re = $re . $flags if $quote;
+ if ($binop) {
+ return $self->maybe_parens("$var =~ $re", $cx, 20);
+ } else {
+ return $re;
+ }
+}
+
+sub pp_match { matchop(@_, "m", "/") }
+sub pp_pushre { matchop(@_, "m", "/") }
+sub pp_qr { matchop(@_, "qr", "") }
+
+sub pp_split {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my($kid, @exprs, $ary, $expr);
+ $kid = $op->first;
+
+ # For our kid (an OP_PUSHRE), pmreplroot is never actually the
+ # root of a replacement; it's either empty, or abused to point to
+ # the GV for an array we split into (an optimization to save
+ # assignment overhead). Depending on whether we're using ithreads,
+ # this OP* holds either a GV* or a PADOFFSET. Luckily, B.xs
+ # figures out for us which it is.
+ my $replroot = $kid->pmreplroot;
+ my $gv = 0;
+ if (ref($replroot) eq "B::GV") {
+ $gv = $replroot;
+ } elsif (!ref($replroot) and $replroot > 0) {
+ $gv = $self->padval($replroot);
+ }
+ $ary = $self->stash_variable('@', $self->gv_name($gv)) if $gv;
+
+ for (; !null($kid); $kid = $kid->sibling) {
+ push @exprs, $self->deparse($kid, 6);
+ }
+
+ # handle special case of split(), and split(' ') that compiles to /\s+/
+ $kid = $op->first;
+ if ( $kid->flags & OPf_SPECIAL
+ and ( $] < 5.009 ? $kid->pmflags & PMf_SKIPWHITE()
+ : $kid->reflags & RXf_SKIPWHITE() ) ) {
+ $exprs[0] = "' '";
+ }
+
+ $expr = "split(" . join(", ", @exprs) . ")";
+ if ($ary) {
+ return $self->maybe_parens("$ary = $expr", $cx, 7);
+ } else {
+ return $expr;
+ }
+}
+
+# oxime -- any of various compounds obtained chiefly by the action of
+# hydroxylamine on aldehydes and ketones and characterized by the
+# bivalent grouping C=NOH [Webster's Tenth]
+
+my %substwords;
+map($substwords{join "", sort split //, $_} = $_, 'ego', 'egoism', 'em',
+ 'es', 'ex', 'exes', 'gee', 'go', 'goes', 'ie', 'ism', 'iso', 'me',
+ 'meese', 'meso', 'mig', 'mix', 'os', 'ox', 'oxime', 'see', 'seem',
+ 'seg', 'sex', 'sig', 'six', 'smog', 'sog', 'some', 'xi');
+
+sub pp_subst {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my $kid = $op->first;
+ my($binop, $var, $re, $repl) = ("", "", "", "");
+ if ($op->flags & OPf_STACKED) {
+ $binop = 1;
+ $var = $self->deparse($kid, 20);
+ $kid = $kid->sibling;
+ }
+ my $flags = "";
+ if (null($op->pmreplroot)) {
+ $repl = $self->dq($kid);
+ $kid = $kid->sibling;
+ } else {
+ $repl = $op->pmreplroot->first; # skip substcont
+ while ($repl->name eq "entereval") {
+ $repl = $repl->first;
+ $flags .= "e";
+ }
+ if ($op->pmflags & PMf_EVAL) {
+ $repl = $self->deparse($repl->first, 0);
+ } else {
+ $repl = $self->dq($repl);
+ }
+ }
+ my $extended = ($op->pmflags & PMf_EXTENDED);
+ if (null $kid) {
+ my $unbacked = re_unback($op->precomp);
+ if ($extended) {
+ $re = re_uninterp_extended(escape_extended_re($unbacked));
+ }
+ else {
+ $re = re_uninterp(escape_str($unbacked));
+ }
+ } else {
+ ($re) = $self->regcomp($kid, 1, $extended);
+ }
+ $flags .= "e" if $op->pmflags & PMf_EVAL;
+ $flags .= "g" if $op->pmflags & PMf_GLOBAL;
+ $flags .= "i" if $op->pmflags & PMf_FOLD;
+ $flags .= "m" if $op->pmflags & PMf_MULTILINE;
+ $flags .= "o" if $op->pmflags & PMf_KEEP;
+ $flags .= "s" if $op->pmflags & PMf_SINGLELINE;
+ $flags .= "x" if $extended;
+ $flags = $substwords{$flags} if $substwords{$flags};
+ if ($binop) {
+ return $self->maybe_parens("$var =~ s"
+ . double_delim($re, $repl) . $flags,
+ $cx, 20);
+ } else {
+ return "s". double_delim($re, $repl) . $flags;
+ }
+}
+
+1;
+__END__
+
+=head1 NAME
+
+B::Deparse - Perl compiler backend to produce perl code
+
+=head1 SYNOPSIS
+
+B<perl> B<-MO=Deparse>[B<,-d>][B<,-f>I<FILE>][B<,-p>][B<,-q>][B<,-l>]
+ [B<,-s>I<LETTERS>][B<,-x>I<LEVEL>] I<prog.pl>
+
+=head1 DESCRIPTION
+
+B::Deparse is a backend module for the Perl compiler that generates
+perl source code, based on the internal compiled structure that perl
+itself creates after parsing a program. The output of B::Deparse won't
+be exactly the same as the original source, since perl doesn't keep
+track of comments or whitespace, and there isn't a one-to-one
+correspondence between perl's syntactical constructions and their
+compiled form, but it will often be close. When you use the B<-p>
+option, the output also includes parentheses even when they are not
+required by precedence, which can make it easy to see if perl is
+parsing your expressions the way you intended.
+
+While B::Deparse goes to some lengths to try to figure out what your
+original program was doing, some parts of the language can still trip
+it up; it still fails even on some parts of Perl's own test suite. If
+you encounter a failure other than the most common ones described in
+the BUGS section below, you can help contribute to B::Deparse's
+ongoing development by submitting a bug report with a small
+example.
+
+=head1 OPTIONS
+
+As with all compiler backend options, these must follow directly after
+the '-MO=Deparse', separated by a comma but not any white space.
+
+=over 4
+
+=item B<-d>
+
+Output data values (when they appear as constants) using Data::Dumper.
+Without this option, B::Deparse will use some simple routines of its
+own for the same purpose. Currently, Data::Dumper is better for some
+kinds of data (such as complex structures with sharing and
+self-reference) while the built-in routines are better for others
+(such as odd floating-point values).
+
+=item B<-f>I<FILE>
+
+Normally, B::Deparse deparses the main code of a program, and all the subs
+defined in the same file. To include subs defined in other files, pass the
+B<-f> option with the filename. You can pass the B<-f> option several times, to
+include more than one secondary file. (Most of the time you don't want to
+use it at all.) You can also use this option to include subs which are
+defined in the scope of a B<#line> directive with two parameters.
+
+=item B<-l>
+
+Add '#line' declarations to the output based on the line and file
+locations of the original code.
+
+=item B<-p>
+
+Print extra parentheses. Without this option, B::Deparse includes
+parentheses in its output only when they are needed, based on the
+structure of your program. With B<-p>, it uses parentheses (almost)
+whenever they would be legal. This can be useful if you are used to
+LISP, or if you want to see how perl parses your input. If you say
+
+ if ($var & 0x7f == 65) {print "Gimme an A!"}
+ print ($which ? $a : $b), "\n";
+ $name = $ENV{USER} or "Bob";
+
+C<B::Deparse,-p> will print
+
+ if (($var & 0)) {
+ print('Gimme an A!')
+ };
+ (print(($which ? $a : $b)), '???');
+ (($name = $ENV{'USER'}) or '???')
+
+which probably isn't what you intended (the C<'???'> is a sign that
+perl optimized away a constant value).
+
+=item B<-P>
+
+Disable prototype checking. With this option, all function calls are
+deparsed as if no prototype was defined for them. In other words,
+
+ perl -MO=Deparse,-P -e 'sub foo (\@) { 1 } foo @x'
+
+will print
+
+ sub foo (\@) {
+ 1;
+ }
+ &foo(\@x);
+
+making clear how the parameters are actually passed to C<foo>.
+
+=item B<-q>
+
+Expand double-quoted strings into the corresponding combinations of
+concatenation, uc, ucfirst, lc, lcfirst, quotemeta, and join. For
+instance, print
+
+ print "Hello, $world, @ladies, \u$gentlemen\E, \u\L$me!";
+
+as
+
+ print 'Hello, ' . $world . ', ' . join($", @ladies) . ', '
+ . ucfirst($gentlemen) . ', ' . ucfirst(lc $me . '!');
+
+Note that the expanded form represents the way perl handles such
+constructions internally -- this option actually turns off the reverse
+translation that B::Deparse usually does. On the other hand, note that
+C<$x = "$y"> is not the same as C<$x = $y>: the former makes the value
+of $y into a string before doing the assignment.
+
+=item B<-s>I<LETTERS>
+
+Tweak the style of B::Deparse's output. The letters should follow
+directly after the 's', with no space or punctuation. The following
+options are available:
+
+=over 4
+
+=item B<C>
+
+Cuddle C<elsif>, C<else>, and C<continue> blocks. For example, print
+
+ if (...) {
+ ...
+ } else {
+ ...
+ }
+
+instead of
+
+ if (...) {
+ ...
+ }
+ else {
+ ...
+ }
+
+The default is not to cuddle.
+
+=item B<i>I<NUMBER>
+
+Indent lines by multiples of I<NUMBER> columns. The default is 4 columns.
+
+=item B<T>
+
+Use tabs for each 8 columns of indent. The default is to use only spaces.
+For instance, if the style options are B<-si4T>, a line that's indented
+3 times will be preceded by one tab and four spaces; if the options were
+B<-si8T>, the same line would be preceded by three tabs.
+
+=item B<v>I<STRING>B<.>
+
+Print I<STRING> for the value of a constant that can't be determined
+because it was optimized away (mnemonic: this happens when a constant
+is used in B<v>oid context). The end of the string is marked by a period.
+The string should be a valid perl expression, generally a constant.
+Note that unless it's a number, it probably needs to be quoted, and on
+a command line quotes need to be protected from the shell. Some
+conventional values include 0, 1, 42, '', 'foo', and
+'Useless use of constant omitted' (which may need to be
+B<-sv"'Useless use of constant omitted'.">
+or something similar depending on your shell). The default is '???'.
+If you're using B::Deparse on a module or other file that's require'd,
+you shouldn't use a value that evaluates to false, since the customary
+true constant at the end of a module will be in void context when the
+file is compiled as a main program.
+
+=back
+
+=item B<-x>I<LEVEL>
+
+Expand conventional syntax constructions into equivalent ones that expose
+their internal operation. I<LEVEL> should be a digit, with higher values
+meaning more expansion. As with B<-q>, this actually involves turning off
+special cases in B::Deparse's normal operations.
+
+If I<LEVEL> is at least 3, C<for> loops will be translated into equivalent
+while loops with continue blocks; for instance
+
+ for ($i = 0; $i < 10; ++$i) {
+ print $i;
+ }
+
+turns into
+
+ $i = 0;
+ while ($i < 10) {
+ print $i;
+ } continue {
+ ++$i
+ }
+
+Note that in a few cases this translation can't be perfectly carried back
+into the source code -- if the loop's initializer declares a my variable,
+for instance, it won't have the correct scope outside of the loop.
+
+If I<LEVEL> is at least 5, C<use> declarations will be translated into
+C<BEGIN> blocks containing calls to C<require> and C<import>; for
+instance,
+
+ use strict 'refs';
+
+turns into
+
+ sub BEGIN {
+ require strict;
+ do {
+ 'strict'->import('refs')
+ };
+ }
+
+If I<LEVEL> is at least 7, C<if> statements will be translated into
+equivalent expressions using C<&&>, C<?:> and C<do {}>; for instance
+
+ print 'hi' if $nice;
+ if ($nice) {
+ print 'hi';
+ }
+ if ($nice) {
+ print 'hi';
+ } else {
+ print 'bye';
+ }
+
+turns into
+
+ $nice and print 'hi';
+ $nice and do { print 'hi' };
+ $nice ? do { print 'hi' } : do { print 'bye' };
+
+Long sequences of elsifs will turn into nested ternary operators, which
+B::Deparse doesn't know how to indent nicely.
+
+=back
+
+=head1 USING B::Deparse AS A MODULE
+
+=head2 Synopsis
+
+ use B::Deparse;
+ $deparse = B::Deparse->new("-p", "-sC");
+ $body = $deparse->coderef2text(\&func);
+ eval "sub func $body"; # the inverse operation
+
+=head2 Description
+
+B::Deparse can also be used on a sub-by-sub basis from other perl
+programs.
+
+=head2 new
+
+ $deparse = B::Deparse->new(OPTIONS)
+
+Create an object to store the state of a deparsing operation and any
+options. The options are the same as those that can be given on the
+command line (see L</OPTIONS>); options that are separated by commas
+after B<-MO=Deparse> should be given as separate strings.
+
+=head2 ambient_pragmas
+
+ $deparse->ambient_pragmas(strict => 'all', '$[' => $[);
+
+The compilation of a subroutine can be affected by a few compiler
+directives, B<pragmas>. These are:
+
+=over 4
+
+=item *
+
+use strict;
+
+=item *
+
+use warnings;
+
+=item *
+
+Assigning to the special variable $[
+
+=item *
+
+use integer;
+
+=item *
+
+use bytes;
+
+=item *
+
+use utf8;
+
+=item *
+
+use re;
+
+=back
+
+Ordinarily, if you use B::Deparse on a subroutine which has
+been compiled in the presence of one or more of these pragmas,
+the output will include statements to turn on the appropriate
+directives. So if you then compile the code returned by coderef2text,
+it will behave the same way as the subroutine which you deparsed.
+
+However, you may know that you intend to use the results in a
+particular context, where some pragmas are already in scope. In
+this case, you use the B<ambient_pragmas> method to describe the
+assumptions you wish to make.
+
+Not all of the options currently have any useful effect. See
+L</BUGS> for more details.
+
+The parameters it accepts are:
+
+=over 4
+
+=item strict
+
+Takes a string, possibly containing several values separated
+by whitespace. The special values "all" and "none" mean what you'd
+expect.
+
+ $deparse->ambient_pragmas(strict => 'subs refs');
+
+=item $[
+
+Takes a number, the value of the array base $[.
+
+=item bytes
+
+=item utf8
+
+=item integer
+
+If the value is true, then the appropriate pragma is assumed to
+be in the ambient scope, otherwise not.
+
+=item re
+
+Takes a string, possibly containing a whitespace-separated list of
+values. The values "all" and "none" are special. It's also permissible
+to pass an array reference here.
+
+ $deparser->ambient_pragmas(re => 'eval');
+
+
+=item warnings
+
+Takes a string, possibly containing a whitespace-separated list of
+values. The values "all" and "none" are special, again. It's also
+permissible to pass an array reference here.
+
+ $deparser->ambient_pragmas(warnings => [qw[void io]]);
+
+If one of the values is the string "FATAL", then all the warnings
+in that list will be considered fatal, just as with the B<warnings>
+pragma itself. Should you need to specify that some warnings are
+fatal, and others are merely enabled, you can pass the B<warnings>
+parameter twice:
+
+ $deparser->ambient_pragmas(
+ warnings => 'all',
+ warnings => [FATAL => qw/void io/],
+ );
+
+See L<perllexwarn> for more information about lexical warnings.
+
+=item hint_bits
+
+=item warning_bits
+
+These two parameters are used to specify the ambient pragmas in
+the format used by the special variables $^H and ${^WARNING_BITS}.
+
+They exist principally so that you can write code like:
+
+ { my ($hint_bits, $warning_bits);
+ BEGIN {($hint_bits, $warning_bits) = ($^H, ${^WARNING_BITS})}
+ $deparser->ambient_pragmas (
+ hint_bits => $hint_bits,
+ warning_bits => $warning_bits,
+ '$[' => 0 + $[
+ ); }
+
+which specifies that the ambient pragmas are exactly those which
+are in scope at the point of calling.
+
+=item %^H
+
+This parameter is used to specify the ambient pragmas which are
+stored in the special hash %^H.
+
+=back
+
+=head2 coderef2text
+
+ $body = $deparse->coderef2text(\&func)
+ $body = $deparse->coderef2text(sub ($$) { ... })
+
+Return source code for the body of a subroutine (a block, optionally
+preceded by a prototype in parens), given a reference to the
+sub. Because a subroutine can have no names, or more than one name,
+this method doesn't return a complete subroutine definition -- if you
+want to eval the result, you should prepend "sub subname ", or "sub "
+for an anonymous function constructor. Unless the sub was defined in
+the main:: package, the code will include a package declaration.
+
+=head1 BUGS
+
+=over 4
+
+=item *
+
+The only pragmas to be completely supported are: C<use warnings>,
+C<use strict 'refs'>, C<use bytes>, and C<use integer>. (C<$[>, which
+behaves like a pragma, is also supported.)
+
+Excepting those listed above, we're currently unable to guarantee that
+B::Deparse will produce a pragma at the correct point in the program.
+(Specifically, pragmas at the beginning of a block often appear right
+before the start of the block instead.)
+Since the effects of pragmas are often lexically scoped, this can mean
+that the pragma holds sway over a different portion of the program
+than in the input file.
+
+=item *
+
+In fact, the above is a specific instance of a more general problem:
+we can't guarantee to produce BEGIN blocks or C<use> declarations in
+exactly the right place. So if you use a module which affects compilation
+(such as by over-riding keywords, overloading constants or whatever)
+then the output code might not work as intended.
+
+This is the most serious outstanding problem, and will require some help
+from the Perl core to fix.
+
+=item *
+
+If a keyword is over-ridden, and your program explicitly calls
+the built-in version by using CORE::keyword, the output of B::Deparse
+will not reflect this. If you run the resulting code, it will call
+the over-ridden version rather than the built-in one. (Maybe there
+should be an option to B<always> print keyword calls as C<CORE::name>.)
+
+=item *
+
+Some constants don't print correctly either with or without B<-d>.
+For instance, neither B::Deparse nor Data::Dumper know how to print
+dual-valued scalars correctly, as in:
+
+ use constant E2BIG => ($!=7); $y = E2BIG; print $y, 0+$y;
+
+ use constant H => { "#" => 1 }; H->{"#"};
+
+=item *
+
+An input file that uses source filtering probably won't be deparsed into
+runnable code, because it will still include the B<use> declaration
+for the source filtering module, even though the code that is
+produced is already ordinary Perl which shouldn't be filtered again.
+
+=item *
+
+Optimised away statements are rendered as '???'. This includes statements that
+have a compile-time side-effect, such as the obscure
+
+ my $x if 0;
+
+which is not, consequently, deparsed correctly.
+
+ foreach my $i (@_) { 0 }
+ =>
+ foreach my $i (@_) { '???' }
+
+=item *
+
+Lexical (my) variables declared in scopes external to a subroutine
+appear in code2ref output text as package variables. This is a tricky
+problem, as perl has no native facility for refering to a lexical variable
+defined within a different scope, although L<PadWalker> is a good start.
+
+=item *
+
+There are probably many more bugs on non-ASCII platforms (EBCDIC).
+
+=back
+
+=head1 AUTHOR
+
+Stephen McCamant <smcc at CSUA.Berkeley.EDU>, based on an earlier version
+by Malcolm Beattie <mbeattie at sable.ox.ac.uk>, with contributions from
+Gisle Aas, James Duncan, Albert Dvornik, Robin Houston, Dave Mitchell,
+Hugo van der Sanden, Gurusamy Sarathy, Nick Ing-Simmons, and Rafael
+Garcia-Suarez.
+
+=cut
Copied: trunk/contrib/perl/ext/B/B/Lint.pm (from rev 6437, vendor/perl/5.18.1/ext/B/B/Lint.pm)
===================================================================
--- trunk/contrib/perl/ext/B/B/Lint.pm (rev 0)
+++ trunk/contrib/perl/ext/B/B/Lint.pm 2013-12-02 21:32:26 UTC (rev 6445)
@@ -0,0 +1,792 @@
+package B::Lint;
+
+our $VERSION = '1.11'; ## no critic
+
+=head1 NAME
+
+B::Lint - Perl lint
+
+=head1 SYNOPSIS
+
+perl -MO=Lint[,OPTIONS] foo.pl
+
+=head1 DESCRIPTION
+
+The B::Lint module is equivalent to an extended version of the B<-w>
+option of B<perl>. It is named after the program F<lint> which carries
+out a similar process for C programs.
+
+=head1 OPTIONS AND LINT CHECKS
+
+Option words are separated by commas (not whitespace) and follow the
+usual conventions of compiler backend options. Following any options
+(indicated by a leading B<->) come lint check arguments. Each such
+argument (apart from the special B<all> and B<none> options) is a
+word representing one possible lint check (turning on that check) or
+is B<no-foo> (turning off that check). Before processing the check
+arguments, a standard list of checks is turned on. Later options
+override earlier ones. Available options are:
+
+=over 8
+
+=item B<magic-diamond>
+
+Produces a warning whenever the magic C<E<lt>E<gt>> readline is
+used. Internally it uses perl's two-argument open which itself treats
+filenames with special characters specially. This could allow
+interestingly named files to have unexpected effects when reading.
+
+ % touch 'rm *|'
+ % perl -pe 1
+
+The above creates a file named C<rm *|>. When perl opens it with
+C<E<lt>E<gt>> it actually executes the shell program C<rm *>. This
+makes C<E<lt>E<gt>> dangerous to use carelessly.
+
+=item B<context>
+
+Produces a warning whenever an array is used in an implicit scalar
+context. For example, both of the lines
+
+ $foo = length(@bar);
+ $foo = @bar;
+
+will elicit a warning. Using an explicit B<scalar()> silences the
+warning. For example,
+
+ $foo = scalar(@bar);
+
+=item B<implicit-read> and B<implicit-write>
+
+These options produce a warning whenever an operation implicitly
+reads or (respectively) writes to one of Perl's special variables.
+For example, B<implicit-read> will warn about these:
+
+ /foo/;
+
+and B<implicit-write> will warn about these:
+
+ s/foo/bar/;
+
+Both B<implicit-read> and B<implicit-write> warn about this:
+
+ for (@a) { ... }
+
+=item B<bare-subs>
+
+This option warns whenever a bareword is implicitly quoted, but is also
+the name of a subroutine in the current package. Typical mistakes that it will
+trap are:
+
+ use constant foo => 'bar';
+ @a = ( foo => 1 );
+ $b{foo} = 2;
+
+Neither of these will do what a naive user would expect.
+
+=item B<dollar-underscore>
+
+This option warns whenever C<$_> is used either explicitly anywhere or
+as the implicit argument of a B<print> statement.
+
+=item B<private-names>
+
+This option warns on each use of any variable, subroutine or
+method name that lives in a non-current package but begins with
+an underscore ("_"). Warnings aren't issued for the special case
+of the single character name "_" by itself (e.g. C<$_> and C<@_>).
+
+=item B<undefined-subs>
+
+This option warns whenever an undefined subroutine is invoked.
+This option will only catch explicitly invoked subroutines such
+as C<foo()> and not indirect invocations such as C<&$subref()>
+or C<$obj-E<gt>meth()>. Note that some programs or modules delay
+definition of subs until runtime by means of the AUTOLOAD
+mechanism.
+
+=item B<regexp-variables>
+
+This option warns whenever one of the regexp variables C<$`>, C<$&> or C<$'>
+is used. Any occurrence of any of these variables in your
+program can slow your whole program down. See L<perlre> for
+details.
+
+=item B<all>
+
+Turn all warnings on.
+
+=item B<none>
+
+Turn all warnings off.
+
+=back
+
+=head1 NON LINT-CHECK OPTIONS
+
+=over 8
+
+=item B<-u Package>
+
+Normally, Lint only checks the main code of the program together
+with all subs defined in package main. The B<-u> option lets you
+include other package names whose subs are then checked by Lint.
+
+=back
+
+=head1 EXTENDING LINT
+
+Lint can be extended by with plugins. Lint uses L<Module::Pluggable>
+to find available plugins. Plugins are expected but not required to
+inform Lint of which checks they are adding.
+
+The C<< B::Lint->register_plugin( MyPlugin => \@new_checks ) >> method
+adds the list of C<@new_checks> to the list of valid checks. If your
+module wasn't loaded by L<Module::Pluggable> then your class name is
+added to the list of plugins.
+
+You must create a C<match( \%checks )> method in your plugin class or one
+of its parents. It will be called on every op as a regular method call
+with a hash ref of checks as its parameter.
+
+The class methods C<< B::Lint->file >> and C<< B::Lint->line >> contain
+the current filename and line number.
+
+ package Sample;
+ use B::Lint;
+ B::Lint->register_plugin( Sample => [ 'good_taste' ] );
+
+ sub match {
+ my ( $op, $checks_href ) = shift @_;
+ if ( $checks_href->{good_taste} ) {
+ ...
+ }
+ }
+
+=head1 TODO
+
+=over
+
+=item while(<FH>) stomps $_
+
+=item strict oo
+
+=item unchecked system calls
+
+=item more tests, validate against older perls
+
+=back
+
+=head1 BUGS
+
+This is only a very preliminary version.
+
+=head1 AUTHOR
+
+Malcolm Beattie, mbeattie at sable.ox.ac.uk.
+
+=head1 ACKNOWLEDGEMENTS
+
+Sebastien Aperghis-Tramoni - bug fixes
+
+=cut
+
+use strict;
+use B qw( walkoptree_slow
+ main_root main_cv walksymtable parents
+ OPpOUR_INTRO
+ OPf_WANT_VOID OPf_WANT_LIST OPf_WANT OPf_STACKED SVf_POK );
+use Carp 'carp';
+
+# The current M::P doesn't know about .pmc files.
+use Module::Pluggable ( require => 1 );
+
+use List::Util 'first';
+## no critic Prototypes
+sub any (&@) { my $test = shift @_; $test->() and return 1 for @_; return 0 }
+
+BEGIN {
+
+ # Import or create some constants from B. B doesn't provide
+ # everything I need so some things like OPpCONST_BARE are defined
+ # here.
+ for my $sym ( qw( begin_av check_av init_av end_av ),
+ [ 'OPpCONST_BARE' => 64 ] )
+ {
+ my $val;
+ ( $sym, $val ) = @$sym if ref $sym;
+
+ if ( any { $sym eq $_ } @B::EXPORT_OK, @B::EXPORT ) {
+ B->import($sym);
+ }
+ else {
+ require constant;
+ constant->import( $sym => $val );
+ }
+ }
+}
+
+my $file = "unknown"; # shadows current filename
+my $line = 0; # shadows current line number
+my $curstash = "main"; # shadows current stash
+my $curcv; # shadows current B::CV for pad lookups
+
+sub file {$file}
+sub line {$line}
+sub curstash {$curstash}
+sub curcv {$curcv}
+
+# Lint checks
+my %check;
+my %implies_ok_context;
+
+map( $implies_ok_context{$_}++,
+ qw(scalar av2arylen aelem aslice helem hslice
+ keys values hslice defined undef delete) );
+
+# Lint checks turned on by default
+my @default_checks
+ = qw(context magic_diamond undefined_subs regexp_variables);
+
+my %valid_check;
+
+# All valid checks
+for my $check (
+ qw(context implicit_read implicit_write dollar_underscore
+ private_names bare_subs undefined_subs regexp_variables
+ magic_diamond )
+ )
+{
+ $valid_check{$check} = __PACKAGE__;
+}
+
+# Debugging options
+my ($debug_op);
+
+my %done_cv; # used to mark which subs have already been linted
+my @extra_packages; # Lint checks mainline code and all subs which are
+ # in main:: or in one of these packages.
+
+sub warning {
+ my $format = ( @_ < 2 ) ? "%s" : shift @_;
+ warn sprintf( "$format at %s line %d\n", @_, $file, $line );
+ return undef; ## no critic undef
+}
+
+# This gimme can't cope with context that's only determined
+# at runtime via dowantarray().
+sub gimme {
+ my $op = shift @_;
+ my $flags = $op->flags;
+ if ( $flags & OPf_WANT ) {
+ return ( ( $flags & OPf_WANT ) == OPf_WANT_LIST ? 1 : 0 );
+ }
+ return undef; ## no critic undef
+}
+
+my @plugins = __PACKAGE__->plugins;
+
+sub inside_grepmap {
+
+ # A boolean function to be used while inside a B::walkoptree_slow
+ # call. If we are in the EXPR part of C<grep EXPR, ...> or C<grep
+ # { EXPR } ...>, this returns true.
+ return any { $_->name =~ m/\A(?:grep|map)/xms } @{ parents() };
+}
+
+sub inside_foreach_modifier {
+
+ # TODO: use any()
+
+ # A boolean function to be used while inside a B::walkoptree_slow
+ # call. If we are in the EXPR part of C<EXPR foreach ...> this
+ # returns true.
+ for my $ancestor ( @{ parents() } ) {
+ next unless $ancestor->name eq 'leaveloop';
+
+ my $first = $ancestor->first;
+ next unless $first->name eq 'enteriter';
+
+ next if $first->redoop->name =~ m/\A(?:next|db|set)state\z/xms;
+
+ return 1;
+ }
+ return 0;
+}
+
+for (
+ [qw[ B::PADOP::gv_harder gv padix]],
+ [qw[ B::SVOP::sv_harder sv targ]],
+ [qw[ B::SVOP::gv_harder gv padix]]
+ )
+{
+
+ # I'm generating some functions here because they're mostly
+ # similar. It's all for compatibility with threaded
+ # perl. Perhaps... this code should inspect $Config{usethreads}
+ # and generate a *specific* function. I'm leaving it generic for
+ # the moment.
+ #
+ # In threaded perl SVs and GVs aren't used directly in the optrees
+ # like they are in non-threaded perls. The ops that would use a SV
+ # or GV keep an index into the subroutine's scratchpad. I'm
+ # currently ignoring $cv->DEPTH and that might be at my peril.
+
+ my ( $subname, $attr, $pad_attr ) = @$_;
+ my $target = do { ## no critic strict
+ no strict 'refs';
+ \*$subname;
+ };
+ *$target = sub {
+ my ($op) = @_;
+
+ my $elt;
+ if ( not $op->isa('B::PADOP') ) {
+ $elt = $op->$attr;
+ }
+ return $elt if eval { $elt->isa('B::SV') };
+
+ my $ix = $op->$pad_attr;
+ my @entire_pad = $curcv->PADLIST->ARRAY;
+ my @elts = map +( $_->ARRAY )[$ix], @entire_pad;
+ ($elt) = first {
+ eval { $_->isa('B::SV') } ? $_ : ();
+ }
+ @elts[ 0, reverse 1 .. $#elts ];
+ return $elt;
+ };
+}
+
+sub B::OP::lint {
+ my ($op) = @_;
+
+ # This is a fallback ->lint for all the ops where I haven't
+ # defined something more specific. Nothing happens here.
+
+ # Call all registered plugins
+ my $m;
+ $m = $_->can('match'), $op->$m( \%check ) for @plugins;
+ return;
+}
+
+sub B::COP::lint {
+ my ($op) = @_;
+
+ # nextstate ops sit between statements. Whenever I see one I
+ # update the current info on file, line, and stash. This code also
+ # updates it when it sees a dbstate or setstate op. I have no idea
+ # what those are but having seen them mentioned together in other
+ # parts of the perl I think they're kind of equivalent.
+ if ( $op->name =~ m/\A(?:next|db|set)state\z/ ) {
+ $file = $op->file;
+ $line = $op->line;
+ $curstash = $op->stash->NAME;
+ }
+
+ # Call all registered plugins
+ my $m;
+ $m = $_->can('match'), $op->$m( \%check ) for @plugins;
+ return;
+}
+
+sub B::UNOP::lint {
+ my ($op) = @_;
+
+ my $opname = $op->name;
+
+CONTEXT: {
+
+ # Check arrays and hashes in scalar or void context where
+ # scalar() hasn't been used.
+
+ next
+ unless $check{context}
+ and $opname =~ m/\Arv2[ah]v\z/xms
+ and not gimme($op);
+
+ my ( $parent, $gparent ) = @{ parents() }[ 0, 1 ];
+ my $pname = $parent->name;
+
+ next if $implies_ok_context{$pname};
+
+ # Three special cases to deal with: "foreach (@foo)", "delete
+ # $a{$b}", and "exists $a{$b}" null out the parent so we have to
+ # check for a parent of pp_null and a grandparent of
+ # pp_enteriter, pp_delete, pp_exists
+
+ next
+ if $pname eq "null"
+ and $gparent->name =~ m/\A(?:delete|enteriter|exists)\z/xms;
+
+ # our( @bar ); would also trigger this error so I exclude
+ # that.
+ next
+ if $op->private & OPpOUR_INTRO
+ and ( $op->flags & OPf_WANT ) == OPf_WANT_VOID;
+
+ warning 'Implicit scalar context for %s in %s',
+ $opname eq "rv2av" ? "array" : "hash", $parent->desc;
+ }
+
+PRIVATE_NAMES: {
+
+ # Looks for calls to methods with names that begin with _ and
+ # that aren't visible within the current package. Maybe this
+ # should look at @ISA.
+ next
+ unless $check{private_names}
+ and $opname =~ m/\Amethod/xms;
+
+ my $methop = $op->first;
+ next unless $methop->name eq "const";
+
+ my $method = $methop->sv_harder->PV;
+ next
+ unless $method =~ m/\A_/xms
+ and not defined &{"$curstash\::$method"};
+
+ warning q[Illegal reference to private method name '%s'], $method;
+ }
+
+ # Call all registered plugins
+ my $m;
+ $m = $_->can('match'), $op->$m( \%check ) for @plugins;
+ return;
+}
+
+sub B::PMOP::lint {
+ my ($op) = @_;
+
+IMPLICIT_READ: {
+
+ # Look for /.../ that doesn't use =~ to bind to something.
+ next
+ unless $check{implicit_read}
+ and $op->name eq "match"
+ and not( $op->flags & OPf_STACKED
+ or inside_grepmap() );
+ warning 'Implicit match on $_';
+ }
+
+IMPLICIT_WRITE: {
+
+ # Look for s/.../.../ that doesn't use =~ to bind to
+ # something.
+ next
+ unless $check{implicit_write}
+ and $op->name eq "subst"
+ and not $op->flags & OPf_STACKED;
+ warning 'Implicit substitution on $_';
+ }
+
+ # Call all registered plugins
+ my $m;
+ $m = $_->can('match'), $op->$m( \%check ) for @plugins;
+ return;
+}
+
+sub B::LOOP::lint {
+ my ($op) = @_;
+
+IMPLICIT_FOO: {
+
+ # Look for C<for ( ... )>.
+ next
+ unless ( $check{implicit_read} or $check{implicit_write} )
+ and $op->name eq "enteriter";
+
+ my $last = $op->last;
+ next
+ unless $last->name eq "gv"
+ and $last->gv_harder->NAME eq "_"
+ and $op->redoop->name =~ m/\A(?:next|db|set)state\z/xms;
+
+ warning 'Implicit use of $_ in foreach';
+ }
+
+ # Call all registered plugins
+ my $m;
+ $m = $_->can('match'), $op->$m( \%check ) for @plugins;
+ return;
+}
+
+# In threaded vs non-threaded perls you'll find that threaded perls
+# use PADOP in place of SVOPs so they can do lookups into the
+# scratchpad to find things. I suppose this is so a optree can be
+# shared between threads and all symbol table muckery will just get
+# written to a scratchpad.
+*B::PADOP::lint = *B::PADOP::lint = \&B::SVOP::lint;
+
+sub B::SVOP::lint {
+ my ($op) = @_;
+
+MAGIC_DIAMOND: {
+ next
+ unless $check{magic_diamond}
+ and parents()->[0]->name eq 'readline'
+ and $op->gv_harder->NAME eq 'ARGV';
+
+ warning 'Use of <>';
+ }
+
+BARE_SUBS: {
+ next
+ unless $check{bare_subs}
+ and $op->name eq 'const'
+ and $op->private & OPpCONST_BARE;
+
+ my $sv = $op->sv_harder;
+ next unless $sv->FLAGS & SVf_POK;
+
+ my $sub = $sv->PV;
+ my $subname = "$curstash\::$sub";
+
+ # I want to skip over things that were declared with the
+ # constant pragma. Well... sometimes. Hmm. I want to ignore
+ # C<<use constant FOO => ...>> but warn on C<<FOO => ...>>
+ # later. The former is typical declaration syntax and the
+ # latter would be an error.
+ #
+ # Skipping over both could be handled by looking if
+ # $constant::declared{$subname} is true.
+
+ # Check that it's a function.
+ next
+ unless exists &{"$curstash\::$sub"};
+
+ warning q[Bare sub name '%s' interpreted as string], $sub;
+ }
+
+PRIVATE_NAMES: {
+ next unless $check{private_names};
+
+ my $opname = $op->name;
+ if ( $opname =~ m/\Agv(?:sv)?\z/xms ) {
+
+ # Looks for uses of variables and stuff that are named
+ # private and we're not in the same package.
+ my $gv = $op->gv_harder;
+ my $name = $gv->NAME;
+ next
+ unless $name =~ m/\A_./xms
+ and $gv->STASH->NAME ne $curstash;
+
+ warning q[Illegal reference to private name '%s'], $name;
+ }
+ elsif ( $opname eq "method_named" ) {
+ my $method = $op->sv_harder->PV;
+ next unless $method =~ m/\A_./xms;
+
+ warning q[Illegal reference to private method name '%s'], $method;
+ }
+ }
+
+DOLLAR_UNDERSCORE: {
+
+ # Warn on uses of $_ with a few exceptions. I'm not warning on
+ # $_ inside grep, map, or statement modifer foreach because
+ # they localize $_ and it'd be impossible to use these
+ # features without getting warnings.
+
+ next
+ unless $check{dollar_underscore}
+ and $op->name eq "gvsv"
+ and $op->gv_harder->NAME eq "_"
+ and not( inside_grepmap
+ or inside_foreach_modifier );
+
+ warning 'Use of $_';
+ }
+
+REGEXP_VARIABLES: {
+
+ # Look for any uses of $`, $&, or $'.
+ next
+ unless $check{regexp_variables}
+ and $op->name eq "gvsv";
+
+ my $name = $op->gv_harder->NAME;
+ next unless $name =~ m/\A[\&\'\`]\z/xms;
+
+ warning 'Use of regexp variable $%s', $name;
+ }
+
+UNDEFINED_SUBS: {
+
+ # Look for calls to functions that either don't exist or don't
+ # have a definition.
+ next
+ unless $check{undefined_subs}
+ and $op->name eq "gv"
+ and $op->next->name eq "entersub";
+
+ my $gv = $op->gv_harder;
+ my $subname = $gv->STASH->NAME . "::" . $gv->NAME;
+
+ no strict 'refs'; ## no critic strict
+ if ( not exists &$subname ) {
+ $subname =~ s/\Amain:://;
+ warning q[Nonexistant subroutine '%s' called], $subname;
+ }
+ elsif ( not defined &$subname ) {
+ $subname =~ s/\A\&?main:://;
+ warning q[Undefined subroutine '%s' called], $subname;
+ }
+ }
+
+ # Call all registered plugins
+ my $m;
+ $m = $_->can('match'), $op->$m( \%check ) for @plugins;
+ return;
+}
+
+sub B::GV::lintcv {
+
+ # Example: B::svref_2object( \ *A::Glob )->lintcv
+
+ my $gv = shift @_;
+ my $cv = $gv->CV;
+ return unless $cv->can('lintcv');
+ $cv->lintcv;
+ return;
+}
+
+sub B::CV::lintcv {
+
+ # Example: B::svref_2object( \ &foo )->lintcv
+
+ # Write to the *global* $
+ $curcv = shift @_;
+
+ #warn sprintf("lintcv: %s::%s (done=%d)\n",
+ # $gv->STASH->NAME, $gv->NAME, $done_cv{$$curcv});#debug
+ return unless ref($curcv) and $$curcv and not $done_cv{$$curcv}++;
+ my $root = $curcv->ROOT;
+
+ #warn " root = $root (0x$$root)\n";#debug
+ walkoptree_slow( $root, "lint" ) if $$root;
+ return;
+}
+
+sub do_lint {
+ my %search_pack;
+
+ # Copy to the global $curcv for use in pad lookups.
+ $curcv = main_cv;
+ walkoptree_slow( main_root, "lint" ) if ${ main_root() };
+
+ # Do all the miscellaneous non-sub blocks.
+ for my $av ( begin_av, init_av, check_av, end_av ) {
+ next unless eval { $av->isa('B::AV') };
+ for my $cv ( $av->ARRAY ) {
+ next unless ref($cv) and $cv->FILE eq $0;
+ $cv->lintcv;
+ }
+ }
+
+ walksymtable(
+ \%main::,
+ sub {
+ if ( $_[0]->FILE eq $0 ) { $_[0]->lintcv }
+ },
+ sub {1}
+ );
+ return;
+}
+
+sub compile {
+ my @options = @_;
+
+ # Turn on default lint checks
+ for my $opt (@default_checks) {
+ $check{$opt} = 1;
+ }
+
+OPTION:
+ while ( my $option = shift @options ) {
+ my ( $opt, $arg );
+ unless ( ( $opt, $arg ) = $option =~ m/\A-(.)(.*)/xms ) {
+ unshift @options, $option;
+ last OPTION;
+ }
+
+ if ( $opt eq "-" && $arg eq "-" ) {
+ shift @options;
+ last OPTION;
+ }
+ elsif ( $opt eq "D" ) {
+ $arg ||= shift @options;
+ foreach my $arg ( split //, $arg ) {
+ if ( $arg eq "o" ) {
+ B->debug(1);
+ }
+ elsif ( $arg eq "O" ) {
+ $debug_op = 1;
+ }
+ }
+ }
+ elsif ( $opt eq "u" ) {
+ $arg ||= shift @options;
+ push @extra_packages, $arg;
+ }
+ }
+
+ foreach my $opt ( @default_checks, @options ) {
+ $opt =~ tr/-/_/;
+ if ( $opt eq "all" ) {
+ %check = %valid_check;
+ }
+ elsif ( $opt eq "none" ) {
+ %check = ();
+ }
+ else {
+ if ( $opt =~ s/\Ano_//xms ) {
+ $check{$opt} = 0;
+ }
+ else {
+ $check{$opt} = 1;
+ }
+ carp "No such check: $opt"
+ unless defined $valid_check{$opt};
+ }
+ }
+
+ # Remaining arguments are things to check. So why aren't I
+ # capturing them or something? I don't know.
+
+ return \&do_lint;
+}
+
+sub register_plugin {
+ my ( undef, $plugin, $new_checks ) = @_;
+
+ # Allow the user to be lazy and not give us a name.
+ $plugin = caller unless defined $plugin;
+
+ # Register the plugin's named checks, if any.
+ for my $check ( eval {@$new_checks} ) {
+ if ( not defined $check ) {
+ carp 'Undefined value in checks.';
+ next;
+ }
+ if ( exists $valid_check{$check} ) {
+ carp
+ "$check is already registered as a $valid_check{$check} feature.";
+ next;
+ }
+
+ $valid_check{$check} = $plugin;
+ }
+
+ # Register a non-Module::Pluggable loaded module. @plugins already
+ # contains whatever M::P found on disk. The user might load a
+ # plugin manually from some arbitrary namespace and ask for it to
+ # be registered.
+ if ( not any { $_ eq $plugin } @plugins ) {
+ push @plugins, $plugin;
+ }
+
+ return;
+}
+
+1;
Index: trunk/contrib/perl/ext/B/B/Showlex.pm
===================================================================
--- trunk/contrib/perl/ext/B/B/Showlex.pm 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/B/B/Showlex.pm 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/B/B/Showlex.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/ext/B/B/Terse.pm
===================================================================
--- trunk/contrib/perl/ext/B/B/Terse.pm 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/B/B/Terse.pm 2013-12-02 21:32:26 UTC (rev 6445)
@@ -1,6 +1,6 @@
package B::Terse;
-our $VERSION = '1.05';
+our $VERSION = '1.06';
use strict;
use B qw(class @specialsv_name);
@@ -78,7 +78,15 @@
=head1 DESCRIPTION
-This version of B::Terse is really just a wrapper that calls B::Concise
+This module prints the contents of the parse tree, but without as much
+information as L<B::Debug>. For comparison, C<print "Hello, world.">
+produced 96 lines of output from B::Debug, but only 6 from B::Terse.
+
+This module is useful for people who are writing their own back end,
+or who are learning about the Perl internals. It's not useful to the
+average programmer.
+
+This version of B::Terse is really just a wrapper that calls L<B::Concise>
with the B<-terse> option. It is provided for compatibility with old scripts
(and habits) but using B::Concise directly is now recommended instead.
Property changes on: trunk/contrib/perl/ext/B/B/Terse.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/ext/B/B/Xref.pm
===================================================================
--- trunk/contrib/perl/ext/B/B/Xref.pm 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/B/B/Xref.pm 2013-12-02 21:32:26 UTC (rev 6445)
@@ -1,6 +1,6 @@
package B::Xref;
-our $VERSION = '1.02';
+our $VERSION = '1.05';
=head1 NAME
@@ -48,6 +48,56 @@
"&". Subroutine definitions are indicated by "s" and format
definitions by "f".
+For instance, here's part of the report from the I<pod2man> program that
+comes with Perl:
+
+ Subroutine clear_noremap
+ Package (lexical)
+ $ready_to_print i1069, 1079
+ Package main
+ $& 1086
+ $. 1086
+ $0 1086
+ $1 1087
+ $2 1085, 1085
+ $3 1085, 1085
+ $ARGV 1086
+ %HTML_Escapes 1085, 1085
+
+This shows the variables used in the subroutine C<clear_noremap>. The
+variable C<$ready_to_print> is a my() (lexical) variable,
+B<i>ntroduced (first declared with my()) on line 1069, and used on
+line 1079. The variable C<$&> from the main package is used on 1086,
+and so on.
+
+A line number may be prefixed by a single letter:
+
+=over 4
+
+=item i
+
+Lexical variable introduced (declared with my()) for the first time.
+
+=item &
+
+Subroutine or method call.
+
+=item s
+
+Subroutine defined.
+
+=item r
+
+Format defined.
+
+=back
+
+The most useful option the cross referencer has is to save the report
+to a separate file. For instance, to save the report on
+I<myperlprogram> to the file I<report>:
+
+ $ perl -MO=Xref,-oreport myperlprogram
+
=head1 OPTIONS
Option words are separated by commas (not whitespace) and follow the
@@ -142,7 +192,7 @@
my $padlist = shift;
my ($namelistav, $vallistav, @namelist, $ix);
@pad = ();
- return if class($padlist) eq "SPECIAL";
+ return if class($padlist) =~ '^(?:SPECIAL|NULL)\z';
($namelistav,$vallistav) = $padlist->ARRAY;
@namelist = $namelistav->ARRAY;
for ($ix = 1; $ix < @namelist; $ix++) {
@@ -225,6 +275,15 @@
$top = UNKNOWN;
}
+sub pp_padrange {
+ my $op = shift;
+ my $count = $op->private & 127;
+ for my $i (0..$count-1) {
+ $top = $pad[$op->targ + $i];
+ process($top, $op->private & OPpLVAL_INTRO ? "intro" : "used");
+ }
+}
+
sub pp_padsv {
my $op = shift;
$top = $pad[$op->targ];
Property changes on: trunk/contrib/perl/ext/B/B/Xref.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/ext/B/B.pm
===================================================================
--- trunk/contrib/perl/ext/B/B.pm 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/B/B.pm 2013-12-02 21:32:26 UTC (rev 6445)
@@ -15,7 +15,7 @@
# walkoptree comes from B.xs
BEGIN {
- $B::VERSION = '1.29';
+ $B::VERSION = '1.42_01';
@B::EXPORT_OK = ();
# Our BOOT code needs $VERSION set, and will append to @EXPORT_OK.
@@ -35,8 +35,7 @@
parents comppadlist sv_undef compile_stats timing_info
begin_av init_av check_av end_av regex_padav dowarn
defstash curstash warnhook diehook inc_gv @optype
- @specialsv_name
- ), $] > 5.009 && 'unitcheck_av');
+ @specialsv_name unitcheck_av));
@B::SV::ISA = 'B::OBJECT';
@B::NULL::ISA = 'B::SV';
@@ -49,10 +48,8 @@
@B::PVNV::ISA = qw(B::PVIV B::NV);
@B::PVMG::ISA = 'B::PVNV';
@B::REGEXP::ISA = 'B::PVMG' if $] >= 5.011;
-# Change in the inheritance hierarchy post 5.9.0
- at B::PVLV::ISA = $] > 5.009 ? 'B::GV' : 'B::PVMG';
-# BM is eliminated post 5.9.5, but effectively is a specialisation of GV now.
- at B::BM::ISA = $] > 5.009005 ? 'B::GV' : 'B::PVMG';
+ at B::PVLV::ISA = 'B::GV';
+ at B::BM::ISA = 'B::GV';
@B::AV::ISA = 'B::PVMG';
@B::GV::ISA = 'B::PVMG';
@B::HV::ISA = 'B::PVMG';
@@ -253,7 +250,8 @@
my $fullname;
no strict 'refs';
$prefix = '' unless defined $prefix;
- while (($sym, $ref) = each %$symref) {
+ foreach my $sym ( sort keys %$symref ) {
+ $ref= $symref->{$sym};
$fullname = "*main::".$prefix.$sym;
if ($sym =~ /::$/) {
$sym = $prefix . $sym;
@@ -347,11 +345,11 @@
=head1 DESCRIPTION
The C<B> module supplies classes which allow a Perl program to delve
-into its own innards. It is the module used to implement the
-"backends" of the Perl compiler. Usage of the compiler does not
+into its own innards. It is the module used to implement the
+"backends" of the Perl compiler. Usage of the compiler does not
require knowledge of this module: see the F<O> module for the
-user-visible part. The C<B> module is of use to those who want to
-write new compiler backends. This documentation assumes that the
+user-visible part. The C<B> module is of use to those who want to
+write new compiler backends. This documentation assumes that the
reader knows a fair amount about perl's internals including such
things as SVs, OPs and the internal symbol table and syntax tree
of a program.
@@ -394,17 +392,19 @@
Takes a reference to any Perl value, and turns the referred-to value
into an object in the appropriate B::OP-derived or B::SV-derived
-class. Apart from functions such as C<main_root>, this is the primary
+class. Apart from functions such as C<main_root>, this is the primary
way to get an initial "handle" on an internal perl data structure
which can then be followed with the other access methods.
The returned object will only be valid as long as the underlying OPs
-and SVs continue to exist. Do not attempt to use the object after the
+and SVs continue to exist. Do not attempt to use the object after the
underlying structures are freed.
=item amagic_generation
Returns the SV object corresponding to the C variable C<amagic_generation>.
+As of Perl 5.18, this is just an alias to C<PL_na>, so its value is
+meaningless.
=item init_av
@@ -458,10 +458,10 @@
# Walk CGI's symbol table calling print_subs on each symbol.
# Recurse only into CGI::Util::
- walksymtable(\%CGI::, 'print_subs', sub { $_[0] eq 'CGI::Util::' },
- 'CGI::');
+ walksymtable(\%CGI::, 'print_subs',
+ sub { $_[0] eq 'CGI::Util::' }, 'CGI::');
-print_subs() is a B::GV method you have declared. Also see L<"B::GV
+print_subs() is a B::GV method you have declared. Also see L<"B::GV
Methods">, below.
=back
@@ -486,7 +486,7 @@
=item walkoptree(OP, METHOD)
Does a tree-walk of the syntax tree based at OP and calls METHOD on
-each op it visits. Each node is visited before its children. If
+each op it visits. Each node is visited before its children. If
C<walkoptree_debug> (see below) has been called to turn debugging on then
the method C<walkoptree_debug> is called on each op before METHOD is
called.
@@ -493,8 +493,8 @@
=item walkoptree_debug(DEBUG)
-Returns the current debugging flag for C<walkoptree>. If the optional
-DEBUG argument is non-zero, it sets the debugging flag to that. See
+Returns the current debugging flag for C<walkoptree>. If the optional
+DEBUG argument is non-zero, it sets the debugging flag to that. See
the description of C<walkoptree> above for what the debugging flag
does.
@@ -519,7 +519,7 @@
=item minus_c
-Does the equivalent of the C<-c> command-line option. Obviously, this
+Does the equivalent of the C<-c> command-line option. Obviously, this
is only useful in a BEGIN block or else the flag is set too late.
=item cstring(STR)
@@ -535,7 +535,7 @@
=item class(OBJ)
Returns the class of an object without the part of the classname
-preceding the first C<"::">. This is used to turn C<"B::UNOP"> into
+preceding the first C<"::">. This is used to turn C<"B::UNOP"> into
C<"UNOP"> for example.
=item threadsv_names
@@ -572,7 +572,7 @@
The C structures used by Perl's internals to hold SV and OP
information (PVIV, AV, HV, ..., OP, SVOP, UNOP, ...) are modelled on a
class hierarchy and the C<B> module gives access to them via a true
-object hierarchy. Structure fields which point to other objects
+object hierarchy. Structure fields which point to other objects
(whether types of SV or types of OP) are represented by the C<B>
module as Perl objects of the appropriate class.
@@ -580,18 +580,18 @@
these structures.
Note that all access is read-only. You cannot modify the internals by
-using this module. Also, note that the B::OP and B::SV objects created
+using this module. Also, note that the B::OP and B::SV objects created
by this module are only valid for as long as the underlying objects
exist; their creation doesn't increase the reference counts of the
-underlying objects. Trying to access the fields of a freed object will
+underlying objects. Trying to access the fields of a freed object will
give incomprehensible results, or worse.
=head2 SV-RELATED CLASSES
B::IV, B::NV, B::RV, B::PV, B::PVIV, B::PVNV, B::PVMG, B::BM (5.9.5 and
-earlier), B::PVLV, B::AV, B::HV, B::CV, B::GV, B::FM, B::IO. These classes
+earlier), B::PVLV, B::AV, B::HV, B::CV, B::GV, B::FM, B::IO. These classes
correspond in the obvious way to the underlying C structures of similar names.
-The inheritance hierarchy mimics the underlying C "inheritance". For the
+The inheritance hierarchy mimics the underlying C "inheritance". For the
5.10.x branch, (I<ie> 5.10.0, 5.10.1 I<etc>) this is:
B::SV
@@ -661,8 +661,8 @@
Access methods correspond to the underlying C macros for field access,
usually with the leading "class indication" prefix removed (Sv, Av,
-Hv, ...). The leading prefix is only left in cases where its removal
-would cause a clash in method name. For example, C<GvREFCNT> stays
+Hv, ...). The leading prefix is only left in cases where its removal
+would cause a clash in method name. For example, C<GvREFCNT> stays
as-is since its abbreviation would clash with the "superclass" method
C<REFCNT> (corresponding to the C function C<SvREFCNT>).
@@ -677,8 +677,8 @@
=item object_2svref
Returns a reference to the regular scalar corresponding to this
-B::SV object. In other words, this method is the inverse operation
-to the svref_2object() subroutine. This scalar and other data it points
+B::SV object. In other words, this method is the inverse operation
+to the svref_2object() subroutine. This scalar and other data it points
at should be considered read-only: modifying them is neither safe nor
guaranteed to have a sensible effect.
@@ -691,8 +691,8 @@
=item IV
Returns the value of the IV, I<interpreted as
-a signed integer>. This will be misleading
-if C<FLAGS & SVf_IVisUV>. Perhaps you want the
+a signed integer>. This will be misleading
+if C<FLAGS & SVf_IVisUV>. Perhaps you want the
C<int_value> method instead?
=item IVX
@@ -736,7 +736,7 @@
=item PV
-This method is the one you usually want. It constructs a
+This method is the one you usually want. It constructs a
string using the length and offset information in the struct:
for ordinary scalars it will return the string that you'd see
from Perl, even if it contains null characters.
@@ -748,15 +748,25 @@
=item PVX
-This method is less often useful. It assumes that the string
+This method is less often useful. It assumes that the string
stored in the struct is null-terminated, and disregards the
length information.
It is the appropriate method to use if you need to get the name
-of a lexical variable from a padname array. Lexical variable names
+of a lexical variable from a padname array. Lexical variable names
are always stored with a null terminator, and the length field
-(SvCUR) is overloaded for other purposes and can't be relied on here.
+(CUR) is overloaded for other purposes and can't be relied on here.
+=item CUR
+
+This method returns the internal length field, which consists of the number
+of internal bytes, not necessarily the number of logical characters.
+
+=item LEN
+
+This method returns the number of bytes allocated (via malloc) for storing
+the string. This is 0 if the scalar does not "own" the string.
+
=back
=head2 B::PVMG Methods
@@ -883,6 +893,15 @@
=head2 B::IO Methods
+B::IO objects derive from IO objects and you will get more information from
+the IO object itself.
+
+For example:
+
+ $gvio = B::svref_2object(\*main::stdin)->IO;
+ $IO = $gvio->object_2svref();
+ $fd = $IO->fileno();
+
=over 4
=item LINES
@@ -909,14 +928,29 @@
=item IoTYPE
+A character symbolizing the type of IO Handle.
+
+ - STDIN/OUT
+ I STDIN/OUT/ERR
+ < read-only
+ > write-only
+ a append
+ + read and write
+ s socket
+ | pipe
+ I IMPLICIT
+ # NUMERIC
+ space closed handle
+ \0 closed internal handle
+
=item IoFLAGS
=item IsSTD
-Takes one arguments ( 'stdin' | 'stdout' | 'stderr' ) and returns true
+Takes one argument ( 'stdin' | 'stdout' | 'stderr' ) and returns true
if the IoIFP of the object is equal to the handle whose name was
-passed as argument ( i.e. $io->IsSTD('stderr') is true if
-IoIFP($io) == PerlIO_stdin() ).
+passed as argument; i.e., $io->IsSTD('stderr') is true if
+IoIFP($io) == PerlIO_stderr().
=back
@@ -942,7 +976,8 @@
=item AvFLAGS
-This method returns the AV specific flags. In Perl 5.9 these are now stored
+This method returns the AV specific
+flags. In Perl 5.9 these are now stored
in with the main SV flags, so this method is no longer present.
=back
@@ -979,6 +1014,10 @@
=item const_sv
+=item NAME_HEK
+
+Returns the name of a lexical sub, otherwise C<undef>.
+
=back
=head2 B::HV Methods
@@ -1010,7 +1049,7 @@
C<B::SVOP>, C<B::PADOP>, C<B::PVOP>, C<B::LOOP>, C<B::COP>.
These classes correspond in the obvious way to the underlying C
-structures of similar names. The inheritance hierarchy mimics the
+structures of similar names. The inheritance hierarchy mimics the
underlying C "inheritance":
B::OP
@@ -1126,6 +1165,10 @@
Only when perl was compiled with ithreads.
+=item code_list
+
+Since perl 5.17.1
+
=back
=head2 B::SVOP METHOD
@@ -1176,6 +1219,8 @@
=item stashpv
+=item stashoff (threaded only)
+
=item file
=item cop_seq
@@ -1195,6 +1240,29 @@
=back
+=head2 $B::overlay
+
+Although the optree is read-only, there is an overlay facility that allows
+you to override what values the various B::*OP methods return for a
+particular op. C<$B::overlay> should be set to reference a two-deep hash:
+indexed by OP address, then method name. Whenever a an op method is
+called, the value in the hash is returned if it exists. This facility is
+used by B::Deparse to "undo" some optimisations. For example:
+
+
+ local $B::overlay = {};
+ ...
+ if ($op->name eq "foo") {
+ $B::overlay->{$$op} = {
+ name => 'bar',
+ next => $op->next->next,
+ };
+ }
+ ...
+ $op->name # returns "bar"
+ $op->next # returns the next op but one
+
+
=head1 AUTHOR
Malcolm Beattie, C<mbeattie at sable.ox.ac.uk>
Property changes on: trunk/contrib/perl/ext/B/B.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/ext/B/B.xs
===================================================================
--- trunk/contrib/perl/ext/B/B.xs 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/B/B.xs 2013-12-02 21:32:26 UTC (rev 6445)
@@ -21,9 +21,7 @@
static const char* const svclassnames[] = {
"B::NULL",
-#if PERL_VERSION >= 9
"B::BIND",
-#endif
"B::IV",
"B::NV",
#if PERL_VERSION <= 10
@@ -33,22 +31,14 @@
"B::PVIV",
"B::PVNV",
"B::PVMG",
-#if PERL_VERSION <= 8
- "B::BM",
-#endif
#if PERL_VERSION >= 11
"B::REGEXP",
#endif
-#if PERL_VERSION >= 9
"B::GV",
-#endif
"B::PVLV",
"B::AV",
"B::HV",
"B::CV",
-#if PERL_VERSION <= 8
- "B::GV",
-#endif
"B::FM",
"B::IO",
};
@@ -125,9 +115,11 @@
return ((o->op_private & OPpASSIGN_BACKWARDS) ? OPc_UNOP : OPc_BINOP);
if (o->op_type == OP_AELEMFAST) {
+#if PERL_VERSION <= 14
if (o->op_flags & OPf_SPECIAL)
return OPc_BASEOP;
else
+#endif
#ifdef USE_ITHREADS
return OPc_PADOP;
#else
@@ -181,8 +173,7 @@
return (!custom &&
(o->op_private & (OPpTRANS_TO_UTF|OPpTRANS_FROM_UTF))
)
-#if defined(USE_ITHREADS) \
- && (PERL_VERSION > 8 || (PERL_VERSION == 8 && PERL_SUBVERSION >= 9))
+#if defined(USE_ITHREADS)
? OPc_PADOP : OPc_PVOP;
#else
? OPc_SVOP : OPc_PVOP;
@@ -250,7 +241,39 @@
return opsv;
}
+
static SV *
+get_overlay_object(pTHX_ const OP *o, const char * const name, U32 namelen)
+{
+ HE *he;
+ SV **svp;
+ SV *key;
+ SV *sv =get_sv("B::overlay", 0);
+ if (!sv || !SvROK(sv))
+ return NULL;
+ sv = SvRV(sv);
+ if (SvTYPE(sv) != SVt_PVHV)
+ return NULL;
+ key = newSViv(PTR2IV(o));
+ he = hv_fetch_ent((HV*)sv, key, 0, 0);
+ SvREFCNT_dec(key);
+ if (!he)
+ return NULL;
+ sv = HeVAL(he);
+ if (!sv || !SvROK(sv))
+ return NULL;
+ sv = SvRV(sv);
+ if (SvTYPE(sv) != SVt_PVHV)
+ return NULL;
+ svp = hv_fetch((HV*)sv, name, namelen, 0);
+ if (!svp)
+ return NULL;
+ sv = *svp;
+ return sv;
+}
+
+
+static SV *
make_sv_object(pTHX_ SV *sv)
{
SV *const arg = sv_newmortal();
@@ -272,7 +295,6 @@
return arg;
}
-#if PERL_VERSION >= 9
static SV *
make_temp_object(pTHX_ SV *temp)
{
@@ -337,7 +359,6 @@
return make_sv_object(aTHX_ NULL);
}
}
-#endif
static SV *
make_mg_object(pTHX_ MAGIC *mg)
@@ -401,11 +422,7 @@
sv_catpvs(sstr, "\\$");
else if (perlstyle && *s == '@')
sv_catpvs(sstr, "\\@");
-#ifdef EBCDIC
else if (isPRINT(*s))
-#else
- else if (*s >= ' ' && *s < 127)
-#endif /* EBCDIC */
sv_catpvn(sstr, s, 1);
else if (*s == '\n')
sv_catpvs(sstr, "\\n");
@@ -446,11 +463,7 @@
sv_catpvs(sstr, "\\'");
else if (c == '\\')
sv_catpvs(sstr, "\\\\");
-#ifdef EBCDIC
else if (isPRINT(c))
-#else
- else if (c >= ' ' && c < 127)
-#endif /* EBCDIC */
sv_catpvn(sstr, s, 1);
else if (c == '\n')
sv_catpvs(sstr, "\\n");
@@ -472,15 +485,8 @@
return sstr;
}
-#if PERL_VERSION >= 9
-# define PMOP_pmreplstart(o) o->op_pmstashstartu.op_pmreplstart
-# define PMOP_pmreplroot(o) o->op_pmreplrootu.op_pmreplroot
-#else
-# define PMOP_pmreplstart(o) o->op_pmreplstart
-# define PMOP_pmreplroot(o) o->op_pmreplroot
-# define PMOP_pmpermflags(o) o->op_pmpermflags
-# define PMOP_pmdynflags(o) o->op_pmdynflags
-#endif
+#define PMOP_pmreplstart(o) o->op_pmstashstartu.op_pmreplstart
+#define PMOP_pmreplroot(o) o->op_pmreplrootu.op_pmreplroot
static SV *
walkoptree(pTHX_ OP *o, const char *method, SV *ref)
@@ -533,15 +539,9 @@
oplist(pTHX_ OP *o, SV **SP)
{
for(; o; o = o->op_next) {
-#if PERL_VERSION >= 9
if (o->op_opt == 0)
break;
o->op_opt = 0;
-#else
- if (o->op_seq == 0)
- break;
- o->op_seq = 0;
-#endif
XPUSHs(make_op_object(aTHX_ o));
switch (o->op_type) {
case OP_SUBST:
@@ -602,15 +602,16 @@
typedef MAGIC *B__MAGIC;
typedef HE *B__HE;
-#if PERL_VERSION >= 9
typedef struct refcounted_he *B__RHE;
+#ifdef PadlistARRAY
+typedef PADLIST *B__PADLIST;
#endif
#ifdef MULTIPLICITY
-# define ASSIGN_COMMON_ALIAS(var) \
- STMT_START { XSANY.any_i32 = offsetof(struct interpreter, var); } STMT_END
+# define ASSIGN_COMMON_ALIAS(prefix, var) \
+ STMT_START { XSANY.any_i32 = offsetof(struct interpreter, prefix##var); } STMT_END
#else
-# define ASSIGN_COMMON_ALIAS(var) \
+# define ASSIGN_COMMON_ALIAS(prefix, var) \
STMT_START { XSANY.any_ptr = (void *)&PL_##var; } STMT_END
#endif
@@ -633,6 +634,92 @@
XSRETURN(1);
}
+
+
+#define SVp 0x00000
+#define U32p 0x10000
+#define line_tp 0x20000
+#define OPp 0x30000
+#define PADOFFSETp 0x40000
+#define U8p 0x50000
+#define IVp 0x60000
+#define char_pp 0x70000
+
+/* table that drives most of the B::*OP methods */
+
+struct OP_methods {
+ const char *name;
+ STRLEN namelen;
+ I32 type;
+ size_t offset; /* if -1, access is handled on a case-by-case basis */
+} op_methods[] = {
+ STR_WITH_LEN("next"), OPp, offsetof(struct op, op_next), /* 0*/
+ STR_WITH_LEN("sibling"), OPp, offsetof(struct op, op_sibling), /* 1*/
+ STR_WITH_LEN("targ"), PADOFFSETp, offsetof(struct op, op_targ), /* 2*/
+ STR_WITH_LEN("flags"), U8p, offsetof(struct op, op_flags), /* 3*/
+ STR_WITH_LEN("private"), U8p, offsetof(struct op, op_private), /* 4*/
+ STR_WITH_LEN("first"), OPp, offsetof(struct unop, op_first), /* 5*/
+ STR_WITH_LEN("last"), OPp, offsetof(struct binop, op_last), /* 6*/
+ STR_WITH_LEN("other"), OPp, offsetof(struct logop, op_other), /* 7*/
+ STR_WITH_LEN("pmreplstart"), 0, -1, /* 8*/
+ STR_WITH_LEN("redoop"), OPp, offsetof(struct loop, op_redoop), /* 9*/
+ STR_WITH_LEN("nextop"), OPp, offsetof(struct loop, op_nextop), /*10*/
+ STR_WITH_LEN("lastop"), OPp, offsetof(struct loop, op_lastop), /*11*/
+ STR_WITH_LEN("pmflags"), U32p, offsetof(struct pmop, op_pmflags), /*12*/
+#if PERL_VERSION >= 17
+ STR_WITH_LEN("code_list"),OPp, offsetof(struct pmop, op_code_list),/*13*/
+#else
+ STR_WITH_LEN("code_list"),0, -1,
+#endif
+ STR_WITH_LEN("sv"), SVp, offsetof(struct svop, op_sv), /*14*/
+ STR_WITH_LEN("gv"), SVp, offsetof(struct svop, op_sv), /*15*/
+ STR_WITH_LEN("padix"), PADOFFSETp,offsetof(struct padop, op_padix),/*16*/
+ STR_WITH_LEN("cop_seq"), U32p, offsetof(struct cop, cop_seq), /*17*/
+ STR_WITH_LEN("line"), line_tp, offsetof(struct cop, cop_line), /*18*/
+ STR_WITH_LEN("hints"), U32p, offsetof(struct cop, cop_hints), /*19*/
+#ifdef USE_ITHREADS
+ STR_WITH_LEN("pmoffset"),IVp, offsetof(struct pmop, op_pmoffset),/*20*/
+ STR_WITH_LEN("filegv"), 0, -1, /*21*/
+ STR_WITH_LEN("file"), char_pp, offsetof(struct cop, cop_file), /*22*/
+ STR_WITH_LEN("stash"), 0, -1, /*23*/
+# if PERL_VERSION < 17
+ STR_WITH_LEN("stashpv"), char_pp, offsetof(struct cop, cop_stashpv), /*24*/
+ STR_WITH_LEN("stashoff"),0, -1, /*25*/
+# else
+ STR_WITH_LEN("stashpv"), 0, -1, /*24*/
+ STR_WITH_LEN("stashoff"),PADOFFSETp,offsetof(struct cop, cop_stashoff),/*25*/
+# endif
+#else
+ STR_WITH_LEN("pmoffset"),0, -1, /*20*/
+ STR_WITH_LEN("filegv"), SVp, offsetof(struct cop, cop_filegv), /*21*/
+ STR_WITH_LEN("file"), 0, -1, /*22*/
+ STR_WITH_LEN("stash"), SVp, offsetof(struct cop, cop_stash), /*23*/
+ STR_WITH_LEN("stashpv"), 0, -1, /*24*/
+ STR_WITH_LEN("stashoff"),0, -1, /*25*/
+#endif
+ STR_WITH_LEN("size"), 0, -1, /*26*/
+ STR_WITH_LEN("name"), 0, -1, /*27*/
+ STR_WITH_LEN("desc"), 0, -1, /*28*/
+ STR_WITH_LEN("ppaddr"), 0, -1, /*29*/
+ STR_WITH_LEN("type"), 0, -1, /*30*/
+ STR_WITH_LEN("opt"), 0, -1, /*31*/
+ STR_WITH_LEN("spare"), 0, -1, /*32*/
+ STR_WITH_LEN("children"),0, -1, /*33*/
+ STR_WITH_LEN("pmreplroot"), 0, -1, /*34*/
+ STR_WITH_LEN("pmstashpv"), 0, -1, /*35*/
+ STR_WITH_LEN("pmstash"), 0, -1, /*36*/
+ STR_WITH_LEN("precomp"), 0, -1, /*37*/
+ STR_WITH_LEN("reflags"), 0, -1, /*38*/
+ STR_WITH_LEN("sv"), 0, -1, /*39*/
+ STR_WITH_LEN("gv"), 0, -1, /*40*/
+ STR_WITH_LEN("pv"), 0, -1, /*41*/
+ STR_WITH_LEN("label"), 0, -1, /*42*/
+ STR_WITH_LEN("arybase"), 0, -1, /*43*/
+ STR_WITH_LEN("warnings"),0, -1, /*44*/
+ STR_WITH_LEN("io"), 0, -1, /*45*/
+ STR_WITH_LEN("hints_hash"),0, -1, /*46*/
+};
+
#include "const-c.inc"
MODULE = B PACKAGE = B
@@ -655,37 +742,46 @@
specialsv_list[6] = (SV *) pWARN_STD;
cv = newXS("B::init_av", intrpvar_sv_common, file);
- ASSIGN_COMMON_ALIAS(Iinitav);
+ ASSIGN_COMMON_ALIAS(I, initav);
cv = newXS("B::check_av", intrpvar_sv_common, file);
- ASSIGN_COMMON_ALIAS(Icheckav_save);
-#if PERL_VERSION >= 9
+ ASSIGN_COMMON_ALIAS(I, checkav_save);
cv = newXS("B::unitcheck_av", intrpvar_sv_common, file);
- ASSIGN_COMMON_ALIAS(Iunitcheckav_save);
-#endif
+ ASSIGN_COMMON_ALIAS(I, unitcheckav_save);
cv = newXS("B::begin_av", intrpvar_sv_common, file);
- ASSIGN_COMMON_ALIAS(Ibeginav_save);
+ ASSIGN_COMMON_ALIAS(I, beginav_save);
cv = newXS("B::end_av", intrpvar_sv_common, file);
- ASSIGN_COMMON_ALIAS(Iendav);
+ ASSIGN_COMMON_ALIAS(I, endav);
cv = newXS("B::main_cv", intrpvar_sv_common, file);
- ASSIGN_COMMON_ALIAS(Imain_cv);
+ ASSIGN_COMMON_ALIAS(I, main_cv);
cv = newXS("B::inc_gv", intrpvar_sv_common, file);
- ASSIGN_COMMON_ALIAS(Iincgv);
+ ASSIGN_COMMON_ALIAS(I, incgv);
cv = newXS("B::defstash", intrpvar_sv_common, file);
- ASSIGN_COMMON_ALIAS(Idefstash);
+ ASSIGN_COMMON_ALIAS(I, defstash);
cv = newXS("B::curstash", intrpvar_sv_common, file);
- ASSIGN_COMMON_ALIAS(Icurstash);
+ ASSIGN_COMMON_ALIAS(I, curstash);
+#ifdef PL_formfeed
cv = newXS("B::formfeed", intrpvar_sv_common, file);
- ASSIGN_COMMON_ALIAS(Iformfeed);
+ ASSIGN_COMMON_ALIAS(I, formfeed);
+#endif
#ifdef USE_ITHREADS
cv = newXS("B::regex_padav", intrpvar_sv_common, file);
- ASSIGN_COMMON_ALIAS(Iregex_padav);
+ ASSIGN_COMMON_ALIAS(I, regex_padav);
#endif
cv = newXS("B::warnhook", intrpvar_sv_common, file);
- ASSIGN_COMMON_ALIAS(Iwarnhook);
+ ASSIGN_COMMON_ALIAS(I, warnhook);
cv = newXS("B::diehook", intrpvar_sv_common, file);
- ASSIGN_COMMON_ALIAS(Idiehook);
+ ASSIGN_COMMON_ALIAS(I, diehook);
}
+#ifndef PL_formfeed
+
+void
+formfeed()
+ PPCODE:
+ PUSHs(make_sv_object(aTHX_ GvSV(gv_fetchpvs("\f", GV_ADD, SVt_PV))));
+
+#endif
+
long
amagic_generation()
CODE:
@@ -695,9 +791,19 @@
void
comppadlist()
+ PREINIT:
+ PADLIST *padlist = CvPADLIST(PL_main_cv ? PL_main_cv : PL_compcv);
PPCODE:
- PUSHs(make_sv_object(aTHX_ (SV *)(PL_main_cv ? CvPADLIST(PL_main_cv)
- : CvPADLIST(PL_compcv))));
+#ifdef PadlistARRAY
+ {
+ SV * const rv = sv_newmortal();
+ sv_setiv(newSVrv(rv, padlist ? "B::PADLIST" : "B::NULL"),
+ PTR2IV(padlist));
+ PUSHs(rv);
+ }
+#else
+ PUSHs(make_sv_object(aTHX_ (SV *)padlist));
+#endif
void
sv_undef()
@@ -782,10 +888,8 @@
int opnum
CODE:
ST(0) = sv_newmortal();
- if (opnum >= 0 && opnum < PL_maxo) {
- sv_setpvs(ST(0), "pp_");
- sv_catpv(ST(0), PL_op_name[opnum]);
- }
+ if (opnum >= 0 && opnum < PL_maxo)
+ Perl_sv_setpvf(aTHX_ ST(0), "pp_%s", PL_op_name[opnum]);
void
hash(sv)
@@ -824,82 +928,12 @@
void
threadsv_names()
PPCODE:
-#if PERL_VERSION <= 8
-# ifdef USE_5005THREADS
- int i;
- const STRLEN len = strlen(PL_threadsv_names);
- EXTEND(sp, len);
- for (i = 0; i < len; i++)
- PUSHs(newSVpvn_flags(&PL_threadsv_names[i], 1, SVs_TEMP));
-# endif
-#endif
-#define SVp 0x00000
-#define U32p 0x10000
-#define line_tp 0x20000
-#define OPp 0x30000
-#define PADOFFSETp 0x40000
-#define U8p 0x50000
-#define IVp 0x60000
-#define char_pp 0x70000
-#define OP_next_ix OPp | offsetof(struct op, op_next)
-#define OP_sibling_ix OPp | offsetof(struct op, op_sibling)
-#define UNOP_first_ix OPp | offsetof(struct unop, op_first)
-#define BINOP_last_ix OPp | offsetof(struct binop, op_last)
-#define LOGOP_other_ix OPp | offsetof(struct logop, op_other)
-#if PERL_VERSION >= 9
-# define PMOP_pmreplstart_ix \
- OPp | offsetof(struct pmop, op_pmstashstartu.op_pmreplstart)
-#else
-# define PMOP_pmreplstart_ix OPp | offsetof(struct pmop, op_pmreplstart)
-#endif
-#define LOOP_redoop_ix OPp | offsetof(struct loop, op_redoop)
-#define LOOP_nextop_ix OPp | offsetof(struct loop, op_nextop)
-#define LOOP_lastop_ix OPp | offsetof(struct loop, op_lastop)
-#define OP_targ_ix PADOFFSETp | offsetof(struct op, op_targ)
-#define OP_flags_ix U8p | offsetof(struct op, op_flags)
-#define OP_private_ix U8p | offsetof(struct op, op_private)
-
-#define PMOP_pmflags_ix U32p | offsetof(struct pmop, op_pmflags)
-
-#ifdef USE_ITHREADS
-#define PMOP_pmoffset_ix IVp | offsetof(struct pmop, op_pmoffset)
-#endif
-
-# Yes, B::SV::sv and B::SV::gv really do end up generating identical code.
-#define SVOP_sv_ix SVp | offsetof(struct svop, op_sv)
-#define SVOP_gv_ix SVp | offsetof(struct svop, op_sv)
-
-#define PADOP_padix_ix PADOFFSETp | offsetof(struct padop, op_padix)
-
-#define COP_seq_ix U32p | offsetof(struct cop, cop_seq)
-#define COP_line_ix line_tp | offsetof(struct cop, cop_line)
-#if PERL_VERSION >= 9
-#define COP_hints_ix U32p | offsetof(struct cop, cop_hints)
-#else
-#define COP_hints_ix U8p | offsetof(struct cop, op_private)
-#endif
-
-#ifdef USE_ITHREADS
-#define COP_stashpv_ix char_pp | offsetof(struct cop, cop_stashpv)
-#define COP_file_ix char_pp | offsetof(struct cop, cop_file)
-#else
-#define COP_stash_ix SVp | offsetof(struct cop, cop_stash)
-#define COP_filegv_ix SVp | offsetof(struct cop, cop_filegv)
-#endif
-
MODULE = B PACKAGE = B::OP
-size_t
-size(o)
- B::OP o
- CODE:
- RETVAL = opsizes[cc_opclass(aTHX_ o)];
- OUTPUT:
- RETVAL
# The type checking code in B has always been identical for all OP types,
# irrespective of whether the action is actually defined on that OP.
@@ -908,35 +942,252 @@
next(o)
B::OP o
ALIAS:
- B::OP::next = OP_next_ix
- B::OP::sibling = OP_sibling_ix
- B::OP::targ = OP_targ_ix
- B::OP::flags = OP_flags_ix
- B::OP::private = OP_private_ix
- B::UNOP::first = UNOP_first_ix
- B::BINOP::last = BINOP_last_ix
- B::LOGOP::other = LOGOP_other_ix
- B::PMOP::pmreplstart = PMOP_pmreplstart_ix
- B::LOOP::redoop = LOOP_redoop_ix
- B::LOOP::nextop = LOOP_nextop_ix
- B::LOOP::lastop = LOOP_lastop_ix
- B::PMOP::pmflags = PMOP_pmflags_ix
- B::SVOP::sv = SVOP_sv_ix
- B::SVOP::gv = SVOP_gv_ix
- B::PADOP::padix = PADOP_padix_ix
- B::COP::cop_seq = COP_seq_ix
- B::COP::line = COP_line_ix
- B::COP::hints = COP_hints_ix
+ B::OP::next = 0
+ B::OP::sibling = 1
+ B::OP::targ = 2
+ B::OP::flags = 3
+ B::OP::private = 4
+ B::UNOP::first = 5
+ B::BINOP::last = 6
+ B::LOGOP::other = 7
+ B::PMOP::pmreplstart = 8
+ B::LOOP::redoop = 9
+ B::LOOP::nextop = 10
+ B::LOOP::lastop = 11
+ B::PMOP::pmflags = 12
+ B::PMOP::code_list = 13
+ B::SVOP::sv = 14
+ B::SVOP::gv = 15
+ B::PADOP::padix = 16
+ B::COP::cop_seq = 17
+ B::COP::line = 18
+ B::COP::hints = 19
+ B::PMOP::pmoffset = 20
+ B::COP::filegv = 21
+ B::COP::file = 22
+ B::COP::stash = 23
+ B::COP::stashpv = 24
+ B::COP::stashoff = 25
+ B::OP::size = 26
+ B::OP::name = 27
+ B::OP::desc = 28
+ B::OP::ppaddr = 29
+ B::OP::type = 30
+ B::OP::opt = 31
+ B::OP::spare = 32
+ B::LISTOP::children = 33
+ B::PMOP::pmreplroot = 34
+ B::PMOP::pmstashpv = 35
+ B::PMOP::pmstash = 36
+ B::PMOP::precomp = 37
+ B::PMOP::reflags = 38
+ B::PADOP::sv = 39
+ B::PADOP::gv = 40
+ B::PVOP::pv = 41
+ B::COP::label = 42
+ B::COP::arybase = 43
+ B::COP::warnings = 44
+ B::COP::io = 45
+ B::COP::hints_hash = 46
PREINIT:
char *ptr;
SV *ret;
+ I32 type;
+ I32 offset;
+ STRLEN len;
PPCODE:
- ptr = (ix & 0xFFFF) + (char *)o;
- switch ((U8)(ix >> 16)) {
- case (U8)(OPp >> 16):
+ if (ix < 0 || ix > 46)
+ croak("Illegal alias %d for B::*OP::next", (int)ix);
+ ret = get_overlay_object(aTHX_ o,
+ op_methods[ix].name, op_methods[ix].namelen);
+ if (ret) {
+ ST(0) = ret;
+ XSRETURN(1);
+ }
+
+ /* handle non-direct field access */
+
+ offset = op_methods[ix].offset;
+ if (offset < 0) {
+ switch (ix) {
+ case 8: /* pmreplstart */
+ ret = make_op_object(aTHX_
+ cPMOPo->op_type == OP_SUBST
+ ? cPMOPo->op_pmstashstartu.op_pmreplstart
+ : NULL
+ );
+ break;
+#ifdef USE_ITHREADS
+ case 21: /* filegv */
+ ret = make_sv_object(aTHX_ (SV *)CopFILEGV((COP*)o));
+ break;
+#endif
+#ifndef USE_ITHREADS
+ case 22: /* file */
+ ret = sv_2mortal(newSVpv(CopFILE((COP*)o), 0));
+ break;
+#endif
+#ifdef USE_ITHREADS
+ case 23: /* stash */
+ ret = make_sv_object(aTHX_ (SV *)CopSTASH((COP*)o));
+ break;
+#endif
+#if PERL_VERSION >= 17 || !defined USE_ITHREADS
+ case 24: /* stashpv */
+# if PERL_VERSION >= 17
+ ret = sv_2mortal(CopSTASH((COP*)o)
+ && SvTYPE(CopSTASH((COP*)o)) == SVt_PVHV
+ ? newSVhek(HvNAME_HEK(CopSTASH((COP*)o)))
+ : &PL_sv_undef);
+# else
+ ret = sv_2mortal(newSVpv(CopSTASHPV((COP*)o), 0));
+# endif
+ break;
+#endif
+ case 26: /* size */
+ ret = sv_2mortal(newSVuv((UV)(opsizes[cc_opclass(aTHX_ o)])));
+ break;
+ case 27: /* name */
+ case 28: /* desc */
+ ret = sv_2mortal(newSVpv(
+ (char *)(ix == 28 ? OP_DESC(o) : OP_NAME(o)), 0));
+ break;
+ case 29: /* ppaddr */
+ {
+ int i;
+ ret = sv_2mortal(Perl_newSVpvf(aTHX_ "PL_ppaddr[OP_%s]",
+ PL_op_name[o->op_type]));
+ for (i=13; (STRLEN)i < SvCUR(ret); ++i)
+ SvPVX(ret)[i] = toUPPER(SvPVX(ret)[i]);
+ }
+ break;
+ case 30: /* type */
+ case 31: /* opt */
+ case 32: /* spare */
+ /* These 3 are all bitfields, so we can't take their addresses */
+ ret = sv_2mortal(newSVuv((UV)(
+ ix == 30 ? o->op_type
+ : ix == 31 ? o->op_opt
+ : o->op_spare)));
+ break;
+ case 33: /* children */
+ {
+ OP *kid;
+ UV i = 0;
+ for (kid = ((LISTOP*)o)->op_first; kid; kid = kid->op_sibling)
+ i++;
+ ret = sv_2mortal(newSVuv(i));
+ }
+ break;
+ case 34: /* pmreplroot */
+ if (cPMOPo->op_type == OP_PUSHRE) {
+#ifdef USE_ITHREADS
+ ret = sv_newmortal();
+ sv_setiv(ret, cPMOPo->op_pmreplrootu.op_pmtargetoff);
+#else
+ GV *const target = cPMOPo->op_pmreplrootu.op_pmtargetgv;
+ ret = sv_newmortal();
+ sv_setiv(newSVrv(ret, target ?
+ svclassnames[SvTYPE((SV*)target)] : "B::SV"),
+ PTR2IV(target));
+#endif
+ }
+ else {
+ OP *const root = cPMOPo->op_pmreplrootu.op_pmreplroot;
+ ret = make_op_object(aTHX_ root);
+ }
+ break;
+#ifdef USE_ITHREADS
+ case 35: /* pmstashpv */
+ ret = sv_2mortal(newSVpv(PmopSTASHPV(cPMOPo),0));
+ break;
+#else
+ case 36: /* pmstash */
+ ret = make_sv_object(aTHX_ (SV *) PmopSTASH(cPMOPo));
+ break;
+#endif
+ case 37: /* precomp */
+ case 38: /* reflags */
+ {
+ REGEXP *rx = PM_GETRE(cPMOPo);
+ ret = sv_newmortal();
+ if (rx) {
+ if (ix==38) {
+ sv_setuv(ret, RX_EXTFLAGS(rx));
+ }
+ else {
+ sv_setpvn(ret, RX_PRECOMP(rx), RX_PRELEN(rx));
+ }
+ }
+ }
+ break;
+ case 39: /* sv */
+ case 40: /* gv */
+ /* It happens that the output typemaps for B::SV and B::GV
+ * are identical. The "smarts" are in make_sv_object(),
+ * which determines which class to use based on SvTYPE(),
+ * rather than anything baked in at compile time. */
+ if (cPADOPo->op_padix) {
+ ret = PAD_SVl(cPADOPo->op_padix);
+ if (ix == 40 && SvTYPE(ret) != SVt_PVGV)
+ ret = NULL;
+ } else {
+ ret = NULL;
+ }
+ ret = make_sv_object(aTHX_ ret);
+ break;
+ case 41: /* pv */
+ /* OP_TRANS uses op_pv to point to a table of 256 or >=258
+ * shorts whereas other PVOPs point to a null terminated
+ * string. */
+ if ( (cPVOPo->op_type == OP_TRANS
+ || cPVOPo->op_type == OP_TRANSR) &&
+ (cPVOPo->op_private & OPpTRANS_COMPLEMENT) &&
+ !(cPVOPo->op_private & OPpTRANS_DELETE))
+ {
+ const short* const tbl = (short*)cPVOPo->op_pv;
+ const short entries = 257 + tbl[256];
+ ret = newSVpvn_flags(cPVOPo->op_pv, entries * sizeof(short), SVs_TEMP);
+ }
+ else if (cPVOPo->op_type == OP_TRANS || cPVOPo->op_type == OP_TRANSR) {
+ ret = newSVpvn_flags(cPVOPo->op_pv, 256 * sizeof(short), SVs_TEMP);
+ }
+ else
+ ret = newSVpvn_flags(cPVOPo->op_pv, strlen(cPVOPo->op_pv), SVs_TEMP);
+ break;
+ case 42: /* label */
+ ret = sv_2mortal(newSVpv(CopLABEL(cCOPo),0));
+ break;
+ case 43: /* arybase */
+ ret = sv_2mortal(newSVuv(0));
+ break;
+ case 44: /* warnings */
+ ret = make_warnings_object(aTHX_ cCOPo);
+ break;
+ case 45: /* io */
+ ret = make_cop_io_object(aTHX_ cCOPo);
+ break;
+ case 46: /* hints_hash */
+ ret = sv_newmortal();
+ sv_setiv(newSVrv(ret, "B::RHE"),
+ PTR2IV(CopHINTHASH_get(cCOPo)));
+ break;
+ default:
+ croak("method %s not implemented", op_methods[ix].name);
+ }
+ ST(0) = ret;
+ XSRETURN(1);
+ }
+
+ /* do a direct structure offset lookup */
+
+ ptr = (char *)o + offset;
+ type = op_methods[ix].type;
+ switch ((U8)(type >> 16)) {
+ case (U8)(OPp >> 16):
ret = make_op_object(aTHX_ *((OP **)ptr));
break;
- case (U8)(PADOFFSETp >> 16):
+ case (U8)(PADOFFSETp >> 16):
ret = sv_2mortal(newSVuv(*((PADOFFSET*)ptr)));
break;
case (U8)(U8p >> 16):
@@ -951,7 +1202,6 @@
case (U8)(line_tp >> 16):
ret = sv_2mortal(newSVuv(*((line_t *)ptr)));
break;
-#ifdef USE_ITHREADS
case (U8)(IVp >> 16):
ret = sv_2mortal(newSViv(*((IV*)ptr)));
break;
@@ -958,342 +1208,22 @@
case (U8)(char_pp >> 16):
ret = sv_2mortal(newSVpv(*((char **)ptr), 0));
break;
-#endif
default:
- croak("Illegal alias 0x%08x for B::*next", (unsigned)ix);
+ croak("Illegal type 0x%08x for B::*OP::%s",
+ (unsigned)type, op_methods[ix].name);
}
ST(0) = ret;
XSRETURN(1);
-char *
-name(o)
- B::OP o
- ALIAS:
- desc = 1
- CODE:
- RETVAL = (char *)(ix ? OP_DESC(o) : OP_NAME(o));
- OUTPUT:
- RETVAL
void
-ppaddr(o)
- B::OP o
- PREINIT:
- int i;
- SV *sv = newSVpvs_flags("PL_ppaddr[OP_", SVs_TEMP);
- CODE:
- sv_catpv(sv, PL_op_name[o->op_type]);
- for (i=13; (STRLEN)i < SvCUR(sv); ++i)
- SvPVX(sv)[i] = toUPPER(SvPVX(sv)[i]);
- sv_catpvs(sv, "]");
- ST(0) = sv;
-
-#if PERL_VERSION >= 9
-# These 3 are all bitfields, so we can't take their addresses.
-UV
-type(o)
- B::OP o
- ALIAS:
- opt = 1
- spare = 2
- CODE:
- switch(ix) {
- case 1:
- RETVAL = o->op_opt;
- break;
- case 2:
- RETVAL = o->op_spare;
- break;
- default:
- RETVAL = o->op_type;
- }
- OUTPUT:
- RETVAL
-
-#else
-
-UV
-type(o)
- B::OP o
- ALIAS:
- seq = 1
- CODE:
- switch(ix) {
- case 1:
- RETVAL = o->op_seq;
- break;
- default:
- RETVAL = o->op_type;
- }
- OUTPUT:
- RETVAL
-
-#endif
-
-void
oplist(o)
B::OP o
PPCODE:
SP = oplist(aTHX_ o, SP);
-MODULE = B PACKAGE = B::LISTOP
-U32
-children(o)
- B::LISTOP o
- OP * kid = NO_INIT
- int i = NO_INIT
- CODE:
- i = 0;
- for (kid = o->op_first; kid; kid = kid->op_sibling)
- i++;
- RETVAL = i;
- OUTPUT:
- RETVAL
-
-MODULE = B PACKAGE = B::PMOP PREFIX = PMOP_
-
-#if PERL_VERSION <= 8
-
-void
-PMOP_pmreplroot(o)
- B::PMOP o
- OP * root = NO_INIT
- CODE:
- root = o->op_pmreplroot;
- /* OP_PUSHRE stores an SV* instead of an OP* in op_pmreplroot */
- if (o->op_type == OP_PUSHRE) {
- ST(0) = sv_newmortal();
-# ifdef USE_ITHREADS
- sv_setiv(ST(0), INT2PTR(PADOFFSET,root) );
-# else
- sv_setiv(newSVrv(ST(0), root ?
- svclassnames[SvTYPE((SV*)root)] : "B::SV"),
- PTR2IV(root));
-# endif
- }
- else {
- ST(0) = make_op_object(aTHX_ root);
- }
-
-#else
-
-void
-PMOP_pmreplroot(o)
- B::PMOP o
- CODE:
- if (o->op_type == OP_PUSHRE) {
-# ifdef USE_ITHREADS
- ST(0) = sv_newmortal();
- sv_setiv(ST(0), o->op_pmreplrootu.op_pmtargetoff);
-# else
- GV *const target = o->op_pmreplrootu.op_pmtargetgv;
- ST(0) = sv_newmortal();
- sv_setiv(newSVrv(ST(0), target ?
- svclassnames[SvTYPE((SV*)target)] : "B::SV"),
- PTR2IV(target));
-# endif
- }
- else {
- OP *const root = o->op_pmreplrootu.op_pmreplroot;
- ST(0) = make_op_object(aTHX_ root);
- }
-
-#endif
-
-#ifdef USE_ITHREADS
-#define PMOP_pmstashpv(o) PmopSTASHPV(o);
-
-char*
-PMOP_pmstashpv(o)
- B::PMOP o
-
-#else
-
-void
-PMOP_pmstash(o)
- B::PMOP o
- PPCODE:
- PUSHs(make_sv_object(aTHX_ (SV *) PmopSTASH(o)));
-
-#endif
-
-#if PERL_VERSION < 9
-
-void
-PMOP_pmnext(o)
- B::PMOP o
- PPCODE:
- PUSHs(make_op_object(aTHX_ o->op_pmnext));
-
-U32
-PMOP_pmpermflags(o)
- B::PMOP o
-
-U8
-PMOP_pmdynflags(o)
- B::PMOP o
-
-#endif
-
-void
-PMOP_precomp(o)
- B::PMOP o
- PREINIT:
- dXSI32;
- REGEXP *rx;
- CODE:
- rx = PM_GETRE(o);
- ST(0) = sv_newmortal();
- if (rx) {
-#if PERL_VERSION >= 9
- if (ix) {
- sv_setuv(ST(0), RX_EXTFLAGS(rx));
- } else
-#endif
- {
- sv_setpvn(ST(0), RX_PRECOMP(rx), RX_PRELEN(rx));
- }
- }
-
-BOOT:
-{
- CV *cv;
-#ifdef USE_ITHREADS
- cv = newXS("B::PMOP::pmoffset", XS_B__OP_next, __FILE__);
- XSANY.any_i32 = PMOP_pmoffset_ix;
- cv = newXS("B::COP::stashpv", XS_B__OP_next, __FILE__);
- XSANY.any_i32 = COP_stashpv_ix;
- cv = newXS("B::COP::file", XS_B__OP_next, __FILE__);
- XSANY.any_i32 = COP_file_ix;
-#else
- cv = newXS("B::COP::stash", XS_B__OP_next, __FILE__);
- XSANY.any_i32 = COP_stash_ix;
- cv = newXS("B::COP::filegv", XS_B__OP_next, __FILE__);
- XSANY.any_i32 = COP_filegv_ix;
-#endif
-#if PERL_VERSION >= 9
- cv = newXS("B::PMOP::reflags", XS_B__PMOP_precomp, __FILE__);
- XSANY.any_i32 = 1;
-#endif
-}
-
-MODULE = B PACKAGE = B::PADOP
-
-void
-sv(o)
- B::PADOP o
- PREINIT:
- SV *ret;
- ALIAS:
- gv = 1
- PPCODE:
- /* It happens that the output typemaps for B::SV and B::GV are
- identical. The "smarts" are in make_sv_object(), which determines
- which class to use based on SvTYPE(), rather than anything baked in
- at compile time. */
- if (o->op_padix) {
- ret = PAD_SVl(o->op_padix);
- if (ix && SvTYPE(ret) != SVt_PVGV)
- ret = NULL;
- } else {
- ret = NULL;
- }
- PUSHs(make_sv_object(aTHX_ ret));
-
-MODULE = B PACKAGE = B::PVOP
-
-void
-pv(o)
- B::PVOP o
- CODE:
- /*
- * OP_TRANS uses op_pv to point to a table of 256 or >=258 shorts
- * whereas other PVOPs point to a null terminated string.
- */
- if ((o->op_type == OP_TRANS || o->op_type == OP_TRANSR) &&
- (o->op_private & OPpTRANS_COMPLEMENT) &&
- !(o->op_private & OPpTRANS_DELETE))
- {
- const short* const tbl = (short*)o->op_pv;
- const short entries = 257 + tbl[256];
- ST(0) = newSVpvn_flags(o->op_pv, entries * sizeof(short), SVs_TEMP);
- }
- else if (o->op_type == OP_TRANS || o->op_type == OP_TRANSR) {
- ST(0) = newSVpvn_flags(o->op_pv, 256 * sizeof(short), SVs_TEMP);
- }
- else
- ST(0) = newSVpvn_flags(o->op_pv, strlen(o->op_pv), SVs_TEMP);
-
-#define COP_label(o) CopLABEL(o)
-#define COP_arybase(o) CopARYBASE_get(o)
-
-MODULE = B PACKAGE = B::COP PREFIX = COP_
-
-const char *
-COP_label(o)
- B::COP o
-
-# Both pairs of accessors are provided for both ithreads and not, but for each,
-# one pair is direct structure access, and 1 pair "faked up" with a more complex
-# macro. We implement the direct structure access pair using the common code
-# above (B::OP::next)
-
-#ifdef USE_ITHREADS
-
-void
-COP_stash(o)
- B::COP o
- ALIAS:
- filegv = 1
- PPCODE:
- PUSHs(make_sv_object(aTHX_
- ix ? (SV *)CopFILEGV(o) : (SV *)CopSTASH(o)));
-
-#else
-
-char *
-COP_stashpv(o)
- B::COP o
- ALIAS:
- file = 1
- CODE:
- RETVAL = ix ? CopFILE(o) : CopSTASHPV(o);
- OUTPUT:
- RETVAL
-
-#endif
-
-I32
-COP_arybase(o)
- B::COP o
-
-void
-COP_warnings(o)
- B::COP o
- ALIAS:
- io = 1
- PPCODE:
-#if PERL_VERSION >= 9
- ST(0) = ix ? make_cop_io_object(aTHX_ o) : make_warnings_object(aTHX_ o);
-#else
- ST(0) = make_sv_object(aTHX_ ix ? o->cop_io : o->cop_warnings);
-#endif
- XSRETURN(1);
-
-#if PERL_VERSION >= 9
-
-B::RHE
-COP_hints_hash(o)
- B::COP o
- CODE:
- RETVAL = CopHINTHASH_get(o);
- OUTPUT:
- RETVAL
-
-#endif
-
MODULE = B PACKAGE = B::SV
#define MAGICAL_FLAG_BITS (SVs_GMG|SVs_SMG|SVs_RMG)
@@ -1344,7 +1274,6 @@
#define IV_uvx_ix sv_UVp | offsetof(struct xpvuv, xuv_uv)
#define NV_nvx_ix sv_NVp | offsetof(struct xpvnv, xnv_u.xnv_nv)
-#if PERL_VERSION >= 10
#define NV_cop_seq_range_low_ix \
sv_U32p | offsetof(struct xpvnv, xnv_u.xpad_cop_seq.xlow)
#define NV_cop_seq_range_high_ix \
@@ -1353,16 +1282,6 @@
sv_U32p | offsetof(struct xpvnv, xnv_u.xpad_cop_seq.xlow)
#define NV_parent_fakelex_flags_ix \
sv_U32p | offsetof(struct xpvnv, xnv_u.xpad_cop_seq.xhigh)
-#else
-#define NV_cop_seq_range_low_ix \
- sv_NVp | offsetof(struct xpvnv, xnv_nv)
-#define NV_cop_seq_range_high_ix \
- sv_UVp | offsetof(struct xpvnv, xuv_uv)
-#define NV_parent_pad_index_ix \
- sv_NVp | offsetof(struct xpvnv, xnv_nv)
-#define NV_parent_fakelex_flags_ix \
- sv_UVp | offsetof(struct xpvnv, xuv_uv)
-#endif
#define PV_cur_ix sv_STRLENp | offsetof(struct xpv, xpv_cur)
#define PV_len_ix sv_STRLENp | offsetof(struct xpv, xpv_len)
@@ -1369,30 +1288,24 @@
#define PVMG_stash_ix sv_SVp | offsetof(struct xpvmg, xmg_stash)
-#if PERL_VERSION >= 10
+#if PERL_VERSION > 14
+# define PVBM_useful_ix sv_I32p | offsetof(struct xpvgv, xnv_u.xbm_s.xbm_useful)
+# define PVBM_previous_ix sv_UVp | offsetof(struct xpvuv, xuv_uv)
+#else
#define PVBM_useful_ix sv_I32p | offsetof(struct xpvgv, xiv_u.xivu_i32)
#define PVBM_previous_ix sv_U32p | offsetof(struct xpvgv, xnv_u.xbm_s.xbm_previous)
-#define PVBM_rare_ix sv_U8p | offsetof(struct xpvgv, xnv_u.xbm_s.xbm_rare)
-#else
-#define PVBM_useful_ix sv_I32p | offsetof(struct xpvbm, xbm_useful)
-#define PVBM_previous_ix sv_U16p | offsetof(struct xpvbm, xbm_previous)
-#define PVBM_rare_ix sv_U8p | offsetof(struct xpvbm, xbm_rare)
#endif
+#define PVBM_rare_ix sv_U8p | offsetof(struct xpvgv, xnv_u.xbm_s.xbm_rare)
+
#define PVLV_targoff_ix sv_U32p | offsetof(struct xpvlv, xlv_targoff)
#define PVLV_targlen_ix sv_U32p | offsetof(struct xpvlv, xlv_targlen)
#define PVLV_targ_ix sv_SVp | offsetof(struct xpvlv, xlv_targ)
#define PVLV_type_ix sv_char_p | offsetof(struct xpvlv, xlv_type)
-#if PERL_VERSION >= 10
#define PVGV_stash_ix sv_SVp | offsetof(struct xpvgv, xnv_u.xgv_stash)
#define PVGV_flags_ix sv_STRLENp | offsetof(struct xpvgv, xpv_cur)
#define PVIO_lines_ix sv_IVp | offsetof(struct xpvio, xiv_iv)
-#else
-#define PVGV_stash_ix sv_SVp | offsetof(struct xpvgv, xgv_stash)
-#define PVGV_flags_ix sv_U8p | offsetof(struct xpvgv, xgv_flags)
-#define PVIO_lines_ix sv_IVp | offsetof(struct xpvio, xio_lines)
-#endif
#define PVIO_page_ix sv_IVp | offsetof(struct xpvio, xio_page)
#define PVIO_page_len_ix sv_IVp | offsetof(struct xpvio, xio_page_len)
@@ -1408,13 +1321,13 @@
#define PVAV_max_ix sv_SSize_tp | offsetof(struct xpvav, xav_max)
-#define PVFM_lines_ix sv_IVp | offsetof(struct xpvfm, xfm_lines)
-
#define PVCV_stash_ix sv_SVp | offsetof(struct xpvcv, xcv_stash)
-#define PVCV_gv_ix sv_SVp | offsetof(struct xpvcv, xcv_gv)
+#if PERL_VERSION > 17 || (PERL_VERSION == 17 && PERL_SUBVERSION >= 3)
+# define PVCV_gv_ix sv_SVp | offsetof(struct xpvcv, xcv_gv_u.xcv_gv)
+#else
+# define PVCV_gv_ix sv_SVp | offsetof(struct xpvcv, xcv_gv)
+#endif
#define PVCV_file_ix sv_char_pp | offsetof(struct xpvcv, xcv_file)
-#define PVCV_depth_ix sv_I32p | offsetof(struct xpvcv, xcv_depth)
-#define PVCV_padlist_ix sv_SVp | offsetof(struct xpvcv, xcv_padlist)
#define PVCV_outside_ix sv_SVp | offsetof(struct xpvcv, xcv_outside)
#define PVCV_outside_seq_ix sv_U32p | offsetof(struct xpvcv, xcv_outside_seq)
#define PVCV_flags_ix sv_U16p | offsetof(struct xpvcv, xcv_flags)
@@ -1466,12 +1379,8 @@
B::IO::IoTYPE = PVIO_type_ix
B::IO::IoFLAGS = PVIO_flags_ix
B::AV::MAX = PVAV_max_ix
- B::FM::LINES = PVFM_lines_ix
B::CV::STASH = PVCV_stash_ix
- B::CV::GV = PVCV_gv_ix
B::CV::FILE = PVCV_file_ix
- B::CV::DEPTH = PVCV_depth_ix
- B::CV::PADLIST = PVCV_padlist_ix
B::CV::OUTSIDE = PVCV_outside_ix
B::CV::OUTSIDE_SEQ = PVCV_outside_seq_ix
B::CV::CvFLAGS = PVCV_flags_ix
@@ -1614,38 +1523,67 @@
U32 utf8 = 0;
CODE:
if (ix == 3) {
+#ifndef PERL_FBM_TABLE_OFFSET
+ const MAGIC *const mg = mg_find(sv, PERL_MAGIC_bm);
+
+ if (!mg)
+ croak("argument to B::BM::TABLE is not a PVBM");
+ p = mg->mg_ptr;
+ len = mg->mg_len;
+#else
p = SvPV(sv, len);
/* Boyer-Moore table is just after string and its safety-margin \0 */
p += len + PERL_FBM_TABLE_OFFSET;
len = 256;
+#endif
} else if (ix == 2) {
/* This used to read 257. I think that that was buggy - should have
- been 258. (The "\0", the flags byte, and 256 for the table. Not
- that anything anywhere calls this method. NWC. */
- /* Also, the start pointer has always been SvPVX(sv). Surely it
- should be SvPVX(sv) + SvCUR(sv)? The code has faithfully been
- refactored with this behaviour, since PVBM was added in
- 651aa52ea1faa806. */
+ been 258. (The "\0", the flags byte, and 256 for the table.)
+ The only user of this method is B::Bytecode in B::PV::bsave.
+ I'm guessing that nothing tested the runtime correctness of
+ output of bytecompiled string constant arguments to index (etc).
+
+ Note the start pointer is and has always been SvPVX(sv), not
+ SvPVX(sv) + SvCUR(sv) PVBM was added in 651aa52ea1faa806, and
+ first used by the compiler in 651aa52ea1faa806. It's used to
+ get a "complete" dump of the buffer at SvPVX(), not just the
+ PVBM table. This permits the generated bytecode to "load"
+ SvPVX in "one" hit.
+
+ 5.15 and later store the BM table via MAGIC, so the compiler
+ should handle this just fine without changes if PVBM now
+ always returns the SvPVX() buffer. */
+#ifdef isREGEXP
+ p = isREGEXP(sv)
+ ? RX_WRAPPED_const((REGEXP*)sv)
+ : SvPVX_const(sv);
+#else
p = SvPVX_const(sv);
+#endif
+#ifdef PERL_FBM_TABLE_OFFSET
len = SvCUR(sv) + (SvVALID(sv) ? 256 + PERL_FBM_TABLE_OFFSET : 0);
+#else
+ len = SvCUR(sv);
+#endif
} else if (ix) {
+#ifdef isREGEXP
+ p = isREGEXP(sv) ? RX_WRAPPED((REGEXP*)sv) : SvPVX(sv);
+#else
p = SvPVX(sv);
+#endif
len = strlen(p);
} else if (SvPOK(sv)) {
len = SvCUR(sv);
p = SvPVX_const(sv);
utf8 = SvUTF8(sv);
-#if PERL_VERSION < 10
- /* Before 5.10 (well 931b58fb28fa5ca7), PAD_COMPNAME_GEN was stored
- in SvCUR(), which meant we had to attempt this special casing
- to avoid tripping up over variable names in the pads. */
- if((SvLEN(sv) && len >= SvLEN(sv))) {
- /* It claims to be longer than the space allocated for it -
- presumably it's a variable name in the pad */
- len = strlen(p);
- }
+ }
+#ifdef isREGEXP
+ else if (isREGEXP(sv)) {
+ len = SvCUR(sv);
+ p = RX_WRAPPED_const((REGEXP*)sv);
+ utf8 = SvUTF8(sv);
+ }
#endif
- }
else {
/* XXX for backward compatibility, but should fail */
/* croak( "argument is not SvPOK" ); */
@@ -1736,14 +1674,9 @@
FILE = 1
B::HV::NAME = 2
CODE:
-#if PERL_VERSION >= 10
ST(0) = sv_2mortal(newSVhek(!ix ? GvNAME_HEK(gv)
: (ix == 1 ? GvFILE_HEK(gv)
: HvNAME_HEK((HV *)gv))));
-#else
- ST(0) = !ix ? newSVpvn_flags(GvNAME(gv), GvNAMELEN(gv), SVs_TEMP)
- : sv_2mortal(newSVpv(ix == 1 ? GvFILE(gv) : HvNAME((HV *)gv), 0))
-#endif
bool
is_empty(gv)
@@ -1752,11 +1685,7 @@
isGV_with_GP = 1
CODE:
if (ix) {
-#if PERL_VERSION >= 9
RETVAL = isGV_with_GP(gv) ? TRUE : FALSE;
-#else
- RETVAL = TRUE; /* In 5.8 and earlier they all are. */
-#endif
} else {
RETVAL = GvGP(gv) == Null(GP*);
}
@@ -1827,14 +1756,7 @@
MODULE = B PACKAGE = B::IO PREFIX = Io
-#if PERL_VERSION <= 8
-short
-IoSUBPROCESS(io)
- B::IO io
-
-#endif
-
bool
IsSTD(io,name)
B::IO io
@@ -1885,22 +1807,16 @@
else
XPUSHs(make_sv_object(aTHX_ NULL));
-#if PERL_VERSION < 9
-
-#define AvOFF(av) ((XPVAV*)SvANY(av))->xof_off
-IV
-AvOFF(av)
- B::AV av
+MODULE = B PACKAGE = B::FM PREFIX = Fm
-MODULE = B PACKAGE = B::AV
+#undef FmLINES
+#define FmLINES(sv) 0
-U8
-AvFLAGS(av)
- B::AV av
+IV
+FmLINES(form)
+ B::FM form
-#endif
-
MODULE = B PACKAGE = B::CV PREFIX = Cv
U32
@@ -1916,6 +1832,27 @@
PUSHs(make_op_object(aTHX_ CvISXSUB(cv) ? NULL
: ix ? CvROOT(cv) : CvSTART(cv)));
+I32
+CvDEPTH(cv)
+ B::CV cv
+
+#ifdef PadlistARRAY
+
+B::PADLIST
+CvPADLIST(cv)
+ B::CV cv
+
+#else
+
+B::AV
+CvPADLIST(cv)
+ B::CV cv
+ PPCODE:
+ PUSHs(make_sv_object(aTHX_ (SV *)CvPADLIST(cv)));
+
+
+#endif
+
void
CvXSUB(cv)
B::CV cv
@@ -1935,6 +1872,27 @@
PPCODE:
PUSHs(make_sv_object(aTHX_ (SV *)cv_const_sv(cv)));
+void
+GV(cv)
+ B::CV cv
+ PREINIT:
+ GV *gv;
+ CODE:
+ gv = CvGV(cv);
+ ST(0) = gv ? make_sv_object(aTHX_ (SV*)gv) : &PL_sv_undef;
+
+#if PERL_VERSION > 17
+
+SV *
+NAME_HEK(cv)
+ B::CV cv
+ CODE:
+ RETVAL = CvNAMED(cv) ? newSVhek(CvNAME_HEK(cv)) : &PL_sv_undef;
+ OUTPUT:
+ RETVAL
+
+#endif
+
MODULE = B PACKAGE = B::HV PREFIX = Hv
STRLEN
@@ -1945,26 +1903,16 @@
HvRITER(hv)
B::HV hv
-#if PERL_VERSION < 9
-
-B::PMOP
-HvPMROOT(hv)
- B::HV hv
- PPCODE:
- PUSHs(make_op_object(aTHX_ HvPMROOT(hv)));
-
-#endif
-
void
HvARRAY(hv)
B::HV hv
PPCODE:
- if (HvKEYS(hv) > 0) {
+ if (HvUSEDKEYS(hv) > 0) {
SV *sv;
char *key;
I32 len;
(void)hv_iterinit(hv);
- EXTEND(sp, HvKEYS(hv) * 2);
+ EXTEND(sp, HvUSEDKEYS(hv) * 2);
while ((sv = hv_iternextsv(hv, &key, &len))) {
mPUSHp(key, len);
PUSHs(make_sv_object(aTHX_ sv));
@@ -1987,8 +1935,6 @@
MODULE = B PACKAGE = B::RHE
-#if PERL_VERSION >= 9
-
SV*
HASH(h)
B::RHE h
@@ -1997,4 +1943,44 @@
OUTPUT:
RETVAL
+
+#ifdef PadlistARRAY
+
+MODULE = B PACKAGE = B::PADLIST PREFIX = Padlist
+
+SSize_t
+PadlistMAX(padlist)
+ B::PADLIST padlist
+
+void
+PadlistARRAY(padlist)
+ B::PADLIST padlist
+ PPCODE:
+ if (PadlistMAX(padlist) >= 0) {
+ PAD **padp = PadlistARRAY(padlist);
+ PADOFFSET i;
+ for (i = 0; i <= PadlistMAX(padlist); i++)
+ XPUSHs(make_sv_object(aTHX_ (SV *)padp[i]));
+ }
+
+void
+PadlistARRAYelt(padlist, idx)
+ B::PADLIST padlist
+ PADOFFSET idx
+ PPCODE:
+ if (PadlistMAX(padlist) >= 0
+ && idx <= PadlistMAX(padlist))
+ XPUSHs(make_sv_object(aTHX_
+ (SV *)PadlistARRAY(padlist)[idx]));
+ else
+ XPUSHs(make_sv_object(aTHX_ NULL));
+
+U32
+PadlistREFCNT(padlist)
+ B::PADLIST padlist
+ CODE:
+ RETVAL = PadlistREFCNT(padlist);
+ OUTPUT:
+ RETVAL
+
#endif
Property changes on: trunk/contrib/perl/ext/B/B.xs
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/ext/B/Makefile.PL
===================================================================
--- trunk/contrib/perl/ext/B/Makefile.PL 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/B/Makefile.PL 2013-12-02 21:32:26 UTC (rev 6445)
@@ -20,38 +20,23 @@
$headerpath = File::Spec->catdir($Config::Config{archlibexp}, "CORE");
}
-my @names = qw(CVf_ANON CVf_CLONE CVf_CLONED CVf_CONST CVf_LVALUE CVf_METHOD
- CVf_NODEBUG CVf_UNIQUE CVf_WEAKOUTSIDE
- GVf_IMPORTED_AV GVf_IMPORTED_CV GVf_IMPORTED_HV GVf_IMPORTED_SV
- HEf_SVKEY
+my @names = qw(HEf_SVKEY
SVTYPEMASK SVt_PVGV SVt_PVHV
- SVf_FAKE SVf_IOK SVf_IVisUV SVf_NOK SVf_POK SVf_READONLY
- SVf_ROK SVp_IOK SVp_NOK SVp_POK SVpad_OUR SVs_RMG SVs_SMG
PAD_FAKELEX_ANON PAD_FAKELEX_MULTI);
-if ($] >= 5.009) {
- push @names, 'CVf_ISXSUB';
-} else {
- # Constant not present after 5.8.x
- push @names, 'AVf_REAL';
- # This is only present in 5.10, but it's useful to B::Deparse to be able
- # to import a dummy value from B
- push @names, {name=>"OPpPAD_STATE", default=>["IV", "0"]};
-}
-if ($] < 5.011) {
- # Constant not present after 5.10.x
- push @names, 'CVf_LOCKED';
-}
-
# First element in each tuple is the file; second is a regex snippet
# giving the prefix to limit the names of symbols to define that come
# from that file. If none, all symbols will be defined whose values
# match the pattern below.
-foreach my $tuple (['op_reg_common.h','(?:(?:RXf_)?PMf_)'],
- ['op.h'],
- ['cop.h'],
- ['regexp.h','RXf_']) {
+foreach my $tuple (['cop.h'],
+ ['cv.h', 'CVf'],
+ ['gv.h', 'GVf'],
+ ['op.h'],
+ ['op_reg_common.h','(?:(?:RXf_)?PMf_)'],
+ ['regexp.h','RXf_'],
+ ['sv.h', 'SV(?:[fps]|pad)_'],
+ ) {
my $file = $tuple->[0];
my $pfx = $tuple->[1] || '';
my $path = File::Spec->catfile($headerpath, $file);
Property changes on: trunk/contrib/perl/ext/B/Makefile.PL
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Index: trunk/contrib/perl/ext/B/O.pm
===================================================================
--- trunk/contrib/perl/ext/B/O.pm 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/B/O.pm 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/B/O.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Copied: trunk/contrib/perl/ext/B/defsubs_h.PL (from rev 6437, vendor/perl/5.18.1/ext/B/defsubs_h.PL)
===================================================================
--- trunk/contrib/perl/ext/B/defsubs_h.PL (rev 0)
+++ trunk/contrib/perl/ext/B/defsubs_h.PL 2013-12-02 21:32:26 UTC (rev 6445)
@@ -0,0 +1,98 @@
+# Do not remove the following line; MakeMaker relies on it to identify
+# this file as a template for defsubs.h
+# Extracting defsubs.h (with variable substitutions)
+#!perl -w
+use File::Spec;
+my (undef, $headerpath) = @ARGV;
+my ($out) = __FILE__ =~ /(^.*)\.PL/i;
+$out =~ s/_h$/.h/;
+unlink $out if -l $out;
+open(OUT,">$out") || die "Cannot open $file:$!";
+print "Extracting $out...\n";
+print OUT <<"END";
+/*
+ !!! Don't modify this file - it's autogenerated from $0 !!!
+ */
+END
+
+foreach my $const (qw(
+ CVf_ANON
+ CVf_CLONE
+ CVf_CLONED
+ CVf_CONST
+ CVf_LOCKED
+ CVf_LVALUE
+ CVf_METHOD
+ CVf_NODEBUG
+ CVf_UNIQUE
+ CVf_WEAKOUTSIDE
+ GVf_IMPORTED_AV
+ GVf_IMPORTED_CV
+ GVf_IMPORTED_HV
+ GVf_IMPORTED_SV
+ HEf_SVKEY
+ SVTYPEMASK
+ SVf_FAKE
+ SVf_IOK
+ SVf_IVisUV
+ SVf_NOK
+ SVf_POK
+ SVf_READONLY
+ SVf_ROK
+ SVp_IOK
+ SVp_NOK
+ SVp_POK
+ SVpad_OUR
+ SVs_RMG
+ SVs_SMG
+ SVt_PVGV
+ SVt_PVHV
+ PAD_FAKELEX_ANON
+ PAD_FAKELEX_MULTI
+ ))
+ {
+ doconst($const);
+ }
+
+if ($] < 5.009) {
+ # This is only present in 5.10, but it's useful to B::Deparse to be able
+ # to import a dummy value from B
+ doconst(OPpPAD_STATE);
+}
+
+if ($] >= 5.009) {
+ # Constant not present in 5.8.x
+ doconst(CVf_ISXSUB);
+} else {
+ # Constant not present after 5.8.x
+ doconst(AVf_REAL);
+}
+
+if ($] < 5.011) {
+ # Constant not present after 5.10.x
+ doconst(CVf_LOCKED);
+}
+
+foreach my $tuple (['op.h'],['cop.h'],['regexp.h','RXf_'])
+ {
+ my $file = $tuple->[0];
+ my $pfx = $tuple->[1] || '';
+ my $path = File::Spec->catfile($headerpath, $file);
+ open(OPH,"$path") || die "Cannot open $path:$!";
+ while (<OPH>)
+ {
+ doconst($1) if (/#define\s+($pfx\w+)\s+([\(\)\|\dx]+)\s*(?:$|\/\*)/);
+ }
+ close(OPH);
+ }
+close(OUT);
+
+sub doconst
+{
+ my $sym = shift;
+ my $l = length($sym);
+ print OUT <<"END";
+ newCONSTSUB(stash,"$sym",newSViv($sym));
+ av_push(export_ok,newSVpvn("$sym",$l));
+END
+}
Index: trunk/contrib/perl/ext/B/hints/darwin.pl
===================================================================
--- trunk/contrib/perl/ext/B/hints/darwin.pl 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/B/hints/darwin.pl 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/B/hints/darwin.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/B/hints/openbsd.pl
===================================================================
--- trunk/contrib/perl/ext/B/hints/openbsd.pl 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/B/hints/openbsd.pl 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/B/hints/openbsd.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/ext/B/t/OptreeCheck.pm
===================================================================
--- trunk/contrib/perl/ext/B/t/OptreeCheck.pm 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/B/t/OptreeCheck.pm 2013-12-02 21:32:26 UTC (rev 6445)
@@ -5,11 +5,11 @@
use vars qw($TODO $Level $using_open);
require "test.pl";
-our $VERSION = '0.05';
+our $VERSION = '0.09';
# now export checkOptree, and those test.pl functions used by tests
our @EXPORT = qw( checkOptree plan skip skip_all pass is like unlike
- require_ok runperl);
+ require_ok runperl tempfile);
# The hints flags will differ if ${^OPEN} is set.
@@ -135,10 +135,10 @@
=head2 getRendering
-getRendering() runs code or prog through B::Concise, and captures its
-rendering. Errors emitted during rendering are checked against
-expected errors, and are reported as diagnostics by default, or as
-failures if 'report=fail' cmdline-option is given.
+getRendering() runs code or prog or progfile through B::Concise, and
+captures its rendering. Errors emitted during rendering are checked
+against expected errors, and are reported as diagnostics by default,
+or as failures if 'report=fail' cmdline-option is given.
prog is run in a sub-shell, with $bcopts passed through. This is the way
to run code intended for main. The code arg in contrast, is always a
@@ -180,9 +180,9 @@
bcopts, note, prog, code. This is more convenient than trying to do
it manually.
-=head2 code or prog
+=head2 code or prog or progfile
-Either code or prog must be present.
+Either code or prog or progfile must be present.
=head2 prog => $perl_source_string
@@ -191,6 +191,11 @@
'./perl -w -MO=Concise,$bcopts_massaged -e $src'
+=head2 progfile => $perl_script
+
+progfile => $file provides a file containing a snippet of code which is
+run as per the prog => $src example above.
+
=head2 code => $perl_source_string || CODEREF
The $code arg is passed to B::Concise::compile(), and run in-process.
@@ -207,6 +212,10 @@
They're both required, and the correct one is selected for the platform
being tested, and saved into the synthesized property B<wanted>.
+Individual sample lines may be suffixed with whitespace followed
+by (<|<=|==|>=|>)5.nnnn to select that line only for the listed perl
+version; the whitespace and conditional are stripped.
+
=head2 bcopts => $bcopts || [ @bcopts ]
When getRendering() runs, it passes bcopts into B::Concise::compile().
@@ -214,8 +223,8 @@
=head2 errs => $err_str_regex || [ @err_str_regexs ]
-getRendering() processes the code or prog arg under warnings, and both
-parsing and optree-traversal errors are collected. These are
+getRendering() processes the code or prog or progfile arg under warnings,
+and both parsing and optree-traversal errors are collected. These are
validated against the one or more errors you specify.
=head1 testcase modifier properties
@@ -404,7 +413,14 @@
print "checkOptree args: ",mydumper($tc) if $tc->{dump};
SKIP: {
- skip("$tc->{skip} $tc->{name}", 1) if $tc->{skip};
+ if ($tc->{skip}) {
+ skip("$tc->{skip} $tc->{name}",
+ ($gOpts{selftest}
+ ? 1
+ : 1 + @{$modes{$gOpts{testmode}}}
+ )
+ );
+ }
return runSelftest($tc) if $gOpts{selftest};
@@ -463,8 +479,8 @@
sub getRendering {
my $tc = shift;
- fail("getRendering: code or prog is required")
- unless $tc->{code} or $tc->{prog};
+ fail("getRendering: code or prog or progfile is required")
+ unless $tc->{code} or $tc->{prog} or $tc->{progfile};
my @opts = get_bcopts($tc);
my $rendering = ''; # suppress "Use of uninitialized value in open"
@@ -475,6 +491,10 @@
$rendering = runperl( switches => ['-w',join(',',"-MO=Concise", at opts)],
prog => $tc->{prog}, stderr => 1,
); # verbose => 1);
+ } elsif ($tc->{progfile}) {
+ $rendering = runperl( switches => ['-w',join(',',"-MO=Concise", at opts)],
+ progfile => $tc->{progfile}, stderr => 1,
+ ); # verbose => 1);
} else {
my $code = $tc->{code};
unless (ref $code eq 'CODE') {
@@ -482,7 +502,7 @@
# in caller's package ( to test arg-fixup, comment next line)
my $pkg = '{ package '.caller(1) .';';
{
- no strict;
+ BEGIN { $^H = 0 }
no warnings;
$code = eval "$pkg sub { $code } }";
}
@@ -619,14 +639,24 @@
$str =~ s/^\# //mg; # ease cut-paste testcase authoring
- if ($] < 5.009) {
- # add 5.8 private flags, which bleadperl (5.9.1) doesn't have/use/render
- # works because it adds no wildcards, which are butchered below..
- $str =~ s|(mapstart l?K\*?)|$1/2|mg;
- $str =~ s|(grepstart l?K\*?)|$1/2|msg;
- $str =~ s|(mapwhile.*? l?K)|$1/1|msg;
- $str =~ s|(grepwhile.*? l?K)|$1/1|msg;
- }
+ # strip out conditional lines
+
+ $str =~ s{^(.*?)\s+(<|<=|==|>=|>)\s*(5\.\d+)\ *\n}
+ {
+ my ($line, $cmp, $version) = ($1,$2,$3);
+ my $repl = "";
+ if ( $cmp eq '<' ? $] < $version
+ : $cmp eq '<=' ? $] <= $version
+ : $cmp eq '==' ? $] == $version
+ : $cmp eq '>=' ? $] >= $version
+ : $cmp eq '>' ? $] > $version
+ : die("bad comparision '$cmp' in string [$str]\n")
+ ) {
+ $repl = "$line\n";
+ }
+ $repl;
+ }gem;
+
$tc->{wantstr} = $str;
# make targ args wild
@@ -663,32 +693,12 @@
)
(?:(:>,<,%,\\{) # hints when open.pm is in force
|(:>,<,%)) # (two variations)
- (\ ->[0-9a-z]+)?
+ (\ ->(?:-|[0-9a-z]+))?
$
]
[$1 . ($2 && ':{') . $4]xegm; # change to the hints without open.pm
}
- if ($] < 5.009) {
- # 5.8.x doesn't provide the hints in the OP, which means that
- # B::Concise doesn't show the symbolic hints. So strip all the
- # symbolic hints from the golden results.
- $str =~ s[( # capture
- \(\?:next\|db\)state # the regexp matching next/db state
- .* # all sorts of things follow it
- v # The opening v
- )
- :(?:\\[{*] # \{ or \*
- |[^,\\]) # or other symbols on their own
- (?:,
- (?:\\[{*]
- |[^,\\])
- )* # maybe some more joined with commas
- (\ ->[0-9a-z]+)?
- $
- ]
- [$1$2]xgm; # change to the hints without flags
- }
# don't care about:
$str =~ s/:-?\d+,-?\d+/:-?\\d+,-?\\d+/msg; # FAKE line numbers
@@ -975,7 +985,7 @@
sub OptreeCheck::processExamples {
my @files = @_;
- # gets array of paragraphs, which should be code-samples. Theyre
+ # gets array of paragraphs, which should be code-samples. They're
# turned into optreeCheck tests,
foreach my $file (@files) {
Property changes on: trunk/contrib/perl/ext/B/t/OptreeCheck.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/ext/B/t/b.t
===================================================================
--- trunk/contrib/perl/ext/B/t/b.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/B/t/b.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -218,8 +218,12 @@
like($hash, qr/\A0x[0-9a-f]+\z/, "Testing B::hash(\"wibble\")");
unlike($hash, qr/\A0x0+\z/, "Testing B::hash(\"wibble\")");
- like(B::hash("\0" x $_), qr/\A0x0+\z/, "Testing B::hash(\"0\" x $_)")
- for 0..19;
+ SKIP: {
+ skip "Nulls don't hash to the same bucket regardless of length with this PERL_HASH implementation", 20
+ if B::hash("") ne B::hash("\0" x 19);
+ like(B::hash("\0" x $_), qr/\A0x0+\z/, "Testing B::hash(\"0\" x $_)")
+ for 0..19;
+ }
$hash = eval {B::hash(chr 256)};
is($hash, undef, "B::hash() refuses non-octets");
@@ -268,7 +272,8 @@
is(B::class(bless {}, "Wibble::Bibble"), "Bibble", "Testing B::class()");
is(B::cast_I32(3.14), 3, "Testing B::cast_I32()");
-is(B::opnumber("chop"), 38, "Testing opnumber with opname (chop)");
+is(B::opnumber("chop"), $] >= 5.015 ? 39 : 38,
+ "Testing opnumber with opname (chop)");
{
no warnings 'once';
@@ -277,17 +282,8 @@
ok( $sg < B::sub_generation, "sub_generation increments" );
}
-{
- my $ag = B::amagic_generation();
- {
+like( B::amagic_generation, qr/^\d+\z/, "amagic_generation" );
- package Whatever;
- require overload;
- overload->import( '""' => sub {"What? You want more?!"} );
- }
- ok( $ag < B::amagic_generation, "amagic_generation increments" );
-}
-
is(B::svref_2object(sub {})->ROOT->ppaddr, 'PL_ppaddr[OP_LEAVESUB]',
'OP->ppaddr');
@@ -295,4 +291,128 @@
B::svref_2object(sub{y/\x{100}//})->ROOT->first->first->sibling->sv;
ok 1, 'B knows that UTF trans is a padop in 5.8.9, not an svop';
+{
+ format FOO =
+foo
+.
+ my $f = B::svref_2object(*FOO{FORMAT});
+ isa_ok $f, 'B::FM';
+ can_ok $f, 'LINES';
+}
+
+my $sub1 = sub {die};
+{ no warnings 'once'; no strict; *Peel:: = *{"Pe\0e\x{142}::"} }
+my $sub2 = eval 'package Peel; sub {die}';
+my $cop = B::svref_2object($sub1)->ROOT->first->first;
+my $bobby = B::svref_2object($sub2)->ROOT->first->first;
+is $cop->stash->object_2svref, \%main::, 'COP->stash';
+is $cop->stashpv, 'main', 'COP->stashpv';
+
+SKIP: {
+ skip "no nulls in packages before 5.17", 1 if $] < 5.017;
+ is $bobby->stashpv, "Pe\0e\x{142}", 'COP->stashpv with utf8 and nulls';
+}
+
+SKIP: {
+ skip "no stashoff", 2 if $] < 5.017 || !$Config::Config{useithreads};
+ like $cop->stashoff, qr/^[1-9]\d*\z/a, 'COP->stashoff';
+ isnt $cop->stashoff, $bobby->stashoff,
+ 'different COP->stashoff for different stashes';
+}
+
+
+# Test $B::overlay
+{
+ my $methods = {
+ BINOP => [ qw(last) ],
+ COP => [ qw(arybase cop_seq file filegv hints hints_hash io
+ label line stash stashpv
+ stashoff warnings) ],
+ LISTOP => [ qw(children) ],
+ LOGOP => [ qw(other) ],
+ LOOP => [ qw(lastop nextop redoop) ],
+ OP => [ qw(desc flags name next opt ppaddr private sibling
+ size spare targ type) ],
+ PADOP => [ qw(gv padix sv) ],
+ PMOP => [ qw(code_list pmflags pmoffset pmreplroot pmreplstart pmstash pmstashpv precomp reflags) ],
+ PVOP => [ qw(pv) ],
+ SVOP => [ qw(gv sv) ],
+ UNOP => [ qw(first) ],
+ };
+
+ my $overlay = {};
+ my $op = B::svref_2object(sub { my $x = 1 })->ROOT;
+
+ for my $class (sort keys %$methods) {
+ for my $meth (@{$methods->{$class}}) {
+ my $full = "B::${class}::$meth";
+ die "Duplicate method '$full'\n"
+ if grep $_ eq $full, @{$overlay->{$meth}};
+ push @{$overlay->{$meth}}, "B::${class}::$meth";
+ }
+ }
+
+ {
+ local $B::overlay; # suppress 'used once' warning
+ local $B::overlay = { $$op => $overlay };
+
+ for my $class (sort keys %$methods) {
+ bless $op, "B::$class"; # naughty
+ for my $meth (@{$methods->{$class}}) {
+ if ($op->can($meth)) {
+ my $list = $op->$meth;
+ ok(defined $list
+ && ref($list) eq "ARRAY"
+ && grep($_ eq "B::${class}::$meth", @$list),
+ "overlay: B::$class $meth");
+ }
+ else {
+ pass("overlay: B::$class $meth (skipped; no method)");
+ }
+ }
+ }
+ }
+ # B::overlay should be disabled again here
+ is($op->name, "leavesub", "overlay: orig name");
+}
+
+{ # [perl #118525]
+ {
+ sub foo {}
+ my $cv = B::svref_2object(\&foo);
+ ok($cv, "make a B::CV from a non-anon sub reference");
+ isa_ok($cv, "B::CV");
+ my $gv = $cv->GV;
+ ok($gv, "we get a GV from a GV on a normal sub");
+ isa_ok($gv, "B::GV");
+ is($gv->NAME, "foo", "check the GV name");
+ SKIP:
+ { # do we need these version checks?
+ skip "no HEK before 5.18", 1 if $] < 5.018;
+ is($cv->NAME_HEK, undef, "no hek for a global sub");
+ }
+ }
+
+SKIP:
+ {
+ skip "no HEK before 5.18", 4 if $] < 5.018;
+ eval <<'EOS'
+ {
+ use feature 'lexical_subs';
+ no warnings 'experimental::lexical_subs';
+ my sub bar {};
+ my $cv = B::svref_2object(\&bar);
+ ok($cv, "make a B::CV from a lexical sub reference");
+ isa_ok($cv, "B::CV");
+ my $gv = $cv->GV;
+ is($gv, undef, "GV on a lexical sub is NULL");
+ my $hek = $cv->NAME_HEK;
+ is($hek, "bar", "check the NAME_HEK");
+ }
+ 1;
+EOS
+ or die "lexical_subs test failed to compile: $@";
+ }
+}
+
done_testing();
Property changes on: trunk/contrib/perl/ext/B/t/b.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/ext/B/t/concise-xs.t
===================================================================
--- trunk/contrib/perl/ext/B/t/concise-xs.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/B/t/concise-xs.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -127,7 +127,10 @@
Digest::MD5 => { perl => [qw/ import /],
dflt => 'XS' },
- Data::Dumper => { XS => [qw/ bootstrap Dumpxs /],
+ Data::Dumper => { XS => [qw/ bootstrap Dumpxs /,
+ $] >= 5.015 ? qw/_vstring / : () ],
+ $] >= 5.015
+ ? (constant => ['_bad_vsmg']) : (),
dflt => 'perl' },
B => {
dflt => 'constant', # all but 47/297
@@ -145,7 +148,7 @@
formfeed end_av dowarn diehook defstash curstash
cstring comppadlist check_av cchar cast_I32 bootstrap
begin_av amagic_generation sub_generation address
- ), $] > 5.009 ? ('unitcheck_av') : ()],
+ unitcheck_av) ],
},
B::Deparse => { dflt => 'perl', # 236 functions
@@ -157,7 +160,7 @@
CVf_METHOD LIST_CONTEXT OP_CONST OP_LIST OP_RV2SV
OP_STRINGIFY OPf_KIDS OPf_MOD OPf_REF OPf_SPECIAL
OPf_STACKED OPf_WANT OPf_WANT_LIST OPf_WANT_SCALAR
- OPf_WANT_VOID OPpCONST_ARYBASE OPpCONST_BARE OPpCONST_NOVER
+ OPf_WANT_VOID OPpCONST_BARE OPpCONST_NOVER
OPpENTERSUB_AMPER OPpEXISTS_SUB OPpITER_REVERSED
OPpLVAL_INTRO OPpOUR_INTRO OPpSLICE OPpSORT_DESCEND
OPpSORT_INPLACE OPpSORT_INTEGER OPpSORT_NUMERIC
@@ -168,7 +171,10 @@
PMf_MULTILINE PMf_ONCE PMf_SINGLELINE
POSTFIX SVf_FAKE SVf_IOK SVf_NOK SVf_POK SVf_ROK
SVpad_OUR SVs_RMG SVs_SMG SWAP_CHILDREN OPpPAD_STATE
- /, $] > 5.009 ? ('RXf_SKIPWHITE') : ('PMf_SKIPWHITE'),
+ OPpCONST_ARYBASE RXf_SKIPWHITE/,
+ $] >= 5.015 ? qw(
+ OP_GLOB PMf_SKIPWHITE RXf_PMf_CHARSET RXf_PMf_KEEPCOPY
+ OPpEVAL_BYTES OPpSUBSTR_REPL_FIRST) : (),
'CVf_LOCKED', # This ends up as a constant, pre or post 5.10
],
},
@@ -184,7 +190,11 @@
WSTOPSIG WTERMSIG/,
'int_macro_int', # Removed in POSIX 1.16
],
- perl => [qw/ import croak AUTOLOAD /],
+ perl => [qw/ import croak AUTOLOAD /,
+ $] >= 5.015
+ ? qw/load_imports usage printf sprintf perror/
+ : (),
+ ],
XS => [qw/ write wctomb wcstombs uname tzset tzname
ttyname tmpnam times tcsetpgrp tcsendbreak
@@ -202,7 +212,7 @@
ctermid cosh constant close clock ceil
bootstrap atan asin asctime acos access abort
_exit
- /],
+ /, $] >= 5.015 ? ('sleep') : () ],
},
IO::Socket => { dflt => 'constant', # 157/190
@@ -214,7 +224,7 @@
new listen import getsockopt croak
connected connect configure confess close
carp bind atmark accept sockaddr_in6
- /, $] > 5.009 ? ('blocking') : () ],
+ blocking/ ],
XS => [qw/ unpack_sockaddr_un unpack_sockaddr_in
sockatmark sockaddr_family pack_sockaddr_un
@@ -247,6 +257,7 @@
if (%opts) {
require Data::Dumper;
Data::Dumper->import('Dumper');
+ { my $x = \*Data::Dumper::Sortkeys } # shut up 'used once' warning
$Data::Dumper::Sortkeys = 1;
}
my @argpkgs = @ARGV;
@@ -349,6 +360,7 @@
warn "Module::CoreList not available on $]\n";
return;
}
+ { my $x = \*Module::CoreList::version } # shut up 'used once' warning
my $mods = $Module::CoreList::version{'5.009002'};
$mods = [ sort keys %$mods ];
print Dumper($mods);
@@ -360,6 +372,7 @@
END {
if ($opts{c}) {
+ { my $x = \*Data::Dumper::Indent } # shut up 'used once' warning
$Data::Dumper::Indent = 1;
print "Corrections: ", Dumper(\%report);
Property changes on: trunk/contrib/perl/ext/B/t/concise-xs.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/ext/B/t/concise.t
===================================================================
--- trunk/contrib/perl/ext/B/t/concise.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/B/t/concise.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -10,7 +10,7 @@
require 'test.pl'; # we use runperl from 'test.pl', so can't use Test::More
}
-plan tests => 159;
+plan tests => 160;
require_ok("B::Concise");
@@ -448,4 +448,11 @@
`-ex-rv2sv---<4>gvsv[*_]
end
+# -nobanner
+$out =
+ runperl(
+ switches => ["-MO=Concise,-nobanner,foo"], prog=>'sub foo{}', stderr => 1
+ );
+unlike $out, 'main::foo', '-nobanner';
+
__END__
Property changes on: trunk/contrib/perl/ext/B/t/concise.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Copied: trunk/contrib/perl/ext/B/t/debug.t (from rev 6437, vendor/perl/5.18.1/ext/B/t/debug.t)
===================================================================
--- trunk/contrib/perl/ext/B/t/debug.t (rev 0)
+++ trunk/contrib/perl/ext/B/t/debug.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -0,0 +1,90 @@
+#!./perl
+
+BEGIN {
+ delete $ENV{PERL_DL_NONLAZY} if $] < 5.005_58; #Perl_byterun problem
+ if ($ENV{PERL_CORE}){
+ chdir('t') if -d 't';
+ if ($^O eq 'MacOS') {
+ @INC = qw(: ::lib ::macos:lib);
+ } else {
+ @INC = '.';
+ push @INC, '../lib';
+ }
+ } else {
+ unshift @INC, 't';
+ }
+ require Config;
+ if (($Config::Config{'extensions'} !~ /\bB\b/) ){
+ print "1..0 # Skip -- Perl configured without B module\n";
+ exit 0;
+ }
+}
+
+$| = 1;
+use warnings;
+use strict;
+use Config;
+use Test::More tests => 8;
+use B;
+use B::Debug;
+
+my $a;
+my $Is_VMS = $^O eq 'VMS';
+my $Is_MacOS = $^O eq 'MacOS';
+
+my $path = join " ", map { qq["-I$_"] } @INC;
+my $redir = $Is_MacOS ? "" : "2>&1";
+
+$a = `$^X $path "-MO=Debug" -e 1 $redir`;
+like($a, qr/\bLISTOP\b.*\bOP\b.*\bCOP\b.*\bOP\b/s);
+
+
+$a = `$^X $path "-MO=Terse" -e 1 $redir`;
+like($a, qr/\bLISTOP\b.*leave.*\n OP\b.*enter.*\n COP\b.*nextstate.*\n OP\b.*null/s);
+
+$a = `$^X $path "-MO=Terse" -ane "s/foo/bar/" $redir`;
+$a =~ s/\(0x[^)]+\)//g;
+$a =~ s/\[[^\]]+\]//g;
+$a =~ s/-e syntax OK//;
+$a =~ s/[^a-z ]+//g;
+$a =~ s/\s+/ /g;
+$a =~ s/\b(s|foo|bar|ullsv)\b\s?//g;
+$a =~ s/^\s+//;
+$a =~ s/\s+$//;
+$a =~ s/\s+nextstate$//; # if $] < 5.008001; # 5.8.0 adds it. 5.8.8 not anymore
+my $is_thread = $Config{use5005threads} && $Config{use5005threads} eq 'define';
+if ($is_thread) {
+ $b=<<EOF;
+leave enter nextstate label leaveloop enterloop null and defined null
+threadsv readline gv lineseq nextstate aassign null pushmark split pushre
+threadsv const null pushmark rvav gv nextstate subst const unstack
+EOF
+} else {
+ $b=<<EOF;
+leave enter nextstate label leaveloop enterloop null and defined null null
+gvsv readline gv lineseq nextstate aassign null pushmark split pushre null
+gvsv const null pushmark rvav gv nextstate subst const unstack
+EOF
+}
+#$b .= " nextstate" if $] < 5.008001; # ??
+$b=~s/\n/ /g;$b=~s/\s+/ /g;
+$b =~ s/\s+$//;
+is($a, $b);
+
+like(B::Debug::_printop(B::main_root), qr/LISTOP\s+\[OP_LEAVE\]/);
+like(B::Debug::_printop(B::main_start), qr/OP\s+\[OP_ENTER\]/);
+
+$a = `$^X $path "-MO=Debug" -e "B::main_root->debug" $redir`;
+like($a, qr/op_next\s+0x0/m);
+$a = `$^X $path "-MO=Debug" -e "B::main_start->debug" $redir`;
+like($a, qr/PL_ppaddr\[OP_ENTER\]/m);
+
+# pass missing FETCHSIZE, fixed with 1.06
+my $tmp = "tmp.pl";
+open TMP, "> $tmp";
+print TMP 'BEGIN{tie @a, __PACKAGE__;sub TIEARRAY {bless{}} sub FETCH{1}};
+print $a[1]';
+close TMP;
+$a = `$^X $path "-MO=Debug" $tmp $redir`;
+unlink $tmp;
+unlike($a, qr/locate object method "FETCHSIZE"/m);
Copied: trunk/contrib/perl/ext/B/t/deparse.t (from rev 6437, vendor/perl/5.18.1/ext/B/t/deparse.t)
===================================================================
--- trunk/contrib/perl/ext/B/t/deparse.t (rev 0)
+++ trunk/contrib/perl/ext/B/t/deparse.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -0,0 +1,527 @@
+#!./perl
+
+BEGIN {
+ if ($ENV{PERL_CORE}){
+ chdir('t') if -d 't';
+ if ($^O eq 'MacOS') {
+ @INC = qw(: ::lib ::macos:lib);
+ } else {
+ @INC = '.';
+ push @INC, '../lib';
+ }
+ } else {
+ unshift @INC, 't';
+ }
+ require Config;
+ if (($Config::Config{'extensions'} !~ /\bB\b/) ){
+ print "1..0 # Skip -- Perl configured without B module\n";
+ exit 0;
+ }
+}
+
+use warnings;
+use strict;
+BEGIN {
+ # BEGIN block is acutally a subroutine :-)
+ return unless $] > 5.009;
+ require feature;
+ feature->import(':5.10');
+}
+use Test::More tests => 70;
+use Config ();
+
+use B::Deparse;
+my $deparse = B::Deparse->new();
+ok($deparse);
+
+# Tell B::Deparse about our ambient pragmas
+{ my ($hint_bits, $warning_bits, $hinthash);
+ BEGIN { ($hint_bits, $warning_bits, $hinthash) = ($^H, ${^WARNING_BITS}, \%^H); }
+ $deparse->ambient_pragmas (
+ hint_bits => $hint_bits,
+ warning_bits => $warning_bits,
+ '$[' => 0 + $[,
+ '%^H' => $hinthash,
+ );
+}
+
+$/ = "\n####\n";
+while (<DATA>) {
+ chomp;
+ # This code is pinched from the t/lib/common.pl for TODO.
+ # It's not clear how to avoid duplication
+ # Now tweaked a bit to do skip or todo
+ my %reason;
+ foreach my $what (qw(skip todo)) {
+ s/^#\s*\U$what\E\s*(.*)\n//m and $reason{$what} = $1;
+ # If the SKIP reason starts ? then it's taken as a code snippet to
+ # evaluate. This provides the flexibility to have conditional SKIPs
+ if ($reason{$what} && $reason{$what} =~ s/^\?//) {
+ my $temp = eval $reason{$what};
+ if ($@) {
+ die "# In \U$what\E code reason:\n# $reason{$what}\n$@";
+ }
+ $reason{$what} = $temp;
+ }
+ }
+
+ s/^\s*#\s*(.*)$//mg;
+ my ($num, $testname) = $1 =~ m/(\d+)\s*(.*)/;
+
+ if ($reason{skip}) {
+ # Like this to avoid needing a label SKIP:
+ Test::More->builder->skip($reason{skip});
+ next;
+ }
+
+ my ($input, $expected);
+ if (/(.*)\n>>>>\n(.*)/s) {
+ ($input, $expected) = ($1, $2);
+ }
+ else {
+ ($input, $expected) = ($_, $_);
+ }
+
+ my $coderef = eval "sub {$input}";
+
+ if ($@) {
+ diag("$num deparsed: $@");
+ ok(0, $testname);
+ }
+ else {
+ my $deparsed = $deparse->coderef2text( $coderef );
+ my $regex = $expected;
+ $regex =~ s/(\S+)/\Q$1/g;
+ $regex =~ s/\s+/\\s+/g;
+ $regex = '^\{\s*' . $regex . '\s*\}$';
+
+ local $::TODO = $reason{todo};
+ like($deparsed, qr/$regex/, $testname);
+ }
+}
+
+use constant 'c', 'stuff';
+is((eval "sub ".$deparse->coderef2text(\&c))->(), 'stuff');
+
+my $a = 0;
+is("{\n (-1) ** \$a;\n}", $deparse->coderef2text(sub{(-1) ** $a }));
+
+use constant cr => ['hello'];
+my $string = "sub " . $deparse->coderef2text(\&cr);
+my $val = (eval $string)->() or diag $string;
+is(ref($val), 'ARRAY');
+is($val->[0], 'hello');
+
+my $Is_VMS = $^O eq 'VMS';
+my $Is_MacOS = $^O eq 'MacOS';
+
+my $path = join " ", map { qq["-I$_"] } @INC;
+$path .= " -MMac::err=unix" if $Is_MacOS;
+my $redir = $Is_MacOS ? "" : "2>&1";
+
+$a = `$^X $path "-MO=Deparse" -anlwi.bak -e 1 $redir`;
+$a =~ s/-e syntax OK\n//g;
+$a =~ s/.*possible typo.*\n//; # Remove warning line
+$a =~ s{\\340\\242}{\\s} if (ord("\\") == 224); # EBCDIC, cp 1047 or 037
+$a =~ s{\\274\\242}{\\s} if (ord("\\") == 188); # $^O eq 'posix-bc'
+$b = <<'EOF';
+BEGIN { $^I = ".bak"; }
+BEGIN { $^W = 1; }
+BEGIN { $/ = "\n"; $\ = "\n"; }
+LINE: while (defined($_ = <ARGV>)) {
+ chomp $_;
+ our(@F) = split(' ', $_, 0);
+ '???';
+}
+EOF
+$b =~ s/(LINE:)/sub BEGIN {
+ 'MacPerl'->bootstrap;
+ 'OSA'->bootstrap;
+ 'XL'->bootstrap;
+}
+$1/ if $Is_MacOS;
+is($a, $b);
+
+#Re: perlbug #35857, patch #24505
+#handle warnings::register-ed packages properly.
+package B::Deparse::Wrapper;
+use strict;
+use warnings;
+use warnings::register;
+sub getcode {
+ my $deparser = B::Deparse->new();
+ return $deparser->coderef2text(shift);
+}
+
+package Moo;
+use overload '0+' => sub { 42 };
+
+package main;
+use strict;
+use warnings;
+use constant GLIPP => 'glipp';
+use constant PI => 4;
+use constant OVERLOADED_NUMIFICATION => bless({}, 'Moo');
+use Fcntl qw/O_TRUNC O_APPEND O_EXCL/;
+BEGIN { delete $::Fcntl::{O_APPEND}; }
+use POSIX qw/O_CREAT/;
+sub test {
+ my $val = shift;
+ my $res = B::Deparse::Wrapper::getcode($val);
+ like( $res, qr/use warnings/);
+}
+my ($q,$p);
+my $x=sub { ++$q,++$p };
+test($x);
+eval <<EOFCODE and test($x);
+ package bar;
+ use strict;
+ use warnings;
+ use warnings::register;
+ package main;
+ 1
+EOFCODE
+
+__DATA__
+# 2
+1;
+####
+# 3
+{
+ no warnings;
+ '???';
+ 2;
+}
+####
+# 4
+my $test;
+++$test and $test /= 2;
+>>>>
+my $test;
+$test /= 2 if ++$test;
+####
+# 5
+-((1, 2) x 2);
+####
+# 6
+{
+ my $test = sub : lvalue {
+ my $x;
+ }
+ ;
+}
+####
+# 7
+{
+ my $test = sub : method {
+ my $x;
+ }
+ ;
+}
+####
+# 8
+{
+ my $test = sub : locked method {
+ my $x;
+ }
+ ;
+}
+####
+# 9
+{
+ 234;
+}
+continue {
+ 123;
+}
+####
+# 10
+my $x;
+print $main::x;
+####
+# 11
+my @x;
+print $main::x[1];
+####
+# 12
+my %x;
+$x{warn()};
+####
+# 13
+my $foo;
+$_ .= <ARGV> . <$foo>;
+####
+# 14
+my $foo = "Ab\x{100}\200\x{200}\377Cd\000Ef\x{1000}\cA\x{2000}\cZ";
+####
+# 15
+s/x/'y';/e;
+####
+# 16 - various lypes of loop
+{ my $x; }
+####
+# 17
+while (1) { my $k; }
+####
+# 18
+my ($x, at a);
+$x=1 for @a;
+>>>>
+my($x, @a);
+$x = 1 foreach (@a);
+####
+# 19
+for (my $i = 0; $i < 2;) {
+ my $z = 1;
+}
+####
+# 20
+for (my $i = 0; $i < 2; ++$i) {
+ my $z = 1;
+}
+####
+# 21
+for (my $i = 0; $i < 2; ++$i) {
+ my $z = 1;
+}
+####
+# 22
+my $i;
+while ($i) { my $z = 1; } continue { $i = 99; }
+####
+# 23
+foreach my $i (1, 2) {
+ my $z = 1;
+}
+####
+# 24
+my $i;
+foreach $i (1, 2) {
+ my $z = 1;
+}
+####
+# 25
+my $i;
+foreach my $i (1, 2) {
+ my $z = 1;
+}
+####
+# 26
+foreach my $i (1, 2) {
+ my $z = 1;
+}
+####
+# 27
+foreach our $i (1, 2) {
+ my $z = 1;
+}
+####
+# 28
+my $i;
+foreach our $i (1, 2) {
+ my $z = 1;
+}
+####
+# 29
+my @x;
+print reverse sort(@x);
+####
+# 30
+my @x;
+print((sort {$b cmp $a} @x));
+####
+# 31
+my @x;
+print((reverse sort {$b <=> $a} @x));
+####
+# 32
+our @a;
+print $_ foreach (reverse @a);
+####
+# 33
+our @a;
+print $_ foreach (reverse 1, 2..5);
+####
+# 34 (bug #38684)
+our @ary;
+ at ary = split(' ', 'foo', 0);
+####
+# 35 (bug #40055)
+do { () };
+####
+# 36 (ibid.)
+do { my $x = 1; $x };
+####
+# 37 <20061012113037.GJ25805 at c4.convolution.nl>
+my $f = sub {
+ +{[]};
+} ;
+####
+# 38 (bug #43010)
+'!@$%'->();
+####
+# 39 (ibid.)
+::();
+####
+# 40 (ibid.)
+'::::'->();
+####
+# 41 (ibid.)
+&::::;
+####
+# 42
+my $bar;
+'Foo'->$bar('orz');
+####
+# 43
+'Foo'->bar('orz');
+####
+# 44
+'Foo'->bar;
+####
+# SKIP ?$] < 5.010 && "say not implemented on this Perl version"
+# 45 say
+say 'foo';
+####
+# SKIP ?$] < 5.010 && "state vars not implemented on this Perl version"
+# 46 state vars
+state $x = 42;
+####
+# SKIP ?$] < 5.010 && "state vars not implemented on this Perl version"
+# 47 state var assignment
+{
+ my $y = (state $x = 42);
+}
+####
+# SKIP ?$] < 5.010 && "state vars not implemented on this Perl version"
+# 48 state vars in anoymous subroutines
+$a = sub {
+ state $x;
+ return $x++;
+}
+;
+####
+# SKIP ?$] < 5.011 && 'each @array not implemented on this Perl version'
+# 49 each @array;
+each @ARGV;
+each @$a;
+####
+# SKIP ?$] < 5.011 && 'each @array not implemented on this Perl version'
+# 50 keys @array; values @array
+keys @$a if keys @ARGV;
+values @ARGV if values @$a;
+####
+# 51 Anonymous arrays and hashes, and references to them
+my $a = {};
+my $b = \{};
+my $c = [];
+my $d = \[];
+####
+# SKIP ?$] < 5.010 && "smartmatch and given/when not implemented on this Perl version"
+# 52 implicit smartmatch in given/when
+given ('foo') {
+ when ('bar') { continue; }
+ when ($_ ~~ 'quux') { continue; }
+ default { 0; }
+}
+####
+# 53 conditions in elsifs (regression in change #33710 which fixed bug #37302)
+if ($a) { x(); }
+elsif ($b) { x(); }
+elsif ($a and $b) { x(); }
+elsif ($a or $b) { x(); }
+else { x(); }
+####
+# 54 interpolation in regexps
+my($y, $t);
+/x${y}z$t/;
+####
+# TODO new undocumented cpan-bug #33708
+# 55 (cpan-bug #33708)
+%{$_ || {}}
+####
+# TODO hash constants not yet fixed
+# 56 (cpan-bug #33708)
+use constant H => { "#" => 1 }; H->{"#"}
+####
+# TODO optimized away 0 not yet fixed
+# 57 (cpan-bug #33708)
+foreach my $i (@_) { 0 }
+####
+# 58 placeholder for skipped edbe35ea95
+1;
+####
+# 59 placeholder for skipped edbe35ea95
+1;
+####
+# 60 tests that should be constant folded
+x() if 1;
+x() if GLIPP;
+x() if !GLIPP;
+x() if GLIPP && GLIPP;
+x() if !GLIPP || GLIPP;
+x() if do { GLIPP };
+x() if do { no warnings 'void'; 5; GLIPP };
+x() if do { !GLIPP };
+if (GLIPP) { x() } else { z() }
+if (!GLIPP) { x() } else { z() }
+if (GLIPP) { x() } elsif (GLIPP) { z() }
+if (!GLIPP) { x() } elsif (GLIPP) { z() }
+if (GLIPP) { x() } elsif (!GLIPP) { z() }
+if (!GLIPP) { x() } elsif (!GLIPP) { z() }
+if (!GLIPP) { x() } elsif (!GLIPP) { z() } elsif (GLIPP) { t() }
+if (!GLIPP) { x() } elsif (!GLIPP) { z() } elsif (!GLIPP) { t() }
+if (!GLIPP) { x() } elsif (!GLIPP) { z() } elsif (!GLIPP) { t() }
+>>>>
+x();
+x();
+'???';
+x();
+x();
+x();
+x();
+do {
+ '???'
+};
+do {
+ x()
+};
+do {
+ z()
+};
+do {
+ x()
+};
+do {
+ z()
+};
+do {
+ x()
+};
+'???';
+do {
+ t()
+};
+'???';
+!1;
+####
+# TODO Only strict 'refs' currently supported
+# 68 strict
+no strict;
+$x;
+####
+# TODO Subsets of warnings could be encoded textually, rather than as bitflips.
+no warnings 'deprecated';
+my $x;
+####
+# TODO Better test for CPAN #33708 - the deparsed code has different behaviour
+use strict;
+no warnings;
+
+foreach (0..3) {
+ my $x = 2;
+ {
+ my $x if 0;
+ print ++$x, "\n";
+ }
+}
Index: trunk/contrib/perl/ext/B/t/f_map
===================================================================
--- trunk/contrib/perl/ext/B/t/f_map 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/B/t/f_map 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/B/t/f_map
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/ext/B/t/f_map.t
===================================================================
--- trunk/contrib/perl/ext/B/t/f_map.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/B/t/f_map.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -25,7 +25,7 @@
private flags /1, /2 are gone in blead (for the cases covered)
When the optree stuff was integrated into 5.8.6, these tests failed,
-and were todo'd. Theyre now done, by version-specific tweaking in
+and were todo'd. They're now done, by version-specific tweaking in
mkCheckRex(), therefore the skip is removed too.
=for gentest
@@ -95,7 +95,8 @@
# 3 <0> pushmark s
# 4 <#> gv[*array] s
# 5 <1> rv2av[t8] lKM/1
-# 6 <@> mapstart lK*
+# 6 <@> mapstart lK* < 5.017002
+# 6 <@> mapstart lK >=5.017002
# 7 <|> mapwhile(other->8)[t9] lK
# 8 <0> enter l
# 9 <;> nextstate(main 475 (eval 10):1) v:{
@@ -103,7 +104,7 @@
# b <0> pushmark s
# c <#> gvsv[*_] s
# d <#> gv[*getkey] s/EARLYCV
-# e <1> entersub[t5] lKS/TARG,1
+# e <1> entersub[t5] lKS/TARG
# f <#> gvsv[*_] s
# g <@> list lK
# h <@> leave lKP
@@ -119,7 +120,8 @@
# 3 <0> pushmark s
# 4 <$> gv(*array) s
# 5 <1> rv2av[t3] lKM/1
-# 6 <@> mapstart lK*
+# 6 <@> mapstart lK* < 5.017002
+# 6 <@> mapstart lK >=5.017002
# 7 <|> mapwhile(other->8)[t4] lK
# 8 <0> enter l
# 9 <;> nextstate(main 559 (eval 15):1) v:{
@@ -127,7 +129,7 @@
# b <0> pushmark s
# c <$> gvsv(*_) s
# d <$> gv(*getkey) s/EARLYCV
-# e <1> entersub[t2] lKS/TARG,1
+# e <1> entersub[t2] lKS/TARG
# f <$> gvsv(*_) s
# g <@> list lK
# h <@> leave lKP
@@ -179,7 +181,7 @@
# k <0> pushmark s
# l <#> gvsv[*_] s
# m <#> gv[*getkey] s/EARLYCV
-# n <1> entersub[t10] sKS/TARG,1
+# n <1> entersub[t10] sKS/TARG
# o <2> helem sKRM*/2
# p <2> sassign vKS/2
# q <0> unstack s
@@ -212,7 +214,7 @@
# k <0> pushmark s
# l <$> gvsv(*_) s
# m <$> gv(*getkey) s/EARLYCV
-# n <1> entersub[t4] sKS/TARG,1
+# n <1> entersub[t4] sKS/TARG
# o <2> helem sKRM*/2
# p <2> sassign vKS/2
# q <0> unstack s
@@ -239,7 +241,8 @@
# 3 <0> pushmark s
# 4 <#> gv[*array] s
# 5 <1> rv2av[t7] lKM/1
-# 6 <@> mapstart lK*
+# 6 <@> mapstart lK* < 5.017002
+# 6 <@> mapstart lK >=5.017002
# 7 <|> mapwhile(other->8)[t9] lK
# 8 <0> pushmark s
# 9 <#> gvsv[*_] s
@@ -247,7 +250,7 @@
# b <@> stringify[t5] sK/1
# c <$> const[IV 1] s
# d <@> list lK
-# - <@> scope lK
+# - <@> scope lK < 5.017002
# goto 7
# e <0> pushmark s
# f <#> gv[*hash] s
@@ -260,7 +263,8 @@
# 3 <0> pushmark s
# 4 <$> gv(*array) s
# 5 <1> rv2av[t4] lKM/1
-# 6 <@> mapstart lK*
+# 6 <@> mapstart lK* < 5.017002
+# 6 <@> mapstart lK >=5.017002
# 7 <|> mapwhile(other->8)[t5] lK
# 8 <0> pushmark s
# 9 <$> gvsv(*_) s
@@ -268,7 +272,7 @@
# b <@> stringify[t3] sK/1
# c <$> const(IV 1) s
# d <@> list lK
-# - <@> scope lK
+# - <@> scope lK < 5.017002
# goto 7
# e <0> pushmark s
# f <$> gv(*hash) s
@@ -293,7 +297,8 @@
# 3 <0> pushmark s
# 4 <#> gv[*array] s
# 5 <1> rv2av[t7] lKM/1
-# 6 <@> mapstart lK*
+# 6 <@> mapstart lK* < 5.017002
+# 6 <@> mapstart lK >=5.017002
# 7 <|> mapwhile(other->8)[t9] lK
# 8 <0> pushmark s
# 9 <#> gvsv[*_] s
@@ -301,7 +306,7 @@
# b <@> stringify[t5] sK/1
# c <$> const[IV 1] s
# d <@> list lKP
-# - <@> scope lK
+# - <@> scope lK < 5.017002
# goto 7
# e <0> pushmark s
# f <#> gv[*hash] s
@@ -314,7 +319,8 @@
# 3 <0> pushmark s
# 4 <$> gv(*array) s
# 5 <1> rv2av[t4] lKM/1
-# 6 <@> mapstart lK*
+# 6 <@> mapstart lK* < 5.017002
+# 6 <@> mapstart lK >=5.017002
# 7 <|> mapwhile(other->8)[t5] lK
# 8 <0> pushmark s
# 9 <$> gvsv(*_) s
@@ -322,7 +328,7 @@
# b <@> stringify[t3] sK/1
# c <$> const(IV 1) s
# d <@> list lKP
-# - <@> scope lK
+# - <@> scope lK < 5.017002
# goto 7
# e <0> pushmark s
# f <$> gv(*hash) s
@@ -347,7 +353,8 @@
# 3 <0> pushmark s
# 4 <#> gv[*array] s
# 5 <1> rv2av[t6] lKM/1
-# 6 <@> mapstart lK*
+# 6 <@> mapstart lK* < 5.017002
+# 6 <@> mapstart lK >=5.017002
# 7 <|> mapwhile(other->8)[t8] lK
# 8 <0> pushmark s
# 9 <#> gvsv[*_] s
@@ -354,7 +361,7 @@
# a <1> lc[t4] sK/1
# b <$> const[IV 1] s
# c <@> list lK
-# - <@> scope lK
+# - <@> scope lK < 5.017002
# goto 7
# d <0> pushmark s
# e <#> gv[*hash] s
@@ -367,7 +374,8 @@
# 3 <0> pushmark s
# 4 <$> gv(*array) s
# 5 <1> rv2av[t3] lKM/1
-# 6 <@> mapstart lK*
+# 6 <@> mapstart lK* < 5.017002
+# 6 <@> mapstart lK >=5.017002
# 7 <|> mapwhile(other->8)[t4] lK
# 8 <0> pushmark s
# 9 <$> gvsv(*_) s
@@ -374,7 +382,7 @@
# a <1> lc[t2] sK/1
# b <$> const(IV 1) s
# c <@> list lK
-# - <@> scope lK
+# - <@> scope lK < 5.017002
# goto 7
# d <0> pushmark s
# e <$> gv(*hash) s
Property changes on: trunk/contrib/perl/ext/B/t/f_map.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/ext/B/t/f_sort
===================================================================
--- trunk/contrib/perl/ext/B/t/f_sort 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/B/t/f_sort 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/B/t/f_sort
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/ext/B/t/f_sort.t
===================================================================
--- trunk/contrib/perl/ext/B/t/f_sort.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/B/t/f_sort.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -24,7 +24,7 @@
private flags /1, /2 are gone in blead (for the cases covered)
When the optree stuff was integrated into 5.8.6, these tests failed,
-and were todo'd. Theyre now done, by version-specific tweaking in
+and were todo'd. They're now done, by version-specific tweaking in
mkCheckRex(), therefore the skip is removed too.
=head1 Test Notes
@@ -500,7 +500,8 @@
# 5 <0> pushmark s
# 6 <#> gv[*old] s
# 7 <1> rv2av[t19] lKM/1
-# 8 <@> mapstart lK*
+# 8 <@> mapstart lK* < 5.017002
+# 8 <@> mapstart lK >=5.017002
# 9 <|> mapwhile(other->a)[t20] lK
# a <0> enter l
# b <;> nextstate(main 608 (eval 34):2) v:{
@@ -513,14 +514,15 @@
# i <@> leave lKP
# goto 9
# j <@> sort lKMS*
-# k <@> mapstart lK*
+# k <@> mapstart lK* < 5.017002
+# k <@> mapstart lK >=5.017002
# l <|> mapwhile(other->m)[t26] lK
# m <#> gv[*_] s
# n <1> rv2sv sKM/DREFAV,1
-# o <1> rv2av[t4] sKR/DREFed,1
+# o <1> rv2av[t4] sKR/1
# p <$> const[IV 0] s
# q <2> aelem sK/2
-# - <@> scope lK
+# - <@> scope lK < 5.017002
# goto l
# r <0> pushmark s
# s <#> gv[*new] s
@@ -535,7 +537,8 @@
# 5 <0> pushmark s
# 6 <$> gv(*old) s
# 7 <1> rv2av[t10] lKM/1
-# 8 <@> mapstart lK*
+# 8 <@> mapstart lK* < 5.017002
+# 8 <@> mapstart lK >=5.017002
# 9 <|> mapwhile(other->a)[t11] lK
# a <0> enter l
# b <;> nextstate(main 608 (eval 34):2) v:{
@@ -548,14 +551,15 @@
# i <@> leave lKP
# goto 9
# j <@> sort lKMS*
-# k <@> mapstart lK*
+# k <@> mapstart lK* < 5.017002
+# k <@> mapstart lK >=5.017002
# l <|> mapwhile(other->m)[t12] lK
# m <$> gv(*_) s
# n <1> rv2sv sKM/DREFAV,1
-# o <1> rv2av[t2] sKR/DREFed,1
+# o <1> rv2av[t2] sKR/1
# p <$> const(IV 0) s
# q <2> aelem sK/2
-# - <@> scope lK
+# - <@> scope lK < 5.017002
# goto l
# r <0> pushmark s
# s <$> gv(*new) s
@@ -683,10 +687,6 @@
# b <1> leavesub[1 ref] K/REFC,1
EONT_EONT
-if($] < 5.009) {
- # 5.8.x doesn't show the /STABLE flag, so massage the golden results.
- s!/STABLE!!s foreach ($expect, $expect_nt);
-}
checkOptree(note => q{},
bcopts => q{-exec},
@@ -785,12 +785,13 @@
# 4 <0> pushmark s
# 5 <#> gv[*input] s
# 6 <1> rv2av[t9] lKM/1
-# 7 <@> grepstart lK*
+# 7 <@> grepstart lK* < 5.017002
+# 7 <@> grepstart lK >=5.017002
# 8 <|> grepwhile(other->9)[t10] lK
# 9 <#> gvsv[*_] s
# a <#> gvsv[*_] s
# b <2> eq sK/2
-# - <@> scope sK
+# - <@> scope sK < 5.017002
# goto 8
# c <@> sort lK/NUM
# d <0> pushmark s
@@ -805,12 +806,13 @@
# 4 <0> pushmark s
# 5 <$> gv(*input) s
# 6 <1> rv2av[t3] lKM/1
-# 7 <@> grepstart lK*
+# 7 <@> grepstart lK* < 5.017002
+# 7 <@> grepstart lK >=5.017002
# 8 <|> grepwhile(other->9)[t4] lK
# 9 <$> gvsv(*_) s
# a <$> gvsv(*_) s
# b <2> eq sK/2
-# - <@> scope sK
+# - <@> scope sK < 5.017002
# goto 8
# c <@> sort lK/NUM
# d <0> pushmark s
@@ -864,12 +866,13 @@
# 3 <0> pushmark s
# 4 <#> gv[*input] s
# 5 <1> rv2av[t7] lKM/1
-# 6 <@> grepstart lK*
+# 6 <@> grepstart lK* < 5.017002
+# 6 <@> grepstart lK >=5.017002
# 7 <|> grepwhile(other->8)[t8] lK
# 8 <#> gvsv[*_] s
# 9 <#> gvsv[*_] s
# a <2> eq sK/2
-# - <@> scope sK
+# - <@> scope sK < 5.017002
# goto 7
# b <@> sort K/NUM
# c <1> leavesub[1 ref] K/REFC,1
@@ -879,12 +882,13 @@
# 3 <0> pushmark s
# 4 <$> gv(*input) s
# 5 <1> rv2av[t2] lKM/1
-# 6 <@> grepstart lK*
+# 6 <@> grepstart lK* < 5.017002
+# 6 <@> grepstart lK >=5.017002
# 7 <|> grepwhile(other->8)[t3] lK
# 8 <$> gvsv(*_) s
# 9 <$> gvsv(*_) s
# a <2> eq sK/2
-# - <@> scope sK
+# - <@> scope sK < 5.017002
# goto 7
# b <@> sort K/NUM
# c <1> leavesub[1 ref] K/REFC,1
@@ -937,12 +941,13 @@
# 3 <0> pushmark s
# 4 <#> gv[*input] s
# 5 <1> rv2av[t8] lKM/1
-# 6 <@> grepstart lK*
+# 6 <@> grepstart lK* < 5.017002
+# 6 <@> grepstart lK >=5.017002
# 7 <|> grepwhile(other->8)[t9] lK
# 8 <#> gvsv[*_] s
# 9 <#> gvsv[*_] s
# a <2> eq sK/2
-# - <@> scope sK
+# - <@> scope sK < 5.017002
# goto 7
# b <@> sort sK/NUM
# c <#> gvsv[*s] s
@@ -954,12 +959,13 @@
# 3 <0> pushmark s
# 4 <$> gv(*input) s
# 5 <1> rv2av[t2] lKM/1
-# 6 <@> grepstart lK*
+# 6 <@> grepstart lK* < 5.017002
+# 6 <@> grepstart lK >=5.017002
# 7 <|> grepwhile(other->8)[t3] lK
# 8 <$> gvsv(*_) s
# 9 <$> gvsv(*_) s
# a <2> eq sK/2
-# - <@> scope sK
+# - <@> scope sK < 5.017002
# goto 7
# b <@> sort sK/NUM
# c <$> gvsv(*s) s
Property changes on: trunk/contrib/perl/ext/B/t/f_sort.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Copied: trunk/contrib/perl/ext/B/t/lint.t (from rev 6437, vendor/perl/5.18.1/ext/B/t/lint.t)
===================================================================
--- trunk/contrib/perl/ext/B/t/lint.t (rev 0)
+++ trunk/contrib/perl/ext/B/t/lint.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -0,0 +1,151 @@
+#!./perl -w
+
+BEGIN {
+ if ( $ENV{PERL_CORE} ) {
+ chdir('t') if -d 't';
+ @INC = ( '.', '../lib' );
+ }
+ else {
+ unshift @INC, 't';
+ push @INC, "../../t";
+ }
+ require Config;
+ if ( ( $Config::Config{'extensions'} !~ /\bB\b/ ) ) {
+ print "1..0 # Skip -- Perl configured without B module\n";
+ exit 0;
+ }
+ require 'test.pl';
+}
+use strict;
+use warnings;
+
+plan tests => 29;
+
+# Runs a separate perl interpreter with the appropriate lint options
+# turned on
+sub runlint ($$$;$) {
+ my ( $opts, $prog, $result, $testname ) = @_;
+ my $res = runperl(
+ switches => ["-MO=Lint,$opts"],
+ prog => $prog,
+ stderr => 1,
+ );
+ $res =~ s/-e syntax OK\n$//;
+ local $::Level = $::Level + 1;
+ is( $res, $result, $testname || $opts );
+}
+
+runlint 'magic-diamond', 'while(<>){}', <<'RESULT';
+Use of <> at -e line 1
+RESULT
+
+runlint 'magic-diamond', 'while(<ARGV>){}', <<'RESULT';
+Use of <> at -e line 1
+RESULT
+
+runlint 'magic-diamond', 'while(<FOO>){}', <<'RESULT';
+RESULT
+
+runlint 'context', '$foo = @bar', <<'RESULT';
+Implicit scalar context for array in scalar assignment at -e line 1
+RESULT
+
+runlint 'context', '$foo = length @bar', <<'RESULT';
+Implicit scalar context for array in length at -e line 1
+RESULT
+
+runlint 'context', 'our @bar', '';
+
+runlint 'context', 'exists $BAR{BAZ}', '';
+
+runlint 'implicit-read', '/foo/', <<'RESULT';
+Implicit match on $_ at -e line 1
+RESULT
+
+runlint 'implicit-read', 'grep /foo/, ()', '';
+
+runlint 'implicit-read', 'grep { /foo/ } ()', '';
+
+runlint 'implicit-write', 's/foo/bar/', <<'RESULT';
+Implicit substitution on $_ at -e line 1
+RESULT
+
+runlint 'implicit-read', 'for ( @ARGV ) { 1 }',
+ <<'RESULT', 'implicit-read in foreach';
+Implicit use of $_ in foreach at -e line 1
+RESULT
+
+runlint 'implicit-read', '1 for @ARGV', '', 'implicit-read in foreach';
+
+runlint 'dollar-underscore', '$_ = 1', <<'RESULT';
+Use of $_ at -e line 1
+RESULT
+
+runlint 'dollar-underscore', 'sub foo {}; foo( $_ ) for @A', '';
+runlint 'dollar-underscore', 'sub foo {}; map { foo( $_ ) } @A', '';
+runlint 'dollar-underscore', 'sub foo {}; grep { foo( $_ ) } @A', '';
+
+runlint 'dollar-underscore', 'print',
+ <<'RESULT', 'dollar-underscore in print';
+Use of $_ at -e line 1
+RESULT
+
+runlint 'private-names', 'sub A::_f{};A::_f()', <<'RESULT';
+Illegal reference to private name '_f' at -e line 1
+RESULT
+
+runlint 'private-names', '$A::_x', <<'RESULT';
+Illegal reference to private name '_x' at -e line 1
+RESULT
+
+runlint 'private-names', 'sub A::_f{};A->_f()', <<'RESULT',
+Illegal reference to private method name '_f' at -e line 1
+RESULT
+ 'private-names (method)';
+
+runlint 'undefined-subs', 'foo()', <<'RESULT';
+Nonexistant subroutine 'foo' called at -e line 1
+RESULT
+
+runlint 'undefined-subs', 'foo();sub foo;', <<'RESULT';
+Undefined subroutine 'foo' called at -e line 1
+RESULT
+
+runlint 'regexp-variables', 'print $&', <<'RESULT';
+Use of regexp variable $& at -e line 1
+RESULT
+
+runlint 'regexp-variables', 's/./$&/', <<'RESULT';
+Use of regexp variable $& at -e line 1
+RESULT
+
+runlint 'bare-subs', 'sub bare(){1};$x=bare', '';
+
+runlint 'bare-subs', 'sub bare(){1}; $x=[bare=>0]; $x=$y{bare}', <<'RESULT';
+Bare sub name 'bare' interpreted as string at -e line 1
+Bare sub name 'bare' interpreted as string at -e line 1
+RESULT
+
+{
+
+ # Check for backwards-compatible plugin support. This was where
+ # preloaded mdoules would register themselves with B::Lint.
+ my $res = runperl(
+ switches => ["-MB::Lint"],
+ prog =>
+ 'BEGIN{B::Lint->register_plugin(X=>[q[x]])};use O(qw[Lint x]);sub X::match{warn qq[X ok.\n]};dummy()',
+ stderr => 1,
+ );
+ like( $res, qr/X ok\./, 'Lint legacy plugin' );
+}
+
+{
+
+ # Check for Module::Plugin support
+ my $res = runperl(
+ switches => [ '-I../ext/B/t/pluglib', '-MO=Lint,none' ],
+ prog => 1,
+ stderr => 1,
+ );
+ like( $res, qr/Module::Pluggable ok\./, 'Lint uses Module::Pluggable' );
+}
Index: trunk/contrib/perl/ext/B/t/o.t
===================================================================
--- trunk/contrib/perl/ext/B/t/o.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/B/t/o.t 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/B/t/o.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/ext/B/t/optree_check.t
===================================================================
--- trunk/contrib/perl/ext/B/t/optree_check.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/B/t/optree_check.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -26,7 +26,12 @@
=cut
-plan tests => 5 + 15 + 12 + 16 * $gOpts{selftest}; # pass()s + $#tests
+plan tests => 11 # REGEX TEST HARNESS SELFTEST
+ + 3 # TEST FATAL ERRS
+ + 11 # TEST -e \$srcCode
+ + 5 # REFTEXT FIXUP TESTS
+ + 5 # CANONICAL B::Concise EXAMPLE
+ + 16 * $gOpts{selftest}; # XXX I don't understand this - DAPM
pass("REGEX TEST HARNESS SELFTEST");
Property changes on: trunk/contrib/perl/ext/B/t/optree_check.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/ext/B/t/optree_concise.t
===================================================================
--- trunk/contrib/perl/ext/B/t/optree_concise.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/B/t/optree_concise.t 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/B/t/optree_concise.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/ext/B/t/optree_constants.t
===================================================================
--- trunk/contrib/perl/ext/B/t/optree_constants.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/B/t/optree_constants.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -16,7 +16,7 @@
use OptreeCheck; # ALSO DOES @ARGV HANDLING !!!!!!
use Config;
-plan tests => 57;
+plan tests => 67;
#################################
@@ -49,7 +49,6 @@
# these are not inlined, at least not per BC::Concise
#myyes => [ $RV_class, ],
#myno => [ $RV_class, ],
- $] > 5.009 ? (
myaref => [ $RV_class, '\\\\' ],
myfl => [ 'NV', myfl ],
myint => [ 'IV', myint ],
@@ -59,13 +58,6 @@
myrex => [ $RV_class, '\\\\' ],
),
myundef => [ 'NULL', ],
- ) : (
- myaref => [ 'PVIV', '' ],
- myfl => [ 'PVNV', myfl ],
- myint => [ 'PVIV', myint ],
- myrex => [ 'PVNV', '' ],
- myundef => [ 'PVIV', ],
- )
};
use constant WEEKDAYS
@@ -110,12 +102,14 @@
3 <1> leavesub[2 refs] K/REFC,1 ->(end)
- <\@> lineseq KP ->3
1 <;> dbstate(main 833 (eval 44):1) v ->2
-2 <\$> const[$want->{$func}[0] $want->{$func}[1]] s* ->3
+2 <\$> const[$want->{$func}[0] $want->{$func}[1]] s* ->3 < 5.017002
+2 <\$> const[$want->{$func}[0] $want->{$func}[1]] s*/FOLD ->3 >=5.017002
EOT_EOT
3 <1> leavesub[2 refs] K/REFC,1 ->(end)
- <\@> lineseq KP ->3
1 <;> dbstate(main 833 (eval 44):1) v ->2
-2 <\$> const($want->{$func}[0] $want->{$func}[1]) s* ->3
+2 <\$> const($want->{$func}[0] $want->{$func}[1]) s* ->3 < 5.017002
+2 <\$> const($want->{$func}[0] $want->{$func}[1]) s*/FOLD ->3 >=5.017002
EONT_EONT
}
@@ -143,7 +137,8 @@
# 2 <;> nextstate(main 2 -e:1) v:>,<,%,{ ->3
# 5 <@> print vK ->6
# 3 <0> pushmark s ->4
-# 4 <$> const[SPECIAL sv_yes] s* ->5
+# 4 <$> const[SPECIAL sv_yes] s* ->5 < 5.017002
+# 4 <$> const[SPECIAL sv_yes] s*/FOLD ->5 >=5.017002
EOT_EOT
# 6 <@> leave[1 ref] vKP/REFC ->(end)
# 1 <0> enter ->2
@@ -150,7 +145,8 @@
# 2 <;> nextstate(main 2 -e:1) v:>,<,%,{ ->3
# 5 <@> print vK ->6
# 3 <0> pushmark s ->4
-# 4 <$> const(SPECIAL sv_yes) s* ->5
+# 4 <$> const(SPECIAL sv_yes) s* ->5 < 5.017002
+# 4 <$> const(SPECIAL sv_yes) s*/FOLD ->5 >=5.017002
EONT_EONT
@@ -167,7 +163,8 @@
# 2 <;> nextstate(main 2 -e:1) v:>,<,%,{ ->3
# 5 <@> print vK ->6
# 3 <0> pushmark s ->4
-# 4 <$> const[SPECIAL sv_no] s* ->5
+# 4 <$> const[SPECIAL sv_no] s* ->5 < 5.017002
+# 4 <$> const[SPECIAL sv_no] s*/FOLD ->5 >=5.017002
EOT_EOT
# 6 <@> leave[1 ref] vKP/REFC ->(end)
# 1 <0> enter ->2
@@ -174,7 +171,8 @@
# 2 <;> nextstate(main 2 -e:1) v:>,<,%,{ ->3
# 5 <@> print vK ->6
# 3 <0> pushmark s ->4
-# 4 <$> const(SPECIAL sv_no) s* ->5
+# 4 <$> const(SPECIAL sv_no) s* ->5 < 5.017002
+# 4 <$> const(SPECIAL sv_no) s*/FOLD ->5 >=5.017002
EONT_EONT
@@ -181,19 +179,15 @@
my ($expect, $expect_nt) = (<<'EOT_EOT', <<'EONT_EONT');
# 3 <1> leavesub[2 refs] K/REFC,1 ->(end)
# - <@> lineseq K ->3
-# 1 <;> nextstate(constant 61 constant.pm:118) v:*,& ->2
+# 1 <;> nextstate(constant 61 constant.pm:118) v:*,&,x*,x&,x$ ->2
# 2 <0> padav[@list:FAKE:m:96] ->3
EOT_EOT
# 3 <1> leavesub[2 refs] K/REFC,1 ->(end)
# - <@> lineseq K ->3
-# 1 <;> nextstate(constant 61 constant.pm:118) v:*,& ->2
+# 1 <;> nextstate(constant 61 constant.pm:118) v:*,&,x*,x&,x$ ->2
# 2 <0> padav[@list:FAKE:m:71] ->3
EONT_EONT
-if($] < 5.009) {
- # 5.8.x doesn't add the m flag to padav
- s/FAKE:m:\d+/FAKE/ foreach ($expect, $expect_nt);
-}
checkOptree ( name => 'constant sub returning list',
code => \&WEEKDAYS,
@@ -211,31 +205,37 @@
# - <@> lineseq KP ->9
# 1 <;> nextstate(main 635 optree_constants.t:163) v:>,<,% ->2
# 8 <@> prtf sK ->9
-# 2 <0> pushmark s ->3
-# 3 <$> const[PV "myint %d mystr %s myfl %f pi %f\n"] s ->4
-# 4 <$> const[IV 42] s* ->5
-# 5 <$> const[PV "hithere"] s* ->6
-# 6 <$> const[NV 1.414213] s* ->7
-# 7 <$> const[NV 3.14159] s* ->8
+# 2 <0> pushmark sM ->3
+# 3 <$> const[PV "myint %d mystr %s myfl %f pi %f\n"] sM ->4 < 5.017002
+# 4 <$> const[IV 42] sM* ->5 < 5.017002
+# 5 <$> const[PV "hithere"] sM* ->6 < 5.017002
+# 6 <$> const[NV 1.414213] sM* ->7 < 5.017002
+# 7 <$> const[NV 3.14159] sM* ->8 < 5.017002
+# 3 <$> const[PV "myint %d mystr %s myfl %f pi %f\n"] sM/FOLD ->4 >= 5.017002
+# 4 <$> const[IV 42] sM*/FOLD ->5 >=5.017002
+# 5 <$> const[PV "hithere"] sM*/FOLD ->6 >=5.017002
+# 6 <$> const[NV 1.414213] sM*/FOLD ->7 >=5.017002
+# 7 <$> const[NV 3.14159] sM*/FOLD ->8 >=5.017002
EOT_EOT
# 9 <1> leavesub[1 ref] K/REFC,1 ->(end)
# - <@> lineseq KP ->9
# 1 <;> nextstate(main 635 optree_constants.t:163) v:>,<,% ->2
# 8 <@> prtf sK ->9
-# 2 <0> pushmark s ->3
-# 3 <$> const(PV "myint %d mystr %s myfl %f pi %f\n") s ->4
-# 4 <$> const(IV 42) s* ->5
-# 5 <$> const(PV "hithere") s* ->6
-# 6 <$> const(NV 1.414213) s* ->7
-# 7 <$> const(NV 3.14159) s* ->8
+# 2 <0> pushmark sM ->3
+# 3 <$> const(PV "myint %d mystr %s myfl %f pi %f\n") sM ->4 < 5.017002
+# 4 <$> const(IV 42) sM* ->5 < 5.017002
+# 5 <$> const(PV "hithere") sM* ->6 < 5.017002
+# 6 <$> const(NV 1.414213) sM* ->7 < 5.017002
+# 7 <$> const(NV 3.14159) sM* ->8 < 5.017002
+# 3 <$> const(PV "myint %d mystr %s myfl %f pi %f\n") sM/FOLD ->4 >= 5.017002
+# 4 <$> const(IV 42) sM*/FOLD ->5 >=5.017002
+# 5 <$> const(PV "hithere") sM*/FOLD ->6 >=5.017002
+# 6 <$> const(NV 1.414213) sM*/FOLD ->7 >=5.017002
+# 7 <$> const(NV 3.14159) sM*/FOLD ->8 >=5.017002
EONT_EONT
-if($] < 5.009) {
- # 5.8.x's use constant has larger types
- foreach ($expect, $expect_nt) {
- s/IV 42/PV$&/;
- s/NV 1.41/PV$&/;
- }
+if($] < 5.015) {
+ s/M(?=\*? ->)//g for $expect, $expect_nt;
}
checkOptree ( name => 'call many in a print statement',
@@ -243,6 +243,167 @@
strip_open_hints => 1,
expect => $expect, expect_nt => $expect_nt);
+# test constant expression folding
+
+checkOptree ( name => 'arithmetic constant folding in print',
+ code => 'print 1+2+3',
+ strip_open_hints => 1,
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+# 5 <1> leavesub[1 ref] K/REFC,1 ->(end)
+# - <@> lineseq KP ->5
+# 1 <;> nextstate(main 937 (eval 53):1) v ->2
+# 4 <@> print sK ->5
+# 2 <0> pushmark s ->3
+# 3 <$> const[IV 6] s ->4 < 5.017002
+# 3 <$> const[IV 6] s/FOLD ->4 >=5.017002
+EOT_EOT
+# 5 <1> leavesub[1 ref] K/REFC,1 ->(end)
+# - <@> lineseq KP ->5
+# 1 <;> nextstate(main 937 (eval 53):1) v ->2
+# 4 <@> print sK ->5
+# 2 <0> pushmark s ->3
+# 3 <$> const(IV 6) s ->4 < 5.017002
+# 3 <$> const(IV 6) s/FOLD ->4 >=5.017002
+EONT_EONT
+
+checkOptree ( name => 'string constant folding in print',
+ code => 'print "foo"."bar"',
+ strip_open_hints => 1,
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+# 5 <1> leavesub[1 ref] K/REFC,1 ->(end)
+# - <@> lineseq KP ->5
+# 1 <;> nextstate(main 942 (eval 55):1) v ->2
+# 4 <@> print sK ->5
+# 2 <0> pushmark s ->3
+# 3 <$> const[PV "foobar"] s ->4 < 5.017002
+# 3 <$> const[PV "foobar"] s/FOLD ->4 >=5.017002
+EOT_EOT
+# 5 <1> leavesub[1 ref] K/REFC,1 ->(end)
+# - <@> lineseq KP ->5
+# 1 <;> nextstate(main 942 (eval 55):1) v ->2
+# 4 <@> print sK ->5
+# 2 <0> pushmark s ->3
+# 3 <$> const(PV "foobar") s ->4 < 5.017002
+# 3 <$> const(PV "foobar") s/FOLD ->4 >=5.017002
+EONT_EONT
+
+checkOptree ( name => 'boolean or folding',
+ code => 'print "foobar" if 1 or 0',
+ strip_open_hints => 1,
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+# 5 <1> leavesub[1 ref] K/REFC,1 ->(end)
+# - <@> lineseq KP ->5
+# 1 <;> nextstate(main 942 (eval 55):1) v ->2
+# 4 <@> print sK ->5
+# 2 <0> pushmark s ->3
+# 3 <$> const[PV "foobar"] s ->4
+EOT_EOT
+# 5 <1> leavesub[1 ref] K/REFC,1 ->(end)
+# - <@> lineseq KP ->5
+# 1 <;> nextstate(main 942 (eval 55):1) v ->2
+# 4 <@> print sK ->5
+# 2 <0> pushmark s ->3
+# 3 <$> const(PV "foobar") s ->4
+EONT_EONT
+
+checkOptree ( name => 'lc*,uc*,gt,lt,ge,le,cmp',
+ code => sub {
+ $s = uc('foo.').ucfirst('bar.').lc('LOW.').lcfirst('LOW');
+ print "a-lt-b" if "a" lt "b";
+ print "b-gt-a" if "b" gt "a";
+ print "a-le-b" if "a" le "b";
+ print "b-ge-a" if "b" ge "a";
+ print "b-cmp-a" if "b" cmp "a";
+ print "a-gt-b" if "a" gt "b"; # should be suppressed
+ },
+ strip_open_hints => 1,
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+# r <1> leavesub[1 ref] K/REFC,1 ->(end)
+# - <@> lineseq KP ->r
+# 1 <;> nextstate(main 916 optree_constants.t:307) v:>,<,%,{ ->2
+# 4 <2> sassign vKS/2 ->5
+# 2 <$> const[PV "FOO.Bar.low.lOW"] s ->3 < 5.017002
+# 2 <$> const[PV "FOO.Bar.low.lOW"] s/FOLD ->3 >=5.017002
+# - <1> ex-rv2sv sKRM*/1 ->4
+# 3 <#> gvsv[*s] s ->4
+# 5 <;> nextstate(main 916 optree_constants.t:308) v:>,<,%,{ ->6
+# 8 <@> print vK ->9
+# 6 <0> pushmark s ->7
+# 7 <$> const[PV "a-lt-b"] s ->8
+# 9 <;> nextstate(main 916 optree_constants.t:309) v:>,<,%,{ ->a
+# c <@> print vK ->d
+# a <0> pushmark s ->b
+# b <$> const[PV "b-gt-a"] s ->c
+# d <;> nextstate(main 916 optree_constants.t:310) v:>,<,%,{ ->e
+# g <@> print vK ->h
+# e <0> pushmark s ->f
+# f <$> const[PV "a-le-b"] s ->g
+# h <;> nextstate(main 916 optree_constants.t:311) v:>,<,%,{ ->i
+# k <@> print vK ->l
+# i <0> pushmark s ->j
+# j <$> const[PV "b-ge-a"] s ->k
+# l <;> nextstate(main 916 optree_constants.t:312) v:>,<,%,{ ->m
+# o <@> print vK ->p
+# m <0> pushmark s ->n
+# n <$> const[PV "b-cmp-a"] s ->o
+# p <;> nextstate(main 916 optree_constants.t:313) v:>,<,%,{ ->q
+# q <$> const[PVNV 0] s/SHORT ->r < 5.017002
+# q <$> const[PVNV 0] s/FOLD,SHORT ->r >=5.017002
+EOT_EOT
+# r <1> leavesub[1 ref] K/REFC,1 ->(end)
+# - <@> lineseq KP ->r
+# 1 <;> nextstate(main 916 optree_constants.t:307) v:>,<,%,{ ->2
+# 4 <2> sassign vKS/2 ->5
+# 2 <$> const(PV "FOO.Bar.low.lOW") s ->3 < 5.017002
+# 2 <$> const(PV "FOO.Bar.low.lOW") s/FOLD ->3 >=5.017002
+# - <1> ex-rv2sv sKRM*/1 ->4
+# 3 <$> gvsv(*s) s ->4
+# 5 <;> nextstate(main 916 optree_constants.t:308) v:>,<,%,{ ->6
+# 8 <@> print vK ->9
+# 6 <0> pushmark s ->7
+# 7 <$> const(PV "a-lt-b") s ->8
+# 9 <;> nextstate(main 916 optree_constants.t:309) v:>,<,%,{ ->a
+# c <@> print vK ->d
+# a <0> pushmark s ->b
+# b <$> const(PV "b-gt-a") s ->c
+# d <;> nextstate(main 916 optree_constants.t:310) v:>,<,%,{ ->e
+# g <@> print vK ->h
+# e <0> pushmark s ->f
+# f <$> const(PV "a-le-b") s ->g
+# h <;> nextstate(main 916 optree_constants.t:311) v:>,<,%,{ ->i
+# k <@> print vK ->l
+# i <0> pushmark s ->j
+# j <$> const(PV "b-ge-a") s ->k
+# l <;> nextstate(main 916 optree_constants.t:312) v:>,<,%,{ ->m
+# o <@> print vK ->p
+# m <0> pushmark s ->n
+# n <$> const(PV "b-cmp-a") s ->o
+# p <;> nextstate(main 916 optree_constants.t:313) v:>,<,%,{ ->q
+# q <$> const(SPECIAL sv_no) s/SHORT ->r < 5.017002
+# q <$> const(SPECIAL sv_no) s/FOLD,SHORT ->r >=5.017002
+EONT_EONT
+
+checkOptree ( name => 'mixed constant folding, with explicit braces',
+ code => 'print "foo"."bar".(2+3)',
+ strip_open_hints => 1,
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+# 5 <1> leavesub[1 ref] K/REFC,1 ->(end)
+# - <@> lineseq KP ->5
+# 1 <;> nextstate(main 977 (eval 28):1) v ->2
+# 4 <@> print sK ->5
+# 2 <0> pushmark s ->3
+# 3 <$> const[PV "foobar5"] s ->4 < 5.017002
+# 3 <$> const[PV "foobar5"] s/FOLD ->4 >=5.017002
+EOT_EOT
+# 5 <1> leavesub[1 ref] K/REFC,1 ->(end)
+# - <@> lineseq KP ->5
+# 1 <;> nextstate(main 977 (eval 28):1) v ->2
+# 4 <@> print sK ->5
+# 2 <0> pushmark s ->3
+# 3 <$> const(PV "foobar5") s ->4 < 5.017002
+# 3 <$> const(PV "foobar5") s/FOLD ->4 >=5.017002
+EONT_EONT
+
__END__
=head NB
Property changes on: trunk/contrib/perl/ext/B/t/optree_constants.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/ext/B/t/optree_misc.t
===================================================================
--- trunk/contrib/perl/ext/B/t/optree_misc.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/B/t/optree_misc.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -10,17 +10,19 @@
}
use OptreeCheck;
use Config;
-plan tests => 6;
+plan tests => 18;
SKIP: {
skip "no perlio in this build", 4 unless $Config::Config{useperlio};
-# The regression this is testing is that the first aelemfast, derived
+# The regression this was testing is that the first aelemfast, derived
# from a lexical array, is supposed to be a BASEOP "<0>", while the
# second, from a global, is an SVOP "<$>" or a PADOP "<#>" depending
# on threading. In buggy versions, both showed up as SVOPs/PADOPs. See
# B.xs:cc_opclass() for the relevant code.
+# All this is much simpler, now that aelemfast_lex has been broken out from
+# aelemfast
checkOptree ( name => 'OP_AELEMFAST opclass',
code => sub { my @x; our @y; $x[0] + $y[0]},
strip_open_hints => 1,
@@ -35,7 +37,7 @@
# 6 <;> nextstate(main 636 optree_misc.t:25) v:>,<,%,{ ->7
# 9 <2> add[t6] sK/2 ->a
# - <1> ex-aelem sK/2 ->8
-# 7 <0> aelemfast[@x:634,636] sR* ->8
+# 7 <0> aelemfast_lex[@x:634,636] sR ->8
# - <0> ex-const s ->-
# - <1> ex-aelem sK/2 ->9
# - <1> ex-rv2av sKR/1 ->-
@@ -52,7 +54,7 @@
# 6 <;> nextstate(main 636 optree_misc.t:27) v:>,<,%,{ ->7
# 9 <2> add[t4] sK/2 ->a
# - <1> ex-aelem sK/2 ->8
-# 7 <0> aelemfast[@x:634,636] sR* ->8
+# 7 <0> aelemfast_lex[@x:634,636] sR ->8
# - <0> ex-const s ->-
# - <1> ex-aelem sK/2 ->9
# - <1> ex-rv2av sKR/1 ->-
@@ -63,7 +65,8 @@
checkOptree ( name => 'PMOP children',
code => sub { $foo =~ s/(a)/$1/ },
strip_open_hints => 1,
- expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+ ( $] < 5.017002
+ ? (expect => <<'EOT_EOT16', expect_nt => <<'EONT_EONT16')
# 6 <1> leavesub[1 ref] K/REFC,1 ->(end)
# - <@> lineseq KP ->6
# 1 <;> nextstate(main 1 -e:1) v:>,<,%,{ ->2
@@ -73,7 +76,7 @@
# 5 <|> substcont(other->3) sK/1 ->(end)
# - <1> ex-rv2sv sK/1 ->5
# 4 <#> gvsv[*1] s ->5
-EOT_EOT
+EOT_EOT16
# 6 <1> leavesub[1 ref] K/REFC,1 ->(end)
# - <@> lineseq KP ->6
# 1 <;> nextstate(main 1 -e:1) v:>,<,%,{ ->2
@@ -83,6 +86,26 @@
# 5 <|> substcont(other->3) sK/1 ->(end)
# - <1> ex-rv2sv sK/1 ->5
# 4 <$> gvsv(*1) s ->5
+EONT_EONT16
+
+ : (expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT')));
+# 5 <1> leavesub[1 ref] K/REFC,1 ->(end)
+# - <@> lineseq KP ->5
+# 1 <;> nextstate(main 1 -e:1) v:>,<,%,{ ->2
+# 4 </> subst(/"(a)"/) KS ->5
+# - <1> ex-rv2sv sKRM/1 ->3
+# 2 <#> gvsv[*foo] s ->3
+# - <1> ex-rv2sv sK/1 ->4
+# 3 <#> gvsv[*1] s ->4
+EOT_EOT
+# 5 <1> leavesub[1 ref] K/REFC,1 ->(end)
+# - <@> lineseq KP ->5
+# 1 <;> nextstate(main 1 -e:1) v:>,<,%,{ ->2
+# 4 </> subst(/"(a)"/) KS ->5
+# - <1> ex-rv2sv sKRM/1 ->3
+# 2 <$> gvsv(*foo) s ->3
+# - <1> ex-rv2sv sK/1 ->4
+# 3 <$> gvsv(*1) s ->4
EONT_EONT
} #skip
@@ -95,7 +118,7 @@
# 5 <@> index[t2] sK/2 ->6
# - <0> ex-pushmark s ->3
# 3 <$> const[PV "foo"] s ->4
-# 4 <$> const[GV "foo"] s ->5
+# 4 <$> const[PVMG "foo"] s ->5
# - <1> ex-rv2sv sKRM*/1 ->7
# 6 <#> gvsv[*_] s ->7
EOT_EOT
@@ -107,17 +130,321 @@
# 5 <@> index[t1] sK/2 ->6
# - <0> ex-pushmark s ->3
# 3 <$> const(PV "foo") s ->4
-# 4 <$> const(GV "foo") s ->5
+# 4 <$> const(PVMG "foo") s ->5
# - <1> ex-rv2sv sKRM*/1 ->7
# 6 <$> gvsv(*_) s ->7
EONT_EONT
-if ($] < 5.009) {
- $t =~ s/GV /BM /;
- $nt =~ s/GV /BM /;
-}
-
checkOptree ( name => 'index and PVBM',
prog => '$_ = index q(foo), q(foo)',
strip_open_hints => 1,
expect => $t, expect_nt => $nt);
+
+my $tmpfile = tempfile();
+open my $fh, '>', $tmpfile or die "Cannot open $tmpfile: $!";
+print $fh "no warnings;format =\n@<<<\n\$a\n@>>>\n\@b\n.";
+close $fh;
+
+checkOptree ( name => 'formats',
+ bcopts => 'STDOUT',
+ progfile => $tmpfile,
+ strip_open_hints => 1,
+ skip => ($] < 5.017003),
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+# main::STDOUT (FORMAT):
+# c <1> leavewrite[1 ref] K/REFC,1 ->(end)
+# - <@> lineseq KP ->c
+# 1 <;> nextstate(main 1 -:4) v:>,<,% ->2
+# 5 <@> formline vK/2 ->6
+# 2 <0> pushmark s ->3
+# 3 <$> const[PV "@<<<\n"] s ->4
+# - <@> lineseq lK ->5
+# - <0> ex-nextstate v ->4
+# - <1> ex-rv2sv sK/1 ->-
+# 4 <#> gvsv[*a] s ->5
+# 6 <;> nextstate(main 1 -:6) v:>,<,% ->7
+# b <@> formline sK/2 ->c
+# 7 <0> pushmark s ->8
+# 8 <$> const[PV "@>>>\n"] s ->9
+# - <@> lineseq lK ->b
+# - <0> ex-nextstate v ->9
+# a <1> rv2av[t3] lK/1 ->b
+# 9 <#> gv[*b] s ->a
+EOT_EOT
+# main::STDOUT (FORMAT):
+# c <1> leavewrite[1 ref] K/REFC,1 ->(end)
+# - <@> lineseq KP ->c
+# 1 <;> nextstate(main 1 -:4) v:>,<,% ->2
+# 5 <@> formline vK/2 ->6
+# 2 <0> pushmark s ->3
+# 3 <$> const(PV "@<<<\n") s ->4
+# - <@> lineseq lK ->5
+# - <0> ex-nextstate v ->4
+# - <1> ex-rv2sv sK/1 ->-
+# 4 <$> gvsv(*a) s ->5
+# 6 <;> nextstate(main 1 -:6) v:>,<,% ->7
+# b <@> formline sK/2 ->c
+# 7 <0> pushmark s ->8
+# 8 <$> const(PV "@>>>\n") s ->9
+# - <@> lineseq lK ->b
+# - <0> ex-nextstate v ->9
+# a <1> rv2av[t3] lK/1 ->b
+# 9 <$> gv(*b) s ->a
+EONT_EONT
+
+checkOptree ( name => 'padrange',
+ code => sub { my ($x,$y); @a = ($x,$y); ($x,$y) = @a },
+ strip_open_hints => 1,
+ skip => ($] < 5.017006),
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+# f <1> leavesub[1 ref] K/REFC,1 ->(end)
+# - <@> lineseq KP ->f
+# 1 <;> nextstate(main 1 -e:1) v:>,<,% ->2
+# - <@> list vKP ->3
+# 2 <0> padrange[$x:1,2; $y:1,2] vM/LVINTRO,2 ->3
+# - <0> padsv[$x:1,2] vM/LVINTRO ->-
+# - <0> padsv[$y:1,2] vM/LVINTRO ->-
+# 3 <;> nextstate(main 2 -e:1) v:>,<,% ->4
+# 8 <2> aassign[t4] vKS ->9
+# - <1> ex-list lKP ->5
+# 4 <0> padrange[$x:1,2; $y:1,2] l/2 ->5
+# - <0> padsv[$x:1,2] l ->-
+# - <0> padsv[$y:1,2] l ->-
+# - <1> ex-list lK ->8
+# 5 <0> pushmark s ->6
+# 7 <1> rv2av[t3] lKRM*/1 ->8
+# 6 <#> gv[*a] s ->7
+# 9 <;> nextstate(main 2 -e:1) v:>,<,%,{ ->a
+# e <2> aassign[t6] KS ->f
+# - <1> ex-list lK ->d
+# a <0> pushmark s ->b
+# c <1> rv2av[t5] lK/1 ->d
+# b <#> gv[*a] s ->c
+# - <1> ex-list lKPRM* ->e
+# d <0> padrange[$x:1,2; $y:1,2] lRM/2 ->e
+# - <0> padsv[$x:1,2] lRM* ->-
+# - <0> padsv[$y:1,2] lRM* ->-
+EOT_EOT
+# f <1> leavesub[1 ref] K/REFC,1 ->(end)
+# - <@> lineseq KP ->f
+# 1 <;> nextstate(main 1 -e:1) v:>,<,% ->2
+# - <@> list vKP ->3
+# 2 <0> padrange[$x:1,2; $y:1,2] vM/LVINTRO,2 ->3
+# - <0> padsv[$x:1,2] vM/LVINTRO ->-
+# - <0> padsv[$y:1,2] vM/LVINTRO ->-
+# 3 <;> nextstate(main 2 -e:1) v:>,<,% ->4
+# 8 <2> aassign[t4] vKS ->9
+# - <1> ex-list lKP ->5
+# 4 <0> padrange[$x:1,2; $y:1,2] l/2 ->5
+# - <0> padsv[$x:1,2] l ->-
+# - <0> padsv[$y:1,2] l ->-
+# - <1> ex-list lK ->8
+# 5 <0> pushmark s ->6
+# 7 <1> rv2av[t3] lKRM*/1 ->8
+# 6 <$> gv(*a) s ->7
+# 9 <;> nextstate(main 2 -e:1) v:>,<,%,{ ->a
+# e <2> aassign[t6] KS ->f
+# - <1> ex-list lK ->d
+# a <0> pushmark s ->b
+# c <1> rv2av[t5] lK/1 ->d
+# b <$> gv(*a) s ->c
+# - <1> ex-list lKPRM* ->e
+# d <0> padrange[$x:1,2; $y:1,2] lRM/2 ->e
+# - <0> padsv[$x:1,2] lRM* ->-
+# - <0> padsv[$y:1,2] lRM* ->-
+EONT_EONT
+
+checkOptree ( name => 'padrange and @_',
+ code => sub { my ($a,$b) = @_;
+ my ($c,$d) = @X::_;
+ package Y;
+ my ($e,$f) = @_;
+ },
+ strip_open_hints => 1,
+ skip => ($] < 5.017006),
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+# d <1> leavesub[1 ref] K/REFC,1 ->(end)
+# - <@> lineseq KP ->d
+# 1 <;> nextstate(main 1 p3:1) v:>,<,% ->2
+# 3 <2> aassign[t5] vKS ->4
+# - <1> ex-list lK ->-
+# 2 <0> padrange[$a:1,4; $b:1,4] l*/LVINTRO,2 ->3
+# - <1> rv2av[t4] lK/1 ->-
+# - <#> gv[*_] s ->-
+# - <1> ex-list lKPRM* ->3
+# - <0> pushmark sRM*/LVINTRO ->-
+# - <0> padsv[$a:1,4] lRM*/LVINTRO ->-
+# - <0> padsv[$b:1,4] lRM*/LVINTRO ->-
+# 4 <;> nextstate(main 2 p3:2) v:>,<,% ->5
+# 9 <2> aassign[t10] vKS ->a
+# - <1> ex-list lK ->8
+# 5 <0> pushmark s ->6
+# 7 <1> rv2av[t9] lK/1 ->8
+# 6 <#> gv[*X::_] s ->7
+# - <1> ex-list lKPRM* ->9
+# 8 <0> padrange[$c:2,4; $d:2,4] lRM/LVINTRO,2 ->9
+# - <0> padsv[$c:2,4] lRM*/LVINTRO ->-
+# - <0> padsv[$d:2,4] lRM*/LVINTRO ->-
+# a <;> nextstate(Y 3 p3:4) v:>,<,%,{ ->b
+# c <2> aassign[t15] KS ->d
+# - <1> ex-list lK ->-
+# b <0> padrange[$e:3,4; $f:3,4] l*/LVINTRO,2 ->c
+# - <1> rv2av[t14] lK/1 ->-
+# - <#> gv[*_] s ->-
+# - <1> ex-list lKPRM* ->c
+# - <0> pushmark sRM*/LVINTRO ->-
+# - <0> padsv[$e:3,4] lRM*/LVINTRO ->-
+# - <0> padsv[$f:3,4] lRM*/LVINTRO ->-
+EOT_EOT
+# d <1> leavesub[1 ref] K/REFC,1 ->(end)
+# - <@> lineseq KP ->d
+# 1 <;> nextstate(main 1 p3:1) v:>,<,% ->2
+# 3 <2> aassign[t5] vKS ->4
+# - <1> ex-list lK ->-
+# 2 <0> padrange[$a:1,4; $b:1,4] l*/LVINTRO,2 ->3
+# - <1> rv2av[t4] lK/1 ->-
+# - <$> gv(*_) s ->-
+# - <1> ex-list lKPRM* ->3
+# - <0> pushmark sRM*/LVINTRO ->-
+# - <0> padsv[$a:1,4] lRM*/LVINTRO ->-
+# - <0> padsv[$b:1,4] lRM*/LVINTRO ->-
+# 4 <;> nextstate(main 2 p3:2) v:>,<,% ->5
+# 9 <2> aassign[t10] vKS ->a
+# - <1> ex-list lK ->8
+# 5 <0> pushmark s ->6
+# 7 <1> rv2av[t9] lK/1 ->8
+# 6 <$> gv(*X::_) s ->7
+# - <1> ex-list lKPRM* ->9
+# 8 <0> padrange[$c:2,4; $d:2,4] lRM/LVINTRO,2 ->9
+# - <0> padsv[$c:2,4] lRM*/LVINTRO ->-
+# - <0> padsv[$d:2,4] lRM*/LVINTRO ->-
+# a <;> nextstate(Y 3 p3:4) v:>,<,%,{ ->b
+# c <2> aassign[t15] KS ->d
+# - <1> ex-list lK ->-
+# b <0> padrange[$e:3,4; $f:3,4] l*/LVINTRO,2 ->c
+# - <1> rv2av[t14] lK/1 ->-
+# - <$> gv(*_) s ->-
+# - <1> ex-list lKPRM* ->c
+# - <0> pushmark sRM*/LVINTRO ->-
+# - <0> padsv[$e:3,4] lRM*/LVINTRO ->-
+# - <0> padsv[$f:3,4] lRM*/LVINTRO ->-
+EONT_EONT
+
+checkOptree ( name => 'consolidate padranges',
+ code => sub { my ($a,$b); my ($c,$d); 1 },
+ strip_open_hints => 1,
+ skip => ($] < 5.017006),
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+# 5 <1> leavesub[1 ref] K/REFC,1 ->(end)
+# - <@> lineseq KP ->5
+# 1 <;> nextstate(main 900 optree_misc.t:334) v:>,<,% ->2
+# - <@> list vKP ->-
+# 2 <0> padrange[$a:900,902; $b:900,902; $c:901,902; $d:901,902] vM/LVINTRO,4 ->3
+# - <0> padsv[$a:900,902] vM/LVINTRO ->-
+# - <0> padsv[$b:900,902] vM/LVINTRO ->-
+# - <;> nextstate(main 901 optree_misc.t:334) v:>,<,% ->-
+# - <@> list vKP ->3
+# - <0> pushmark vM/LVINTRO ->-
+# - <0> padsv[$c:901,902] vM/LVINTRO ->-
+# - <0> padsv[$d:901,902] vM/LVINTRO ->-
+# 3 <;> nextstate(main 902 optree_misc.t:334) v:>,<,%,{ ->4
+# 4 <$> const[IV 1] s ->5
+EOT_EOT
+# 5 <1> leavesub[1 ref] K/REFC,1 ->(end)
+# - <@> lineseq KP ->5
+# 1 <;> nextstate(main 900 optree_misc.t:334) v:>,<,% ->2
+# - <@> list vKP ->-
+# 2 <0> padrange[$a:900,902; $b:900,902; $c:901,902; $d:901,902] vM/LVINTRO,4 ->3
+# - <0> padsv[$a:900,902] vM/LVINTRO ->-
+# - <0> padsv[$b:900,902] vM/LVINTRO ->-
+# - <;> nextstate(main 901 optree_misc.t:334) v:>,<,% ->-
+# - <@> list vKP ->3
+# - <0> pushmark vM/LVINTRO ->-
+# - <0> padsv[$c:901,902] vM/LVINTRO ->-
+# - <0> padsv[$d:901,902] vM/LVINTRO ->-
+# 3 <;> nextstate(main 902 optree_misc.t:334) v:>,<,%,{ ->4
+# 4 <$> const(IV 1) s ->5
+EONT_EONT
+
+
+checkOptree ( name => 'consolidate padranges and singletons',
+ code => sub { my ($a,$b); my $c; my ($d,$e);
+ my @f; my $g; my ($h,$i); my %j; 1 },
+ strip_open_hints => 1,
+ skip => ($] < 5.017006),
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+# 5 <1> leavesub[1 ref] K/REFC,1 ->(end)
+# - <@> lineseq KP ->5
+# 1 <;> nextstate(main 903 optree_misc.t:371) v:>,<,% ->2
+# - <@> list vKP ->-
+# 2 <0> padrange[$a:903,910; $b:903,910; $c:904,910; $d:905,910; $e:905,910; @f:906,910; $g:907,910; $h:908,910; $i:908,910; %j:909,910] vM/LVINTRO,10 ->3
+# - <0> padsv[$a:903,910] vM/LVINTRO ->-
+# - <0> padsv[$b:903,910] vM/LVINTRO ->-
+# - <;> nextstate(main 904 optree_misc.t:371) v:>,<,% ->-
+# - <0> padsv[$c:904,910] vM/LVINTRO ->-
+# - <;> nextstate(main 905 optree_misc.t:371) v:>,<,%,{ ->-
+# - <@> list vKP ->-
+# - <0> pushmark vM/LVINTRO ->-
+# - <0> padsv[$d:905,910] vM/LVINTRO ->-
+# - <0> padsv[$e:905,910] vM/LVINTRO ->-
+# - <;> nextstate(main 906 optree_misc.t:372) v:>,<,%,{ ->-
+# - <0> padav[@f:906,910] vM/LVINTRO ->-
+# - <;> nextstate(main 907 optree_misc.t:372) v:>,<,%,{ ->-
+# - <0> padsv[$g:907,910] vM/LVINTRO ->-
+# - <;> nextstate(main 908 optree_misc.t:372) v:>,<,%,{ ->-
+# - <@> list vKP ->-
+# - <0> pushmark vM/LVINTRO ->-
+# - <0> padsv[$h:908,910] vM/LVINTRO ->-
+# - <0> padsv[$i:908,910] vM/LVINTRO ->-
+# - <;> nextstate(main 909 optree_misc.t:372) v:>,<,%,{ ->-
+# - <0> padhv[%j:909,910] vM/LVINTRO ->3
+# 3 <;> nextstate(main 910 optree_misc.t:372) v:>,<,%,{ ->4
+# 4 <$> const[IV 1] s ->5
+EOT_EOT
+# 5 <1> leavesub[1 ref] K/REFC,1 ->(end)
+# - <@> lineseq KP ->5
+# 1 <;> nextstate(main 903 optree_misc.t:371) v:>,<,% ->2
+# - <@> list vKP ->-
+# 2 <0> padrange[$a:903,910; $b:903,910; $c:904,910; $d:905,910; $e:905,910; @f:906,910; $g:907,910; $h:908,910; $i:908,910; %j:909,910] vM/LVINTRO,10 ->3
+# - <0> padsv[$a:903,910] vM/LVINTRO ->-
+# - <0> padsv[$b:903,910] vM/LVINTRO ->-
+# - <;> nextstate(main 904 optree_misc.t:371) v:>,<,% ->-
+# - <0> padsv[$c:904,910] vM/LVINTRO ->-
+# - <;> nextstate(main 905 optree_misc.t:371) v:>,<,%,{ ->-
+# - <@> list vKP ->-
+# - <0> pushmark vM/LVINTRO ->-
+# - <0> padsv[$d:905,910] vM/LVINTRO ->-
+# - <0> padsv[$e:905,910] vM/LVINTRO ->-
+# - <;> nextstate(main 906 optree_misc.t:372) v:>,<,%,{ ->-
+# - <0> padav[@f:906,910] vM/LVINTRO ->-
+# - <;> nextstate(main 907 optree_misc.t:372) v:>,<,%,{ ->-
+# - <0> padsv[$g:907,910] vM/LVINTRO ->-
+# - <;> nextstate(main 908 optree_misc.t:372) v:>,<,%,{ ->-
+# - <@> list vKP ->-
+# - <0> pushmark vM/LVINTRO ->-
+# - <0> padsv[$h:908,910] vM/LVINTRO ->-
+# - <0> padsv[$i:908,910] vM/LVINTRO ->-
+# - <;> nextstate(main 909 optree_misc.t:372) v:>,<,%,{ ->-
+# - <0> padhv[%j:909,910] vM/LVINTRO ->3
+# 3 <;> nextstate(main 910 optree_misc.t:372) v:>,<,%,{ ->4
+# 4 <$> const(IV 1) s ->5
+EONT_EONT
+
+
+checkOptree ( name => 'm?x?',
+ code => sub { m?x?; },
+ strip_open_hints => 1,
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+# 3 <1> leavesub[1 ref] K/REFC,1 ->(end)
+# - <@> lineseq KP ->3
+# 1 <;> nextstate(main 914 optree_misc.t:434) v:>,<,%,{ ->2
+# 2 </> match(/"x"/) /RTIME ->3
+EOT_EOT
+# 3 <1> leavesub[1 ref] K/REFC,1 ->(end)
+# - <@> lineseq KP ->3
+# 1 <;> nextstate(main 914 optree_misc.t:434) v:>,<,%,{ ->2
+# 2 </> match(/"x"/) /RTIME ->3
+EONT_EONT
+
+
+unlink $tmpfile;
Property changes on: trunk/contrib/perl/ext/B/t/optree_misc.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/ext/B/t/optree_samples.t
===================================================================
--- trunk/contrib/perl/ext/B/t/optree_samples.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/B/t/optree_samples.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -469,7 +469,8 @@
# 3 <0> pushmark s
# 4 <#> gv[*a] s
# 5 <1> rv2av[t8] lKM/1
-# 6 <@> mapstart lK*
+# 6 <@> mapstart lK* < 5.017002
+# 6 <@> mapstart lK >=5.017002
# 7 <|> mapwhile(other->8)[t9] lK
# 8 <0> enter l
# 9 <;> nextstate(main 500 (eval 22):1) v:{
@@ -477,7 +478,7 @@
# b <0> pushmark s
# c <#> gvsv[*_] s
# d <#> gv[*getkey] s/EARLYCV
-# e <1> entersub[t5] lKS/TARG,1
+# e <1> entersub[t5] lKS/TARG
# f <#> gvsv[*_] s
# g <@> list lK
# h <@> leave lKP
@@ -493,7 +494,8 @@
# 3 <0> pushmark s
# 4 <$> gv(*a) s
# 5 <1> rv2av[t3] lKM/1
-# 6 <@> mapstart lK*
+# 6 <@> mapstart lK* < 5.017002
+# 6 <@> mapstart lK >=5.017002
# 7 <|> mapwhile(other->8)[t4] lK
# 8 <0> enter l
# 9 <;> nextstate(main 500 (eval 22):1) v:{
@@ -501,7 +503,7 @@
# b <0> pushmark s
# c <$> gvsv(*_) s
# d <$> gv(*getkey) s/EARLYCV
-# e <1> entersub[t2] lKS/TARG,1
+# e <1> entersub[t2] lKS/TARG
# f <$> gvsv(*_) s
# g <@> list lK
# h <@> leave lKP
@@ -539,7 +541,7 @@
# i <0> pushmark s
# j <#> gvsv[*_] s
# k <#> gv[*getkey] s/EARLYCV
-# l <1> entersub[t10] sKS/TARG,1
+# l <1> entersub[t10] sKS/TARG
# m <2> helem sKRM*/2
# n <2> sassign vKS/2
# o <0> unstack s
@@ -569,7 +571,7 @@
# i <0> pushmark s
# j <$> gvsv(*_) s
# k <$> gv(*getkey) s/EARLYCV
-# l <1> entersub[t4] sKS/TARG,1
+# l <1> entersub[t4] sKS/TARG
# m <2> helem sKRM*/2
# n <2> sassign vKS/2
# o <0> unstack s
@@ -617,7 +619,8 @@
# 1 <0> enter
# 2 <;> nextstate(main 71 -e:1) v:>,<,%,{
# 3 <0> pushmark s
-# 4 <$> const[PV "junk"] s*
+# 4 <$> const[PV "junk"] s* < 5.017002
+# 4 <$> const[PV "junk"] s*/FOLD >=5.017002
# 5 <@> print vK
# 6 <@> leave[1 ref] vKP/REFC
EOT_EOT
@@ -624,7 +627,8 @@
# 1 <0> enter
# 2 <;> nextstate(main 71 -e:1) v:>,<,%,{
# 3 <0> pushmark s
-# 4 <$> const(PV "junk") s*
+# 4 <$> const(PV "junk") s* < 5.017002
+# 4 <$> const(PV "junk") s*/FOLD >=5.017002
# 5 <@> print vK
# 6 <@> leave[1 ref] vKP/REFC
EONT_EONT
Property changes on: trunk/contrib/perl/ext/B/t/optree_samples.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/ext/B/t/optree_sort.t
===================================================================
--- trunk/contrib/perl/ext/B/t/optree_sort.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/B/t/optree_sort.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -196,10 +196,9 @@
5 <0> pushmark s
6 <0> padav[@a:-437,-436] l
7 <@> sort lK
-8 <0> pushmark s
-9 <0> padav[@a:-437,-436] lRM*
-a <2> aassign[t2] KS/COMMON
-b <1> leavesub[1 ref] K/REFC,1
+8 <0> padrange[@a:-437,-436] l/1
+9 <2> aassign[t2] KS/COMMON
+a <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1 <;> nextstate(main 427 optree_sort.t:172) v:>,<,%
# 2 <0> padav[@a:427,428] vM/LVINTRO
@@ -208,10 +207,9 @@
# 5 <0> pushmark s
# 6 <0> padav[@a:427,428] l
# 7 <@> sort lK
-# 8 <0> pushmark s
-# 9 <0> padav[@a:427,428] lRM*
-# a <2> aassign[t2] KS/COMMON
-# b <1> leavesub[1 ref] K/REFC,1
+# 8 <0> padrange[@a:427,428] l/1
+# 9 <2> aassign[t2] KS/COMMON
+# a <1> leavesub[1 ref] K/REFC,1
EONT_EONT
checkOptree ( name => 'my @a; @a = sort @a',
@@ -224,10 +222,9 @@
3 <0> padav[@a:1,2] vM/LVINTRO
4 <;> nextstate(main 2 -e:1) v:>,<,%,{
5 <0> pushmark s
-6 <0> pushmark s
-7 <0> padav[@a:1,2] lRM*
-8 <@> sort lK/INPLACE
-9 <@> leave[1 ref] vKP/REFC
+6 <0> padrange[@a:1,2] l/1
+7 <@> sort lK/INPLACE
+8 <@> leave[1 ref] vKP/REFC
EOT_EOT
# 1 <0> enter
# 2 <;> nextstate(main 1 -e:1) v:>,<,%,{
@@ -234,10 +231,9 @@
# 3 <0> padav[@a:1,2] vM/LVINTRO
# 4 <;> nextstate(main 2 -e:1) v:>,<,%,{
# 5 <0> pushmark s
-# 6 <0> pushmark s
-# 7 <0> padav[@a:1,2] lRM*
-# 8 <@> sort lK/INPLACE
-# 9 <@> leave[1 ref] vKP/REFC
+# 6 <0> padrange[@a:1,2] l/1
+# 7 <@> sort lK/INPLACE
+# 8 <@> leave[1 ref] vKP/REFC
EONT_EONT
checkOptree ( name => 'sub {my @a; @a = sort @a; push @a, 1}',
@@ -250,29 +246,25 @@
2 <0> padav[@a:-437,-436] vM/LVINTRO
3 <;> nextstate(main -436 optree.t:325) v:>,<,%
4 <0> pushmark s
-5 <0> pushmark s
-6 <0> padav[@a:-437,-436] lRM*
-7 <@> sort lK/INPLACE
-8 <;> nextstate(main -436 optree.t:325) v:>,<,%,{
-9 <0> pushmark s
-a <0> padav[@a:-437,-436] lRM
-b <$> const[IV 1] s
-c <@> push[t3] sK/2
-d <1> leavesub[1 ref] K/REFC,1
+5 <0> padrange[@a:-437,-436] l/1
+6 <@> sort lK/INPLACE
+7 <;> nextstate(main -436 optree.t:325) v:>,<,%,{
+8 <0> padrange[@a:-437,-436] l/1
+9 <$> const[IV 1] s
+a <@> push[t3] sK/2
+b <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1 <;> nextstate(main 429 optree_sort.t:219) v:>,<,%
# 2 <0> padav[@a:429,430] vM/LVINTRO
# 3 <;> nextstate(main 430 optree_sort.t:220) v:>,<,%
# 4 <0> pushmark s
-# 5 <0> pushmark s
-# 6 <0> padav[@a:429,430] lRM*
-# 7 <@> sort lK/INPLACE
-# 8 <;> nextstate(main 430 optree_sort.t:220) v:>,<,%,{
-# 9 <0> pushmark s
-# a <0> padav[@a:429,430] lRM
-# b <$> const(IV 1) s
-# c <@> push[t3] sK/2
-# d <1> leavesub[1 ref] K/REFC,1
+# 5 <0> padrange[@a:429,430] l/1
+# 6 <@> sort lK/INPLACE
+# 7 <;> nextstate(main 430 optree_sort.t:220) v:>,<,%,{
+# 8 <0> padrange[@a:429,430] l/1
+# 9 <$> const(IV 1) s
+# a <@> push[t3] sK/2
+# b <1> leavesub[1 ref] K/REFC,1
EONT_EONT
checkOptree ( name => 'sub {my @a; @a = sort @a; 1}',
@@ -285,21 +277,19 @@
2 <0> padav[@a:-437,-436] vM/LVINTRO
3 <;> nextstate(main -436 optree.t:325) v:>,<,%
4 <0> pushmark s
-5 <0> pushmark s
-6 <0> padav[@a:-437,-436] lRM*
-7 <@> sort lK/INPLACE
-8 <;> nextstate(main -436 optree.t:346) v:>,<,%,{
-9 <$> const[IV 1] s
-a <1> leavesub[1 ref] K/REFC,1
+5 <0> padrange[@a:-437,-436] l/1
+6 <@> sort lK/INPLACE
+7 <;> nextstate(main -436 optree.t:346) v:>,<,%,{
+8 <$> const[IV 1] s
+9 <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1 <;> nextstate(main 431 optree_sort.t:250) v:>,<,%
# 2 <0> padav[@a:431,432] vM/LVINTRO
# 3 <;> nextstate(main 432 optree_sort.t:251) v:>,<,%
# 4 <0> pushmark s
-# 5 <0> pushmark s
-# 6 <0> padav[@a:431,432] lRM*
-# 7 <@> sort lK/INPLACE
-# 8 <;> nextstate(main 432 optree_sort.t:251) v:>,<,%,{
-# 9 <$> const(IV 1) s
-# a <1> leavesub[1 ref] K/REFC,1
+# 5 <0> padrange[@a:431,432] l/1
+# 6 <@> sort lK/INPLACE
+# 7 <;> nextstate(main 432 optree_sort.t:251) v:>,<,%,{
+# 8 <$> const(IV 1) s
+# 9 <1> leavesub[1 ref] K/REFC,1
EONT_EONT
Property changes on: trunk/contrib/perl/ext/B/t/optree_sort.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/ext/B/t/optree_specials.t
===================================================================
--- trunk/contrib/perl/ext/B/t/optree_specials.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/B/t/optree_specials.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -20,7 +20,7 @@
use OptreeCheck; # ALSO DOES @ARGV HANDLING !!!!!!
use Config;
-plan tests => 13 + ($] > 5.009 ? 2 : 0);
+plan tests => 15;
require_ok("B::Concise");
@@ -34,25 +34,18 @@
my $src = q[our ($beg, $chk, $init, $end, $uc) = qq{'foo'}; BEGIN { $beg++ } CHECK { $chk++ } INIT { $init++ } END { $end++ } UNITCHECK {$uc++}];
-my @warnings_todo;
- at warnings_todo = (todo =>
- "Change 23768 (Remove Carp from warnings.pm) alters expected output, not"
- . "propagated to 5.8.x")
- if $] < 5.009;
-
checkOptree ( name => 'BEGIN',
bcopts => 'BEGIN',
prog => $src,
- @warnings_todo,
strip_open_hints => 1,
expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
# BEGIN 1:
# a <1> leavesub[1 ref] K/REFC,1 ->(end)
# - <@> lineseq KP ->a
-# 1 <;> nextstate(B::Concise -275 Concise.pm:356) v:*,&,{,$ ->2
+# 1 <;> nextstate(B::Concise -275 Concise.pm:356) v:*,&,{,x*,x&,x$,$ ->2
# 3 <1> require sK/1 ->4
# 2 <$> const[PV "strict.pm"] s/BARE ->3
-# 4 <;> nextstate(B::Concise -275 Concise.pm:356) v:*,&,{,$ ->5
+# 4 <;> nextstate(B::Concise -275 Concise.pm:356) v:*,&,{,x*,x&,x$,$ ->5
# - <@> lineseq K ->-
# - <0> null ->5
# 9 <1> entersub[t1] KS*/TARG,2 ->a
@@ -63,10 +56,10 @@
# BEGIN 2:
# k <1> leavesub[1 ref] K/REFC,1 ->(end)
# - <@> lineseq K ->k
-# b <;> nextstate(B::Concise -265 Concise.pm:367) v:*,&,$ ->c
+# b <;> nextstate(B::Concise -265 Concise.pm:367) v:*,&,x*,x&,x$,$ ->c
# d <1> require sK/1 ->e
# c <$> const[PV "strict.pm"] s/BARE ->d
-# e <;> nextstate(B::Concise -265 Concise.pm:367) v:*,&,$ ->f
+# e <;> nextstate(B::Concise -265 Concise.pm:367) v:*,&,x*,x&,x$,$ ->f
# - <@> lineseq K ->-
# - <0> null ->f
# j <1> entersub[t1] KS*/TARG,2 ->k
@@ -77,10 +70,10 @@
# BEGIN 3:
# u <1> leavesub[1 ref] K/REFC,1 ->(end)
# - <@> lineseq KP ->u
-# l <;> nextstate(B::Concise -254 Concise.pm:386) v:*,&,{,$ ->m
+# l <;> nextstate(B::Concise -254 Concise.pm:386) v:*,&,{,x*,x&,x$,$ ->m
# n <1> require sK/1 ->o
# m <$> const[PV "warnings.pm"] s/BARE ->n
-# o <;> nextstate(B::Concise -254 Concise.pm:386) v:*,&,{,$ ->p
+# o <;> nextstate(B::Concise -254 Concise.pm:386) v:*,&,{,x*,x&,x$,$ ->p
# - <@> lineseq K ->-
# - <0> null ->p
# t <1> entersub[t1] KS*/TARG,2 ->u
@@ -99,10 +92,10 @@
# BEGIN 1:
# a <1> leavesub[1 ref] K/REFC,1 ->(end)
# - <@> lineseq KP ->a
-# 1 <;> nextstate(B::Concise -275 Concise.pm:356) v:*,&,{,$ ->2
+# 1 <;> nextstate(B::Concise -275 Concise.pm:356) v:*,&,{,x*,x&,x$,$ ->2
# 3 <1> require sK/1 ->4
# 2 <$> const(PV "strict.pm") s/BARE ->3
-# 4 <;> nextstate(B::Concise -275 Concise.pm:356) v:*,&,{,$ ->5
+# 4 <;> nextstate(B::Concise -275 Concise.pm:356) v:*,&,{,x*,x&,x$,$ ->5
# - <@> lineseq K ->-
# - <0> null ->5
# 9 <1> entersub[t1] KS*/TARG,2 ->a
@@ -113,10 +106,10 @@
# BEGIN 2:
# k <1> leavesub[1 ref] K/REFC,1 ->(end)
# - <@> lineseq K ->k
-# b <;> nextstate(B::Concise -265 Concise.pm:367) v:*,&,$ ->c
+# b <;> nextstate(B::Concise -265 Concise.pm:367) v:*,&,x*,x&,x$,$ ->c
# d <1> require sK/1 ->e
# c <$> const(PV "strict.pm") s/BARE ->d
-# e <;> nextstate(B::Concise -265 Concise.pm:367) v:*,&,$ ->f
+# e <;> nextstate(B::Concise -265 Concise.pm:367) v:*,&,x*,x&,x$,$ ->f
# - <@> lineseq K ->-
# - <0> null ->f
# j <1> entersub[t1] KS*/TARG,2 ->k
@@ -127,10 +120,10 @@
# BEGIN 3:
# u <1> leavesub[1 ref] K/REFC,1 ->(end)
# - <@> lineseq KP ->u
-# l <;> nextstate(B::Concise -254 Concise.pm:386) v:*,&,{,$ ->m
+# l <;> nextstate(B::Concise -254 Concise.pm:386) v:*,&,{,x*,x&,x$,$ ->m
# n <1> require sK/1 ->o
# m <$> const(PV "warnings.pm") s/BARE ->n
-# o <;> nextstate(B::Concise -254 Concise.pm:386) v:*,&,{,$ ->p
+# o <;> nextstate(B::Concise -254 Concise.pm:386) v:*,&,{,x*,x&,x$,$ ->p
# - <@> lineseq K ->-
# - <0> null ->p
# t <1> entersub[t1] KS*/TARG,2 ->u
@@ -193,12 +186,11 @@
# 2 <$> gvsv(*chk) s ->3
EONT_EONT
-if ($] >= 5.009) {
- checkOptree ( name => 'UNITCHECK',
- bcopts=> 'UNITCHECK',
- prog => $src,
- strip_open_hints => 1,
- expect=> <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+checkOptree ( name => 'UNITCHECK',
+ bcopts=> 'UNITCHECK',
+ prog => $src,
+ strip_open_hints => 1,
+ expect=> <<'EOT_EOT', expect_nt => <<'EONT_EONT');
# UNITCHECK 1:
# 4 <1> leavesub[1 ref] K/REFC,1 ->(end)
# - <@> lineseq KP ->4
@@ -215,7 +207,6 @@
# - <1> ex-rv2sv sKRM/1 ->3
# 2 <$> gvsv(*uc) s ->3
EONT_EONT
-}
checkOptree ( name => 'INIT',
bcopts => 'INIT',
@@ -244,14 +235,13 @@
checkOptree ( name => 'all of BEGIN END INIT CHECK UNITCHECK -exec',
bcopts => [qw/ BEGIN END INIT CHECK UNITCHECK -exec /],
prog => $src,
- @warnings_todo,
strip_open_hints => 1,
expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
# BEGIN 1:
-# 1 <;> nextstate(B::Concise -275 Concise.pm:356) v:*,&,{,$
+# 1 <;> nextstate(B::Concise -275 Concise.pm:356) v:*,&,{,x*,x&,x$,$
# 2 <$> const[PV "strict.pm"] s/BARE
# 3 <1> require sK/1
-# 4 <;> nextstate(B::Concise -275 Concise.pm:356) v:*,&,{,$
+# 4 <;> nextstate(B::Concise -275 Concise.pm:356) v:*,&,{,x*,x&,x$,$
# 5 <0> pushmark s
# 6 <$> const[PV "strict"] sM
# 7 <$> const[PV "refs"] sM
@@ -259,10 +249,10 @@
# 9 <1> entersub[t1] KS*/TARG,2
# a <1> leavesub[1 ref] K/REFC,1
# BEGIN 2:
-# b <;> nextstate(B::Concise -265 Concise.pm:367) v:*,&,$
+# b <;> nextstate(B::Concise -265 Concise.pm:367) v:*,&,x*,x&,x$,$
# c <$> const[PV "strict.pm"] s/BARE
# d <1> require sK/1
-# e <;> nextstate(B::Concise -265 Concise.pm:367) v:*,&,$
+# e <;> nextstate(B::Concise -265 Concise.pm:367) v:*,&,x*,x&,x$,$
# f <0> pushmark s
# g <$> const[PV "strict"] sM
# h <$> const[PV "refs"] sM
@@ -270,10 +260,10 @@
# j <1> entersub[t1] KS*/TARG,2
# k <1> leavesub[1 ref] K/REFC,1
# BEGIN 3:
-# l <;> nextstate(B::Concise -254 Concise.pm:386) v:*,&,{,$
+# l <;> nextstate(B::Concise -254 Concise.pm:386) v:*,&,{,x*,x&,x$,$
# m <$> const[PV "warnings.pm"] s/BARE
# n <1> require sK/1
-# o <;> nextstate(B::Concise -254 Concise.pm:386) v:*,&,{,$
+# o <;> nextstate(B::Concise -254 Concise.pm:386) v:*,&,{,x*,x&,x$,$
# p <0> pushmark s
# q <$> const[PV "warnings"] sM
# r <$> const[PV "qw"] sM
@@ -307,10 +297,10 @@
# 1e <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# BEGIN 1:
-# 1 <;> nextstate(B::Concise -275 Concise.pm:356) v:*,&,{,$
+# 1 <;> nextstate(B::Concise -275 Concise.pm:356) v:*,&,{,x*,x&,x$,$
# 2 <$> const(PV "strict.pm") s/BARE
# 3 <1> require sK/1
-# 4 <;> nextstate(B::Concise -275 Concise.pm:356) v:*,&,{,$
+# 4 <;> nextstate(B::Concise -275 Concise.pm:356) v:*,&,{,x*,x&,x$,$
# 5 <0> pushmark s
# 6 <$> const(PV "strict") sM
# 7 <$> const(PV "refs") sM
@@ -318,10 +308,10 @@
# 9 <1> entersub[t1] KS*/TARG,2
# a <1> leavesub[1 ref] K/REFC,1
# BEGIN 2:
-# b <;> nextstate(B::Concise -265 Concise.pm:367) v:*,&,$
+# b <;> nextstate(B::Concise -265 Concise.pm:367) v:*,&,x*,x&,x$,$
# c <$> const(PV "strict.pm") s/BARE
# d <1> require sK/1
-# e <;> nextstate(B::Concise -265 Concise.pm:367) v:*,&,$
+# e <;> nextstate(B::Concise -265 Concise.pm:367) v:*,&,x*,x&,x$,$
# f <0> pushmark s
# g <$> const(PV "strict") sM
# h <$> const(PV "refs") sM
@@ -329,10 +319,10 @@
# j <1> entersub[t1] KS*/TARG,2
# k <1> leavesub[1 ref] K/REFC,1
# BEGIN 3:
-# l <;> nextstate(B::Concise -254 Concise.pm:386) v:*,&,{,$
+# l <;> nextstate(B::Concise -254 Concise.pm:386) v:*,&,{,x*,x&,x$,$
# m <$> const(PV "warnings.pm") s/BARE
# n <1> require sK/1
-# o <;> nextstate(B::Concise -254 Concise.pm:386) v:*,&,{,$
+# o <;> nextstate(B::Concise -254 Concise.pm:386) v:*,&,{,x*,x&,x$,$
# p <0> pushmark s
# q <$> const(PV "warnings") sM
# r <$> const(PV "qw") sM
@@ -374,13 +364,12 @@
checkOptree ( name => 'regression test for patch 25352',
bcopts => [qw/ BEGIN END INIT CHECK -exec /],
prog => 'print q/foo/',
- @warnings_todo,
expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
# BEGIN 1:
-# 1 <;> nextstate(B::Concise -275 Concise.pm:356) v:*,&,{,$
+# 1 <;> nextstate(B::Concise -275 Concise.pm:356) v:*,&,{,x*,x&,x$,$
# 2 <$> const[PV "strict.pm"] s/BARE
# 3 <1> require sK/1
-# 4 <;> nextstate(B::Concise -275 Concise.pm:356) v:*,&,{,$
+# 4 <;> nextstate(B::Concise -275 Concise.pm:356) v:*,&,{,x*,x&,x$,$
# 5 <0> pushmark s
# 6 <$> const[PV "strict"] sM
# 7 <$> const[PV "refs"] sM
@@ -388,10 +377,10 @@
# 9 <1> entersub[t1] KS*/TARG,2
# a <1> leavesub[1 ref] K/REFC,1
# BEGIN 2:
-# b <;> nextstate(B::Concise -265 Concise.pm:367) v:*,&,$
+# b <;> nextstate(B::Concise -265 Concise.pm:367) v:*,&,x*,x&,x$,$
# c <$> const[PV "strict.pm"] s/BARE
# d <1> require sK/1
-# e <;> nextstate(B::Concise -265 Concise.pm:367) v:*,&,$
+# e <;> nextstate(B::Concise -265 Concise.pm:367) v:*,&,x*,x&,x$,$
# f <0> pushmark s
# g <$> const[PV "strict"] sM
# h <$> const[PV "refs"] sM
@@ -399,10 +388,10 @@
# j <1> entersub[t1] KS*/TARG,2
# k <1> leavesub[1 ref] K/REFC,1
# BEGIN 3:
-# l <;> nextstate(B::Concise -254 Concise.pm:386) v:*,&,{,$
+# l <;> nextstate(B::Concise -254 Concise.pm:386) v:*,&,{,x*,x&,x$,$
# m <$> const[PV "warnings.pm"] s/BARE
# n <1> require sK/1
-# o <;> nextstate(B::Concise -254 Concise.pm:386) v:*,&,{,$
+# o <;> nextstate(B::Concise -254 Concise.pm:386) v:*,&,{,x*,x&,x$,$
# p <0> pushmark s
# q <$> const[PV "warnings"] sM
# r <$> const[PV "qw"] sM
@@ -411,10 +400,10 @@
# u <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# BEGIN 1:
-# 1 <;> nextstate(B::Concise -275 Concise.pm:356) v:*,&,{,$
+# 1 <;> nextstate(B::Concise -275 Concise.pm:356) v:*,&,{,x*,x&,x$,$
# 2 <$> const(PV "strict.pm") s/BARE
# 3 <1> require sK/1
-# 4 <;> nextstate(B::Concise -275 Concise.pm:356) v:*,&,{,$
+# 4 <;> nextstate(B::Concise -275 Concise.pm:356) v:*,&,{,x*,x&,x$,$
# 5 <0> pushmark s
# 6 <$> const(PV "strict") sM
# 7 <$> const(PV "refs") sM
@@ -422,10 +411,10 @@
# 9 <1> entersub[t1] KS*/TARG,2
# a <1> leavesub[1 ref] K/REFC,1
# BEGIN 2:
-# b <;> nextstate(B::Concise -265 Concise.pm:367) v:*,&,$
+# b <;> nextstate(B::Concise -265 Concise.pm:367) v:*,&,x*,x&,x$,$
# c <$> const(PV "strict.pm") s/BARE
# d <1> require sK/1
-# e <;> nextstate(B::Concise -265 Concise.pm:367) v:*,&,$
+# e <;> nextstate(B::Concise -265 Concise.pm:367) v:*,&,x*,x&,x$,$
# f <0> pushmark s
# g <$> const(PV "strict") sM
# h <$> const(PV "refs") sM
@@ -433,10 +422,10 @@
# j <1> entersub[t1] KS*/TARG,2
# k <1> leavesub[1 ref] K/REFC,1
# BEGIN 3:
-# l <;> nextstate(B::Concise -254 Concise.pm:386) v:*,&,{,$
+# l <;> nextstate(B::Concise -254 Concise.pm:386) v:*,&,{,x*,x&,x$,$
# m <$> const(PV "warnings.pm") s/BARE
# n <1> require sK/1
-# o <;> nextstate(B::Concise -254 Concise.pm:386) v:*,&,{,$
+# o <;> nextstate(B::Concise -254 Concise.pm:386) v:*,&,{,x*,x&,x$,$
# p <0> pushmark s
# q <$> const(PV "warnings") sM
# r <$> const(PV "qw") sM
Property changes on: trunk/contrib/perl/ext/B/t/optree_specials.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/ext/B/t/optree_varinit.t
===================================================================
--- trunk/contrib/perl/ext/B/t/optree_varinit.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/B/t/optree_varinit.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -390,18 +390,14 @@
# 1 <0> enter
# 2 <;> nextstate(main 1 -e:1) v:>,<,%,{
# 3 <0> pushmark s
-# 4 <0> pushmark sRM*/128
-# 5 <0> padsv[$a:1,2] lRM*/LVINTRO
-# 6 <0> padsv[$b:1,2] lRM*/LVINTRO
-# 7 <2> aassign[t3] vKS
-# 8 <@> leave[1 ref] vKP/REFC
+# 4 <0> padrange[$a:1,2; $b:1,2] lRM/LVINTRO,2
+# 5 <2> aassign[t3] vKS
+# 6 <@> leave[1 ref] vKP/REFC
EOT_EOT
# 1 <0> enter
# 2 <;> nextstate(main 1 -e:1) v:>,<,%,{
# 3 <0> pushmark s
-# 4 <0> pushmark sRM*/128
-# 5 <0> padsv[$a:1,2] lRM*/LVINTRO
-# 6 <0> padsv[$b:1,2] lRM*/LVINTRO
-# 7 <2> aassign[t3] vKS
-# 8 <@> leave[1 ref] vKP/REFC
+# 4 <0> padrange[$a:1,2; $b:1,2] lRM/LVINTRO,2
+# 5 <2> aassign[t3] vKS
+# 6 <@> leave[1 ref] vKP/REFC
EONT_EONT
Property changes on: trunk/contrib/perl/ext/B/t/optree_varinit.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/ext/B/t/pragma.t
===================================================================
--- trunk/contrib/perl/ext/B/t/pragma.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/B/t/pragma.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -11,10 +11,6 @@
print "1..0 # Skip -- Perl configured without B module\n";
exit 0;
}
- if ( $] < 5.009 ) {
- print "1..0 # Skip -- No user pragmata in 5.8.x\n";
- exit 0;
- }
}
use strict;
Property changes on: trunk/contrib/perl/ext/B/t/pragma.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/ext/B/t/showlex.t
===================================================================
--- trunk/contrib/perl/ext/B/t/showlex.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/B/t/showlex.t 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/B/t/showlex.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/ext/B/t/terse.t
===================================================================
--- trunk/contrib/perl/ext/B/t/terse.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/B/t/terse.t 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/B/t/terse.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/ext/B/t/walkoptree.t
===================================================================
--- trunk/contrib/perl/ext/B/t/walkoptree.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/B/t/walkoptree.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -33,7 +33,7 @@
my $victim = sub {
# This gives us a substcont, which gets to the second recursive call
# point (in the if statement in the XS code)
- $_[0] =~ s/(a)/$1/;
+ $_[0] =~ s/(a)/ $1/;
# PMOP_pmreplroot(cPMOPo) is NULL for this
$_[0] =~ s/(b)//;
# This gives an OP_PUSHRE
Property changes on: trunk/contrib/perl/ext/B/t/walkoptree.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/ext/B/t/xref.t
===================================================================
--- trunk/contrib/perl/ext/B/t/xref.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/B/t/xref.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -23,7 +23,7 @@
close STDOUT;
# line 100
our $compilesub = B::Xref::compile("-o$file");
-ok( ref $compilesub eq 'CODE', "compile() returns a coderef ($compilesub)" );
+ok( ref $compilesub eq 'CODE', "compile() returns a coderef" );
$compilesub->(); # Compile this test script
close STDOUT;
open STDOUT, ">&SAVEOUT" or diag $!;
@@ -34,6 +34,7 @@
our %xreftable = ();
open XREF, $file or die "# Can't open $file: $!\n";
while (<XREF>) {
+ print STDERR $_ if $ENV{PERL_DEBUG};
chomp;
if (/^File (.*)/) {
$curfile = $1;
Property changes on: trunk/contrib/perl/ext/B/t/xref.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/ext/B/typemap
===================================================================
--- trunk/contrib/perl/ext/B/typemap 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/B/typemap 2013-12-02 21:32:26 UTC (rev 6445)
@@ -36,6 +36,8 @@
B::HE T_HE_OBJ
B::RHE T_RHE_OBJ
+B::PADLIST T_PL_OBJ
+
INPUT
T_OP_OBJ
if (SvROK($arg)) {
@@ -77,6 +79,14 @@
else
croak(\"$var is not a reference\")
+T_PL_OBJ
+ if (SvROK($arg)) {
+ IV tmp = SvIV((SV*)SvRV($arg));
+ $var = INT2PTR($type,tmp);
+ }
+ else
+ croak(\"$var is not a reference\")
+
OUTPUT
T_MG_OBJ
sv_setiv(newSVrv($arg, "B::MAGIC"), PTR2IV($var));
@@ -86,3 +96,7 @@
T_RHE_OBJ
sv_setiv(newSVrv($arg, "B::RHE"), PTR2IV($var));
+
+T_PL_OBJ
+ sv_setiv(newSVrv($arg, $var ? "B::PADLIST" : "B::NULL"),
+ PTR2IV($var));
Property changes on: trunk/contrib/perl/ext/B/typemap
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/ext/Devel-Peek/Changes
===================================================================
--- trunk/contrib/perl/ext/Devel-Peek/Changes 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/Devel-Peek/Changes 2013-12-02 21:32:26 UTC (rev 6445)
@@ -66,3 +66,8 @@
1.02:
2004-10-22: Document "hash quality" output and update examples.
+1.09:
+ 2012-07-23: Modify tests for 5.18's slightly different flags.
+1.10:
+ 2012-08-22: Update so compiles under C++ with new PADLIST changes in
+ the Perl core
Property changes on: trunk/contrib/perl/ext/Devel-Peek/Changes
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/Devel-Peek/Makefile.PL
===================================================================
--- trunk/contrib/perl/ext/Devel-Peek/Makefile.PL 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/Devel-Peek/Makefile.PL 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/Devel-Peek/Makefile.PL
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/ext/Devel-Peek/Peek.pm
===================================================================
--- trunk/contrib/perl/ext/Devel-Peek/Peek.pm 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/Devel-Peek/Peek.pm 2013-12-02 21:32:26 UTC (rev 6445)
@@ -3,7 +3,7 @@
package Devel::Peek;
-$VERSION = '1.07';
+$VERSION = '1.11';
$XS_VERSION = $VERSION;
$VERSION = eval $VERSION;
@@ -139,7 +139,7 @@
Use mstat() function to emit a memory state statistic to the terminal.
For more information on the format of output of mstat() see
-L<perldebguts/Using C<$ENV{PERL_DEBUG_MSTATS}>>.
+L<perldebguts/Using $ENV{PERL_DEBUG_MSTATS}>.
Three additional functions allow access to this statistic from Perl.
First, use C<mstats_fillhash(%hash)> to get the information contained
@@ -152,9 +152,10 @@
provide per-bucket count of free and used chunks. Two other fields
C<mem_size>, C<available_size> contain array references which provide
the information about the allocated size and usable size of chunks in
-each bucket. Again, see L<perldebguts/Using C<$ENV{PERL_DEBUG_MSTATS}>>
+each bucket. Again, see L<perldebguts/Using $ENV{PERL_DEBUG_MSTATS}>
for details.
+
Keep in mind that only the first several "odd-numbered" buckets are
used, so the information on size of the "odd-numbered" buckets which are
not used is probably meaningless.
@@ -410,7 +411,7 @@
IV = 42
This shows C<$a> is a reference pointing to an SV. That SV is a PVHV, a
-hash. Fields RITER and EITER are used by C<L<each>>.
+hash. Fields RITER and EITER are used by C<L<perlfunc/each>>.
The "quality" of a hash is defined as the total number of comparisons needed
to access every element once, relative to the expected number needed for a
Property changes on: trunk/contrib/perl/ext/Devel-Peek/Peek.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/ext/Devel-Peek/Peek.xs
===================================================================
--- trunk/contrib/perl/ext/Devel-Peek/Peek.xs 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/Devel-Peek/Peek.xs 2013-12-02 21:32:26 UTC (rev 6445)
@@ -23,7 +23,7 @@
SV* sva;
SV* sv;
SV* ret = newRV_noinc((SV*)newAV());
- register SV* svend;
+ SV* svend;
int tm = 0, tref = 0, ts = 0, ta = 0, tas = 0;
for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
@@ -31,7 +31,8 @@
for (sv = sva + 1; sv < svend; ++sv) {
if (SvTYPE(sv) == SVt_PVCV) {
CV *cv = (CV*)sv;
- AV* padlist = CvPADLIST(cv), *argav;
+ PADLIST* padlist = CvPADLIST(cv);
+ AV *argav;
SV** svp;
SV** pad;
int i = 0, j, levelm, totm = 0, levelref, totref = 0;
@@ -53,10 +54,11 @@
PerlIO_printf(Perl_debug_log, " busy\n");
continue;
}
- svp = AvARRAY(padlist);
- while (++i <= AvFILL(padlist)) { /* Depth. */
+ svp = (SV**) PadlistARRAY(padlist);
+ while (++i <= PadlistMAX(padlist)) { /* Depth. */
SV **args;
+ if (!svp[i]) continue;
pad = AvARRAY((AV*)svp[i]);
argav = (AV*)pad[0];
if (!argav || (SV*)argav == &PL_sv_undef) {
@@ -108,7 +110,7 @@
if (dumpit)
do_sv_dump(0, Perl_debug_log, (SV*)cv, 0, 2, 0, 0);
}
- if (AvFILL(padlist) > 1) {
+ if (PadlistMAX(padlist) > 1) {
PerlIO_printf(Perl_debug_log, " total: refs: %i, strings: %i in %i,\targsarrays: %i, argsstrings: %i\n",
totref, totm, tots, tota, totas);
}
@@ -161,6 +163,7 @@
{
dTHX;
+ if (SvIsCOW(sv)) sv_force_normal(sv);
if (SvREADONLY(sv))
croak("Cannot modify a readonly value");
SvGROW(sv, sizeof(struct mstats_buffer)+1);
Property changes on: trunk/contrib/perl/ext/Devel-Peek/Peek.xs
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/ext/Devel-Peek/t/Peek.t
===================================================================
--- trunk/contrib/perl/ext/Devel-Peek/t/Peek.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/Devel-Peek/t/Peek.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -25,6 +25,8 @@
$::mmmm
.
+use constant thr => $Config{useithreads};
+
sub do_test {
my $todo = $_[3];
my $repeat_todo = $_[4];
@@ -54,11 +56,10 @@
# legitimate regexp, it still isn't true. Seems easier and clearer
# things that look like comments.
- my $version_condition = qr/\$] [<>]=? 5\.\d\d\d/;
# Could do this is in a s///mge but seems clearer like this:
$pattern = join '', map {
# If we identify the version condition, take *it* out whatever
- s/\s*# ($version_condition(?: && $version_condition)?)$//
+ s/\s*# (\$].*)$//
? (eval $1 ? $_ : '')
: $_ # Didn't match, so this line is in
} split /^/, $pattern;
@@ -240,7 +241,7 @@
FLAGS = \\(ROK\\)
RV = $ADDR
SV = PVHV\\($ADDR\\) at $ADDR
- REFCNT = 1
+ REFCNT = [12]
FLAGS = \\(SHAREKEYS\\)
IV = 1 # $] < 5.009
NV = $FLOAT # $] < 5.009
@@ -249,11 +250,10 @@
KEYS = 1
FILL = 1
MAX = 7
- RITER = -1
- EITER = 0x0
Elt "123" HASH = $ADDR' . $c_pattern,
'',
- $] > 5.009 && 'The hash iterator used in dump.c sets the OOK flag');
+ $] > 5.009 && $] < 5.015
+ && 'The hash iterator used in dump.c sets the OOK flag');
do_test('reference to anon sub with empty prototype',
sub(){@_},
@@ -263,7 +263,8 @@
RV = $ADDR
SV = PVCV\\($ADDR\\) at $ADDR
REFCNT = 2
- FLAGS = \\($PADMY,POK,pPOK,ANON,WEAKOUTSIDE,CVGV_RC\\)
+ FLAGS = \\($PADMY,POK,pPOK,ANON,WEAKOUTSIDE,CVGV_RC\\) # $] < 5.015 || !thr
+ FLAGS = \\($PADMY,POK,pPOK,ANON,WEAKOUTSIDE,CVGV_RC,DYNFILE\\) # $] >= 5.015 && thr
IV = 0 # $] < 5.009
NV = 0 # $] < 5.009
PROTOTYPE = ""
@@ -278,7 +279,8 @@
MUTEXP = $ADDR
OWNER = $ADDR)?
FLAGS = 0x404 # $] < 5.009
- FLAGS = 0x490 # $] >= 5.009
+ FLAGS = 0x490 # $] >= 5.009 && ($] < 5.015 || !thr)
+ FLAGS = 0x1490 # $] >= 5.015 && thr
OUTSIDE_SEQ = \\d+
PADLIST = $ADDR
PADNAME = $ADDR\\($ADDR\\) PAD = $ADDR\\($ADDR\\)
@@ -292,7 +294,8 @@
RV = $ADDR
SV = PVCV\\($ADDR\\) at $ADDR
REFCNT = (3|4)
- FLAGS = \\(\\)
+ FLAGS = \\((?:HASEVAL)?\\) # $] < 5.015 || !thr
+ FLAGS = \\(DYNFILE(?:,HASEVAL)?\\) # $] >= 5.015 && thr
IV = 0 # $] < 5.009
NV = 0 # $] < 5.009
COMP_STASH = $ADDR\\t"main"
@@ -302,10 +305,11 @@
XSUBANY = 0 # $] < 5.009
GVGV::GV = $ADDR\\t"main" :: "do_test"
FILE = ".*\\b(?i:peek\\.t)"
- DEPTH = 1
-(?: MUTEXP = $ADDR
- OWNER = $ADDR
-)? FLAGS = 0x0
+ DEPTH = 1(?:
+ MUTEXP = $ADDR
+ OWNER = $ADDR)?
+ FLAGS = 0x(?:400)?0 # $] < 5.015 || !thr
+ FLAGS = 0x[145]000 # $] >= 5.015 && thr
OUTSIDE_SEQ = \\d+
PADLIST = $ADDR
PADNAME = $ADDR\\($ADDR\\) PAD = $ADDR\\($ADDR\\)
@@ -312,7 +316,6 @@
\\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$todo"
\\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$repeat_todo"
\\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$pattern"
- \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$version_condition"
\\d+\\. $ADDR<\\d+> FAKE "\\$DEBUG" # $] < 5.009
\\d+\\. $ADDR<\\d+> FAKE "\\$DEBUG" flags=0x0 index=0 # $] >= 5.009
\\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$dump"
@@ -328,13 +331,15 @@
RV = $ADDR
SV = REGEXP\\($ADDR\\) at $ADDR
REFCNT = 1
- FLAGS = \\(OBJECT,POK,FAKE,pPOK\\)
+ FLAGS = \\(OBJECT,POK,FAKE,pPOK\\) # $] < 5.017006
+ FLAGS = \\(OBJECT,FAKE\\) # $] >= 5.017006
PV = $ADDR "\\(\\?\\^:tic\\)"
CUR = 8
- LEN = 0
+ LEN = 0 # $] < 5.017006
STASH = $ADDR\\t"Regexp"'
. ($] < 5.013 ? '' :
'
+ COMPFLAGS = 0x0 \(\)
EXTFLAGS = 0x680000 \(CHECK_ALL,USE_INTUIT_NOML,USE_INTUIT_ML\)
INTFLAGS = 0x0
NPARENS = 0
@@ -344,8 +349,9 @@
MINLENRET = 3
GOFS = 0
PRE_PREFIX = 4
- SEEN_EVALS = 0
SUBLEN = 0
+ SUBOFFSET = 0
+ SUBCOFFSET = 0
SUBBEG = 0x0
ENGINE = $ADDR
MOTHER_RE = $ADDR
@@ -352,7 +358,9 @@
PAREN_NAMES = 0x0
SUBSTRS = $ADDR
PPRIVATE = $ADDR
- OFFS = $ADDR'
+ OFFS = $ADDR
+ QR_ANONCV = 0x0(?:
+ SAVED_COPY = 0x0)?'
));
} else {
do_test('reference to regexp',
@@ -383,7 +391,7 @@
FLAGS = \\(ROK\\)
RV = $ADDR
SV = PVHV\\($ADDR\\) at $ADDR
- REFCNT = 1
+ REFCNT = [12]
FLAGS = \\(OBJECT,SHAREKEYS\\)
IV = 0 # $] < 5.009
NV = 0 # $] < 5.009
@@ -391,10 +399,11 @@
ARRAY = 0x0
KEYS = 0
FILL = 0
- MAX = 7
- RITER = -1
- EITER = 0x0', '',
- $] > 5.009 ? 'The hash iterator used in dump.c sets the OOK flag'
+ MAX = 7', '',
+ $] > 5.009
+ ? $] >= 5.015
+ ? 0
+ : 'The hash iterator used in dump.c sets the OOK flag'
: "Something causes the HV's array to become allocated");
do_test('typeglob',
@@ -456,7 +465,7 @@
FLAGS = \\(ROK\\)
RV = $ADDR
SV = PVHV\\($ADDR\\) at $ADDR
- REFCNT = 1
+ REFCNT = [12]
FLAGS = \\(SHAREKEYS,HASKFLAGS\\)
UV = 1 # $] < 5.009
NV = $FLOAT # $] < 5.009
@@ -465,8 +474,6 @@
KEYS = 1
FILL = 1
MAX = 7
- RITER = -1
- EITER = $ADDR
Elt "\\\214\\\101" \[UTF8 "\\\x\{100\}"\] HASH = $ADDR
SV = PV\\($ADDR\\) at $ADDR
REFCNT = 1
@@ -474,7 +481,10 @@
PV = $ADDR "\\\235\\\101"\\\0 \[UTF8 "\\\x\{200\}"\]
CUR = 2
LEN = \\d+',
- $] > 5.009 ? 'The hash iterator used in dump.c sets the OOK flag'
+ $] > 5.009
+ ? $] >= 5.015
+ ? 0
+ : 'The hash iterator used in dump.c sets the OOK flag'
: 'sv_length has been called on the element, and cached the result in MAGIC');
} else {
do_test('reference to hash containing Unicode',
@@ -484,7 +494,7 @@
FLAGS = \\(ROK\\)
RV = $ADDR
SV = PVHV\\($ADDR\\) at $ADDR
- REFCNT = 1
+ REFCNT = [12]
FLAGS = \\(SHAREKEYS,HASKFLAGS\\)
UV = 1 # $] < 5.009
NV = 0 # $] < 5.009
@@ -493,8 +503,6 @@
KEYS = 1
FILL = 1
MAX = 7
- RITER = -1
- EITER = $ADDR
Elt "\\\304\\\200" \[UTF8 "\\\x\{100\}"\] HASH = $ADDR
SV = PV\\($ADDR\\) at $ADDR
REFCNT = 1
@@ -502,7 +510,10 @@
PV = $ADDR "\\\310\\\200"\\\0 \[UTF8 "\\\x\{200\}"\]
CUR = 2
LEN = \\d+', '',
- $] > 5.009 ? 'The hash iterator used in dump.c sets the OOK flag'
+ $] > 5.009
+ ? $] >= 5.015
+ ? 0
+ : 'The hash iterator used in dump.c sets the OOK flag'
: 'sv_length has been called on the element, and cached the result in MAGIC');
}
@@ -512,12 +523,13 @@
$x,
'SV = PVMG\\($ADDR\\) at $ADDR
REFCNT = 1
- FLAGS = \\($PADMY,SMG,POK,pPOK\\)
- IV = 0
+ FLAGS = \\($PADMY,SMG,POK,(?:IsCOW,)?pPOK\\)
+ IV = \d+
NV = 0
PV = $ADDR ""\\\0
CUR = 0
- LEN = \d+
+ LEN = \d+(?:
+ COW_REFCNT = 1)?
MAGIC = $ADDR
MG_VIRTUAL = &PL_vtbl_mglob
MG_TYPE = PERL_MAGIC_regex_global\\(g\\)
@@ -528,14 +540,17 @@
# TAINTEDDIR is not set on: OS2, AMIGAOS, WIN32, MSDOS
# environment variables may be invisibly case-forced, hence the (?i:PATH)
# C<scalar(@ARGV)> is turned into an IV on VMS hence the (?:IV)?
+# Perl 5.18 ensures all env vars end up as strings only, hence the (?:,pIOK)?
+# Perl 5.18 ensures even magic vars have public OK, hence the (?:,POK)?
# VMS is setting FAKE and READONLY flags. What VMS uses for storing
# ENV hashes is also not always null terminated.
#
-do_test('tainted value in %ENV',
- $ENV{PATH}=@ARGV, # scalar(@ARGV) is a handy known tainted value
+if (${^TAINT}) {
+ do_test('tainted value in %ENV',
+ $ENV{PATH}=@ARGV, # scalar(@ARGV) is a handy known tainted value
'SV = PVMG\\($ADDR\\) at $ADDR
REFCNT = 1
- FLAGS = \\(GMG,SMG,RMG,pIOK,pPOK\\)
+ FLAGS = \\(GMG,SMG,RMG(?:,POK)?(?:,pIOK)?,pPOK\\)
IV = 0
NV = 0
PV = $ADDR "0"\\\0
@@ -558,6 +573,7 @@
MAGIC = $ADDR
MG_VIRTUAL = &PL_vtbl_taint
MG_TYPE = PERL_MAGIC_taint\\(t\\)');
+}
do_test('blessed reference',
bless(\\undef, 'Foobar'),
@@ -591,7 +607,8 @@
RV = $ADDR
SV = PVCV\\($ADDR\\) at $ADDR
REFCNT = (2)
- FLAGS = \\(POK,pPOK,CONST,ISXSUB\\)
+ FLAGS = \\(POK,pPOK,CONST,ISXSUB\\) # $] < 5.015
+ FLAGS = \\(POK,pPOK,CONST,DYNFILE,ISXSUB\\) # $] >= 5.015
IV = 0 # $] < 5.009
NV = 0 # $] < 5.009
PROTOTYPE = ""
@@ -612,7 +629,8 @@
OWNER = $ADDR)?
FLAGS = 0x200 # $] < 5.009
FLAGS = 0xc00 # $] >= 5.009 && $] < 5.013
- FLAGS = 0xc # $] >= 5.013
+ FLAGS = 0xc # $] >= 5.013 && $] < 5.015
+ FLAGS = 0x100c # $] >= 5.015
OUTSIDE_SEQ = 0
PADLIST = 0x0
OUTSIDE = 0x0 \\(null\\)');
@@ -660,7 +678,8 @@
RV = $ADDR
SV = PVFM\\($ADDR\\) at $ADDR
REFCNT = 2
- FLAGS = \\(\\)
+ FLAGS = \\(\\) # $] < 5.015 || !thr
+ FLAGS = \\(DYNFILE\\) # $] >= 5.015 && thr
IV = 0 # $] < 5.009
NV = 0 # $] < 5.009
(?: PV = 0
@@ -670,13 +689,14 @@
XSUB = 0x0 # $] < 5.009
XSUBANY = 0 # $] < 5.009
GVGV::GV = $ADDR\\t"main" :: "PIE"
- FILE = ".*\\b(?i:peek\\.t)"
-(?: DEPTH = 0
+ FILE = ".*\\b(?i:peek\\.t)"(?:
+ DEPTH = 0)?(?:
MUTEXP = $ADDR
- OWNER = $ADDR
-)? FLAGS = 0x0
+ OWNER = $ADDR)?
+ FLAGS = 0x0 # $] < 5.015 || !thr
+ FLAGS = 0x1000 # $] >= 5.015 && thr
OUTSIDE_SEQ = \\d+
- LINES = 0
+ LINES = 0 # $] < 5.017_003
PADLIST = $ADDR
PADNAME = $ADDR\\($ADDR\\) PAD = $ADDR\\($ADDR\\)
OUTSIDE = $ADDR \\(MAIN\\)');
@@ -688,7 +708,7 @@
FLAGS = \\(ROK\\)
RV = $ADDR
SV = PVHV\\($ADDR\\) at $ADDR
- REFCNT = 1
+ REFCNT = [12]
FLAGS = \\(OBJECT,SHAREKEYS\\)
IV = 0 # $] < 5.009
NV = 0 # $] < 5.009
@@ -696,10 +716,11 @@
ARRAY = $ADDR
KEYS = 0
FILL = 0
- MAX = 7
- RITER = -1
- EITER = 0x0', '',
- $] > 5.009 ? 'The hash iterator used in dump.c sets the OOK flag'
+ MAX = 7', '',
+ $] > 5.009
+ ? $] >= 5.015
+ ? 0
+ : 'The hash iterator used in dump.c sets the OOK flag'
: "Something causes the HV's array to become allocated");
do_test('ENAME on a stash',
@@ -719,6 +740,7 @@
MAX = 7
RITER = -1
EITER = 0x0
+ RAND = $ADDR
NAME = "RWOM"
ENAME = "RWOM" # $] > 5.012
');
@@ -742,6 +764,7 @@
MAX = 7
RITER = -1
EITER = 0x0
+ RAND = $ADDR
NAME = "RWOM"
NAMECOUNT = 2 # $] > 5.012
ENAME = "RWOM", "KLANK" # $] > 5.012
@@ -757,7 +780,8 @@
RV = $ADDR
SV = PVHV\\($ADDR\\) at $ADDR
REFCNT = 3
- FLAGS = \\(OOK,SHAREKEYS\\)
+ FLAGS = \\(OOK,SHAREKEYS\\) # $] < 5.017
+ FLAGS = \\(OOK,OVERLOAD,SHAREKEYS\\) # $] >=5.017
IV = 1 # $] < 5.009
NV = $FLOAT # $] < 5.009
ARRAY = $ADDR
@@ -766,8 +790,182 @@
MAX = 7
RITER = -1
EITER = 0x0
+ RAND = $ADDR
NAMECOUNT = -3 # $] > 5.012
ENAME = "RWOM", "KLANK" # $] > 5.012
');
+SKIP: {
+ skip "Not built with usemymalloc", 1
+ unless $Config{usemymalloc} eq 'y';
+ my $x = __PACKAGE__;
+ ok eval { fill_mstats($x); 1 }, 'fill_mstats on COW scalar'
+ or diag $@;
+}
+
+# This is more a test of fbm_compile/pp_study (non) interaction than dumping
+# prowess, but short of duplicating all the gubbins of this file, I can't see
+# a way to make a better place for it:
+
+use constant {
+ perl => 'rules',
+ beer => 'foamy',
+};
+
+unless ($Config{useithreads}) {
+ # These end up as copies in pads under ithreads, which rather defeats the
+ # the point of what we're trying to test here.
+
+ do_test('regular string constant', perl,
+'SV = PV\\($ADDR\\) at $ADDR
+ REFCNT = 5
+ FLAGS = \\(PADMY,POK,READONLY,pPOK\\)
+ PV = $ADDR "rules"\\\0
+ CUR = 5
+ LEN = \d+
+');
+
+ eval 'index "", perl';
+
+ # FIXME - really this shouldn't say EVALED. It's a false posistive on
+ # 0x40000000 being used for several things, not a flag for "I'm in a string
+ # eval"
+
+ do_test('string constant now an FBM', perl,
+'SV = PVMG\\($ADDR\\) at $ADDR
+ REFCNT = 5
+ FLAGS = \\(PADMY,SMG,POK,READONLY,pPOK,VALID,EVALED\\)
+ PV = $ADDR "rules"\\\0
+ CUR = 5
+ LEN = \d+
+ MAGIC = $ADDR
+ MG_VIRTUAL = &PL_vtbl_regexp
+ MG_TYPE = PERL_MAGIC_bm\\(B\\)
+ MG_LEN = 256
+ MG_PTR = $ADDR "(?:\\\\\d){256}"
+ RARE = \d+
+ PREVIOUS = 1
+ USEFUL = 100
+');
+
+ is(study perl, '', "Not allowed to study an FBM");
+
+ do_test('string constant still an FBM', perl,
+'SV = PVMG\\($ADDR\\) at $ADDR
+ REFCNT = 5
+ FLAGS = \\(PADMY,SMG,POK,READONLY,pPOK,VALID,EVALED\\)
+ PV = $ADDR "rules"\\\0
+ CUR = 5
+ LEN = \d+
+ MAGIC = $ADDR
+ MG_VIRTUAL = &PL_vtbl_regexp
+ MG_TYPE = PERL_MAGIC_bm\\(B\\)
+ MG_LEN = 256
+ MG_PTR = $ADDR "(?:\\\\\d){256}"
+ RARE = \d+
+ PREVIOUS = 1
+ USEFUL = 100
+');
+
+ do_test('regular string constant', beer,
+'SV = PV\\($ADDR\\) at $ADDR
+ REFCNT = 6
+ FLAGS = \\(PADMY,POK,READONLY,pPOK\\)
+ PV = $ADDR "foamy"\\\0
+ CUR = 5
+ LEN = \d+
+');
+
+ is(study beer, 1, "Our studies were successful");
+
+ do_test('string constant quite unaffected', beer, 'SV = PV\\($ADDR\\) at $ADDR
+ REFCNT = 6
+ FLAGS = \\(PADMY,POK,READONLY,pPOK\\)
+ PV = $ADDR "foamy"\\\0
+ CUR = 5
+ LEN = \d+
+');
+
+ my $want = 'SV = PVMG\\($ADDR\\) at $ADDR
+ REFCNT = 6
+ FLAGS = \\(PADMY,SMG,POK,READONLY,pPOK,VALID,EVALED\\)
+ PV = $ADDR "foamy"\\\0
+ CUR = 5
+ LEN = \d+
+ MAGIC = $ADDR
+ MG_VIRTUAL = &PL_vtbl_regexp
+ MG_TYPE = PERL_MAGIC_bm\\(B\\)
+ MG_LEN = 256
+ MG_PTR = $ADDR "(?:\\\\\d){256}"
+ RARE = \d+
+ PREVIOUS = \d+
+ USEFUL = 100
+';
+
+ is (eval 'index "not too foamy", beer', 8, 'correct index');
+
+ do_test('string constant now FBMed', beer, $want);
+
+ my $pie = 'good';
+
+ is(study $pie, 1, "Our studies were successful");
+
+ do_test('string constant still FBMed', beer, $want);
+
+ do_test('second string also unaffected', $pie, 'SV = PV\\($ADDR\\) at $ADDR
+ REFCNT = 1
+ FLAGS = \\(PADMY,POK,pPOK\\)
+ PV = $ADDR "good"\\\0
+ CUR = 4
+ LEN = \d+
+');
+}
+
+# (One block of study tests removed when study was made a no-op.)
+
+{
+ open(OUT,">peek$$") or die "Failed to open peek $$: $!";
+ open(STDERR, ">&OUT") or die "Can't dup OUT: $!";
+ DeadCode();
+ open(STDERR, ">&SAVERR") or die "Can't restore STDERR: $!";
+ pass "no crash with DeadCode";
+ close OUT;
+}
+
+do_test('UTF-8 in a regular expression',
+ qr/\x{100}/,
+'SV = IV\($ADDR\) at $ADDR
+ REFCNT = 1
+ FLAGS = \(ROK\)
+ RV = $ADDR
+ SV = REGEXP\($ADDR\) at $ADDR
+ REFCNT = 1
+ FLAGS = \(OBJECT,FAKE,UTF8\)
+ PV = $ADDR "\(\?\^u:\\\\\\\\x\{100\}\)" \[UTF8 "\(\?\^u:\\\\\\\\x\{100\}\)"\]
+ CUR = 13
+ STASH = $ADDR "Regexp"
+ COMPFLAGS = 0x0 \(\)
+ EXTFLAGS = 0x680040 \(CHECK_ALL,USE_INTUIT_NOML,USE_INTUIT_ML\)
+ INTFLAGS = 0x0
+ NPARENS = 0
+ LASTPAREN = 0
+ LASTCLOSEPAREN = 0
+ MINLEN = 1
+ MINLENRET = 1
+ GOFS = 0
+ PRE_PREFIX = 5
+ SUBLEN = 0
+ SUBOFFSET = 0
+ SUBCOFFSET = 0
+ SUBBEG = 0x0
+ ENGINE = $ADDR
+ MOTHER_RE = $ADDR
+ PAREN_NAMES = 0x0
+ SUBSTRS = $ADDR
+ PPRIVATE = $ADDR
+ OFFS = $ADDR
+ QR_ANONCV = 0x0(?:
+ SAVED_COPY = 0x0)?
+');
+
done_testing();
Property changes on: trunk/contrib/perl/ext/Devel-Peek/t/Peek.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/ext/DynaLoader/DynaLoader_pm.PL
===================================================================
--- trunk/contrib/perl/ext/DynaLoader/DynaLoader_pm.PL 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/DynaLoader/DynaLoader_pm.PL 2013-12-02 21:32:26 UTC (rev 6445)
@@ -85,7 +85,7 @@
# Tim.Bunce at ig.co.uk, August 1994
BEGIN {
- $VERSION = '1.13';
+ $VERSION = '1.18';
}
use Config;
Property changes on: trunk/contrib/perl/ext/DynaLoader/DynaLoader_pm.PL
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Index: trunk/contrib/perl/ext/DynaLoader/Makefile.PL
===================================================================
--- trunk/contrib/perl/ext/DynaLoader/Makefile.PL 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/DynaLoader/Makefile.PL 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/DynaLoader/Makefile.PL
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Index: trunk/contrib/perl/ext/DynaLoader/README
===================================================================
--- trunk/contrib/perl/ext/DynaLoader/README 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/DynaLoader/README 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/DynaLoader/README
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Copied: trunk/contrib/perl/ext/DynaLoader/XSLoader_pm.PL (from rev 6437, vendor/perl/5.18.1/ext/DynaLoader/XSLoader_pm.PL)
===================================================================
--- trunk/contrib/perl/ext/DynaLoader/XSLoader_pm.PL (rev 0)
+++ trunk/contrib/perl/ext/DynaLoader/XSLoader_pm.PL 2013-12-02 21:32:26 UTC (rev 6445)
@@ -0,0 +1,407 @@
+use strict;
+use Config;
+
+sub to_string {
+ my ($value) = @_;
+ $value =~ s/\\/\\\\/g;
+ $value =~ s/'/\\'/g;
+ return "'$value'";
+}
+
+1 while unlink "XSLoader.pm";
+open OUT, ">XSLoader.pm" or die $!;
+print OUT <<'EOT';
+# Generated from XSLoader.pm.PL (resolved %Config::Config value)
+
+package XSLoader;
+
+$VERSION = "0.10";
+
+#use strict;
+
+# enable debug/trace messages from DynaLoader perl code
+# $dl_debug = $ENV{PERL_DL_DEBUG} || 0 unless defined $dl_debug;
+
+EOT
+
+print OUT ' my $dl_dlext = ', to_string($Config::Config{'dlext'}), ";\n" ;
+
+print OUT <<'EOT';
+
+package DynaLoader;
+
+# No prizes for guessing why we don't say 'bootstrap DynaLoader;' here.
+# NOTE: All dl_*.xs (including dl_none.xs) define a dl_error() XSUB
+boot_DynaLoader('DynaLoader') if defined(&boot_DynaLoader) &&
+ !defined(&dl_error);
+package XSLoader;
+
+sub load {
+ package DynaLoader;
+
+ die q{XSLoader::load('Your::Module', $Your::Module::VERSION)} unless @_;
+
+ my($module) = $_[0];
+
+ # work with static linking too
+ my $boots = "$module\::bootstrap";
+ goto &$boots if defined &$boots;
+
+ goto retry unless $module and defined &dl_load_file;
+
+ my @modparts = split(/::/,$module);
+ my $modfname = $modparts[-1];
+
+EOT
+
+print OUT <<'EOT' if defined &DynaLoader::mod2fname;
+ # Some systems have restrictions on files names for DLL's etc.
+ # mod2fname returns appropriate file base name (typically truncated)
+ # It may also edit @modparts if required.
+ $modfname = &mod2fname(\@modparts) if defined &mod2fname;
+
+EOT
+
+print OUT <<'EOT' if $^O eq 'os2';
+
+ # os2 static build can dynaload, but cannot dynaload Perl modules...
+ die 'Dynaloaded Perl modules are not available in this build of Perl' if $OS2::is_static;
+
+EOT
+
+print OUT <<'EOT';
+ my $modpname = join('/', at modparts);
+ my $modlibname = (caller())[1];
+ my $c = @modparts;
+ $modlibname =~ s,[\\/][^\\/]+$,, while $c--; # Q&D basename
+ my $file = "$modlibname/auto/$modpname/$modfname.$dl_dlext";
+
+# print STDERR "XSLoader::load for $module ($file)\n" if $dl_debug;
+
+ my $bs = $file;
+ $bs =~ s/(\.\w+)?(;\d*)?$/\.bs/; # look for .bs 'beside' the library
+
+ if (-s $bs) { # only read file if it's not empty
+# print STDERR "BS: $bs ($^O, $dlsrc)\n" if $dl_debug;
+ eval { do $bs; };
+ warn "$bs: $@\n" if $@;
+ }
+
+ goto retry if not -f $file or -s $bs;
+
+ my $bootname = "boot_$module";
+ $bootname =~ s/\W/_/g;
+ @DynaLoader::dl_require_symbols = ($bootname);
+
+ my $boot_symbol_ref;
+
+EOT
+
+ if ($^O eq 'darwin') {
+print OUT <<'EOT';
+ if ($boot_symbol_ref = dl_find_symbol(0, $bootname)) {
+ goto boot; #extension library has already been loaded, e.g. darwin
+ }
+EOT
+ }
+
+print OUT <<'EOT';
+ # Many dynamic extension loading problems will appear to come from
+ # this section of code: XYZ failed at line 123 of DynaLoader.pm.
+ # Often these errors are actually occurring in the initialisation
+ # C code of the extension XS file. Perl reports the error as being
+ # in this perl code simply because this was the last perl code
+ # it executed.
+
+ my $libref = dl_load_file($file, 0) or do {
+ require Carp;
+ Carp::croak("Can't load '$file' for module $module: " . dl_error());
+ };
+ push(@DynaLoader::dl_librefs,$libref); # record loaded object
+
+ my @unresolved = dl_undef_symbols();
+ if (@unresolved) {
+ require Carp;
+ Carp::carp("Undefined symbols present after loading $file: @unresolved\n");
+ }
+
+ $boot_symbol_ref = dl_find_symbol($libref, $bootname) or do {
+ require Carp;
+ Carp::croak("Can't find '$bootname' symbol in $file\n");
+ };
+
+ push(@DynaLoader::dl_modules, $module); # record loaded module
+
+ boot:
+ my $xs = dl_install_xsub($boots, $boot_symbol_ref, $file);
+
+ # See comment block above
+ push(@DynaLoader::dl_shared_objects, $file); # record files loaded
+ return &$xs(@_);
+
+ retry:
+ my $bootstrap_inherit = DynaLoader->can('bootstrap_inherit') ||
+ XSLoader->can('bootstrap_inherit');
+ goto &$bootstrap_inherit;
+}
+
+# Versions of DynaLoader prior to 5.6.0 don't have this function.
+sub bootstrap_inherit {
+ package DynaLoader;
+
+ my $module = $_[0];
+ local *DynaLoader::isa = *{"$module\::ISA"};
+ local @DynaLoader::isa = (@DynaLoader::isa, 'DynaLoader');
+ # Cannot goto due to delocalization. Will report errors on a wrong line?
+ require DynaLoader;
+ DynaLoader::bootstrap(@_);
+}
+
+1;
+
+
+__END__
+
+=head1 NAME
+
+XSLoader - Dynamically load C libraries into Perl code
+
+=head1 VERSION
+
+Version 0.10
+
+=head1 SYNOPSIS
+
+ package YourPackage;
+ use XSLoader;
+
+ XSLoader::load 'YourPackage', $YourPackage::VERSION;
+
+=head1 DESCRIPTION
+
+This module defines a standard I<simplified> interface to the dynamic
+linking mechanisms available on many platforms. Its primary purpose is
+to implement cheap automatic dynamic loading of Perl modules.
+
+For a more complicated interface, see L<DynaLoader>. Many (most)
+features of C<DynaLoader> are not implemented in C<XSLoader>, like for
+example the C<dl_load_flags>, not honored by C<XSLoader>.
+
+=head2 Migration from C<DynaLoader>
+
+A typical module using L<DynaLoader|DynaLoader> starts like this:
+
+ package YourPackage;
+ require DynaLoader;
+
+ our @ISA = qw( OnePackage OtherPackage DynaLoader );
+ our $VERSION = '0.01';
+ bootstrap YourPackage $VERSION;
+
+Change this to
+
+ package YourPackage;
+ use XSLoader;
+
+ our @ISA = qw( OnePackage OtherPackage );
+ our $VERSION = '0.01';
+ XSLoader::load 'YourPackage', $VERSION;
+
+In other words: replace C<require DynaLoader> by C<use XSLoader>, remove
+C<DynaLoader> from C<@ISA>, change C<bootstrap> by C<XSLoader::load>. Do not
+forget to quote the name of your package on the C<XSLoader::load> line,
+and add comma (C<,>) before the arguments (C<$VERSION> above).
+
+Of course, if C<@ISA> contained only C<DynaLoader>, there is no need to have
+the C<@ISA> assignment at all; moreover, if instead of C<our> one uses the
+more backward-compatible
+
+ use vars qw($VERSION @ISA);
+
+one can remove this reference to C<@ISA> together with the C<@ISA> assignment.
+
+If no C<$VERSION> was specified on the C<bootstrap> line, the last line becomes
+
+ XSLoader::load 'YourPackage';
+
+=head2 Backward compatible boilerplate
+
+If you want to have your cake and eat it too, you need a more complicated
+boilerplate.
+
+ package YourPackage;
+ use vars qw($VERSION @ISA);
+
+ @ISA = qw( OnePackage OtherPackage );
+ $VERSION = '0.01';
+ eval {
+ require XSLoader;
+ XSLoader::load('YourPackage', $VERSION);
+ 1;
+ } or do {
+ require DynaLoader;
+ push @ISA, 'DynaLoader';
+ bootstrap YourPackage $VERSION;
+ };
+
+The parentheses about C<XSLoader::load()> arguments are needed since we replaced
+C<use XSLoader> by C<require>, so the compiler does not know that a function
+C<XSLoader::load()> is present.
+
+This boilerplate uses the low-overhead C<XSLoader> if present; if used with
+an antic Perl which has no C<XSLoader>, it falls back to using C<DynaLoader>.
+
+=head1 Order of initialization: early load()
+
+I<Skip this section if the XSUB functions are supposed to be called from other
+modules only; read it only if you call your XSUBs from the code in your module,
+or have a C<BOOT:> section in your XS file (see L<perlxs/"The BOOT: Keyword">).
+What is described here is equally applicable to the L<DynaLoader|DynaLoader>
+interface.>
+
+A sufficiently complicated module using XS would have both Perl code (defined
+in F<YourPackage.pm>) and XS code (defined in F<YourPackage.xs>). If this
+Perl code makes calls into this XS code, and/or this XS code makes calls to
+the Perl code, one should be careful with the order of initialization.
+
+The call to C<XSLoader::load()> (or C<bootstrap()>) has three side effects:
+
+=over
+
+=item *
+
+if C<$VERSION> was specified, a sanity check is done to ensure that the
+versions of the F<.pm> and the (compiled) F<.xs> parts are compatible;
+
+=item *
+
+the XSUBs are made accessible from Perl;
+
+=item *
+
+if a C<BOOT:> section was present in the F<.xs> file, the code there is called.
+
+=back
+
+Consequently, if the code in the F<.pm> file makes calls to these XSUBs, it is
+convenient to have XSUBs installed before the Perl code is defined; for
+example, this makes prototypes for XSUBs visible to this Perl code.
+Alternatively, if the C<BOOT:> section makes calls to Perl functions (or
+uses Perl variables) defined in the F<.pm> file, they must be defined prior to
+the call to C<XSLoader::load()> (or C<bootstrap()>).
+
+The first situation being much more frequent, it makes sense to rewrite the
+boilerplate as
+
+ package YourPackage;
+ use XSLoader;
+ use vars qw($VERSION @ISA);
+
+ BEGIN {
+ @ISA = qw( OnePackage OtherPackage );
+ $VERSION = '0.01';
+
+ # Put Perl code used in the BOOT: section here
+
+ XSLoader::load 'YourPackage', $VERSION;
+ }
+
+ # Put Perl code making calls into XSUBs here
+
+=head2 The most hairy case
+
+If the interdependence of your C<BOOT:> section and Perl code is
+more complicated than this (e.g., the C<BOOT:> section makes calls to Perl
+functions which make calls to XSUBs with prototypes), get rid of the C<BOOT:>
+section altogether. Replace it with a function C<onBOOT()>, and call it like
+this:
+
+ package YourPackage;
+ use XSLoader;
+ use vars qw($VERSION @ISA);
+
+ BEGIN {
+ @ISA = qw( OnePackage OtherPackage );
+ $VERSION = '0.01';
+ XSLoader::load 'YourPackage', $VERSION;
+ }
+
+ # Put Perl code used in onBOOT() function here; calls to XSUBs are
+ # prototype-checked.
+
+ onBOOT;
+
+ # Put Perl initialization code assuming that XS is initialized here
+
+
+=head1 DIAGNOSTICS
+
+=over
+
+=item C<Can't find '%s' symbol in %s>
+
+B<(F)> The bootstrap symbol could not be found in the extension module.
+
+=item C<Can't load '%s' for module %s: %s>
+
+B<(F)> The loading or initialisation of the extension module failed.
+The detailed error follows.
+
+=item C<Undefined symbols present after loading %s: %s>
+
+B<(W)> As the message says, some symbols stay undefined although the
+extension module was correctly loaded and initialised. The list of undefined
+symbols follows.
+
+=item C<XSLoader::load('Your::Module', $Your::Module::VERSION)>
+
+B<(F)> You tried to invoke C<load()> without any argument. You must supply
+a module name, and optionally its version.
+
+=back
+
+
+=head1 LIMITATIONS
+
+To reduce the overhead as much as possible, only one possible location
+is checked to find the extension DLL (this location is where C<make install>
+would put the DLL). If not found, the search for the DLL is transparently
+delegated to C<DynaLoader>, which looks for the DLL along the C<@INC> list.
+
+In particular, this is applicable to the structure of C<@INC> used for testing
+not-yet-installed extensions. This means that running uninstalled extensions
+may have much more overhead than running the same extensions after
+C<make install>.
+
+
+=head1 BUGS
+
+Please report any bugs or feature requests via the perlbug(1) utility.
+
+
+=head1 SEE ALSO
+
+L<DynaLoader>
+
+
+=head1 AUTHORS
+
+Ilya Zakharevich originally extracted C<XSLoader> from C<DynaLoader>.
+
+CPAN version is currently maintained by SE<eacute>bastien Aperghis-Tramoni
+E<lt>sebastien at aperghis.netE<gt>.
+
+Previous maintainer was Michael G Schwern <schwern at pobox.com>.
+
+
+=head1 COPYRIGHT & LICENSE
+
+Copyright (C) 1990-2007 by Larry Wall and others.
+
+This program is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
+EOT
+
+close OUT or die $!;
Modified: trunk/contrib/perl/ext/DynaLoader/dl_aix.xs
===================================================================
--- trunk/contrib/perl/ext/DynaLoader/dl_aix.xs 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/DynaLoader/dl_aix.xs 2013-12-02 21:32:26 UTC (rev 6445)
@@ -210,7 +210,7 @@
{
dTHX;
dMY_CXT;
- register ModulePtr mp;
+ ModulePtr mp;
/*
* Upon the first call register a terminate handler that will
@@ -316,7 +316,7 @@
{
dTHX;
dMY_CXT;
- register char *p = s;
+ char *p = s;
while (*p >= '0' && *p <= '9')
p++;
@@ -353,9 +353,9 @@
{
dTHX;
dMY_CXT;
- register ModulePtr mp = (ModulePtr)handle;
- register ExportPtr ep;
- register int i;
+ ModulePtr mp = (ModulePtr)handle;
+ ExportPtr ep;
+ int i;
/*
* Could speed up search, but I assume that one assigns
@@ -385,9 +385,9 @@
{
dTHX;
dMY_CXT;
- register ModulePtr mp = (ModulePtr)handle;
+ ModulePtr mp = (ModulePtr)handle;
int result;
- register ModulePtr mp1;
+ ModulePtr mp1;
if (--mp->refCnt > 0)
return 0;
@@ -397,8 +397,8 @@
strerrorcpy(dl_errbuf, errno);
}
if (mp->exports) {
- register ExportPtr ep;
- register int i;
+ ExportPtr ep;
+ int i;
for (ep = mp->exports, i = mp->nExports; i; i--, ep++)
if (ep->name)
safefree(ep->name);
@@ -688,21 +688,24 @@
(void)dl_private_init(aTHX);
-void *
+void
dl_load_file(filename, flags=0)
char * filename
int flags
- CODE:
+ PREINIT:
+ void *retv;
+ PPCODE:
DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_load_file(%s,%x):\n", filename,flags));
if (flags & 0x01)
Perl_warn(aTHX_ "Can't make loaded symbols global on this platform while loading %s",filename);
- RETVAL = dlopen(filename, RTLD_GLOBAL|RTLD_LAZY) ;
- DLDEBUG(2,PerlIO_printf(Perl_debug_log, " libref=%x\n", RETVAL));
+ retv = dlopen(filename, RTLD_GLOBAL|RTLD_LAZY) ;
+ DLDEBUG(2,PerlIO_printf(Perl_debug_log, " libref=%x\n", retv));
ST(0) = sv_newmortal() ;
- if (RETVAL == NULL)
+ if (retv == NULL)
SaveError(aTHX_ "%s",dlerror()) ;
else
- sv_setiv( ST(0), PTR2IV(RETVAL) );
+ sv_setiv( ST(0), PTR2IV(retv) );
+ XSRETURN(1);
int
dl_unload_file(libref)
@@ -716,25 +719,27 @@
OUTPUT:
RETVAL
-void *
+void
dl_find_symbol(libhandle, symbolname)
void * libhandle
char * symbolname
- CODE:
+ PREINIT:
+ void *retv;
+ CODE:
DLDEBUG(2,PerlIO_printf(Perl_debug_log, "dl_find_symbol(handle=%x, symbol=%s)\n",
libhandle, symbolname));
- RETVAL = dlsym(libhandle, symbolname);
- DLDEBUG(2,PerlIO_printf(Perl_debug_log, " symbolref = %x\n", RETVAL));
+ retv = dlsym(libhandle, symbolname);
+ DLDEBUG(2,PerlIO_printf(Perl_debug_log, " symbolref = %x\n", retv));
ST(0) = sv_newmortal() ;
- if (RETVAL == NULL)
+ if (retv == NULL)
SaveError(aTHX_ "%s",dlerror()) ;
else
- sv_setiv( ST(0), PTR2IV(RETVAL));
+ sv_setiv( ST(0), PTR2IV(retv));
void
dl_undef_symbols()
- PPCODE:
+ CODE:
Property changes on: trunk/contrib/perl/ext/DynaLoader/dl_aix.xs
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Index: trunk/contrib/perl/ext/DynaLoader/dl_beos.xs
===================================================================
--- trunk/contrib/perl/ext/DynaLoader/dl_beos.xs 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/DynaLoader/dl_beos.xs 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/DynaLoader/dl_beos.xs
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/ext/DynaLoader/dl_dld.xs
===================================================================
--- trunk/contrib/perl/ext/DynaLoader/dl_dld.xs 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/DynaLoader/dl_dld.xs 2013-12-02 21:32:26 UTC (rev 6445)
@@ -7,12 +7,12 @@
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
*
- * $Date: 2011-02-17 12:49:41 $
- * $Source: /home/cvs/src/contrib/perl/ext/DynaLoader/dl_dld.xs,v $
- * $Revision: 1.1.1.2 $
+ * $Date: 1994/03/07 00:21:43 $
+ * $Source: /home/rsanders/src/perl5alpha6/RCS/dld_dl.c,v $
+ * $Revision: 1.4 $
* $State: Exp $
*
- * $Log: not supported by cvs2svn $
+ * $Log: dld_dl.c,v $
* Removed implicit link against libc. 1994/09/14 William Setzer.
*
* Integrated other DynaLoader changes. 1994/06/08 Tim Bunce.
Property changes on: trunk/contrib/perl/ext/DynaLoader/dl_dld.xs
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/ext/DynaLoader/dl_dllload.xs
===================================================================
--- trunk/contrib/perl/ext/DynaLoader/dl_dllload.xs 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/DynaLoader/dl_dllload.xs 2013-12-02 21:32:26 UTC (rev 6445)
@@ -105,24 +105,24 @@
(void)dl_private_init(aTHX);
-void *
+void
dl_load_file(filename, flags=0)
char * filename
int flags
PREINIT:
int mode = 0;
- CODE:
-{
+ void *retv;
+ PPCODE:
DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_load_file(%s,%x):\n", filename,flags));
/* add a (void *) dllload(filename) ; cast if needed */
- RETVAL = dllload(filename) ;
- DLDEBUG(2,PerlIO_printf(Perl_debug_log, " libref=%lx\n", (unsigned long) RETVAL));
+ retv = dllload(filename) ;
+ DLDEBUG(2,PerlIO_printf(Perl_debug_log, " libref=%lx\n", (unsigned long) retv));
ST(0) = sv_newmortal() ;
- if (RETVAL == NULL)
+ if (retv == NULL)
SaveError(aTHX_ "%s",strerror(errno)) ;
else
- sv_setiv( ST(0), PTR2IV(RETVAL));
-}
+ sv_setiv( ST(0), PTR2IV(retv));
+ XSRETURN(1);
int
@@ -139,28 +139,31 @@
RETVAL
-void *
+void
dl_find_symbol(libhandle, symbolname)
void * libhandle
char * symbolname
- CODE:
+ PREINIT:
+ void *retv;
+ PPCODE:
DLDEBUG(2, PerlIO_printf(Perl_debug_log,
"dl_find_symbol(handle=%lx, symbol=%s)\n",
(unsigned long) libhandle, symbolname));
- if((RETVAL = (void*)dllqueryfn(libhandle, symbolname)) == NULL)
- RETVAL = dllqueryvar(libhandle, symbolname);
+ if((retv = (void*)dllqueryfn(libhandle, symbolname)) == NULL)
+ retv = dllqueryvar(libhandle, symbolname);
DLDEBUG(2, PerlIO_printf(Perl_debug_log,
- " symbolref = %lx\n", (unsigned long) RETVAL));
+ " symbolref = %lx\n", (unsigned long) retv));
ST(0) = sv_newmortal() ;
- if (RETVAL == NULL)
+ if (retv == NULL)
SaveError(aTHX_ "%s",strerror(errno)) ;
else
- sv_setiv( ST(0), PTR2IV(RETVAL));
+ sv_setiv( ST(0), PTR2IV(retv));
+ XSRETURN(1);
void
dl_undef_symbols()
- PPCODE:
+ CODE:
@@ -171,7 +174,7 @@
char * perl_name
void * symref
const char * filename
- CODE:
+ PPCODE:
DLDEBUG(2,PerlIO_printf(Perl_debug_log, "dl_install_xsub(name=%s, symref=%lx)\n",
perl_name, (unsigned long) symref));
ST(0) = sv_2mortal(newRV((SV*)newXS_flags(perl_name,
@@ -178,6 +181,7 @@
(void(*)(pTHX_ CV *))symref,
filename, NULL,
XS_DYNAMIC_FILENAME)));
+ XSRETURN(1);
char *
Property changes on: trunk/contrib/perl/ext/DynaLoader/dl_dllload.xs
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/ext/DynaLoader/dl_dlopen.xs
===================================================================
--- trunk/contrib/perl/ext/DynaLoader/dl_dlopen.xs 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/DynaLoader/dl_dlopen.xs 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/DynaLoader/dl_dlopen.xs
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Index: trunk/contrib/perl/ext/DynaLoader/dl_dyld.xs
===================================================================
--- trunk/contrib/perl/ext/DynaLoader/dl_dyld.xs 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/DynaLoader/dl_dyld.xs 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/DynaLoader/dl_dyld.xs
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/ext/DynaLoader/dl_hpux.xs
===================================================================
--- trunk/contrib/perl/ext/DynaLoader/dl_hpux.xs 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/DynaLoader/dl_hpux.xs 2013-12-02 21:32:26 UTC (rev 6445)
@@ -51,7 +51,7 @@
(void)dl_private_init(aTHX);
-void *
+void
dl_load_file(filename, flags=0)
char * filename
int flags
@@ -115,7 +115,7 @@
RETVAL
-void *
+void
dl_find_symbol(libhandle, symbolname)
void * libhandle
char * symbolname
@@ -150,7 +150,7 @@
void
dl_undef_symbols()
- PPCODE:
+ CODE:
Property changes on: trunk/contrib/perl/ext/DynaLoader/dl_hpux.xs
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Copied: trunk/contrib/perl/ext/DynaLoader/dl_mac.xs (from rev 6437, vendor/perl/5.18.1/ext/DynaLoader/dl_mac.xs)
===================================================================
--- trunk/contrib/perl/ext/DynaLoader/dl_mac.xs (rev 0)
+++ trunk/contrib/perl/ext/DynaLoader/dl_mac.xs 2013-12-02 21:32:26 UTC (rev 6445)
@@ -0,0 +1,162 @@
+/* dl_mac.xs
+ *
+ * Platform: Macintosh CFM
+ * Author: Matthias Neeracher <neeri at iis.ee.ethz.ch>
+ * Adapted from dl_dlopen.xs reference implementation by
+ * Paul Marquess (pmarquess at bfsec.bt.co.uk)
+ * $Log: not supported by cvs2svn $
+ * Revision 1.3 1998/04/07 01:47:24 neeri
+ * MacPerl 5.2.0r4b1
+ *
+ * Revision 1.2 1997/08/08 16:39:18 neeri
+ * MacPerl 5.1.4b1 + time() fix
+ *
+ * Revision 1.1 1997/04/07 20:48:23 neeri
+ * Synchronized with MacPerl 5.1.4a1
+ *
+ */
+
+#define MAC_CONTEXT
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+#include <CodeFragments.h>
+
+typedef CFragConnectionID ConnectionID;
+
+typedef struct {
+ ConnectionID ** x_connections;
+} my_cxtx_t; /* this *must* be named my_cxtx_t */
+
+#define DL_CXT_EXTRA /* ask for dl_cxtx to be defined in dlutils.c */
+#include "dlutils.c" /* SaveError() etc */
+
+#define dl_connections (dl_cxtx.x_connections)
+
+static void terminate(pTHX_ void *ptr)
+{
+ dMY_CXT;
+ int size = GetHandleSize((Handle) dl_connections) / sizeof(ConnectionID);
+ HLock((Handle) dl_connections);
+ while (size)
+ CloseConnection(*dl_connections + --size);
+ DisposeHandle((Handle) dl_connections);
+ dl_connections = nil;
+}
+
+static void
+dl_private_init(pTHX)
+{
+ (void)dl_generic_private_init(aTHX);
+}
+
+MODULE = DynaLoader PACKAGE = DynaLoader
+
+BOOT:
+ (void)dl_private_init(aTHX);
+
+
+ConnectionID
+dl_load_file(filename, flags=0)
+ char * filename
+ int flags
+ PREINIT:
+ OSErr err;
+ FSSpec spec;
+ ConnectionID connID;
+ Ptr mainAddr;
+ Str255 errName;
+ CODE:
+ DLDEBUG(1,PerlIO_printf(Perl_debug_log,"dl_load_file(%s):\n", filename));
+ err = GUSIPath2FSp(filename, &spec);
+ if (!err)
+ err =
+ GetDiskFragment(
+ &spec, 0, 0, spec.name, kLoadCFrag, &connID, &mainAddr, errName);
+ if (!err) {
+ dMY_CXT;
+ if (!dl_connections) {
+ dl_connections = (ConnectionID **)NewHandle(0);
+ call_atexit(terminate, (void*)0);
+ }
+ PtrAndHand((Ptr) &connID, (Handle) dl_connections, sizeof(ConnectionID));
+ RETVAL = connID;
+ } else
+ RETVAL = (ConnectionID) 0;
+ DLDEBUG(2,PerlIO_printf(Perl_debug_log," libref=%d\n", RETVAL));
+ ST(0) = sv_newmortal() ;
+ if (err)
+ SaveError(aTHX_ "DynaLoader error [%d, %#s]", err, errName) ;
+ else
+ sv_setiv( ST(0), (IV)RETVAL);
+
+void *
+dl_find_symbol(connID, symbol)
+ ConnectionID connID
+ Str255 symbol
+ CODE:
+ {
+ OSErr err;
+ Ptr symAddr;
+ CFragSymbolClass symClass;
+ DLDEBUG(2,PerlIO_printf(Perl_debug_log,"dl_find_symbol(handle=%x, symbol=%#s)\n",
+ connID, symbol));
+ err = FindSymbol(connID, symbol, &symAddr, &symClass);
+ if (err)
+ symAddr = (Ptr) 0;
+ RETVAL = (void *) symAddr;
+ DLDEBUG(2,PerlIO_printf(Perl_debug_log," symbolref = %x\n", RETVAL));
+ ST(0) = sv_newmortal() ;
+ if (err)
+ SaveError(aTHX_ "DynaLoader error [%d]!", err) ;
+ else
+ sv_setiv( ST(0), (IV)RETVAL);
+ }
+
+void
+dl_undef_symbols()
+ PPCODE:
+
+
+
+# These functions should not need changing on any platform:
+
+void
+dl_install_xsub(perl_name, symref, filename="$Package")
+ char * perl_name
+ void * symref
+ const char * filename
+ CODE:
+ DLDEBUG(2,PerlIO_printf(Perl_debug_log,"dl_install_xsub(name=%s, symref=%x)\n",
+ perl_name, symref));
+ ST(0) = sv_2mortal(newRV((SV*)newXS_flags(perl_name,
+ (void(*)(pTHX_ CV *))symref,
+ filename, NULL,
+ XS_DYNAMIC_FILENAME)));
+
+
+char *
+dl_error()
+ CODE:
+ dMY_CXT;
+ RETVAL = dl_last_error ;
+ OUTPUT:
+ RETVAL
+
+#if defined(USE_ITHREADS)
+
+void
+CLONE(...)
+ CODE:
+ MY_CXT_CLONE;
+
+ /* MY_CXT_CLONE just does a memcpy on the whole structure, so to avoid
+ * using Perl variables that belong to another thread, we create our
+ * own for this thread.
+ */
+ MY_CXT.x_dl_last_error = newSVpvn("", 0);
+
+#endif
+
+# end.
Index: trunk/contrib/perl/ext/DynaLoader/dl_mpeix.xs
===================================================================
--- trunk/contrib/perl/ext/DynaLoader/dl_mpeix.xs 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/DynaLoader/dl_mpeix.xs 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/DynaLoader/dl_mpeix.xs
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/ext/DynaLoader/dl_next.xs
===================================================================
--- trunk/contrib/perl/ext/DynaLoader/dl_next.xs 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/DynaLoader/dl_next.xs 2013-12-02 21:32:26 UTC (rev 6445)
@@ -251,29 +251,32 @@
-void *
+void
dl_load_file(filename, flags=0)
char * filename
int flags
PREINIT:
int mode = 1;
+ void *retv;
CODE:
DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_load_file(%s,%x):\n", filename,flags));
if (flags & 0x01)
Perl_warn(aTHX_ "Can't make loaded symbols global on this platform while loading %s",filename);
- RETVAL = dlopen(filename, mode) ;
- DLDEBUG(2,PerlIO_printf(Perl_debug_log, " libref=%x\n", RETVAL));
+ retv = dlopen(filename, mode) ;
+ DLDEBUG(2,PerlIO_printf(Perl_debug_log, " libref=%x\n", retv));
ST(0) = sv_newmortal() ;
- if (RETVAL == NULL)
+ if (retv == NULL)
SaveError(aTHX_ "%s",dlerror()) ;
else
- sv_setiv( ST(0), PTR2IV(RETVAL) );
+ sv_setiv( ST(0), PTR2IV(retv) );
-void *
+void
dl_find_symbol(libhandle, symbolname)
void * libhandle
char * symbolname
+ PREINIT:
+ void *retv;
CODE:
#if NS_TARGET_MAJOR >= 4
symbolname = Perl_form_nocontext("_%s", symbolname);
@@ -281,19 +284,19 @@
DLDEBUG(2, PerlIO_printf(Perl_debug_log,
"dl_find_symbol(handle=%lx, symbol=%s)\n",
(unsigned long) libhandle, symbolname));
- RETVAL = dlsym(libhandle, symbolname);
+ retv = dlsym(libhandle, symbolname);
DLDEBUG(2, PerlIO_printf(Perl_debug_log,
- " symbolref = %lx\n", (unsigned long) RETVAL));
+ " symbolref = %lx\n", (unsigned long) retv));
ST(0) = sv_newmortal() ;
- if (RETVAL == NULL)
+ if (retv == NULL)
SaveError(aTHX_ "%s",dlerror()) ;
else
- sv_setiv( ST(0), PTR2IV(RETVAL) );
+ sv_setiv( ST(0), PTR2IV(retv) );
void
dl_undef_symbols()
- PPCODE:
+ CODE:
Property changes on: trunk/contrib/perl/ext/DynaLoader/dl_next.xs
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/ext/DynaLoader/dl_none.xs
===================================================================
--- trunk/contrib/perl/ext/DynaLoader/dl_none.xs 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/DynaLoader/dl_none.xs 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/DynaLoader/dl_none.xs
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/DynaLoader/dl_symbian.xs
===================================================================
--- trunk/contrib/perl/ext/DynaLoader/dl_symbian.xs 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/DynaLoader/dl_symbian.xs 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/DynaLoader/dl_symbian.xs
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/DynaLoader/dl_vmesa.xs
===================================================================
--- trunk/contrib/perl/ext/DynaLoader/dl_vmesa.xs 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/DynaLoader/dl_vmesa.xs 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/DynaLoader/dl_vmesa.xs
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/ext/DynaLoader/dl_vms.xs
===================================================================
--- trunk/contrib/perl/ext/DynaLoader/dl_vms.xs 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/DynaLoader/dl_vms.xs 2013-12-02 21:32:26 UTC (rev 6445)
@@ -127,7 +127,7 @@
struct dsc$descriptor_s *defspec)
{
unsigned long int retsts;
- VAXC$ESTABLISH(lib$sig_to_ret);
+ VAXC$ESTABLISH((__vms_handler)lib$sig_to_ret);
retsts = lib$find_image_symbol(imgname,symname,entry,defspec,DL_CASE_SENSITIVE);
return retsts;
}
Property changes on: trunk/contrib/perl/ext/DynaLoader/dl_vms.xs
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/ext/DynaLoader/dl_win32.xs
===================================================================
--- trunk/contrib/perl/ext/DynaLoader/dl_win32.xs 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/DynaLoader/dl_win32.xs 2013-12-02 21:32:26 UTC (rev 6445)
@@ -67,9 +67,9 @@
static int
dl_static_linked(char *filename)
{
- char **p;
+ const char * const *p;
char *ptr, *hptr;
- static char subStr[] = "/auto/";
+ static const char subStr[] = "/auto/";
char szBuffer[MAX_PATH];
/* avoid buffer overflow when called with invalid filenames */
@@ -111,26 +111,27 @@
BOOT:
(void)dl_private_init(aTHX);
-void *
+void
dl_load_file(filename,flags=0)
char * filename
int flags
PREINIT:
+ void *retv;
CODE:
{
DLDEBUG(1,PerlIO_printf(Perl_debug_log,"dl_load_file(%s):\n", filename));
if (dl_static_linked(filename) == 0) {
- RETVAL = PerlProc_DynaLoad(filename);
+ retv = PerlProc_DynaLoad(filename);
}
else
- RETVAL = (void*) Win_GetModuleHandle(NULL);
- DLDEBUG(2,PerlIO_printf(Perl_debug_log," libref=%x\n", RETVAL));
+ retv = (void*) Win_GetModuleHandle(NULL);
+ DLDEBUG(2,PerlIO_printf(Perl_debug_log," libref=%x\n", retv));
ST(0) = sv_newmortal() ;
- if (RETVAL == NULL)
+ if (retv == NULL)
SaveError(aTHX_ "load_file:%s",
OS_Error_String(aTHX)) ;
else
- sv_setiv( ST(0), (IV)RETVAL);
+ sv_setiv( ST(0), (IV)retv);
}
int
@@ -145,26 +146,28 @@
OUTPUT:
RETVAL
-void *
+void
dl_find_symbol(libhandle, symbolname)
void * libhandle
char * symbolname
+ PREINIT:
+ void *retv;
CODE:
DLDEBUG(2,PerlIO_printf(Perl_debug_log,"dl_find_symbol(handle=%x, symbol=%s)\n",
libhandle, symbolname));
- RETVAL = (void*) GetProcAddress((HINSTANCE) libhandle, symbolname);
- DLDEBUG(2,PerlIO_printf(Perl_debug_log," symbolref = %x\n", RETVAL));
+ retv = (void*) GetProcAddress((HINSTANCE) libhandle, symbolname);
+ DLDEBUG(2,PerlIO_printf(Perl_debug_log," symbolref = %x\n", retv));
ST(0) = sv_newmortal() ;
- if (RETVAL == NULL)
+ if (retv == NULL)
SaveError(aTHX_ "find_symbol:%s",
OS_Error_String(aTHX)) ;
else
- sv_setiv( ST(0), (IV)RETVAL);
+ sv_setiv( ST(0), (IV)retv);
void
dl_undef_symbols()
- PPCODE:
+ CODE:
Property changes on: trunk/contrib/perl/ext/DynaLoader/dl_win32.xs
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/ext/DynaLoader/dlutils.c
===================================================================
--- trunk/contrib/perl/ext/DynaLoader/dlutils.c 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/DynaLoader/dlutils.c 2013-12-02 21:32:26 UTC (rev 6445)
@@ -8,6 +8,7 @@
* files when the interpreter exits
*/
+#define PERL_EUPXS_ALWAYS_EXPORT
#ifndef START_MY_CXT /* Some IDEs try compiling this standalone. */
# include "EXTERN.h"
# include "perl.h"
Property changes on: trunk/contrib/perl/ext/DynaLoader/dlutils.c
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Index: trunk/contrib/perl/ext/DynaLoader/hints/aix.pl
===================================================================
--- trunk/contrib/perl/ext/DynaLoader/hints/aix.pl 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/DynaLoader/hints/aix.pl 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/DynaLoader/hints/aix.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/DynaLoader/hints/gnukfreebsd.pl
===================================================================
--- trunk/contrib/perl/ext/DynaLoader/hints/gnukfreebsd.pl 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/DynaLoader/hints/gnukfreebsd.pl 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/DynaLoader/hints/gnukfreebsd.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/DynaLoader/hints/gnuknetbsd.pl
===================================================================
--- trunk/contrib/perl/ext/DynaLoader/hints/gnuknetbsd.pl 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/DynaLoader/hints/gnuknetbsd.pl 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/DynaLoader/hints/gnuknetbsd.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/DynaLoader/hints/linux.pl
===================================================================
--- trunk/contrib/perl/ext/DynaLoader/hints/linux.pl 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/DynaLoader/hints/linux.pl 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/DynaLoader/hints/linux.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/DynaLoader/hints/netbsd.pl
===================================================================
--- trunk/contrib/perl/ext/DynaLoader/hints/netbsd.pl 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/DynaLoader/hints/netbsd.pl 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/DynaLoader/hints/netbsd.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/DynaLoader/hints/openbsd.pl
===================================================================
--- trunk/contrib/perl/ext/DynaLoader/hints/openbsd.pl 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/DynaLoader/hints/openbsd.pl 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/DynaLoader/hints/openbsd.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/ext/DynaLoader/t/DynaLoader.t
===================================================================
--- trunk/contrib/perl/ext/DynaLoader/t/DynaLoader.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/DynaLoader/t/DynaLoader.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -32,6 +32,11 @@
# Try to load the module
use_ok( 'DynaLoader' );
+# Some tests need to be skipped on old Darwin versions.
+# Commit ce12ed1954 added the skip originally, without specifying which
+# darwin version needed it. I know OS X 10.6 (Snow Leopard; darwin 10)
+# supports it, so skip anything before that.
+my $old_darwin = $^O eq 'darwin' && ($Config{osvers} =~ /^(\d+)/)[0] < 10;
# Check functions
can_ok( 'DynaLoader' => 'bootstrap' ); # defined in Perl section
@@ -43,7 +48,7 @@
can_ok( 'DynaLoader' => 'dl_load_file' ); # defined in XS section
can_ok( 'DynaLoader' => 'dl_undef_symbols' ); # defined in XS section
SKIP: {
- skip "unloading unsupported on $^O", 1 if ($^O eq 'VMS' || $^O eq 'darwin');
+ skip "unloading unsupported on $^O", 1 if ($old_darwin || $^O eq 'VMS');
can_ok( 'DynaLoader' => 'dl_unload_file' ); # defined in XS section
}
} else {
@@ -137,8 +142,9 @@
my @loaded_modules = @DynaLoader::dl_modules;
for my $libref (reverse @DynaLoader::dl_librefs) {
SKIP: {
- skip "unloading unsupported on $^O", 2 if ($^O eq 'VMS' || $^O eq 'darwin');
+ skip "unloading unsupported on $^O", 2 if ($old_darwin || $^O eq 'VMS');
my $module = pop @loaded_modules;
+ skip "File::Glob sets PL_opfreehook", 2 if $module eq 'File::Glob';
my $r = eval { DynaLoader::dl_unload_file($libref) };
is( $@, '', "calling dl_unload_file() for $module" );
is( $r, 1, " - unload was successful" );
Property changes on: trunk/contrib/perl/ext/DynaLoader/t/DynaLoader.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Copied: trunk/contrib/perl/ext/DynaLoader/t/XSLoader.t (from rev 6437, vendor/perl/5.18.1/ext/DynaLoader/t/XSLoader.t)
===================================================================
--- trunk/contrib/perl/ext/DynaLoader/t/XSLoader.t (rev 0)
+++ trunk/contrib/perl/ext/DynaLoader/t/XSLoader.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -0,0 +1,87 @@
+#!perl -T
+
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ chdir 't';
+ @INC = '../lib';
+ }
+}
+
+use strict;
+use Config;
+
+my $db_file;
+BEGIN {
+ eval "use Test::More";
+ if ($@) {
+ print "1..0 # Skip: Test::More not available\n";
+ die "Test::More not available\n";
+ }
+
+ use Config;
+ foreach (qw/SDBM_File GDBM_File ODBM_File NDBM_File DB_File/) {
+ if ($Config{extensions} =~ /\b$_\b/) {
+ $db_file = $_;
+ last;
+ }
+ }
+}
+
+
+my %modules = (
+ # ModuleName => q|code to check that it was loaded|,
+ 'Cwd' => q| ::can_ok( 'Cwd' => 'fastcwd' ) |, # 5.7 ?
+ 'File::Glob' => q| ::can_ok( 'File::Glob' => 'doglob' ) |, # 5.6
+ $db_file => q| ::can_ok( $db_file => 'TIEHASH' ) |, # 5.0
+ 'Socket' => q| ::can_ok( 'Socket' => 'inet_aton' ) |, # 5.0
+ 'Time::HiRes'=> q| ::can_ok( 'Time::HiRes' => 'usleep' ) |, # 5.7.3
+);
+
+plan tests => keys(%modules) * 4 + 5;
+
+# Try to load the module
+use_ok( 'XSLoader' );
+
+# Check functions
+can_ok( 'XSLoader' => 'load' );
+can_ok( 'XSLoader' => 'bootstrap_inherit' );
+
+# Check error messages
+eval { XSLoader::load() };
+like( $@, '/^XSLoader::load\(\'Your::Module\', \$Your::Module::VERSION\)/',
+ "calling XSLoader::load() with no argument" );
+
+eval q{ package Thwack; XSLoader::load('Thwack'); };
+if ($Config{usedl}) {
+ like( $@, q{/^Can't locate loadable object for module Thwack in @INC/},
+ "calling XSLoader::load() under a package with no XS part" );
+}
+else {
+ like( $@, q{/^Can't load module Thwack, dynamic loading not available in this perl./},
+ "calling XSLoader::load() under a package with no XS part" );
+}
+
+# Now try to load well known XS modules
+my $extensions = $Config{'extensions'};
+$extensions =~ s|/|::|g;
+
+for my $module (sort keys %modules) {
+ my $warnings = "";
+ local $SIG{__WARN__} = sub { $warnings = $_[0] };
+
+ SKIP: {
+ skip "$module not available", 4 if $extensions !~ /\b$module\b/;
+
+ eval qq{ package $module; XSLoader::load('$module', "qunckkk"); };
+ like( $@, "/^$module object version \\S+ does not match bootstrap parameter (?:qunckkk|0)/",
+ "calling XSLoader::load() with a XS module and an incorrect version" );
+ like( $warnings, "/^\$|^Version string 'qunckkk' contains invalid data; ignoring: 'qunckkk'/",
+ "in Perl 5.10, DynaLoader warns about the incorrect version string" );
+
+ eval qq{ package $module; XSLoader::load('$module'); };
+ is( $@, '', "XSLoader::load($module)");
+
+ eval qq{ package $module; $modules{$module}; };
+ }
+}
+
Index: trunk/contrib/perl/ext/Errno/ChangeLog
===================================================================
--- trunk/contrib/perl/ext/Errno/ChangeLog 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/Errno/ChangeLog 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/Errno/ChangeLog
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/ext/Errno/Errno_pm.PL
===================================================================
--- trunk/contrib/perl/ext/Errno/Errno_pm.PL 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/Errno/Errno_pm.PL 2013-12-02 21:32:26 UTC (rev 6445)
@@ -2,7 +2,7 @@
use Config;
use strict;
-our $VERSION = "1.13";
+our $VERSION = "1.18";
my %err = ();
my %wsa = ();
@@ -125,12 +125,6 @@
} elsif ($^O eq 'os390') {
# OS/390 C compiler doesn't generate #file or #line directives
$file{'/usr/include/errno.h'} = 1;
- } elsif ($^O eq 'vmesa') {
- # OS/390 C compiler doesn't generate #file or #line directives
- $file{'../../vmesa/errno.h'} = 1;
- } elsif ($Config{archname} eq 'epoc') {
- # Watch out for cross compiling for EPOC (usually done on linux)
- $file{'/usr/local/epocemx/epocsdk/include/libc/sys/errno.h'} = 1;
} elsif ($Config{archname} eq 'arm-riscos') {
# Watch out for cross compiling for RISC OS
my $dep = `echo "#include <errno.h>" | gcc -E -M -`;
@@ -147,7 +141,7 @@
my $linux_errno_h = -e '/usr/include/errno.h' ?
'/usr/include/errno.h' : '/usr/local/include/errno.h';
$file{$linux_errno_h} = 1;
- } elsif ($^O eq 'beos' || $^O eq 'haiku') {
+ } elsif ($^O eq 'haiku') {
# hidden in a special place
$file{'/boot/develop/headers/posix/errno.h'} = 1;
@@ -184,13 +178,7 @@
die "Cannot exec $cpp";
}
- my $pat;
- if (($IsMSWin32 || $^O eq 'NetWare') and $Config{cc} =~ /^bcc/i) {
- $pat = '^/\*\s+(.+)\s+\d+\s*:\s+\*/';
- }
- else {
- $pat = '^#\s*(?:line)?\s*\d+\s+"([^"]+)"';
- }
+ my $pat = '^#\s*(?:line)?\s*\d+\s+"([^"]+)"';
while(<CPPO>) {
if ($^O eq 'os2' or $IsMSWin32 or $^O eq 'NetWare') {
if (/$pat/o) {
@@ -245,7 +233,7 @@
close(CPPI);
- unless ($^O eq 'beos') { # trust what we have / get later
+ { # BeOS (support now removed) did not enter this block
# invoke CPP and read the output
if ($^O eq 'VMS') {
@@ -286,42 +274,10 @@
close(CPPO);
}
- # Many of the E constants (including ENOENT, which is being
- # used in the Perl test suite a lot), are available only as
- # enums in BeOS, so compiling and executing some code is about
- # only way to find out what the numeric Evalues are. In fact above, we
- # didn't even bother to get the values of the ones that have numeric
- # values, since we can get all of them here, anyway.
+ # escape $Config{'archname'}
+ my $archname = $Config{'archname'};
+ $archname =~ s/([@%\$])/\\\1/g;
- if ($^O eq 'beos') {
- if (open(C, ">errno.c")) {
- my @allerrs = keys %err;
- print C <<EOF;
-#include <errno.h>
-#include <stdio.h>
-int main() {
-EOF
- for (@allerrs) {
- print C qq[printf("$_ %d\n", $_);]
- }
- print C "}\n";
- close C;
- system("cc -o errno errno.c");
- unlink("errno.c");
- if (open(C, "./errno|")) {
- while (<C>) {
- if (/^(\w+) (-?\d+)$/) { $err{$1} = $2 }
- }
- close(C);
- } else {
- die "failed to execute ./errno: $!\n";
- }
- unlink("errno");
- } else {
- die "failed to create errno.c: $!\n";
- }
- }
-
# Write Errno.pm
print <<"EDQ";
@@ -336,8 +292,8 @@
use strict;
"\$Config{'archname'}-\$Config{'osvers'}" eq
-"$Config{'archname'}-$Config{'osvers'}" or
- die "Errno architecture ($Config{'archname'}-$Config{'osvers'}) does not match executable architecture (\$Config{'archname'}-\$Config{'osvers'})";
+"$archname-$Config{'osvers'}" or
+ die "Errno architecture ($archname-$Config{'osvers'}) does not match executable architecture (\$Config{'archname'}-\$Config{'osvers'})";
our \$VERSION = "$VERSION";
\$VERSION = eval \$VERSION;
Property changes on: trunk/contrib/perl/ext/Errno/Errno_pm.PL
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Index: trunk/contrib/perl/ext/Errno/Makefile.PL
===================================================================
--- trunk/contrib/perl/ext/Errno/Makefile.PL 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/Errno/Makefile.PL 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/Errno/Makefile.PL
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/ext/Errno/t/Errno.t
===================================================================
--- trunk/contrib/perl/ext/Errno/t/Errno.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/Errno/t/Errno.t 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/Errno/t/Errno.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/ext/Fcntl/Fcntl.pm
===================================================================
--- trunk/contrib/perl/ext/Fcntl/Fcntl.pm 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/Fcntl/Fcntl.pm 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/Fcntl/Fcntl.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/ext/Fcntl/Fcntl.xs
===================================================================
--- trunk/contrib/perl/ext/Fcntl/Fcntl.xs 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/Fcntl/Fcntl.xs 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/Fcntl/Fcntl.xs
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/ext/Fcntl/Makefile.PL
===================================================================
--- trunk/contrib/perl/ext/Fcntl/Makefile.PL 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/Fcntl/Makefile.PL 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/Fcntl/Makefile.PL
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Index: trunk/contrib/perl/ext/Fcntl/t/autoload.t
===================================================================
--- trunk/contrib/perl/ext/Fcntl/t/autoload.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/Fcntl/t/autoload.t 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/Fcntl/t/autoload.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/Fcntl/t/fcntl.t
===================================================================
--- trunk/contrib/perl/ext/Fcntl/t/fcntl.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/Fcntl/t/fcntl.t 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/Fcntl/t/fcntl.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/ext/Fcntl/t/mode.t
===================================================================
--- trunk/contrib/perl/ext/Fcntl/t/mode.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/Fcntl/t/mode.t 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/Fcntl/t/mode.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/ext/Fcntl/t/syslfs.t
===================================================================
--- trunk/contrib/perl/ext/Fcntl/t/syslfs.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/Fcntl/t/syslfs.t 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/Fcntl/t/syslfs.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/ext/File-Glob/Changes
===================================================================
--- trunk/contrib/perl/ext/File-Glob/Changes 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/File-Glob/Changes 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/File-Glob/Changes
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/ext/File-Glob/Glob.pm
===================================================================
--- trunk/contrib/perl/ext/File-Glob/Glob.pm 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/File-Glob/Glob.pm 2013-12-02 21:32:26 UTC (rev 6445)
@@ -4,7 +4,6 @@
our($VERSION, @ISA, @EXPORT_OK, @EXPORT_FAIL, %EXPORT_TAGS, $DEFAULT_FLAGS);
require XSLoader;
-use feature 'switch';
@ISA = qw(Exporter);
@@ -29,30 +28,40 @@
GLOB_NOSPACE
GLOB_QUOTE
GLOB_TILDE
+ bsd_glob
glob
- bsd_glob
) ],
);
+$EXPORT_TAGS{bsd_glob} = [@{$EXPORT_TAGS{glob}}];
+pop @{$EXPORT_TAGS{bsd_glob}}; # no "glob"
@EXPORT_OK = (@{$EXPORT_TAGS{'glob'}}, 'csh_glob');
-$VERSION = '1.13';
+$VERSION = '1.20';
sub import {
require Exporter;
local $Exporter::ExportLevel = $Exporter::ExportLevel + 1;
Exporter::import(grep {
- my $passthrough;
- given ($_) {
- $DEFAULT_FLAGS &= ~GLOB_NOCASE() when ':case';
- $DEFAULT_FLAGS |= GLOB_NOCASE() when ':nocase';
- when (':globally') {
- no warnings 'redefine';
- *CORE::GLOBAL::glob = \&File::Glob::csh_glob;
- }
- $passthrough = 1;
+ my $passthrough;
+ if ($_ eq ':case') {
+ $DEFAULT_FLAGS &= ~GLOB_NOCASE()
+ }
+ elsif ($_ eq ':nocase') {
+ $DEFAULT_FLAGS |= GLOB_NOCASE();
+ }
+ elsif ($_ eq ':globally') {
+ no warnings 'redefine';
+ *CORE::GLOBAL::glob = \&File::Glob::csh_glob;
}
- $passthrough;
+ elsif ($_ eq ':bsd_glob') {
+ no strict; *{caller."::glob"} = \&bsd_glob_override;
+ $passthrough = 1;
+ }
+ else {
+ $passthrough = 1;
+ }
+ $passthrough;
} @_);
}
@@ -66,66 +75,10 @@
# File::Glob::glob() is deprecated because its prototype is different from
# CORE::glob() (use bsd_glob() instead)
sub glob {
- splice @_, 1; # don't pass PL_glob_index as flags!
+ splice @_, 1; # no flags
goto &bsd_glob;
}
-## borrowed heavily from gsar's File::DosGlob
-my %iter;
-my %entries;
-
-sub csh_glob {
- my $pat = shift;
- my $cxix = shift;
- my @pat;
-
- # glob without args defaults to $_
- $pat = $_ unless defined $pat;
-
- # extract patterns
- $pat =~ s/^\s+//; # Protect against empty elements in
- $pat =~ s/\s+$//; # things like < *.c> and <*.c >.
- # These alone shouldn't trigger ParseWords.
- if ($pat =~ /\s/) {
- # XXX this is needed for compatibility with the csh
- # implementation in Perl. Need to support a flag
- # to disable this behavior.
- require Text::ParseWords;
- @pat = Text::ParseWords::parse_line('\s+',0,$pat);
- }
-
- # assume global context if not provided one
- $cxix = '_G_' unless defined $cxix;
- $iter{$cxix} = 0 unless exists $iter{$cxix};
-
- # if we're just beginning, do it all first
- if ($iter{$cxix} == 0) {
- if (@pat) {
- $entries{$cxix} = [ map { doglob($_, $DEFAULT_FLAGS) } @pat ];
- }
- else {
- $entries{$cxix} = [ doglob($pat, $DEFAULT_FLAGS) ];
- }
- }
-
- # chuck it all out, quick or slow
- if (wantarray) {
- delete $iter{$cxix};
- return @{delete $entries{$cxix}};
- }
- else {
- if ($iter{$cxix} = scalar @{$entries{$cxix}}) {
- return shift @{$entries{$cxix}};
- }
- else {
- # return undef for EOL
- delete $iter{$cxix};
- delete $entries{$cxix};
- return undef;
- }
- }
-}
-
1;
__END__
@@ -135,7 +88,7 @@
=head1 SYNOPSIS
- use File::Glob ':glob';
+ use File::Glob ':bsd_glob';
@list = bsd_glob('*.[ch]');
$homedir = bsd_glob('~gnat', GLOB_TILDE | GLOB_ERR);
@@ -178,7 +131,8 @@
Note that they don't share the same prototype--CORE::glob() only accepts
a single argument. Due to historical reasons, CORE::glob() will also
split its argument on whitespace, treating it as multiple patterns,
-whereas bsd_glob() considers them as one pattern.
+whereas bsd_glob() considers them as one pattern. But see C<:bsd_glob>
+under L</EXPORTS>, below.
=head2 META CHARACTERS
@@ -191,9 +145,55 @@
The metanotation C<a{b,c,d}e> is a shorthand for C<abe ace ade>. Left to
right order is preserved, with results of matches being sorted separately
-at a low level to preserve this order. As a special case C<{>, C<}>, and
+at a low level to preserve this order. As a special case C<{>, C<}>, and
C<{}> are passed undisturbed.
+=head2 EXPORTS
+
+See also the L</POSIX FLAGS> below, which can be exported individually.
+
+=head3 C<:bsd_glob>
+
+The C<:bsd_glob> export tag exports bsd_glob() and the constants listed
+below. It also overrides glob() in the calling package with one that
+behaves like bsd_glob() with regard to spaces (the space is treated as part
+of a file name), but supports iteration in scalar context; i.e., it
+preserves the core function's feature of returning the next item each time
+it is called.
+
+=head3 C<:glob>
+
+The C<:glob> tag, now discouraged, is the old version of C<:bsd_glob>. It
+exports the same constants and functions, but its glob() override does not
+support iteration; it returns the last file name in scalar context. That
+means this will loop forever:
+
+ use File::Glob ':glob';
+ while (my $file = <* copy.txt>) {
+ ...
+ }
+
+=head3 C<bsd_glob>
+
+This function, which is included in the two export tags listed above,
+takes one or two arguments. The first is the glob pattern. The second is
+a set of flags ORed together. The available flags are listed below under
+L</POSIX FLAGS>. If the second argument is omitted, C<GLOB_CSH> (or
+C<GLOB_CSH|GLOB_NOCASE> on VMS and DOSish systems) is used by default.
+
+=head3 C<:nocase> and C<:case>
+
+These two export tags globally modify the default flags that bsd_glob()
+and, except on VMS, Perl's built-in C<glob> operator use. C<GLOB_NOCASE>
+is turned on or off, respectively.
+
+=head3 C<csh_glob>
+
+The csh_glob() function can also be exported, but you should not use it
+directly unless you really know what you are doing. It splits the pattern
+into words and feeds each one to bsd_glob(). Perl's own glob() function
+uses this internally.
+
=head2 POSIX FLAGS
The POSIX defined flags for bsd_glob() are:
@@ -334,10 +334,10 @@
On DOSISH systems, backslash is a valid directory separator character.
In this case, use of backslash as a quoting character (via GLOB_QUOTE)
-interferes with the use of backslash as a directory separator. The
+interferes with the use of backslash as a directory separator. The
best (simplest, most portable) solution is to use forward slashes for
-directory separators, and backslashes for quoting. However, this does
-not match "normal practice" on these systems. As a concession to user
+directory separators, and backslashes for quoting. However, this does
+not match "normal practice" on these systems. As a concession to user
expectation, therefore, backslashes (under GLOB_QUOTE) only quote the
glob metacharacters '[', ']', '{', '}', '-', '~', and backslash itself.
All other backslashes are passed through unchanged.
@@ -348,46 +348,6 @@
backslashes, consider using Sarathy's File::DosGlob, which comes with
the standard Perl distribution.
-=item *
-
-Mac OS (Classic) users should note a few differences. Since
-Mac OS is not Unix, when the glob code encounters a tilde glob (e.g.
-~user) and the C<GLOB_TILDE> flag is used, it simply returns that
-pattern without doing any expansion.
-
-Glob on Mac OS is case-insensitive by default (if you don't use any
-flags). If you specify any flags at all and still want glob
-to be case-insensitive, you must include C<GLOB_NOCASE> in the flags.
-
-The path separator is ':' (aka colon), not '/' (aka slash). Mac OS users
-should be careful about specifying relative pathnames. While a full path
-always begins with a volume name, a relative pathname should always
-begin with a ':'. If specifying a volume name only, a trailing ':' is
-required.
-
-The specification of pathnames in glob patterns adheres to the usual Mac
-OS conventions: The path separator is a colon ':', not a slash '/'. A
-full path always begins with a volume name. A relative pathname on Mac
-OS must always begin with a ':', except when specifying a file or
-directory name in the current working directory, where the leading colon
-is optional. If specifying a volume name only, a trailing ':' is
-required. Due to these rules, a glob like E<lt>*:E<gt> will find all
-mounted volumes, while a glob like E<lt>*E<gt> or E<lt>:*E<gt> will find
-all files and directories in the current directory.
-
-Note that updirs in the glob pattern are resolved before the matching begins,
-i.e. a pattern like "*HD:t?p::a*" will be matched as "*HD:a*". Note also,
-that a single trailing ':' in the pattern is ignored (unless it's a volume
-name pattern like "*HD:"), i.e. a glob like E<lt>:*:E<gt> will find both
-directories I<and> files (and not, as one might expect, only directories).
-You can, however, use the C<GLOB_MARK> flag to distinguish (without a file
-test) directory names from file names.
-
-If the C<GLOB_MARK> flag is set, all directory paths will have a ':' appended.
-Since a directory like 'lib:' is I<not> a valid I<relative> path on Mac OS,
-both a leading and a trailing colon will be added, when the directory name in
-question doesn't contain any colons (e.g. 'lib' becomes ':lib:').
-
=back
=head1 SEE ALSO
@@ -422,7 +382,7 @@
may be used to endorse or promote products derived from this software
without specific prior written permission.
- THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND
+ THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS "AS IS" AND
ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
Property changes on: trunk/contrib/perl/ext/File-Glob/Glob.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/ext/File-Glob/Glob.xs
===================================================================
--- trunk/contrib/perl/ext/File-Glob/Glob.xs 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/File-Glob/Glob.xs 2013-12-02 21:32:26 UTC (rev 6445)
@@ -10,6 +10,8 @@
typedef struct {
int x_GLOB_ERROR;
+ HV * x_GLOB_ENTRIES;
+ Perl_ophook_t x_GLOB_OLD_OPHOOK;
} my_cxt_t;
START_MY_CXT
@@ -28,6 +30,303 @@
}
#endif
+static void
+doglob(pTHX_ const char *pattern, int flags)
+{
+ dSP;
+ glob_t pglob;
+ int i;
+ int retval;
+ SV *tmp;
+ {
+ dMY_CXT;
+
+ /* call glob */
+ memset(&pglob, 0, sizeof(glob_t));
+ retval = bsd_glob(pattern, flags, errfunc, &pglob);
+ GLOB_ERROR = retval;
+
+ /* return any matches found */
+ EXTEND(sp, pglob.gl_pathc);
+ for (i = 0; i < pglob.gl_pathc; i++) {
+ /* printf("# bsd_glob: %s\n", pglob.gl_pathv[i]); */
+ tmp = newSVpvn_flags(pglob.gl_pathv[i], strlen(pglob.gl_pathv[i]),
+ SVs_TEMP);
+ TAINT;
+ SvTAINT(tmp);
+ PUSHs(tmp);
+ }
+ PUTBACK;
+
+ bsd_globfree(&pglob);
+ }
+}
+
+static void
+iterate(pTHX_ bool(*globber)(pTHX_ AV *entries, SV *patsv))
+{
+ dSP;
+ dMY_CXT;
+
+ const char * const cxixpv = (char *)&PL_op;
+ STRLEN const cxixlen = sizeof(OP *);
+ AV *entries;
+ U32 const gimme = GIMME_V;
+ SV *patsv = POPs;
+ bool on_stack = FALSE;
+
+ if (!MY_CXT.x_GLOB_ENTRIES) MY_CXT.x_GLOB_ENTRIES = newHV();
+ entries = (AV *)*(hv_fetch(MY_CXT.x_GLOB_ENTRIES, cxixpv, cxixlen, 1));
+
+ /* if we're just beginning, do it all first */
+ if (SvTYPE(entries) != SVt_PVAV) {
+ PUTBACK;
+ on_stack = globber(aTHX_ entries, patsv);
+ SPAGAIN;
+ }
+
+ /* chuck it all out, quick or slow */
+ if (gimme == G_ARRAY) {
+ if (!on_stack) {
+ EXTEND(SP, AvFILLp(entries)+1);
+ Copy(AvARRAY(entries), SP+1, AvFILLp(entries)+1, SV *);
+ SP += AvFILLp(entries)+1;
+ }
+ /* No G_DISCARD here! It will free the stack items. */
+ hv_delete(MY_CXT.x_GLOB_ENTRIES, cxixpv, cxixlen, 0);
+ }
+ else {
+ if (AvFILLp(entries) + 1) {
+ mPUSHs(av_shift(entries));
+ }
+ else {
+ /* return undef for EOL */
+ hv_delete(MY_CXT.x_GLOB_ENTRIES, cxixpv, cxixlen, G_DISCARD);
+ PUSHs(&PL_sv_undef);
+ }
+ }
+ PUTBACK;
+}
+
+/* returns true if the items are on the stack already, but only in
+ list context */
+static bool
+csh_glob(pTHX_ AV *entries, SV *patsv)
+{
+ dSP;
+ const char *pat;
+ AV *patav = NULL;
+ const char *patend;
+ const char *s = NULL;
+ const char *piece = NULL;
+ SV *word = NULL;
+ int const flags =
+ (int)SvIV(get_sv("File::Glob::DEFAULT_FLAGS", GV_ADD));
+ bool is_utf8;
+ STRLEN len;
+ U32 const gimme = GIMME_V;
+
+ /* glob without args defaults to $_ */
+ SvGETMAGIC(patsv);
+ if (
+ !SvOK(patsv)
+ && (patsv = DEFSV, SvGETMAGIC(patsv), !SvOK(patsv))
+ )
+ pat = "", len = 0, is_utf8 = 0;
+ else pat = SvPV_nomg(patsv,len), is_utf8 = !!SvUTF8(patsv);
+ patend = pat + len;
+
+ /* extract patterns */
+ s = pat-1;
+ while (++s < patend) {
+ switch (*s) {
+ case '\'':
+ case '"' :
+ {
+ bool found = FALSE;
+ const char quote = *s;
+ if (!word) {
+ word = newSVpvs("");
+ if (is_utf8) SvUTF8_on(word);
+ }
+ if (piece) sv_catpvn(word, piece, s-piece);
+ piece = s+1;
+ while (++s < patend)
+ if (*s == '\\') {
+ s++;
+ /* If the backslash is here to escape a quote,
+ obliterate it. */
+ if (s < patend && *s == quote)
+ sv_catpvn(word, piece, s-piece-1), piece = s;
+ }
+ else if (*s == quote) {
+ sv_catpvn(word, piece, s-piece);
+ piece = NULL;
+ found = TRUE;
+ break;
+ }
+ if (!found) { /* unmatched quote */
+ /* Give up on tokenisation and treat the whole string
+ as a single token, but with whitespace stripped. */
+ piece = pat;
+ while (isSPACE(*pat)) pat++;
+ while (isSPACE(*(patend-1))) patend--;
+ /* bsd_glob expects a trailing null, but we cannot mod-
+ ify the original */
+ if (patend < SvEND(patsv)) {
+ if (word) sv_setpvn(word, pat, patend-pat);
+ else
+ word = newSVpvn_flags(
+ pat, patend-pat, SVf_UTF8*is_utf8
+ );
+ piece = NULL;
+ }
+ else {
+ if (word) SvREFCNT_dec(word), word=NULL;
+ piece = pat;
+ s = patend;
+ }
+ goto end_of_parsing;
+ }
+ break;
+ }
+ case '\\':
+ if (!piece) piece = s;
+ s++;
+ /* If the backslash is here to escape a quote,
+ obliterate it. */
+ if (s < patend && (*s == '"' || *s == '\'')) {
+ if (!word) {
+ word = newSVpvn(piece,s-piece-1);
+ if (is_utf8) SvUTF8_on(word);
+ }
+ else sv_catpvn(word, piece, s-piece-1);
+ piece = s;
+ }
+ break;
+ default:
+ if (isSPACE(*s)) {
+ if (piece) {
+ if (!word) {
+ word = newSVpvn(piece,s-piece);
+ if (is_utf8) SvUTF8_on(word);
+ }
+ else sv_catpvn(word, piece, s-piece);
+ }
+ if (!word) break;
+ if (!patav) patav = (AV *)sv_2mortal((SV *)newAV());
+ av_push(patav, word);
+ word = NULL;
+ piece = NULL;
+ }
+ else if (!piece) piece = s;
+ break;
+ }
+ }
+ end_of_parsing:
+
+ assert(SvTYPE(entries) != SVt_PVAV);
+ sv_upgrade((SV *)entries, SVt_PVAV);
+
+ if (patav) {
+ I32 items = AvFILLp(patav) + 1;
+ SV **svp = AvARRAY(patav);
+ while (items--) {
+ PUSHMARK(SP);
+ PUTBACK;
+ doglob(aTHX_ SvPVXx(*svp++), flags);
+ SPAGAIN;
+ {
+ dMARK;
+ dORIGMARK;
+ while (++MARK <= SP)
+ av_push(entries, SvREFCNT_inc_simple_NN(*MARK));
+ SP = ORIGMARK;
+ }
+ }
+ }
+ /* piece is set at this point if there is no trailing whitespace.
+ It is the beginning of the last token or quote-delimited
+ piece thereof. word is set at this point if the last token has
+ multiple quoted pieces. */
+ if (piece || word) {
+ if (word) {
+ if (piece) sv_catpvn(word, piece, s-piece);
+ piece = SvPVX(word);
+ }
+ PUSHMARK(SP);
+ PUTBACK;
+ doglob(aTHX_ piece, flags);
+ if (word) SvREFCNT_dec(word);
+ SPAGAIN;
+ {
+ dMARK;
+ dORIGMARK;
+ /* short-circuit here for a fairly common case */
+ if (!patav && gimme == G_ARRAY) { PUTBACK; return TRUE; }
+ while (++MARK <= SP)
+ av_push(entries, SvREFCNT_inc_simple_NN(*MARK));
+
+ SP = ORIGMARK;
+ }
+ }
+ PUTBACK;
+ return FALSE;
+}
+
+static void
+csh_glob_iter(pTHX)
+{
+ iterate(aTHX_ csh_glob);
+}
+
+/* wrapper around doglob that can be passed to the iterator */
+static bool
+doglob_iter_wrapper(pTHX_ AV *entries, SV *patsv)
+{
+ dSP;
+ const char *pattern;
+ int const flags =
+ (int)SvIV(get_sv("File::Glob::DEFAULT_FLAGS", GV_ADD));
+
+ SvGETMAGIC(patsv);
+ if (
+ !SvOK(patsv)
+ && (patsv = DEFSV, SvGETMAGIC(patsv), !SvOK(patsv))
+ )
+ pattern = "";
+ else pattern = SvPV_nomg_nolen(patsv);
+
+ PUSHMARK(SP);
+ PUTBACK;
+ doglob(aTHX_ pattern, flags);
+ SPAGAIN;
+ {
+ dMARK;
+ dORIGMARK;
+ if (GIMME_V == G_ARRAY) { PUTBACK; return TRUE; }
+ sv_upgrade((SV *)entries, SVt_PVAV);
+ while (++MARK <= SP)
+ av_push(entries, SvREFCNT_inc_simple_NN(*MARK));
+ SP = ORIGMARK;
+ }
+ return FALSE;
+}
+
+static void
+glob_ophook(pTHX_ OP *o)
+{
+ if (PL_dirty) return;
+ {
+ dMY_CXT;
+ if (MY_CXT.x_GLOB_ENTRIES
+ && (o->op_type == OP_GLOB || o->op_type == OP_ENTERSUB))
+ hv_delete(MY_CXT.x_GLOB_ENTRIES, (char *)&o, sizeof(OP *),
+ G_DISCARD);
+ if (MY_CXT.x_GLOB_OLD_OPHOOK) MY_CXT.x_GLOB_OLD_OPHOOK(aTHX_ o);
+ }
+}
+
MODULE = File::Glob PACKAGE = File::Glob
int
@@ -40,57 +339,69 @@
RETVAL
void
-doglob(pattern,...)
+bsd_glob(pattern,...)
char *pattern
-PROTOTYPE: $;$
PREINIT:
- glob_t pglob;
- int i;
- int retval;
int flags = 0;
- SV *tmp;
PPCODE:
{
- dMY_CXT;
- dXSI32;
-
/* allow for optional flags argument */
if (items > 1) {
flags = (int) SvIV(ST(1));
/* remove unsupported flags */
flags &= ~(GLOB_APPEND | GLOB_DOOFFS | GLOB_ALTDIRFUNC | GLOB_MAGCHAR);
- } else if (ix) {
+ } else {
flags = (int) SvIV(get_sv("File::Glob::DEFAULT_FLAGS", GV_ADD));
}
+
+ PUTBACK;
+ doglob(aTHX_ pattern, flags);
+ SPAGAIN;
+ }
- /* call glob */
- memset(&pglob, 0, sizeof(glob_t));
- retval = bsd_glob(pattern, flags, errfunc, &pglob);
- GLOB_ERROR = retval;
+PROTOTYPES: DISABLE
+void
+csh_glob(...)
+PPCODE:
+ /* For backward-compatibility with the original Perl function, we sim-
+ * ply take the first argument, regardless of how many there are.
+ */
+ if (items) SP ++;
+ else {
+ XPUSHs(&PL_sv_undef);
+ }
+ PUTBACK;
+ csh_glob_iter(aTHX);
+ SPAGAIN;
- /* return any matches found */
- EXTEND(sp, pglob.gl_pathc);
- for (i = 0; i < pglob.gl_pathc; i++) {
- /* printf("# bsd_glob: %s\n", pglob.gl_pathv[i]); */
- tmp = newSVpvn_flags(pglob.gl_pathv[i], strlen(pglob.gl_pathv[i]),
- SVs_TEMP);
- TAINT;
- SvTAINT(tmp);
- PUSHs(tmp);
- }
-
- bsd_globfree(&pglob);
+void
+bsd_glob_override(...)
+PPCODE:
+ if (items) SP ++;
+ else {
+ XPUSHs(&PL_sv_undef);
}
+ PUTBACK;
+ iterate(aTHX_ doglob_iter_wrapper);
+ SPAGAIN;
BOOT:
{
- CV *cv = newXS("File::Glob::bsd_glob", XS_File__Glob_doglob, __FILE__);
- XSANY.any_i32 = 1;
+#ifndef PERL_EXTERNAL_GLOB
+ /* Don't do this at home! The globhook interface is highly volatile. */
+ PL_globhook = csh_glob_iter;
+#endif
}
BOOT:
{
MY_CXT_INIT;
+ {
+ dMY_CXT;
+ MY_CXT.x_GLOB_ENTRIES = NULL;
+ MY_CXT.x_GLOB_OLD_OPHOOK = PL_opfreehook;
+ PL_opfreehook = glob_ophook;
+ }
}
INCLUDE: const-xs.inc
Property changes on: trunk/contrib/perl/ext/File-Glob/Glob.xs
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Index: trunk/contrib/perl/ext/File-Glob/Makefile.PL
===================================================================
--- trunk/contrib/perl/ext/File-Glob/Makefile.PL 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/File-Glob/Makefile.PL 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/File-Glob/Makefile.PL
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/ext/File-Glob/TODO
===================================================================
--- trunk/contrib/perl/ext/File-Glob/TODO 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/File-Glob/TODO 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/File-Glob/TODO
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/ext/File-Glob/bsd_glob.c
===================================================================
--- trunk/contrib/perl/ext/File-Glob/bsd_glob.c 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/File-Glob/bsd_glob.c 2013-12-02 21:32:26 UTC (rev 6445)
@@ -17,7 +17,7 @@
* may be used to endorse or promote products derived from this software
* without specific prior written permission.
*
- * THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND
+ * THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS "AS IS" AND
* ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
* IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
* ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
@@ -457,6 +457,7 @@
/*
* handle a plain ~ or ~/ by expanding $HOME
* first and then trying the password file
+ * or $USERPROFILE on DOSISH systems
*/
if ((h = getenv("HOME")) == NULL) {
#ifdef HAS_PASSWD
@@ -465,6 +466,14 @@
return pattern;
else
h = pwd->pw_dir;
+#elif DOSISH
+ /*
+ * When no passwd file, fallback to the USERPROFILE
+ * environment variable on DOSish systems.
+ */
+ if ((h = getenv("USERPROFILE")) == NULL) {
+ return pattern;
+ }
#else
return pattern;
#endif
@@ -723,7 +732,7 @@
Char *pattern, Char *pattern_last,
Char *restpattern, Char *restpattern_last, glob_t *pglob, size_t *limitp)
{
- register Direntry_t *dp;
+ Direntry_t *dp;
DIR *dirp;
int err;
int nocase;
@@ -780,8 +789,8 @@
else
readdirfunc = (Direntry_t *(*)(DIR *))my_readdir;
while ((dp = (*readdirfunc)(dirp))) {
- register U8 *sc;
- register Char *dc;
+ U8 *sc;
+ Char *dc;
/* Initial BG_DOT must be matched literally. */
if (dp->d_name[0] == BG_DOT && *pattern != BG_DOT)
@@ -831,8 +840,8 @@
static int
globextend(const Char *path, glob_t *pglob, size_t *limitp)
{
- register char **pathv;
- register int i;
+ char **pathv;
+ int i;
STRLEN newsize, len;
char *copy;
const Char *p;
@@ -894,7 +903,7 @@
* pattern causes a recursion level.
*/
static int
-match(register Char *name, register Char *pat, register Char *patend, int nocase)
+match(Char *name, Char *pat, Char *patend, int nocase)
{
int ok, negate_range;
Char c, k;
@@ -950,8 +959,8 @@
void
bsd_globfree(glob_t *pglob)
{
- register int i;
- register char **pp;
+ int i;
+ char **pp;
if (pglob->gl_pathv != NULL) {
pp = pglob->gl_pathv + pglob->gl_offs;
@@ -964,7 +973,7 @@
}
static DIR *
-g_opendir(register Char *str, glob_t *pglob)
+g_opendir(Char *str, glob_t *pglob)
{
char buf[MAXPATHLEN];
@@ -982,7 +991,7 @@
}
static int
-g_lstat(register Char *fn, Stat_t *sb, glob_t *pglob)
+g_lstat(Char *fn, Stat_t *sb, glob_t *pglob)
{
char buf[MAXPATHLEN];
@@ -998,7 +1007,7 @@
}
static int
-g_stat(register Char *fn, Stat_t *sb, glob_t *pglob)
+g_stat(Char *fn, Stat_t *sb, glob_t *pglob)
{
char buf[MAXPATHLEN];
@@ -1020,7 +1029,7 @@
}
static int
-g_Ctoc(register const Char *str, char *buf, STRLEN len)
+g_Ctoc(const Char *str, char *buf, STRLEN len)
{
while (len--) {
if ((*buf++ = (char)*str++) == BG_EOS)
@@ -1031,9 +1040,9 @@
#ifdef GLOB_DEBUG
static void
-qprintf(const char *str, register Char *s)
+qprintf(const char *str, Char *s)
{
- register Char *p;
+ Char *p;
(void)printf("%s:\n", str);
for (p = s; *p; p++)
Property changes on: trunk/contrib/perl/ext/File-Glob/bsd_glob.c
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/ext/File-Glob/bsd_glob.h
===================================================================
--- trunk/contrib/perl/ext/File-Glob/bsd_glob.h 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/File-Glob/bsd_glob.h 2013-12-02 21:32:26 UTC (rev 6445)
@@ -17,7 +17,7 @@
* may be used to endorse or promote products derived from this software
* without specific prior written permission.
*
- * THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND
+ * THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS "AS IS" AND
* ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
* IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
* ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
Property changes on: trunk/contrib/perl/ext/File-Glob/bsd_glob.h
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/ext/File-Glob/t/basic.t
===================================================================
--- trunk/contrib/perl/ext/File-Glob/t/basic.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/File-Glob/t/basic.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -10,7 +10,7 @@
}
}
use strict;
-use Test::More tests => 15;
+use Test::More tests => 49;
BEGIN {use_ok('File::Glob', ':glob')};
use Cwd ();
@@ -52,7 +52,7 @@
SKIP: {
my ($name, $home);
skip $^O, 1 if $^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'VMS'
- || $^O eq 'os2' || $^O eq 'beos';
+ || $^O eq 'os2';
skip "Can't find user for $>: $@", 1 unless eval {
($name, $home) = (getpwuid($>))[0,7];
1;
@@ -68,7 +68,47 @@
is_deeply (\@a, [$home]);
}
}
+# check plain tilde expansion
+{
+ my $tilde_check = sub {
+ my @a = bsd_glob('~');
+ if (GLOB_ERROR) {
+ fail(GLOB_ERROR);
+ } else {
+ is_deeply (\@a, [$_[0]], join ' - ', 'tilde expansion', @_ > 1 ? $_[1] : ());
+ }
+ };
+ my $passwd_home = eval { (getpwuid($>))[7] };
+
+ TODO: {
+ local $TODO = 'directory brackets look like pattern brackets to glob' if $^O eq 'VMS';
+ local $ENV{HOME};
+ delete $ENV{HOME};
+ local $ENV{USERPROFILE};
+ delete $ENV{USERPROFILE};
+ $tilde_check->(defined $passwd_home ? $passwd_home : q{~}, 'no environment');
+ }
+
+ SKIP: {
+ skip 'MSWin32 only', 1 if $^O ne 'MSWin32';
+ local $ENV{HOME};
+ delete $ENV{HOME};
+ local $ENV{USERPROFILE};
+ $ENV{USERPROFILE} = 'sweet win32 home';
+ $tilde_check->(defined $passwd_home ? $passwd_home : $ENV{USERPROFILE}, 'USERPROFILE');
+ }
+
+ TODO: {
+ local $TODO = 'directory brackets look like pattern brackets to glob' if $^O eq 'VMS';
+ my $home = exists $ENV{HOME} ? $ENV{HOME}
+ : eval { getpwuid($>); 1 } ? (getpwuid($>))[7]
+ : $^O eq 'MSWin32' && exists $ENV{USERPROFILE} ? $ENV{USERPROFILE}
+ : q{~};
+ $tilde_check->($home);
+ }
+}
+
# check backslashing
# should return a list with one item, and not set ERROR
@a = bsd_glob('TEST', GLOB_QUOTE);
@@ -90,7 +130,7 @@
# check bad protections
# should return an empty list, and set ERROR
SKIP: {
- skip $^O, 2 if $^O eq 'mpeix' or $^O eq 'MSWin32' or $^O eq 'NetWare'
+ skip $^O, 2 if $^O eq 'MSWin32' or $^O eq 'NetWare'
or $^O eq 'os2' or $^O eq 'VMS' or $^O eq 'cygwin';
skip "AFS", 2 if Cwd::cwd() =~ m#^$Config{'afsroot'}#s;
skip "running as root", 2 if not $>;
@@ -119,14 +159,17 @@
@a = grep !/(,v$|~$|\.(pm|ori?g|rej)$)/, @a;
@a = (grep !/test.pl/, @a) if $^O eq 'VMS';
+map { $_ =~ s/test\.?/TEST/i } @a if $^O eq 'VMS';
print "# @a\n";
-is_deeply(\@a, [($vms_mode ? 'test.' : 'TEST'), 'a', 'b']);
+is_deeply(\@a, ['TEST', 'a', 'b']);
# "~" should expand to $ENV{HOME}
-$ENV{HOME} = "sweet home";
- at a = bsd_glob('~', GLOB_TILDE | GLOB_NOMAGIC);
-is_deeply(\@a, [$ENV{HOME}]);
+{
+ local $ENV{HOME} = "sweet home";
+ @a = bsd_glob('~', GLOB_TILDE | GLOB_NOMAGIC);
+ is_deeply(\@a, [$ENV{HOME}]);
+}
# GLOB_ALPHASORT (default) should sort alphabetically regardless of case
mkdir "pteerslo", 0777;
@@ -191,3 +234,52 @@
# This used to segfault.
my $i = bsd_glob('*', GLOB_ALTDIRFUNC);
is(&File::Glob::GLOB_ERROR, 0, "Successfuly ignored unsupported flag");
+
+package frimpy; # get away from the glob override, so we can test csh_glob,
+use Test::More; # which is perl's default
+
+# In case of PERL_EXTERNAL_GLOB:
+use subs 'glob';
+BEGIN { *glob = \&File::Glob::csh_glob }
+
+is +(glob "a'b'")[0], (<a'b' c>)[0], "a'b' with and without spaces";
+is <a"b">, 'ab', 'a"b" without spaces';
+is_deeply [<a"b" c>], [qw<ab c>], 'a"b" without spaces';
+is_deeply [<\\* .\\*>], [<\\*>,<.\\*>], 'backslashes with(out) spaces';
+like <\\ >, qr/^\\? \z/, 'final escaped space';
+is <a"b>, 'a"b', 'unmatched quote';
+is < a"b >, 'a"b', 'unmatched quote with surrounding spaces';
+is glob('a\"b'), 'a"b', '\ before quote *only* escapes quote';
+is glob(q"a\'b"), "a'b", '\ before single quote *only* escapes quote';
+is glob('"a\"b c\"d"'), 'a"b c"d', 'before \" within "..."';
+is glob(q"'a\'b c\'d'"), "a'b c'd", q"before \' within '...'";
+
+
+package bsdglob; # for testing the :bsd_glob export tag
+
+use File::Glob ':bsd_glob';
+use Test::More;
+for (qw[
+ GLOB_ABEND
+ GLOB_ALPHASORT
+ GLOB_ALTDIRFUNC
+ GLOB_BRACE
+ GLOB_CSH
+ GLOB_ERR
+ GLOB_ERROR
+ GLOB_LIMIT
+ GLOB_MARK
+ GLOB_NOCASE
+ GLOB_NOCHECK
+ GLOB_NOMAGIC
+ GLOB_NOSORT
+ GLOB_NOSPACE
+ GLOB_QUOTE
+ GLOB_TILDE
+ bsd_glob
+ ]) {
+ ok (exists &$_, qq':bsd_glob exports $_');
+}
+is <a b>, 'a b', '<a b> under :bsd_glob';
+is <"a" "b">, '"a" "b"', '<"a" "b"> under :bsd_glob';
+is_deeply [<a b>], [q<a b>], '<> in list context under :bsd_glob';
Property changes on: trunk/contrib/perl/ext/File-Glob/t/basic.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Index: trunk/contrib/perl/ext/File-Glob/t/case.t
===================================================================
--- trunk/contrib/perl/ext/File-Glob/t/case.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/File-Glob/t/case.t 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/File-Glob/t/case.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/ext/File-Glob/t/global.t
===================================================================
--- trunk/contrib/perl/ext/File-Glob/t/global.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/File-Glob/t/global.t 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/File-Glob/t/global.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Copied: trunk/contrib/perl/ext/File-Glob/t/rt114984.t (from rev 6437, vendor/perl/5.18.1/ext/File-Glob/t/rt114984.t)
===================================================================
--- trunk/contrib/perl/ext/File-Glob/t/rt114984.t (rev 0)
+++ trunk/contrib/perl/ext/File-Glob/t/rt114984.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -0,0 +1,31 @@
+use strict;
+use warnings;
+use v5.16.0;
+use File::Temp 'tempdir';
+use File::Spec::Functions;
+use Test::More;
+
+BEGIN {
+ plan skip_all => "Home-grown glob does not do character classes on $^O" if $^O eq 'VMS';
+}
+
+plan tests => 1;
+
+my @md = (1..305);
+my @mp = (1000..1205);
+
+my $path = tempdir uc cleanup => 1;
+
+foreach (@md) {
+ open(my $f, ">", catfile $path, "md_$_.dat");
+ close $f;
+}
+
+foreach (@mp) {
+ open(my $f, ">", catfile $path, "mp_$_.dat");
+ close $f;
+}
+my @b = glob(qq{$path/mp_[0123456789]*.dat
+ $path/md_[0123456789]*.dat});
+is scalar(@b), @md+ at mp,
+ 'File::Glob extends the stack when returning a long list';
Modified: trunk/contrib/perl/ext/File-Glob/t/taint.t
===================================================================
--- trunk/contrib/perl/ext/File-Glob/t/taint.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/File-Glob/t/taint.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -10,7 +10,14 @@
}
}
-use Test::More tests => 2;
+use Test::More;
+BEGIN {
+ plan(
+ ${^TAINT}
+ ? (tests => 2)
+ : (skip_all => "Appear to running a perl without taint support")
+ );
+}
BEGIN {
use_ok('File::Glob');
Property changes on: trunk/contrib/perl/ext/File-Glob/t/taint.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/ext/FileCache/lib/FileCache.pm
===================================================================
--- trunk/contrib/perl/ext/FileCache/lib/FileCache.pm 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/FileCache/lib/FileCache.pm 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/FileCache/lib/FileCache.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/FileCache/t/01open.t
===================================================================
--- trunk/contrib/perl/ext/FileCache/t/01open.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/FileCache/t/01open.t 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/FileCache/t/01open.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/FileCache/t/02maxopen.t
===================================================================
--- trunk/contrib/perl/ext/FileCache/t/02maxopen.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/FileCache/t/02maxopen.t 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/FileCache/t/02maxopen.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/FileCache/t/03append.t
===================================================================
--- trunk/contrib/perl/ext/FileCache/t/03append.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/FileCache/t/03append.t 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/FileCache/t/03append.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/FileCache/t/04twoarg.t
===================================================================
--- trunk/contrib/perl/ext/FileCache/t/04twoarg.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/FileCache/t/04twoarg.t 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/FileCache/t/04twoarg.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/FileCache/t/05override.t
===================================================================
--- trunk/contrib/perl/ext/FileCache/t/05override.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/FileCache/t/05override.t 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/FileCache/t/05override.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/FileCache/t/06export.t
===================================================================
--- trunk/contrib/perl/ext/FileCache/t/06export.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/FileCache/t/06export.t 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/FileCache/t/06export.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/FileCache/t/07noimport.t
===================================================================
--- trunk/contrib/perl/ext/FileCache/t/07noimport.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/FileCache/t/07noimport.t 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/FileCache/t/07noimport.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/ext/GDBM_File/GDBM_File.pm
===================================================================
--- trunk/contrib/perl/ext/GDBM_File/GDBM_File.pm 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/GDBM_File/GDBM_File.pm 2013-12-02 21:32:26 UTC (rev 6445)
@@ -69,7 +69,7 @@
);
# This module isn't dual life, so no need for dev version numbers.
-$VERSION = '1.14';
+$VERSION = '1.15';
XSLoader::load();
Property changes on: trunk/contrib/perl/ext/GDBM_File/GDBM_File.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/ext/GDBM_File/GDBM_File.xs
===================================================================
--- trunk/contrib/perl/ext/GDBM_File/GDBM_File.xs 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/GDBM_File/GDBM_File.xs 2013-12-02 21:32:26 UTC (rev 6445)
@@ -25,7 +25,13 @@
#define GDBM_BLOCKSIZE 0 /* gdbm defaults to stat blocksize */
+#if defined(GDBM_VERSION_MAJOR) && defined(GDBM_VERSION_MINOR) \
+ && GDBM_VERSION_MAJOR > 1 || \
+ (GDBM_VERSION_MAJOR == 1 && GDBM_VERSION_MINOR >= 9)
+typedef void (*FATALFUNC)(const char *);
+#else
typedef void (*FATALFUNC)();
+#endif
#ifndef GDBM_FAST
static int
@@ -58,6 +64,11 @@
#define gdbm_setopt(db,optflag,optval,optlen) not_here("gdbm_setopt")
#endif
+static void
+croak_string(const char *message) {
+ Perl_croak_nocontext("%s", message);
+}
+
#include "const-c.inc"
MODULE = GDBM_File PACKAGE = GDBM_File PREFIX = gdbm_
@@ -65,18 +76,18 @@
INCLUDE: const-xs.inc
GDBM_File
-gdbm_TIEHASH(dbtype, name, read_write, mode, fatal_func = (FATALFUNC)croak)
+gdbm_TIEHASH(dbtype, name, read_write, mode)
char * dbtype
char * name
int read_write
int mode
- FATALFUNC fatal_func
CODE:
{
GDBM_FILE dbp ;
RETVAL = NULL ;
- if ((dbp = gdbm_open(name, GDBM_BLOCKSIZE, read_write, mode, fatal_func))) {
+ if ((dbp = gdbm_open(name, GDBM_BLOCKSIZE, read_write, mode,
+ (FATALFUNC) croak_string))) {
RETVAL = (GDBM_File)safecalloc(1, sizeof(GDBM_File_type)) ;
RETVAL->dbp = dbp ;
}
Property changes on: trunk/contrib/perl/ext/GDBM_File/GDBM_File.xs
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/ext/GDBM_File/Makefile.PL
===================================================================
--- trunk/contrib/perl/ext/GDBM_File/Makefile.PL 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/GDBM_File/Makefile.PL 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/GDBM_File/Makefile.PL
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Index: trunk/contrib/perl/ext/GDBM_File/hints/sco.pl
===================================================================
--- trunk/contrib/perl/ext/GDBM_File/hints/sco.pl 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/GDBM_File/hints/sco.pl 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/GDBM_File/hints/sco.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Copied: trunk/contrib/perl/ext/GDBM_File/t/fatal.t (from rev 6437, vendor/perl/5.18.1/ext/GDBM_File/t/fatal.t)
===================================================================
--- trunk/contrib/perl/ext/GDBM_File/t/fatal.t (rev 0)
+++ trunk/contrib/perl/ext/GDBM_File/t/fatal.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -0,0 +1,45 @@
+#!./perl -w
+use strict;
+
+use Test::More;
+use Config;
+
+BEGIN {
+ plan(skip_all => "GDBM_File was not built")
+ unless $Config{extensions} =~ /\bGDBM_File\b/;
+
+ plan(tests => 8);
+ use_ok('GDBM_File');
+}
+
+unlink <Op_dbmx*>;
+
+open my $fh, $^X or die "Can't open $^X: $!";
+my $fileno = fileno $fh;
+isnt($fileno, undef, "Can find next available file descriptor");
+close $fh or die $!;
+
+is((open $fh, "<&=$fileno"), undef,
+ "Check that we cannot open fileno $fileno. \$! is $!");
+
+umask(0);
+my %h;
+isa_ok(tie(%h, 'GDBM_File', 'Op_dbmx', GDBM_WRCREAT, 0640), 'GDBM_File');
+
+isnt((open $fh, "<&=$fileno"), undef, "dup fileno $fileno")
+ or diag("\$! = $!");
+isnt(close $fh, undef,
+ "close fileno $fileno, out from underneath the GDBM_File");
+is(eval {
+ $h{Perl} = 'Rules';
+ untie %h;
+ 1;
+}, undef, 'Trapped error when attempting to write to knobbled GDBM_File');
+
+# Observed "File write error" and "lseek error" from two different systems.
+# So there might be more variants. Important part was that we trapped the error
+# via croak.
+like($@, qr/ at .*\bfatal\.t line \d+\.\n\z/,
+ 'expected error message from GDBM_File');
+
+unlink <Op_dbmx*>;
Index: trunk/contrib/perl/ext/GDBM_File/t/gdbm.t
===================================================================
--- trunk/contrib/perl/ext/GDBM_File/t/gdbm.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/GDBM_File/t/gdbm.t 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/GDBM_File/t/gdbm.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/ext/GDBM_File/typemap
===================================================================
--- trunk/contrib/perl/ext/GDBM_File/typemap 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/GDBM_File/typemap 2013-12-02 21:32:26 UTC (rev 6445)
@@ -11,7 +11,6 @@
ODBM_File T_PTROBJ
DB_File T_PTROBJ
DBZ_File T_PTROBJ
-FATALFUNC T_OPAQUEPTR
INPUT
T_DATUM_K
Property changes on: trunk/contrib/perl/ext/GDBM_File/typemap
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Index: trunk/contrib/perl/ext/Hash-Util/Changes
===================================================================
--- trunk/contrib/perl/ext/Hash-Util/Changes 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/Hash-Util/Changes 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/Hash-Util/Changes
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/Hash-Util/Makefile.PL
===================================================================
--- trunk/contrib/perl/ext/Hash-Util/Makefile.PL 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/Hash-Util/Makefile.PL 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/Hash-Util/Makefile.PL
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/ext/Hash-Util/Util.xs
===================================================================
--- trunk/contrib/perl/ext/Hash-Util/Util.xs 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/Hash-Util/Util.xs 2013-12-02 21:32:26 UTC (rev 6445)
@@ -60,3 +60,185 @@
XSRETURN_YES;
}
}
+
+void
+hash_seed()
+ PROTOTYPE:
+ PPCODE:
+ mXPUSHs(newSVpvn((char *)PERL_HASH_SEED,PERL_HASH_SEED_BYTES));
+ XSRETURN(1);
+
+
+void
+hash_value(string)
+ SV* string
+ PROTOTYPE: $
+ PPCODE:
+ STRLEN len;
+ char *pv;
+ UV uv;
+
+ pv= SvPV(string,len);
+ PERL_HASH(uv,pv,len);
+ XSRETURN_UV(uv);
+
+void
+hash_traversal_mask(rhv, ...)
+ SV* rhv
+ PPCODE:
+{
+#ifdef PERL_HASH_RANDOMIZE_KEYS
+ if (SvROK(rhv) && SvTYPE(SvRV(rhv))==SVt_PVHV && !SvMAGICAL(SvRV(rhv))) {
+ HV *hv = (HV *)SvRV(rhv);
+ if (items>1) {
+ hv_rand_set(hv, SvUV(ST(1)));
+ }
+ if (SvOOK(hv)) {
+ XSRETURN_UV(HvRAND_get(hv));
+ } else {
+ XSRETURN_UNDEF;
+ }
+ }
+#else
+ Perl_croak(aTHX_ "Perl has not been compiled with support for randomized hash key traversal");
+#endif
+}
+
+void
+bucket_info(rhv)
+ SV* rhv
+ PPCODE:
+{
+ /*
+
+ Takes a non-magical hash ref as an argument and returns a list of
+ statistics about the hash. The number and keys and the size of the
+ array will always be reported as the first two values. If the array is
+ actually allocated (they are lazily allocated), then additionally
+ will return a list of counts of bucket lengths. In other words in
+
+ ($keys, $buckets, $used, @length_count)= hash::bucket_info(\%hash);
+
+ $length_count[0] is the number of empty buckets, and $length_count[1]
+ is the number of buckets with only one key in it, $buckets - $length_count[0]
+ gives the number of used buckets, and @length_count-1 is the maximum
+ bucket depth.
+
+ If the argument is not a hash ref, or if it is magical, then returns
+ nothing (the empty list).
+
+ */
+ if (SvROK(rhv) && SvTYPE(SvRV(rhv))==SVt_PVHV && !SvMAGICAL(SvRV(rhv))) {
+ const HV * const hv = (const HV *) SvRV(rhv);
+ U32 max_bucket_index= HvMAX(hv);
+ U32 total_keys= HvUSEDKEYS(hv);
+ HE **bucket_array= HvARRAY(hv);
+ mXPUSHi(total_keys);
+ mXPUSHi(max_bucket_index+1);
+ mXPUSHi(0); /* for the number of used buckets */
+#define BUCKET_INFO_ITEMS_ON_STACK 3
+ if (!bucket_array) {
+ XSRETURN(BUCKET_INFO_ITEMS_ON_STACK);
+ } else {
+ /* we use chain_length to index the stack - we eliminate an add
+ * by initializing things with the number of items already on the stack.
+ * If we have 2 items then ST(2+0) (the third stack item) will be the counter
+ * for empty chains, ST(2+1) will be for chains with one element, etc.
+ */
+ I32 max_chain_length= BUCKET_INFO_ITEMS_ON_STACK - 1; /* so we do not have to do an extra push for the 0 index */
+ HE *he;
+ U32 bucket_index;
+ for ( bucket_index= 0; bucket_index <= max_bucket_index; bucket_index++ ) {
+ I32 chain_length= BUCKET_INFO_ITEMS_ON_STACK;
+ for (he= bucket_array[bucket_index]; he; he= HeNEXT(he) ) {
+ chain_length++;
+ }
+ while ( max_chain_length < chain_length ) {
+ mXPUSHi(0);
+ max_chain_length++;
+ }
+ SvIVX( ST( chain_length ) )++;
+ }
+ /* now set the number of used buckets */
+ SvIVX( ST( BUCKET_INFO_ITEMS_ON_STACK - 1 ) ) = max_bucket_index - SvIVX( ST( BUCKET_INFO_ITEMS_ON_STACK ) ) + 1;
+ XSRETURN( max_chain_length + 1 ); /* max_chain_length is the index of the last item on the stack, so we add 1 */
+ }
+#undef BUCKET_INFO_ITEMS_ON_STACK
+ }
+ XSRETURN(0);
+}
+
+void
+bucket_array(rhv)
+ SV* rhv
+ PPCODE:
+{
+ /* Returns an array of arrays representing key/bucket mappings.
+ * Each element of the array contains either an integer or a reference
+ * to an array of keys. A plain integer represents K empty buckets. An
+ * array ref represents a single bucket, with each element being a key in
+ * the hash. (Note this treats a placeholder as a normal key.)
+ *
+ * This allows one to "see" the keyorder. Note the "insert first" nature
+ * of the hash store, combined with regular remappings means that relative
+ * order of keys changes each remap.
+ */
+ if (SvROK(rhv) && SvTYPE(SvRV(rhv))==SVt_PVHV && !SvMAGICAL(SvRV(rhv))) {
+ const HV * const hv = (const HV *) SvRV(rhv);
+ HE **he_ptr= HvARRAY(hv);
+ if (!he_ptr) {
+ XSRETURN(0);
+ } else {
+ U32 i, max;
+ AV *info_av;
+ HE *he;
+ I32 empty_count=0;
+ if (SvMAGICAL(hv)) {
+ Perl_croak(aTHX_ "hash::bucket_array only works on 'normal' hashes");
+ }
+ info_av= newAV();
+ max= HvMAX(hv);
+ mXPUSHs(newRV_noinc((SV*)info_av));
+ for ( i= 0; i <= max; i++ ) {
+ AV *key_av= NULL;
+ for (he= he_ptr[i]; he; he= HeNEXT(he) ) {
+ SV *key_sv;
+ char *str;
+ STRLEN len;
+ char mode;
+ if (!key_av) {
+ key_av= newAV();
+ if (empty_count) {
+ av_push(info_av, newSViv(empty_count));
+ empty_count= 0;
+ }
+ av_push(info_av, (SV *)newRV_noinc((SV *)key_av));
+ }
+ if (HeKLEN(he) == HEf_SVKEY) {
+ SV *sv= HeSVKEY(he);
+ SvGETMAGIC(sv);
+ str= SvPV(sv, len);
+ mode= SvUTF8(sv) ? 1 : 0;
+ } else {
+ str= HeKEY(he);
+ len= HeKLEN(he);
+ mode= HeKUTF8(he) ? 1 : 0;
+ }
+ key_sv= newSVpvn(str,len);
+ av_push(key_av,key_sv);
+ if (mode) {
+ SvUTF8_on(key_sv);
+ }
+ }
+ if (!key_av)
+ empty_count++;
+ }
+ if (empty_count) {
+ av_push(info_av, newSViv(empty_count));
+ empty_count++;
+ }
+ }
+ XSRETURN(1);
+ }
+ XSRETURN(0);
+}
Property changes on: trunk/contrib/perl/ext/Hash-Util/Util.xs
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/ext/Hash-Util/lib/Hash/Util.pm
===================================================================
--- trunk/contrib/perl/ext/Hash-Util/lib/Hash/Util.pm 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/Hash-Util/lib/Hash/Util.pm 2013-12-02 21:32:26 UTC (rev 6445)
@@ -17,19 +17,24 @@
lock_keys unlock_keys
lock_value unlock_value
lock_hash unlock_hash
- lock_keys_plus hash_locked
+ lock_keys_plus
+ hash_locked hash_unlocked
+ hashref_locked hashref_unlocked
hidden_keys legal_keys
lock_ref_keys unlock_ref_keys
lock_ref_value unlock_ref_value
lock_hashref unlock_hashref
- lock_ref_keys_plus hashref_locked
+ lock_ref_keys_plus
hidden_ref_keys legal_ref_keys
- hash_seed hv_store
+ hash_seed hash_value hv_store
+ bucket_stats bucket_info bucket_array
+ lock_hash_recurse unlock_hash_recurse
+ hash_traversal_mask
);
-our $VERSION = '0.11';
+our $VERSION = '0.16';
require XSLoader;
XSLoader::load();
@@ -53,12 +58,28 @@
# Restricted hashes
use Hash::Util qw(
- hash_seed all_keys
+ fieldhash fieldhashes
+
+ all_keys
lock_keys unlock_keys
lock_value unlock_value
lock_hash unlock_hash
- lock_keys_plus hash_locked
+ lock_keys_plus
+ hash_locked hash_unlocked
+ hashref_locked hashref_unlocked
hidden_keys legal_keys
+
+ lock_ref_keys unlock_ref_keys
+ lock_ref_value unlock_ref_value
+ lock_hashref unlock_hashref
+ lock_ref_keys_plus
+ hidden_ref_keys legal_ref_keys
+
+ hash_seed hash_value hv_store
+ bucket_stats bucket_info bucket_array
+ lock_hash_recurse unlock_hash_recurse
+
+ hash_traversal_mask
);
%hash = (foo => 42, bar => 23);
@@ -86,6 +107,12 @@
my $hashes_are_randomised = hash_seed() != 0;
+ my $int_hash_value = hash_value( 'string' );
+
+ my $mask= hash_traversal_mask(%hash);
+
+ hash_traversal_mask(%hash,1234);
+
=head1 DESCRIPTION
C<Hash::Util> and C<Hash::Util::FieldHash> contain special functions
@@ -129,8 +156,8 @@
Removes the restriction on the %hash's keyset.
-B<Note> that if any of the values of the hash have been locked they will not be unlocked
-after this sub executes.
+B<Note> that if any of the values of the hash have been locked they will not
+be unlocked after this sub executes.
Both routines return a reference to the hash operated on.
@@ -190,7 +217,7 @@
sub lock_ref_keys_plus {
- my ($hash, at keys)=@_;
+ my ($hash, at keys) = @_;
my @delete;
Internals::hv_clear_placeholders(%$hash);
foreach my $key (@keys) {
@@ -301,9 +328,9 @@
making all keys and values read-only. No value can be changed, no keys can
be added or deleted.
-B<Only> recurses into hashes that are referenced by another hash. Thus a
-Hash of Hashes (HoH) will all be restricted, but a Hash of Arrays of Hashes
-(HoAoH) will only have the top hash restricted.
+This method B<only> recurses into hashes that are referenced by another hash.
+Thus a Hash of Hashes (HoH) will all be restricted, but a Hash of Arrays of
+Hashes (HoAoH) will only have the top hash restricted.
unlock_hash_recurse(%hash);
@@ -346,9 +373,29 @@
sub lock_hash_recurse (\%) { lock_hashref_recurse(@_) }
sub unlock_hash_recurse (\%) { unlock_hashref_recurse(@_) }
+=item B<hashref_locked>
+=item B<hash_locked>
+
+ hashref_locked(\%hash) and print "Hash is locked!\n";
+ hash_locked(%hash) and print "Hash is locked!\n";
+
+Returns true if the hash and its keys are locked.
+
+=cut
+
+sub hashref_locked {
+ my $hash=shift;
+ Internals::SvREADONLY(%$hash);
+}
+
+sub hash_locked(\%) { hashref_locked(@_) }
+
+=item B<hashref_unlocked>
+
=item B<hash_unlocked>
+ hashref_unlocked(\%hash) and print "Hash is unlocked!\n";
hash_unlocked(%hash) and print "Hash is unlocked!\n";
Returns true if the hash and its keys are unlocked.
@@ -357,7 +404,7 @@
sub hashref_unlocked {
my $hash=shift;
- return Internals::SvREADONLY($hash)
+ !Internals::SvREADONLY(%$hash);
}
sub hash_unlocked(\%) { hashref_unlocked(@_) }
@@ -424,9 +471,7 @@
my $hash_seed = hash_seed();
-hash_seed() returns the seed number used to randomise hash ordering.
-Zero means the "traditional" random hash ordering, non-zero means the
-new even more random hash ordering introduced in Perl 5.8.1.
+hash_seed() returns the seed bytes used to randomise hash ordering.
B<Note that the hash seed is sensitive information>: by knowing it one
can craft a denial-of-service attack against Perl code, even remotely,
@@ -434,10 +479,121 @@
B<Do not disclose the hash seed> to people who don't need to know it.
See also L<perlrun/PERL_HASH_SEED_DEBUG>.
+Prior to Perl 5.17.6 this function returned a UV, it now returns a string,
+which may be of nearly any size as determined by the hash function your
+Perl has been built with. Possible sizes may be but are not limited to
+4 bytes (for most hash algorithms) and 16 bytes (for siphash).
+
+=item B<hash_value>
+
+ my $hash_value = hash_value($string);
+
+hash_value() returns the current perl's internal hash value for a given
+string.
+
+Returns a 32 bit integer representing the hash value of the string passed
+in. This value is only reliable for the lifetime of the process. It may
+be different depending on invocation, environment variables, perl version,
+architectures, and build options.
+
+B<Note that the hash value of a given string is sensitive information>:
+by knowing it one can deduce the hash seed which in turn can allow one to
+craft a denial-of-service attack against Perl code, even remotely,
+see L<perlsec/"Algorithmic Complexity Attacks"> for more information.
+B<Do not disclose the hash value of a string> to people who don't need to
+know it. See also L<perlrun/PERL_HASH_SEED_DEBUG>.
+
+=item B<bucket_info>
+
+Return a set of basic information about a hash.
+
+ my ($keys, $buckets, $used, @length_counts)= bucket_info($hash);
+
+Fields are as follows:
+
+ 0: Number of keys in the hash
+ 1: Number of buckets in the hash
+ 2: Number of used buckets in the hash
+ rest : list of counts, Kth element is the number of buckets
+ with K keys in it.
+
+See also bucket_stats() and bucket_array().
+
+=item B<bucket_stats>
+
+Returns a list of statistics about a hash.
+
+ my ($keys, buckets, $used, $utilization_ratio, $collision_pct,
+ $mean, $stddev, @length_counts) = bucket_info($hashref);
+
+
+Fields are as follows:
+
+
+ 0: Number of keys in the hash
+ 1: Number of buckets in the hash
+ 2: Number of used buckets in the hash
+ 3: Hash Quality Score
+ 4: Percent of buckets used
+ 5: Percent of keys which are in collision
+ 6: Average bucket length
+ 7: Standard Deviation of bucket lengths.
+ rest : list of counts, Kth element is the number of buckets
+ with K keys in it.
+
+See also bucket_info() and bucket_array().
+
+Note that Hash Quality Score would be 1 for an ideal hash, numbers
+close to and below 1 indicate good hashing, and number significantly
+above indicate a poor score. In practice it should be around 0.95 to 1.05.
+It is defined as:
+
+ $score= sum( $count[$length] * ($length * ($length + 1) / 2) )
+ /
+ ( ( $keys / 2 * $buckets ) *
+ ( $keys + ( 2 * $buckets ) - 1 ) )
+
+The formula is from the Red Dragon book (reformulated to use the data available)
+and is documented at L<http://www.strchr.com/hash_functions>
+
+=item B<bucket_array>
+
+ my $array= bucket_array(\%hash);
+
+Returns a packed representation of the bucket array associated with a hash. Each element
+of the array is either an integer K, in which case it represents K empty buckets, or
+a reference to another array which contains the keys that are in that bucket.
+
+B<Note that the information returned by bucket_array is sensitive information>:
+by knowing it one can directly attack perl's hash function which in turn may allow
+one to craft a denial-of-service attack against Perl code, even remotely,
+see L<perlsec/"Algorithmic Complexity Attacks"> for more information.
+B<Do not disclose the output of this function> to people who don't need to
+know it. See also L<perlrun/PERL_HASH_SEED_DEBUG>. This function is provided strictly
+for debugging and diagnostics purposes only, it is hard to imagine a reason why it
+would be used in production code.
+
=cut
-sub hash_seed () {
- Internals::rehash_seed();
+
+sub bucket_stats {
+ my ($hash) = @_;
+ my ($keys, $buckets, $used, @length_counts) = bucket_info($hash);
+ my $sum;
+ my $score;
+ for (0 .. $#length_counts) {
+ $sum += ($length_counts[$_] * $_);
+ $score += $length_counts[$_] * ( $_ * ($_ + 1 ) / 2 );
+ }
+ $score = $score /
+ (( $keys / (2 * $buckets )) * ( $keys + ( 2 * $buckets ) - 1 ))
+ if $keys;
+ my $mean= $sum/$buckets;
+ $sum= 0;
+ $sum += ($length_counts[$_] * (($_-$mean)**2)) for 0 .. $#length_counts;
+
+ my $stddev= sqrt($sum/$buckets);
+ return $keys, $buckets, $used, $keys ? ($score, $used/$buckets, ($keys-$used)/$keys, $mean, $stddev, @length_counts) : ();
}
=item B<hv_store>
@@ -449,6 +605,20 @@
Stores an alias to a variable in a hash instead of copying the value.
+=item B<hash_traversal_mask>
+
+As of Perl 5.18 every hash has its own hash traversal order, and this order
+changes every time a new element is inserted into the hash. This functionality
+is provided by maintaining an unsigned integer mask (U32) which is xor'ed
+with the actual bucket id during a traversal of the hash buckets using keys(),
+values() or each().
+
+You can use this subroutine to get and set the traversal mask for a specific
+hash. Setting the mask ensures that a given hash will produce the same key
+order. B<Note> that this does B<not> guarantee that B<two> hashes will produce
+the same key order for the same hash seed and traversal mask, items that
+collide into one bucket may have different orders regardless of this setting.
+
=back
=head2 Operating on references to hashes.
Property changes on: trunk/contrib/perl/ext/Hash-Util/lib/Hash/Util.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/ext/Hash-Util/t/Util.t
===================================================================
--- trunk/contrib/perl/ext/Hash-Util/t/Util.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/Hash-Util/t/Util.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -16,22 +16,28 @@
my @Exported_Funcs;
BEGIN {
@Exported_Funcs = qw(
- hash_seed all_keys
+ fieldhash fieldhashes
+
+ all_keys
lock_keys unlock_keys
lock_value unlock_value
lock_hash unlock_hash
- lock_keys_plus hash_locked
+ lock_keys_plus
+ hash_locked hash_unlocked
+ hashref_locked hashref_unlocked
hidden_keys legal_keys
lock_ref_keys unlock_ref_keys
lock_ref_value unlock_ref_value
lock_hashref unlock_hashref
- lock_ref_keys_plus hashref_locked
+ lock_ref_keys_plus
hidden_ref_keys legal_ref_keys
+
+ hash_seed hash_value bucket_stats bucket_info bucket_array
hv_store
-
+ lock_hash_recurse unlock_hash_recurse
);
- plan tests => 204 + @Exported_Funcs;
+ plan tests => 234 + @Exported_Funcs;
use_ok 'Hash::Util', @Exported_Funcs;
}
foreach my $func (@Exported_Funcs) {
@@ -43,7 +49,7 @@
eval { $hash{baz} = 99; };
like( $@, qr/^Attempt to access disallowed key 'baz' in a restricted hash/,
'lock_keys()');
-is( $hash{bar}, 23 );
+is( $hash{bar}, 23, '$hash{bar} == 23' );
ok( !exists $hash{baz},'!exists $hash{baz}' );
delete $hash{bar};
@@ -70,7 +76,7 @@
eval { $hash{locked} = 42; };
like( $@, qr/^Modification of a read-only value attempted/,
'trying to change a locked key' );
-is( $hash{locked}, 'yep' );
+is( $hash{locked}, 'yep', '$hash{locked} is yep' );
eval { delete $hash{I_dont_exist} };
like( $@, qr/^Attempt to delete disallowed key 'I_dont_exist' from a restricted hash/,
@@ -108,7 +114,8 @@
lock_value(%hash, 'RO');
eval { %hash = (KEY => 1) };
- like( $@, qr/^Attempt to delete readonly key 'RO' from a restricted hash/ );
+ like( $@, qr/^Attempt to delete readonly key 'RO' from a restricted hash/,
+ 'attempt to delete readonly key from restricted hash' );
}
{
@@ -115,17 +122,15 @@
my %hash = (KEY => 1, RO => 2);
lock_keys(%hash);
eval { %hash = (KEY => 1, RO => 2) };
- is( $@, '');
+ is( $@, '', 'No error message, as expected');
}
-
-
{
my %hash = ();
lock_keys(%hash, qw(foo bar));
is( keys %hash, 0, 'lock_keys() w/keyset shouldnt add new keys' );
$hash{foo} = 42;
- is( keys %hash, 1 );
+ is( keys %hash, 1, '1 element in hash' );
eval { $hash{wibble} = 42 };
like( $@, qr/^Attempt to access disallowed key 'wibble' in a restricted hash/,
'write threw error (locked)');
@@ -135,7 +140,6 @@
is( $@, '', 'unlock_keys' );
}
-
{
my %hash = (foo => 42, bar => undef, baz => 0);
lock_keys(%hash, qw(foo bar baz up down));
@@ -150,19 +154,18 @@
'locked "wibble"' );
}
-
{
my %hash = (foo => 42, bar => undef);
eval { lock_keys(%hash, qw(foo baz)); };
- is( $@, sprintf("Hash has key 'bar' which is not in the new key ".
- "set at %s line %d\n", __FILE__, __LINE__ - 2),
+ like( $@, qr/^Hash has key 'bar' which is not in the new key set/,
'carp test' );
}
-
{
my %hash = (foo => 42, bar => 23);
lock_hash( %hash );
+ ok( hashref_locked( \%hash ), 'hashref_locked' );
+ ok( hash_locked( %hash ), 'hash_locked' );
ok( Internals::SvREADONLY(%hash),'Was locked %hash' );
ok( Internals::SvREADONLY($hash{foo}),'Was locked $hash{foo}' );
@@ -169,6 +172,8 @@
ok( Internals::SvREADONLY($hash{bar}),'Was locked $hash{bar}' );
unlock_hash ( %hash );
+ ok( hashref_unlocked( { %hash } ), 'hashref_unlocked' );
+ ok( hash_unlocked( %hash ), 'hash_unlocked' );
ok( !Internals::SvREADONLY(%hash),'Was unlocked %hash' );
ok( !Internals::SvREADONLY($hash{foo}),'Was unlocked $hash{foo}' );
@@ -175,10 +180,23 @@
ok( !Internals::SvREADONLY($hash{bar}),'Was unlocked $hash{bar}' );
}
+{
+ my %hash = (foo => 42, bar => 23);
+ ok( ! hashref_locked( { %hash } ), 'hashref_locked negated' );
+ ok( ! hash_locked( %hash ), 'hash_locked negated' );
+ lock_hash( %hash );
+ ok( ! hashref_unlocked( \%hash ), 'hashref_unlocked negated' );
+ ok( ! hash_unlocked( %hash ), 'hash_unlocked negated' );
+}
+
lock_keys(%ENV);
eval { () = $ENV{I_DONT_EXIST} };
-like( $@, qr/^Attempt to access disallowed key 'I_DONT_EXIST' in a restricted hash/, 'locked %ENV');
+like(
+ $@,
+ qr/^Attempt to access disallowed key 'I_DONT_EXIST' in a restricted hash/,
+ 'locked %ENV'
+);
{
my %hash;
@@ -309,7 +327,7 @@
}
my $hash_seed = hash_seed();
-ok($hash_seed >= 0, "hash_seed $hash_seed");
+ok(defined($hash_seed) && $hash_seed ne '', "hash_seed $hash_seed");
{
package Minder;
@@ -440,6 +458,17 @@
is("@keys","0 2 4 6 8",'lock_ref_keys_plus() @keys DDS/t');
}
{
+ my %hash=(0..9, 'a' => 'alpha');
+ lock_ref_keys_plus(\%hash,'a'..'f');
+ ok(Internals::SvREADONLY(%hash),'lock_ref_keys_plus args overlap');
+ my @hidden=sort(hidden_keys(%hash));
+ my @legal=sort(legal_keys(%hash));
+ my @keys=sort(keys(%hash));
+ is("@hidden","b c d e f",'lock_ref_keys_plus() @hidden overlap');
+ is("@legal","0 2 4 6 8 a b c d e f",'lock_ref_keys_plus() @legal overlap');
+ is("@keys","0 2 4 6 8 a",'lock_ref_keys_plus() @keys overlap');
+}
+{
my %hash=(0..9);
lock_keys_plus(%hash,'a'..'f');
ok(Internals::SvREADONLY(%hash),'lock_keys_plus args DDS/t');
@@ -450,6 +479,17 @@
is("@legal","0 2 4 6 8 a b c d e f",'lock_keys_plus() @legal DDS/t 3');
is("@keys","0 2 4 6 8",'lock_keys_plus() @keys DDS/t 3');
}
+{
+ my %hash=(0..9, 'a' => 'alpha');
+ lock_keys_plus(%hash,'a'..'f');
+ ok(Internals::SvREADONLY(%hash),'lock_keys_plus args overlap non-ref');
+ my @hidden=sort(hidden_keys(%hash));
+ my @legal=sort(legal_keys(%hash));
+ my @keys=sort(keys(%hash));
+ is("@hidden","b c d e f",'lock_keys_plus() @hidden overlap non-ref');
+ is("@legal","0 2 4 6 8 a b c d e f",'lock_keys_plus() @legal overlap non-ref');
+ is("@keys","0 2 4 6 8 a",'lock_keys_plus() @keys overlap non-ref');
+}
{
my %hash = ('a'..'f');
@@ -468,3 +508,49 @@
is_deeply(\@ph, \@bam, "Placeholders in place");
}
+{
+ my %hash = (
+ a => 'alpha',
+ b => [ qw( beta gamma delta ) ],
+ c => [ 'epsilon', { zeta => 'eta' }, ],
+ d => { theta => 'iota' },
+ );
+ lock_hash_recurse(%hash);
+ ok( hash_locked(%hash),
+ "lock_hash_recurse(): top-level hash locked" );
+ ok( hash_locked(%{$hash{d}}),
+ "lock_hash_recurse(): element which is hashref locked" );
+ ok( ! hash_locked(%{$hash{c}[1]}),
+ "lock_hash_recurse(): element which is hashref in array ref not locked" );
+
+ unlock_hash_recurse(%hash);
+ ok( hash_unlocked(%hash),
+ "unlock_hash_recurse(): top-level hash unlocked" );
+ ok( hash_unlocked(%{$hash{d}}),
+ "unlock_hash_recurse(): element which is hashref unlocked" );
+ ok( hash_unlocked(%{$hash{c}[1]}),
+ "unlock_hash_recurse(): element which is hashref in array ref not locked" );
+}
+
+{
+ my $h1= hash_value("foo");
+ my $h2= hash_value("bar");
+ is( $h1, hash_value("foo") );
+ is( $h2, hash_value("bar") );
+}
+{
+ my @info1= bucket_info({});
+ my @info2= bucket_info({1..10});
+ my @stats1= bucket_stats({});
+ my @stats2= bucket_stats({1..10});
+ my $array1= bucket_array({});
+ my $array2= bucket_array({1..10});
+ is("@info1","0 8 0");
+ is("@info2[0,1]","5 8");
+ is("@stats1","0 8 0");
+ is("@stats2[0,1]","5 8");
+ my @keys1= sort map { ref $_ ? @$_ : () } @$array1;
+ my @keys2= sort map { ref $_ ? @$_ : () } @$array2;
+ is("@keys1","");
+ is("@keys2","1 3 5 7 9");
+}
Property changes on: trunk/contrib/perl/ext/Hash-Util/t/Util.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/ext/Hash-Util-FieldHash/Changes
===================================================================
--- trunk/contrib/perl/ext/Hash-Util-FieldHash/Changes 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/Hash-Util-FieldHash/Changes 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/Hash-Util-FieldHash/Changes
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/Hash-Util-FieldHash/FieldHash.xs
===================================================================
--- trunk/contrib/perl/ext/Hash-Util-FieldHash/FieldHash.xs 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/Hash-Util-FieldHash/FieldHash.xs 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/Hash-Util-FieldHash/FieldHash.xs
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/ext/Hash-Util-FieldHash/lib/Hash/Util/FieldHash.pm
===================================================================
--- trunk/contrib/perl/ext/Hash-Util-FieldHash/lib/Hash/Util/FieldHash.pm 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/Hash-Util-FieldHash/lib/Hash/Util/FieldHash.pm 2013-12-02 21:32:26 UTC (rev 6445)
@@ -5,7 +5,7 @@
use warnings;
use Scalar::Util qw( reftype);
-our $VERSION = '1.09';
+our $VERSION = '1.10';
require Exporter;
our @ISA = qw(Exporter);
@@ -103,7 +103,7 @@
not a reference, returns $obj.
This function is a stand-in replacement for
-L<Scalar::Util::refaddr|Scalar::Util/refaddr>, that is, it returns
+L<Scalar::Util::refaddr|Scalar::Util/refaddr EXPR>, that is, it returns
the reference address of its argument as a numeric value. The only
difference is that C<refaddr()> returns C<undef> when given a
non-reference while C<id()> returns its argument unchanged.
@@ -217,7 +217,7 @@
on your @ISA list and use my methods". If the other class has different
ideas about how the object body is used, there is trouble.
-For reference L<Name_hash> in L<Example 1> shows the standard implementation of
+For reference C<Name_hash> in L</Example 1> shows the standard implementation of
a simple class C<Name> in the well-known hash based way. It also demonstrates
the predictable failure to construct a common subclass C<NamedFile>
of C<Name> and the class C<IO::File> (whose objects I<must> be globrefs).
@@ -231,8 +231,8 @@
hash for each field it wants to use. The reference address of an
object is used as the hash key. By definition, the reference address
is unique to each object so this guarantees a place for each field that
-is private to the class and unique to each object. See L<Name_id> in
-L<Example 1> for a simple example.
+is private to the class and unique to each object. See C<Name_id>
+in L</Example 1> for a simple example.
In comparison to the standard implementation where the object is a
hash and the fields correspond to hash keys, here the fields correspond
@@ -494,7 +494,7 @@
=item * C<Name_idhash>
-Idhash-based inside-out implementation. Like L<Name_id> it needs
+Idhash-based inside-out implementation. Like C<Name_id> it needs
a C<DESTROY> method and would need C<CLONE> for thread support.
=item * C<Name_id_reg>
Property changes on: trunk/contrib/perl/ext/Hash-Util-FieldHash/lib/Hash/Util/FieldHash.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/ext/Hash-Util-FieldHash/t/01_load.t
===================================================================
--- trunk/contrib/perl/ext/Hash-Util-FieldHash/t/01_load.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/Hash-Util-FieldHash/t/01_load.t 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/Hash-Util-FieldHash/t/01_load.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/ext/Hash-Util-FieldHash/t/02_function.t
===================================================================
--- trunk/contrib/perl/ext/Hash-Util-FieldHash/t/02_function.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/Hash-Util-FieldHash/t/02_function.t 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/Hash-Util-FieldHash/t/02_function.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/ext/Hash-Util-FieldHash/t/03_class.t
===================================================================
--- trunk/contrib/perl/ext/Hash-Util-FieldHash/t/03_class.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/Hash-Util-FieldHash/t/03_class.t 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/Hash-Util-FieldHash/t/03_class.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/ext/Hash-Util-FieldHash/t/04_thread.t
===================================================================
--- trunk/contrib/perl/ext/Hash-Util-FieldHash/t/04_thread.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/Hash-Util-FieldHash/t/04_thread.t 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/Hash-Util-FieldHash/t/04_thread.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/ext/Hash-Util-FieldHash/t/05_perlhook.t
===================================================================
--- trunk/contrib/perl/ext/Hash-Util-FieldHash/t/05_perlhook.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/Hash-Util-FieldHash/t/05_perlhook.t 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/Hash-Util-FieldHash/t/05_perlhook.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/ext/Hash-Util-FieldHash/t/10_hash.t
===================================================================
--- trunk/contrib/perl/ext/Hash-Util-FieldHash/t/10_hash.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/Hash-Util-FieldHash/t/10_hash.t 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/Hash-Util-FieldHash/t/10_hash.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/ext/Hash-Util-FieldHash/t/11_hashassign.t
===================================================================
--- trunk/contrib/perl/ext/Hash-Util-FieldHash/t/11_hashassign.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/Hash-Util-FieldHash/t/11_hashassign.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -282,9 +282,9 @@
fieldhash %h;
is( (join ':', %h = (1) x 8), '1:1',
'hash assignment in list context removes duplicates' );
- is( scalar( %h = (1,2,1,3,1,4,1,5) ), 2,
+ is( scalar( %h = (1,2,1,3,1,4,1,5) ), 8,
'hash assignment in scalar context' );
- is( scalar( ($x,%h) = (0,1,2,1,3,1,4,1,5) ), 3,
+ is( scalar( ($x,%h) = (0,1,2,1,3,1,4,1,5) ), 9,
'scalar + hash assignment in scalar context' );
$ar = [ %h = (1,2,1,3,1,4,1,5) ];
is( $#$ar, 1, 'hash assignment in list context' );
Property changes on: trunk/contrib/perl/ext/Hash-Util-FieldHash/t/11_hashassign.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/ext/Hash-Util-FieldHash/t/12_hashwarn.t
===================================================================
--- trunk/contrib/perl/ext/Hash-Util-FieldHash/t/12_hashwarn.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/Hash-Util-FieldHash/t/12_hashwarn.t 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/Hash-Util-FieldHash/t/12_hashwarn.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/ext/I18N-Langinfo/Langinfo.pm
===================================================================
--- trunk/contrib/perl/ext/I18N-Langinfo/Langinfo.pm 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/I18N-Langinfo/Langinfo.pm 2013-12-02 21:32:26 UTC (rev 6445)
@@ -72,7 +72,7 @@
YESSTR
);
-our $VERSION = '0.08';
+our $VERSION = '0.10';
XSLoader::load();
@@ -103,7 +103,7 @@
use I18N::Langinfo qw(langinfo ABDAY_1 YESSTR NOSTR);
- my ($abday_1, $yesstr, $nostr) = map { langinfo } qw(ABDAY_1 YESSTR NOSTR);
+ my ($abday_1, $yesstr, $nostr) = map { langinfo($_) } (ABDAY_1, YESSTR, NOSTR);
print "$abday_1? [$yesstr/$nostr] ";
Property changes on: trunk/contrib/perl/ext/I18N-Langinfo/Langinfo.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/ext/I18N-Langinfo/Langinfo.xs
===================================================================
--- trunk/contrib/perl/ext/I18N-Langinfo/Langinfo.xs 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/I18N-Langinfo/Langinfo.xs 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/I18N-Langinfo/Langinfo.xs
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/ext/I18N-Langinfo/Makefile.PL
===================================================================
--- trunk/contrib/perl/ext/I18N-Langinfo/Makefile.PL 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/I18N-Langinfo/Makefile.PL 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/I18N-Langinfo/Makefile.PL
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/ext/I18N-Langinfo/t/Langinfo.t
===================================================================
--- trunk/contrib/perl/ext/I18N-Langinfo/t/Langinfo.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/I18N-Langinfo/t/Langinfo.t 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/I18N-Langinfo/t/Langinfo.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/ext/IPC-Open2/lib/IPC/Open2.pm
===================================================================
--- trunk/contrib/perl/ext/IPC-Open2/lib/IPC/Open2.pm 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/IPC-Open2/lib/IPC/Open2.pm 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/IPC-Open2/lib/IPC/Open2.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/IPC-Open2/t/IPC-Open2.t
===================================================================
--- trunk/contrib/perl/ext/IPC-Open2/t/IPC-Open2.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/IPC-Open2/t/IPC-Open2.t 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/IPC-Open2/t/IPC-Open2.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Copied: trunk/contrib/perl/ext/IPC-Open3/lib/IPC/Open2.pm (from rev 6437, vendor/perl/5.18.1/ext/IPC-Open3/lib/IPC/Open2.pm)
===================================================================
--- trunk/contrib/perl/ext/IPC-Open3/lib/IPC/Open2.pm (rev 0)
+++ trunk/contrib/perl/ext/IPC-Open3/lib/IPC/Open2.pm 2013-12-02 21:32:26 UTC (rev 6445)
@@ -0,0 +1,120 @@
+package IPC::Open2;
+
+use strict;
+our ($VERSION, @ISA, @EXPORT);
+
+require 5.000;
+require Exporter;
+
+$VERSION = 1.04;
+ at ISA = qw(Exporter);
+ at EXPORT = qw(open2);
+
+=head1 NAME
+
+IPC::Open2 - open a process for both reading and writing using open2()
+
+=head1 SYNOPSIS
+
+ use IPC::Open2;
+
+ $pid = open2(\*CHLD_OUT, \*CHLD_IN, 'some cmd and args');
+ # or without using the shell
+ $pid = open2(\*CHLD_OUT, \*CHLD_IN, 'some', 'cmd', 'and', 'args');
+
+ # or with handle autovivification
+ my($chld_out, $chld_in);
+ $pid = open2($chld_out, $chld_in, 'some cmd and args');
+ # or without using the shell
+ $pid = open2($chld_out, $chld_in, 'some', 'cmd', 'and', 'args');
+
+ waitpid( $pid, 0 );
+ my $child_exit_status = $? >> 8;
+
+=head1 DESCRIPTION
+
+The open2() function runs the given $cmd and connects $chld_out for
+reading and $chld_in for writing. It's what you think should work
+when you try
+
+ $pid = open(HANDLE, "|cmd args|");
+
+The write filehandle will have autoflush turned on.
+
+If $chld_out is a string (that is, a bareword filehandle rather than a glob
+or a reference) and it begins with C<< >& >>, then the child will send output
+directly to that file handle. If $chld_in is a string that begins with
+C<< <& >>, then $chld_in will be closed in the parent, and the child will
+read from it directly. In both cases, there will be a dup(2) instead of a
+pipe(2) made.
+
+If either reader or writer is the null string, this will be replaced
+by an autogenerated filehandle. If so, you must pass a valid lvalue
+in the parameter slot so it can be overwritten in the caller, or
+an exception will be raised.
+
+open2() returns the process ID of the child process. It doesn't return on
+failure: it just raises an exception matching C</^open2:/>. However,
+C<exec> failures in the child are not detected. You'll have to
+trap SIGPIPE yourself.
+
+open2() does not wait for and reap the child process after it exits.
+Except for short programs where it's acceptable to let the operating system
+take care of this, you need to do this yourself. This is normally as
+simple as calling C<waitpid $pid, 0> when you're done with the process.
+Failing to do this can result in an accumulation of defunct or "zombie"
+processes. See L<perlfunc/waitpid> for more information.
+
+This whole affair is quite dangerous, as you may block forever. It
+assumes it's going to talk to something like B<bc>, both writing
+to it and reading from it. This is presumably safe because you
+"know" that commands like B<bc> will read a line at a time and
+output a line at a time. Programs like B<sort> that read their
+entire input stream first, however, are quite apt to cause deadlock.
+
+The big problem with this approach is that if you don't have control
+over source code being run in the child process, you can't control
+what it does with pipe buffering. Thus you can't just open a pipe to
+C<cat -v> and continually read and write a line from it.
+
+The IO::Pty and Expect modules from CPAN can help with this, as they
+provide a real tty (well, a pseudo-tty, actually), which gets you
+back to line buffering in the invoked command again.
+
+=head1 WARNING
+
+The order of arguments differs from that of open3().
+
+=head1 SEE ALSO
+
+See L<IPC::Open3> for an alternative that handles STDERR as well. This
+function is really just a wrapper around open3().
+
+=cut
+
+# &open2: tom christiansen, <tchrist at convex.com>
+#
+# usage: $pid = open2('rdr', 'wtr', 'some cmd and args');
+# or $pid = open2('rdr', 'wtr', 'some', 'cmd', 'and', 'args');
+#
+# spawn the given $cmd and connect $rdr for
+# reading and $wtr for writing. return pid
+# of child, or 0 on failure.
+#
+# WARNING: this is dangerous, as you may block forever
+# unless you are very careful.
+#
+# $wtr is left unbuffered.
+#
+# abort program if
+# rdr or wtr are null
+# a system call fails
+
+require IPC::Open3;
+
+sub open2 {
+ local $Carp::CarpLevel = $Carp::CarpLevel + 1;
+ return IPC::Open3::_open3('open2', $_[1], $_[0], '>&STDERR', @_[2 .. $#_]);
+}
+
+1
Modified: trunk/contrib/perl/ext/IPC-Open3/lib/IPC/Open3.pm
===================================================================
--- trunk/contrib/perl/ext/IPC-Open3/lib/IPC/Open3.pm 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/IPC-Open3/lib/IPC/Open3.pm 2013-12-02 21:32:26 UTC (rev 6445)
@@ -9,7 +9,7 @@
use Carp;
use Symbol qw(gensym qualify);
-$VERSION = 1.09;
+$VERSION = '1.13';
@ISA = qw(Exporter);
@EXPORT = qw(open3);
@@ -149,66 +149,44 @@
# Fatal.pm needs to be fixed WRT prototypes.
-sub xfork {
- my $pid = fork;
- defined $pid or croak "$Me: fork failed: $!";
- return $pid;
-}
-
sub xpipe {
pipe $_[0], $_[1] or croak "$Me: pipe($_[0], $_[1]) failed: $!";
}
-sub xpipe_anon {
- pipe $_[0], $_[1] or croak "$Me: pipe failed: $!";
-}
-
-sub xclose_on_exec {
- require Fcntl;
- my $flags = fcntl($_[0], &Fcntl::F_GETFD, 0)
- or croak "$Me: fcntl failed: $!";
- fcntl($_[0], &Fcntl::F_SETFD, $flags|&Fcntl::FD_CLOEXEC)
- or croak "$Me: fcntl failed: $!";
-}
-
# I tried using a * prototype character for the filehandle but it still
# disallows a bareword while compiling under strict subs.
sub xopen {
- open $_[0], $_[1] or croak "$Me: open($_[0], $_[1]) failed: $!";
+ open $_[0], $_[1], @_[2..$#_] and return;
+ local $" = ', ';
+ carp "$Me: open(@_) failed: $!";
}
sub xclose {
- $_[0] =~ /\A=?(\d+)\z/ ? eval { require POSIX; POSIX::close($1); } : close $_[0]
+ $_[0] =~ /\A=?(\d+)\z/
+ ? do { my $fh; open($fh, $_[1] . '&=' . $1) and close($fh); }
+ : close $_[0]
+ or croak "$Me: close($_[0]) failed: $!";
}
-sub fh_is_fd {
- return $_[0] =~ /\A=?(\d+)\z/;
-}
-
sub xfileno {
return $1 if $_[0] =~ /\A=?(\d+)\z/; # deal with fh just being an fd
return fileno $_[0];
}
-use constant DO_SPAWN => $^O eq 'os2' || $^O eq 'MSWin32';
+use constant FORCE_DEBUG_SPAWN => 0;
+use constant DO_SPAWN => $^O eq 'os2' || $^O eq 'MSWin32' || FORCE_DEBUG_SPAWN;
sub _open3 {
local $Me = shift;
- my($package, $dad_wtr, $dad_rdr, $dad_err, @cmd) = @_;
- my($dup_wtr, $dup_rdr, $dup_err, $kidpid);
- if (@cmd > 1 and $cmd[0] eq '-') {
- croak "Arguments don't make sense when the command is '-'"
- }
-
# simulate autovivification of filehandles because
# it's too ugly to use @_ throughout to make perl do it for us
# tchrist 5-Mar-00
unless (eval {
- $dad_wtr = $_[1] = gensym unless defined $dad_wtr && length $dad_wtr;
- $dad_rdr = $_[2] = gensym unless defined $dad_rdr && length $dad_rdr;
+ $_[0] = gensym unless defined $_[0] && length $_[0];
+ $_[1] = gensym unless defined $_[1] && length $_[1];
1; })
{
# must strip crud for croak to add back, or looks ugly
@@ -216,30 +194,48 @@
croak "$Me: $@";
}
- $dad_err ||= $dad_rdr;
+ my @handles = ({ mode => '<', handle => \*STDIN },
+ { mode => '>', handle => \*STDOUT },
+ { mode => '>', handle => \*STDERR },
+ );
- $dup_wtr = ($dad_wtr =~ s/^[<>]&//);
- $dup_rdr = ($dad_rdr =~ s/^[<>]&//);
- $dup_err = ($dad_err =~ s/^[<>]&//);
+ foreach (@handles) {
+ $_->{parent} = shift;
+ $_->{open_as} = gensym;
+ }
- # force unqualified filehandles into caller's package
- $dad_wtr = qualify $dad_wtr, $package unless fh_is_fd($dad_wtr);
- $dad_rdr = qualify $dad_rdr, $package unless fh_is_fd($dad_rdr);
- $dad_err = qualify $dad_err, $package unless fh_is_fd($dad_err);
+ if (@_ > 1 and $_[0] eq '-') {
+ croak "Arguments don't make sense when the command is '-'"
+ }
- my $kid_rdr = gensym;
- my $kid_wtr = gensym;
- my $kid_err = gensym;
+ $handles[2]{parent} ||= $handles[1]{parent};
+ $handles[2]{dup_of_out} = $handles[1]{parent} eq $handles[2]{parent};
- xpipe $kid_rdr, $dad_wtr if !$dup_wtr;
- xpipe $dad_rdr, $kid_wtr if !$dup_rdr;
- xpipe $dad_err, $kid_err if !$dup_err && $dad_err ne $dad_rdr;
+ my $package;
+ foreach (@handles) {
+ $_->{dup} = ($_->{parent} =~ s/^[<>]&//);
+ if ($_->{parent} !~ /\A=?(\d+)\z/) {
+ # force unqualified filehandles into caller's package
+ $package //= caller 1;
+ $_->{parent} = qualify $_->{parent}, $package;
+ }
+
+ next if $_->{dup} or $_->{dup_of_out};
+ if ($_->{mode} eq '<') {
+ xpipe $_->{open_as}, $_->{parent};
+ } else {
+ xpipe $_->{parent}, $_->{open_as};
+ }
+ }
+
+ my $kidpid;
if (!DO_SPAWN) {
# Used to communicate exec failures.
xpipe my $stat_r, my $stat_w;
- $kidpid = xfork;
+ $kidpid = fork;
+ croak "$Me: fork failed: $!" unless defined $kidpid;
if ($kidpid == 0) { # Kid
eval {
# A tie in the parent should not be allowed to cause problems.
@@ -247,49 +243,43 @@
untie *STDOUT;
close $stat_r;
- xclose_on_exec $stat_w;
+ require Fcntl;
+ my $flags = fcntl $stat_w, &Fcntl::F_GETFD, 0;
+ croak "$Me: fcntl failed: $!" unless $flags;
+ fcntl $stat_w, &Fcntl::F_SETFD, $flags|&Fcntl::FD_CLOEXEC
+ or croak "$Me: fcntl failed: $!";
# If she wants to dup the kid's stderr onto her stdout I need to
# save a copy of her stdout before I put something else there.
- if ($dad_rdr ne $dad_err && $dup_err
- && xfileno($dad_err) == fileno(STDOUT)) {
+ if (!$handles[2]{dup_of_out} && $handles[2]{dup}
+ && xfileno($handles[2]{parent}) == fileno \*STDOUT) {
my $tmp = gensym;
- xopen($tmp, ">&$dad_err");
- $dad_err = $tmp;
+ xopen($tmp, '>&', $handles[2]{parent});
+ $handles[2]{parent} = $tmp;
}
- if ($dup_wtr) {
- xopen \*STDIN, "<&$dad_wtr" if fileno(STDIN) != xfileno($dad_wtr);
- } else {
- xclose $dad_wtr;
- xopen \*STDIN, "<&=" . fileno $kid_rdr;
- }
- if ($dup_rdr) {
- xopen \*STDOUT, ">&$dad_rdr" if fileno(STDOUT) != xfileno($dad_rdr);
- } else {
- xclose $dad_rdr;
- xopen \*STDOUT, ">&=" . fileno $kid_wtr;
- }
- if ($dad_rdr ne $dad_err) {
- if ($dup_err) {
- # I have to use a fileno here because in this one case
- # I'm doing a dup but the filehandle might be a reference
- # (from the special case above).
- xopen \*STDERR, ">&" . xfileno($dad_err)
- if fileno(STDERR) != xfileno($dad_err);
+ foreach (@handles) {
+ if ($_->{dup_of_out}) {
+ xopen \*STDERR, ">&STDOUT"
+ if defined fileno STDERR && fileno STDERR != fileno STDOUT;
+ } elsif ($_->{dup}) {
+ xopen $_->{handle}, $_->{mode} . '&', $_->{parent}
+ if fileno $_->{handle} != xfileno($_->{parent});
} else {
- xclose $dad_err;
- xopen \*STDERR, ">&=" . fileno $kid_err;
+ xclose $_->{parent}, $_->{mode};
+ xopen $_->{handle}, $_->{mode} . '&=',
+ fileno $_->{open_as};
}
- } else {
- xopen \*STDERR, ">&STDOUT" if fileno(STDERR) != fileno(STDOUT);
}
- return 0 if ($cmd[0] eq '-');
- exec @cmd or do {
+ return 1 if ($_[0] eq '-');
+ exec @_ or do {
local($")=(" ");
- croak "$Me: exec of @cmd failed";
+ croak "$Me: exec of @_ failed";
};
- };
+ } and do {
+ close $stat_w;
+ return 0;
+ };
my $bang = 0+$!;
my $err = $@;
@@ -322,52 +312,35 @@
# handled in spawn_with_handles.
my @close;
- if ($dup_wtr) {
- $kid_rdr = \*{$dad_wtr};
- push @close, $kid_rdr;
- } else {
- push @close, \*{$dad_wtr}, $kid_rdr;
- }
- if ($dup_rdr) {
- $kid_wtr = \*{$dad_rdr};
- push @close, $kid_wtr;
- } else {
- push @close, \*{$dad_rdr}, $kid_wtr;
- }
- if ($dad_rdr ne $dad_err) {
- if ($dup_err) {
- $kid_err = \*{$dad_err};
- push @close, $kid_err;
+
+ foreach (@handles) {
+ if ($_->{dup_of_out}) {
+ $_->{open_as} = $handles[1]{open_as};
+ } elsif ($_->{dup}) {
+ $_->{open_as} = $_->{parent} =~ /\A[0-9]+\z/
+ ? $_->{parent} : \*{$_->{parent}};
+ push @close, $_->{open_as};
} else {
- push @close, \*{$dad_err}, $kid_err;
+ push @close, \*{$_->{parent}}, $_->{open_as};
}
- } else {
- $kid_err = $kid_wtr;
}
require IO::Pipe;
$kidpid = eval {
- spawn_with_handles( [ { mode => 'r',
- open_as => $kid_rdr,
- handle => \*STDIN },
- { mode => 'w',
- open_as => $kid_wtr,
- handle => \*STDOUT },
- { mode => 'w',
- open_as => $kid_err,
- handle => \*STDERR },
- ], \@close, @cmd);
+ spawn_with_handles(\@handles, \@close, @_);
};
die "$Me: $@" if $@;
}
- xclose $kid_rdr if !$dup_wtr;
- xclose $kid_wtr if !$dup_rdr;
- xclose $kid_err if !$dup_err && $dad_rdr ne $dad_err;
+ foreach (@handles) {
+ next if $_->{dup} or $_->{dup_of_out};
+ xclose $_->{open_as}, $_->{mode};
+ }
+
# If the write handle is a dup give it away entirely, close my copy
# of it.
- xclose $dad_wtr if $dup_wtr;
+ xclose $handles[0]{parent}, $handles[0]{mode} if $handles[0]{dup};
- select((select($dad_wtr), $| = 1)[0]); # unbuffer pipe
+ select((select($handles[0]{parent}), $| = 1)[0]); # unbuffer pipe
$kidpid;
}
@@ -376,7 +349,7 @@
local $" = ', ';
croak "open3(@_): not enough arguments";
}
- return _open3 'open3', scalar caller, @_
+ return _open3 'open3', @_
}
sub spawn_with_handles {
@@ -383,11 +356,10 @@
my $fds = shift; # Fields: handle, mode, open_as
my $close_in_child = shift;
my ($fd, $pid, @saved_fh, $saved, %saved, @errs);
- require Fcntl;
foreach $fd (@$fds) {
$fd->{tmp_copy} = IO::Handle->new_from_fd($fd->{handle}, $fd->{mode});
- $saved{fileno $fd->{handle}} = $fd->{tmp_copy};
+ $saved{fileno $fd->{handle}} = $fd->{tmp_copy} if $fd->{tmp_copy};
}
foreach $fd (@$fds) {
bless $fd->{handle}, 'IO::Handle'
@@ -394,12 +366,16 @@
unless eval { $fd->{handle}->isa('IO::Handle') } ;
# If some of handles to redirect-to coincide with handles to
# redirect, we need to use saved variants:
- $fd->{handle}->fdopen($saved{fileno $fd->{open_as}} || $fd->{open_as},
+ $fd->{handle}->fdopen(defined fileno $fd->{open_as}
+ ? $saved{fileno $fd->{open_as}} || $fd->{open_as}
+ : $fd->{open_as},
$fd->{mode});
}
unless ($^O eq 'MSWin32') {
+ require Fcntl;
# Stderr may be redirected below, so we save the err text:
foreach $fd (@$close_in_child) {
+ next unless fileno $fd;
fcntl($fd, Fcntl::F_SETFD(), 1) or push @errs, "fcntl $fd: $!"
unless $saved{fileno $fd}; # Do not close what we redirect!
}
@@ -406,14 +382,36 @@
}
unless (@errs) {
- $pid = eval { system 1, @_ }; # 1 == P_NOWAIT
+ if (FORCE_DEBUG_SPAWN) {
+ pipe my $r, my $w or die "Pipe failed: $!";
+ $pid = fork;
+ die "Fork failed: $!" unless defined $pid;
+ if (!$pid) {
+ { no warnings; exec @_ }
+ print $w 0 + $!;
+ close $w;
+ require POSIX;
+ POSIX::_exit(255);
+ }
+ close $w;
+ my $bad = <$r>;
+ if (defined $bad) {
+ $! = $bad;
+ undef $pid;
+ }
+ } else {
+ $pid = eval { system 1, @_ }; # 1 == P_NOWAIT
+ }
push @errs, "IO::Pipe: Can't spawn-NOWAIT: $!" if !$pid || $pid < 0;
}
- foreach $fd (@$fds) {
+ # Do this in reverse, so that STDERR is restored first:
+ foreach $fd (reverse @$fds) {
$fd->{handle}->fdopen($fd->{tmp_copy}, $fd->{mode});
- $fd->{tmp_copy}->close or croak "Can't close: $!";
}
+ foreach (values %saved) {
+ $_->close or croak "Can't close: $!";
+ }
croak join "\n", @errs if @errs;
return $pid;
}
Property changes on: trunk/contrib/perl/ext/IPC-Open3/lib/IPC/Open3.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Copied: trunk/contrib/perl/ext/IPC-Open3/t/IPC-Open2.t (from rev 6437, vendor/perl/5.18.1/ext/IPC-Open3/t/IPC-Open2.t)
===================================================================
--- trunk/contrib/perl/ext/IPC-Open3/t/IPC-Open2.t (rev 0)
+++ trunk/contrib/perl/ext/IPC-Open3/t/IPC-Open2.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -0,0 +1,61 @@
+#!./perl -w
+
+use Config;
+BEGIN {
+ require Test::More;
+ if (!$Config{'d_fork'}
+ # open2/3 supported on win32
+ && $^O ne 'MSWin32' && $^O ne 'NetWare')
+ {
+ Test::More->import(skip_all => 'open2/3 not available with MSWin32+Netware');
+ exit 0;
+ }
+ # make warnings fatal
+ $SIG{__WARN__} = sub { die @_ };
+}
+
+use strict;
+use IPC::Open2;
+use Test::More tests => 15;
+
+my $perl = $^X;
+
+sub cmd_line {
+ if ($^O eq 'MSWin32' || $^O eq 'NetWare') {
+ return qq/"$_[0]"/;
+ }
+ else {
+ return $_[0];
+ }
+}
+
+STDOUT->autoflush;
+STDERR->autoflush;
+
+my $pid = open2('READ', 'WRITE', $perl, '-e', cmd_line('print scalar <STDIN>'));
+cmp_ok($pid, '>', 1, 'got a sane process ID');
+ok(print WRITE "hi kid\n");
+like(<READ>, qr/^hi kid\r?\n$/);
+ok(close(WRITE), "closing WRITE: $!");
+ok(close(READ), "closing READ: $!");
+my $reaped_pid = waitpid $pid, 0;
+is($reaped_pid, $pid, "Reaped PID matches");
+is($?, 0, '$? should be zero');
+
+{
+ package SKREEEK;
+ my $pid = IPC::Open2::open2('KAZOP', 'WRITE', $perl, '-e',
+ main::cmd_line('print scalar <STDIN>'));
+ main::cmp_ok($pid, '>', 1, 'got a sane process ID');
+ main::ok(print WRITE "hi kid\n");
+ main::like(<KAZOP>, qr/^hi kid\r?\n$/);
+ main::ok(close(WRITE), "closing WRITE: $!");
+ main::ok(close(KAZOP), "closing READ: $!");
+ my $reaped_pid = waitpid $pid, 0;
+ main::is($reaped_pid, $pid, "Reaped PID matches");
+ main::is($?, 0, '$? should be zero');
+}
+
+$pid = eval { open2('READ', '', $perl, '-e', cmd_line('print scalar <STDIN>')) };
+like($@, qr/^open2: Modification of a read-only value attempted at /,
+ 'open2 faults read-only parameters correctly') or do {waitpid $pid, 0};
Modified: trunk/contrib/perl/ext/IPC-Open3/t/IPC-Open3.t
===================================================================
--- trunk/contrib/perl/ext/IPC-Open3/t/IPC-Open3.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/IPC-Open3/t/IPC-Open3.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -3,8 +3,8 @@
BEGIN {
require Config; import Config;
if (!$Config{'d_fork'}
- # open2/3 supported on win32 (but not Borland due to CRT bugs)
- && (($^O ne 'MSWin32' && $^O ne 'NetWare') || $Config{'cc'} =~ /^bcc/i))
+ # open2/3 supported on win32
+ && $^O ne 'MSWin32' && $^O ne 'NetWare')
{
print "1..0\n";
exit 0;
@@ -14,7 +14,7 @@
}
use strict;
-use Test::More tests => 23;
+use Test::More tests => 37;
use IO::Handle;
use IPC::Open3;
@@ -96,6 +96,16 @@
print WRITE "ok $test\n";
waitpid $pid, 0;
+{
+ package YAAH;
+ $pid = IPC::Open3::open3('QWACK_WAAK_WAAK', '>&STDOUT', 'ERROR',
+ $perl, '-e', main::cmd_line('print scalar <STDIN>'));
+ ++$test;
+ no warnings 'once';
+ print QWACK_WAAK_WAAK "ok $test # filenames qualified to their package\n";
+ waitpid $pid, 0;
+}
+
# dup error: This particular case, duping stderr onto the existing
# stdout but putting stdout somewhere else, is a good case because it
# used not to work.
@@ -105,35 +115,25 @@
print WRITE "ok $test\n";
waitpid $pid, 0;
-# dup reader and error together, both named
-$pid = open3 'WRITE', '>&STDOUT', '>&STDOUT', $perl, '-e', cmd_line(<<'EOF');
+foreach (['>&STDOUT', 'both named'],
+ ['', 'error empty'],
+ ) {
+ my ($err, $desc) = @$_;
+ $pid = open3 'WRITE', '>&STDOUT', $err, $perl, '-e', cmd_line(<<'EOF');
$| = 1;
print STDOUT scalar <STDIN>;
print STDERR scalar <STDIN>;
EOF
-++$test;
-print WRITE "ok $test\n";
-++$test;
-print WRITE "ok $test\n";
-waitpid $pid, 0;
+ printf WRITE "ok %d # dup reader and error together, $desc\n", ++$test
+ for 0, 1;
+ waitpid $pid, 0;
+}
-# dup reader and error together, error empty
-$pid = open3 'WRITE', '>&STDOUT', '', $perl, '-e', cmd_line(<<'EOF');
- $| = 1;
- print STDOUT scalar <STDIN>;
- print STDERR scalar <STDIN>;
-EOF
-++$test;
-print WRITE "ok $test\n";
-++$test;
-print WRITE "ok $test\n";
-waitpid $pid, 0;
-
# command line in single parameter variant of open3
# for understanding of Config{'sh'} test see exec description in camel book
my $cmd = 'print(scalar(<STDIN>))';
$cmd = $Config{'sh'} =~ /sh/ ? "'$cmd'" : cmd_line($cmd);
-eval{$pid = open3 'WRITE', '>&STDOUT', 'ERROR', "$perl -e " . $cmd; };
+$pid = eval { open3 'WRITE', '>&STDOUT', 'ERROR', "$perl -e " . $cmd; };
if ($@) {
print "error $@\n";
++$test;
@@ -147,13 +147,38 @@
$TB->current_test($test);
# RT 72016
-eval{$pid = open3 'WRITE', 'READ', 'ERROR', '/non/existent/program'; };
-if (IPC::Open3::DO_SPAWN) {
- if ($@) {
- cmp_ok(waitpid($pid, 0), '>', 0);
+{
+ local $::TODO = "$^O returns a pid and doesn't throw an exception"
+ if $^O eq 'MSWin32';
+ $pid = eval { open3 'WRITE', 'READ', 'ERROR', '/non/existent/program'; };
+ isnt($@, '',
+ 'open3 of a non existent program fails with an exception in the parent')
+ or do {waitpid $pid, 0};
+}
+
+$pid = eval { open3 'WRITE', '', 'ERROR', '/non/existent/program'; };
+like($@, qr/^open3: Modification of a read-only value attempted at /,
+ 'open3 faults read-only parameters correctly') or do {waitpid $pid, 0};
+
+foreach my $handle (qw (DUMMY STDIN STDOUT STDERR)) {
+ local $::{$handle};
+ my $out = IO::Handle->new();
+ my $pid = eval {
+ local $SIG{__WARN__} = sub {
+ open my $fh, '>/dev/tty';
+ return if "@_" =~ m!^Use of uninitialized value \$fd.*IO/Handle\.pm!;
+ print $fh "@_";
+ die @_
+ };
+ open3 undef, $out, undef, $perl, '-le', "print q _# ${handle}_"
+ };
+ is($@, '', "No errors with localised $handle");
+ cmp_ok($pid, '>', 0, "Got a pid with localised $handle");
+ if ($handle eq 'STDOUT') {
+ is(<$out>, undef, "Expected no output with localised $handle");
} else {
- pass();
+ like(<$out>, qr/\A# $handle\r?\n\z/,
+ "Expected output with localised $handle");
}
-} else {
- isnt($@, '') or do {waitpid $pid, 0};
+ waitpid $pid, 0;
}
Property changes on: trunk/contrib/perl/ext/IPC-Open3/t/IPC-Open3.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/ext/IPC-Open3/t/fd.t
===================================================================
--- trunk/contrib/perl/ext/IPC-Open3/t/fd.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/IPC-Open3/t/fd.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -1,10 +1,6 @@
#!./perl
BEGIN {
- if (!PerlIO::Layer->find('perlio') || $ENV{PERLIO} eq 'stdio') {
- print "1..0 # Skip: not perlio\n";
- exit 0;
- }
if ($^O eq 'VMS') {
print "1..0 # Skip: needs porting, perhaps imitating Win32 mechanisms\n";
exit 0;
@@ -14,22 +10,36 @@
use strict;
use warnings;
-plan 2;
+plan 3;
# [perl #76474]
{
my $stderr = runperl(
switches => ['-MIPC::Open3', '-w'],
- prog => 'open STDIN, q _Makefile_ or die $!; open3(q _<&1_, my $out, undef, $ENV{PERLEXE}, q _-e0_)',
+ prog => 'open STDIN, q _Makefile_ or die $!; open3(q _<&0_, my $out, undef, $ENV{PERLEXE}, q _-e0_)',
stderr => 1,
);
- {
- local $::TODO = "Bogus warning in IPC::Open3::spawn_with_handles"
- if $^O eq 'MSWin32';
- $stderr =~ s/(Use of uninitialized value.*Open3\.pm line \d+\.)\n//;
- is($1, undef, 'No bogus warning found');
- }
is $stderr, '',
"dup STDOUT in a child process by using its file descriptor";
}
+
+{
+ my $want = qr/\A# This Makefile is for the IPC::Open3 extension to perl\.\r?\z/;
+ open my $fh, '<', 'Makefile' or die "Can't open MAKEFILE: $!";
+ my $have = <$fh>;
+ chomp $have;
+ like($have, $want, 'No surprises from MakeMaker');
+ close $fh;
+
+ fresh_perl_like(<<'EOP',
+use IPC::Open3;
+open FOO, 'Makefile' or die $!;
+open3('<&' . fileno FOO, my $out, undef, $ENV{PERLEXE}, '-eprint scalar <STDIN>');
+print <$out>;
+EOP
+ $want,
+ undef,
+ 'Numeric file handles are duplicated correctly'
+ );
+}
Property changes on: trunk/contrib/perl/ext/IPC-Open3/t/fd.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/NDBM_File/Makefile.PL
===================================================================
--- trunk/contrib/perl/ext/NDBM_File/Makefile.PL 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/NDBM_File/Makefile.PL 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/NDBM_File/Makefile.PL
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/ext/NDBM_File/NDBM_File.pm
===================================================================
--- trunk/contrib/perl/ext/NDBM_File/NDBM_File.pm 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/NDBM_File/NDBM_File.pm 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/NDBM_File/NDBM_File.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Index: trunk/contrib/perl/ext/NDBM_File/NDBM_File.xs
===================================================================
--- trunk/contrib/perl/ext/NDBM_File/NDBM_File.xs 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/NDBM_File/NDBM_File.xs 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/NDBM_File/NDBM_File.xs
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Index: trunk/contrib/perl/ext/NDBM_File/hints/cygwin.pl
===================================================================
--- trunk/contrib/perl/ext/NDBM_File/hints/cygwin.pl 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/NDBM_File/hints/cygwin.pl 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/NDBM_File/hints/cygwin.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/NDBM_File/hints/dec_osf.pl
===================================================================
--- trunk/contrib/perl/ext/NDBM_File/hints/dec_osf.pl 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/NDBM_File/hints/dec_osf.pl 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/NDBM_File/hints/dec_osf.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/NDBM_File/hints/dynixptx.pl
===================================================================
--- trunk/contrib/perl/ext/NDBM_File/hints/dynixptx.pl 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/NDBM_File/hints/dynixptx.pl 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/NDBM_File/hints/dynixptx.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Copied: trunk/contrib/perl/ext/NDBM_File/hints/gnu.pl (from rev 6437, vendor/perl/5.18.1/ext/NDBM_File/hints/gnu.pl)
===================================================================
--- trunk/contrib/perl/ext/NDBM_File/hints/gnu.pl (rev 0)
+++ trunk/contrib/perl/ext/NDBM_File/hints/gnu.pl 2013-12-02 21:32:26 UTC (rev 6445)
@@ -0,0 +1 @@
+do './hints/linux.pl' or die $@;
Index: trunk/contrib/perl/ext/NDBM_File/hints/gnukfreebsd.pl
===================================================================
--- trunk/contrib/perl/ext/NDBM_File/hints/gnukfreebsd.pl 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/NDBM_File/hints/gnukfreebsd.pl 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/NDBM_File/hints/gnukfreebsd.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/NDBM_File/hints/gnuknetbsd.pl
===================================================================
--- trunk/contrib/perl/ext/NDBM_File/hints/gnuknetbsd.pl 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/NDBM_File/hints/gnuknetbsd.pl 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/NDBM_File/hints/gnuknetbsd.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/NDBM_File/hints/linux.pl
===================================================================
--- trunk/contrib/perl/ext/NDBM_File/hints/linux.pl 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/NDBM_File/hints/linux.pl 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/NDBM_File/hints/linux.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/NDBM_File/hints/sco.pl
===================================================================
--- trunk/contrib/perl/ext/NDBM_File/hints/sco.pl 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/NDBM_File/hints/sco.pl 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/NDBM_File/hints/sco.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/NDBM_File/hints/solaris.pl
===================================================================
--- trunk/contrib/perl/ext/NDBM_File/hints/solaris.pl 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/NDBM_File/hints/solaris.pl 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/NDBM_File/hints/solaris.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/NDBM_File/hints/svr4.pl
===================================================================
--- trunk/contrib/perl/ext/NDBM_File/hints/svr4.pl 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/NDBM_File/hints/svr4.pl 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/NDBM_File/hints/svr4.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/NDBM_File/t/ndbm.t
===================================================================
--- trunk/contrib/perl/ext/NDBM_File/t/ndbm.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/NDBM_File/t/ndbm.t 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/NDBM_File/t/ndbm.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/ext/NDBM_File/typemap
===================================================================
--- trunk/contrib/perl/ext/NDBM_File/typemap 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/NDBM_File/typemap 2013-12-02 21:32:26 UTC (rev 6445)
@@ -11,7 +11,6 @@
ODBM_File T_PTROBJ
DB_File T_PTROBJ
DBZ_File T_PTROBJ
-FATALFUNC T_OPAQUEPTR
INPUT
T_DATUM_K
Property changes on: trunk/contrib/perl/ext/NDBM_File/typemap
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Index: trunk/contrib/perl/ext/ODBM_File/Makefile.PL
===================================================================
--- trunk/contrib/perl/ext/ODBM_File/Makefile.PL 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/ODBM_File/Makefile.PL 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/ODBM_File/Makefile.PL
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/ext/ODBM_File/ODBM_File.pm
===================================================================
--- trunk/contrib/perl/ext/ODBM_File/ODBM_File.pm 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/ODBM_File/ODBM_File.pm 2013-12-02 21:32:26 UTC (rev 6445)
@@ -7,7 +7,7 @@
require XSLoader;
our @ISA = qw(Tie::Hash);
-our $VERSION = "1.10";
+our $VERSION = "1.12";
XSLoader::load();
Property changes on: trunk/contrib/perl/ext/ODBM_File/ODBM_File.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/ext/ODBM_File/ODBM_File.xs
===================================================================
--- trunk/contrib/perl/ext/ODBM_File/ODBM_File.xs 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/ODBM_File/ODBM_File.xs 2013-12-02 21:32:26 UTC (rev 6445)
@@ -1,3 +1,5 @@
+#define PERL_NO_GET_CONTEXT
+
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
@@ -111,9 +113,9 @@
dbp = (void*)(dbminit(filename) >= 0 ? &dbmrefcnt : 0);
RETVAL = (ODBM_File)safecalloc(1, sizeof(ODBM_File_type));
RETVAL->dbp = dbp ;
- ST(0) = sv_mortalcopy(&PL_sv_undef);
- sv_setptrobj(ST(0), RETVAL, dbtype);
}
+ OUTPUT:
+ RETVAL
void
DESTROY(db)
Property changes on: trunk/contrib/perl/ext/ODBM_File/ODBM_File.xs
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/ext/ODBM_File/hints/cygwin.pl
===================================================================
--- trunk/contrib/perl/ext/ODBM_File/hints/cygwin.pl 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/ODBM_File/hints/cygwin.pl 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/ODBM_File/hints/cygwin.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/ODBM_File/hints/dec_osf.pl
===================================================================
--- trunk/contrib/perl/ext/ODBM_File/hints/dec_osf.pl 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/ODBM_File/hints/dec_osf.pl 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/ODBM_File/hints/dec_osf.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Copied: trunk/contrib/perl/ext/ODBM_File/hints/gnu.pl (from rev 6437, vendor/perl/5.18.1/ext/ODBM_File/hints/gnu.pl)
===================================================================
--- trunk/contrib/perl/ext/ODBM_File/hints/gnu.pl (rev 0)
+++ trunk/contrib/perl/ext/ODBM_File/hints/gnu.pl 2013-12-02 21:32:26 UTC (rev 6445)
@@ -0,0 +1 @@
+do './hints/linux.pl' or die $@;
Index: trunk/contrib/perl/ext/ODBM_File/hints/gnukfreebsd.pl
===================================================================
--- trunk/contrib/perl/ext/ODBM_File/hints/gnukfreebsd.pl 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/ODBM_File/hints/gnukfreebsd.pl 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/ODBM_File/hints/gnukfreebsd.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/ODBM_File/hints/gnuknetbsd.pl
===================================================================
--- trunk/contrib/perl/ext/ODBM_File/hints/gnuknetbsd.pl 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/ODBM_File/hints/gnuknetbsd.pl 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/ODBM_File/hints/gnuknetbsd.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/ODBM_File/hints/hpux.pl
===================================================================
--- trunk/contrib/perl/ext/ODBM_File/hints/hpux.pl 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/ODBM_File/hints/hpux.pl 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/ODBM_File/hints/hpux.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/ODBM_File/hints/linux.pl
===================================================================
--- trunk/contrib/perl/ext/ODBM_File/hints/linux.pl 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/ODBM_File/hints/linux.pl 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/ODBM_File/hints/linux.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/ext/ODBM_File/hints/sco.pl
===================================================================
--- trunk/contrib/perl/ext/ODBM_File/hints/sco.pl 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/ODBM_File/hints/sco.pl 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/ODBM_File/hints/sco.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/ODBM_File/hints/solaris.pl
===================================================================
--- trunk/contrib/perl/ext/ODBM_File/hints/solaris.pl 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/ODBM_File/hints/solaris.pl 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/ODBM_File/hints/solaris.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/ODBM_File/hints/svr4.pl
===================================================================
--- trunk/contrib/perl/ext/ODBM_File/hints/svr4.pl 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/ODBM_File/hints/svr4.pl 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/ODBM_File/hints/svr4.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/ODBM_File/hints/ultrix.pl
===================================================================
--- trunk/contrib/perl/ext/ODBM_File/hints/ultrix.pl 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/ODBM_File/hints/ultrix.pl 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/ODBM_File/hints/ultrix.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/ODBM_File/t/odbm.t
===================================================================
--- trunk/contrib/perl/ext/ODBM_File/t/odbm.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/ODBM_File/t/odbm.t 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/ODBM_File/t/odbm.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/ext/ODBM_File/typemap
===================================================================
--- trunk/contrib/perl/ext/ODBM_File/typemap 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/ODBM_File/typemap 2013-12-02 21:32:26 UTC (rev 6445)
@@ -12,7 +12,6 @@
ODBM_File T_PTROBJ
DB_File T_PTROBJ
DBZ_File T_PTROBJ
-FATALFUNC T_OPAQUEPTR
INPUT
T_DATUM_K
@@ -57,3 +56,5 @@
DBM_ckFilter($arg, filter[fetch_value],\"filter_fetch_value\");
T_GDATUM
sv_usepvn($arg, $var.dptr, $var.dsize);
+T_PTROBJ
+ sv_setref_pv($arg, dbtype, (void*)$var);
Property changes on: trunk/contrib/perl/ext/ODBM_File/typemap
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Copied: trunk/contrib/perl/ext/Opcode/Makefile.PL (from rev 6437, vendor/perl/5.18.1/ext/Opcode/Makefile.PL)
===================================================================
--- trunk/contrib/perl/ext/Opcode/Makefile.PL (rev 0)
+++ trunk/contrib/perl/ext/Opcode/Makefile.PL 2013-12-02 21:32:26 UTC (rev 6445)
@@ -0,0 +1,6 @@
+use ExtUtils::MakeMaker;
+WriteMakefile(
+ NAME => 'Opcode',
+ MAN3PODS => {},
+ VERSION_FROM => 'Opcode.pm',
+);
Modified: trunk/contrib/perl/ext/Opcode/Opcode.pm
===================================================================
--- trunk/contrib/perl/ext/Opcode/Opcode.pm 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/Opcode/Opcode.pm 2013-12-02 21:32:26 UTC (rev 6445)
@@ -6,7 +6,7 @@
our($VERSION, @ISA, @EXPORT_OK);
-$VERSION = "1.18";
+$VERSION = "1.25";
use Carp;
use Exporter ();
@@ -65,7 +65,7 @@
# Split into lines, keep only indented lines
my @lines = grep { m/^\s/ } split(/\n/);
- foreach (@lines) { s/--.*// } # delete comments
+ foreach (@lines) { s/(?:\t|--).*// } # delete comments
my @ops = map { split ' ' } @lines; # get op words
foreach(@ops) {
@@ -288,8 +288,8 @@
=head1 TO DO (maybe)
- $bool = opset_eq($opset1, $opset2) true if opsets are logically eqiv
-
+ $bool = opset_eq($opset1, $opset2) true if opsets are logically
+ equivalent
$yes = opset_can($opset, @ops) true if $opset has all @ops set
@diff = opset_diff($opset1, $opset2) => ('foo', '!bar', ...)
@@ -308,14 +308,14 @@
rv2sv sassign
- rv2av aassign aelem aelemfast aslice av2arylen
+ rv2av aassign aelem aelemfast aelemfast_lex aslice av2arylen
- rv2hv helem hslice each values keys exists delete aeach akeys avalues
- boolkeys reach rvalues rkeys
+ rv2hv helem hslice each values keys exists delete aeach akeys
+ avalues reach rvalues rkeys
- preinc i_preinc predec i_predec postinc i_postinc postdec i_postdec
- int hex oct abs pow multiply i_multiply divide i_divide
- modulo i_modulo add i_add subtract i_subtract
+ preinc i_preinc predec i_predec postinc i_postinc
+ postdec i_postdec int hex oct abs pow multiply i_multiply
+ divide i_divide modulo i_modulo add i_add subtract i_subtract
left_shift right_shift bit_and bit_xor bit_or negate i_negate
not complement
@@ -325,7 +325,8 @@
substr vec stringify study pos length index rindex ord chr
- ucfirst lcfirst uc lc quotemeta trans transr chop schop chomp schomp
+ ucfirst lcfirst uc lc fc quotemeta trans transr chop schop
+ chomp schomp
match split qr
@@ -335,11 +336,13 @@
warn die lineseq nextstate scope enter leave
- rv2cv anoncode prototype
+ rv2cv anoncode prototype coreargs
- entersub leavesub leavesublv return method method_named -- XXX loops via recursion?
+ entersub leavesub leavesublv return method method_named
+ -- XXX loops via recursion?
- leaveeval -- needed for Safe to operate, is safe without entereval
+ leaveeval -- needed for Safe to operate, is safe
+ without entereval
=item :base_mem
@@ -394,13 +397,14 @@
gvsv gv gelem
- padsv padav padhv padany
+ padsv padav padhv padcv padany padrange introcv clonecv
once
rv2gv refgen srefgen ref
- bless -- could be used to change ownership of objects (reblessing)
+ bless -- could be used to change ownership of objects
+ (reblessing)
pushre regcmaybe regcreset regcomp subst substcont
@@ -414,7 +418,8 @@
sselect select
pipe_op sockpair
- getppid getpgrp setpgrp getpriority setpriority localtime gmtime
+ getppid getpgrp setpgrp getpriority setpriority
+ localtime gmtime
entertry leavetry -- can be used to 'hide' fatal errors
@@ -460,9 +465,10 @@
stat lstat readlink
- ftatime ftblk ftchr ftctime ftdir fteexec fteowned fteread
- ftewrite ftfile ftis ftlink ftmtime ftpipe ftrexec ftrowned
- ftrread ftsgid ftsize ftsock ftsuid fttty ftzero ftrwrite ftsvtx
+ ftatime ftblk ftchr ftctime ftdir fteexec fteowned
+ fteread ftewrite ftfile ftis ftlink ftmtime ftpipe
+ ftrexec ftrowned ftrread ftsgid ftsize ftsock ftsuid
+ fttty ftzero ftrwrite ftsvtx
fttext ftbinary
@@ -506,7 +512,8 @@
utime chmod chown
- fcntl -- not strictly filesys related, but possibly as dangerous?
+ fcntl -- not strictly filesys related, but possibly as
+ dangerous?
=item :subprocess
@@ -543,7 +550,7 @@
about calling environment and args.
require dofile
- caller
+ caller runcv
=item :still_to_be_decided
Property changes on: trunk/contrib/perl/ext/Opcode/Opcode.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/ext/Opcode/Opcode.xs
===================================================================
--- trunk/contrib/perl/ext/Opcode/Opcode.xs 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/Opcode/Opcode.xs 2013-12-02 21:32:26 UTC (rev 6445)
@@ -294,8 +294,8 @@
/* the assignment to global defstash changes our sense of 'main' */
PL_defstash = gv_stashsv(Package, GV_ADDWARN); /* should exist already */
- save_hptr(&PL_curstash);
- PL_curstash = PL_defstash;
+ SAVEGENERICSV(PL_curstash);
+ PL_curstash = (HV *)SvREFCNT_inc_simple(PL_defstash);
/* defstash must itself contain a main:: so we'll add that now */
/* take care with the ref counts (was cause of long standing bug) */
Property changes on: trunk/contrib/perl/ext/Opcode/Opcode.xs
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Copied: trunk/contrib/perl/ext/Opcode/Safe.pm (from rev 6437, vendor/perl/5.18.1/ext/Opcode/Safe.pm)
===================================================================
--- trunk/contrib/perl/ext/Opcode/Safe.pm (rev 0)
+++ trunk/contrib/perl/ext/Opcode/Safe.pm 2013-12-02 21:32:26 UTC (rev 6445)
@@ -0,0 +1,621 @@
+package Safe;
+
+use 5.003_11;
+use strict;
+
+$Safe::VERSION = "2.12";
+
+# *** Don't declare any lexicals above this point ***
+#
+# This function should return a closure which contains an eval that can't
+# see any lexicals in scope (apart from __ExPr__ which is unavoidable)
+
+sub lexless_anon_sub {
+ # $_[0] is package;
+ # $_[1] is strict flag;
+ my $__ExPr__ = $_[2]; # must be a lexical to create the closure that
+ # can be used to pass the value into the safe
+ # world
+
+ # Create anon sub ref in root of compartment.
+ # Uses a closure (on $__ExPr__) to pass in the code to be executed.
+ # (eval on one line to keep line numbers as expected by caller)
+ eval sprintf
+ 'package %s; %s strict; sub { @_=(); eval q[my $__ExPr__;] . $__ExPr__; }',
+ $_[0], $_[1] ? 'use' : 'no';
+}
+
+use Carp;
+use Carp::Heavy;
+
+use Opcode 1.01, qw(
+ opset opset_to_ops opmask_add
+ empty_opset full_opset invert_opset verify_opset
+ opdesc opcodes opmask define_optag opset_to_hex
+);
+
+*ops_to_opset = \&opset; # Temporary alias for old Penguins
+
+
+my $default_root = 0;
+# share *_ and functions defined in universal.c
+# Don't share stuff like *UNIVERSAL:: otherwise code from the
+# compartment can 0wn functions in UNIVERSAL
+my $default_share = [qw[
+ *_
+ &PerlIO::get_layers
+ &Regexp::DESTROY
+ &re::is_regexp
+ &re::regname
+ &re::regnames
+ &re::regnames_count
+ &Tie::Hash::NamedCapture::FETCH
+ &Tie::Hash::NamedCapture::STORE
+ &Tie::Hash::NamedCapture::DELETE
+ &Tie::Hash::NamedCapture::CLEAR
+ &Tie::Hash::NamedCapture::EXISTS
+ &Tie::Hash::NamedCapture::FIRSTKEY
+ &Tie::Hash::NamedCapture::NEXTKEY
+ &Tie::Hash::NamedCapture::SCALAR
+ &Tie::Hash::NamedCapture::flags
+ &UNIVERSAL::isa
+ &UNIVERSAL::can
+ &UNIVERSAL::DOES
+ &UNIVERSAL::VERSION
+ &utf8::is_utf8
+ &utf8::valid
+ &utf8::encode
+ &utf8::decode
+ &utf8::upgrade
+ &utf8::downgrade
+ &utf8::native_to_unicode
+ &utf8::unicode_to_native
+ &version::()
+ &version::new
+ &version::(""
+ &version::stringify
+ &version::(0+
+ &version::numify
+ &version::normal
+ &version::(cmp
+ &version::(<=>
+ &version::vcmp
+ &version::(bool
+ &version::boolean
+ &version::(nomethod
+ &version::noop
+ &version::is_alpha
+ &version::qv
+]];
+
+sub new {
+ my($class, $root, $mask) = @_;
+ my $obj = {};
+ bless $obj, $class;
+
+ if (defined($root)) {
+ croak "Can't use \"$root\" as root name"
+ if $root =~ /^main\b/ or $root !~ /^\w[:\w]*$/;
+ $obj->{Root} = $root;
+ $obj->{Erase} = 0;
+ }
+ else {
+ $obj->{Root} = "Safe::Root".$default_root++;
+ $obj->{Erase} = 1;
+ }
+
+ # use permit/deny methods instead till interface issues resolved
+ # XXX perhaps new Safe 'Root', mask => $mask, foo => bar, ...;
+ croak "Mask parameter to new no longer supported" if defined $mask;
+ $obj->permit_only(':default');
+
+ # We must share $_ and @_ with the compartment or else ops such
+ # as split, length and so on won't default to $_ properly, nor
+ # will passing argument to subroutines work (via @_). In fact,
+ # for reasons I don't completely understand, we need to share
+ # the whole glob *_ rather than $_ and @_ separately, otherwise
+ # @_ in non default packages within the compartment don't work.
+ $obj->share_from('main', $default_share);
+ Opcode::_safe_pkg_prep($obj->{Root}) if($Opcode::VERSION > 1.04);
+ return $obj;
+}
+
+sub DESTROY {
+ my $obj = shift;
+ $obj->erase('DESTROY') if $obj->{Erase};
+}
+
+sub erase {
+ my ($obj, $action) = @_;
+ my $pkg = $obj->root();
+ my ($stem, $leaf);
+
+ no strict 'refs';
+ $pkg = "main::$pkg\::"; # expand to full symbol table name
+ ($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/;
+
+ # The 'my $foo' is needed! Without it you get an
+ # 'Attempt to free unreferenced scalar' warning!
+ my $stem_symtab = *{$stem}{HASH};
+
+ #warn "erase($pkg) stem=$stem, leaf=$leaf";
+ #warn " stem_symtab hash ".scalar(%$stem_symtab)."\n";
+ # ", join(', ', %$stem_symtab),"\n";
+
+# delete $stem_symtab->{$leaf};
+
+ my $leaf_glob = $stem_symtab->{$leaf};
+ my $leaf_symtab = *{$leaf_glob}{HASH};
+# warn " leaf_symtab ", join(', ', %$leaf_symtab),"\n";
+ %$leaf_symtab = ();
+ #delete $leaf_symtab->{'__ANON__'};
+ #delete $leaf_symtab->{'foo'};
+ #delete $leaf_symtab->{'main::'};
+# my $foo = undef ${"$stem\::"}{"$leaf\::"};
+
+ if ($action and $action eq 'DESTROY') {
+ delete $stem_symtab->{$leaf};
+ } else {
+ $obj->share_from('main', $default_share);
+ }
+ 1;
+}
+
+
+sub reinit {
+ my $obj= shift;
+ $obj->erase;
+ $obj->share_redo;
+}
+
+sub root {
+ my $obj = shift;
+ croak("Safe root method now read-only") if @_;
+ return $obj->{Root};
+}
+
+
+sub mask {
+ my $obj = shift;
+ return $obj->{Mask} unless @_;
+ $obj->deny_only(@_);
+}
+
+# v1 compatibility methods
+sub trap { shift->deny(@_) }
+sub untrap { shift->permit(@_) }
+
+sub deny {
+ my $obj = shift;
+ $obj->{Mask} |= opset(@_);
+}
+sub deny_only {
+ my $obj = shift;
+ $obj->{Mask} = opset(@_);
+}
+
+sub permit {
+ my $obj = shift;
+ # XXX needs testing
+ $obj->{Mask} &= invert_opset opset(@_);
+}
+sub permit_only {
+ my $obj = shift;
+ $obj->{Mask} = invert_opset opset(@_);
+}
+
+
+sub dump_mask {
+ my $obj = shift;
+ print opset_to_hex($obj->{Mask}),"\n";
+}
+
+
+
+sub share {
+ my($obj, @vars) = @_;
+ $obj->share_from(scalar(caller), \@vars);
+}
+
+sub share_from {
+ my $obj = shift;
+ my $pkg = shift;
+ my $vars = shift;
+ my $no_record = shift || 0;
+ my $root = $obj->root();
+ croak("vars not an array ref") unless ref $vars eq 'ARRAY';
+ no strict 'refs';
+ # Check that 'from' package actually exists
+ croak("Package \"$pkg\" does not exist")
+ unless keys %{"$pkg\::"};
+ my $arg;
+ foreach $arg (@$vars) {
+ # catch some $safe->share($var) errors:
+ my ($var, $type);
+ $type = $1 if ($var = $arg) =~ s/^(\W)//;
+ # warn "share_from $pkg $type $var";
+ *{$root."::$var"} = (!$type) ? \&{$pkg."::$var"}
+ : ($type eq '&') ? \&{$pkg."::$var"}
+ : ($type eq '$') ? \${$pkg."::$var"}
+ : ($type eq '@') ? \@{$pkg."::$var"}
+ : ($type eq '%') ? \%{$pkg."::$var"}
+ : ($type eq '*') ? *{$pkg."::$var"}
+ : croak(qq(Can't share "$type$var" of unknown type));
+ }
+ $obj->share_record($pkg, $vars) unless $no_record or !$vars;
+}
+
+sub share_record {
+ my $obj = shift;
+ my $pkg = shift;
+ my $vars = shift;
+ my $shares = \%{$obj->{Shares} ||= {}};
+ # Record shares using keys of $obj->{Shares}. See reinit.
+ @{$shares}{@$vars} = ($pkg) x @$vars if @$vars;
+}
+sub share_redo {
+ my $obj = shift;
+ my $shares = \%{$obj->{Shares} ||= {}};
+ my($var, $pkg);
+ while(($var, $pkg) = each %$shares) {
+ # warn "share_redo $pkg\:: $var";
+ $obj->share_from($pkg, [ $var ], 1);
+ }
+}
+sub share_forget {
+ delete shift->{Shares};
+}
+
+sub varglob {
+ my ($obj, $var) = @_;
+ no strict 'refs';
+ return *{$obj->root()."::$var"};
+}
+
+
+sub reval {
+ my ($obj, $expr, $strict) = @_;
+ my $root = $obj->{Root};
+
+ my $evalsub = lexless_anon_sub($root,$strict, $expr);
+ return Opcode::_safe_call_sv($root, $obj->{Mask}, $evalsub);
+}
+
+sub rdo {
+ my ($obj, $file) = @_;
+ my $root = $obj->{Root};
+
+ my $evalsub = eval
+ sprintf('package %s; sub { @_ = (); do $file }', $root);
+ return Opcode::_safe_call_sv($root, $obj->{Mask}, $evalsub);
+}
+
+
+1;
+
+__END__
+
+=head1 NAME
+
+Safe - Compile and execute code in restricted compartments
+
+=head1 SYNOPSIS
+
+ use Safe;
+
+ $compartment = new Safe;
+
+ $compartment->permit(qw(time sort :browse));
+
+ $result = $compartment->reval($unsafe_code);
+
+=head1 DESCRIPTION
+
+The Safe extension module allows the creation of compartments
+in which perl code can be evaluated. Each compartment has
+
+=over 8
+
+=item a new namespace
+
+The "root" of the namespace (i.e. "main::") is changed to a
+different package and code evaluated in the compartment cannot
+refer to variables outside this namespace, even with run-time
+glob lookups and other tricks.
+
+Code which is compiled outside the compartment can choose to place
+variables into (or I<share> variables with) the compartment's namespace
+and only that data will be visible to code evaluated in the
+compartment.
+
+By default, the only variables shared with compartments are the
+"underscore" variables $_ and @_ (and, technically, the less frequently
+used %_, the _ filehandle and so on). This is because otherwise perl
+operators which default to $_ will not work and neither will the
+assignment of arguments to @_ on subroutine entry.
+
+=item an operator mask
+
+Each compartment has an associated "operator mask". Recall that
+perl code is compiled into an internal format before execution.
+Evaluating perl code (e.g. via "eval" or "do 'file'") causes
+the code to be compiled into an internal format and then,
+provided there was no error in the compilation, executed.
+Code evaluated in a compartment compiles subject to the
+compartment's operator mask. Attempting to evaluate code in a
+compartment which contains a masked operator will cause the
+compilation to fail with an error. The code will not be executed.
+
+The default operator mask for a newly created compartment is
+the ':default' optag.
+
+It is important that you read the L<Opcode> module documentation
+for more information, especially for detailed definitions of opnames,
+optags and opsets.
+
+Since it is only at the compilation stage that the operator mask
+applies, controlled access to potentially unsafe operations can
+be achieved by having a handle to a wrapper subroutine (written
+outside the compartment) placed into the compartment. For example,
+
+ $cpt = new Safe;
+ sub wrapper {
+ # vet arguments and perform potentially unsafe operations
+ }
+ $cpt->share('&wrapper');
+
+=back
+
+
+=head1 WARNING
+
+The authors make B<no warranty>, implied or otherwise, about the
+suitability of this software for safety or security purposes.
+
+The authors shall not in any case be liable for special, incidental,
+consequential, indirect or other similar damages arising from the use
+of this software.
+
+Your mileage will vary. If in any doubt B<do not use it>.
+
+
+=head2 RECENT CHANGES
+
+The interface to the Safe module has changed quite dramatically since
+version 1 (as supplied with Perl5.002). Study these pages carefully if
+you have code written to use Safe version 1 because you will need to
+makes changes.
+
+
+=head2 Methods in class Safe
+
+To create a new compartment, use
+
+ $cpt = new Safe;
+
+Optional argument is (NAMESPACE), where NAMESPACE is the root namespace
+to use for the compartment (defaults to "Safe::Root0", incremented for
+each new compartment).
+
+Note that version 1.00 of the Safe module supported a second optional
+parameter, MASK. That functionality has been withdrawn pending deeper
+consideration. Use the permit and deny methods described below.
+
+The following methods can then be used on the compartment
+object returned by the above constructor. The object argument
+is implicit in each case.
+
+
+=over 8
+
+=item permit (OP, ...)
+
+Permit the listed operators to be used when compiling code in the
+compartment (in I<addition> to any operators already permitted).
+
+You can list opcodes by names, or use a tag name; see
+L<Opcode/"Predefined Opcode Tags">.
+
+=item permit_only (OP, ...)
+
+Permit I<only> the listed operators to be used when compiling code in
+the compartment (I<no> other operators are permitted).
+
+=item deny (OP, ...)
+
+Deny the listed operators from being used when compiling code in the
+compartment (other operators may still be permitted).
+
+=item deny_only (OP, ...)
+
+Deny I<only> the listed operators from being used when compiling code
+in the compartment (I<all> other operators will be permitted).
+
+=item trap (OP, ...)
+
+=item untrap (OP, ...)
+
+The trap and untrap methods are synonyms for deny and permit
+respectfully.
+
+=item share (NAME, ...)
+
+This shares the variable(s) in the argument list with the compartment.
+This is almost identical to exporting variables using the L<Exporter>
+module.
+
+Each NAME must be the B<name> of a non-lexical variable, typically
+with the leading type identifier included. A bareword is treated as a
+function name.
+
+Examples of legal names are '$foo' for a scalar, '@foo' for an
+array, '%foo' for a hash, '&foo' or 'foo' for a subroutine and '*foo'
+for a glob (i.e. all symbol table entries associated with "foo",
+including scalar, array, hash, sub and filehandle).
+
+Each NAME is assumed to be in the calling package. See share_from
+for an alternative method (which share uses).
+
+=item share_from (PACKAGE, ARRAYREF)
+
+This method is similar to share() but allows you to explicitly name the
+package that symbols should be shared from. The symbol names (including
+type characters) are supplied as an array reference.
+
+ $safe->share_from('main', [ '$foo', '%bar', 'func' ]);
+
+
+=item varglob (VARNAME)
+
+This returns a glob reference for the symbol table entry of VARNAME in
+the package of the compartment. VARNAME must be the B<name> of a
+variable without any leading type marker. For example,
+
+ $cpt = new Safe 'Root';
+ $Root::foo = "Hello world";
+ # Equivalent version which doesn't need to know $cpt's package name:
+ ${$cpt->varglob('foo')} = "Hello world";
+
+
+=item reval (STRING)
+
+This evaluates STRING as perl code inside the compartment.
+
+The code can only see the compartment's namespace (as returned by the
+B<root> method). The compartment's root package appears to be the
+C<main::> package to the code inside the compartment.
+
+Any attempt by the code in STRING to use an operator which is not permitted
+by the compartment will cause an error (at run-time of the main program
+but at compile-time for the code in STRING). The error is of the form
+"'%s' trapped by operation mask...".
+
+If an operation is trapped in this way, then the code in STRING will
+not be executed. If such a trapped operation occurs or any other
+compile-time or return error, then $@ is set to the error message, just
+as with an eval().
+
+If there is no error, then the method returns the value of the last
+expression evaluated, or a return statement may be used, just as with
+subroutines and B<eval()>. The context (list or scalar) is determined
+by the caller as usual.
+
+This behaviour differs from the beta distribution of the Safe extension
+where earlier versions of perl made it hard to mimic the return
+behaviour of the eval() command and the context was always scalar.
+
+Some points to note:
+
+If the entereval op is permitted then the code can use eval "..." to
+'hide' code which might use denied ops. This is not a major problem
+since when the code tries to execute the eval it will fail because the
+opmask is still in effect. However this technique would allow clever,
+and possibly harmful, code to 'probe' the boundaries of what is
+possible.
+
+Any string eval which is executed by code executing in a compartment,
+or by code called from code executing in a compartment, will be eval'd
+in the namespace of the compartment. This is potentially a serious
+problem.
+
+Consider a function foo() in package pkg compiled outside a compartment
+but shared with it. Assume the compartment has a root package called
+'Root'. If foo() contains an eval statement like eval '$foo = 1' then,
+normally, $pkg::foo will be set to 1. If foo() is called from the
+compartment (by whatever means) then instead of setting $pkg::foo, the
+eval will actually set $Root::pkg::foo.
+
+This can easily be demonstrated by using a module, such as the Socket
+module, which uses eval "..." as part of an AUTOLOAD function. You can
+'use' the module outside the compartment and share an (autoloaded)
+function with the compartment. If an autoload is triggered by code in
+the compartment, or by any code anywhere that is called by any means
+from the compartment, then the eval in the Socket module's AUTOLOAD
+function happens in the namespace of the compartment. Any variables
+created or used by the eval'd code are now under the control of
+the code in the compartment.
+
+A similar effect applies to I<all> runtime symbol lookups in code
+called from a compartment but not compiled within it.
+
+
+
+=item rdo (FILENAME)
+
+This evaluates the contents of file FILENAME inside the compartment.
+See above documentation on the B<reval> method for further details.
+
+=item root (NAMESPACE)
+
+This method returns the name of the package that is the root of the
+compartment's namespace.
+
+Note that this behaviour differs from version 1.00 of the Safe module
+where the root module could be used to change the namespace. That
+functionality has been withdrawn pending deeper consideration.
+
+=item mask (MASK)
+
+This is a get-or-set method for the compartment's operator mask.
+
+With no MASK argument present, it returns the current operator mask of
+the compartment.
+
+With the MASK argument present, it sets the operator mask for the
+compartment (equivalent to calling the deny_only method).
+
+=back
+
+
+=head2 Some Safety Issues
+
+This section is currently just an outline of some of the things code in
+a compartment might do (intentionally or unintentionally) which can
+have an effect outside the compartment.
+
+=over 8
+
+=item Memory
+
+Consuming all (or nearly all) available memory.
+
+=item CPU
+
+Causing infinite loops etc.
+
+=item Snooping
+
+Copying private information out of your system. Even something as
+simple as your user name is of value to others. Much useful information
+could be gleaned from your environment variables for example.
+
+=item Signals
+
+Causing signals (especially SIGFPE and SIGALARM) to affect your process.
+
+Setting up a signal handler will need to be carefully considered
+and controlled. What mask is in effect when a signal handler
+gets called? If a user can get an imported function to get an
+exception and call the user's signal handler, does that user's
+restricted mask get re-instated before the handler is called?
+Does an imported handler get called with its original mask or
+the user's one?
+
+=item State Changes
+
+Ops such as chdir obviously effect the process as a whole and not just
+the code in the compartment. Ops such as rand and srand have a similar
+but more subtle effect.
+
+=back
+
+=head2 AUTHOR
+
+Originally designed and implemented by Malcolm Beattie.
+
+Reworked to use the Opcode module and other changes added by Tim Bunce.
+
+Currently maintained by the Perl 5 Porters, <perl5-porters at perl.org>.
+
+=cut
+
Index: trunk/contrib/perl/ext/Opcode/ops.pm
===================================================================
--- trunk/contrib/perl/ext/Opcode/ops.pm 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/Opcode/ops.pm 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/Opcode/ops.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/ext/Opcode/t/Opcode.t
===================================================================
--- trunk/contrib/perl/ext/Opcode/t/Opcode.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/Opcode/t/Opcode.t 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/Opcode/t/Opcode.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/ext/Opcode/t/ops.t
===================================================================
--- trunk/contrib/perl/ext/Opcode/t/ops.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/Opcode/t/ops.t 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/Opcode/t/ops.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/ext/POSIX/Makefile.PL
===================================================================
--- trunk/contrib/perl/ext/POSIX/Makefile.PL 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/POSIX/Makefile.PL 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/POSIX/Makefile.PL
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Copied: trunk/contrib/perl/ext/POSIX/POSIX.pm (from rev 6437, vendor/perl/5.18.1/ext/POSIX/POSIX.pm)
===================================================================
--- trunk/contrib/perl/ext/POSIX/POSIX.pm (rev 0)
+++ trunk/contrib/perl/ext/POSIX/POSIX.pm 2013-12-02 21:32:26 UTC (rev 6445)
@@ -0,0 +1,1042 @@
+package POSIX;
+use strict;
+use warnings;
+
+our(@ISA, %EXPORT_TAGS, @EXPORT_OK, @EXPORT, $AUTOLOAD, %SIGRT) = ();
+
+our $VERSION = "1.17";
+
+use AutoLoader;
+
+use XSLoader ();
+
+use Fcntl qw(FD_CLOEXEC F_DUPFD F_GETFD F_GETFL F_GETLK F_RDLCK F_SETFD
+ F_SETFL F_SETLK F_SETLKW F_UNLCK F_WRLCK O_ACCMODE O_APPEND
+ O_CREAT O_EXCL O_NOCTTY O_NONBLOCK O_RDONLY O_RDWR O_TRUNC
+ O_WRONLY SEEK_CUR SEEK_END SEEK_SET
+ S_ISBLK S_ISCHR S_ISDIR S_ISFIFO S_ISREG
+ S_IRGRP S_IROTH S_IRUSR S_IRWXG S_IRWXO S_IRWXU S_ISGID S_ISUID
+ S_IWGRP S_IWOTH S_IWUSR S_IXGRP S_IXOTH S_IXUSR);
+
+# Grandfather old foo_h form to new :foo_h form
+my $loaded;
+
+sub import {
+ load_imports() unless $loaded++;
+ my $this = shift;
+ my @list = map { m/^\w+_h$/ ? ":$_" : $_ } @_;
+ local $Exporter::ExportLevel = 1;
+ Exporter::import($this, at list);
+}
+
+sub croak { require Carp; goto &Carp::croak }
+# declare usage to assist AutoLoad
+sub usage;
+
+XSLoader::load 'POSIX', $VERSION;
+
+sub AUTOLOAD {
+ no strict;
+ no warnings 'uninitialized';
+ if ($AUTOLOAD =~ /::(_?[a-z])/) {
+ # require AutoLoader;
+ $AutoLoader::AUTOLOAD = $AUTOLOAD;
+ goto &AutoLoader::AUTOLOAD
+ }
+ local $! = 0;
+ my $constname = $AUTOLOAD;
+ $constname =~ s/.*:://;
+ my ($error, $val) = constant($constname);
+ croak $error if $error;
+ *$AUTOLOAD = sub { $val };
+
+ goto &$AUTOLOAD;
+}
+
+package POSIX::SigAction;
+
+use AutoLoader 'AUTOLOAD';
+
+package POSIX::SigRt;
+
+use AutoLoader 'AUTOLOAD';
+
+use Tie::Hash;
+
+use vars qw($SIGACTION_FLAGS $_SIGRTMIN $_SIGRTMAX $_sigrtn @ISA);
+ at POSIX::SigRt::ISA = qw(Tie::StdHash);
+
+$SIGACTION_FLAGS = 0;
+
+tie %POSIX::SIGRT, 'POSIX::SigRt';
+
+sub DESTROY {};
+
+package POSIX;
+
+1;
+__END__
+
+sub usage {
+ my ($mess) = @_;
+ croak "Usage: POSIX::$mess";
+}
+
+sub redef {
+ my ($mess) = @_;
+ croak "Use method $mess instead";
+}
+
+sub unimpl {
+ my ($mess) = @_;
+ $mess =~ s/xxx//;
+ croak "Unimplemented: POSIX::$mess";
+}
+
+sub assert {
+ usage "assert(expr)" if @_ != 1;
+ if (!$_[0]) {
+ croak "Assertion failed";
+ }
+}
+
+sub tolower {
+ usage "tolower(string)" if @_ != 1;
+ lc($_[0]);
+}
+
+sub toupper {
+ usage "toupper(string)" if @_ != 1;
+ uc($_[0]);
+}
+
+sub closedir {
+ usage "closedir(dirhandle)" if @_ != 1;
+ CORE::closedir($_[0]);
+}
+
+sub opendir {
+ usage "opendir(directory)" if @_ != 1;
+ my $dirhandle;
+ CORE::opendir($dirhandle, $_[0])
+ ? $dirhandle
+ : undef;
+}
+
+sub readdir {
+ usage "readdir(dirhandle)" if @_ != 1;
+ CORE::readdir($_[0]);
+}
+
+sub rewinddir {
+ usage "rewinddir(dirhandle)" if @_ != 1;
+ CORE::rewinddir($_[0]);
+}
+
+sub errno {
+ usage "errno()" if @_ != 0;
+ $! + 0;
+}
+
+sub creat {
+ usage "creat(filename, mode)" if @_ != 2;
+ &open($_[0], &O_WRONLY | &O_CREAT | &O_TRUNC, $_[1]);
+}
+
+sub fcntl {
+ usage "fcntl(filehandle, cmd, arg)" if @_ != 3;
+ CORE::fcntl($_[0], $_[1], $_[2]);
+}
+
+sub getgrgid {
+ usage "getgrgid(gid)" if @_ != 1;
+ CORE::getgrgid($_[0]);
+}
+
+sub getgrnam {
+ usage "getgrnam(name)" if @_ != 1;
+ CORE::getgrnam($_[0]);
+}
+
+sub atan2 {
+ usage "atan2(x,y)" if @_ != 2;
+ CORE::atan2($_[0], $_[1]);
+}
+
+sub cos {
+ usage "cos(x)" if @_ != 1;
+ CORE::cos($_[0]);
+}
+
+sub exp {
+ usage "exp(x)" if @_ != 1;
+ CORE::exp($_[0]);
+}
+
+sub fabs {
+ usage "fabs(x)" if @_ != 1;
+ CORE::abs($_[0]);
+}
+
+sub log {
+ usage "log(x)" if @_ != 1;
+ CORE::log($_[0]);
+}
+
+sub pow {
+ usage "pow(x,exponent)" if @_ != 2;
+ $_[0] ** $_[1];
+}
+
+sub sin {
+ usage "sin(x)" if @_ != 1;
+ CORE::sin($_[0]);
+}
+
+sub sqrt {
+ usage "sqrt(x)" if @_ != 1;
+ CORE::sqrt($_[0]);
+}
+
+sub getpwnam {
+ usage "getpwnam(name)" if @_ != 1;
+ CORE::getpwnam($_[0]);
+}
+
+sub getpwuid {
+ usage "getpwuid(uid)" if @_ != 1;
+ CORE::getpwuid($_[0]);
+}
+
+sub longjmp {
+ unimpl "longjmp() is C-specific: use die instead";
+}
+
+sub setjmp {
+ unimpl "setjmp() is C-specific: use eval {} instead";
+}
+
+sub siglongjmp {
+ unimpl "siglongjmp() is C-specific: use die instead";
+}
+
+sub sigsetjmp {
+ unimpl "sigsetjmp() is C-specific: use eval {} instead";
+}
+
+sub kill {
+ usage "kill(pid, sig)" if @_ != 2;
+ CORE::kill $_[1], $_[0];
+}
+
+sub raise {
+ usage "raise(sig)" if @_ != 1;
+ CORE::kill $_[0], $$; # Is this good enough?
+}
+
+sub offsetof {
+ unimpl "offsetof() is C-specific, stopped";
+}
+
+sub clearerr {
+ redef "IO::Handle::clearerr()";
+}
+
+sub fclose {
+ redef "IO::Handle::close()";
+}
+
+sub fdopen {
+ redef "IO::Handle::new_from_fd()";
+}
+
+sub feof {
+ redef "IO::Handle::eof()";
+}
+
+sub fgetc {
+ redef "IO::Handle::getc()";
+}
+
+sub fgets {
+ redef "IO::Handle::gets()";
+}
+
+sub fileno {
+ redef "IO::Handle::fileno()";
+}
+
+sub fopen {
+ redef "IO::File::open()";
+}
+
+sub fprintf {
+ unimpl "fprintf() is C-specific--use printf instead";
+}
+
+sub fputc {
+ unimpl "fputc() is C-specific--use print instead";
+}
+
+sub fputs {
+ unimpl "fputs() is C-specific--use print instead";
+}
+
+sub fread {
+ unimpl "fread() is C-specific--use read instead";
+}
+
+sub freopen {
+ unimpl "freopen() is C-specific--use open instead";
+}
+
+sub fscanf {
+ unimpl "fscanf() is C-specific--use <> and regular expressions instead";
+}
+
+sub fseek {
+ redef "IO::Seekable::seek()";
+}
+
+sub fsync {
+ redef "IO::Handle::sync()";
+}
+
+sub ferror {
+ redef "IO::Handle::error()";
+}
+
+sub fflush {
+ redef "IO::Handle::flush()";
+}
+
+sub fgetpos {
+ redef "IO::Seekable::getpos()";
+}
+
+sub fsetpos {
+ redef "IO::Seekable::setpos()";
+}
+
+sub ftell {
+ redef "IO::Seekable::tell()";
+}
+
+sub fwrite {
+ unimpl "fwrite() is C-specific--use print instead";
+}
+
+sub getc {
+ usage "getc(handle)" if @_ != 1;
+ CORE::getc($_[0]);
+}
+
+sub getchar {
+ usage "getchar()" if @_ != 0;
+ CORE::getc(STDIN);
+}
+
+sub gets {
+ usage "gets()" if @_ != 0;
+ scalar <STDIN>;
+}
+
+sub perror {
+ print STDERR "@_: " if @_;
+ print STDERR $!,"\n";
+}
+
+sub printf {
+ usage "printf(pattern, args...)" if @_ < 1;
+ CORE::printf STDOUT @_;
+}
+
+sub putc {
+ unimpl "putc() is C-specific--use print instead";
+}
+
+sub putchar {
+ unimpl "putchar() is C-specific--use print instead";
+}
+
+sub puts {
+ unimpl "puts() is C-specific--use print instead";
+}
+
+sub remove {
+ usage "remove(filename)" if @_ != 1;
+ (-d $_[0]) ? CORE::rmdir($_[0]) : CORE::unlink($_[0]);
+}
+
+sub rename {
+ usage "rename(oldfilename, newfilename)" if @_ != 2;
+ CORE::rename($_[0], $_[1]);
+}
+
+sub rewind {
+ usage "rewind(filehandle)" if @_ != 1;
+ CORE::seek($_[0],0,0);
+}
+
+sub scanf {
+ unimpl "scanf() is C-specific--use <> and regular expressions instead";
+}
+
+sub sprintf {
+ usage "sprintf(pattern,args)" if @_ == 0;
+ CORE::sprintf(shift, at _);
+}
+
+sub sscanf {
+ unimpl "sscanf() is C-specific--use regular expressions instead";
+}
+
+sub tmpfile {
+ redef "IO::File::new_tmpfile()";
+}
+
+sub ungetc {
+ redef "IO::Handle::ungetc()";
+}
+
+sub vfprintf {
+ unimpl "vfprintf() is C-specific";
+}
+
+sub vprintf {
+ unimpl "vprintf() is C-specific";
+}
+
+sub vsprintf {
+ unimpl "vsprintf() is C-specific";
+}
+
+sub abs {
+ usage "abs(x)" if @_ != 1;
+ CORE::abs($_[0]);
+}
+
+sub atexit {
+ unimpl "atexit() is C-specific: use END {} instead";
+}
+
+sub atof {
+ unimpl "atof() is C-specific, stopped";
+}
+
+sub atoi {
+ unimpl "atoi() is C-specific, stopped";
+}
+
+sub atol {
+ unimpl "atol() is C-specific, stopped";
+}
+
+sub bsearch {
+ unimpl "bsearch() not supplied";
+}
+
+sub calloc {
+ unimpl "calloc() is C-specific, stopped";
+}
+
+sub div {
+ unimpl "div() is C-specific, use /, % and int instead";
+}
+
+sub exit {
+ usage "exit(status)" if @_ != 1;
+ CORE::exit($_[0]);
+}
+
+sub free {
+ unimpl "free() is C-specific, stopped";
+}
+
+sub getenv {
+ usage "getenv(name)" if @_ != 1;
+ $ENV{$_[0]};
+}
+
+sub labs {
+ unimpl "labs() is C-specific, use abs instead";
+}
+
+sub ldiv {
+ unimpl "ldiv() is C-specific, use /, % and int instead";
+}
+
+sub malloc {
+ unimpl "malloc() is C-specific, stopped";
+}
+
+sub qsort {
+ unimpl "qsort() is C-specific, use sort instead";
+}
+
+sub rand {
+ unimpl "rand() is non-portable, use Perl's rand instead";
+}
+
+sub realloc {
+ unimpl "realloc() is C-specific, stopped";
+}
+
+sub srand {
+ unimpl "srand()";
+}
+
+sub system {
+ usage "system(command)" if @_ != 1;
+ CORE::system($_[0]);
+}
+
+sub memchr {
+ unimpl "memchr() is C-specific, use index() instead";
+}
+
+sub memcmp {
+ unimpl "memcmp() is C-specific, use eq instead";
+}
+
+sub memcpy {
+ unimpl "memcpy() is C-specific, use = instead";
+}
+
+sub memmove {
+ unimpl "memmove() is C-specific, use = instead";
+}
+
+sub memset {
+ unimpl "memset() is C-specific, use x instead";
+}
+
+sub strcat {
+ unimpl "strcat() is C-specific, use .= instead";
+}
+
+sub strchr {
+ unimpl "strchr() is C-specific, use index() instead";
+}
+
+sub strcmp {
+ unimpl "strcmp() is C-specific, use eq instead";
+}
+
+sub strcpy {
+ unimpl "strcpy() is C-specific, use = instead";
+}
+
+sub strcspn {
+ unimpl "strcspn() is C-specific, use regular expressions instead";
+}
+
+sub strerror {
+ usage "strerror(errno)" if @_ != 1;
+ local $! = $_[0];
+ $! . "";
+}
+
+sub strlen {
+ unimpl "strlen() is C-specific, use length instead";
+}
+
+sub strncat {
+ unimpl "strncat() is C-specific, use .= instead";
+}
+
+sub strncmp {
+ unimpl "strncmp() is C-specific, use eq instead";
+}
+
+sub strncpy {
+ unimpl "strncpy() is C-specific, use = instead";
+}
+
+sub strpbrk {
+ unimpl "strpbrk() is C-specific, stopped";
+}
+
+sub strrchr {
+ unimpl "strrchr() is C-specific, use rindex() instead";
+}
+
+sub strspn {
+ unimpl "strspn() is C-specific, stopped";
+}
+
+sub strstr {
+ usage "strstr(big, little)" if @_ != 2;
+ CORE::index($_[0], $_[1]);
+}
+
+sub strtok {
+ unimpl "strtok() is C-specific, stopped";
+}
+
+sub chmod {
+ usage "chmod(mode, filename)" if @_ != 2;
+ CORE::chmod($_[0], $_[1]);
+}
+
+sub fstat {
+ usage "fstat(fd)" if @_ != 1;
+ local *TMP;
+ CORE::open(TMP, "<&$_[0]"); # Gross.
+ my @l = CORE::stat(TMP);
+ CORE::close(TMP);
+ @l;
+}
+
+sub mkdir {
+ usage "mkdir(directoryname, mode)" if @_ != 2;
+ CORE::mkdir($_[0], $_[1]);
+}
+
+sub stat {
+ usage "stat(filename)" if @_ != 1;
+ CORE::stat($_[0]);
+}
+
+sub umask {
+ usage "umask(mask)" if @_ != 1;
+ CORE::umask($_[0]);
+}
+
+sub wait {
+ usage "wait()" if @_ != 0;
+ CORE::wait();
+}
+
+sub waitpid {
+ usage "waitpid(pid, options)" if @_ != 2;
+ CORE::waitpid($_[0], $_[1]);
+}
+
+sub gmtime {
+ usage "gmtime(time)" if @_ != 1;
+ CORE::gmtime($_[0]);
+}
+
+sub localtime {
+ usage "localtime(time)" if @_ != 1;
+ CORE::localtime($_[0]);
+}
+
+sub time {
+ usage "time()" if @_ != 0;
+ CORE::time;
+}
+
+sub alarm {
+ usage "alarm(seconds)" if @_ != 1;
+ CORE::alarm($_[0]);
+}
+
+sub chdir {
+ usage "chdir(directory)" if @_ != 1;
+ CORE::chdir($_[0]);
+}
+
+sub chown {
+ usage "chown(uid, gid, filename)" if @_ != 3;
+ CORE::chown($_[0], $_[1], $_[2]);
+}
+
+sub execl {
+ unimpl "execl() is C-specific, stopped";
+}
+
+sub execle {
+ unimpl "execle() is C-specific, stopped";
+}
+
+sub execlp {
+ unimpl "execlp() is C-specific, stopped";
+}
+
+sub execv {
+ unimpl "execv() is C-specific, stopped";
+}
+
+sub execve {
+ unimpl "execve() is C-specific, stopped";
+}
+
+sub execvp {
+ unimpl "execvp() is C-specific, stopped";
+}
+
+sub fork {
+ usage "fork()" if @_ != 0;
+ CORE::fork;
+}
+
+sub getegid {
+ usage "getegid()" if @_ != 0;
+ $) + 0;
+}
+
+sub geteuid {
+ usage "geteuid()" if @_ != 0;
+ $> + 0;
+}
+
+sub getgid {
+ usage "getgid()" if @_ != 0;
+ $( + 0;
+}
+
+sub getgroups {
+ usage "getgroups()" if @_ != 0;
+ my %seen;
+ grep(!$seen{$_}++, split(' ', $) ));
+}
+
+sub getlogin {
+ usage "getlogin()" if @_ != 0;
+ CORE::getlogin();
+}
+
+sub getpgrp {
+ usage "getpgrp()" if @_ != 0;
+ CORE::getpgrp;
+}
+
+sub getpid {
+ usage "getpid()" if @_ != 0;
+ $$;
+}
+
+sub getppid {
+ usage "getppid()" if @_ != 0;
+ CORE::getppid;
+}
+
+sub getuid {
+ usage "getuid()" if @_ != 0;
+ $<;
+}
+
+sub isatty {
+ usage "isatty(filehandle)" if @_ != 1;
+ -t $_[0];
+}
+
+sub link {
+ usage "link(oldfilename, newfilename)" if @_ != 2;
+ CORE::link($_[0], $_[1]);
+}
+
+sub rmdir {
+ usage "rmdir(directoryname)" if @_ != 1;
+ CORE::rmdir($_[0]);
+}
+
+sub setbuf {
+ redef "IO::Handle::setbuf()";
+}
+
+sub setvbuf {
+ redef "IO::Handle::setvbuf()";
+}
+
+sub sleep {
+ usage "sleep(seconds)" if @_ != 1;
+ $_[0] - CORE::sleep($_[0]);
+}
+
+sub unlink {
+ usage "unlink(filename)" if @_ != 1;
+ CORE::unlink($_[0]);
+}
+
+sub utime {
+ usage "utime(filename, atime, mtime)" if @_ != 3;
+ CORE::utime($_[1], $_[2], $_[0]);
+}
+
+sub load_imports {
+%EXPORT_TAGS = (
+
+ assert_h => [qw(assert NDEBUG)],
+
+ ctype_h => [qw(isalnum isalpha iscntrl isdigit isgraph islower
+ isprint ispunct isspace isupper isxdigit tolower toupper)],
+
+ dirent_h => [],
+
+ errno_h => [qw(E2BIG EACCES EADDRINUSE EADDRNOTAVAIL EAFNOSUPPORT
+ EAGAIN EALREADY EBADF EBUSY ECHILD ECONNABORTED
+ ECONNREFUSED ECONNRESET EDEADLK EDESTADDRREQ EDOM EDQUOT
+ EEXIST EFAULT EFBIG EHOSTDOWN EHOSTUNREACH EINPROGRESS
+ EINTR EINVAL EIO EISCONN EISDIR ELOOP EMFILE EMLINK
+ EMSGSIZE ENAMETOOLONG ENETDOWN ENETRESET ENETUNREACH
+ ENFILE ENOBUFS ENODEV ENOENT ENOEXEC ENOLCK ENOMEM
+ ENOPROTOOPT ENOSPC ENOSYS ENOTBLK ENOTCONN ENOTDIR
+ ENOTEMPTY ENOTSOCK ENOTTY ENXIO EOPNOTSUPP EPERM
+ EPFNOSUPPORT EPIPE EPROCLIM EPROTONOSUPPORT EPROTOTYPE
+ ERANGE EREMOTE ERESTART EROFS ESHUTDOWN ESOCKTNOSUPPORT
+ ESPIPE ESRCH ESTALE ETIMEDOUT ETOOMANYREFS ETXTBSY
+ EUSERS EWOULDBLOCK EXDEV errno)],
+
+ fcntl_h => [qw(FD_CLOEXEC F_DUPFD F_GETFD F_GETFL F_GETLK F_RDLCK
+ F_SETFD F_SETFL F_SETLK F_SETLKW F_UNLCK F_WRLCK
+ O_ACCMODE O_APPEND O_CREAT O_EXCL O_NOCTTY O_NONBLOCK
+ O_RDONLY O_RDWR O_TRUNC O_WRONLY
+ creat
+ SEEK_CUR SEEK_END SEEK_SET
+ S_IRGRP S_IROTH S_IRUSR S_IRWXG S_IRWXO S_IRWXU
+ S_ISBLK S_ISCHR S_ISDIR S_ISFIFO S_ISGID S_ISREG S_ISUID
+ S_IWGRP S_IWOTH S_IWUSR)],
+
+ float_h => [qw(DBL_DIG DBL_EPSILON DBL_MANT_DIG
+ DBL_MAX DBL_MAX_10_EXP DBL_MAX_EXP
+ DBL_MIN DBL_MIN_10_EXP DBL_MIN_EXP
+ FLT_DIG FLT_EPSILON FLT_MANT_DIG
+ FLT_MAX FLT_MAX_10_EXP FLT_MAX_EXP
+ FLT_MIN FLT_MIN_10_EXP FLT_MIN_EXP
+ FLT_RADIX FLT_ROUNDS
+ LDBL_DIG LDBL_EPSILON LDBL_MANT_DIG
+ LDBL_MAX LDBL_MAX_10_EXP LDBL_MAX_EXP
+ LDBL_MIN LDBL_MIN_10_EXP LDBL_MIN_EXP)],
+
+ grp_h => [],
+
+ limits_h => [qw( ARG_MAX CHAR_BIT CHAR_MAX CHAR_MIN CHILD_MAX
+ INT_MAX INT_MIN LINK_MAX LONG_MAX LONG_MIN MAX_CANON
+ MAX_INPUT MB_LEN_MAX NAME_MAX NGROUPS_MAX OPEN_MAX
+ PATH_MAX PIPE_BUF SCHAR_MAX SCHAR_MIN SHRT_MAX SHRT_MIN
+ SSIZE_MAX STREAM_MAX TZNAME_MAX UCHAR_MAX UINT_MAX
+ ULONG_MAX USHRT_MAX _POSIX_ARG_MAX _POSIX_CHILD_MAX
+ _POSIX_LINK_MAX _POSIX_MAX_CANON _POSIX_MAX_INPUT
+ _POSIX_NAME_MAX _POSIX_NGROUPS_MAX _POSIX_OPEN_MAX
+ _POSIX_PATH_MAX _POSIX_PIPE_BUF _POSIX_SSIZE_MAX
+ _POSIX_STREAM_MAX _POSIX_TZNAME_MAX)],
+
+ locale_h => [qw(LC_ALL LC_COLLATE LC_CTYPE LC_MESSAGES
+ LC_MONETARY LC_NUMERIC LC_TIME NULL
+ localeconv setlocale)],
+
+ math_h => [qw(HUGE_VAL acos asin atan ceil cosh fabs floor fmod
+ frexp ldexp log10 modf pow sinh tan tanh)],
+
+ pwd_h => [],
+
+ setjmp_h => [qw(longjmp setjmp siglongjmp sigsetjmp)],
+
+ signal_h => [qw(SA_NOCLDSTOP SA_NOCLDWAIT SA_NODEFER SA_ONSTACK
+ SA_RESETHAND SA_RESTART SA_SIGINFO SIGABRT SIGALRM
+ SIGCHLD SIGCONT SIGFPE SIGHUP SIGILL SIGINT SIGKILL
+ SIGPIPE %SIGRT SIGRTMIN SIGRTMAX SIGQUIT SIGSEGV SIGSTOP
+ SIGTERM SIGTSTP SIGTTIN SIGTTOU SIGUSR1 SIGUSR2
+ SIG_BLOCK SIG_DFL SIG_ERR SIG_IGN SIG_SETMASK SIG_UNBLOCK
+ raise sigaction signal sigpending sigprocmask sigsuspend)],
+
+ stdarg_h => [],
+
+ stddef_h => [qw(NULL offsetof)],
+
+ stdio_h => [qw(BUFSIZ EOF FILENAME_MAX L_ctermid L_cuserid
+ L_tmpname NULL SEEK_CUR SEEK_END SEEK_SET
+ STREAM_MAX TMP_MAX stderr stdin stdout
+ clearerr fclose fdopen feof ferror fflush fgetc fgetpos
+ fgets fopen fprintf fputc fputs fread freopen
+ fscanf fseek fsetpos ftell fwrite getchar gets
+ perror putc putchar puts remove rewind
+ scanf setbuf setvbuf sscanf tmpfile tmpnam
+ ungetc vfprintf vprintf vsprintf)],
+
+ stdlib_h => [qw(EXIT_FAILURE EXIT_SUCCESS MB_CUR_MAX NULL RAND_MAX
+ abort atexit atof atoi atol bsearch calloc div
+ free getenv labs ldiv malloc mblen mbstowcs mbtowc
+ qsort realloc strtod strtol strtoul wcstombs wctomb)],
+
+ string_h => [qw(NULL memchr memcmp memcpy memmove memset strcat
+ strchr strcmp strcoll strcpy strcspn strerror strlen
+ strncat strncmp strncpy strpbrk strrchr strspn strstr
+ strtok strxfrm)],
+
+ sys_stat_h => [qw(S_IRGRP S_IROTH S_IRUSR S_IRWXG S_IRWXO S_IRWXU
+ S_ISBLK S_ISCHR S_ISDIR S_ISFIFO S_ISGID S_ISREG
+ S_ISUID S_IWGRP S_IWOTH S_IWUSR S_IXGRP S_IXOTH S_IXUSR
+ fstat mkfifo)],
+
+ sys_times_h => [],
+
+ sys_types_h => [],
+
+ sys_utsname_h => [qw(uname)],
+
+ sys_wait_h => [qw(WEXITSTATUS WIFEXITED WIFSIGNALED WIFSTOPPED
+ WNOHANG WSTOPSIG WTERMSIG WUNTRACED)],
+
+ termios_h => [qw( B0 B110 B1200 B134 B150 B1800 B19200 B200 B2400
+ B300 B38400 B4800 B50 B600 B75 B9600 BRKINT CLOCAL
+ CREAD CS5 CS6 CS7 CS8 CSIZE CSTOPB ECHO ECHOE ECHOK
+ ECHONL HUPCL ICANON ICRNL IEXTEN IGNBRK IGNCR IGNPAR
+ INLCR INPCK ISIG ISTRIP IXOFF IXON NCCS NOFLSH OPOST
+ PARENB PARMRK PARODD TCIFLUSH TCIOFF TCIOFLUSH TCION
+ TCOFLUSH TCOOFF TCOON TCSADRAIN TCSAFLUSH TCSANOW
+ TOSTOP VEOF VEOL VERASE VINTR VKILL VMIN VQUIT VSTART
+ VSTOP VSUSP VTIME
+ cfgetispeed cfgetospeed cfsetispeed cfsetospeed tcdrain
+ tcflow tcflush tcgetattr tcsendbreak tcsetattr )],
+
+ time_h => [qw(CLK_TCK CLOCKS_PER_SEC NULL asctime clock ctime
+ difftime mktime strftime tzset tzname)],
+
+ unistd_h => [qw(F_OK NULL R_OK SEEK_CUR SEEK_END SEEK_SET
+ STDERR_FILENO STDIN_FILENO STDOUT_FILENO W_OK X_OK
+ _PC_CHOWN_RESTRICTED _PC_LINK_MAX _PC_MAX_CANON
+ _PC_MAX_INPUT _PC_NAME_MAX _PC_NO_TRUNC _PC_PATH_MAX
+ _PC_PIPE_BUF _PC_VDISABLE _POSIX_CHOWN_RESTRICTED
+ _POSIX_JOB_CONTROL _POSIX_NO_TRUNC _POSIX_SAVED_IDS
+ _POSIX_VDISABLE _POSIX_VERSION _SC_ARG_MAX
+ _SC_CHILD_MAX _SC_CLK_TCK _SC_JOB_CONTROL
+ _SC_NGROUPS_MAX _SC_OPEN_MAX _SC_PAGESIZE _SC_SAVED_IDS
+ _SC_STREAM_MAX _SC_TZNAME_MAX _SC_VERSION
+ _exit access ctermid cuserid
+ dup2 dup execl execle execlp execv execve execvp
+ fpathconf fsync getcwd getegid geteuid getgid getgroups
+ getpid getuid isatty lseek pathconf pause setgid setpgid
+ setsid setuid sysconf tcgetpgrp tcsetpgrp ttyname)],
+
+ utime_h => [],
+
+);
+
+# Exporter::export_tags();
+{
+ # De-duplicate the export list:
+ my %export;
+ @export{map {@$_} values %EXPORT_TAGS} = ();
+ # Doing the de-dup with a temporary hash has the advantage that the SVs in
+ # @EXPORT are actually shared hash key sacalars, which will save some memory.
+ push @EXPORT, keys %export;
+}
+
+ at EXPORT_OK = qw(
+ abs
+ alarm
+ atan2
+ chdir
+ chmod
+ chown
+ close
+ closedir
+ cos
+ exit
+ exp
+ fcntl
+ fileno
+ fork
+ getc
+ getgrgid
+ getgrnam
+ getlogin
+ getpgrp
+ getppid
+ getpwnam
+ getpwuid
+ gmtime
+ isatty
+ kill
+ lchown
+ link
+ localtime
+ log
+ mkdir
+ nice
+ open
+ opendir
+ pipe
+ printf
+ rand
+ read
+ readdir
+ rename
+ rewinddir
+ rmdir
+ sin
+ sleep
+ sprintf
+ sqrt
+ srand
+ stat
+ system
+ time
+ times
+ umask
+ unlink
+ utime
+ wait
+ waitpid
+ write
+);
+
+require Exporter;
+}
+
+package POSIX::SigAction;
+
+sub new { bless {HANDLER => $_[1], MASK => $_[2], FLAGS => $_[3] || 0, SAFE => 0}, $_[0] }
+sub handler { $_[0]->{HANDLER} = $_[1] if @_ > 1; $_[0]->{HANDLER} };
+sub mask { $_[0]->{MASK} = $_[1] if @_ > 1; $_[0]->{MASK} };
+sub flags { $_[0]->{FLAGS} = $_[1] if @_ > 1; $_[0]->{FLAGS} };
+sub safe { $_[0]->{SAFE} = $_[1] if @_ > 1; $_[0]->{SAFE} };
+
+package POSIX::SigRt;
+
+
+sub _init {
+ $_SIGRTMIN = &POSIX::SIGRTMIN;
+ $_SIGRTMAX = &POSIX::SIGRTMAX;
+ $_sigrtn = $_SIGRTMAX - $_SIGRTMIN;
+}
+
+sub _croak {
+ &_init unless defined $_sigrtn;
+ die "POSIX::SigRt not available" unless defined $_sigrtn && $_sigrtn > 0;
+}
+
+sub _getsig {
+ &_croak;
+ my $rtsig = $_[0];
+ # Allow (SIGRT)?MIN( + n)?, a common idiom when doing these things in C.
+ $rtsig = $_SIGRTMIN + ($1 || 0)
+ if $rtsig =~ /^(?:(?:SIG)?RT)?MIN(\s*\+\s*(\d+))?$/;
+ return $rtsig;
+}
+
+sub _exist {
+ my $rtsig = _getsig($_[1]);
+ my $ok = $rtsig >= $_SIGRTMIN && $rtsig <= $_SIGRTMAX;
+ ($rtsig, $ok);
+}
+
+sub _check {
+ my ($rtsig, $ok) = &_exist;
+ die "No POSIX::SigRt signal $_[1] (valid range SIGRTMIN..SIGRTMAX, or $_SIGRTMIN..$_SIGRTMAX)"
+ unless $ok;
+ return $rtsig;
+}
+
+sub new {
+ my ($rtsig, $handler, $flags) = @_;
+ my $sigset = POSIX::SigSet->new($rtsig);
+ my $sigact = POSIX::SigAction->new($handler,
+ $sigset,
+ $flags);
+ POSIX::sigaction($rtsig, $sigact);
+}
+
+sub EXISTS { &_exist }
+sub FETCH { my $rtsig = &_check;
+ my $oa = POSIX::SigAction->new();
+ POSIX::sigaction($rtsig, undef, $oa);
+ return $oa->{HANDLER} }
+sub STORE { my $rtsig = &_check; new($rtsig, $_[2], $SIGACTION_FLAGS) }
+sub DELETE { delete $SIG{ &_check } }
+sub CLEAR { &_exist; delete @SIG{ &POSIX::SIGRTMIN .. &POSIX::SIGRTMAX } }
+sub SCALAR { &_croak; $_sigrtn + 1 }
Copied: trunk/contrib/perl/ext/POSIX/POSIX.pod (from rev 6437, vendor/perl/5.18.1/ext/POSIX/POSIX.pod)
===================================================================
--- trunk/contrib/perl/ext/POSIX/POSIX.pod (rev 0)
+++ trunk/contrib/perl/ext/POSIX/POSIX.pod 2013-12-02 21:32:26 UTC (rev 6445)
@@ -0,0 +1,2210 @@
+=head1 NAME
+
+POSIX - Perl interface to IEEE Std 1003.1
+
+=head1 SYNOPSIS
+
+ use POSIX;
+ use POSIX qw(setsid);
+ use POSIX qw(:errno_h :fcntl_h);
+
+ printf "EINTR is %d\n", EINTR;
+
+ $sess_id = POSIX::setsid();
+
+ $fd = POSIX::open($path, O_CREAT|O_EXCL|O_WRONLY, 0644);
+ # note: that's a filedescriptor, *NOT* a filehandle
+
+=head1 DESCRIPTION
+
+The POSIX module permits you to access all (or nearly all) the standard
+POSIX 1003.1 identifiers. Many of these identifiers have been given Perl-ish
+interfaces.
+
+I<Everything is exported by default> with the exception of any POSIX
+functions with the same name as a built-in Perl function, such as
+C<abs>, C<alarm>, C<rmdir>, C<write>, etc.., which will be exported
+only if you ask for them explicitly. This is an unfortunate backwards
+compatibility feature. You can stop the exporting by saying C<use
+POSIX ()> and then use the fully qualified names (ie. C<POSIX::SEEK_END>).
+
+This document gives a condensed list of the features available in the POSIX
+module. Consult your operating system's manpages for general information on
+most features. Consult L<perlfunc> for functions which are noted as being
+identical to Perl's builtin functions.
+
+The first section describes POSIX functions from the 1003.1 specification.
+The second section describes some classes for signal objects, TTY objects,
+and other miscellaneous objects. The remaining sections list various
+constants and macros in an organization which roughly follows IEEE Std
+1003.1b-1993.
+
+=head1 NOTE
+
+The POSIX module is probably the most complex Perl module supplied with
+the standard distribution. It incorporates autoloading, namespace games,
+and dynamic loading of code that's in Perl, C, or both. It's a great
+source of wisdom.
+
+=head1 CAVEATS
+
+A few functions are not implemented because they are C specific. If you
+attempt to call these, they will print a message telling you that they
+aren't implemented, and suggest using the Perl equivalent should one
+exist. For example, trying to access the setjmp() call will elicit the
+message "setjmp() is C-specific: use eval {} instead".
+
+Furthermore, some evil vendors will claim 1003.1 compliance, but in fact
+are not so: they will not pass the PCTS (POSIX Compliance Test Suites).
+For example, one vendor may not define EDEADLK, or the semantics of the
+errno values set by open(2) might not be quite right. Perl does not
+attempt to verify POSIX compliance. That means you can currently
+successfully say "use POSIX", and then later in your program you find
+that your vendor has been lax and there's no usable ICANON macro after
+all. This could be construed to be a bug.
+
+=head1 FUNCTIONS
+
+=over 8
+
+=item _exit
+
+This is identical to the C function C<_exit()>. It exits the program
+immediately which means among other things buffered I/O is B<not> flushed.
+
+Note that when using threads and in Linux this is B<not> a good way to
+exit a thread because in Linux processes and threads are kind of the
+same thing (Note: while this is the situation in early 2003 there are
+projects under way to have threads with more POSIXly semantics in Linux).
+If you want not to return from a thread, detach the thread.
+
+=item abort
+
+This is identical to the C function C<abort()>. It terminates the
+process with a C<SIGABRT> signal unless caught by a signal handler or
+if the handler does not return normally (it e.g. does a C<longjmp>).
+
+=item abs
+
+This is identical to Perl's builtin C<abs()> function, returning
+the absolute value of its numerical argument.
+
+=item access
+
+Determines the accessibility of a file.
+
+ if( POSIX::access( "/", &POSIX::R_OK ) ){
+ print "have read permission\n";
+ }
+
+Returns C<undef> on failure. Note: do not use C<access()> for
+security purposes. Between the C<access()> call and the operation
+you are preparing for the permissions might change: a classic
+I<race condition>.
+
+=item acos
+
+This is identical to the C function C<acos()>, returning
+the arcus cosine of its numerical argument. See also L<Math::Trig>.
+
+=item alarm
+
+This is identical to Perl's builtin C<alarm()> function,
+either for arming or disarming the C<SIGARLM> timer.
+
+=item asctime
+
+This is identical to the C function C<asctime()>. It returns
+a string of the form
+
+ "Fri Jun 2 18:22:13 2000\n\0"
+
+and it is called thusly
+
+ $asctime = asctime($sec, $min, $hour, $mday, $mon, $year,
+ $wday, $yday, $isdst);
+
+The C<$mon> is zero-based: January equals C<0>. The C<$year> is
+1900-based: 2001 equals C<101>. C<$wday> and C<$yday> default to zero
+(and are usually ignored anyway), and C<$isdst> defaults to -1.
+
+=item asin
+
+This is identical to the C function C<asin()>, returning
+the arcus sine of its numerical argument. See also L<Math::Trig>.
+
+=item assert
+
+Unimplemented, but you can use L<perlfunc/die> and the L<Carp> module
+to achieve similar things.
+
+=item atan
+
+This is identical to the C function C<atan()>, returning the
+arcus tangent of its numerical argument. See also L<Math::Trig>.
+
+=item atan2
+
+This is identical to Perl's builtin C<atan2()> function, returning
+the arcus tangent defined by its two numerical arguments, the I<y>
+coordinate and the I<x> coordinate. See also L<Math::Trig>.
+
+=item atexit
+
+atexit() is C-specific: use C<END {}> instead, see L<perlsub>.
+
+=item atof
+
+atof() is C-specific. Perl converts strings to numbers transparently.
+If you need to force a scalar to a number, add a zero to it.
+
+=item atoi
+
+atoi() is C-specific. Perl converts strings to numbers transparently.
+If you need to force a scalar to a number, add a zero to it.
+If you need to have just the integer part, see L<perlfunc/int>.
+
+=item atol
+
+atol() is C-specific. Perl converts strings to numbers transparently.
+If you need to force a scalar to a number, add a zero to it.
+If you need to have just the integer part, see L<perlfunc/int>.
+
+=item bsearch
+
+bsearch() not supplied. For doing binary search on wordlists,
+see L<Search::Dict>.
+
+=item calloc
+
+calloc() is C-specific. Perl does memory management transparently.
+
+=item ceil
+
+This is identical to the C function C<ceil()>, returning the smallest
+integer value greater than or equal to the given numerical argument.
+
+=item chdir
+
+This is identical to Perl's builtin C<chdir()> function, allowing
+one to change the working (default) directory, see L<perlfunc/chdir>.
+
+=item chmod
+
+This is identical to Perl's builtin C<chmod()> function, allowing
+one to change file and directory permissions, see L<perlfunc/chmod>.
+
+=item chown
+
+This is identical to Perl's builtin C<chown()> function, allowing one
+to change file and directory owners and groups, see L<perlfunc/chown>.
+
+=item clearerr
+
+Use the method C<IO::Handle::clearerr()> instead, to reset the error
+state (if any) and EOF state (if any) of the given stream.
+
+=item clock
+
+This is identical to the C function C<clock()>, returning the
+amount of spent processor time in microseconds.
+
+=item close
+
+Close the file. This uses file descriptors such as those obtained by calling
+C<POSIX::open>.
+
+ $fd = POSIX::open( "foo", &POSIX::O_RDONLY );
+ POSIX::close( $fd );
+
+Returns C<undef> on failure.
+
+See also L<perlfunc/close>.
+
+=item closedir
+
+This is identical to Perl's builtin C<closedir()> function for closing
+a directory handle, see L<perlfunc/closedir>.
+
+=item cos
+
+This is identical to Perl's builtin C<cos()> function, for returning
+the cosine of its numerical argument, see L<perlfunc/cos>.
+See also L<Math::Trig>.
+
+=item cosh
+
+This is identical to the C function C<cosh()>, for returning
+the hyperbolic cosine of its numeric argument. See also L<Math::Trig>.
+
+=item creat
+
+Create a new file. This returns a file descriptor like the ones returned by
+C<POSIX::open>. Use C<POSIX::close> to close the file.
+
+ $fd = POSIX::creat( "foo", 0611 );
+ POSIX::close( $fd );
+
+See also L<perlfunc/sysopen> and its C<O_CREAT> flag.
+
+=item ctermid
+
+Generates the path name for the controlling terminal.
+
+ $path = POSIX::ctermid();
+
+=item ctime
+
+This is identical to the C function C<ctime()> and equivalent
+to C<asctime(localtime(...))>, see L</asctime> and L</localtime>.
+
+=item cuserid
+
+Get the login name of the owner of the current process.
+
+ $name = POSIX::cuserid();
+
+=item difftime
+
+This is identical to the C function C<difftime()>, for returning
+the time difference (in seconds) between two times (as returned
+by C<time()>), see L</time>.
+
+=item div
+
+div() is C-specific, use L<perlfunc/int> on the usual C</> division and
+the modulus C<%>.
+
+=item dup
+
+This is similar to the C function C<dup()>, for duplicating a file
+descriptor.
+
+This uses file descriptors such as those obtained by calling
+C<POSIX::open>.
+
+Returns C<undef> on failure.
+
+=item dup2
+
+This is similar to the C function C<dup2()>, for duplicating a file
+descriptor to an another known file descriptor.
+
+This uses file descriptors such as those obtained by calling
+C<POSIX::open>.
+
+Returns C<undef> on failure.
+
+=item errno
+
+Returns the value of errno.
+
+ $errno = POSIX::errno();
+
+This identical to the numerical values of the C<$!>, see L<perlvar/$ERRNO>.
+
+=item execl
+
+execl() is C-specific, see L<perlfunc/exec>.
+
+=item execle
+
+execle() is C-specific, see L<perlfunc/exec>.
+
+=item execlp
+
+execlp() is C-specific, see L<perlfunc/exec>.
+
+=item execv
+
+execv() is C-specific, see L<perlfunc/exec>.
+
+=item execve
+
+execve() is C-specific, see L<perlfunc/exec>.
+
+=item execvp
+
+execvp() is C-specific, see L<perlfunc/exec>.
+
+=item exit
+
+This is identical to Perl's builtin C<exit()> function for exiting the
+program, see L<perlfunc/exit>.
+
+=item exp
+
+This is identical to Perl's builtin C<exp()> function for
+returning the exponent (I<e>-based) of the numerical argument,
+see L<perlfunc/exp>.
+
+=item fabs
+
+This is identical to Perl's builtin C<abs()> function for returning
+the absolute value of the numerical argument, see L<perlfunc/abs>.
+
+=item fclose
+
+Use method C<IO::Handle::close()> instead, or see L<perlfunc/close>.
+
+=item fcntl
+
+This is identical to Perl's builtin C<fcntl()> function,
+see L<perlfunc/fcntl>.
+
+=item fdopen
+
+Use method C<IO::Handle::new_from_fd()> instead, or see L<perlfunc/open>.
+
+=item feof
+
+Use method C<IO::Handle::eof()> instead, or see L<perlfunc/eof>.
+
+=item ferror
+
+Use method C<IO::Handle::error()> instead.
+
+=item fflush
+
+Use method C<IO::Handle::flush()> instead.
+See also L<perlvar/$OUTPUT_AUTOFLUSH>.
+
+=item fgetc
+
+Use method C<IO::Handle::getc()> instead, or see L<perlfunc/read>.
+
+=item fgetpos
+
+Use method C<IO::Seekable::getpos()> instead, or see L<L/seek>.
+
+=item fgets
+
+Use method C<IO::Handle::gets()> instead. Similar to E<lt>E<gt>, also known
+as L<perlfunc/readline>.
+
+=item fileno
+
+Use method C<IO::Handle::fileno()> instead, or see L<perlfunc/fileno>.
+
+=item floor
+
+This is identical to the C function C<floor()>, returning the largest
+integer value less than or equal to the numerical argument.
+
+=item fmod
+
+This is identical to the C function C<fmod()>.
+
+ $r = fmod($x, $y);
+
+It returns the remainder C<$r = $x - $n*$y>, where C<$n = trunc($x/$y)>.
+The C<$r> has the same sign as C<$x> and magnitude (absolute value)
+less than the magnitude of C<$y>.
+
+=item fopen
+
+Use method C<IO::File::open()> instead, or see L<perlfunc/open>.
+
+=item fork
+
+This is identical to Perl's builtin C<fork()> function
+for duplicating the current process, see L<perlfunc/fork>
+and L<perlfork> if you are in Windows.
+
+=item fpathconf
+
+Retrieves the value of a configurable limit on a file or directory. This
+uses file descriptors such as those obtained by calling C<POSIX::open>.
+
+The following will determine the maximum length of the longest allowable
+pathname on the filesystem which holds C</var/foo>.
+
+ $fd = POSIX::open( "/var/foo", &POSIX::O_RDONLY );
+ $path_max = POSIX::fpathconf( $fd, &POSIX::_PC_PATH_MAX );
+
+Returns C<undef> on failure.
+
+=item fprintf
+
+fprintf() is C-specific, see L<perlfunc/printf> instead.
+
+=item fputc
+
+fputc() is C-specific, see L<perlfunc/print> instead.
+
+=item fputs
+
+fputs() is C-specific, see L<perlfunc/print> instead.
+
+=item fread
+
+fread() is C-specific, see L<perlfunc/read> instead.
+
+=item free
+
+free() is C-specific. Perl does memory management transparently.
+
+=item freopen
+
+freopen() is C-specific, see L<perlfunc/open> instead.
+
+=item frexp
+
+Return the mantissa and exponent of a floating-point number.
+
+ ($mantissa, $exponent) = POSIX::frexp( 1.234e56 );
+
+=item fscanf
+
+fscanf() is C-specific, use E<lt>E<gt> and regular expressions instead.
+
+=item fseek
+
+Use method C<IO::Seekable::seek()> instead, or see L<perlfunc/seek>.
+
+=item fsetpos
+
+Use method C<IO::Seekable::setpos()> instead, or seek L<perlfunc/seek>.
+
+=item fstat
+
+Get file status. This uses file descriptors such as those obtained by
+calling C<POSIX::open>. The data returned is identical to the data from
+Perl's builtin C<stat> function.
+
+ $fd = POSIX::open( "foo", &POSIX::O_RDONLY );
+ @stats = POSIX::fstat( $fd );
+
+=item fsync
+
+Use method C<IO::Handle::sync()> instead.
+
+=item ftell
+
+Use method C<IO::Seekable::tell()> instead, or see L<perlfunc/tell>.
+
+=item fwrite
+
+fwrite() is C-specific, see L<perlfunc/print> instead.
+
+=item getc
+
+This is identical to Perl's builtin C<getc()> function,
+see L<perlfunc/getc>.
+
+=item getchar
+
+Returns one character from STDIN. Identical to Perl's C<getc()>,
+see L<perlfunc/getc>.
+
+=item getcwd
+
+Returns the name of the current working directory.
+See also L<Cwd>.
+
+=item getegid
+
+Returns the effective group identifier. Similar to Perl' s builtin
+variable C<$(>, see L<perlvar/$EGID>.
+
+=item getenv
+
+Returns the value of the specified environment variable.
+The same information is available through the C<%ENV> array.
+
+=item geteuid
+
+Returns the effective user identifier. Identical to Perl's builtin C<$E<gt>>
+variable, see L<perlvar/$EUID>.
+
+=item getgid
+
+Returns the user's real group identifier. Similar to Perl's builtin
+variable C<$)>, see L<perlvar/$GID>.
+
+=item getgrgid
+
+This is identical to Perl's builtin C<getgrgid()> function for
+returning group entries by group identifiers, see
+L<perlfunc/getgrgid>.
+
+=item getgrnam
+
+This is identical to Perl's builtin C<getgrnam()> function for
+returning group entries by group names, see L<perlfunc/getgrnam>.
+
+=item getgroups
+
+Returns the ids of the user's supplementary groups. Similar to Perl's
+builtin variable C<$)>, see L<perlvar/$GID>.
+
+=item getlogin
+
+This is identical to Perl's builtin C<getlogin()> function for
+returning the user name associated with the current session, see
+L<perlfunc/getlogin>.
+
+=item getpgrp
+
+This is identical to Perl's builtin C<getpgrp()> function for
+returning the process group identifier of the current process, see
+L<perlfunc/getpgrp>.
+
+=item getpid
+
+Returns the process identifier. Identical to Perl's builtin
+variable C<$$>, see L<perlvar/$PID>.
+
+=item getppid
+
+This is identical to Perl's builtin C<getppid()> function for
+returning the process identifier of the parent process of the current
+process , see L<perlfunc/getppid>.
+
+=item getpwnam
+
+This is identical to Perl's builtin C<getpwnam()> function for
+returning user entries by user names, see L<perlfunc/getpwnam>.
+
+=item getpwuid
+
+This is identical to Perl's builtin C<getpwuid()> function for
+returning user entries by user identifiers, see L<perlfunc/getpwuid>.
+
+=item gets
+
+Returns one line from C<STDIN>, similar to E<lt>E<gt>, also known
+as the C<readline()> function, see L<perlfunc/readline>.
+
+B<NOTE>: if you have C programs that still use C<gets()>, be very
+afraid. The C<gets()> function is a source of endless grief because
+it has no buffer overrun checks. It should B<never> be used. The
+C<fgets()> function should be preferred instead.
+
+=item getuid
+
+Returns the user's identifier. Identical to Perl's builtin C<$E<lt>> variable,
+see L<perlvar/$UID>.
+
+=item gmtime
+
+This is identical to Perl's builtin C<gmtime()> function for
+converting seconds since the epoch to a date in Greenwich Mean Time,
+see L<perlfunc/gmtime>.
+
+=item isalnum
+
+This is identical to the C function, except that it can apply to a
+single character or to a whole string. Note that locale settings may
+affect what characters are considered C<isalnum>. Does not work on
+Unicode characters code point 256 or higher. Consider using regular
+expressions and the C</[[:alnum:]]/> construct instead, or possibly
+the C</\w/> construct.
+
+=item isalpha
+
+This is identical to the C function, except that it can apply to
+a single character or to a whole string. Note that locale settings
+may affect what characters are considered C<isalpha>. Does not work
+on Unicode characters code point 256 or higher. Consider using regular
+expressions and the C</[[:alpha:]]/> construct instead.
+
+=item isatty
+
+Returns a boolean indicating whether the specified filehandle is connected
+to a tty. Similar to the C<-t> operator, see L<perlfunc/-X>.
+
+=item iscntrl
+
+This is identical to the C function, except that it can apply to
+a single character or to a whole string. Note that locale settings
+may affect what characters are considered C<iscntrl>. Does not work
+on Unicode characters code point 256 or higher. Consider using regular
+expressions and the C</[[:cntrl:]]/> construct instead.
+
+=item isdigit
+
+This is identical to the C function, except that it can apply to
+a single character or to a whole string. Note that locale settings
+may affect what characters are considered C<isdigit> (unlikely, but
+still possible). Does not work on Unicode characters code point 256
+or higher. Consider using regular expressions and the C</[[:digit:]]/>
+construct instead, or the C</\d/> construct.
+
+=item isgraph
+
+This is identical to the C function, except that it can apply to
+a single character or to a whole string. Note that locale settings
+may affect what characters are considered C<isgraph>. Does not work
+on Unicode characters code point 256 or higher. Consider using regular
+expressions and the C</[[:graph:]]/> construct instead.
+
+=item islower
+
+This is identical to the C function, except that it can apply to
+a single character or to a whole string. Note that locale settings
+may affect what characters are considered C<islower>. Does not work
+on Unicode characters code point 256 or higher. Consider using regular
+expressions and the C</[[:lower:]]/> construct instead. Do B<not> use
+C</[a-z]/>.
+
+=item isprint
+
+This is identical to the C function, except that it can apply to
+a single character or to a whole string. Note that locale settings
+may affect what characters are considered C<isprint>. Does not work
+on Unicode characters code point 256 or higher. Consider using regular
+expressions and the C</[[:print:]]/> construct instead.
+
+=item ispunct
+
+This is identical to the C function, except that it can apply to
+a single character or to a whole string. Note that locale settings
+may affect what characters are considered C<ispunct>. Does not work
+on Unicode characters code point 256 or higher. Consider using regular
+expressions and the C</[[:punct:]]/> construct instead.
+
+=item isspace
+
+This is identical to the C function, except that it can apply to
+a single character or to a whole string. Note that locale settings
+may affect what characters are considered C<isspace>. Does not work
+on Unicode characters code point 256 or higher. Consider using regular
+expressions and the C</[[:space:]]/> construct instead, or the C</\s/>
+construct. (Note that C</\s/> and C</[[:space:]]/> are slightly
+different in that C</[[:space:]]/> can normally match a vertical tab,
+while C</\s/> does not.)
+
+=item isupper
+
+This is identical to the C function, except that it can apply to
+a single character or to a whole string. Note that locale settings
+may affect what characters are considered C<isupper>. Does not work
+on Unicode characters code point 256 or higher. Consider using regular
+expressions and the C</[[:upper:]]/> construct instead. Do B<not> use
+C</[A-Z]/>.
+
+=item isxdigit
+
+This is identical to the C function, except that it can apply to a single
+character or to a whole string. Note that locale settings may affect what
+characters are considered C<isxdigit> (unlikely, but still possible).
+Does not work on Unicode characters code point 256 or higher.
+Consider using regular expressions and the C</[[:xdigit:]]/>
+construct instead, or simply C</[0-9a-f]/i>.
+
+=item kill
+
+This is identical to Perl's builtin C<kill()> function for sending
+signals to processes (often to terminate them), see L<perlfunc/kill>.
+
+=item labs
+
+(For returning absolute values of long integers.)
+labs() is C-specific, see L<perlfunc/abs> instead.
+
+=item ldexp
+
+This is identical to the C function C<ldexp()>
+for multiplying floating point numbers with powers of two.
+
+ $x_quadrupled = POSIX::ldexp($x, 2);
+
+=item ldiv
+
+(For computing dividends of long integers.)
+ldiv() is C-specific, use C</> and C<int()> instead.
+
+=item link
+
+This is identical to Perl's builtin C<link()> function
+for creating hard links into files, see L<perlfunc/link>.
+
+=item localeconv
+
+Get numeric formatting information. Returns a reference to a hash
+containing the current locale formatting values.
+
+Here is how to query the database for the B<de> (Deutsch or German) locale.
+
+ $loc = POSIX::setlocale( &POSIX::LC_ALL, "de" );
+ print "Locale = $loc\n";
+ $lconv = POSIX::localeconv();
+ print "decimal_point = ", $lconv->{decimal_point}, "\n";
+ print "thousands_sep = ", $lconv->{thousands_sep}, "\n";
+ print "grouping = ", $lconv->{grouping}, "\n";
+ print "int_curr_symbol = ", $lconv->{int_curr_symbol}, "\n";
+ print "currency_symbol = ", $lconv->{currency_symbol}, "\n";
+ print "mon_decimal_point = ", $lconv->{mon_decimal_point}, "\n";
+ print "mon_thousands_sep = ", $lconv->{mon_thousands_sep}, "\n";
+ print "mon_grouping = ", $lconv->{mon_grouping}, "\n";
+ print "positive_sign = ", $lconv->{positive_sign}, "\n";
+ print "negative_sign = ", $lconv->{negative_sign}, "\n";
+ print "int_frac_digits = ", $lconv->{int_frac_digits}, "\n";
+ print "frac_digits = ", $lconv->{frac_digits}, "\n";
+ print "p_cs_precedes = ", $lconv->{p_cs_precedes}, "\n";
+ print "p_sep_by_space = ", $lconv->{p_sep_by_space}, "\n";
+ print "n_cs_precedes = ", $lconv->{n_cs_precedes}, "\n";
+ print "n_sep_by_space = ", $lconv->{n_sep_by_space}, "\n";
+ print "p_sign_posn = ", $lconv->{p_sign_posn}, "\n";
+ print "n_sign_posn = ", $lconv->{n_sign_posn}, "\n";
+
+=item localtime
+
+This is identical to Perl's builtin C<localtime()> function for
+converting seconds since the epoch to a date see L<perlfunc/localtime>.
+
+=item log
+
+This is identical to Perl's builtin C<log()> function,
+returning the natural (I<e>-based) logarithm of the numerical argument,
+see L<perlfunc/log>.
+
+=item log10
+
+This is identical to the C function C<log10()>,
+returning the 10-base logarithm of the numerical argument.
+You can also use
+
+ sub log10 { log($_[0]) / log(10) }
+
+or
+
+ sub log10 { log($_[0]) / 2.30258509299405 }
+
+or
+
+ sub log10 { log($_[0]) * 0.434294481903252 }
+
+=item longjmp
+
+longjmp() is C-specific: use L<perlfunc/die> instead.
+
+=item lseek
+
+Move the file's read/write position. This uses file descriptors such as
+those obtained by calling C<POSIX::open>.
+
+ $fd = POSIX::open( "foo", &POSIX::O_RDONLY );
+ $off_t = POSIX::lseek( $fd, 0, &POSIX::SEEK_SET );
+
+Returns C<undef> on failure.
+
+=item malloc
+
+malloc() is C-specific. Perl does memory management transparently.
+
+=item mblen
+
+This is identical to the C function C<mblen()>.
+Perl does not have any support for the wide and multibyte
+characters of the C standards, so this might be a rather
+useless function.
+
+=item mbstowcs
+
+This is identical to the C function C<mbstowcs()>.
+Perl does not have any support for the wide and multibyte
+characters of the C standards, so this might be a rather
+useless function.
+
+=item mbtowc
+
+This is identical to the C function C<mbtowc()>.
+Perl does not have any support for the wide and multibyte
+characters of the C standards, so this might be a rather
+useless function.
+
+=item memchr
+
+memchr() is C-specific, see L<perlfunc/index> instead.
+
+=item memcmp
+
+memcmp() is C-specific, use C<eq> instead, see L<perlop>.
+
+=item memcpy
+
+memcpy() is C-specific, use C<=>, see L<perlop>, or see L<perlfunc/substr>.
+
+=item memmove
+
+memmove() is C-specific, use C<=>, see L<perlop>, or see L<perlfunc/substr>.
+
+=item memset
+
+memset() is C-specific, use C<x> instead, see L<perlop>.
+
+=item mkdir
+
+This is identical to Perl's builtin C<mkdir()> function
+for creating directories, see L<perlfunc/mkdir>.
+
+=item mkfifo
+
+This is similar to the C function C<mkfifo()> for creating
+FIFO special files.
+
+ if (mkfifo($path, $mode)) { ....
+
+Returns C<undef> on failure. The C<$mode> is similar to the
+mode of C<mkdir()>, see L<perlfunc/mkdir>, though for C<mkfifo>
+you B<must> specify the C<$mode>.
+
+=item mktime
+
+Convert date/time info to a calendar time.
+
+Synopsis:
+
+ mktime(sec, min, hour, mday, mon, year, wday = 0, yday = 0, isdst = -1)
+
+The month (C<mon>), weekday (C<wday>), and yearday (C<yday>) begin at zero.
+I.e. January is 0, not 1; Sunday is 0, not 1; January 1st is 0, not 1. The
+year (C<year>) is given in years since 1900. I.e. The year 1995 is 95; the
+year 2001 is 101. Consult your system's C<mktime()> manpage for details
+about these and the other arguments.
+
+Calendar time for December 12, 1995, at 10:30 am.
+
+ $time_t = POSIX::mktime( 0, 30, 10, 12, 11, 95 );
+ print "Date = ", POSIX::ctime($time_t);
+
+Returns C<undef> on failure.
+
+=item modf
+
+Return the integral and fractional parts of a floating-point number.
+
+ ($fractional, $integral) = POSIX::modf( 3.14 );
+
+=item nice
+
+This is similar to the C function C<nice()>, for changing
+the scheduling preference of the current process. Positive
+arguments mean more polite process, negative values more
+needy process. Normal user processes can only be more polite.
+
+Returns C<undef> on failure.
+
+=item offsetof
+
+offsetof() is C-specific, you probably want to see L<perlfunc/pack> instead.
+
+=item open
+
+Open a file for reading for writing. This returns file descriptors, not
+Perl filehandles. Use C<POSIX::close> to close the file.
+
+Open a file read-only with mode 0666.
+
+ $fd = POSIX::open( "foo" );
+
+Open a file for read and write.
+
+ $fd = POSIX::open( "foo", &POSIX::O_RDWR );
+
+Open a file for write, with truncation.
+
+ $fd = POSIX::open( "foo", &POSIX::O_WRONLY | &POSIX::O_TRUNC );
+
+Create a new file with mode 0640. Set up the file for writing.
+
+ $fd = POSIX::open( "foo", &POSIX::O_CREAT | &POSIX::O_WRONLY, 0640 );
+
+Returns C<undef> on failure.
+
+See also L<perlfunc/sysopen>.
+
+=item opendir
+
+Open a directory for reading.
+
+ $dir = POSIX::opendir( "/var" );
+ @files = POSIX::readdir( $dir );
+ POSIX::closedir( $dir );
+
+Returns C<undef> on failure.
+
+=item pathconf
+
+Retrieves the value of a configurable limit on a file or directory.
+
+The following will determine the maximum length of the longest allowable
+pathname on the filesystem which holds C</var>.
+
+ $path_max = POSIX::pathconf( "/var", &POSIX::_PC_PATH_MAX );
+
+Returns C<undef> on failure.
+
+=item pause
+
+This is similar to the C function C<pause()>, which suspends
+the execution of the current process until a signal is received.
+
+Returns C<undef> on failure.
+
+=item perror
+
+This is identical to the C function C<perror()>, which outputs to the
+standard error stream the specified message followed by ": " and the
+current error string. Use the C<warn()> function and the C<$!>
+variable instead, see L<perlfunc/warn> and L<perlvar/$ERRNO>.
+
+=item pipe
+
+Create an interprocess channel. This returns file descriptors like those
+returned by C<POSIX::open>.
+
+ my ($read, $write) = POSIX::pipe();
+ POSIX::write( $write, "hello", 5 );
+ POSIX::read( $read, $buf, 5 );
+
+See also L<perlfunc/pipe>.
+
+=item pow
+
+Computes C<$x> raised to the power C<$exponent>.
+
+ $ret = POSIX::pow( $x, $exponent );
+
+You can also use the C<**> operator, see L<perlop>.
+
+=item printf
+
+Formats and prints the specified arguments to STDOUT.
+See also L<perlfunc/printf>.
+
+=item putc
+
+putc() is C-specific, see L<perlfunc/print> instead.
+
+=item putchar
+
+putchar() is C-specific, see L<perlfunc/print> instead.
+
+=item puts
+
+puts() is C-specific, see L<perlfunc/print> instead.
+
+=item qsort
+
+qsort() is C-specific, see L<perlfunc/sort> instead.
+
+=item raise
+
+Sends the specified signal to the current process.
+See also L<perlfunc/kill> and the C<$$> in L<perlvar/$PID>.
+
+=item rand
+
+C<rand()> is non-portable, see L<perlfunc/rand> instead.
+
+=item read
+
+Read from a file. This uses file descriptors such as those obtained by
+calling C<POSIX::open>. If the buffer C<$buf> is not large enough for the
+read then Perl will extend it to make room for the request.
+
+ $fd = POSIX::open( "foo", &POSIX::O_RDONLY );
+ $bytes = POSIX::read( $fd, $buf, 3 );
+
+Returns C<undef> on failure.
+
+See also L<perlfunc/sysread>.
+
+=item readdir
+
+This is identical to Perl's builtin C<readdir()> function
+for reading directory entries, see L<perlfunc/readdir>.
+
+=item realloc
+
+realloc() is C-specific. Perl does memory management transparently.
+
+=item remove
+
+This is identical to Perl's builtin C<unlink()> function
+for removing files, see L<perlfunc/unlink>.
+
+=item rename
+
+This is identical to Perl's builtin C<rename()> function
+for renaming files, see L<perlfunc/rename>.
+
+=item rewind
+
+Seeks to the beginning of the file.
+
+=item rewinddir
+
+This is identical to Perl's builtin C<rewinddir()> function for
+rewinding directory entry streams, see L<perlfunc/rewinddir>.
+
+=item rmdir
+
+This is identical to Perl's builtin C<rmdir()> function
+for removing (empty) directories, see L<perlfunc/rmdir>.
+
+=item scanf
+
+scanf() is C-specific, use E<lt>E<gt> and regular expressions instead,
+see L<perlre>.
+
+=item setgid
+
+Sets the real group identifier and the effective group identifier for
+this process. Similar to assigning a value to the Perl's builtin
+C<$)> variable, see L<perlvar/$EGID>, except that the latter
+will change only the real user identifier, and that the setgid()
+uses only a single numeric argument, as opposed to a space-separated
+list of numbers.
+
+=item setjmp
+
+C<setjmp()> is C-specific: use C<eval {}> instead,
+see L<perlfunc/eval>.
+
+=item setlocale
+
+Modifies and queries program's locale. The following examples assume
+
+ use POSIX qw(setlocale LC_ALL LC_CTYPE);
+
+has been issued.
+
+The following will set the traditional UNIX system locale behavior
+(the second argument C<"C">).
+
+ $loc = setlocale( LC_ALL, "C" );
+
+The following will query the current LC_CTYPE category. (No second
+argument means 'query'.)
+
+ $loc = setlocale( LC_CTYPE );
+
+The following will set the LC_CTYPE behaviour according to the locale
+environment variables (the second argument C<"">).
+Please see your systems C<setlocale(3)> documentation for the locale
+environment variables' meaning or consult L<perllocale>.
+
+ $loc = setlocale( LC_CTYPE, "" );
+
+The following will set the LC_COLLATE behaviour to Argentinian
+Spanish. B<NOTE>: The naming and availability of locales depends on
+your operating system. Please consult L<perllocale> for how to find
+out which locales are available in your system.
+
+ $loc = setlocale( LC_ALL, "es_AR.ISO8859-1" );
+
+=item setpgid
+
+This is similar to the C function C<setpgid()> for
+setting the process group identifier of the current process.
+
+Returns C<undef> on failure.
+
+=item setsid
+
+This is identical to the C function C<setsid()> for
+setting the session identifier of the current process.
+
+=item setuid
+
+Sets the real user identifier and the effective user identifier for
+this process. Similar to assigning a value to the Perl's builtin
+C<$E<lt>> variable, see L<perlvar/$UID>, except that the latter
+will change only the real user identifier.
+
+=item sigaction
+
+Detailed signal management. This uses C<POSIX::SigAction> objects for
+the C<action> and C<oldaction> arguments (the oldaction can also be
+just a hash reference). Consult your system's C<sigaction> manpage
+for details, see also C<POSIX::SigRt>.
+
+Synopsis:
+
+ sigaction(signal, action, oldaction = 0)
+
+Returns C<undef> on failure. The C<signal> must be a number (like
+SIGHUP), not a string (like "SIGHUP"), though Perl does try hard
+to understand you.
+
+If you use the SA_SIGINFO flag, the signal handler will in addition to
+the first argument, the signal name, also receive a second argument, a
+hash reference, inside which are the following keys with the following
+semantics, as defined by POSIX/SUSv3:
+
+ signo the signal number
+ errno the error number
+ code if this is zero or less, the signal was sent by
+ a user process and the uid and pid make sense,
+ otherwise the signal was sent by the kernel
+
+The following are also defined by POSIX/SUSv3, but unfortunately
+not very widely implemented:
+
+ pid the process id generating the signal
+ uid the uid of the process id generating the signal
+ status exit value or signal for SIGCHLD
+ band band event for SIGPOLL
+
+A third argument is also passed to the handler, which contains a copy
+of the raw binary contents of the siginfo structure: if a system has
+some non-POSIX fields, this third argument is where to unpack() them
+from.
+
+Note that not all siginfo values make sense simultaneously (some are
+valid only for certain signals, for example), and not all values make
+sense from Perl perspective, you should to consult your system's
+C<sigaction> and possibly also C<siginfo> documentation.
+
+=item siglongjmp
+
+siglongjmp() is C-specific: use L<perlfunc/die> instead.
+
+=item sigpending
+
+Examine signals that are blocked and pending. This uses C<POSIX::SigSet>
+objects for the C<sigset> argument. Consult your system's C<sigpending>
+manpage for details.
+
+Synopsis:
+
+ sigpending(sigset)
+
+Returns C<undef> on failure.
+
+=item sigprocmask
+
+Change and/or examine calling process's signal mask. This uses
+C<POSIX::SigSet> objects for the C<sigset> and C<oldsigset> arguments.
+Consult your system's C<sigprocmask> manpage for details.
+
+Synopsis:
+
+ sigprocmask(how, sigset, oldsigset = 0)
+
+Returns C<undef> on failure.
+
+=item sigsetjmp
+
+C<sigsetjmp()> is C-specific: use C<eval {}> instead,
+see L<perlfunc/eval>.
+
+=item sigsuspend
+
+Install a signal mask and suspend process until signal arrives. This uses
+C<POSIX::SigSet> objects for the C<signal_mask> argument. Consult your
+system's C<sigsuspend> manpage for details.
+
+Synopsis:
+
+ sigsuspend(signal_mask)
+
+Returns C<undef> on failure.
+
+=item sin
+
+This is identical to Perl's builtin C<sin()> function
+for returning the sine of the numerical argument,
+see L<perlfunc/sin>. See also L<Math::Trig>.
+
+=item sinh
+
+This is identical to the C function C<sinh()>
+for returning the hyperbolic sine of the numerical argument.
+See also L<Math::Trig>.
+
+=item sleep
+
+This is functionally identical to Perl's builtin C<sleep()> function
+for suspending the execution of the current for process for certain
+number of seconds, see L<perlfunc/sleep>. There is one significant
+difference, however: C<POSIX::sleep()> returns the number of
+B<unslept> seconds, while the C<CORE::sleep()> returns the
+number of slept seconds.
+
+=item sprintf
+
+This is similar to Perl's builtin C<sprintf()> function
+for returning a string that has the arguments formatted as requested,
+see L<perlfunc/sprintf>.
+
+=item sqrt
+
+This is identical to Perl's builtin C<sqrt()> function.
+for returning the square root of the numerical argument,
+see L<perlfunc/sqrt>.
+
+=item srand
+
+Give a seed the pseudorandom number generator, see L<perlfunc/srand>.
+
+=item sscanf
+
+sscanf() is C-specific, use regular expressions instead,
+see L<perlre>.
+
+=item stat
+
+This is identical to Perl's builtin C<stat()> function
+for returning information about files and directories.
+
+=item strcat
+
+strcat() is C-specific, use C<.=> instead, see L<perlop>.
+
+=item strchr
+
+strchr() is C-specific, see L<perlfunc/index> instead.
+
+=item strcmp
+
+strcmp() is C-specific, use C<eq> or C<cmp> instead, see L<perlop>.
+
+=item strcoll
+
+This is identical to the C function C<strcoll()>
+for collating (comparing) strings transformed using
+the C<strxfrm()> function. Not really needed since
+Perl can do this transparently, see L<perllocale>.
+
+=item strcpy
+
+strcpy() is C-specific, use C<=> instead, see L<perlop>.
+
+=item strcspn
+
+strcspn() is C-specific, use regular expressions instead,
+see L<perlre>.
+
+=item strerror
+
+Returns the error string for the specified errno.
+Identical to the string form of the C<$!>, see L<perlvar/$ERRNO>.
+
+=item strftime
+
+Convert date and time information to string. Returns the string.
+
+Synopsis:
+
+ strftime(fmt, sec, min, hour, mday, mon, year, wday = -1, yday = -1, isdst = -1)
+
+The month (C<mon>), weekday (C<wday>), and yearday (C<yday>) begin at zero.
+I.e. January is 0, not 1; Sunday is 0, not 1; January 1st is 0, not 1. The
+year (C<year>) is given in years since 1900. I.e., the year 1995 is 95; the
+year 2001 is 101. Consult your system's C<strftime()> manpage for details
+about these and the other arguments.
+
+If you want your code to be portable, your format (C<fmt>) argument
+should use only the conversion specifiers defined by the ANSI C
+standard (C89, to play safe). These are C<aAbBcdHIjmMpSUwWxXyYZ%>.
+But even then, the B<results> of some of the conversion specifiers are
+non-portable. For example, the specifiers C<aAbBcpZ> change according
+to the locale settings of the user, and both how to set locales (the
+locale names) and what output to expect are non-standard.
+The specifier C<c> changes according to the timezone settings of the
+user and the timezone computation rules of the operating system.
+The C<Z> specifier is notoriously unportable since the names of
+timezones are non-standard. Sticking to the numeric specifiers is the
+safest route.
+
+The given arguments are made consistent as though by calling
+C<mktime()> before calling your system's C<strftime()> function,
+except that the C<isdst> value is not affected.
+
+The string for Tuesday, December 12, 1995.
+
+ $str = POSIX::strftime( "%A, %B %d, %Y", 0, 0, 0, 12, 11, 95, 2 );
+ print "$str\n";
+
+=item strlen
+
+strlen() is C-specific, use C<length()> instead, see L<perlfunc/length>.
+
+=item strncat
+
+strncat() is C-specific, use C<.=> instead, see L<perlop>.
+
+=item strncmp
+
+strncmp() is C-specific, use C<eq> instead, see L<perlop>.
+
+=item strncpy
+
+strncpy() is C-specific, use C<=> instead, see L<perlop>.
+
+=item strpbrk
+
+strpbrk() is C-specific, use regular expressions instead,
+see L<perlre>.
+
+=item strrchr
+
+strrchr() is C-specific, see L<perlfunc/rindex> instead.
+
+=item strspn
+
+strspn() is C-specific, use regular expressions instead,
+see L<perlre>.
+
+=item strstr
+
+This is identical to Perl's builtin C<index()> function,
+see L<perlfunc/index>.
+
+=item strtod
+
+String to double translation. Returns the parsed number and the number
+of characters in the unparsed portion of the string. Truly
+POSIX-compliant systems set $! ($ERRNO) to indicate a translation
+error, so clear $! before calling strtod. However, non-POSIX systems
+may not check for overflow, and therefore will never set $!.
+
+strtod should respect any POSIX I<setlocale()> settings.
+
+To parse a string $str as a floating point number use
+
+ $! = 0;
+ ($num, $n_unparsed) = POSIX::strtod($str);
+
+The second returned item and $! can be used to check for valid input:
+
+ if (($str eq '') || ($n_unparsed != 0) || $!) {
+ die "Non-numeric input $str" . ($! ? ": $!\n" : "\n");
+ }
+
+When called in a scalar context strtod returns the parsed number.
+
+=item strtok
+
+strtok() is C-specific, use regular expressions instead, see
+L<perlre>, or L<perlfunc/split>.
+
+=item strtol
+
+String to (long) integer translation. Returns the parsed number and
+the number of characters in the unparsed portion of the string. Truly
+POSIX-compliant systems set $! ($ERRNO) to indicate a translation
+error, so clear $! before calling strtol. However, non-POSIX systems
+may not check for overflow, and therefore will never set $!.
+
+strtol should respect any POSIX I<setlocale()> settings.
+
+To parse a string $str as a number in some base $base use
+
+ $! = 0;
+ ($num, $n_unparsed) = POSIX::strtol($str, $base);
+
+The base should be zero or between 2 and 36, inclusive. When the base
+is zero or omitted strtol will use the string itself to determine the
+base: a leading "0x" or "0X" means hexadecimal; a leading "0" means
+octal; any other leading characters mean decimal. Thus, "1234" is
+parsed as a decimal number, "01234" as an octal number, and "0x1234"
+as a hexadecimal number.
+
+The second returned item and $! can be used to check for valid input:
+
+ if (($str eq '') || ($n_unparsed != 0) || !$!) {
+ die "Non-numeric input $str" . $! ? ": $!\n" : "\n";
+ }
+
+When called in a scalar context strtol returns the parsed number.
+
+=item strtoul
+
+String to unsigned (long) integer translation. strtoul() is identical
+to strtol() except that strtoul() only parses unsigned integers. See
+L</strtol> for details.
+
+Note: Some vendors supply strtod() and strtol() but not strtoul().
+Other vendors that do supply strtoul() parse "-1" as a valid value.
+
+=item strxfrm
+
+String transformation. Returns the transformed string.
+
+ $dst = POSIX::strxfrm( $src );
+
+Used in conjunction with the C<strcoll()> function, see L</strcoll>.
+
+Not really needed since Perl can do this transparently, see
+L<perllocale>.
+
+=item sysconf
+
+Retrieves values of system configurable variables.
+
+The following will get the machine's clock speed.
+
+ $clock_ticks = POSIX::sysconf( &POSIX::_SC_CLK_TCK );
+
+Returns C<undef> on failure.
+
+=item system
+
+This is identical to Perl's builtin C<system()> function, see
+L<perlfunc/system>.
+
+=item tan
+
+This is identical to the C function C<tan()>, returning the
+tangent of the numerical argument. See also L<Math::Trig>.
+
+=item tanh
+
+This is identical to the C function C<tanh()>, returning the
+hyperbolic tangent of the numerical argument. See also L<Math::Trig>.
+
+=item tcdrain
+
+This is similar to the C function C<tcdrain()> for draining
+the output queue of its argument stream.
+
+Returns C<undef> on failure.
+
+=item tcflow
+
+This is similar to the C function C<tcflow()> for controlling
+the flow of its argument stream.
+
+Returns C<undef> on failure.
+
+=item tcflush
+
+This is similar to the C function C<tcflush()> for flushing
+the I/O buffers of its argument stream.
+
+Returns C<undef> on failure.
+
+=item tcgetpgrp
+
+This is identical to the C function C<tcgetpgrp()> for returning the
+process group identifier of the foreground process group of the controlling
+terminal.
+
+=item tcsendbreak
+
+This is similar to the C function C<tcsendbreak()> for sending
+a break on its argument stream.
+
+Returns C<undef> on failure.
+
+=item tcsetpgrp
+
+This is similar to the C function C<tcsetpgrp()> for setting the
+process group identifier of the foreground process group of the controlling
+terminal.
+
+Returns C<undef> on failure.
+
+=item time
+
+This is identical to Perl's builtin C<time()> function
+for returning the number of seconds since the epoch
+(whatever it is for the system), see L<perlfunc/time>.
+
+=item times
+
+The times() function returns elapsed realtime since some point in the past
+(such as system startup), user and system times for this process, and user
+and system times used by child processes. All times are returned in clock
+ticks.
+
+ ($realtime, $user, $system, $cuser, $csystem) = POSIX::times();
+
+Note: Perl's builtin C<times()> function returns four values, measured in
+seconds.
+
+=item tmpfile
+
+Use method C<IO::File::new_tmpfile()> instead, or see L<File::Temp>.
+
+=item tmpnam
+
+Returns a name for a temporary file.
+
+ $tmpfile = POSIX::tmpnam();
+
+For security reasons, which are probably detailed in your system's
+documentation for the C library tmpnam() function, this interface
+should not be used; instead see L<File::Temp>.
+
+=item tolower
+
+This is identical to the C function, except that it can apply to a single
+character or to a whole string. Consider using the C<lc()> function,
+see L<perlfunc/lc>, or the equivalent C<\L> operator inside doublequotish
+strings.
+
+=item toupper
+
+This is identical to the C function, except that it can apply to a single
+character or to a whole string. Consider using the C<uc()> function,
+see L<perlfunc/uc>, or the equivalent C<\U> operator inside doublequotish
+strings.
+
+=item ttyname
+
+This is identical to the C function C<ttyname()> for returning the
+name of the current terminal.
+
+=item tzname
+
+Retrieves the time conversion information from the C<tzname> variable.
+
+ POSIX::tzset();
+ ($std, $dst) = POSIX::tzname();
+
+=item tzset
+
+This is identical to the C function C<tzset()> for setting
+the current timezone based on the environment variable C<TZ>,
+to be used by C<ctime()>, C<localtime()>, C<mktime()>, and C<strftime()>
+functions.
+
+=item umask
+
+This is identical to Perl's builtin C<umask()> function
+for setting (and querying) the file creation permission mask,
+see L<perlfunc/umask>.
+
+=item uname
+
+Get name of current operating system.
+
+ ($sysname, $nodename, $release, $version, $machine) = POSIX::uname();
+
+Note that the actual meanings of the various fields are not
+that well standardized, do not expect any great portability.
+The C<$sysname> might be the name of the operating system,
+the C<$nodename> might be the name of the host, the C<$release>
+might be the (major) release number of the operating system,
+the C<$version> might be the (minor) release number of the
+operating system, and the C<$machine> might be a hardware identifier.
+Maybe.
+
+=item ungetc
+
+Use method C<IO::Handle::ungetc()> instead.
+
+=item unlink
+
+This is identical to Perl's builtin C<unlink()> function
+for removing files, see L<perlfunc/unlink>.
+
+=item utime
+
+This is identical to Perl's builtin C<utime()> function
+for changing the time stamps of files and directories,
+see L<perlfunc/utime>.
+
+=item vfprintf
+
+vfprintf() is C-specific, see L<perlfunc/printf> instead.
+
+=item vprintf
+
+vprintf() is C-specific, see L<perlfunc/printf> instead.
+
+=item vsprintf
+
+vsprintf() is C-specific, see L<perlfunc/sprintf> instead.
+
+=item wait
+
+This is identical to Perl's builtin C<wait()> function,
+see L<perlfunc/wait>.
+
+=item waitpid
+
+Wait for a child process to change state. This is identical to Perl's
+builtin C<waitpid()> function, see L<perlfunc/waitpid>.
+
+ $pid = POSIX::waitpid( -1, POSIX::WNOHANG );
+ print "status = ", ($? / 256), "\n";
+
+=item wcstombs
+
+This is identical to the C function C<wcstombs()>.
+Perl does not have any support for the wide and multibyte
+characters of the C standards, so this might be a rather
+useless function.
+
+=item wctomb
+
+This is identical to the C function C<wctomb()>.
+Perl does not have any support for the wide and multibyte
+characters of the C standards, so this might be a rather
+useless function.
+
+=item write
+
+Write to a file. This uses file descriptors such as those obtained by
+calling C<POSIX::open>.
+
+ $fd = POSIX::open( "foo", &POSIX::O_WRONLY );
+ $buf = "hello";
+ $bytes = POSIX::write( $fd, $buf, 5 );
+
+Returns C<undef> on failure.
+
+See also L<perlfunc/syswrite>.
+
+=back
+
+=head1 CLASSES
+
+=head2 POSIX::SigAction
+
+=over 8
+
+=item new
+
+Creates a new C<POSIX::SigAction> object which corresponds to the C
+C<struct sigaction>. This object will be destroyed automatically when
+it is no longer needed. The first parameter is the handler, a sub
+reference. The second parameter is a C<POSIX::SigSet> object, it
+defaults to the empty set. The third parameter contains the
+C<sa_flags>, it defaults to 0.
+
+ $sigset = POSIX::SigSet->new(SIGINT, SIGQUIT);
+ $sigaction = POSIX::SigAction->new( \&handler, $sigset, &POSIX::SA_NOCLDSTOP );
+
+This C<POSIX::SigAction> object is intended for use with the C<POSIX::sigaction()>
+function.
+
+=back
+
+=over 8
+
+=item handler
+
+=item mask
+
+=item flags
+
+accessor functions to get/set the values of a SigAction object.
+
+ $sigset = $sigaction->mask;
+ $sigaction->flags(&POSIX::SA_RESTART);
+
+=item safe
+
+accessor function for the "safe signals" flag of a SigAction object; see
+L<perlipc> for general information on safe (a.k.a. "deferred") signals. If
+you wish to handle a signal safely, use this accessor to set the "safe" flag
+in the C<POSIX::SigAction> object:
+
+ $sigaction->safe(1);
+
+You may also examine the "safe" flag on the output action object which is
+filled in when given as the third parameter to C<POSIX::sigaction()>:
+
+ sigaction(SIGINT, $new_action, $old_action);
+ if ($old_action->safe) {
+ # previous SIGINT handler used safe signals
+ }
+
+=back
+
+=head2 POSIX::SigRt
+
+=over 8
+
+=item %SIGRT
+
+A hash of the POSIX realtime signal handlers. It is an extension of
+the standard %SIG, the $POSIX::SIGRT{SIGRTMIN} is roughly equivalent
+to $SIG{SIGRTMIN}, but the right POSIX moves (see below) are made with
+the POSIX::SigSet and POSIX::sigaction instead of accessing the %SIG.
+
+You can set the %POSIX::SIGRT elements to set the POSIX realtime
+signal handlers, use C<delete> and C<exists> on the elements, and use
+C<scalar> on the C<%POSIX::SIGRT> to find out how many POSIX realtime
+signals there are available (SIGRTMAX - SIGRTMIN + 1, the SIGRTMAX is
+a valid POSIX realtime signal).
+
+Setting the %SIGRT elements is equivalent to calling this:
+
+ sub new {
+ my ($rtsig, $handler, $flags) = @_;
+ my $sigset = POSIX::SigSet($rtsig);
+ my $sigact = POSIX::SigAction->new($handler, $sigset, $flags);
+ sigaction($rtsig, $sigact);
+ }
+
+The flags default to zero, if you want something different you can
+either use C<local> on $POSIX::SigRt::SIGACTION_FLAGS, or you can
+derive from POSIX::SigRt and define your own C<new()> (the tied hash
+STORE method of the %SIGRT calls C<new($rtsig, $handler, $SIGACTION_FLAGS)>,
+where the $rtsig ranges from zero to SIGRTMAX - SIGRTMIN + 1).
+
+Just as with any signal, you can use sigaction($rtsig, undef, $oa) to
+retrieve the installed signal handler (or, rather, the signal action).
+
+B<NOTE:> whether POSIX realtime signals really work in your system, or
+whether Perl has been compiled so that it works with them, is outside
+of this discussion.
+
+=item SIGRTMIN
+
+Return the minimum POSIX realtime signal number available, or C<undef>
+if no POSIX realtime signals are available.
+
+=item SIGRTMAX
+
+Return the maximum POSIX realtime signal number available, or C<undef>
+if no POSIX realtime signals are available.
+
+=back
+
+=head2 POSIX::SigSet
+
+=over 8
+
+=item new
+
+Create a new SigSet object. This object will be destroyed automatically
+when it is no longer needed. Arguments may be supplied to initialize the
+set.
+
+Create an empty set.
+
+ $sigset = POSIX::SigSet->new;
+
+Create a set with SIGUSR1.
+
+ $sigset = POSIX::SigSet->new( &POSIX::SIGUSR1 );
+
+=item addset
+
+Add a signal to a SigSet object.
+
+ $sigset->addset( &POSIX::SIGUSR2 );
+
+Returns C<undef> on failure.
+
+=item delset
+
+Remove a signal from the SigSet object.
+
+ $sigset->delset( &POSIX::SIGUSR2 );
+
+Returns C<undef> on failure.
+
+=item emptyset
+
+Initialize the SigSet object to be empty.
+
+ $sigset->emptyset();
+
+Returns C<undef> on failure.
+
+=item fillset
+
+Initialize the SigSet object to include all signals.
+
+ $sigset->fillset();
+
+Returns C<undef> on failure.
+
+=item ismember
+
+Tests the SigSet object to see if it contains a specific signal.
+
+ if( $sigset->ismember( &POSIX::SIGUSR1 ) ){
+ print "contains SIGUSR1\n";
+ }
+
+=back
+
+=head2 POSIX::Termios
+
+=over 8
+
+=item new
+
+Create a new Termios object. This object will be destroyed automatically
+when it is no longer needed. A Termios object corresponds to the termios
+C struct. new() mallocs a new one, getattr() fills it from a file descriptor,
+and setattr() sets a file descriptor's parameters to match Termios' contents.
+
+ $termios = POSIX::Termios->new;
+
+=item getattr
+
+Get terminal control attributes.
+
+Obtain the attributes for stdin.
+
+ $termios->getattr( 0 ) # Recommended for clarity.
+ $termios->getattr()
+
+Obtain the attributes for stdout.
+
+ $termios->getattr( 1 )
+
+Returns C<undef> on failure.
+
+=item getcc
+
+Retrieve a value from the c_cc field of a termios object. The c_cc field is
+an array so an index must be specified.
+
+ $c_cc[1] = $termios->getcc(1);
+
+=item getcflag
+
+Retrieve the c_cflag field of a termios object.
+
+ $c_cflag = $termios->getcflag;
+
+=item getiflag
+
+Retrieve the c_iflag field of a termios object.
+
+ $c_iflag = $termios->getiflag;
+
+=item getispeed
+
+Retrieve the input baud rate.
+
+ $ispeed = $termios->getispeed;
+
+=item getlflag
+
+Retrieve the c_lflag field of a termios object.
+
+ $c_lflag = $termios->getlflag;
+
+=item getoflag
+
+Retrieve the c_oflag field of a termios object.
+
+ $c_oflag = $termios->getoflag;
+
+=item getospeed
+
+Retrieve the output baud rate.
+
+ $ospeed = $termios->getospeed;
+
+=item setattr
+
+Set terminal control attributes.
+
+Set attributes immediately for stdout.
+
+ $termios->setattr( 1, &POSIX::TCSANOW );
+
+Returns C<undef> on failure.
+
+=item setcc
+
+Set a value in the c_cc field of a termios object. The c_cc field is an
+array so an index must be specified.
+
+ $termios->setcc( &POSIX::VEOF, 1 );
+
+=item setcflag
+
+Set the c_cflag field of a termios object.
+
+ $termios->setcflag( $c_cflag | &POSIX::CLOCAL );
+
+=item setiflag
+
+Set the c_iflag field of a termios object.
+
+ $termios->setiflag( $c_iflag | &POSIX::BRKINT );
+
+=item setispeed
+
+Set the input baud rate.
+
+ $termios->setispeed( &POSIX::B9600 );
+
+Returns C<undef> on failure.
+
+=item setlflag
+
+Set the c_lflag field of a termios object.
+
+ $termios->setlflag( $c_lflag | &POSIX::ECHO );
+
+=item setoflag
+
+Set the c_oflag field of a termios object.
+
+ $termios->setoflag( $c_oflag | &POSIX::OPOST );
+
+=item setospeed
+
+Set the output baud rate.
+
+ $termios->setospeed( &POSIX::B9600 );
+
+Returns C<undef> on failure.
+
+=item Baud rate values
+
+B38400 B75 B200 B134 B300 B1800 B150 B0 B19200 B1200 B9600 B600 B4800 B50 B2400 B110
+
+=item Terminal interface values
+
+TCSADRAIN TCSANOW TCOON TCIOFLUSH TCOFLUSH TCION TCIFLUSH TCSAFLUSH TCIOFF TCOOFF
+
+=item c_cc field values
+
+VEOF VEOL VERASE VINTR VKILL VQUIT VSUSP VSTART VSTOP VMIN VTIME NCCS
+
+=item c_cflag field values
+
+CLOCAL CREAD CSIZE CS5 CS6 CS7 CS8 CSTOPB HUPCL PARENB PARODD
+
+=item c_iflag field values
+
+BRKINT ICRNL IGNBRK IGNCR IGNPAR INLCR INPCK ISTRIP IXOFF IXON PARMRK
+
+=item c_lflag field values
+
+ECHO ECHOE ECHOK ECHONL ICANON IEXTEN ISIG NOFLSH TOSTOP
+
+=item c_oflag field values
+
+OPOST
+
+=back
+
+=head1 PATHNAME CONSTANTS
+
+=over 8
+
+=item Constants
+
+_PC_CHOWN_RESTRICTED _PC_LINK_MAX _PC_MAX_CANON _PC_MAX_INPUT _PC_NAME_MAX _PC_NO_TRUNC _PC_PATH_MAX _PC_PIPE_BUF _PC_VDISABLE
+
+=back
+
+=head1 POSIX CONSTANTS
+
+=over 8
+
+=item Constants
+
+_POSIX_ARG_MAX _POSIX_CHILD_MAX _POSIX_CHOWN_RESTRICTED _POSIX_JOB_CONTROL _POSIX_LINK_MAX _POSIX_MAX_CANON _POSIX_MAX_INPUT _POSIX_NAME_MAX _POSIX_NGROUPS_MAX _POSIX_NO_TRUNC _POSIX_OPEN_MAX _POSIX_PATH_MAX _POSIX_PIPE_BUF _POSIX_SAVED_IDS _POSIX_SSIZE_MAX _POSIX_STREAM_MAX _POSIX_TZNAME_MAX _POSIX_VDISABLE _POSIX_VERSION
+
+=back
+
+=head1 SYSTEM CONFIGURATION
+
+=over 8
+
+=item Constants
+
+_SC_ARG_MAX _SC_CHILD_MAX _SC_CLK_TCK _SC_JOB_CONTROL _SC_NGROUPS_MAX _SC_OPEN_MAX _SC_PAGESIZE _SC_SAVED_IDS _SC_STREAM_MAX _SC_TZNAME_MAX _SC_VERSION
+
+=back
+
+=head1 ERRNO
+
+=over 8
+
+=item Constants
+
+E2BIG EACCES EADDRINUSE EADDRNOTAVAIL EAFNOSUPPORT EAGAIN EALREADY EBADF
+EBUSY ECHILD ECONNABORTED ECONNREFUSED ECONNRESET EDEADLK EDESTADDRREQ
+EDOM EDQUOT EEXIST EFAULT EFBIG EHOSTDOWN EHOSTUNREACH EINPROGRESS EINTR
+EINVAL EIO EISCONN EISDIR ELOOP EMFILE EMLINK EMSGSIZE ENAMETOOLONG
+ENETDOWN ENETRESET ENETUNREACH ENFILE ENOBUFS ENODEV ENOENT ENOEXEC
+ENOLCK ENOMEM ENOPROTOOPT ENOSPC ENOSYS ENOTBLK ENOTCONN ENOTDIR
+ENOTEMPTY ENOTSOCK ENOTTY ENXIO EOPNOTSUPP EPERM EPFNOSUPPORT EPIPE
+EPROCLIM EPROTONOSUPPORT EPROTOTYPE ERANGE EREMOTE ERESTART EROFS
+ESHUTDOWN ESOCKTNOSUPPORT ESPIPE ESRCH ESTALE ETIMEDOUT ETOOMANYREFS
+ETXTBSY EUSERS EWOULDBLOCK EXDEV
+
+=back
+
+=head1 FCNTL
+
+=over 8
+
+=item Constants
+
+FD_CLOEXEC F_DUPFD F_GETFD F_GETFL F_GETLK F_OK F_RDLCK F_SETFD F_SETFL F_SETLK F_SETLKW F_UNLCK F_WRLCK O_ACCMODE O_APPEND O_CREAT O_EXCL O_NOCTTY O_NONBLOCK O_RDONLY O_RDWR O_TRUNC O_WRONLY
+
+=back
+
+=head1 FLOAT
+
+=over 8
+
+=item Constants
+
+DBL_DIG DBL_EPSILON DBL_MANT_DIG DBL_MAX DBL_MAX_10_EXP DBL_MAX_EXP DBL_MIN DBL_MIN_10_EXP DBL_MIN_EXP FLT_DIG FLT_EPSILON FLT_MANT_DIG FLT_MAX FLT_MAX_10_EXP FLT_MAX_EXP FLT_MIN FLT_MIN_10_EXP FLT_MIN_EXP FLT_RADIX FLT_ROUNDS LDBL_DIG LDBL_EPSILON LDBL_MANT_DIG LDBL_MAX LDBL_MAX_10_EXP LDBL_MAX_EXP LDBL_MIN LDBL_MIN_10_EXP LDBL_MIN_EXP
+
+=back
+
+=head1 LIMITS
+
+=over 8
+
+=item Constants
+
+ARG_MAX CHAR_BIT CHAR_MAX CHAR_MIN CHILD_MAX INT_MAX INT_MIN LINK_MAX LONG_MAX LONG_MIN MAX_CANON MAX_INPUT MB_LEN_MAX NAME_MAX NGROUPS_MAX OPEN_MAX PATH_MAX PIPE_BUF SCHAR_MAX SCHAR_MIN SHRT_MAX SHRT_MIN SSIZE_MAX STREAM_MAX TZNAME_MAX UCHAR_MAX UINT_MAX ULONG_MAX USHRT_MAX
+
+=back
+
+=head1 LOCALE
+
+=over 8
+
+=item Constants
+
+LC_ALL LC_COLLATE LC_CTYPE LC_MONETARY LC_NUMERIC LC_TIME
+
+=back
+
+=head1 MATH
+
+=over 8
+
+=item Constants
+
+HUGE_VAL
+
+=back
+
+=head1 SIGNAL
+
+=over 8
+
+=item Constants
+
+SA_NOCLDSTOP SA_NOCLDWAIT SA_NODEFER SA_ONSTACK SA_RESETHAND SA_RESTART
+SA_SIGINFO SIGABRT SIGALRM SIGCHLD SIGCONT SIGFPE SIGHUP SIGILL SIGINT
+SIGKILL SIGPIPE SIGQUIT SIGSEGV SIGSTOP SIGTERM SIGTSTP SIGTTIN SIGTTOU
+SIGUSR1 SIGUSR2 SIG_BLOCK SIG_DFL SIG_ERR SIG_IGN SIG_SETMASK
+SIG_UNBLOCK
+
+=back
+
+=head1 STAT
+
+=over 8
+
+=item Constants
+
+S_IRGRP S_IROTH S_IRUSR S_IRWXG S_IRWXO S_IRWXU S_ISGID S_ISUID S_IWGRP S_IWOTH S_IWUSR S_IXGRP S_IXOTH S_IXUSR
+
+=item Macros
+
+S_ISBLK S_ISCHR S_ISDIR S_ISFIFO S_ISREG
+
+=back
+
+=head1 STDLIB
+
+=over 8
+
+=item Constants
+
+EXIT_FAILURE EXIT_SUCCESS MB_CUR_MAX RAND_MAX
+
+=back
+
+=head1 STDIO
+
+=over 8
+
+=item Constants
+
+BUFSIZ EOF FILENAME_MAX L_ctermid L_cuserid L_tmpname TMP_MAX
+
+=back
+
+=head1 TIME
+
+=over 8
+
+=item Constants
+
+CLK_TCK CLOCKS_PER_SEC
+
+=back
+
+=head1 UNISTD
+
+=over 8
+
+=item Constants
+
+R_OK SEEK_CUR SEEK_END SEEK_SET STDIN_FILENO STDOUT_FILENO STDERR_FILENO W_OK X_OK
+
+=back
+
+=head1 WAIT
+
+=over 8
+
+=item Constants
+
+WNOHANG WUNTRACED
+
+=over 16
+
+=item WNOHANG
+
+Do not suspend the calling process until a child process
+changes state but instead return immediately.
+
+=item WUNTRACED
+
+Catch stopped child processes.
+
+=back
+
+=item Macros
+
+WIFEXITED WEXITSTATUS WIFSIGNALED WTERMSIG WIFSTOPPED WSTOPSIG
+
+=over 16
+
+=item WIFEXITED
+
+WIFEXITED($?) returns true if the child process exited normally
+(C<exit()> or by falling off the end of C<main()>)
+
+=item WEXITSTATUS
+
+WEXITSTATUS($?) returns the normal exit status of the child process
+(only meaningful if WIFEXITED($?) is true)
+
+=item WIFSIGNALED
+
+WIFSIGNALED($?) returns true if the child process terminated because
+of a signal
+
+=item WTERMSIG
+
+WTERMSIG($?) returns the signal the child process terminated for
+(only meaningful if WIFSIGNALED($?) is true)
+
+=item WIFSTOPPED
+
+WIFSTOPPED($?) returns true if the child process is currently stopped
+(can happen only if you specified the WUNTRACED flag to waitpid())
+
+=item WSTOPSIG
+
+WSTOPSIG($?) returns the signal the child process was stopped for
+(only meaningful if WIFSTOPPED($?) is true)
+
+=back
+
+=back
+
Modified: trunk/contrib/perl/ext/POSIX/POSIX.xs
===================================================================
--- trunk/contrib/perl/ext/POSIX/POSIX.xs 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/POSIX/POSIX.xs 2013-12-02 21:32:26 UTC (rev 6445)
@@ -82,26 +82,6 @@
#endif
#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 dNOOP
-#define dNOOP extern int Perl___notused PERL_UNUSED_DECL
-#endif
-
-#ifndef dVAR
-#define dVAR dNOOP
-#endif
-
#if defined(__VMS) && !defined(__POSIX_SOURCE)
# include <libdef.h> /* LIB$_INVARG constant */
# include <lib$routines.h> /* prototype for lib$ediv() */
@@ -160,9 +140,6 @@
# define ttyname(a) (char*)not_here("ttyname")
# define sigset_t long
# define pid_t long
-# ifdef __BORLANDC__
-# define tzname _tzname
-# endif
# ifdef _MSC_VER
# define mode_t short
# endif
@@ -396,9 +373,11 @@
/* Possibly needed prototypes */
#ifndef WIN32
+START_EXTERN_C
double strtod (const char *, char **);
long strtol (const char *, char **, int);
unsigned long strtoul (const char *, char **, int);
+END_EXTERN_C
#endif
#ifndef HAS_DIFFTIME
@@ -491,7 +470,45 @@
#endif
#endif
-#ifndef HAS_LOCALECONV
+#ifdef HAS_LOCALECONV
+struct lconv_offset {
+ const char *name;
+ size_t offset;
+};
+
+const struct lconv_offset lconv_strings[] = {
+ {"decimal_point", offsetof(struct lconv, decimal_point)},
+ {"thousands_sep", offsetof(struct lconv, thousands_sep)},
+#ifndef NO_LOCALECONV_GROUPING
+ {"grouping", offsetof(struct lconv, grouping)},
+#endif
+ {"int_curr_symbol", offsetof(struct lconv, int_curr_symbol)},
+ {"currency_symbol", offsetof(struct lconv, currency_symbol)},
+ {"mon_decimal_point", offsetof(struct lconv, mon_decimal_point)},
+#ifndef NO_LOCALECONV_MON_THOUSANDS_SEP
+ {"mon_thousands_sep", offsetof(struct lconv, mon_thousands_sep)},
+#endif
+#ifndef NO_LOCALECONV_MON_GROUPING
+ {"mon_grouping", offsetof(struct lconv, mon_grouping)},
+#endif
+ {"positive_sign", offsetof(struct lconv, positive_sign)},
+ {"negative_sign", offsetof(struct lconv, negative_sign)},
+ {NULL, 0}
+};
+
+const struct lconv_offset lconv_integers[] = {
+ {"int_frac_digits", offsetof(struct lconv, int_frac_digits)},
+ {"frac_digits", offsetof(struct lconv, frac_digits)},
+ {"p_cs_precedes", offsetof(struct lconv, p_cs_precedes)},
+ {"p_sep_by_space", offsetof(struct lconv, p_sep_by_space)},
+ {"n_cs_precedes", offsetof(struct lconv, n_cs_precedes)},
+ {"n_sep_by_space", offsetof(struct lconv, n_sep_by_space)},
+ {"p_sign_posn", offsetof(struct lconv, p_sign_posn)},
+ {"n_sign_posn", offsetof(struct lconv, n_sign_posn)},
+ {NULL, 0}
+};
+
+#else
#define localeconv() not_here("localeconv")
#endif
@@ -531,7 +548,7 @@
* as expected. The better solution would be not to use the W*() macros
* in the first place, though. -- Ingo Weinhold
*/
-#if defined(__BEOS__) || defined(__HAIKU__)
+#if defined(__HAIKU__)
# define WMUNGE(x) (((x) & 0xFF00) >> 8 | ((x) & 0x00FF) << 8)
#else
# define WMUNGE(x) (x)
@@ -558,6 +575,16 @@
(void)sigprocmask(SIG_SETMASK, ossetp, (sigset_t *)0);
}
+static void *
+allocate_struct(pTHX_ SV *rv, const STRLEN size, const char *packname) {
+ SV *const t = newSVrv(rv, packname);
+ void *const p = sv_grow(t, size + 1);
+
+ SvCUR_set(t, size);
+ SvPOK_on(t);
+ return p;
+}
+
#ifdef WIN32
/*
@@ -668,46 +695,119 @@
tzset();
}
+typedef int (*isfunc_t)(int);
+typedef void (*any_dptr_t)(void *);
+
+/* This needs to be ALIASed in a custom way, hence can't easily be defined as
+ a regular XSUB. */
+static XSPROTO(is_common); /* prototype to pass -Wmissing-prototypes */
+static XSPROTO(is_common)
+{
+ dXSARGS;
+ SV *charstring;
+ if (items != 1)
+ croak_xs_usage(cv, "charstring");
+
+ {
+ dXSTARG;
+ STRLEN len;
+ int RETVAL;
+ unsigned char *s = (unsigned char *) SvPV(ST(0), len);
+ unsigned char *e = s + len;
+ isfunc_t isfunc = (isfunc_t) XSANY.any_dptr;
+
+ for (RETVAL = 1; RETVAL && s < e; s++)
+ if (!isfunc(*s))
+ RETVAL = 0;
+ XSprePUSH;
+ PUSHi((IV)RETVAL);
+ }
+ XSRETURN(1);
+}
+
+MODULE = POSIX PACKAGE = POSIX
+
+BOOT:
+{
+ CV *cv;
+ const char *file = __FILE__;
+
+ /* Ensure we get the function, not a macro implementation. Like the C89
+ standard says we can... */
+#undef isalnum
+ cv = newXS("POSIX::isalnum", is_common, file);
+ XSANY.any_dptr = (any_dptr_t) &isalnum;
+#undef isalpha
+ cv = newXS("POSIX::isalpha", is_common, file);
+ XSANY.any_dptr = (any_dptr_t) &isalpha;
+#undef iscntrl
+ cv = newXS("POSIX::iscntrl", is_common, file);
+ XSANY.any_dptr = (any_dptr_t) &iscntrl;
+#undef isdigit
+ cv = newXS("POSIX::isdigit", is_common, file);
+ XSANY.any_dptr = (any_dptr_t) &isdigit;
+#undef isgraph
+ cv = newXS("POSIX::isgraph", is_common, file);
+ XSANY.any_dptr = (any_dptr_t) &isgraph;
+#undef islower
+ cv = newXS("POSIX::islower", is_common, file);
+ XSANY.any_dptr = (any_dptr_t) &islower;
+#undef isprint
+ cv = newXS("POSIX::isprint", is_common, file);
+ XSANY.any_dptr = (any_dptr_t) &isprint;
+#undef ispunct
+ cv = newXS("POSIX::ispunct", is_common, file);
+ XSANY.any_dptr = (any_dptr_t) &ispunct;
+#undef isspace
+ cv = newXS("POSIX::isspace", is_common, file);
+ XSANY.any_dptr = (any_dptr_t) &isspace;
+#undef isupper
+ cv = newXS("POSIX::isupper", is_common, file);
+ XSANY.any_dptr = (any_dptr_t) &isupper;
+#undef isxdigit
+ cv = newXS("POSIX::isxdigit", is_common, file);
+ XSANY.any_dptr = (any_dptr_t) &isxdigit;
+}
+
MODULE = SigSet PACKAGE = POSIX::SigSet PREFIX = sig
-POSIX::SigSet
+void
new(packname = "POSIX::SigSet", ...)
const char * packname
CODE:
{
int i;
- Newx(RETVAL, 1, sigset_t);
- sigemptyset(RETVAL);
+ sigset_t *const s
+ = (sigset_t *) allocate_struct(aTHX_ (ST(0) = sv_newmortal()),
+ sizeof(sigset_t),
+ packname);
+ sigemptyset(s);
for (i = 1; i < items; i++)
- sigaddset(RETVAL, SvIV(ST(i)));
+ sigaddset(s, SvIV(ST(i)));
+ XSRETURN(1);
}
- OUTPUT:
- RETVAL
-void
-DESTROY(sigset)
- POSIX::SigSet sigset
- CODE:
- Safefree(sigset);
-
SysRet
-sigaddset(sigset, sig)
+addset(sigset, sig)
POSIX::SigSet sigset
int sig
+ ALIAS:
+ delset = 1
+ CODE:
+ RETVAL = ix ? sigdelset(sigset, sig) : sigaddset(sigset, sig);
+ OUTPUT:
+ RETVAL
SysRet
-sigdelset(sigset, sig)
+emptyset(sigset)
POSIX::SigSet sigset
- int sig
+ ALIAS:
+ fillset = 1
+ CODE:
+ RETVAL = ix ? sigfillset(sigset) : sigemptyset(sigset);
+ OUTPUT:
+ RETVAL
-SysRet
-sigemptyset(sigset)
- POSIX::SigSet sigset
-
-SysRet
-sigfillset(sigset)
- POSIX::SigSet sigset
-
int
sigismember(sigset, sig)
POSIX::SigSet sigset
@@ -715,31 +815,25 @@
MODULE = Termios PACKAGE = POSIX::Termios PREFIX = cf
-POSIX::Termios
+void
new(packname = "POSIX::Termios", ...)
const char * packname
CODE:
{
#ifdef I_TERMIOS
- Newx(RETVAL, 1, struct termios);
+ void *const p = allocate_struct(aTHX_ (ST(0) = sv_newmortal()),
+ sizeof(struct termios), packname);
+ /* The previous implementation stored a pointer to an uninitialised
+ struct termios. Seems safer to initialise it, particularly as
+ this implementation exposes the struct to prying from perl-space.
+ */
+ memset(p, 0, 1 + sizeof(struct termios));
+ XSRETURN(1);
#else
not_here("termios");
- RETVAL = 0;
#endif
}
- OUTPUT:
- RETVAL
-void
-DESTROY(termios_ref)
- POSIX::Termios termios_ref
- CODE:
-#ifdef I_TERMIOS
- Safefree(termios_ref);
-#else
- not_here("termios");
-#endif
-
SysRet
getattr(termios_ref, fd = 0)
POSIX::Termios termios_ref
@@ -749,76 +843,67 @@
OUTPUT:
RETVAL
+# If we define TCSANOW here then both a found and not found constant sub
+# are created causing a Constant subroutine TCSANOW redefined warning
+#ifndef TCSANOW
+# define DEF_SETATTR_ACTION 0
+#else
+# define DEF_SETATTR_ACTION TCSANOW
+#endif
SysRet
-setattr(termios_ref, fd = 0, optional_actions = 0)
+setattr(termios_ref, fd = 0, optional_actions = DEF_SETATTR_ACTION)
POSIX::Termios termios_ref
int fd
int optional_actions
CODE:
+ /* The second argument to the call is mandatory, but we'd like to give
+ it a useful default. 0 isn't valid on all operating systems - on
+ Solaris (at least) TCSANOW, TCSADRAIN and TCSAFLUSH have the same
+ values as the equivalent ioctls, TCSETS, TCSETSW and TCSETSF. */
RETVAL = tcsetattr(fd, optional_actions, termios_ref);
OUTPUT:
RETVAL
speed_t
-cfgetispeed(termios_ref)
+getispeed(termios_ref)
POSIX::Termios termios_ref
-
-speed_t
-cfgetospeed(termios_ref)
- POSIX::Termios termios_ref
-
-tcflag_t
-getiflag(termios_ref)
- POSIX::Termios termios_ref
+ ALIAS:
+ getospeed = 1
CODE:
-#ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */
- RETVAL = termios_ref->c_iflag;
-#else
- not_here("getiflag");
- RETVAL = 0;
-#endif
+ RETVAL = ix ? cfgetospeed(termios_ref) : cfgetispeed(termios_ref);
OUTPUT:
RETVAL
tcflag_t
-getoflag(termios_ref)
+getiflag(termios_ref)
POSIX::Termios termios_ref
+ ALIAS:
+ getoflag = 1
+ getcflag = 2
+ getlflag = 3
CODE:
#ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */
- RETVAL = termios_ref->c_oflag;
+ switch(ix) {
+ case 0:
+ RETVAL = termios_ref->c_iflag;
+ break;
+ case 1:
+ RETVAL = termios_ref->c_oflag;
+ break;
+ case 2:
+ RETVAL = termios_ref->c_cflag;
+ break;
+ case 3:
+ RETVAL = termios_ref->c_lflag;
+ break;
+ }
#else
- not_here("getoflag");
- RETVAL = 0;
+ not_here(GvNAME(CvGV(cv)));
+ RETVAL = 0;
#endif
OUTPUT:
RETVAL
-tcflag_t
-getcflag(termios_ref)
- POSIX::Termios termios_ref
- CODE:
-#ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */
- RETVAL = termios_ref->c_cflag;
-#else
- not_here("getcflag");
- RETVAL = 0;
-#endif
- OUTPUT:
- RETVAL
-
-tcflag_t
-getlflag(termios_ref)
- POSIX::Termios termios_ref
- CODE:
-#ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */
- RETVAL = termios_ref->c_lflag;
-#else
- not_here("getlflag");
- RETVAL = 0;
-#endif
- OUTPUT:
- RETVAL
-
cc_t
getcc(termios_ref, ccix)
POSIX::Termios termios_ref
@@ -836,60 +921,46 @@
RETVAL
SysRet
-cfsetispeed(termios_ref, speed)
+setispeed(termios_ref, speed)
POSIX::Termios termios_ref
speed_t speed
-
-SysRet
-cfsetospeed(termios_ref, speed)
- POSIX::Termios termios_ref
- speed_t speed
-
-void
-setiflag(termios_ref, iflag)
- POSIX::Termios termios_ref
- tcflag_t iflag
+ ALIAS:
+ setospeed = 1
CODE:
-#ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */
- termios_ref->c_iflag = iflag;
-#else
- not_here("setiflag");
-#endif
+ RETVAL = ix
+ ? cfsetospeed(termios_ref, speed) : cfsetispeed(termios_ref, speed);
+ OUTPUT:
+ RETVAL
void
-setoflag(termios_ref, oflag)
+setiflag(termios_ref, flag)
POSIX::Termios termios_ref
- tcflag_t oflag
+ tcflag_t flag
+ ALIAS:
+ setoflag = 1
+ setcflag = 2
+ setlflag = 3
CODE:
#ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */
- termios_ref->c_oflag = oflag;
+ switch(ix) {
+ case 0:
+ termios_ref->c_iflag = flag;
+ break;
+ case 1:
+ termios_ref->c_oflag = flag;
+ break;
+ case 2:
+ termios_ref->c_cflag = flag;
+ break;
+ case 3:
+ termios_ref->c_lflag = flag;
+ break;
+ }
#else
- not_here("setoflag");
+ not_here(GvNAME(CvGV(cv)));
#endif
void
-setcflag(termios_ref, cflag)
- POSIX::Termios termios_ref
- tcflag_t cflag
- CODE:
-#ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */
- termios_ref->c_cflag = cflag;
-#else
- not_here("setcflag");
-#endif
-
-void
-setlflag(termios_ref, lflag)
- POSIX::Termios termios_ref
- tcflag_t lflag
- CODE:
-#ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */
- termios_ref->c_lflag = lflag;
-#else
- not_here("setlflag");
-#endif
-
-void
setcc(termios_ref, ccix, cc)
POSIX::Termios termios_ref
unsigned int ccix
@@ -972,160 +1043,6 @@
OUTPUT:
RETVAL
-int
-isalnum(charstring)
- SV * charstring
- PREINIT:
- STRLEN len;
- CODE:
- unsigned char *s = (unsigned char *) SvPV(charstring, len);
- unsigned char *e = s + len;
- for (RETVAL = 1; RETVAL && s < e; s++)
- if (!isalnum(*s))
- RETVAL = 0;
- OUTPUT:
- RETVAL
-
-int
-isalpha(charstring)
- SV * charstring
- PREINIT:
- STRLEN len;
- CODE:
- unsigned char *s = (unsigned char *) SvPV(charstring, len);
- unsigned char *e = s + len;
- for (RETVAL = 1; RETVAL && s < e; s++)
- if (!isalpha(*s))
- RETVAL = 0;
- OUTPUT:
- RETVAL
-
-int
-iscntrl(charstring)
- SV * charstring
- PREINIT:
- STRLEN len;
- CODE:
- unsigned char *s = (unsigned char *) SvPV(charstring, len);
- unsigned char *e = s + len;
- for (RETVAL = 1; RETVAL && s < e; s++)
- if (!iscntrl(*s))
- RETVAL = 0;
- OUTPUT:
- RETVAL
-
-int
-isdigit(charstring)
- SV * charstring
- PREINIT:
- STRLEN len;
- CODE:
- unsigned char *s = (unsigned char *) SvPV(charstring, len);
- unsigned char *e = s + len;
- for (RETVAL = 1; RETVAL && s < e; s++)
- if (!isdigit(*s))
- RETVAL = 0;
- OUTPUT:
- RETVAL
-
-int
-isgraph(charstring)
- SV * charstring
- PREINIT:
- STRLEN len;
- CODE:
- unsigned char *s = (unsigned char *) SvPV(charstring, len);
- unsigned char *e = s + len;
- for (RETVAL = 1; RETVAL && s < e; s++)
- if (!isgraph(*s))
- RETVAL = 0;
- OUTPUT:
- RETVAL
-
-int
-islower(charstring)
- SV * charstring
- PREINIT:
- STRLEN len;
- CODE:
- unsigned char *s = (unsigned char *) SvPV(charstring, len);
- unsigned char *e = s + len;
- for (RETVAL = 1; RETVAL && s < e; s++)
- if (!islower(*s))
- RETVAL = 0;
- OUTPUT:
- RETVAL
-
-int
-isprint(charstring)
- SV * charstring
- PREINIT:
- STRLEN len;
- CODE:
- unsigned char *s = (unsigned char *) SvPV(charstring, len);
- unsigned char *e = s + len;
- for (RETVAL = 1; RETVAL && s < e; s++)
- if (!isprint(*s))
- RETVAL = 0;
- OUTPUT:
- RETVAL
-
-int
-ispunct(charstring)
- SV * charstring
- PREINIT:
- STRLEN len;
- CODE:
- unsigned char *s = (unsigned char *) SvPV(charstring, len);
- unsigned char *e = s + len;
- for (RETVAL = 1; RETVAL && s < e; s++)
- if (!ispunct(*s))
- RETVAL = 0;
- OUTPUT:
- RETVAL
-
-int
-isspace(charstring)
- SV * charstring
- PREINIT:
- STRLEN len;
- CODE:
- unsigned char *s = (unsigned char *) SvPV(charstring, len);
- unsigned char *e = s + len;
- for (RETVAL = 1; RETVAL && s < e; s++)
- if (!isspace(*s))
- RETVAL = 0;
- OUTPUT:
- RETVAL
-
-int
-isupper(charstring)
- SV * charstring
- PREINIT:
- STRLEN len;
- CODE:
- unsigned char *s = (unsigned char *) SvPV(charstring, len);
- unsigned char *e = s + len;
- for (RETVAL = 1; RETVAL && s < e; s++)
- if (!isupper(*s))
- RETVAL = 0;
- OUTPUT:
- RETVAL
-
-int
-isxdigit(charstring)
- SV * charstring
- PREINIT:
- STRLEN len;
- CODE:
- unsigned char *s = (unsigned char *) SvPV(charstring, len);
- unsigned char *e = s + len;
- for (RETVAL = 1; RETVAL && s < e; s++)
- if (!isxdigit(*s))
- RETVAL = 0;
- OUTPUT:
- RETVAL
-
SysRet
open(filename, flags = O_RDONLY, mode = 0666)
char * filename
@@ -1147,68 +1064,25 @@
RETVAL = newHV();
sv_2mortal((SV*)RETVAL);
if ((lcbuf = localeconv())) {
- /* the strings */
- if (lcbuf->decimal_point && *lcbuf->decimal_point)
- (void) hv_store(RETVAL, "decimal_point", 13,
- newSVpv(lcbuf->decimal_point, 0), 0);
- if (lcbuf->thousands_sep && *lcbuf->thousands_sep)
- (void) hv_store(RETVAL, "thousands_sep", 13,
- newSVpv(lcbuf->thousands_sep, 0), 0);
-#ifndef NO_LOCALECONV_GROUPING
- if (lcbuf->grouping && *lcbuf->grouping)
- (void) hv_store(RETVAL, "grouping", 8,
- newSVpv(lcbuf->grouping, 0), 0);
-#endif
- if (lcbuf->int_curr_symbol && *lcbuf->int_curr_symbol)
- (void) hv_store(RETVAL, "int_curr_symbol", 15,
- newSVpv(lcbuf->int_curr_symbol, 0), 0);
- if (lcbuf->currency_symbol && *lcbuf->currency_symbol)
- (void) hv_store(RETVAL, "currency_symbol", 15,
- newSVpv(lcbuf->currency_symbol, 0), 0);
- if (lcbuf->mon_decimal_point && *lcbuf->mon_decimal_point)
- (void) hv_store(RETVAL, "mon_decimal_point", 17,
- newSVpv(lcbuf->mon_decimal_point, 0), 0);
-#ifndef NO_LOCALECONV_MON_THOUSANDS_SEP
- if (lcbuf->mon_thousands_sep && *lcbuf->mon_thousands_sep)
- (void) hv_store(RETVAL, "mon_thousands_sep", 17,
- newSVpv(lcbuf->mon_thousands_sep, 0), 0);
-#endif
-#ifndef NO_LOCALECONV_MON_GROUPING
- if (lcbuf->mon_grouping && *lcbuf->mon_grouping)
- (void) hv_store(RETVAL, "mon_grouping", 12,
- newSVpv(lcbuf->mon_grouping, 0), 0);
-#endif
- if (lcbuf->positive_sign && *lcbuf->positive_sign)
- (void) hv_store(RETVAL, "positive_sign", 13,
- newSVpv(lcbuf->positive_sign, 0), 0);
- if (lcbuf->negative_sign && *lcbuf->negative_sign)
- (void) hv_store(RETVAL, "negative_sign", 13,
- newSVpv(lcbuf->negative_sign, 0), 0);
- /* the integers */
- if (lcbuf->int_frac_digits != CHAR_MAX)
- (void) hv_store(RETVAL, "int_frac_digits", 15,
- newSViv(lcbuf->int_frac_digits), 0);
- if (lcbuf->frac_digits != CHAR_MAX)
- (void) hv_store(RETVAL, "frac_digits", 11,
- newSViv(lcbuf->frac_digits), 0);
- if (lcbuf->p_cs_precedes != CHAR_MAX)
- (void) hv_store(RETVAL, "p_cs_precedes", 13,
- newSViv(lcbuf->p_cs_precedes), 0);
- if (lcbuf->p_sep_by_space != CHAR_MAX)
- (void) hv_store(RETVAL, "p_sep_by_space", 14,
- newSViv(lcbuf->p_sep_by_space), 0);
- if (lcbuf->n_cs_precedes != CHAR_MAX)
- (void) hv_store(RETVAL, "n_cs_precedes", 13,
- newSViv(lcbuf->n_cs_precedes), 0);
- if (lcbuf->n_sep_by_space != CHAR_MAX)
- (void) hv_store(RETVAL, "n_sep_by_space", 14,
- newSViv(lcbuf->n_sep_by_space), 0);
- if (lcbuf->p_sign_posn != CHAR_MAX)
- (void) hv_store(RETVAL, "p_sign_posn", 11,
- newSViv(lcbuf->p_sign_posn), 0);
- if (lcbuf->n_sign_posn != CHAR_MAX)
- (void) hv_store(RETVAL, "n_sign_posn", 11,
- newSViv(lcbuf->n_sign_posn), 0);
+ const struct lconv_offset *strings = lconv_strings;
+ const struct lconv_offset *integers = lconv_integers;
+ const char *ptr = (const char *) lcbuf;
+
+ do {
+ const char *value = *((const char **)(ptr + strings->offset));
+
+ if (value && *value)
+ (void) hv_store(RETVAL, strings->name, strlen(strings->name),
+ newSVpv(value, 0), 0);
+ } while ((++strings)->name);
+
+ do {
+ const char value = *((const char *)(ptr + integers->offset));
+
+ if (value != CHAR_MAX)
+ (void) hv_store(RETVAL, integers->name,
+ strlen(integers->name), newSViv(value), 0);
+ } while ((++integers)->name);
}
#else
localeconv(); /* A stub to call not_here(). */
@@ -1291,28 +1165,52 @@
NV
acos(x)
NV x
+ ALIAS:
+ asin = 1
+ atan = 2
+ ceil = 3
+ cosh = 4
+ floor = 5
+ log10 = 6
+ sinh = 7
+ tan = 8
+ tanh = 9
+ CODE:
+ switch (ix) {
+ case 0:
+ RETVAL = acos(x);
+ break;
+ case 1:
+ RETVAL = asin(x);
+ break;
+ case 2:
+ RETVAL = atan(x);
+ break;
+ case 3:
+ RETVAL = ceil(x);
+ break;
+ case 4:
+ RETVAL = cosh(x);
+ break;
+ case 5:
+ RETVAL = floor(x);
+ break;
+ case 6:
+ RETVAL = log10(x);
+ break;
+ case 7:
+ RETVAL = sinh(x);
+ break;
+ case 8:
+ RETVAL = tan(x);
+ break;
+ default:
+ RETVAL = tanh(x);
+ }
+ OUTPUT:
+ RETVAL
NV
-asin(x)
- NV x
-
-NV
-atan(x)
- NV x
-
-NV
-ceil(x)
- NV x
-
-NV
-cosh(x)
- NV x
-
-NV
-floor(x)
- NV x
-
-NV
fmod(x,y)
NV x
NV y
@@ -1331,10 +1229,6 @@
NV x
int exp
-NV
-log10(x)
- NV x
-
void
modf(x)
NV x
@@ -1344,18 +1238,6 @@
PUSHs(sv_2mortal(newSVnv(Perl_modf(x,&intvar))));
PUSHs(sv_2mortal(newSVnv(intvar)));
-NV
-sinh(x)
- NV x
-
-NV
-tan(x)
- NV x
-
-NV
-tanh(x)
- NV x
-
SysRet
sigaction(sig, optaction, oldaction = 0)
int sig
@@ -1459,12 +1341,12 @@
/* Get back the mask. */
svp = hv_fetchs(oldaction, "MASK", TRUE);
if (sv_isa(*svp, "POSIX::SigSet")) {
- IV tmp = SvIV((SV*)SvRV(*svp));
- sigset = INT2PTR(sigset_t*, tmp);
+ sigset = (sigset_t *) SvPV_nolen(SvRV(*svp));
}
else {
- Newx(sigset, 1, sigset_t);
- sv_setptrobj(*svp, sigset, "POSIX::SigSet");
+ sigset = (sigset_t *) allocate_struct(aTHX_ *svp,
+ sizeof(sigset_t),
+ "POSIX::SigSet");
}
*sigset = oact.sa_mask;
@@ -1518,8 +1400,7 @@
/* Set up any desired mask. */
svp = hv_fetchs(action, "MASK", FALSE);
if (svp && sv_isa(*svp, "POSIX::SigSet")) {
- IV tmp = SvIV((SV*)SvRV(*svp));
- sigset = INT2PTR(sigset_t*, tmp);
+ sigset = (sigset_t *) SvPV_nolen(SvRV(*svp));
act.sa_mask = *sigset;
}
else
@@ -1550,6 +1431,14 @@
SysRet
sigpending(sigset)
POSIX::SigSet sigset
+ ALIAS:
+ sigsuspend = 1
+ CODE:
+ RETVAL = ix ? sigsuspend(sigset) : sigpending(sigset);
+ OUTPUT:
+ RETVAL
+ CLEANUP:
+ PERL_ASYNC_CHECK();
SysRet
sigprocmask(how, sigset, oldsigset = 0)
@@ -1560,8 +1449,7 @@
if (! SvOK(ST(1))) {
sigset = NULL;
} else if (sv_isa(ST(1), "POSIX::SigSet")) {
- IV tmp = SvIV((SV*)SvRV(ST(1)));
- sigset = INT2PTR(POSIX__SigSet,tmp);
+ sigset = (sigset_t *) SvPV_nolen(SvRV(ST(1)));
} else {
croak("sigset is not of type POSIX::SigSet");
}
@@ -1569,32 +1457,30 @@
if (items < 3 || ! SvOK(ST(2))) {
oldsigset = NULL;
} else if (sv_isa(ST(2), "POSIX::SigSet")) {
- IV tmp = SvIV((SV*)SvRV(ST(2)));
- oldsigset = INT2PTR(POSIX__SigSet,tmp);
+ oldsigset = (sigset_t *) SvPV_nolen(SvRV(ST(2)));
} else {
croak("oldsigset is not of type POSIX::SigSet");
}
-SysRet
-sigsuspend(signal_mask)
- POSIX::SigSet signal_mask
-
void
_exit(status)
int status
SysRet
-close(fd)
- int fd
-
-SysRet
-dup(fd)
- int fd
-
-SysRet
dup2(fd1, fd2)
int fd1
int fd2
+ CODE:
+#ifdef WIN32
+ /* RT #98912 - More Microsoft muppetry - failing to actually implemented
+ the well known documented POSIX behaviour for a POSIX API.
+ http://msdn.microsoft.com/en-us/library/8syseb29.aspx */
+ RETVAL = dup2(fd1, fd2) == -1 ? -1 : fd2;
+#else
+ RETVAL = dup2(fd1, fd2);
+#endif
+ OUTPUT:
+ RETVAL
SV *
lseek(fd, offset, whence)
@@ -1824,9 +1710,15 @@
mkfifo(filename, mode)
char * filename
Mode_t mode
+ ALIAS:
+ access = 1
CODE:
- TAINT_PROPER("mkfifo");
- RETVAL = mkfifo(filename, mode);
+ if(ix) {
+ RETVAL = access(filename, mode);
+ } else {
+ TAINT_PROPER("mkfifo");
+ RETVAL = mkfifo(filename, mode);
+ }
OUTPUT:
RETVAL
@@ -1833,6 +1725,14 @@
SysRet
tcdrain(fd)
int fd
+ ALIAS:
+ close = 1
+ dup = 2
+ CODE:
+ RETVAL = ix == 1 ? close(fd)
+ : (ix < 1 ? tcdrain(fd) : dup(fd));
+ OUTPUT:
+ RETVAL
SysRet
@@ -1839,19 +1739,16 @@
tcflow(fd, action)
int fd
int action
+ ALIAS:
+ tcflush = 1
+ tcsendbreak = 2
+ CODE:
+ RETVAL = ix == 1 ? tcflush(fd, action)
+ : (ix < 1 ? tcflow(fd, action) : tcsendbreak(fd, action));
+ OUTPUT:
+ RETVAL
-
-SysRet
-tcflush(fd, queue_selector)
- int fd
- int queue_selector
-
-SysRet
-tcsendbreak(fd, duration)
- int fd
- int duration
-
-char *
+void
asctime(sec, min, hour, mday, mon, year, wday = 0, yday = 0, isdst = -1)
int sec
int min
@@ -1862,10 +1759,13 @@
int wday
int yday
int isdst
- CODE:
+ ALIAS:
+ mktime = 1
+ PPCODE:
{
+ dXSTARG;
struct tm mytm;
- init_tm(&mytm); /* XXX workaround - see init_tm() above */
+ init_tm(&mytm); /* XXX workaround - see init_tm() in core util.c */
mytm.tm_sec = sec;
mytm.tm_min = min;
mytm.tm_hour = hour;
@@ -1875,10 +1775,20 @@
mytm.tm_wday = wday;
mytm.tm_yday = yday;
mytm.tm_isdst = isdst;
- RETVAL = asctime(&mytm);
+ if (ix) {
+ const time_t result = mktime(&mytm);
+ if (result == (time_t)-1)
+ SvOK_off(TARG);
+ else if (result == 0)
+ sv_setpvn(TARG, "0 but true", 10);
+ else
+ sv_setiv(TARG, (IV)result);
+ } else {
+ sv_setpv(TARG, asctime(&mytm));
+ }
+ ST(0) = TARG;
+ XSRETURN(1);
}
- OUTPUT:
- RETVAL
long
clock()
@@ -1905,35 +1815,6 @@
Time_t time1
Time_t time2
-SysRetLong
-mktime(sec, min, hour, mday, mon, year, wday = 0, yday = 0, isdst = -1)
- int sec
- int min
- int hour
- int mday
- int mon
- int year
- int wday
- int yday
- int isdst
- CODE:
- {
- struct tm mytm;
- init_tm(&mytm); /* XXX workaround - see init_tm() above */
- mytm.tm_sec = sec;
- mytm.tm_min = min;
- mytm.tm_hour = hour;
- mytm.tm_mday = mday;
- mytm.tm_mon = mon;
- mytm.tm_year = year;
- mytm.tm_wday = wday;
- mytm.tm_yday = yday;
- mytm.tm_isdst = isdst;
- RETVAL = (SysRetLong) mktime(&mytm);
- }
- OUTPUT:
- RETVAL
-
#XXX: if $xsubpp::WantOptimize is always the default
# sv_setpv(TARG, ...) could be used rather than
# ST(0) = sv_2mortal(newSVpv(...))
@@ -1974,11 +1855,6 @@
PUSHs(newSVpvn_flags(tzname[0], strlen(tzname[0]), SVs_TEMP));
PUSHs(newSVpvn_flags(tzname[1], strlen(tzname[1]), SVs_TEMP));
-SysRet
-access(filename, mode)
- char * filename
- Mode_t mode
-
char *
ctermid(s = 0)
char * s = 0;
@@ -2019,28 +1895,24 @@
SysRet
pause()
+ CLEANUP:
+ PERL_ASYNC_CHECK();
+unsigned int
+sleep(seconds)
+ unsigned int seconds
+ CODE:
+ RETVAL = PerlProc_sleep(seconds);
+ OUTPUT:
+ RETVAL
+
SysRet
setgid(gid)
Gid_t gid
- CLEANUP:
-#ifndef WIN32
- if (RETVAL >= 0) {
- PL_gid = getgid();
- PL_egid = getegid();
- }
-#endif
SysRet
setuid(uid)
Uid_t uid
- CLEANUP:
-#ifndef WIN32
- if (RETVAL >= 0) {
- PL_uid = getuid();
- PL_euid = geteuid();
- }
-#endif
SysRetLong
sysconf(name)
Property changes on: trunk/contrib/perl/ext/POSIX/POSIX.xs
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Index: trunk/contrib/perl/ext/POSIX/hints/bsdos.pl
===================================================================
--- trunk/contrib/perl/ext/POSIX/hints/bsdos.pl 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/POSIX/hints/bsdos.pl 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/POSIX/hints/bsdos.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/POSIX/hints/dynixptx.pl
===================================================================
--- trunk/contrib/perl/ext/POSIX/hints/dynixptx.pl 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/POSIX/hints/dynixptx.pl 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/POSIX/hints/dynixptx.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/POSIX/hints/freebsd.pl
===================================================================
--- trunk/contrib/perl/ext/POSIX/hints/freebsd.pl 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/POSIX/hints/freebsd.pl 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/POSIX/hints/freebsd.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/POSIX/hints/gnukfreebsd.pl
===================================================================
--- trunk/contrib/perl/ext/POSIX/hints/gnukfreebsd.pl 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/POSIX/hints/gnukfreebsd.pl 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/POSIX/hints/gnukfreebsd.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/POSIX/hints/gnuknetbsd.pl
===================================================================
--- trunk/contrib/perl/ext/POSIX/hints/gnuknetbsd.pl 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/POSIX/hints/gnuknetbsd.pl 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/POSIX/hints/gnuknetbsd.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/POSIX/hints/linux.pl
===================================================================
--- trunk/contrib/perl/ext/POSIX/hints/linux.pl 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/POSIX/hints/linux.pl 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/POSIX/hints/linux.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/POSIX/hints/mint.pl
===================================================================
--- trunk/contrib/perl/ext/POSIX/hints/mint.pl 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/POSIX/hints/mint.pl 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/POSIX/hints/mint.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/POSIX/hints/netbsd.pl
===================================================================
--- trunk/contrib/perl/ext/POSIX/hints/netbsd.pl 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/POSIX/hints/netbsd.pl 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/POSIX/hints/netbsd.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/POSIX/hints/next_3.pl
===================================================================
--- trunk/contrib/perl/ext/POSIX/hints/next_3.pl 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/POSIX/hints/next_3.pl 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/POSIX/hints/next_3.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/POSIX/hints/openbsd.pl
===================================================================
--- trunk/contrib/perl/ext/POSIX/hints/openbsd.pl 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/POSIX/hints/openbsd.pl 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/POSIX/hints/openbsd.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/POSIX/hints/sunos_4.pl
===================================================================
--- trunk/contrib/perl/ext/POSIX/hints/sunos_4.pl 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/POSIX/hints/sunos_4.pl 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/POSIX/hints/sunos_4.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/POSIX/hints/svr4.pl
===================================================================
--- trunk/contrib/perl/ext/POSIX/hints/svr4.pl 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/POSIX/hints/svr4.pl 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/POSIX/hints/svr4.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/POSIX/hints/uts.pl
===================================================================
--- trunk/contrib/perl/ext/POSIX/hints/uts.pl 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/POSIX/hints/uts.pl 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/POSIX/hints/uts.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/ext/POSIX/lib/POSIX.pm
===================================================================
--- trunk/contrib/perl/ext/POSIX/lib/POSIX.pm 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/POSIX/lib/POSIX.pm 2013-12-02 21:32:26 UTC (rev 6445)
@@ -2,12 +2,10 @@
use strict;
use warnings;
-our(@ISA, %EXPORT_TAGS, @EXPORT_OK, @EXPORT, $AUTOLOAD, %SIGRT) = ();
+our ($AUTOLOAD, %SIGRT);
-our $VERSION = "1.24";
+our $VERSION = '1.32';
-use AutoLoader;
-
require XSLoader;
use Fcntl qw(FD_CLOEXEC F_DUPFD F_GETFD F_GETFL F_GETLK F_RDLCK F_SETFD
@@ -18,323 +16,206 @@
S_IRGRP S_IROTH S_IRUSR S_IRWXG S_IRWXO S_IRWXU S_ISGID S_ISUID
S_IWGRP S_IWOTH S_IWUSR S_IXGRP S_IXOTH S_IXUSR);
-# Grandfather old foo_h form to new :foo_h form
my $loaded;
sub import {
+ my $pkg = shift;
+
load_imports() unless $loaded++;
- my $this = shift;
- my @list = map { m/^\w+_h$/ ? ":$_" : $_ } @_;
+
+ # Grandfather old foo_h form to new :foo_h form
+ s/^(?=\w+_h$)/:/ for my @list = @_;
+
local $Exporter::ExportLevel = 1;
- Exporter::import($this, at list);
+ Exporter::import($pkg, at list);
}
sub croak { require Carp; goto &Carp::croak }
-# declare usage to assist AutoLoad
-sub usage;
+sub usage { croak "Usage: POSIX::$_[0]" }
XSLoader::load();
-sub AUTOLOAD {
- no warnings 'uninitialized';
- if ($AUTOLOAD =~ /::(_?[a-z])/) {
- # require AutoLoader;
- $AutoLoader::AUTOLOAD = $AUTOLOAD;
- goto &AutoLoader::AUTOLOAD
- }
- my $constname = $AUTOLOAD;
- $constname =~ s/.*:://;
- constant($constname);
-}
+my %replacement = (
+ atexit => 'END {}',
+ atof => undef,
+ atoi => undef,
+ atol => undef,
+ bsearch => \'not supplied',
+ calloc => undef,
+ clearerr => 'IO::Handle::clearerr',
+ div => '/, % and int',
+ execl => undef,
+ execle => undef,
+ execlp => undef,
+ execv => undef,
+ execve => undef,
+ execvp => undef,
+ fclose => 'IO::Handle::close',
+ fdopen => 'IO::Handle::new_from_fd',
+ feof => 'IO::Handle::eof',
+ ferror => 'IO::Handle::error',
+ fflush => 'IO::Handle::flush',
+ fgetc => 'IO::Handle::getc',
+ fgetpos => 'IO::Seekable::getpos',
+ fgets => 'IO::Handle::gets',
+ fileno => 'IO::Handle::fileno',
+ fopen => 'IO::File::open',
+ fprintf => 'printf',
+ fputc => 'print',
+ fputs => 'print',
+ fread => 'read',
+ free => undef,
+ freopen => 'open',
+ fscanf => '<> and regular expressions',
+ fseek => 'IO::Seekable::seek',
+ fsetpos => 'IO::Seekable::setpos',
+ fsync => 'IO::Handle::sync',
+ ftell => 'IO::Seekable::tell',
+ fwrite => 'print',
+ labs => 'abs',
+ ldiv => '/, % and int',
+ longjmp => 'die',
+ malloc => undef,
+ memchr => 'index()',
+ memcmp => 'eq',
+ memcpy => '=',
+ memmove => '=',
+ memset => 'x',
+ offsetof => undef,
+ putc => 'print',
+ putchar => 'print',
+ puts => 'print',
+ qsort => 'sort',
+ rand => \'non-portable, use Perl\'s rand instead',
+ realloc => undef,
+ scanf => '<> and regular expressions',
+ setbuf => 'IO::Handle::setbuf',
+ setjmp => 'eval {}',
+ setvbuf => 'IO::Handle::setvbuf',
+ siglongjmp => 'die',
+ sigsetjmp => 'eval {}',
+ srand => \'not supplied; refer to Perl\'s srand documentation',
+ sscanf => 'regular expressions',
+ strcat => '.=',
+ strchr => 'index()',
+ strcmp => 'eq',
+ strcpy => '=',
+ strcspn => 'regular expressions',
+ strlen => 'length',
+ strncat => '.=',
+ strncmp => 'eq',
+ strncpy => '=',
+ strpbrk => undef,
+ strrchr => 'rindex()',
+ strspn => undef,
+ strtok => undef,
+ tmpfile => 'IO::File::new_tmpfile',
+ ungetc => 'IO::Handle::ungetc',
+ vfprintf => undef,
+ vprintf => undef,
+ vsprintf => undef,
+);
-package POSIX::SigAction;
+my %reimpl = (
+ assert => 'expr => croak "Assertion failed" if !$_[0]',
+ tolower => 'string => lc($_[0])',
+ toupper => 'string => uc($_[0])',
+ closedir => 'dirhandle => CORE::closedir($_[0])',
+ opendir => 'directory => my $dh; CORE::opendir($dh, $_[0]) ? $dh : undef',
+ readdir => 'dirhandle => CORE::readdir($_[0])',
+ rewinddir => 'dirhandle => CORE::rewinddir($_[0])',
+ errno => '$! + 0',
+ creat => 'filename, mode => &open($_[0], &O_WRONLY | &O_CREAT | &O_TRUNC, $_[1])',
+ fcntl => 'filehandle, cmd, arg => CORE::fcntl($_[0], $_[1], $_[2])',
+ getgrgid => 'gid => CORE::getgrgid($_[0])',
+ getgrnam => 'name => CORE::getgrnam($_[0])',
+ atan2 => 'x, y => CORE::atan2($_[0], $_[1])',
+ cos => 'x => CORE::cos($_[0])',
+ exp => 'x => CORE::exp($_[0])',
+ fabs => 'x => CORE::abs($_[0])',
+ log => 'x => CORE::log($_[0])',
+ pow => 'x, exponent => $_[0] ** $_[1]',
+ sin => 'x => CORE::sin($_[0])',
+ sqrt => 'x => CORE::sqrt($_[0])',
+ getpwnam => 'name => CORE::getpwnam($_[0])',
+ getpwuid => 'uid => CORE::getpwuid($_[0])',
+ kill => 'pid, sig => CORE::kill $_[1], $_[0]',
+ raise => 'sig => CORE::kill $_[0], $$; # Is this good enough',
+ getc => 'handle => CORE::getc($_[0])',
+ getchar => 'CORE::getc(STDIN)',
+ gets => 'scalar <STDIN>',
+ remove => 'filename => (-d $_[0]) ? CORE::rmdir($_[0]) : CORE::unlink($_[0])',
+ rename => 'oldfilename, newfilename => CORE::rename($_[0], $_[1])',
+ rewind => 'filehandle => CORE::seek($_[0],0,0)',
+ abs => 'x => CORE::abs($_[0])',
+ exit => 'status => CORE::exit($_[0])',
+ getenv => 'name => $ENV{$_[0]}',
+ system => 'command => CORE::system($_[0])',
+ strerror => 'errno => local $! = $_[0]; "$!"',
+ strstr => 'big, little => CORE::index($_[0], $_[1])',
+ chmod => 'mode, filename => CORE::chmod($_[0], $_[1])',
+ fstat => 'fd => CORE::open my $dup, "<&", $_[0]; CORE::stat($dup)', # Gross.
+ mkdir => 'directoryname, mode => CORE::mkdir($_[0], $_[1])',
+ stat => 'filename => CORE::stat($_[0])',
+ umask => 'mask => CORE::umask($_[0])',
+ wait => 'CORE::wait()',
+ waitpid => 'pid, options => CORE::waitpid($_[0], $_[1])',
+ gmtime => 'time => CORE::gmtime($_[0])',
+ localtime => 'time => CORE::localtime($_[0])',
+ time => 'CORE::time',
+ alarm => 'seconds => CORE::alarm($_[0])',
+ chdir => 'directory => CORE::chdir($_[0])',
+ chown => 'uid, gid, filename => CORE::chown($_[0], $_[1], $_[2])',
+ fork => 'CORE::fork',
+ getegid => '$) + 0',
+ geteuid => '$> + 0',
+ getgid => '$( + 0',
+ getgroups => 'my %seen; grep !$seen{$_}++, split " ", $)',
+ getlogin => 'CORE::getlogin()',
+ getpgrp => 'CORE::getpgrp',
+ getpid => '$$',
+ getppid => 'CORE::getppid',
+ getuid => '$<',
+ isatty => 'filehandle => -t $_[0]',
+ link => 'oldfilename, newfilename => CORE::link($_[0], $_[1])',
+ rmdir => 'directoryname => CORE::rmdir($_[0])',
+ unlink => 'filename => CORE::unlink($_[0])',
+ utime => 'filename, atime, mtime => CORE::utime($_[1], $_[2], $_[0])',
+);
-use AutoLoader 'AUTOLOAD';
+eval join ';', map "sub $_", keys %replacement, keys %reimpl;
-package POSIX::SigRt;
+sub AUTOLOAD {
+ my ($func) = ($AUTOLOAD =~ /.*::(.*)/);
-use AutoLoader 'AUTOLOAD';
-
-use Tie::Hash;
-
-use vars qw($SIGACTION_FLAGS $_SIGRTMIN $_SIGRTMAX $_sigrtn @ISA);
- at POSIX::SigRt::ISA = qw(Tie::StdHash);
-
-$SIGACTION_FLAGS = 0;
-
-tie %POSIX::SIGRT, 'POSIX::SigRt';
-
-sub DESTROY {};
-
-package POSIX;
-
-1;
-__END__
-
-sub usage {
- my ($mess) = @_;
- croak "Usage: POSIX::$mess";
-}
-
-sub redef {
- my ($mess) = @_;
- croak "Use method $mess instead";
-}
-
-sub unimpl {
- my ($mess) = @_;
- $mess =~ s/xxx//;
- croak "Unimplemented: POSIX::$mess";
-}
-
-sub assert {
- usage "assert(expr)" if @_ != 1;
- if (!$_[0]) {
- croak "Assertion failed";
+ if (my $code = $reimpl{$func}) {
+ my ($num, $arg) = (0, '');
+ if ($code =~ s/^(.*?) *=> *//) {
+ $arg = $1;
+ $num = 1 + $arg =~ tr/,//;
+ }
+ # no warnings to be consistent with the old implementation, where each
+ # function was in its own little AutoSplit world:
+ eval qq{ sub $func {
+ no warnings;
+ usage "$func($arg)" if \@_ != $num;
+ $code
+ } };
+ no strict;
+ goto &$AUTOLOAD;
}
-}
+ if (exists $replacement{$func}) {
+ my $how = $replacement{$func};
+ croak "Unimplemented: POSIX::$func() is C-specific, stopped"
+ unless defined $how;
+ croak "Unimplemented: POSIX::$func() is $$how" if ref $how;
+ croak "Use method $how() instead of POSIX::$func()" if $how =~ /::/;
+ croak "Unimplemented: POSIX::$func() is C-specific: use $how instead";
+ }
-sub tolower {
- usage "tolower(string)" if @_ != 1;
- lc($_[0]);
+ constant($func);
}
-sub toupper {
- usage "toupper(string)" if @_ != 1;
- uc($_[0]);
-}
-
-sub closedir {
- usage "closedir(dirhandle)" if @_ != 1;
- CORE::closedir($_[0]);
-}
-
-sub opendir {
- usage "opendir(directory)" if @_ != 1;
- my $dirhandle;
- CORE::opendir($dirhandle, $_[0])
- ? $dirhandle
- : undef;
-}
-
-sub readdir {
- usage "readdir(dirhandle)" if @_ != 1;
- CORE::readdir($_[0]);
-}
-
-sub rewinddir {
- usage "rewinddir(dirhandle)" if @_ != 1;
- CORE::rewinddir($_[0]);
-}
-
-sub errno {
- usage "errno()" if @_ != 0;
- $! + 0;
-}
-
-sub creat {
- usage "creat(filename, mode)" if @_ != 2;
- &open($_[0], &O_WRONLY | &O_CREAT | &O_TRUNC, $_[1]);
-}
-
-sub fcntl {
- usage "fcntl(filehandle, cmd, arg)" if @_ != 3;
- CORE::fcntl($_[0], $_[1], $_[2]);
-}
-
-sub getgrgid {
- usage "getgrgid(gid)" if @_ != 1;
- CORE::getgrgid($_[0]);
-}
-
-sub getgrnam {
- usage "getgrnam(name)" if @_ != 1;
- CORE::getgrnam($_[0]);
-}
-
-sub atan2 {
- usage "atan2(x,y)" if @_ != 2;
- CORE::atan2($_[0], $_[1]);
-}
-
-sub cos {
- usage "cos(x)" if @_ != 1;
- CORE::cos($_[0]);
-}
-
-sub exp {
- usage "exp(x)" if @_ != 1;
- CORE::exp($_[0]);
-}
-
-sub fabs {
- usage "fabs(x)" if @_ != 1;
- CORE::abs($_[0]);
-}
-
-sub log {
- usage "log(x)" if @_ != 1;
- CORE::log($_[0]);
-}
-
-sub pow {
- usage "pow(x,exponent)" if @_ != 2;
- $_[0] ** $_[1];
-}
-
-sub sin {
- usage "sin(x)" if @_ != 1;
- CORE::sin($_[0]);
-}
-
-sub sqrt {
- usage "sqrt(x)" if @_ != 1;
- CORE::sqrt($_[0]);
-}
-
-sub getpwnam {
- usage "getpwnam(name)" if @_ != 1;
- CORE::getpwnam($_[0]);
-}
-
-sub getpwuid {
- usage "getpwuid(uid)" if @_ != 1;
- CORE::getpwuid($_[0]);
-}
-
-sub longjmp {
- unimpl "longjmp() is C-specific: use die instead";
-}
-
-sub setjmp {
- unimpl "setjmp() is C-specific: use eval {} instead";
-}
-
-sub siglongjmp {
- unimpl "siglongjmp() is C-specific: use die instead";
-}
-
-sub sigsetjmp {
- unimpl "sigsetjmp() is C-specific: use eval {} instead";
-}
-
-sub kill {
- usage "kill(pid, sig)" if @_ != 2;
- CORE::kill $_[1], $_[0];
-}
-
-sub raise {
- usage "raise(sig)" if @_ != 1;
- CORE::kill $_[0], $$; # Is this good enough?
-}
-
-sub offsetof {
- unimpl "offsetof() is C-specific, stopped";
-}
-
-sub clearerr {
- redef "IO::Handle::clearerr()";
-}
-
-sub fclose {
- redef "IO::Handle::close()";
-}
-
-sub fdopen {
- redef "IO::Handle::new_from_fd()";
-}
-
-sub feof {
- redef "IO::Handle::eof()";
-}
-
-sub fgetc {
- redef "IO::Handle::getc()";
-}
-
-sub fgets {
- redef "IO::Handle::gets()";
-}
-
-sub fileno {
- redef "IO::Handle::fileno()";
-}
-
-sub fopen {
- redef "IO::File::open()";
-}
-
-sub fprintf {
- unimpl "fprintf() is C-specific--use printf instead";
-}
-
-sub fputc {
- unimpl "fputc() is C-specific--use print instead";
-}
-
-sub fputs {
- unimpl "fputs() is C-specific--use print instead";
-}
-
-sub fread {
- unimpl "fread() is C-specific--use read instead";
-}
-
-sub freopen {
- unimpl "freopen() is C-specific--use open instead";
-}
-
-sub fscanf {
- unimpl "fscanf() is C-specific--use <> and regular expressions instead";
-}
-
-sub fseek {
- redef "IO::Seekable::seek()";
-}
-
-sub fsync {
- redef "IO::Handle::sync()";
-}
-
-sub ferror {
- redef "IO::Handle::error()";
-}
-
-sub fflush {
- redef "IO::Handle::flush()";
-}
-
-sub fgetpos {
- redef "IO::Seekable::getpos()";
-}
-
-sub fsetpos {
- redef "IO::Seekable::setpos()";
-}
-
-sub ftell {
- redef "IO::Seekable::tell()";
-}
-
-sub fwrite {
- unimpl "fwrite() is C-specific--use print instead";
-}
-
-sub getc {
- usage "getc(handle)" if @_ != 1;
- CORE::getc($_[0]);
-}
-
-sub getchar {
- usage "getchar()" if @_ != 0;
- CORE::getc(STDIN);
-}
-
-sub gets {
- usage "gets()" if @_ != 0;
- scalar <STDIN>;
-}
-
sub perror {
print STDERR "@_: " if @_;
print STDERR $!,"\n";
@@ -345,413 +226,13 @@
CORE::printf STDOUT @_;
}
-sub putc {
- unimpl "putc() is C-specific--use print instead";
-}
-
-sub putchar {
- unimpl "putchar() is C-specific--use print instead";
-}
-
-sub puts {
- unimpl "puts() is C-specific--use print instead";
-}
-
-sub remove {
- usage "remove(filename)" if @_ != 1;
- (-d $_[0]) ? CORE::rmdir($_[0]) : CORE::unlink($_[0]);
-}
-
-sub rename {
- usage "rename(oldfilename, newfilename)" if @_ != 2;
- CORE::rename($_[0], $_[1]);
-}
-
-sub rewind {
- usage "rewind(filehandle)" if @_ != 1;
- CORE::seek($_[0],0,0);
-}
-
-sub scanf {
- unimpl "scanf() is C-specific--use <> and regular expressions instead";
-}
-
sub sprintf {
- usage "sprintf(pattern,args)" if @_ == 0;
+ usage "sprintf(pattern, args...)" if @_ == 0;
CORE::sprintf(shift, at _);
}
-sub sscanf {
- unimpl "sscanf() is C-specific--use regular expressions instead";
-}
-
-sub tmpfile {
- redef "IO::File::new_tmpfile()";
-}
-
-sub ungetc {
- redef "IO::Handle::ungetc()";
-}
-
-sub vfprintf {
- unimpl "vfprintf() is C-specific";
-}
-
-sub vprintf {
- unimpl "vprintf() is C-specific";
-}
-
-sub vsprintf {
- unimpl "vsprintf() is C-specific";
-}
-
-sub abs {
- usage "abs(x)" if @_ != 1;
- CORE::abs($_[0]);
-}
-
-sub atexit {
- unimpl "atexit() is C-specific: use END {} instead";
-}
-
-sub atof {
- unimpl "atof() is C-specific, stopped";
-}
-
-sub atoi {
- unimpl "atoi() is C-specific, stopped";
-}
-
-sub atol {
- unimpl "atol() is C-specific, stopped";
-}
-
-sub bsearch {
- unimpl "bsearch() not supplied";
-}
-
-sub calloc {
- unimpl "calloc() is C-specific, stopped";
-}
-
-sub div {
- unimpl "div() is C-specific, use /, % and int instead";
-}
-
-sub exit {
- usage "exit(status)" if @_ != 1;
- CORE::exit($_[0]);
-}
-
-sub free {
- unimpl "free() is C-specific, stopped";
-}
-
-sub getenv {
- usage "getenv(name)" if @_ != 1;
- $ENV{$_[0]};
-}
-
-sub labs {
- unimpl "labs() is C-specific, use abs instead";
-}
-
-sub ldiv {
- unimpl "ldiv() is C-specific, use /, % and int instead";
-}
-
-sub malloc {
- unimpl "malloc() is C-specific, stopped";
-}
-
-sub qsort {
- unimpl "qsort() is C-specific, use sort instead";
-}
-
-sub rand {
- unimpl "rand() is non-portable, use Perl's rand instead";
-}
-
-sub realloc {
- unimpl "realloc() is C-specific, stopped";
-}
-
-sub srand {
- unimpl "srand()";
-}
-
-sub system {
- usage "system(command)" if @_ != 1;
- CORE::system($_[0]);
-}
-
-sub memchr {
- unimpl "memchr() is C-specific, use index() instead";
-}
-
-sub memcmp {
- unimpl "memcmp() is C-specific, use eq instead";
-}
-
-sub memcpy {
- unimpl "memcpy() is C-specific, use = instead";
-}
-
-sub memmove {
- unimpl "memmove() is C-specific, use = instead";
-}
-
-sub memset {
- unimpl "memset() is C-specific, use x instead";
-}
-
-sub strcat {
- unimpl "strcat() is C-specific, use .= instead";
-}
-
-sub strchr {
- unimpl "strchr() is C-specific, use index() instead";
-}
-
-sub strcmp {
- unimpl "strcmp() is C-specific, use eq instead";
-}
-
-sub strcpy {
- unimpl "strcpy() is C-specific, use = instead";
-}
-
-sub strcspn {
- unimpl "strcspn() is C-specific, use regular expressions instead";
-}
-
-sub strerror {
- usage "strerror(errno)" if @_ != 1;
- local $! = $_[0];
- $! . "";
-}
-
-sub strlen {
- unimpl "strlen() is C-specific, use length instead";
-}
-
-sub strncat {
- unimpl "strncat() is C-specific, use .= instead";
-}
-
-sub strncmp {
- unimpl "strncmp() is C-specific, use eq instead";
-}
-
-sub strncpy {
- unimpl "strncpy() is C-specific, use = instead";
-}
-
-sub strpbrk {
- unimpl "strpbrk() is C-specific, stopped";
-}
-
-sub strrchr {
- unimpl "strrchr() is C-specific, use rindex() instead";
-}
-
-sub strspn {
- unimpl "strspn() is C-specific, stopped";
-}
-
-sub strstr {
- usage "strstr(big, little)" if @_ != 2;
- CORE::index($_[0], $_[1]);
-}
-
-sub strtok {
- unimpl "strtok() is C-specific, stopped";
-}
-
-sub chmod {
- usage "chmod(mode, filename)" if @_ != 2;
- CORE::chmod($_[0], $_[1]);
-}
-
-sub fstat {
- usage "fstat(fd)" if @_ != 1;
- local *TMP;
- CORE::open(TMP, "<&$_[0]"); # Gross.
- my @l = CORE::stat(TMP);
- CORE::close(TMP);
- @l;
-}
-
-sub mkdir {
- usage "mkdir(directoryname, mode)" if @_ != 2;
- CORE::mkdir($_[0], $_[1]);
-}
-
-sub stat {
- usage "stat(filename)" if @_ != 1;
- CORE::stat($_[0]);
-}
-
-sub umask {
- usage "umask(mask)" if @_ != 1;
- CORE::umask($_[0]);
-}
-
-sub wait {
- usage "wait()" if @_ != 0;
- CORE::wait();
-}
-
-sub waitpid {
- usage "waitpid(pid, options)" if @_ != 2;
- CORE::waitpid($_[0], $_[1]);
-}
-
-sub gmtime {
- usage "gmtime(time)" if @_ != 1;
- CORE::gmtime($_[0]);
-}
-
-sub localtime {
- usage "localtime(time)" if @_ != 1;
- CORE::localtime($_[0]);
-}
-
-sub time {
- usage "time()" if @_ != 0;
- CORE::time;
-}
-
-sub alarm {
- usage "alarm(seconds)" if @_ != 1;
- CORE::alarm($_[0]);
-}
-
-sub chdir {
- usage "chdir(directory)" if @_ != 1;
- CORE::chdir($_[0]);
-}
-
-sub chown {
- usage "chown(uid, gid, filename)" if @_ != 3;
- CORE::chown($_[0], $_[1], $_[2]);
-}
-
-sub execl {
- unimpl "execl() is C-specific, stopped";
-}
-
-sub execle {
- unimpl "execle() is C-specific, stopped";
-}
-
-sub execlp {
- unimpl "execlp() is C-specific, stopped";
-}
-
-sub execv {
- unimpl "execv() is C-specific, stopped";
-}
-
-sub execve {
- unimpl "execve() is C-specific, stopped";
-}
-
-sub execvp {
- unimpl "execvp() is C-specific, stopped";
-}
-
-sub fork {
- usage "fork()" if @_ != 0;
- CORE::fork;
-}
-
-sub getegid {
- usage "getegid()" if @_ != 0;
- $) + 0;
-}
-
-sub geteuid {
- usage "geteuid()" if @_ != 0;
- $> + 0;
-}
-
-sub getgid {
- usage "getgid()" if @_ != 0;
- $( + 0;
-}
-
-sub getgroups {
- usage "getgroups()" if @_ != 0;
- my %seen;
- grep(!$seen{$_}++, split(' ', $) ));
-}
-
-sub getlogin {
- usage "getlogin()" if @_ != 0;
- CORE::getlogin();
-}
-
-sub getpgrp {
- usage "getpgrp()" if @_ != 0;
- CORE::getpgrp;
-}
-
-sub getpid {
- usage "getpid()" if @_ != 0;
- $$;
-}
-
-sub getppid {
- usage "getppid()" if @_ != 0;
- CORE::getppid;
-}
-
-sub getuid {
- usage "getuid()" if @_ != 0;
- $<;
-}
-
-sub isatty {
- usage "isatty(filehandle)" if @_ != 1;
- -t $_[0];
-}
-
-sub link {
- usage "link(oldfilename, newfilename)" if @_ != 2;
- CORE::link($_[0], $_[1]);
-}
-
-sub rmdir {
- usage "rmdir(directoryname)" if @_ != 1;
- CORE::rmdir($_[0]);
-}
-
-sub setbuf {
- redef "IO::Handle::setbuf()";
-}
-
-sub setvbuf {
- redef "IO::Handle::setvbuf()";
-}
-
-sub sleep {
- usage "sleep(seconds)" if @_ != 1;
- $_[0] - CORE::sleep($_[0]);
-}
-
-sub unlink {
- usage "unlink(filename)" if @_ != 1;
- CORE::unlink($_[0]);
-}
-
-sub utime {
- usage "utime(filename, atime, mtime)" if @_ != 3;
- CORE::utime($_[1], $_[2], $_[0]);
-}
-
sub load_imports {
-%EXPORT_TAGS = (
+our %EXPORT_TAGS = (
assert_h => [qw(assert NDEBUG)],
@@ -898,7 +379,6 @@
setsid setuid sysconf tcgetpgrp tcsetpgrp ttyname)],
utime_h => [],
-
);
# Exporter::export_tags();
@@ -908,68 +388,13 @@
@export{map {@$_} values %EXPORT_TAGS} = ();
# Doing the de-dup with a temporary hash has the advantage that the SVs in
# @EXPORT are actually shared hash key scalars, which will save some memory.
- push @EXPORT, keys %export;
+ our @EXPORT = keys %export;
+
+ our @EXPORT_OK = (qw(close lchown nice open pipe read sleep times write
+ printf sprintf),
+ grep {!exists $export{$_}} keys %reimpl, keys %replacement);
}
- at EXPORT_OK = qw(
- abs
- alarm
- atan2
- chdir
- chmod
- chown
- close
- closedir
- cos
- exit
- exp
- fcntl
- fileno
- fork
- getc
- getgrgid
- getgrnam
- getlogin
- getpgrp
- getppid
- getpwnam
- getpwuid
- gmtime
- isatty
- kill
- lchown
- link
- localtime
- log
- mkdir
- nice
- open
- opendir
- pipe
- printf
- rand
- read
- readdir
- rename
- rewinddir
- rmdir
- sin
- sleep
- sprintf
- sqrt
- srand
- stat
- system
- time
- times
- umask
- unlink
- utime
- wait
- waitpid
- write
-);
-
require Exporter;
}
@@ -981,9 +406,24 @@
sub flags { $_[0]->{FLAGS} = $_[1] if @_ > 1; $_[0]->{FLAGS} };
sub safe { $_[0]->{SAFE} = $_[1] if @_ > 1; $_[0]->{SAFE} };
+{
+package POSIX::SigSet;
+# This package is here entirely to make sure that POSIX::SigSet is seen by the
+# PAUSE indexer, so that it will always be clearly indexed in core. This is to
+# prevent the accidental case where a third-party distribution can accidentally
+# claim the POSIX::SigSet package, as occurred in 2011-12. -- rjbs, 2011-12-30
+}
+
package POSIX::SigRt;
+require Tie::Hash;
+our @ISA = 'Tie::StdHash';
+
+our ($_SIGRTMIN, $_SIGRTMAX, $_sigrtn);
+
+our $SIGACTION_FLAGS = 0;
+
sub _init {
$_SIGRTMIN = &POSIX::SIGRTMIN;
$_SIGRTMAX = &POSIX::SIGRTMAX;
@@ -1020,9 +460,7 @@
sub new {
my ($rtsig, $handler, $flags) = @_;
my $sigset = POSIX::SigSet->new($rtsig);
- my $sigact = POSIX::SigAction->new($handler,
- $sigset,
- $flags);
+ my $sigact = POSIX::SigAction->new($handler, $sigset, $flags);
POSIX::sigaction($rtsig, $sigact);
}
@@ -1035,3 +473,6 @@
sub DELETE { delete $SIG{ &_check } }
sub CLEAR { &_exist; delete @SIG{ &POSIX::SIGRTMIN .. &POSIX::SIGRTMAX } }
sub SCALAR { &_croak; $_sigrtn + 1 }
+
+tie %POSIX::SIGRT, 'POSIX::SigRt';
+# and the expression on the line above is true, so we return true.
Property changes on: trunk/contrib/perl/ext/POSIX/lib/POSIX.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/ext/POSIX/lib/POSIX.pod
===================================================================
--- trunk/contrib/perl/ext/POSIX/lib/POSIX.pod 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/POSIX/lib/POSIX.pod 2013-12-02 21:32:26 UTC (rev 6445)
@@ -4,7 +4,7 @@
=head1 SYNOPSIS
- use POSIX;
+ use POSIX ();
use POSIX qw(setsid);
use POSIX qw(:errno_h :fcntl_h);
@@ -26,7 +26,9 @@
C<abs>, C<alarm>, C<rmdir>, C<write>, etc.., which will be exported
only if you ask for them explicitly. This is an unfortunate backwards
compatibility feature. You can stop the exporting by saying C<use
-POSIX ()> and then use the fully qualified names (ie. C<POSIX::SEEK_END>).
+POSIX ()> and then use the fully qualified names (ie. C<POSIX::SEEK_END>),
+or by giving an explicit import list. If you do neither, and opt for the
+default, C<use POSIX;> has to import I<553 symbols>.
This document gives a condensed list of the features available in the POSIX
module. Consult your operating system's manpages for general information on
@@ -39,13 +41,6 @@
constants and macros in an organization which roughly follows IEEE Std
1003.1b-1993.
-=head1 NOTE
-
-The POSIX module is probably the most complex Perl module supplied with
-the standard distribution. It incorporates autoloading, namespace games,
-and dynamic loading of code that's in Perl, C, or both. It's a great
-source of wisdom.
-
=head1 CAVEATS
A few functions are not implemented because they are C specific. If you
@@ -375,7 +370,7 @@
=item fgetpos
-Use method C<IO::Seekable::getpos()> instead, or see L<L/seek>.
+Use method C<IO::Seekable::getpos()> instead, or see L<perlfunc/seek>.
=item fgets
@@ -417,7 +412,7 @@
uses file descriptors such as those obtained by calling C<POSIX::open>.
The following will determine the maximum length of the longest allowable
-pathname on the filesystem which holds C</var/foo>.
+pathname on the filesystem which holds F</var/foo>.
$fd = POSIX::open( "/var/foo", &POSIX::O_RDONLY );
$path_max = POSIX::fpathconf( $fd, &POSIX::_PC_PATH_MAX );
@@ -735,27 +730,32 @@
Here is how to query the database for the B<de> (Deutsch or German) locale.
- $loc = POSIX::setlocale( &POSIX::LC_ALL, "de" );
- print "Locale = $loc\n";
- $lconv = POSIX::localeconv();
- print "decimal_point = ", $lconv->{decimal_point}, "\n";
- print "thousands_sep = ", $lconv->{thousands_sep}, "\n";
- print "grouping = ", $lconv->{grouping}, "\n";
- print "int_curr_symbol = ", $lconv->{int_curr_symbol}, "\n";
- print "currency_symbol = ", $lconv->{currency_symbol}, "\n";
- print "mon_decimal_point = ", $lconv->{mon_decimal_point}, "\n";
- print "mon_thousands_sep = ", $lconv->{mon_thousands_sep}, "\n";
- print "mon_grouping = ", $lconv->{mon_grouping}, "\n";
- print "positive_sign = ", $lconv->{positive_sign}, "\n";
- print "negative_sign = ", $lconv->{negative_sign}, "\n";
- print "int_frac_digits = ", $lconv->{int_frac_digits}, "\n";
- print "frac_digits = ", $lconv->{frac_digits}, "\n";
- print "p_cs_precedes = ", $lconv->{p_cs_precedes}, "\n";
- print "p_sep_by_space = ", $lconv->{p_sep_by_space}, "\n";
- print "n_cs_precedes = ", $lconv->{n_cs_precedes}, "\n";
- print "n_sep_by_space = ", $lconv->{n_sep_by_space}, "\n";
- print "p_sign_posn = ", $lconv->{p_sign_posn}, "\n";
- print "n_sign_posn = ", $lconv->{n_sign_posn}, "\n";
+ my $loc = POSIX::setlocale( &POSIX::LC_ALL, "de" );
+ print "Locale: \"$loc\"\n";
+ my $lconv = POSIX::localeconv();
+ foreach my $property (qw(
+ decimal_point
+ thousands_sep
+ grouping
+ int_curr_symbol
+ currency_symbol
+ mon_decimal_point
+ mon_thousands_sep
+ mon_grouping
+ positive_sign
+ negative_sign
+ int_frac_digits
+ frac_digits
+ p_cs_precedes
+ p_sep_by_space
+ n_cs_precedes
+ n_sep_by_space
+ p_sign_posn
+ n_sign_posn
+ ))
+ {
+ printf qq(%s: "%s",\n), $property, $lconv->{$property};
+ }
=item localtime
Property changes on: trunk/contrib/perl/ext/POSIX/lib/POSIX.pod
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Copied: trunk/contrib/perl/ext/POSIX/t/export.t (from rev 6437, vendor/perl/5.18.1/ext/POSIX/t/export.t)
===================================================================
--- trunk/contrib/perl/ext/POSIX/t/export.t (rev 0)
+++ trunk/contrib/perl/ext/POSIX/t/export.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -0,0 +1,116 @@
+#!./perl -w
+
+use strict;
+use Test::More;
+use Config;
+
+plan(skip_all => "POSIX is unavailable")
+ unless $Config{extensions} =~ /\bPOSIX\b/;
+
+require POSIX;
+POSIX->import();
+
+# @POSIX::EXPORT and @POSIX::EXPORT_OK are generated. The intent of this test is
+# to catch *unintended* changes to them introduced by bugs in refactoring.
+
+my %expect = (
+ EXPORT => [qw(%SIGRT ARG_MAX B0 B110 B1200 B134 B150 B1800 B19200 B200
+ B2400 B300 B38400 B4800 B50 B600 B75 B9600 BRKINT BUFSIZ
+ CHAR_BIT CHAR_MAX CHAR_MIN CHILD_MAX CLK_TCK CLOCAL
+ CLOCKS_PER_SEC CREAD CS5 CS6 CS7 CS8 CSIZE CSTOPB DBL_DIG
+ DBL_EPSILON DBL_MANT_DIG DBL_MAX DBL_MAX_10_EXP DBL_MAX_EXP
+ DBL_MIN DBL_MIN_10_EXP DBL_MIN_EXP E2BIG EACCES EADDRINUSE
+ EADDRNOTAVAIL EAFNOSUPPORT EAGAIN EALREADY EBADF EBUSY ECHILD
+ ECHO ECHOE ECHOK ECHONL ECONNABORTED ECONNREFUSED ECONNRESET
+ EDEADLK EDESTADDRREQ EDOM EDQUOT EEXIST EFAULT EFBIG
+ EHOSTDOWN EHOSTUNREACH EINPROGRESS EINTR EINVAL EIO EISCONN
+ EISDIR ELOOP EMFILE EMLINK EMSGSIZE ENAMETOOLONG ENETDOWN
+ ENETRESET ENETUNREACH ENFILE ENOBUFS ENODEV ENOENT ENOEXEC
+ ENOLCK ENOMEM ENOPROTOOPT ENOSPC ENOSYS ENOTBLK ENOTCONN
+ ENOTDIR ENOTEMPTY ENOTSOCK ENOTTY ENXIO EOF EOPNOTSUPP EPERM
+ EPFNOSUPPORT EPIPE EPROCLIM EPROTONOSUPPORT EPROTOTYPE ERANGE
+ EREMOTE ERESTART EROFS ESHUTDOWN ESOCKTNOSUPPORT ESPIPE ESRCH
+ ESTALE ETIMEDOUT ETOOMANYREFS ETXTBSY EUSERS EWOULDBLOCK
+ EXDEV EXIT_FAILURE EXIT_SUCCESS FD_CLOEXEC FILENAME_MAX
+ FLT_DIG FLT_EPSILON FLT_MANT_DIG FLT_MAX FLT_MAX_10_EXP
+ FLT_MAX_EXP FLT_MIN FLT_MIN_10_EXP FLT_MIN_EXP FLT_RADIX
+ FLT_ROUNDS F_DUPFD F_GETFD F_GETFL F_GETLK F_OK F_RDLCK
+ F_SETFD F_SETFL F_SETLK F_SETLKW F_UNLCK F_WRLCK HUGE_VAL
+ HUPCL ICANON ICRNL IEXTEN IGNBRK IGNCR IGNPAR INLCR INPCK
+ INT_MAX INT_MIN ISIG ISTRIP IXOFF IXON LC_ALL LC_COLLATE
+ LC_CTYPE LC_MESSAGES LC_MONETARY LC_NUMERIC LC_TIME LDBL_DIG
+ LDBL_EPSILON LDBL_MANT_DIG LDBL_MAX LDBL_MAX_10_EXP
+ LDBL_MAX_EXP LDBL_MIN LDBL_MIN_10_EXP LDBL_MIN_EXP LINK_MAX
+ LONG_MAX LONG_MIN L_ctermid L_cuserid L_tmpname MAX_CANON
+ MAX_INPUT MB_CUR_MAX MB_LEN_MAX NAME_MAX NCCS NDEBUG
+ NGROUPS_MAX NOFLSH NULL OPEN_MAX OPOST O_ACCMODE O_APPEND
+ O_CREAT O_EXCL O_NOCTTY O_NONBLOCK O_RDONLY O_RDWR O_TRUNC
+ O_WRONLY PARENB PARMRK PARODD PATH_MAX PIPE_BUF RAND_MAX R_OK
+ SA_NOCLDSTOP SA_NOCLDWAIT SA_NODEFER SA_ONSTACK SA_RESETHAND
+ SA_RESTART SA_SIGINFO SCHAR_MAX SCHAR_MIN SEEK_CUR SEEK_END
+ SEEK_SET SHRT_MAX SHRT_MIN SIGABRT SIGALRM SIGBUS SIGCHLD
+ SIGCONT SIGFPE SIGHUP SIGILL SIGINT SIGKILL SIGPIPE SIGPOLL
+ SIGPROF SIGQUIT SIGRTMAX SIGRTMIN SIGSEGV SIGSTOP SIGSYS
+ SIGTERM SIGTRAP SIGTSTP SIGTTIN SIGTTOU SIGURG SIGUSR1
+ SIGUSR2 SIGVTALRM SIGXCPU SIGXFSZ SIG_BLOCK SIG_DFL SIG_ERR
+ SIG_IGN SIG_SETMASK SIG_UNBLOCK SSIZE_MAX STDERR_FILENO
+ STDIN_FILENO STDOUT_FILENO STREAM_MAX S_IRGRP S_IROTH S_IRUSR
+ S_IRWXG S_IRWXO S_IRWXU S_ISBLK S_ISCHR S_ISDIR S_ISFIFO
+ S_ISGID S_ISREG S_ISUID S_IWGRP S_IWOTH S_IWUSR S_IXGRP
+ S_IXOTH S_IXUSR TCIFLUSH TCIOFF TCIOFLUSH TCION TCOFLUSH
+ TCOOFF TCOON TCSADRAIN TCSAFLUSH TCSANOW TMP_MAX TOSTOP
+ TZNAME_MAX UCHAR_MAX UINT_MAX ULONG_MAX USHRT_MAX VEOF VEOL
+ VERASE VINTR VKILL VMIN VQUIT VSTART VSTOP VSUSP VTIME
+ WEXITSTATUS WIFEXITED WIFSIGNALED WIFSTOPPED WNOHANG WSTOPSIG
+ WTERMSIG WUNTRACED W_OK X_OK _PC_CHOWN_RESTRICTED
+ _PC_LINK_MAX _PC_MAX_CANON _PC_MAX_INPUT _PC_NAME_MAX
+ _PC_NO_TRUNC _PC_PATH_MAX _PC_PIPE_BUF _PC_VDISABLE
+ _POSIX_ARG_MAX _POSIX_CHILD_MAX _POSIX_CHOWN_RESTRICTED
+ _POSIX_JOB_CONTROL _POSIX_LINK_MAX _POSIX_MAX_CANON
+ _POSIX_MAX_INPUT _POSIX_NAME_MAX _POSIX_NGROUPS_MAX
+ _POSIX_NO_TRUNC _POSIX_OPEN_MAX _POSIX_PATH_MAX
+ _POSIX_PIPE_BUF _POSIX_SAVED_IDS _POSIX_SSIZE_MAX
+ _POSIX_STREAM_MAX _POSIX_TZNAME_MAX _POSIX_VDISABLE
+ _POSIX_VERSION _SC_ARG_MAX _SC_CHILD_MAX _SC_CLK_TCK
+ _SC_JOB_CONTROL _SC_NGROUPS_MAX _SC_OPEN_MAX _SC_PAGESIZE
+ _SC_SAVED_IDS _SC_STREAM_MAX _SC_TZNAME_MAX _SC_VERSION _exit
+ abort access acos asctime asin assert atan atexit atof atoi
+ atol bsearch calloc ceil cfgetispeed cfgetospeed cfsetispeed
+ cfsetospeed clearerr clock cosh creat ctermid ctime cuserid
+ difftime div dup dup2 errno execl execle execlp execv execve
+ execvp fabs fclose fdopen feof ferror fflush fgetc fgetpos
+ fgets floor fmod fopen fpathconf fprintf fputc fputs fread
+ free freopen frexp fscanf fseek fsetpos fstat fsync ftell
+ fwrite getchar getcwd getegid getenv geteuid getgid getgroups
+ getpid gets getuid isalnum isalpha isatty iscntrl isdigit
+ isgraph islower isprint ispunct isspace isupper isxdigit labs
+ ldexp ldiv localeconv log10 longjmp lseek malloc mblen
+ mbstowcs mbtowc memchr memcmp memcpy memmove memset mkfifo
+ mktime modf offsetof pathconf pause perror pow putc putchar
+ puts qsort raise realloc remove rewind scanf setbuf setgid
+ setjmp setlocale setpgid setsid setuid setvbuf sigaction
+ siglongjmp signal sigpending sigprocmask sigsetjmp sigsuspend
+ sinh sscanf stderr stdin stdout strcat strchr strcmp strcoll
+ strcpy strcspn strerror strftime strlen strncat strncmp
+ strncpy strpbrk strrchr strspn strstr strtod strtok strtol
+ strtoul strxfrm sysconf tan tanh tcdrain tcflow tcflush
+ tcgetattr tcgetpgrp tcsendbreak tcsetattr tcsetpgrp tmpfile
+ tmpnam tolower toupper ttyname tzname tzset uname ungetc
+ vfprintf vprintf vsprintf wcstombs wctomb)],
+ EXPORT_OK => [qw(abs alarm atan2 chdir chmod chown close closedir cos exit
+ exp fcntl fileno fork getc getgrgid getgrnam getlogin
+ getpgrp getppid getpwnam getpwuid gmtime kill lchown link
+ localtime log mkdir nice open opendir pipe printf rand
+ read readdir rename rewinddir rmdir sin sleep sprintf sqrt
+ srand stat system time times umask unlink utime wait
+ waitpid write)],
+);
+
+plan (tests => 2 * keys %expect);
+
+while (my ($var, $expect) = each %expect) {
+ my $have = *{$POSIX::{$var}}{ARRAY};
+ cmp_ok(@$have, '==', @$expect,
+ "Correct number of entries for \@POSIX::$var");
+ is_deeply([sort @$have], $expect, "Correct entries for \@POSIX::$var");
+}
Modified: trunk/contrib/perl/ext/POSIX/t/is.t
===================================================================
--- trunk/contrib/perl/ext/POSIX/t/is.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/POSIX/t/is.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -1,15 +1,16 @@
#!./perl -w
+use strict;
+use Test::More;
+use Config;
+
BEGIN {
- require Config; import Config;
- if ($^O ne 'VMS' and $Config{'extensions'} !~ /\bPOSIX\b/) {
- print "1..0\n";
- exit 0;
- }
+ plan(skip_all => "\$^O eq '$^O'") if $^O eq 'VMS';
+ plan(skip_all => "POSIX is unavailable")
+ unless $Config{extensions} =~ /\bPOSIX\b/;
}
use POSIX;
-use strict ;
# E.g. \t might or might not be isprint() depending on the locale,
# so let's reset to the default.
@@ -70,11 +71,8 @@
# Expected number of tests is one each for every combination of a
# known is<xxx> function and string listed above.
-use Test::More;
plan(tests => keys(%classes) * keys(%functions));
-
-#
# Main test loop: Run all POSIX::is<xxx> tests on each string defined above.
# Only the character classes listed for that string should return 1. We
# always run all functions on every string, and expect to get 0 for the
@@ -85,6 +83,6 @@
my $expected = exists $classes{$s}->{$f};
my $actual = eval "POSIX::$f( \$s )";
- ok( $actual == $expected, "$f('$s') == $actual");
+ cmp_ok($actual, '==', $expected, "$f('$s')");
}
}
Property changes on: trunk/contrib/perl/ext/POSIX/t/is.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/ext/POSIX/t/math.t
===================================================================
--- trunk/contrib/perl/ext/POSIX/t/math.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/POSIX/t/math.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -3,17 +3,37 @@
use strict;
use POSIX;
-use Test::More tests => 14;
+use Test::More;
# These tests are mainly to make sure that these arithmetic functions
# exist and are accessible. They are not meant to be an exhaustive
# test for the interface.
+sub between {
+ my ($low, $have, $high, $desc) = @_;
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+
+ cmp_ok($have, '>=', $low, $desc);
+ cmp_ok($have, '<=', $high, $desc);
+}
+
is(acos(1), 0, "Basic acos(1) test");
+between(3.14, acos(-1), 3.15, 'acos(-1)');
+between(1.57, acos(0), 1.58, 'acos(0)');
is(asin(0), 0, "Basic asin(0) test");
+cmp_ok(asin(1), '>', 1.57, "Basic asin(1) test");
+cmp_ok(asin(-1), '<', -1.57, "Basic asin(-1) test");
+cmp_ok(asin(1), '==', -asin(-1), 'asin(1) == -asin(-1)');
is(atan(0), 0, "Basic atan(0) test");
+between(0.785, atan(1), 0.786, 'atan(1)');
+between(-0.786, atan(-1), -0.785, 'atan(-1)');
+cmp_ok(atan(1), '==', -atan(-1), 'atan(1) == -atan(-1)');
is(cosh(0), 1, "Basic cosh(0) test");
+between(1.54, cosh(1), 1.55, 'cosh(1)');
+between(1.54, cosh(-1), 1.55, 'cosh(-1)');
+is(cosh(1), cosh(-1), 'cosh(1) == cosh(-1)');
is(floor(1.23441242), 1, "Basic floor(1.23441242) test");
+is(floor(-1.23441242), -2, "Basic floor(-1.23441242) test");
is(fmod(3.5, 2.0), 1.5, "Basic fmod(3.5, 2.0) test");
is(join(" ", frexp(1)), "0.5 1", "Basic frexp(1) test");
is(ldexp(0,1), 0, "Basic ldexp(0,1) test");
@@ -21,5 +41,15 @@
is(log10(10), 1, "Basic log10(10) test");
is(join(" ", modf(1.76)), "0.76 1", "Basic modf(1.76) test");
is(sinh(0), 0, "Basic sinh(0) test");
+between(1.17, sinh(1), 1.18, 'sinh(1)');
+between(-1.18, sinh(-1), -1.17, 'sinh(-1)');
is(tan(0), 0, "Basic tan(0) test");
+between(1.55, tan(1), 1.56, 'tan(1)');
+between(1.55, tan(1), 1.56, 'tan(-1)');
+cmp_ok(tan(1), '==', -tan(-1), 'tan(1) == -tan(-1)');
is(tanh(0), 0, "Basic tanh(0) test");
+between(0.76, tanh(1), 0.77, 'tanh(1)');
+between(-0.77, tanh(-1), -0.76, 'tanh(-1)');
+cmp_ok(tanh(1), '==', -tanh(-1), 'tanh(1) == -tanh(-1)');
+
+done_testing();
Property changes on: trunk/contrib/perl/ext/POSIX/t/math.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/ext/POSIX/t/posix.t
===================================================================
--- trunk/contrib/perl/ext/POSIX/t/posix.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/POSIX/t/posix.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -8,10 +8,10 @@
}
}
-use Test::More tests => 66;
+use Test::More tests => 109;
use POSIX qw(fcntl_h signal_h limits_h _exit getcwd open read strftime write
- errno);
+ errno localeconv dup dup2 lseek access);
use strict 'subs';
sub next_test {
@@ -23,7 +23,6 @@
$Is_W32 = $^O eq 'MSWin32';
$Is_Dos = $^O eq 'dos';
-$Is_MPE = $^O eq 'mpeix';
$Is_MacOS = $^O eq 'MacOS';
$Is_VMS = $^O eq 'VMS';
$Is_OS2 = $^O eq 'os2';
@@ -51,8 +50,8 @@
}
-
-ok( $testfd = open("Makefile.PL", O_RDONLY, 0), 'O_RDONLY with open' );
+my $testfd = open("Makefile.PL", O_RDONLY, 0);
+like($testfd, qr/\A\d+\z/, 'O_RDONLY with open');
read($testfd, $buffer, 4) if $testfd > 2;
is( $buffer, "# Ex", ' with read' );
@@ -64,22 +63,22 @@
is( $buffer[1], "perl\n", ' read to array element' );
}
-write(1,"ok 4\nnot ok 4\n", 5);
-next_test();
+my $test = next_test();
+write(1,"ok $test\nnot ok $test\n", 5);
SKIP: {
skip("no pipe() support on DOS", 2) if $Is_Dos;
@fds = POSIX::pipe();
- ok( $fds[0] > $testfd, 'POSIX::pipe' );
+ cmp_ok($fds[0], '>', $testfd, 'POSIX::pipe');
CORE::open($reader = \*READER, "<&=".$fds[0]);
CORE::open($writer = \*WRITER, ">&=".$fds[1]);
- print $writer "ok 6\n";
+ my $test = next_test();
+ print $writer "ok $test\n";
close $writer;
print <$reader>;
close $reader;
- next_test();
}
SKIP: {
@@ -105,6 +104,7 @@
# So the kill() must not be done with this config in order to
# finish the test.
# For others (darwin & freebsd), let the test fail without crashing.
+ # the test passes at least from freebsd 8.1
my $todo = $^O eq 'netbsd' && $Config{osvers}=~/^1\.6/;
my $why_todo = "# TODO $^O $Config{osvers} seems to lose blocked signals";
if (!$todo) {
@@ -115,8 +115,8 @@
}
sleep 1;
- $todo = 1 if ($^O eq 'freebsd')
- || ($^O eq 'darwin' && $Config{osvers} lt '6.6');
+ $todo = 1 if ($^O eq 'freebsd' && $Config{osvers} < 8)
+ || ($^O eq 'darwin' && $Config{osvers} < '6.6');
printf "%s 11 - masked SIGINT received %s\n",
$sigint_called ? "ok" : "not ok",
$todo ? $why_todo : '';
@@ -141,10 +141,10 @@
}
SKIP: {
- skip("_POSIX_OPEN_MAX is inaccurate on MPE", 1) if $Is_MPE;
skip("_POSIX_OPEN_MAX undefined ($fds[1])", 1) unless &_POSIX_OPEN_MAX;
- ok( &_POSIX_OPEN_MAX >= 16, "The minimum allowed values according to susv2" );
+ cmp_ok(&_POSIX_OPEN_MAX, '>=', 16,
+ "The minimum allowed values according to susv2" );
}
@@ -160,13 +160,14 @@
# Check string conversion functions.
SKIP: {
- skip("strtod() not present", 1) unless $Config{d_strtod};
+ skip("strtod() not present", 2) unless $Config{d_strtod};
$lc = &POSIX::setlocale(&POSIX::LC_NUMERIC, 'C') if $Config{d_setlocale};
# we're just checking that strtod works, not how accurate it is
($n, $x) = &POSIX::strtod('3.14159_OR_SO');
- ok((abs("3.14159" - $n) < 1e-6) && ($x == 6), 'strtod works');
+ cmp_ok(abs("3.14159" - $n), '<', 1e-6, 'strtod works');
+ is($x, 6, 'strtod works');
&POSIX::setlocale(&POSIX::LC_NUMERIC, $lc) if $Config{d_setlocale};
}
@@ -188,14 +189,14 @@
}
# Pick up whether we're really able to dynamically load everything.
-ok( &POSIX::acos(1.0) == 0.0, 'dynamic loading' );
+cmp_ok(&POSIX::acos(1.0), '==', 0.0, 'dynamic loading');
# This can coredump if struct tm has a timezone field and we
# didn't detect it. If this fails, try adding
# -DSTRUCT_TM_HASZONE to your cflags when compiling ext/POSIX/POSIX.c.
# See ext/POSIX/hints/sunos_4.pl and ext/POSIX/hints/linux.pl
-print POSIX::strftime("ok 21 # %H:%M, on %m/%d/%y\n", localtime());
-next_test();
+$test = next_test();
+print POSIX::strftime("ok $test # %H:%M, on %m/%d/%y\n", localtime());
# If that worked, validate the mini_mktime() routine's normalisation of
# input fields to strftime().
@@ -222,6 +223,21 @@
try_strftime("Tue Feb 29 00:00:00 2000 060", 0,0,0, 0,2,100);
try_strftime("Wed Mar 01 00:00:00 2000 061", 0,0,0, 1,2,100);
try_strftime("Fri Mar 31 00:00:00 2000 091", 0,0,0, 31,2,100);
+
+{ # rt 72232
+
+ # Std C/POSIX allows day/month to be negative and requires that
+ # wday/yday be adjusted as needed
+ # previously mini_mktime() would allow yday to dominate if mday and
+ # month were both non-positive
+ # check that yday doesn't dominate
+ try_strftime("Thu Dec 30 00:00:00 1999 364", 0,0,0, -1,0,100);
+ try_strftime("Thu Dec 30 00:00:00 1999 364", 0,0,0, -1,0,100,-1,10);
+ # it would also allow a positive wday to override the calculated value
+ # check that wday is recalculated too
+ try_strftime("Thu Dec 30 00:00:00 1999 364", 0,0,0, -1,0,100,0,10);
+}
+
&POSIX::setlocale(&POSIX::LC_TIME, $lc) if $Config{d_setlocale};
{
@@ -297,7 +313,81 @@
eval { use strict; POSIX->import("S_ISBLK"); my $x = S_ISBLK };
unlike( $@, qr/Can't use string .* as a symbol ref/, "Can import autoloaded constants" );
-
+
+SKIP: {
+ skip("localeconv() not present", 20) unless $Config{d_locconv};
+ my $conv = localeconv;
+ is(ref $conv, 'HASH', 'localconv returns a hash reference');
+
+ foreach (qw(decimal_point thousands_sep grouping int_curr_symbol
+ currency_symbol mon_decimal_point mon_thousands_sep
+ mon_grouping positive_sign negative_sign)) {
+ SKIP: {
+ skip("localeconv has no result for $_", 1)
+ unless exists $conv->{$_};
+ unlike(delete $conv->{$_}, qr/\A\z/,
+ "localeconv returned a non-empty string for $_");
+ }
+ }
+
+ foreach (qw(int_frac_digits frac_digits p_cs_precedes p_sep_by_space
+ n_cs_precedes n_sep_by_space p_sign_posn n_sign_posn)) {
+ SKIP: {
+ skip("localeconv has no result for $_", 1)
+ unless exists $conv->{$_};
+ like(delete $conv->{$_}, qr/\A-?\d+\z/,
+ "localeconv returned an integer for $_");
+ }
+ }
+ is_deeply([%$conv], [], 'no unexpected keys returned by localeconv');
+}
+
+my $fd1 = open("Makefile.PL", O_RDONLY, 0);
+like($fd1, qr/\A\d+\z/, 'O_RDONLY with open');
+cmp_ok($fd1, '>', $testfd);
+my $fd2 = dup($fd1);
+like($fd2, qr/\A\d+\z/, 'dup');
+cmp_ok($fd2, '>', $fd1);
+is(POSIX::close($fd1), '0 but true', 'close');
+is(POSIX::close($testfd), '0 but true', 'close');
+$! = 0;
+undef $buffer;
+is(read($fd1, $buffer, 4), undef, 'read on closed file handle fails');
+cmp_ok($!, '==', POSIX::EBADF);
+undef $buffer;
+read($fd2, $buffer, 4) if $fd2 > 2;
+is($buffer, "# Ex", 'read');
+# The descriptor $testfd was using is now free, and is lower than that which
+# $fd1 was using. Hence if dup2() behaves as dup(), we'll know :-)
+{
+ $testfd = dup2($fd2, $fd1);
+ is($testfd, $fd1, 'dup2');
+ undef $buffer;
+ read($testfd, $buffer, 4) if $testfd > 2;
+ is($buffer, 'pect', 'read');
+ is(lseek($testfd, 0, 0), 0, 'lseek back');
+ # The two should share file position:
+ undef $buffer;
+ read($fd2, $buffer, 4) if $fd2 > 2;
+ is($buffer, "# Ex", 'read');
+}
+
+# The FreeBSD man page warns:
+# The access() system call is a potential security hole due to race
+# conditions and should never be used.
+is(access('Makefile.PL', POSIX::F_OK), '0 but true', 'access');
+is(access('Makefile.PL', POSIX::R_OK), '0 but true', 'access');
+$! = 0;
+is(access('no such file', POSIX::F_OK), undef, 'access on missing file');
+cmp_ok($!, '==', POSIX::ENOENT);
+is(access('Makefile.PL/nonsense', POSIX::F_OK), undef,
+ 'access on not-a-directory');
+SKIP: {
+ skip("$^O is insufficiently POSIX", 1)
+ if $Is_W32 || $Is_VMS;
+ cmp_ok($!, '==', POSIX::ENOTDIR);
+}
+
# Check that output is not flushed by _exit. This test should be last
# in the file, and is not counted in the total number of tests.
if ($^O eq 'vos') {
Property changes on: trunk/contrib/perl/ext/POSIX/t/posix.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/ext/POSIX/t/sigaction.t
===================================================================
--- trunk/contrib/perl/ext/POSIX/t/sigaction.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/POSIX/t/sigaction.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -11,7 +11,7 @@
}
}
-use Test::More tests => 32;
+use Test::More tests => 33;
use strict;
use vars qw/$bad $bad7 $ok10 $bad18 $ok/;
@@ -19,15 +19,15 @@
$^W=1;
sub IGNORE {
- $bad7=1;
+ ++$bad7;
}
sub DEFAULT {
- $bad18=1;
+ ++$bad18;
}
sub foo {
- $ok=1;
+ ++$ok;
}
my $newaction=POSIX::SigAction->new('::foo', new POSIX::SigSet(SIGUSR1), 0);
@@ -37,11 +37,10 @@
my $bad;
local($SIG{__WARN__})=sub { $bad=1; };
sigaction(SIGHUP, $newaction, $oldaction);
- ok(!$bad, "no warnings");
+ is($bad, undef, "no warnings");
}
-ok($oldaction->{HANDLER} eq 'DEFAULT' ||
- $oldaction->{HANDLER} eq 'IGNORE', $oldaction->{HANDLER});
+like($oldaction->{HANDLER}, qr/\A(?:DEFAULT|IGNORE)\z/, '$oldaction->{HANDLER}');
is($SIG{HUP}, '::foo');
@@ -59,19 +58,19 @@
$newaction=POSIX::SigAction->new('IGNORE');
sigaction(SIGHUP, $newaction);
kill 'HUP', $$;
-ok(!$bad, "SIGHUP ignored");
+is($bad, undef, "SIGHUP ignored");
is($SIG{HUP}, 'IGNORE');
sigaction(SIGHUP, POSIX::SigAction->new('DEFAULT'));
is($SIG{HUP}, 'DEFAULT');
-$newaction=POSIX::SigAction->new(sub { $ok10=1; });
+$newaction=POSIX::SigAction->new(sub { ++$ok10; });
sigaction(SIGHUP, $newaction);
{
local($^W)=0;
kill 'HUP', $$;
}
-ok($ok10, "SIGHUP handler called");
+is($ok10, 1, "SIGHUP handler called");
is(ref($SIG{HUP}), 'CODE');
@@ -83,13 +82,14 @@
sigaction(SIGINT, $act);
};
kill 'HUP', $$;
-ok($ok, "signal mask gets restored after croak");
+is($ok, 1, "signal mask gets restored after croak");
undef $ok;
# Make sure the signal mask gets restored after sigaction returns early.
my $x=defined sigaction(SIGKILL, $newaction, $oldaction);
kill 'HUP', $$;
-ok(!$x && $ok, "signal mask gets restored after early return");
+is($x, '', "signal mask gets restored after early return");
+is($ok, 1, "signal mask gets restored after early return");
$SIG{HUP}=sub {};
sigaction(SIGHUP, $newaction, $oldaction);
@@ -98,22 +98,23 @@
eval {
sigaction(SIGHUP, undef, $oldaction);
};
-ok(!$@, "undef for new action");
+is($@, '', "undef for new action");
eval {
sigaction(SIGHUP, 0, $oldaction);
};
-ok(!$@, "zero for new action");
+is($@, '', "zero for new action");
eval {
sigaction(SIGHUP, bless({},'Class'), $oldaction);
};
-ok($@, "any object not good as new action");
+like($@, qr/\Aaction is not of type POSIX::SigAction/,
+ 'any object not good as new action');
SKIP: {
skip("SIGCONT not trappable in $^O", 1)
if ($^O eq 'VMS');
- $newaction=POSIX::SigAction->new(sub { $ok10=1; });
+ $newaction=POSIX::SigAction->new(sub { ++$ok10; });
if (eval { SIGCONT; 1 }) {
sigaction(SIGCONT, POSIX::SigAction->new('DEFAULT'));
{
@@ -121,7 +122,7 @@
kill 'CONT', $$;
}
}
- ok(!$bad18, "SIGCONT trappable");
+ is($bad18, undef, "SIGCONT trappable");
}
{
@@ -134,7 +135,7 @@
sub hup21 { $hup21++ }
sigaction("FOOBAR", $newaction);
- ok(1, "no coredump, still alive");
+ pass("no coredump, still alive");
$newaction = POSIX::SigAction->new("hup20");
sigaction("SIGHUP", $newaction);
@@ -171,7 +172,7 @@
# And safe signal delivery must work
$ok = 0;
kill 'HUP', $$;
-ok($ok, "safe signal delivery must work");
+is($ok, 1, "safe signal delivery must work");
SKIP: {
eval 'use POSIX qw(%SIGRT SIGRTMIN SIGRTMAX); scalar %SIGRT + SIGRTMIN() + SIGRTMAX()';
@@ -179,7 +180,7 @@
|| SIGRTMIN() < 0 || SIGRTMAX() < 0 # HP-UX 10.20 exports both as -1
|| SIGRTMIN() > $Config{sig_count} # AIX 4.3.3 exports bogus 888 and 999
and skip("no SIGRT signals", 4);
- ok(SIGRTMAX() > SIGRTMIN(), "SIGRTMAX > SIGRTMIN");
+ cmp_ok(SIGRTMAX(), '>', SIGRTMIN(), "SIGRTMAX > SIGRTMIN");
is(scalar %SIGRT, SIGRTMAX() - SIGRTMIN() + 1, "scalar SIGRT");
my $sigrtmin;
my $h = sub { $sigrtmin = 1 };
Property changes on: trunk/contrib/perl/ext/POSIX/t/sigaction.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Copied: trunk/contrib/perl/ext/POSIX/t/sigset.t (from rev 6437, vendor/perl/5.18.1/ext/POSIX/t/sigset.t)
===================================================================
--- trunk/contrib/perl/ext/POSIX/t/sigset.t (rev 0)
+++ trunk/contrib/perl/ext/POSIX/t/sigset.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -0,0 +1,96 @@
+#!./perl -w
+
+use strict;
+use Test::More;
+use Config;
+
+plan(skip_all => "POSIX is unavailable")
+ unless $Config{extensions} =~ /\bPOSIX\b/;
+plan(skip_all => "sigemptyset is unavailable on $^O")
+ if $^O eq 'MSWin32' || $^O eq 'NetWare';
+
+require POSIX;
+POSIX->import();
+
+my @signo;
+my ($min, $max) = (~0, -1);
+
+sub expected_signals {
+ my $sigset = shift;
+ my $desc = shift;
+ my %expected;
+ ++$expected{$_} foreach @_;
+
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+
+ for my $sig ($min..$max) {
+ if ($expected{$sig}) {
+ cmp_ok($sigset->ismember($sig), '==', 1,
+ "$desc - sig $sig is a member");
+ } else {
+ cmp_ok($sigset->ismember($sig), '==', 0,
+ "$desc - sig $sig is not a member");
+ }
+ }
+}
+
+foreach (@POSIX::EXPORT) {
+ next unless /^SIG[A-Z0-9]+$/;
+ my $val = eval "POSIX::$_";
+ next unless defined $val;
+ $min = $val if $min > $val;
+ $max = $val if $max < $val;
+ push @signo, $val;
+}
+
+# Sanity check that we found something:
+cmp_ok(scalar @signo, '>=', 6,
+ 'found at least 6 signals (6 are named in the ANSI C spec)');
+
+my $sigset = POSIX::SigSet->new();
+isa_ok($sigset, 'POSIX::SigSet', 'checking the type of the object');
+expected_signals($sigset, 'new object');
+
+is($sigset->fillset(), '0 but true', 'fillset');
+# because on some systems, not all integers are valid signals...
+# so the only thing we can really be confident about is that all the signals
+# with names are going to be present:
+foreach (@signo) {
+ cmp_ok($sigset->ismember($_), '==', 1, "after fillset sig $_ is a member");
+}
+is($sigset->emptyset(), '0 but true', 'empyset');
+expected_signals($sigset, 'after emptyset');
+
+is($sigset->addset($signo[1]), '0 but true', 'addset');
+expected_signals($sigset, 'after addset', $signo[1]);
+is($sigset->addset($signo[2]), '0 but true', 'addset');
+expected_signals($sigset, 'after addset', $signo[1], $signo[2]);
+is($sigset->addset($signo[4]), '0 but true', 'addset');
+expected_signals($sigset, 'after addset', $signo[1], $signo[2], $signo[4]);
+is($sigset->addset($signo[2]), '0 but true', 'addset');
+expected_signals($sigset, 'after addset', $signo[1], $signo[2], $signo[4]);
+is($sigset->delset($signo[4]), '0 but true', 'delset');
+expected_signals($sigset, 'after addset', $signo[1], $signo[2]);
+is($sigset->addset($signo[0]), '0 but true', 'addset');
+expected_signals($sigset, 'after addset', $signo[0], $signo[1], $signo[2]);
+is($sigset->delset($signo[4]), '0 but true', 'delset');
+expected_signals($sigset, 'after delset', $signo[0], $signo[1], $signo[2]);
+is($sigset->delset($signo[1]), '0 but true', 'delset');
+expected_signals($sigset, 'after delset', $signo[0], $signo[2]);
+is($sigset->delset($signo[0]), '0 but true', 'delset');
+expected_signals($sigset, 'after addset', $signo[2]);
+is($sigset->delset($signo[2]), '0 but true', 'delset');
+expected_signals($sigset, 'empty again');
+
+foreach ([$signo[0]],
+ [$signo[2]],
+ [$signo[3]],
+ [@signo[2,3,6]],
+ ) {
+ $sigset = POSIX::SigSet->new(@$_);
+ isa_ok($sigset, 'POSIX::SigSet', 'checking the type of the object');
+ local $" = ', ';
+ expected_signals($sigset, "new(@$_)", @$_);
+}
+
+done_testing();
Modified: trunk/contrib/perl/ext/POSIX/t/sysconf.t
===================================================================
--- trunk/contrib/perl/ext/POSIX/t/sysconf.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/POSIX/t/sysconf.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -9,7 +9,6 @@
use strict;
use File::Spec;
use POSIX;
-use Scalar::Util qw(looks_like_number);
sub check(@) {
grep { eval "&$_;1" or $@!~/vendor has not defined POSIX macro/ } @_
@@ -34,10 +33,10 @@
_SC_STREAM_MAX _SC_VERSION _SC_TZNAME_MAX
);
-my $tests = 2 * 3 * @path_consts +
- 2 * 3 * @path_consts_terminal +
- 2 * 3 * @path_consts_fifo +
- 3 * @sys_consts;
+my $tests = 2 * 2 * @path_consts +
+ 2 * 2 * @path_consts_terminal +
+ 2 * 2 * @path_consts_fifo +
+ 1 * @sys_consts;
plan $tests
? (tests => $tests)
: (skip_all => "No tests to run on this OS")
@@ -54,23 +53,30 @@
my $TTY = "/dev/tty";
sub _check_and_report {
- my ($eval_status, $return_val, $description) = @_;
- my $success = defined($return_val) || $! == 0;
- is( $eval_status, '', $description );
- SKIP: {
- skip "terminal constants set errno on QNX", 1
- if $^O eq 'nto' and $description =~ $TTY;
- ok( $success, "\tchecking that the returned value is defined ("
- . (defined($return_val) ? "yes, it's $return_val)" : "it isn't)"
- . " or that errno is clear ("
- . (!($!+0) ? "it is)" : "it isn't, it's $!)"))
- );
+ my ($sub, $constant, $description) = @_;
+ $! = 0;
+ my $return_val = eval {$sub->(eval "$constant()")};
+ my $errno = $!; # Grab this before anything else changes it.
+ is($@, '', $description);
+
+ # We can't test sysconf further without investigating the type of argument
+ # provided
+ return if $description =~ /sysconf/;
+
+ if (defined $return_val) {
+ like($return_val, qr/\A(?:-?[1-9][0-9]*|0 but true)\z/,
+ 'the returned value should be a signed integer');
+ } else {
+ SKIP:
+ {
+ # POSIX specifies EINVAL is returned if the f?pathconf()
+ # isn't implemented for the specific path
+ skip "$description not implemented for this path", 1
+ if $errno == EINVAL && $description =~ /pathconf/;
+ cmp_ok($errno, '==', 0, 'errno should be 0 as before the call')
+ or diag("\$!: $errno");
+ }
}
- SKIP: {
- skip "constant not implemented on $^O or no limit in effect", 1
- if !defined($return_val);
- ok( looks_like_number($return_val), "\tchecking that the returned value looks like a number" );
- }
}
# testing fpathconf() on a non-terminal file
@@ -77,12 +83,11 @@
SKIP: {
my $fd = POSIX::open($testdir, O_RDONLY)
or skip "could not open test directory '$testdir' ($!)",
- 3 * @path_consts;
+ 2 * @path_consts;
for my $constant (@path_consts) {
- $! = 0;
- $r = eval { fpathconf( $fd, eval "$constant()" ) };
- _check_and_report( $@, $r, "calling fpathconf($fd, $constant) " );
+ _check_and_report(sub { fpathconf($fd, shift) }, $constant,
+ "calling fpathconf($fd, $constant)");
}
POSIX::close($fd);
@@ -90,13 +95,12 @@
# testing pathconf() on a non-terminal file
for my $constant (@path_consts) {
- $! = 0;
- $r = eval { pathconf( $testdir, eval "$constant()" ) };
- _check_and_report( $@, $r, qq[calling pathconf("$testdir", $constant)] );
+ _check_and_report(sub { pathconf($testdir, shift) }, $constant,
+ "calling pathconf('$testdir', $constant)");
}
SKIP: {
- my $n = 2 * 3 * @path_consts_terminal;
+ my $n = 2 * 2 * @path_consts_terminal;
-c $TTY
or skip("$TTY not a character file", $n);
@@ -109,17 +113,15 @@
# testing fpathconf() on a terminal file
for my $constant (@path_consts_terminal) {
- $! = 0;
- $r = eval { fpathconf( $fd, eval "$constant()" ) };
- _check_and_report( $@, $r, qq[calling fpathconf($fd, $constant) ($TTY)] );
+ _check_and_report(sub { fpathconf($fd, shift) }, $constant,
+ "calling fpathconf($fd, $constant) ($TTY)");
}
close($fd);
# testing pathconf() on a terminal file
for my $constant (@path_consts_terminal) {
- $! = 0;
- $r = eval { pathconf( $TTY, eval "$constant()" ) };
- _check_and_report( $@, $r, qq[calling pathconf($TTY, $constant)] );
+ _check_and_report(sub { pathconf($TTY, shift) }, $constant,
+ "calling pathconf($TTY, $constant)");
}
}
@@ -127,16 +129,15 @@
SKIP: {
eval { mkfifo($fifo, 0666) }
- or skip("could not create fifo $fifo ($!)", 2 * 3 * @path_consts_fifo);
+ or skip("could not create fifo $fifo ($!)", 2 * 2 * @path_consts_fifo);
SKIP: {
- my $fd = POSIX::open($fifo, O_RDWR)
- or skip("could not open $fifo ($!)", 3 * @path_consts_fifo);
+ my $fd = POSIX::open($fifo, O_RDONLY | O_NONBLOCK)
+ or skip("could not open $fifo ($!)", 2 * @path_consts_fifo);
for my $constant (@path_consts_fifo) {
- $! = 0;
- $r = eval { fpathconf( $fd, eval "$constant()" ) };
- _check_and_report( $@, $r, "calling fpathconf($fd, $constant) ($fifo)" );
+ _check_and_report(sub { fpathconf($fd, shift) }, $constant,
+ "calling fpathconf($fd, $constant) ($fifo)");
}
POSIX::close($fd);
@@ -144,9 +145,8 @@
# testing pathconf() on a fifo file
for my $constant (@path_consts_fifo) {
- $! = 0;
- $r = eval { pathconf( $fifo, eval "$constant()" ) };
- _check_and_report( $@, $r, qq[calling pathconf($fifo, $constant)] );
+ _check_and_report(sub { pathconf($fifo, shift) }, $constant,
+ "calling pathconf($fifo, $constant");
}
}
@@ -157,14 +157,12 @@
SKIP: {
if($^O eq 'cygwin') {
pop @sys_consts;
- skip("No _SC_TZNAME_MAX on Cygwin", 3);
+ skip("No _SC_TZNAME_MAX on Cygwin", 1);
}
}
# testing sysconf()
for my $constant (@sys_consts) {
- $! = 0;
- $r = eval { sysconf( eval "$constant()" ) };
- _check_and_report( $@, $r, "calling sysconf($constant)" );
+ _check_and_report(sub {sysconf(shift)}, $constant,
+ "calling sysconf($constant)");
}
-
Property changes on: trunk/contrib/perl/ext/POSIX/t/sysconf.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/ext/POSIX/t/taint.t
===================================================================
--- trunk/contrib/perl/ext/POSIX/t/taint.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/POSIX/t/taint.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -8,10 +8,17 @@
}
}
-use Test::More tests => 7;
+use Test::More;
+BEGIN {
+ plan(
+ ${^TAINT}
+ ? (tests => 7)
+ : (skip_all => "A perl without taint support")
+ );
+}
+
use Scalar::Util qw/tainted/;
-
use POSIX qw(fcntl_h open read mkfifo);
use strict ;
Property changes on: trunk/contrib/perl/ext/POSIX/t/taint.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/ext/POSIX/t/termios.t
===================================================================
--- trunk/contrib/perl/ext/POSIX/t/termios.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/POSIX/t/termios.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -1,66 +1,179 @@
-#!perl -T
+#!perl -Tw
-BEGIN {
- use Config;
- use Test::More;
- plan skip_all => "POSIX is unavailable"
- if $Config{'extensions'} !~ m!\bPOSIX\b!;
-}
use strict;
-use POSIX;
+use Config;
+use Test::More;
+
BEGIN {
- plan skip_all => "POSIX::Termios not implemented"
- if !eval "POSIX::Termios->new;1"
- and $@=~/not implemented/;
+ plan skip_all => "POSIX is unavailable"
+ if $Config{extensions} !~ m!\bPOSIX\b!;
}
+use POSIX ':termios_h';
-my @getters = qw(getcflag getiflag getispeed getlflag getoflag getospeed);
+plan skip_all => $@
+ if !eval "POSIX::Termios->new; 1" && $@ =~ /termios not implemented/;
-plan tests => 3 + 2 * (3 + NCCS() + @getters);
-my $r;
+# A termios struct that we've successfully read from a terminal device:
+my $termios;
-# create a new object
-my $termios = eval { POSIX::Termios->new };
-is( $@, '', "calling POSIX::Termios->new" );
-ok( defined $termios, "\tchecking if the object is defined" );
-isa_ok( $termios, "POSIX::Termios", "\tchecking the type of the object" );
+foreach (undef, qw(STDIN STDOUT STDERR)) {
+ SKIP:
+ {
+ my ($name, $handle);
+ if (defined $_) {
+ $name = $_;
+ $handle = $::{$name};
+ } else {
+ $name = POSIX::ctermid();
+ skip("Can't get name of controlling terminal", 4)
+ unless defined $name;
+ open $handle, '<', $name or skip("can't open $name: $!", 4);
+ }
-# testing getattr()
+ skip("$name not a tty", 4) unless -t $handle;
-SKIP: {
- -t STDIN or skip("STDIN not a tty", 2);
- $r = eval { $termios->getattr(0) };
- is( $@, '', "calling getattr(0)" );
- ok( defined $r, "\tchecking if the returned value is defined: $r" );
-}
+ my $t = eval { POSIX::Termios->new };
+ is($@, '', "calling POSIX::Termios->new");
+ isa_ok($t, "POSIX::Termios", "checking the type of the object");
-SKIP: {
- -t STDOUT or skip("STDOUT not a tty", 2);
- $r = eval { $termios->getattr(1) };
- is( $@, '', "calling getattr(1)" );
- ok( defined $r, "\tchecking if the returned value is defined: $r" );
+ my $fileno = fileno $handle;
+ my $r = eval { $t->getattr($fileno) };
+ is($@, '', "calling getattr($fileno) for $name");
+ if(isnt($r, undef, "returned value ($r) is defined")) {
+ $termios = $t;
+ }
+ }
}
-SKIP: {
- -t STDERR or skip("STDERR not a tty", 2);
- $r = eval { $termios->getattr(2) };
- is( $@, '', "calling getattr(2)" );
- ok( defined $r, "\tchecking if the returned value is defined: $r" );
-}
+open my $not_a_tty, '<', $^X or die "Can't open $^X: $!";
-# testing getcc()
-for my $i (0..NCCS()-1) {
- $r = eval { $termios->getcc($i) };
- is( $@, '', "calling getcc($i)" );
- ok( defined $r, "\tchecking if the returned value is defined: $r" );
+if (defined $termios) {
+ # testing getcc()
+ for my $i (0 .. NCCS-1) {
+ my $r = eval { $termios->getcc($i) };
+ is($@, '', "calling getcc($i)");
+ like($r, qr/\A-?[0-9]+\z/, 'returns an integer');
+ }
+ for my $i (NCCS, ~0) {
+ my $r = eval { $termios->getcc($i) };
+ like($@, qr/\ABad getcc subscript/, "calling getcc($i)");
+ is($r, undef, 'returns undef')
+ }
+
+ for my $method (qw(getcflag getiflag getispeed getlflag getoflag getospeed)) {
+ my $r = eval { $termios->$method() };
+ is($@, '', "calling $method()");
+ like($r, qr/\A-?[0-9]+\z/, 'returns an integer');
+ }
+
+ $! = 0;
+ is($termios->setattr(fileno $not_a_tty), undef,
+ 'setattr on a non tty should fail');
+ cmp_ok($!, '==', POSIX::ENOTTY, 'and set errno to ENOTTY');
+
+ $! = 0;
+ is($termios->setattr(fileno $not_a_tty, TCSANOW), undef,
+ 'setattr on a non tty should fail');
+ cmp_ok($!, '==', POSIX::ENOTTY, 'and set errno to ENOTTY');
}
-# testing getcflag()
-for my $method (@getters) {
- $r = eval { $termios->$method() };
- is( $@, '', "calling $method()" );
- ok( defined $r, "\tchecking if the returned value is defined: $r" );
+{
+ my $t = POSIX::Termios->new();
+ isa_ok($t, "POSIX::Termios", "checking the type of the object");
+
+ # B0 is special
+ my @baud = (B50, B75, B110, B134, B150, B200, B300, B600, B1200, B1800,
+ B2400, B4800, B9600, B19200, B38400);
+
+ # On some platforms (eg Linux-that-I-tested), ispeed and ospeed are both
+ # "stored" in the same bits of c_cflag (as the man page documents)
+ # *as well as in struct members* (which you would assume obviates the need
+ # for using c_cflag), and the get*() functions return the value encoded
+ # within c_cflag, hence it's not possible to set/get them independently.
+ foreach my $out (@baud) {
+ is($t->setispeed(0), '0 but true', "setispeed(0)");
+ is($t->setospeed($out), '0 but true', "setospeed($out)");
+ is($t->getospeed(), $out, "getospeed() for $out");
+ }
+ foreach my $in (@baud) {
+ is($t->setospeed(0), '0 but true', "setospeed(0)");
+ is($t->setispeed($in), '0 but true', "setispeed($in)");
+ is($t->getispeed(), $in, "getispeed() for $in");
+ }
+
+ my %state;
+ my @flags = qw(iflag oflag cflag lflag);
+ # I'd prefer to use real values per flag, but can only find OPOST in
+ # POSIX.pm for oflag
+ my @values = (0, 6, 9, 42);
+
+ # initialise everything
+ foreach (@flags) {
+ my $method = 'set' . $_;
+ $t->$method(0);
+ $state{$_} = 0;
+ }
+
+ sub testflags {
+ my ($flag, $values, @rest) = @_;
+ $! = 0;
+ my $method = 'set' . $flag;
+ foreach (@$values) {
+ $t->$method($_);
+ $state{$flag} = $_;
+
+ my $state = join ', ', map {"$_=$state{$_}"} keys %state;
+ while (my ($flag, $expect) = each %state) {
+ my $method = 'get' . $flag;
+ is($t->$method(), $expect, "$method() for $state");
+ }
+
+ testflags(@rest) if @rest;
+ }
+ }
+
+ testflags(map {($_, \@values)} @flags);
+
+ for my $i (0 .. NCCS-1) {
+ $t->setcc($i, 0);
+ }
+ for my $i (0 .. NCCS-1) {
+ is($t->getcc($i), 0, "getcc($i)");
+ }
+ my $c = 0;
+ for my $i (0 .. NCCS-1) {
+ $t->setcc($i, ++$c);
+ }
+ for my $i (reverse 0 .. NCCS-1) {
+ is($t->getcc($i), $c--, "getcc($i)");
+ }
+ for my $i (reverse 0 .. NCCS-1) {
+ $t->setcc($i, ++$c);
+ }
+ for my $i (0 .. NCCS-1) {
+ is($t->getcc($i), $c--, "getcc($i)");
+ }
+
}
+$! = 0;
+is(tcdrain(fileno $not_a_tty), undef, 'tcdrain on a non tty should fail');
+cmp_ok($!, '==', POSIX::ENOTTY, 'and set errno to ENOTTY');
+
+$! = 0;
+is(tcflow(fileno $not_a_tty, TCOON), undef, 'tcflow on a non tty should fail');
+cmp_ok($!, '==', POSIX::ENOTTY, 'and set errno to ENOTTY');
+
+$! = 0;
+is(tcflush(fileno $not_a_tty, TCOFLUSH), undef,
+ 'tcflush on a non tty should fail');
+cmp_ok($!, '==', POSIX::ENOTTY, 'and set errno to ENOTTY');
+
+$! = 0;
+is(tcsendbreak(fileno $not_a_tty, 0), undef,
+ 'tcsendbreak on a non tty should fail');
+cmp_ok($!, '==', POSIX::ENOTTY, 'and set errno to ENOTTY');
+
+done_testing();
Property changes on: trunk/contrib/perl/ext/POSIX/t/termios.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/ext/POSIX/t/time.t
===================================================================
--- trunk/contrib/perl/ext/POSIX/t/time.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/POSIX/t/time.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -4,7 +4,7 @@
use Config;
use POSIX;
-use Test::More tests => 13;
+use Test::More tests => 19;
# go to UTC to avoid DST issues around the world when testing. SUS3 says that
# null should get you UTC, but some environments want the explicit names.
@@ -39,21 +39,33 @@
# asctime and ctime...Let's stay below INT_MAX for 32-bits and
# positive for some picky systems.
-is(asctime(localtime(0)), ctime(0), "asctime() and ctime() at zero");
-is(asctime(localtime(12345678)), ctime(12345678), "asctime() and ctime() at 12345678");
+is(asctime(CORE::localtime(0)), ctime(0), "asctime() and ctime() at zero");
+is(asctime(POSIX::localtime(0)), ctime(0), "asctime() and ctime() at zero");
+is(asctime(CORE::localtime(12345678)), ctime(12345678),
+ "asctime() and ctime() at 12345678");
+is(asctime(POSIX::localtime(12345678)), ctime(12345678),
+ "asctime() and ctime() at 12345678");
# Careful! strftime() is locale sensitive. Let's take care of that
my $orig_loc = setlocale(LC_TIME, "C") || die "Cannot setlocale() to C: $!";
my $jan_16 = 15 * 86400;
-is(ctime($jan_16), strftime("%a %b %d %H:%M:%S %Y\n", localtime($jan_16)),
+is(ctime($jan_16), strftime("%a %b %d %H:%M:%S %Y\n", CORE::localtime($jan_16)),
"get ctime() equal to strftime()");
-is(strftime("%Y\x{5e74}%m\x{6708}%d\x{65e5}", gmtime($jan_16)),
+is(ctime($jan_16), strftime("%a %b %d %H:%M:%S %Y\n", POSIX::localtime($jan_16)),
+ "get ctime() equal to strftime()");
+is(strftime("%Y\x{5e74}%m\x{6708}%d\x{65e5}", CORE::gmtime($jan_16)),
"1970\x{5e74}01\x{6708}16\x{65e5}",
"strftime() can handle unicode chars in the format string");
+is(strftime("%Y\x{5e74}%m\x{6708}%d\x{65e5}", POSIX::gmtime($jan_16)),
+ "1970\x{5e74}01\x{6708}16\x{65e5}",
+ "strftime() can handle unicode chars in the format string");
my $ss = chr 223;
unlike($ss, qr/\w/, 'Not internally UTF-8 encoded');
-is(ord strftime($ss, localtime), 223, 'Format string has correct character');
+is(ord strftime($ss, CORE::localtime), 223,
+ 'Format string has correct character');
+is(ord strftime($ss, POSIX::localtime(time)),
+ 223, 'Format string has correct character');
unlike($ss, qr/\w/, 'Still not internally UTF-8 encoded');
setlocale(LC_TIME, $orig_loc) || die "Cannot setlocale() back to orig: $!";
@@ -62,7 +74,7 @@
# and BSD. Cygwin, Win32, and Linux lean the BSD way. So, the tests just
# check the basics.
like(clock(), qr/\d*/, "clock() returns a numeric value");
-ok(clock() >= 0, "...and it returns something >= 0");
+cmp_ok(clock(), '>=', 0, "...and it returns something >= 0");
SKIP: {
skip "No difftime()", 1 if $Config{d_difftime} ne 'define';
@@ -70,7 +82,8 @@
}
SKIP: {
- skip "No mktime()", 1 if $Config{d_mktime} ne 'define';
+ skip "No mktime()", 2 if $Config{d_mktime} ne 'define';
my $time = time();
- is(mktime(localtime($time)), $time, "mktime()");
+ is(mktime(CORE::localtime($time)), $time, "mktime()");
+ is(mktime(POSIX::localtime($time)), $time, "mktime()");
}
Property changes on: trunk/contrib/perl/ext/POSIX/t/time.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Copied: trunk/contrib/perl/ext/POSIX/t/unimplemented.t (from rev 6437, vendor/perl/5.18.1/ext/POSIX/t/unimplemented.t)
===================================================================
--- trunk/contrib/perl/ext/POSIX/t/unimplemented.t (rev 0)
+++ trunk/contrib/perl/ext/POSIX/t/unimplemented.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -0,0 +1,99 @@
+#!./perl -w
+
+use strict;
+use Test::More;
+use Config;
+
+plan(skip_all => "POSIX is unavailable")
+ unless $Config{extensions} =~ /\bPOSIX\b/;
+
+require POSIX;
+
+foreach ([atexit => 'C-specific: use END {} instead'],
+ [atof => 'C-specific, stopped'],
+ [atoi => 'C-specific, stopped'],
+ [atol => 'C-specific, stopped'],
+ [bsearch => 'not supplied'],
+ [calloc => 'C-specific, stopped'],
+ [clearerr => \'IO::Handle::clearerr'],
+ [div => 'C-specific: use /, % and int instead'],
+ [execl => 'C-specific, stopped'],
+ [execle => 'C-specific, stopped'],
+ [execlp => 'C-specific, stopped'],
+ [execv => 'C-specific, stopped'],
+ [execve => 'C-specific, stopped'],
+ [execvp => 'C-specific, stopped'],
+ [fclose => \'IO::Handle::close'],
+ [fdopen => \'IO::Handle::new_from_fd'],
+ [feof => \'IO::Handle::eof'],
+ [ferror => \'IO::Handle::error'],
+ [fflush => \'IO::Handle::flush'],
+ [fgetc => \'IO::Handle::getc'],
+ [fgetpos => \'IO::Seekable::getpos'],
+ [fgets => \'IO::Handle::gets'],
+ [fileno => \'IO::Handle::fileno'],
+ [fopen => \'IO::File::open'],
+ [fprintf => 'C-specific: use printf instead'],
+ [fputc => 'C-specific: use print instead'],
+ [fputs => 'C-specific: use print instead'],
+ [fread => 'C-specific: use read instead'],
+ [free => 'C-specific, stopped'],
+ [freopen => 'C-specific: use open instead'],
+ [fscanf => 'C-specific: use <> and regular expressions instead'],
+ [fseek => \'IO::Seekable::seek'],
+ [fsetpos => \'IO::Seekable::setpos'],
+ [fsync => \'IO::Handle::sync'],
+ [ftell => \'IO::Seekable::tell'],
+ [fwrite => 'C-specific: use print instead'],
+ [labs => 'C-specific: use abs instead'],
+ [ldiv => 'C-specific: use /, % and int instead'],
+ [longjmp => 'C-specific: use die instead'],
+ [malloc => 'C-specific, stopped'],
+ [memchr => 'C-specific: use index() instead'],
+ [memcmp => 'C-specific: use eq instead'],
+ [memcpy => 'C-specific: use = instead'],
+ [memmove => 'C-specific: use = instead'],
+ [memset => 'C-specific: use x instead'],
+ [offsetof => 'C-specific, stopped'],
+ [putc => 'C-specific: use print instead'],
+ [putchar => 'C-specific: use print instead'],
+ [puts => 'C-specific: use print instead'],
+ [qsort => 'C-specific: use sort instead'],
+ [rand => 'non-portable, use Perl\'s rand instead'],
+ [realloc => 'C-specific, stopped'],
+ [scanf => 'C-specific: use <> and regular expressions instead'],
+ [setbuf => \'IO::Handle::setbuf'],
+ [setjmp => 'C-specific: use eval {} instead'],
+ [setvbuf => \'IO::Handle::setvbuf'],
+ [siglongjmp => 'C-specific: use die instead'],
+ [sigsetjmp => 'C-specific: use eval {} instead'],
+ [srand => 'not supplied; refer to Perl\'s srand documentation'],
+ [sscanf => 'C-specific: use regular expressions instead'],
+ [strcat => 'C-specific: use .= instead'],
+ [strchr => 'C-specific: use index() instead'],
+ [strcmp => 'C-specific: use eq instead'],
+ [strcpy => 'C-specific: use = instead'],
+ [strcspn => 'C-specific: use regular expressions instead'],
+ [strlen => 'C-specific: use length instead'],
+ [strncat => 'C-specific: use .= instead'],
+ [strncmp => 'C-specific: use eq instead'],
+ [strncpy => 'C-specific: use = instead'],
+ [strpbrk => 'C-specific, stopped'],
+ [strrchr => 'C-specific: use rindex() instead'],
+ [strspn => 'C-specific, stopped'],
+ [strtok => 'C-specific, stopped'],
+ [tmpfile => \'IO::File::new_tmpfile'],
+ [ungetc => \'IO::Handle::ungetc'],
+ [vfprintf => 'C-specific, stopped'],
+ [vprintf => 'C-specific, stopped'],
+ [vsprintf => 'C-specific, stopped'],
+ ) {
+ my ($func, $action) = @$_;
+ my $expect = ref $action
+ ? qr/Use method $$action\(\) instead of POSIX::$func\(\) at \(eval/
+ : qr/Unimplemented: POSIX::$func\(\) is \Q$action\E at \(eval/;
+ is(eval "POSIX::$func(); 1", undef, "POSIX::$func fails as expected");
+ like($@, $expect, "POSIX::$func gives expected error message");
+}
+
+done_testing();
Copied: trunk/contrib/perl/ext/POSIX/t/usage.t (from rev 6437, vendor/perl/5.18.1/ext/POSIX/t/usage.t)
===================================================================
--- trunk/contrib/perl/ext/POSIX/t/usage.t (rev 0)
+++ trunk/contrib/perl/ext/POSIX/t/usage.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -0,0 +1,48 @@
+#!./perl -w
+
+use strict;
+use Test::More;
+use Config;
+
+plan(skip_all => "POSIX is unavailable")
+ unless $Config{extensions} =~ /\bPOSIX\b/;
+
+require POSIX;
+
+my %valid;
+my @all;
+
+my $argc = 0;
+for my $list ([qw(errno fork getchar getegid geteuid getgid getgroups getlogin
+ getpgrp getpid getppid gets getuid time wait)],
+ [qw(abs alarm assert chdir closedir cos exit exp fabs fstat getc
+ getenv getgrgid getgrnam getpwnam getpwuid gmtime isatty
+ localtime log opendir raise readdir remove rewind rewinddir
+ rmdir sin sleep sqrt stat strerror system tolower toupper
+ umask unlink)],
+ [qw(atan2 chmod creat kill link mkdir pow rename strstr waitpid)],
+ [qw(chown fcntl utime)]) {
+ $valid{$_} = $argc foreach @$list;
+ push @all, @$list;
+ ++$argc;
+}
+
+my @try = 0 .. $argc - 1;
+foreach my $func (sort @all) {
+ my $arg_pat = join ', ', ('[a-z]+') x $valid{$func};
+ my $expect = qr/\AUsage: POSIX::$func\($arg_pat\) at \(eval/;
+ foreach my $try (@try) {
+ next if $valid{$func} == $try;
+ my $call = "POSIX::$func(" . join(', ', 1 .. $try) . ')';
+ is(eval "$call; 1", undef, "$call fails");
+ like($@, $expect, "POSIX::$func for $try arguments gives expected error")
+ }
+}
+
+foreach my $func (qw(printf sprintf)) {
+ is(eval "POSIX::$func(); 1", undef, "POSIX::$func() fails");
+ like($@, qr/\AUsage: POSIX::$func\(pattern, args\.\.\.\) at \(eval/,
+ "POSIX::$func for 0 arguments gives expected error");
+}
+
+done_testing();
Modified: trunk/contrib/perl/ext/POSIX/t/waitpid.t
===================================================================
--- trunk/contrib/perl/ext/POSIX/t/waitpid.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/POSIX/t/waitpid.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -21,7 +21,7 @@
$| = 1;
-print "1..1\n";
+use Test::More tests => 3;
sub NEG1_PROHIBITED () { 0x01 }
sub NEG1_REQUIRED () { 0x02 }
@@ -31,11 +31,12 @@
my $state = NEG1_PROHIBITED;
my $child_pid = fork();
+fail("fork failed") unless defined $child_pid;
# Parent receives a nonzero child PID.
if ($child_pid) {
- my $ok = 1;
+ my @problems;
while ($count++ < $max_count) {
my $begin_time = time();
@@ -45,26 +46,28 @@
printf( "# waitpid(-1,WNOHANG) returned %d after %.2f seconds\n",
$ret, $elapsed_time );
if ($elapsed_time > 0.5) {
- printf( "# %.2f seconds in non-blocking waitpid is too long!\n",
- $elapsed_time );
- $ok = 0;
+ push @problems,
+ sprintf "%.2f seconds in non-blocking waitpid is too long!\n",
+ $elapsed_time;
last;
}
if ($state & NEG1_PROHIBITED) {
if ($ret == -1) {
- print "# waitpid should not have returned -1 here!\n";
- $ok = 0;
+ push @problems, "waitpid should not have returned -1 here!\n";
last;
}
elsif ($ret == $child_pid) {
$state = NEG1_REQUIRED;
+ is(WIFEXITED(${^CHILD_ERROR_NATIVE}), 1, 'child exited cleanly');
+ is(WEXITSTATUS(${^CHILD_ERROR_NATIVE}), 0,
+ 'child exited with 0 (the retun value of its sleep(3) call)');
+
}
}
elsif ($state & NEG1_REQUIRED) {
unless ($ret == -1) {
- print "# waitpid should have returned -1 here\n";
- $ok = 0;
+ push @problems, "waitpid should have returned -1 here!\n";
}
last;
}
@@ -71,13 +74,11 @@
sleep(1);
}
- print $ok ? "ok 1\n" : "not ok 1\n";
- exit(0); # parent
+ is("@problems", "", 'no problems');
+ POSIX::exit(0); # parent
+ fail("Should have exited");
} else {
# Child receives a zero PID and can request parent's PID with
# getppid().
- sleep(3);
- exit(0);
+ POSIX::_exit(POSIX::sleep(3));
}
-
-
Property changes on: trunk/contrib/perl/ext/POSIX/t/waitpid.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Copied: trunk/contrib/perl/ext/POSIX/t/wrappers.t (from rev 6437, vendor/perl/5.18.1/ext/POSIX/t/wrappers.t)
===================================================================
--- trunk/contrib/perl/ext/POSIX/t/wrappers.t (rev 0)
+++ trunk/contrib/perl/ext/POSIX/t/wrappers.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -0,0 +1,233 @@
+#!./perl -w
+
+use strict;
+use Test::More;
+use Config;
+
+plan(skip_all => "POSIX is unavailable")
+ unless $Config{extensions} =~ /\bPOSIX\b/;
+
+require POSIX;
+require Symbol;
+
+use constant NOT_HERE => 'this-file-should-not-exist';
+
+# localtime and gmtime in time.t.
+# exit, fork, waitpid, sleep in waitpid.t
+# errno in posix.t
+
+is(POSIX::abs(-42), 42, 'abs');
+is(POSIX::abs(-3.14), 3.14, 'abs');
+is(POSIX::abs(POSIX::exp(1)), CORE::exp(1), 'abs');
+is(POSIX::alarm(0), 0, 'alarm');
+is(eval {POSIX::assert(1); 1}, 1, 'assert(1)');
+is(eval {POSIX::assert(0); 1}, undef, 'assert(0)');
+like($@, qr/Assertion failed at/, 'assert throws an error');
+is(POSIX::atan2(0, 1), 0, 'atan2');
+is(POSIX::cos(0), 1, 'cos');
+is(POSIX::exp(0), 1, 'exp');
+is(POSIX::fabs(-42), 42, 'fabs');
+is(POSIX::fabs(-3.14), 3.14, 'fabs');
+
+is(do {local $^W;
+ POSIX::fcntl(Symbol::geniosym(), 0, 0);
+ 1;
+ }, 1, 'fcntl');
+
+SKIP: {
+ # Win32 doesn't like me trying to fstat STDIN. Bothersome thing.
+ skip("Can't open $^X: $!", 1) unless open my $fh, '<', $^X;
+
+ is_deeply([POSIX::fstat(fileno $fh)], [stat $fh], 'fstat');
+}
+
+is(POSIX::getegid(), 0 + $), 'getegid');
+is(POSIX::geteuid(), 0 + $>, 'geteuid');
+is(POSIX::getgid(), 0 + $(, 'getgid');
+is(POSIX::getenv('PATH'), $ENV{PATH}, 'getenv');
+
+SKIP: {
+ my $name = eval {getgrgid $(};
+ skip("getgrgid not available", 2) unless defined $name;
+ is_deeply([POSIX::getgrgid($()], [CORE::getgrgid($()], "getgrgid($()");
+ is_deeply([POSIX::getgrnam($name)], [CORE::getgrnam($name)],
+ "getgrnam('$name')");
+}
+
+cmp_ok((length join ' ', POSIX::getgroups()), '<=', length $), 'getgroups');
+is(POSIX::getlogin(), CORE::getlogin, 'getlogin');
+
+SKIP: {
+ skip('getpgrp not available', 1) unless $Config{d_getpgrp};
+ is(POSIX::getpgrp(), CORE::getpgrp(), 'getpgrp');
+}
+
+is(POSIX::getpid(), $$, 'getpid');
+
+SKIP: {
+ my $name = eval {getpwuid $<};
+ skip('getpwuid not available', 2) unless defined $name;
+ is_deeply([POSIX::getpwuid($<)], [CORE::getpwuid($<)], "getgrgid($<)");
+ is_deeply([POSIX::getpwnam($name)], [CORE::getpwnam($name)],
+ "getpwnam('$name')");
+}
+
+SKIP: {
+ skip('STDIN is not a tty', 1) unless -t STDIN;
+ is(POSIX::isatty(*STDIN), 1, 'isatty');
+}
+
+is(POSIX::getuid(), $<, 'getuid');
+is(POSIX::log(1), 0, 'log');
+is(POSIX::pow(2, 31), 0x80000000, 'pow');
+# usage "printf(pattern, args...)" if @_ < 1;
+
+{
+ my $buffer;
+ package Capture;
+ use parent 'Tie::StdHandle';
+
+ sub WRITE {
+ $buffer .= $_[1];
+ 42;
+ }
+
+ package main;
+ tie *STDOUT, 'Capture';
+ is(POSIX::printf('%s %s%c', 'Hello', 'World', ord "\n"), 42, 'printf');
+ is($buffer, "Hello World\n", 'captured print output');
+ untie *STDOUT;
+}
+
+is(do {local $^W;
+ POSIX::rewind(Symbol::geniosym());
+ 1;
+ }, 1, 'rewind');
+
+is(POSIX::sin(0), 0, 'sin');
+is(POSIX::sleep(0), 0, 'sleep');
+is(POSIX::sprintf('%o', 42), '52', 'sprintf');
+is(POSIX::sqrt(256), 16, 'sqrt');
+is_deeply([POSIX::stat($^X)], [stat $^X], 'stat');
+{
+ local $! = 2;
+ my $error = "$!";
+ is(POSIX::strerror(2), $error, 'strerror');
+}
+
+is(POSIX::strstr('BBFRPRAFPGHPP', 'FP'), 7, 'strstr');
+SKIP: {
+ my $true;
+ foreach (qw(/bin/true /usr/bin/true)) {
+ if (-x $_) {
+ $true = $_;
+ last;
+ }
+ }
+ skip("Can't find true", 1) unless $true;
+ is(POSIX::system($true), 0, 'system');
+}
+
+{
+ my $past = CORE::time;
+ my $present = POSIX::time();
+ my $future = CORE::time;
+ # Shakes fist at virtual machines
+ cmp_ok($past, '<=', $present, 'time');
+ cmp_ok($present, '<=', $future, 'time');
+}
+
+is(POSIX::tolower('Perl Rules'), 'perl rules', 'tolower');
+is(POSIX::toupper('oi!'), 'OI!', 'toupper');
+
+is(-e NOT_HERE, undef, NOT_HERE . ' does not exist');
+
+foreach ([undef, 0, 'chdir', NOT_HERE],
+ [undef, 0, 'chmod', 0, NOT_HERE],
+ ['d_chown', 0, 'chown', 0, 0, NOT_HERE],
+ [undef, undef, 'creat', NOT_HERE . '/crash', 0],
+ ['d_link', 0, 'link', NOT_HERE, 'ouch'],
+ [undef, 0, 'remove', NOT_HERE],
+ [undef, 0, 'rename', NOT_HERE, 'z_zwapp'],
+ [undef, 0, 'remove', NOT_HERE],
+ [undef, 0, 'unlink', NOT_HERE],
+ [undef, 0, 'utime', NOT_HERE, 0, 0],
+ ) {
+ my ($skip, $expect, $name, @args) = @$_;
+ my $func = do {no strict 'refs'; \&{"POSIX::$name"}};
+
+ SKIP: {
+ skip("$name() is not available", 2) if $skip && !$Config{$skip};
+ $! = 0;
+ is(&$func(@args), $expect, $name);
+ isnt($!, '', "$name reported an error");
+ }
+}
+
+{
+ my $dir = "./HiC_$$";
+ is(-e $dir, undef, "$dir does not exist");
+
+ is(POSIX::mkdir($dir, 0755), 1, 'mkdir');
+ is(-d $dir, 1, "$dir now exists");
+
+ my $dh = POSIX::opendir($dir);
+ isnt($dh, undef, 'opendir');
+
+ my @first = POSIX::readdir($dh);
+ is(POSIX::rewinddir($dh), 1, 'rewinddir');
+ my @second = POSIX::readdir($dh);
+
+ is_deeply(\@first, \@second, 'readdir,rewinddir,readdir');
+
+ is(POSIX::closedir($dh), 1, 'rewinddir');
+
+ is(POSIX::rmdir($dir), 1, 'rmdir');
+ is(-e $dir, undef, "$dir does not exist");
+}
+
+SKIP: {
+ skip("No \$SIG{USR1} on $^O", 4) unless exists $SIG{USR1};
+ my $gotit = 0;
+ $SIG{USR1} = sub { $gotit++ };
+ is(POSIX::kill($$, 'SIGUSR1'), 1, 'kill');
+ is($gotit, 1, 'got first signal');
+ is(POSIX::raise('SIGUSR1'), 1, 'raise');
+ is($gotit, 2, 'got second signal');
+}
+
+SKIP: {
+ foreach (qw(fork pipe)) {
+ skip("no $_", 8) unless $Config{"d_$_"};
+ }
+ # die with an uncaught SIGARLM if something goes wrong
+ is(CORE::alarm(60), 0, 'no alarm set previously');
+
+ is((pipe *STDIN, my $w), 1, 'pipe');
+ my $pid = POSIX::fork();
+ fail("fork failed: $!") unless defined $pid;
+
+ if ($pid) {
+ close $w;
+ is(POSIX::getc(*STDIN), '1', 'getc');
+ is(POSIX::getchar(), '2', 'getchar');
+ is(POSIX::gets(), "345\n", 'gets');
+ my $ppid = <STDIN>;
+ chomp $ppid;
+ is($ppid, $$, 'getppid');
+ is(POSIX::wait(), $pid, 'wait');
+ is(POSIX::WIFEXITED(${^CHILD_ERROR_NATIVE}), 1, 'child exited cleanly');
+ is(POSIX::WEXITSTATUS(${^CHILD_ERROR_NATIVE}), 1,
+ 'child exited with 1 (the retun value of its close call)');
+ } else {
+ # Child
+ close *STDIN;
+ print $w "12345\n", POSIX::getppid(), "\n";
+ POSIX::_exit(close $w);
+ }
+}
+
+my $umask = CORE::umask;
+is(POSIX::umask($umask), $umask, 'umask');
+
+done_testing();
Modified: trunk/contrib/perl/ext/POSIX/typemap
===================================================================
--- trunk/contrib/perl/ext/POSIX/typemap 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/POSIX/typemap 2013-12-02 21:32:26 UTC (rev 6445)
@@ -11,6 +11,20 @@
speed_t T_IV
tcflag_t T_IV
cc_t T_IV
-POSIX::SigSet T_PTROBJ
-POSIX::Termios T_PTROBJ
+POSIX::SigSet T_OPAQUEPTROBJ
+POSIX::Termios T_OPAQUEPTROBJ
POSIX::SigAction T_HVREF
+
+INPUT
+T_OPAQUEPTROBJ
+ if (SvROK($arg) && sv_derived_from($arg, \"${ntype}\")) {
+ $var = ($type)SvPV_nolen(SvRV($arg));
+ }
+ else
+ Perl_croak(aTHX_ \"%s: %s is not of type %s\",
+ ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]},
+ \"$var\", \"$ntype\")
+
+OUTPUT
+T_OPAQUEPTROBJ
+ sv_setref_pvn($arg, \"${ntype}\", (const char*)$var, sizeof(*$var));
Property changes on: trunk/contrib/perl/ext/POSIX/typemap
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/PerlIO-encoding/MANIFEST
===================================================================
--- trunk/contrib/perl/ext/PerlIO-encoding/MANIFEST 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/PerlIO-encoding/MANIFEST 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/PerlIO-encoding/MANIFEST
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/ext/PerlIO-encoding/encoding.pm
===================================================================
--- trunk/contrib/perl/ext/PerlIO-encoding/encoding.pm 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/PerlIO-encoding/encoding.pm 2013-12-02 21:32:26 UTC (rev 6445)
@@ -1,7 +1,7 @@
package PerlIO::encoding;
use strict;
-our $VERSION = '0.14';
+our $VERSION = '0.16';
our $DEBUG = 0;
$DEBUG and warn __PACKAGE__, " called by ", join(", ", caller), "\n";
Property changes on: trunk/contrib/perl/ext/PerlIO-encoding/encoding.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/ext/PerlIO-encoding/encoding.xs
===================================================================
--- trunk/contrib/perl/ext/PerlIO-encoding/encoding.xs 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/PerlIO-encoding/encoding.xs 2013-12-02 21:32:26 UTC (rev 6445)
@@ -341,6 +341,8 @@
SPAGAIN;
uni = POPs;
PUTBACK;
+ /* No cows allowed. */
+ if (SvTHINKFIRST(e->dataSV)) SvPV_force_nolen(e->dataSV);
/* Now get translated string (forced to UTF-8) and use as buffer */
if (SvPOK(uni)) {
s = SvPVutf8(uni, len);
@@ -365,6 +367,7 @@
/* Adjust ptr/cnt not taking anything which
did not translate - not clear this is a win */
/* compute amount we took */
+ if (!SvPOKp(e->dataSV)) (void)SvPV_force_nolen(e->dataSV);
use -= SvCUR(e->dataSV);
PerlIO_set_ptrcnt(n, ptr+use, (avail-use));
/* and as we did not take it it isn't pending */
@@ -440,6 +443,14 @@
if (PerlIO_flush(PerlIONext(f)) != 0) {
code = -1;
}
+ if (!SvPOKp(e->bufsv) || SvTHINKFIRST(e->bufsv))
+ (void)SvPV_force_nolen(e->bufsv);
+ if ((STDCHAR *)SvPVX(e->bufsv) != e->base.buf) {
+ e->base.ptr = SvEND(e->bufsv);
+ e->base.end = SvPVX(e->bufsv) + (e->base.end-e->base.buf);
+ e->base.buf = (STDCHAR *)SvPVX(e->bufsv);
+ }
+ (void)PerlIOEncode_get_base(aTHX_ f);
if (SvCUR(e->bufsv)) {
/* Did not all translate */
e->base.ptr = e->base.buf+SvCUR(e->bufsv);
@@ -538,8 +549,8 @@
PerlIOEncode_tell(pTHX_ PerlIO * f)
{
PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
- /* Unfortunately the only way to get a postion is to (re-)translate,
- the UTF8 we have in bufefr and then ask layer below
+ /* Unfortunately the only way to get a position is to (re-)translate,
+ the UTF8 we have in buffer and then ask layer below
*/
PerlIO_flush(f);
if (b->buf && b->ptr > b->buf) {
Property changes on: trunk/contrib/perl/ext/PerlIO-encoding/encoding.xs
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/ext/PerlIO-encoding/t/encoding.t
===================================================================
--- trunk/contrib/perl/ext/PerlIO-encoding/t/encoding.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/PerlIO-encoding/t/encoding.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -11,7 +11,7 @@
}
}
-use Test::More tests => 18;
+use Test::More tests => 24;
my $grk = "grk$$";
my $utf = "utf$$";
@@ -124,6 +124,112 @@
is($dstr, "foo\\xF0\\x80\\x80\\x80bar\n:\\x80foo\n");
}
+# Check that PerlIO::encoding can handle custom encodings that do funny
+# things with the buffer.
+use Encode::Encoding;
+package Extensive {
+ @ISA = Encode::Encoding;
+ __PACKAGE__->Define('extensive');
+ sub encode($$;$) {
+ my ($self,$buf,$chk) = @_;
+ my $leftovers = '';
+ if ($buf =~ /(.*\n)(?!\z)/) {
+ $buf = $1;
+ $leftovers = $';
+ }
+ if ($chk) {
+ undef $_[1];
+ my @x = (' ') x 8000; # reuse the just-freed buffer
+ $_[1] = $leftovers; # SvPVX now points elsewhere and is shorter
+ } # than bufsiz
+ $buf;
+ }
+ no warnings 'once';
+ *decode = *encode;
+}
+open my $fh, ">:encoding(extensive)", \$buf;
+$fh->autoflush;
+print $fh "doughnut\n";
+print $fh "quaffee\n";
+# Print something longer than the buffer that encode() shrunk:
+print $fh "The beech leaves beech leaves on the beach by the beech.\n";
+close $fh;
+is $buf, "doughnut\nquaffee\nThe beech leaves beech leaves on the beach by"
+ ." the beech.\n", 'buffer realloc during encoding';
+$buf = "Sheila surely shod Sean\nin shoddy shoes.\n";
+open $fh, "<:encoding(extensive)", \$buf;
+is join("", <$fh>), "Sheila surely shod Sean\nin shoddy shoes.\n",
+ 'buffer realloc during decoding';
+
+package Cower {
+ @ISA = Encode::Encoding;
+ __PACKAGE__->Define('cower');
+ sub encode($$;$) {
+ my ($self,$buf,$chk) = @_;
+ my $leftovers = '';
+ if ($buf =~ /(.*\n)(?!\z)/) {
+ $buf = $1;
+ $leftovers = $';
+ }
+ if ($chk) {
+ no warnings; # stupid @_[1] warning
+ @_[1] = keys %{{$leftovers=>1}}; # shared hash key (copy-on-write)
+ }
+ $buf;
+ }
+ no warnings 'once';
+ *decode = *encode;
+}
+open $fh, ">:encoding(cower)", \$buf;
+$fh->autoflush;
+print $fh $_ for qw "pumping plum pits";
+close $fh;
+is $buf, "pumpingplumpits", 'cowing buffer during encoding';
+$buf = "pumping\nplum\npits\n";
+open $fh, "<:encoding(cower)", \$buf;
+is join("", <$fh>), "pumping\nplum\npits\n",
+ 'cowing buffer during decoding';
+
+package Globber {
+ no warnings 'once';
+ @ISA = Encode::Encoding;
+ __PACKAGE__->Define('globber');
+ sub encode($$;$) {
+ my ($self,$buf,$chk) = @_;
+ $_[1] = *foo if $chk;
+ $buf;
+ }
+ *decode = *encode;
+}
+
+# Here we just want to test there is no crash. The actual output is not so
+# important.
+# We need a double eval, as scope unwinding will close the handle,
+# which croaks.
+# Under debugging builds with PERL_DESTRUCT_LEVEL set, we have to skip this
+# test, as it triggers bug #115692, resulting in string table warnings.
+require Config;
+SKIP: {
+skip "produces string table warnings", 2
+ if "@{[Config::non_bincompat_options()]}" =~ /\bDEBUGGING\b/
+ && $ENV{PERL_DESTRUCT_LEVEL};
+
+eval { eval {
+ open my $fh, ">:encoding(globber)", \$buf;
+ print $fh "Agathopous Goodfoot\n";
+ close $fh;
+}; $e = $@};
+like $@||$e, qr/Close with partial character/,
+ 'no crash when assigning glob to buffer in encode';
+$buf = "To hymn him who heard her herd herd\n";
+open $fh, "<:encoding(globber)", \$buf;
+my $x = <$fh>;
+close $fh;
+is $x, "To hymn him who heard her herd herd\n",
+ 'no crash when assigning glob to buffer in decode';
+
+} # SKIP
+
END {
1 while unlink($grk, $utf, $fail1, $fail2, $russki, $threebyte);
}
Property changes on: trunk/contrib/perl/ext/PerlIO-encoding/t/encoding.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/ext/PerlIO-encoding/t/fallback.t
===================================================================
--- trunk/contrib/perl/ext/PerlIO-encoding/t/fallback.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/PerlIO-encoding/t/fallback.t 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/PerlIO-encoding/t/fallback.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/ext/PerlIO-encoding/t/nolooping.t
===================================================================
--- trunk/contrib/perl/ext/PerlIO-encoding/t/nolooping.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/PerlIO-encoding/t/nolooping.t 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/PerlIO-encoding/t/nolooping.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/ext/PerlIO-scalar/scalar.pm
===================================================================
--- trunk/contrib/perl/ext/PerlIO-scalar/scalar.pm 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/PerlIO-scalar/scalar.pm 2013-12-02 21:32:26 UTC (rev 6445)
@@ -1,5 +1,5 @@
package PerlIO::scalar;
-our $VERSION = '0.11_01';
+our $VERSION = '0.16';
require XSLoader;
XSLoader::load();
1;
Property changes on: trunk/contrib/perl/ext/PerlIO-scalar/scalar.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/ext/PerlIO-scalar/scalar.xs
===================================================================
--- trunk/contrib/perl/ext/PerlIO-scalar/scalar.xs 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/PerlIO-scalar/scalar.xs 2013-12-02 21:32:26 UTC (rev 6445)
@@ -6,6 +6,9 @@
#include "perliol.h"
+static const char code_point_warning[] =
+ "Strings with code points over 0xFF may not be mapped into in-memory file handles\n";
+
typedef struct {
struct _PerlIO base; /* Base "class" info */
SV *var;
@@ -52,6 +55,14 @@
sv_force_normal(s->var);
SvCUR_set(s->var, 0);
}
+ if (SvUTF8(s->var) && !sv_utf8_downgrade(s->var, TRUE)) {
+ if (ckWARN(WARN_UTF8))
+ Perl_warner(aTHX_ packWARN(WARN_UTF8), code_point_warning);
+ SETERRNO(EINVAL, SS_IVCHAN);
+ SvREFCNT_dec(s->var);
+ s->var = Nullsv;
+ return -1;
+ }
if ((PerlIOBase(f)->flags) & PERLIO_F_APPEND)
{
sv_force_normal(s->var);
@@ -93,12 +104,7 @@
PerlIOScalar_seek(pTHX_ PerlIO * f, Off_t offset, int whence)
{
PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
- STRLEN oldcur;
- STRLEN newlen;
- SvGETMAGIC(s->var);
- oldcur = SvCUR(s->var);
-
switch (whence) {
case SEEK_SET:
s->posn = offset;
@@ -107,8 +113,12 @@
s->posn = offset + s->posn;
break;
case SEEK_END:
- s->posn = offset + SvCUR(s->var);
+ {
+ STRLEN oldcur;
+ (void)SvPV(s->var, oldcur);
+ s->posn = offset + oldcur;
break;
+ }
}
if (s->posn < 0) {
if (ckWARN(WARN_LAYER))
@@ -116,17 +126,6 @@
SETERRNO(EINVAL, SS_IVCHAN);
return -1;
}
- newlen = (STRLEN) s->posn;
- if (newlen > oldcur) {
- (void) SvGROW(s->var, newlen);
- Zero(SvPVX(s->var) + oldcur, newlen - oldcur, char);
- /* No SvCUR_set(), though. This is just a seek, not a write. */
- }
- else if (!SvPVX(s->var)) {
- /* ensure there's always a character buffer */
- (void)SvGROW(s->var,1);
- }
- SvPOK_on(s->var);
return 0;
}
@@ -155,6 +154,17 @@
STRLEN len;
I32 got;
p = SvPV(sv, len);
+ if (SvUTF8(sv)) {
+ if (sv_utf8_downgrade(sv, TRUE)) {
+ p = SvPV_nomg(sv, len);
+ }
+ else {
+ if (ckWARN(WARN_UTF8))
+ Perl_warner(aTHX_ packWARN(WARN_UTF8), code_point_warning);
+ SETERRNO(EINVAL, SS_IVCHAN);
+ return -1;
+ }
+ }
got = len - (STRLEN)(s->posn);
if (got <= 0)
return 0;
@@ -175,15 +185,27 @@
SV *sv = s->var;
char *dst;
SvGETMAGIC(sv);
- sv_force_normal(sv);
+ if (!SvROK(sv)) sv_force_normal(sv);
+ if (SvOK(sv)) SvPV_force_nomg_nolen(sv);
+ if (SvUTF8(sv) && !sv_utf8_downgrade(sv, TRUE)) {
+ if (ckWARN(WARN_UTF8))
+ Perl_warner(aTHX_ packWARN(WARN_UTF8), code_point_warning);
+ SETERRNO(EINVAL, SS_IVCHAN);
+ return 0;
+ }
if ((PerlIOBase(f)->flags) & PERLIO_F_APPEND) {
- dst = SvGROW(sv, SvCUR(sv) + count);
+ dst = SvGROW(sv, SvCUR(sv) + count + 1);
offset = SvCUR(sv);
s->posn = offset + count;
}
else {
- if ((s->posn + count) > SvCUR(sv))
- dst = SvGROW(sv, (STRLEN)s->posn + count);
+ STRLEN const cur = SvCUR(sv);
+ if (s->posn > cur) {
+ dst = SvGROW(sv, (STRLEN)s->posn + count + 1);
+ Zero(SvPVX(sv) + cur, (STRLEN)s->posn - cur, char);
+ }
+ else if ((s->posn + count) >= cur)
+ dst = SvGROW(sv, (STRLEN)s->posn + count + 1);
else
dst = SvPVX(sv);
offset = s->posn;
@@ -190,8 +212,10 @@
s->posn += count;
}
Move(vbuf, dst + offset, count, char);
- if ((STRLEN) s->posn > SvCUR(sv))
+ if ((STRLEN) s->posn > SvCUR(sv)) {
SvCUR_set(sv, (STRLEN)s->posn);
+ dst[(STRLEN) s->posn] = 0;
+ }
SvPOK_on(sv);
SvSETMAGIC(sv);
return count;
@@ -240,9 +264,13 @@
{
if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
+ STRLEN len;
SvGETMAGIC(s->var);
- if (SvCUR(s->var) > (STRLEN) s->posn)
- return SvCUR(s->var) - (STRLEN)s->posn;
+ if (isGV_with_GP(s->var))
+ (void)SvPV(s->var,len);
+ else len = SvCUR(s->var);
+ if (len > (STRLEN) s->posn)
+ return len - (STRLEN)s->posn;
else
return 0;
}
@@ -264,9 +292,12 @@
PerlIOScalar_set_ptrcnt(pTHX_ PerlIO * f, STDCHAR * ptr, SSize_t cnt)
{
PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
+ STRLEN len;
PERL_UNUSED_ARG(ptr);
SvGETMAGIC(s->var);
- s->posn = SvCUR(s->var) - cnt;
+ if (isGV_with_GP(s->var)) (void)SvPV(s->var,len);
+ else len = SvCUR(s->var);
+ s->posn = len - cnt;
}
PerlIO *
@@ -311,10 +342,24 @@
PerlIOScalar_dup(pTHX_ PerlIO * f, PerlIO * o, CLONE_PARAMS * param,
int flags)
{
+ /* Duplication causes the scalar layer to be pushed on to clone, caus-
+ ing the cloned scalar to be set to the empty string by
+ PerlIOScalar_pushed. So set aside our scalar temporarily. */
+ PerlIOScalar * const os = PerlIOSelf(o, PerlIOScalar);
+ PerlIOScalar *fs;
+ SV * const var = os->var;
+ os->var = newSVpvs("");
if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) {
- PerlIOScalar *fs = PerlIOSelf(f, PerlIOScalar);
- PerlIOScalar *os = PerlIOSelf(o, PerlIOScalar);
- /* var has been set by implicit push */
+ fs = PerlIOSelf(f, PerlIOScalar);
+ /* var has been set by implicit push, so replace it */
+ SvREFCNT_dec(fs->var);
+ }
+ SvREFCNT_dec(os->var);
+ os->var = var;
+ if (f) {
+ SV * const rv = PerlIOScalar_arg(aTHX_ o, param, flags);
+ fs->var = SvREFCNT_inc(SvRV(rv));
+ SvREFCNT_dec(rv);
fs->posn = os->posn;
}
return f;
Property changes on: trunk/contrib/perl/ext/PerlIO-scalar/scalar.xs
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/ext/PerlIO-scalar/t/scalar.t
===================================================================
--- trunk/contrib/perl/ext/PerlIO-scalar/t/scalar.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/PerlIO-scalar/t/scalar.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -16,7 +16,7 @@
$| = 1;
-use Test::More tests => 71;
+use Test::More tests => 108;
my $fh;
my $var = "aaa\n";
@@ -255,7 +255,7 @@
print($fh 'DEF');
$s .= ':P';
ok(close($fh), 'close tied scalar - write');
- is($s, ':F:S():O:F:S(ABC):P:F:SK:F:S(DEF):P', 'tied actions - write');
+ is($s, ':F:S():O:F:S(ABC):P:SK:F:S(DEF):P', 'tied actions - write');
is($x, 'DEF', 'new value preserved');
$x = 'GHI';
@@ -285,10 +285,180 @@
'seek beyond end end of string followed by read';
}
-# Writing to COW scalars
+# Writing to COW scalars and non-PVs
{
my $bovid = __PACKAGE__;
open my $handel, ">", \$bovid;
print $handel "the COW with the crumpled horn";
is $bovid, "the COW with the crumpled horn", 'writing to COW scalars';
+
+ package lrcg { use overload fallback => 1, '""'=>sub { 'chin' } }
+ seek $handel, 3, 0;
+ $bovid = bless [], lrcg::;
+ print $handel 'mney';
+ is $bovid, 'chimney', 'writing to refs';
+
+ seek $handel, 1, 0;
+ $bovid = 42; # still has a PV
+ print $handel 5;
+ is $bovid, 45, 'writing to numeric scalar';
+
+ seek $handel, 1, 0;
+ undef $bovid;
+ $bovid = 42; # just IOK
+ print $handel 5;
+ is $bovid, 45, 'writing to numeric scalar';
}
+
+# [perl #92706]
+{
+ open my $fh, "<", \(my $f=*f); seek $fh, 2,1;
+ pass 'seeking on a glob copy';
+ open my $fh, "<", \(my $f=*f); seek $fh, -2,2;
+ pass 'seeking on a glob copy from the end';
+}
+
+# [perl #108398]
+sub has_trailing_nul(\$) {
+ my ($ref) = @_;
+ my $sv = B::svref_2object($ref);
+ return undef if !$sv->isa('B::PV');
+
+ my $cur = $sv->CUR;
+ my $len = $sv->LEN;
+ return 0 if $cur >= $len;
+
+ my $ptrlen = length(pack('P', ''));
+ my $ptrfmt
+ = $ptrlen == length(pack('J', 0)) ? 'J'
+ : $ptrlen == length(pack('I', 0)) ? 'I'
+ : die "Can't determine pointer format";
+
+ my $pv_addr = unpack $ptrfmt, pack 'P', $$ref;
+ my $trailing = unpack 'P', pack $ptrfmt, $pv_addr+$cur;
+ return $trailing eq "\0";
+}
+SKIP: {
+ if ($Config::Config{'extensions'} !~ m!\bPerlIO/scalar\b!) {
+ skip "no B", 3;
+ }
+ require B;
+
+ open my $fh, ">", \my $memfile or die $!;
+
+ print $fh "abc";
+ ok has_trailing_nul $memfile,
+ 'write appends trailing null when growing string';
+
+ seek $fh, 0,SEEK_SET;
+ print $fh "abc";
+ ok has_trailing_nul $memfile,
+ 'write appends trailing null when not growing string';
+
+ seek $fh, 200, SEEK_SET;
+ print $fh "abc";
+ ok has_trailing_nul $memfile,
+ 'write appends null when growing string after seek past end';
+}
+
+# [perl #112780] Cloning of in-memory handles
+SKIP: {
+ skip "no threads", 2 if !$Config::Config{useithreads};
+ require threads;
+ my $str = '';
+ open my $fh, ">", \$str;
+ $str = 'a';
+ is scalar threads::async(sub { my $foo = $str; $foo })->join, "a",
+ 'scalars behind in-memory handles are cloned properly';
+ print $fh "a";
+ is scalar threads::async(sub { print $fh "b"; $str })->join, "ab",
+ 'printing to a cloned in-memory handle works';
+}
+
+# [perl #113764] Duping via >&= (broken by the fix for #112870)
+{
+ open FILE, '>', \my $content or die "Couldn't open scalar filehandle";
+ open my $fh, ">&=FILE" or die "Couldn't open: $!";
+ print $fh "Foo-Bar\n";
+ close $fh;
+ close FILE;
+ is $content, "Foo-Bar\n", 'duping via >&=';
+}
+
+# [perl #109828] PerlIO::scalar does not handle UTF-8
+my $byte_warning = "Strings with code points over 0xFF may not be mapped into in-memory file handles\n";
+{
+ use Errno qw(EINVAL);
+ my @warnings;
+ local $SIG{__WARN__} = sub { push @warnings, "@_" };
+ my $content = "12\x{101}";
+ $! = 0;
+ ok(!open(my $fh, "<", \$content), "non-byte open should fail");
+ is(0+$!, EINVAL, "check \$! is updated");
+ is_deeply(\@warnings, [], "should be no warnings (yet)");
+ use warnings "utf8";
+ $! = 0;
+ ok(!open(my $fh, "<", \$content), "non byte open should fail (and warn)");
+ is(0+$!, EINVAL, "check \$! is updated even when we warn");
+ is_deeply(\@warnings, [ $byte_warning ], "should have warned");
+
+ @warnings = ();
+ $content = "12\xA1";
+ utf8::upgrade($content);
+ ok(open(my $fh, "<", \$content), "open upgraded scalar");
+ binmode $fh;
+ my $tmp;
+ is(read($fh, $tmp, 4), 3, "read should get the downgraded bytes");
+ is($tmp, "12\xA1", "check we got the expected bytes");
+ close $fh;
+ is_deeply(\@warnings, [], "should be no more warnings");
+}
+{ # changes after open
+ my $content = "abc";
+ ok(open(my $fh, "+<", \$content), "open a scalar");
+ binmode $fh;
+ my $tmp;
+ is(read($fh, $tmp, 1), 1, "basic read");
+ seek($fh, 1, SEEK_SET);
+ $content = "\xA1\xA2\xA3";
+ utf8::upgrade($content);
+ is(read($fh, $tmp, 1), 1, "read from post-open upgraded scalar");
+ is($tmp, "\xA2", "check we read the correct value");
+ seek($fh, 1, SEEK_SET);
+ $content = "\x{101}\x{102}\x{103}";
+
+ my @warnings;
+ local $SIG{__WARN__} = sub { push @warnings, "@_" };
+
+ $! = 0;
+ is(read($fh, $tmp, 1), undef, "read from scalar with >0xff chars");
+ is(0+$!, EINVAL, "check errno set correctly");
+ is_deeply(\@warnings, [], "should be no warning (yet)");
+ use warnings "utf8";
+ seek($fh, 1, SEEK_SET);
+ is(read($fh, $tmp, 1), undef, "read from scalar with >0xff chars");
+ is_deeply(\@warnings, [ $byte_warning ], "check warning");
+
+ select $fh; # make sure print fails rather tha buffers
+ $| = 1;
+ select STDERR;
+ no warnings "utf8";
+ @warnings = ();
+ $content = "\xA1\xA2\xA3";
+ utf8::upgrade($content);
+ seek($fh, 1, SEEK_SET);
+ ok((print $fh "A"), "print to an upgraded byte string");
+ seek($fh, 1, SEEK_SET);
+ is($content, "\xA1A\xA3", "check result");
+
+ $content = "\x{101}\x{102}\x{103}";
+ $! = 0;
+ ok(!(print $fh "B"), "write to an non-downgradable SV");
+ is(0+$!, EINVAL, "check errno set");
+
+ is_deeply(\@warnings, [], "should be no warning");
+
+ use warnings "utf8";
+ ok(!(print $fh "B"), "write to an non-downgradable SV (and warn)");
+ is_deeply(\@warnings, [ $byte_warning ], "check warning");
+}
Property changes on: trunk/contrib/perl/ext/PerlIO-scalar/t/scalar.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Index: trunk/contrib/perl/ext/PerlIO-scalar/t/scalar_ungetc.t
===================================================================
--- trunk/contrib/perl/ext/PerlIO-scalar/t/scalar_ungetc.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/PerlIO-scalar/t/scalar_ungetc.t 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/PerlIO-scalar/t/scalar_ungetc.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/PerlIO-via/hints/aix.pl
===================================================================
--- trunk/contrib/perl/ext/PerlIO-via/hints/aix.pl 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/PerlIO-via/hints/aix.pl 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/PerlIO-via/hints/aix.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/PerlIO-via/t/via.t
===================================================================
--- trunk/contrib/perl/ext/PerlIO-via/t/via.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/PerlIO-via/t/via.t 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/PerlIO-via/t/via.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/ext/PerlIO-via/via.pm
===================================================================
--- trunk/contrib/perl/ext/PerlIO-via/via.pm 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/PerlIO-via/via.pm 2013-12-02 21:32:26 UTC (rev 6445)
@@ -1,5 +1,5 @@
package PerlIO::via;
-our $VERSION = '0.11';
+our $VERSION = '0.12';
require XSLoader;
XSLoader::load();
1;
@@ -74,7 +74,7 @@
Optional - called when the layer is about to be removed.
-=item $obj->UTF8($bellowFlag,[$fh])
+=item $obj->UTF8($belowFlag,[$fh])
Optional - if present it will be called immediately after PUSHED has
returned. It should return a true value if the layer expects data to be
@@ -84,7 +84,7 @@
If not present or if it returns false, then the stream is left with
the UTF-8 flag clear.
-The I<$bellowFlag> argument will be true if there is a layer below
+The I<$belowFlag> argument will be true if there is a layer below
and that layer was expecting UTF-8.
=item $obj->OPEN($path,$mode,[$fh])
Property changes on: trunk/contrib/perl/ext/PerlIO-via/via.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/ext/PerlIO-via/via.xs
===================================================================
--- trunk/contrib/perl/ext/PerlIO-via/via.xs 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/PerlIO-via/via.xs 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/PerlIO-via/via.xs
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/ext/Pod-Html/Html.pm
===================================================================
--- trunk/contrib/perl/ext/Pod-Html/Html.pm 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/Pod-Html/Html.pm 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/Pod-Html/Html.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/Pod-Html/pod2html.PL
===================================================================
--- trunk/contrib/perl/ext/Pod-Html/pod2html.PL 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/Pod-Html/pod2html.PL 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/Pod-Html/pod2html.PL
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Copied: trunk/contrib/perl/ext/Pod-Html/t/cache.pod (from rev 6437, vendor/perl/5.18.1/ext/Pod-Html/t/cache.pod)
===================================================================
--- trunk/contrib/perl/ext/Pod-Html/t/cache.pod (rev 0)
+++ trunk/contrib/perl/ext/Pod-Html/t/cache.pod 2013-12-02 21:32:26 UTC (rev 6445)
@@ -0,0 +1,3 @@
+=head1 NAME
+
+the contents of this file doesn't matter
Copied: trunk/contrib/perl/ext/Pod-Html/t/cache.t (from rev 6437, vendor/perl/5.18.1/ext/Pod-Html/t/cache.t)
===================================================================
--- trunk/contrib/perl/ext/Pod-Html/t/cache.t (rev 0)
+++ trunk/contrib/perl/ext/Pod-Html/t/cache.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -0,0 +1,72 @@
+#!/usr/bin/perl -w # -*- perl -*-
+
+BEGIN {
+ die "Run me from outside the t/ directory, please" unless -d 't';
+}
+
+# test the directory cache
+# XXX test --flush and %Pages being loaded/used for cross references
+
+use strict;
+use Cwd;
+use Pod::Html;
+use Data::Dumper;
+use Test::More tests => 10;
+
+my $cwd = Pod::Html::_unixify(Cwd::cwd());
+my $infile = "t/cache.pod";
+my $outfile = "cacheout.html";
+my $cachefile = "pod2htmd.tmp";
+my $tcachefile = "t/pod2htmd.tmp";
+
+unlink $cachefile, $tcachefile;
+is(-f $cachefile, undef, "No cache file to start");
+is(-f $tcachefile, undef, "No cache file to start");
+
+# test podpath and podroot
+Pod::Html::pod2html(
+ "--infile=$infile",
+ "--outfile=$outfile",
+ "--podpath=scooby:shaggy:fred:velma:daphne",
+ "--podroot=$cwd",
+ );
+is(-f $cachefile, 1, "Cache created");
+open(my $cache, '<', $cachefile) or die "Cannot open cache file: $!";
+chomp(my $podpath = <$cache>);
+chomp(my $podroot = <$cache>);
+close $cache;
+is($podpath, "scooby:shaggy:fred:velma:daphne", "podpath");
+is($podroot, "$cwd", "podroot");
+
+# test cache contents
+Pod::Html::pod2html(
+ "--infile=$infile",
+ "--outfile=$outfile",
+ "--cachedir=t",
+ "--podpath=t",
+ "--htmldir=$cwd",
+ );
+is(-f $tcachefile, 1, "Cache created");
+open($cache, '<', $tcachefile) or die "Cannot open cache file: $!";
+chomp($podpath = <$cache>);
+chomp($podroot = <$cache>);
+is($podpath, "t", "podpath");
+my %pages;
+while (<$cache>) {
+ /(.*?) (.*)$/;
+ $pages{$1} = $2;
+}
+chdir("t");
+my %expected_pages =
+ # chop off the .pod and set the path
+ map { my $f = substr($_, 0, -4); $f => "t/$f" }
+ <*.pod>;
+chdir($cwd);
+is_deeply(\%pages, \%expected_pages, "cache contents");
+close $cache;
+
+1 while unlink $outfile;
+1 while unlink $cachefile;
+1 while unlink $tcachefile;
+is(-f $cachefile, undef, "No cache file to end");
+is(-f $tcachefile, undef, "No cache file to end");
Copied: trunk/contrib/perl/ext/Pod-Html/t/crossref.pod (from rev 6437, vendor/perl/5.18.1/ext/Pod-Html/t/crossref.pod)
===================================================================
--- trunk/contrib/perl/ext/Pod-Html/t/crossref.pod (rev 0)
+++ trunk/contrib/perl/ext/Pod-Html/t/crossref.pod 2013-12-02 21:32:26 UTC (rev 6445)
@@ -0,0 +1,41 @@
+=head1 NAME
+
+htmlcrossref - Test HTML cross reference links
+
+=head1 LINKS
+
+L</"section1">
+
+L<htmllink/section 2>
+
+L</"item1">
+
+L</"non existant section">
+
+L<var-copy>
+
+L<var-copy/$">
+
+C<var-copy>
+
+C<var-copy/$">
+
+L<podspec-copy/First:>
+
+C<podspec-copy/First:>
+
+L<notperldoc>
+
+=head1 TARGETS
+
+=head2 section1
+
+This is section one.
+
+=over 4
+
+=item item1 X<item> X<one>
+
+This is item one.
+
+=back
Copied: trunk/contrib/perl/ext/Pod-Html/t/crossref.t (from rev 6437, vendor/perl/5.18.1/ext/Pod-Html/t/crossref.t)
===================================================================
--- trunk/contrib/perl/ext/Pod-Html/t/crossref.t (rev 0)
+++ trunk/contrib/perl/ext/Pod-Html/t/crossref.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -0,0 +1,106 @@
+#!/usr/bin/perl -w # -*- perl -*-
+
+BEGIN {
+ require "t/pod2html-lib.pl";
+}
+
+END {
+ rem_test_dir();
+}
+
+use strict;
+use Cwd;
+use File::Spec::Functions;
+use Test::More tests => 1;
+
+SKIP: {
+ my $output = make_test_dir();
+ skip "$output", 1 if $output;
+
+ my ($v, $d) = splitpath(cwd(), 1);
+ my @dirs = splitdir($d);
+ shift @dirs if $dirs[0] eq '';
+ my $relcwd = join '/', @dirs;
+
+ convert_n_test("crossref", "cross references",
+ "--podpath=". File::Spec::Unix->catdir($relcwd, 't') . ":"
+ . File::Spec::Unix->catdir($relcwd, 'testdir/test.lib'),
+ "--podroot=". catpath($v, '/', ''),
+ "--quiet",
+ );
+}
+
+__DATA__
+<?xml version="1.0" ?>
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
+<html xmlns="http://www.w3.org/1999/xhtml">
+<head>
+<title></title>
+<meta http-equiv="content-type" content="text/html; charset=utf-8" />
+<link rev="made" href="mailto:[PERLADMIN]" />
+</head>
+
+<body style="background-color: white">
+
+
+
+<ul id="index">
+ <li><a href="#NAME">NAME</a></li>
+ <li><a href="#LINKS">LINKS</a></li>
+ <li><a href="#TARGETS">TARGETS</a>
+ <ul>
+ <li><a href="#section1">section1</a></li>
+ </ul>
+ </li>
+</ul>
+
+<h1 id="NAME">NAME</h1>
+
+<p>htmlcrossref - Test HTML cross reference links</p>
+
+<h1 id="LINKS">LINKS</h1>
+
+<p><a href="#section1">"section1"</a></p>
+
+<p><a href="/[RELCURRENTWORKINGDIRECTORY]/t/htmllink.html#section-2">"section 2" in htmllink</a></p>
+
+<p><a href="#item1">"item1"</a></p>
+
+<p><a href="#non-existant-section">"non existant section"</a></p>
+
+<p><a href="/[RELCURRENTWORKINGDIRECTORY]/testdir/test.lib/var-copy.html">var-copy</a></p>
+
+<p><a href="/[RELCURRENTWORKINGDIRECTORY]/testdir/test.lib/var-copy.html#pod">"$"" in var-copy</a></p>
+
+<p><code>var-copy</code></p>
+
+<p><code>var-copy/$"</code></p>
+
+<p><a href="/[RELCURRENTWORKINGDIRECTORY]/testdir/test.lib/podspec-copy.html#First">"First:" in podspec-copy</a></p>
+
+<p><code>podspec-copy/First:</code></p>
+
+<p><a>notperldoc</a></p>
+
+<h1 id="TARGETS">TARGETS</h1>
+
+<h2 id="section1">section1</h2>
+
+<p>This is section one.</p>
+
+<dl>
+
+<dt id="item1">item1 </dt>
+<dd>
+
+<p>This is item one.</p>
+
+</dd>
+</dl>
+
+
+</body>
+
+</html>
+
+
Copied: trunk/contrib/perl/ext/Pod-Html/t/crossref2.t (from rev 6437, vendor/perl/5.18.1/ext/Pod-Html/t/crossref2.t)
===================================================================
--- trunk/contrib/perl/ext/Pod-Html/t/crossref2.t (rev 0)
+++ trunk/contrib/perl/ext/Pod-Html/t/crossref2.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -0,0 +1,102 @@
+#!/usr/bin/perl -w # -*- perl -*-
+
+BEGIN {
+ require "t/pod2html-lib.pl";
+}
+
+END {
+ rem_test_dir();
+}
+
+use strict;
+use Cwd;
+use Test::More tests => 1;
+
+SKIP: {
+ my $output = make_test_dir();
+ skip "$output", 1 if $output;
+
+ my $cwd = Pod::Html::_unixify(cwd());
+
+ convert_n_test("crossref", "cross references",
+ "--podpath=t:testdir/test.lib",
+ "--podroot=$cwd",
+ "--htmldir=$cwd",
+ "--quiet",
+ );
+}
+
+__DATA__
+<?xml version="1.0" ?>
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
+<html xmlns="http://www.w3.org/1999/xhtml">
+<head>
+<title></title>
+<meta http-equiv="content-type" content="text/html; charset=utf-8" />
+<link rev="made" href="mailto:[PERLADMIN]" />
+</head>
+
+<body style="background-color: white">
+
+
+
+<ul id="index">
+ <li><a href="#NAME">NAME</a></li>
+ <li><a href="#LINKS">LINKS</a></li>
+ <li><a href="#TARGETS">TARGETS</a>
+ <ul>
+ <li><a href="#section1">section1</a></li>
+ </ul>
+ </li>
+</ul>
+
+<h1 id="NAME">NAME</h1>
+
+<p>htmlcrossref - Test HTML cross reference links</p>
+
+<h1 id="LINKS">LINKS</h1>
+
+<p><a href="#section1">"section1"</a></p>
+
+<p><a href="./htmllink.html#section-2">"section 2" in htmllink</a></p>
+
+<p><a href="#item1">"item1"</a></p>
+
+<p><a href="#non-existant-section">"non existant section"</a></p>
+
+<p><a href="../testdir/test.lib/var-copy.html">var-copy</a></p>
+
+<p><a href="../testdir/test.lib/var-copy.html#pod">"$"" in var-copy</a></p>
+
+<p><code>var-copy</code></p>
+
+<p><code>var-copy/$"</code></p>
+
+<p><a href="../testdir/test.lib/podspec-copy.html#First">"First:" in podspec-copy</a></p>
+
+<p><code>podspec-copy/First:</code></p>
+
+<p><a>notperldoc</a></p>
+
+<h1 id="TARGETS">TARGETS</h1>
+
+<h2 id="section1">section1</h2>
+
+<p>This is section one.</p>
+
+<dl>
+
+<dt id="item1">item1 </dt>
+<dd>
+
+<p>This is item one.</p>
+
+</dd>
+</dl>
+
+
+</body>
+
+</html>
+
+
Copied: trunk/contrib/perl/ext/Pod-Html/t/crossref3.t (from rev 6437, vendor/perl/5.18.1/ext/Pod-Html/t/crossref3.t)
===================================================================
--- trunk/contrib/perl/ext/Pod-Html/t/crossref3.t (rev 0)
+++ trunk/contrib/perl/ext/Pod-Html/t/crossref3.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -0,0 +1,102 @@
+#!/usr/bin/perl -w # -*- perl -*-
+
+BEGIN {
+ require "t/pod2html-lib.pl";
+}
+
+END {
+ rem_test_dir();
+}
+
+use strict;
+use Cwd;
+use Test::More tests => 1;
+
+SKIP: {
+ my $output = make_test_dir();
+ skip "$output", 1 if $output;
+
+ my $cwd = cwd();
+
+ convert_n_test("crossref", "cross references",
+ "--podpath=t:testdir/test.lib",
+ "--podroot=$cwd",
+ "--htmlroot=$cwd",
+ "--quiet",
+ );
+}
+
+__DATA__
+<?xml version="1.0" ?>
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
+<html xmlns="http://www.w3.org/1999/xhtml">
+<head>
+<title></title>
+<meta http-equiv="content-type" content="text/html; charset=utf-8" />
+<link rev="made" href="mailto:[PERLADMIN]" />
+</head>
+
+<body style="background-color: white">
+
+
+
+<ul id="index">
+ <li><a href="#NAME">NAME</a></li>
+ <li><a href="#LINKS">LINKS</a></li>
+ <li><a href="#TARGETS">TARGETS</a>
+ <ul>
+ <li><a href="#section1">section1</a></li>
+ </ul>
+ </li>
+</ul>
+
+<h1 id="NAME">NAME</h1>
+
+<p>htmlcrossref - Test HTML cross reference links</p>
+
+<h1 id="LINKS">LINKS</h1>
+
+<p><a href="#section1">"section1"</a></p>
+
+<p><a href="[ABSCURRENTWORKINGDIRECTORY]/t/htmllink.html#section-2">"section 2" in htmllink</a></p>
+
+<p><a href="#item1">"item1"</a></p>
+
+<p><a href="#non-existant-section">"non existant section"</a></p>
+
+<p><a href="[ABSCURRENTWORKINGDIRECTORY]/testdir/test.lib/var-copy.html">var-copy</a></p>
+
+<p><a href="[ABSCURRENTWORKINGDIRECTORY]/testdir/test.lib/var-copy.html#pod">"$"" in var-copy</a></p>
+
+<p><code>var-copy</code></p>
+
+<p><code>var-copy/$"</code></p>
+
+<p><a href="[ABSCURRENTWORKINGDIRECTORY]/testdir/test.lib/podspec-copy.html#First">"First:" in podspec-copy</a></p>
+
+<p><code>podspec-copy/First:</code></p>
+
+<p><a>notperldoc</a></p>
+
+<h1 id="TARGETS">TARGETS</h1>
+
+<h2 id="section1">section1</h2>
+
+<p>This is section one.</p>
+
+<dl>
+
+<dt id="item1">item1 </dt>
+<dd>
+
+<p>This is item one.</p>
+
+</dd>
+</dl>
+
+
+</body>
+
+</html>
+
+
Copied: trunk/contrib/perl/ext/Pod-Html/t/eol.t (from rev 6437, vendor/perl/5.18.1/ext/Pod-Html/t/eol.t)
===================================================================
--- trunk/contrib/perl/ext/Pod-Html/t/eol.t (rev 0)
+++ trunk/contrib/perl/ext/Pod-Html/t/eol.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -0,0 +1,71 @@
+#!./perl -w
+
+use Test::More tests => 3;
+
+my $podfile = "$$.pod";
+my $infile = "$$.in";
+my @outfile = map { "$$.o$_" } 0..2;
+
+open my $pod, '>', $podfile or die "$podfile: $!";
+print $pod <<__EOF__;
+=pod
+
+=head1 NAME
+
+crlf
+
+=head1 DESCRIPTION
+
+crlf crlf crlf crlf crlf crlf crlf crlf crlf crlf crlf crlf crlf crlf crlf
+crlf crlf crlf crlf crlf crlf crlf crlf crlf crlf crlf crlf crlf crlf crlf
+crlf crlf crlf crlf crlf crlf crlf crlf crlf crlf crlf crlf crlf crlf crlf
+crlf crlf crlf crlf crlf crlf crlf crlf crlf crlf crlf crlf crlf crlf crlf
+
+ crlf crlf crlf crlf
+ crlf crlf crlf crlf
+ crlf crlf crlf crlf
+
+crlf crlf crlf crlf crlf crlf crlf crlf crlf crlf crlf crlf crlf crlf crlf
+crlf crlf crlf crlf crlf crlf crlf crlf crlf crlf crlf crlf crlf crlf crlf
+crlf crlf crlf crlf crlf crlf crlf crlf crlf crlf crlf crlf crlf crlf crlf
+crlf crlf crlf crlf crlf crlf crlf crlf crlf crlf crlf crlf crlf crlf crlf
+
+=cut
+__EOF__
+close $pod or die $!;
+
+use Pod::Html;
+
+my $i = 0;
+foreach my $eol ("\r", "\n", "\r\n") {
+ open $pod, '<', $podfile or die "$podfile: $!";
+ open my $in, '>', $infile or die "$infile: $!";
+ while (<$pod>) {
+ s/[\r\n]+/$eol/g;
+ print $in $_;
+ }
+ close $pod or die $!;
+ close $in or die $!;
+
+ pod2html("--title=eol", "--infile=$infile", "--outfile=$outfile[$i]");
+ ++$i;
+}
+
+# --- now test ---
+
+my @cksum;
+
+foreach (0..2) {
+ local $/;
+ open my $in, '<', $outfile[$_] or die "$outfile[$_]: $!";
+ $cksum[$_] = unpack "%32C*", <$in>;
+ close $in or die $!;
+}
+
+is($cksum[0], $cksum[1], "CR vs LF");
+is($cksum[0], $cksum[2], "CR vs CRLF");
+is($cksum[1], $cksum[2], "LF vs CRLF");
+
+END {
+ 1 while unlink $podfile, $infile, @outfile, 'pod2htmd.tmp';
+}
Copied: trunk/contrib/perl/ext/Pod-Html/t/feature.pod (from rev 6437, vendor/perl/5.18.1/ext/Pod-Html/t/feature.pod)
===================================================================
--- trunk/contrib/perl/ext/Pod-Html/t/feature.pod (rev 0)
+++ trunk/contrib/perl/ext/Pod-Html/t/feature.pod 2013-12-02 21:32:26 UTC (rev 6445)
@@ -0,0 +1,21 @@
+=head1 Head 1
+
+A paragraph
+
+=for html some html
+
+=begin image
+
+|--|
+| |
+|--|
+
+=end image
+
+Another paragraph
+
+=head1 Another Head 1
+
+some text and a link L<crossref>
+
+=cut
Copied: trunk/contrib/perl/ext/Pod-Html/t/feature.t (from rev 6437, vendor/perl/5.18.1/ext/Pod-Html/t/feature.t)
===================================================================
--- trunk/contrib/perl/ext/Pod-Html/t/feature.t (rev 0)
+++ trunk/contrib/perl/ext/Pod-Html/t/feature.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -0,0 +1,70 @@
+#!/usr/bin/perl -w # -*- perl -*-
+
+BEGIN {
+ require "t/pod2html-lib.pl";
+}
+
+use strict;
+use Cwd;
+use File::Spec::Functions;
+use Test::More tests => 1;
+
+my $cwd = cwd();
+
+convert_n_test("feature", "misc pod-html features",
+ "--backlink",
+ "--css=style.css",
+ "--header", # no styling b/c of --ccs
+ "--htmldir=". catdir($cwd, 't'),
+ "--noindex",
+ "--podpath=t",
+ "--podroot=$cwd",
+ "--title=a title",
+ "--quiet",
+ );
+
+__DATA__
+<?xml version="1.0" ?>
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
+<html xmlns="http://www.w3.org/1999/xhtml">
+<head>
+<title>a title</title>
+<link rel="stylesheet" href="style.css" type="text/css" />
+<meta http-equiv="content-type" content="text/html; charset=utf-8" />
+<link rev="made" href="mailto:[PERLADMIN]" />
+</head>
+
+<body id="_podtop_">
+<table border="0" width="100%" cellspacing="0" cellpadding="3">
+<tr><td class="_podblock_" valign="middle">
+<big><strong><span class="_podblock_"> a title</span></strong></big>
+</td></tr>
+</table>
+
+
+
+<a href="#_podtop_"><h1 id="Head-1">Head 1</h1></a>
+
+<p>A paragraph</p>
+
+
+
+some html
+
+<p>Another paragraph</p>
+
+<a href="#_podtop_"><h1 id="Another-Head-1">Another Head 1</h1></a>
+
+<p>some text and a link <a href="t/crossref.html">crossref</a></p>
+
+<table border="0" width="100%" cellspacing="0" cellpadding="3">
+<tr><td class="_podblock_" valign="middle">
+<big><strong><span class="_podblock_"> a title</span></strong></big>
+</td></tr>
+</table>
+
+</body>
+
+</html>
+
+
Copied: trunk/contrib/perl/ext/Pod-Html/t/feature2.pod (from rev 6437, vendor/perl/5.18.1/ext/Pod-Html/t/feature2.pod)
===================================================================
--- trunk/contrib/perl/ext/Pod-Html/t/feature2.pod (rev 0)
+++ trunk/contrib/perl/ext/Pod-Html/t/feature2.pod 2013-12-02 21:32:26 UTC (rev 6445)
@@ -0,0 +1,21 @@
+=head1 Head 1
+
+A paragraph
+
+=for html some html
+
+=begin image
+
+|--|
+| |
+|--|
+
+=end image
+
+Another paragraph
+
+=head1 Another Head 1
+
+some text and a link L<crossref>
+
+=cut
Copied: trunk/contrib/perl/ext/Pod-Html/t/feature2.t (from rev 6437, vendor/perl/5.18.1/ext/Pod-Html/t/feature2.t)
===================================================================
--- trunk/contrib/perl/ext/Pod-Html/t/feature2.t (rev 0)
+++ trunk/contrib/perl/ext/Pod-Html/t/feature2.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -0,0 +1,82 @@
+#!/usr/bin/perl -w # -*- perl -*-
+
+
+BEGIN {
+ require "t/pod2html-lib.pl";
+}
+
+use strict;
+use Cwd;
+use Test::More tests => 2;
+
+my $cwd = cwd();
+
+my $warn;
+$SIG{__WARN__} = sub { $warn .= $_[0] };
+
+convert_n_test("feature2", "misc pod-html features 2",
+ "--backlink",
+ "--header",
+ "--podpath=.",
+ "--podroot=$cwd",
+ "--norecurse",
+ "--verbose",
+ "--quiet",
+ );
+
+like($warn,
+ qr(
+ \Acaching\ directories\ for\ later\ use\n
+ Converting\ input\ file\ \S+[/\\\]]feature2\.pod\n\z
+ )x,
+ "misc pod-html --verbose warnings");
+
+__DATA__
+<?xml version="1.0" ?>
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
+<html xmlns="http://www.w3.org/1999/xhtml">
+<head>
+<title></title>
+<meta http-equiv="content-type" content="text/html; charset=utf-8" />
+<link rev="made" href="mailto:[PERLADMIN]" />
+</head>
+
+<body id="_podtop_" style="background-color: white">
+<table border="0" width="100%" cellspacing="0" cellpadding="3">
+<tr><td class="_podblock_" style="background-color: #cccccc" valign="middle">
+<big><strong><span class="_podblock_"> </span></strong></big>
+</td></tr>
+</table>
+
+
+
+<ul id="index">
+ <li><a href="#Head-1">Head 1</a></li>
+ <li><a href="#Another-Head-1">Another Head 1</a></li>
+</ul>
+
+<a href="#_podtop_"><h1 id="Head-1">Head 1</h1></a>
+
+<p>A paragraph</p>
+
+
+
+some html
+
+<p>Another paragraph</p>
+
+<a href="#_podtop_"><h1 id="Another-Head-1">Another Head 1</h1></a>
+
+<p>some text and a link <a>crossref</a></p>
+
+<table border="0" width="100%" cellspacing="0" cellpadding="3">
+<tr><td class="_podblock_" style="background-color: #cccccc" valign="middle">
+<big><strong><span class="_podblock_"> </span></strong></big>
+</td></tr>
+</table>
+
+</body>
+
+</html>
+
+
Copied: trunk/contrib/perl/ext/Pod-Html/t/htmldir1.pod (from rev 6437, vendor/perl/5.18.1/ext/Pod-Html/t/htmldir1.pod)
===================================================================
--- trunk/contrib/perl/ext/Pod-Html/t/htmldir1.pod (rev 0)
+++ trunk/contrib/perl/ext/Pod-Html/t/htmldir1.pod 2013-12-02 21:32:26 UTC (rev 6445)
@@ -0,0 +1,17 @@
+=head1 NAME
+
+htmldir - Test --htmldir feature
+
+=head1 LINKS
+
+ Verbatim B<means> verbatim.
+
+Normal text, a L<link> to nowhere,
+
+a link to L<var-copy>,
+
+L<htmlescp>,
+
+L<feature/Another Head 1>,
+
+and another L<feature/"Another Head 1">.
Copied: trunk/contrib/perl/ext/Pod-Html/t/htmldir1.t (from rev 6437, vendor/perl/5.18.1/ext/Pod-Html/t/htmldir1.t)
===================================================================
--- trunk/contrib/perl/ext/Pod-Html/t/htmldir1.t (rev 0)
+++ trunk/contrib/perl/ext/Pod-Html/t/htmldir1.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -0,0 +1,92 @@
+#!/usr/bin/perl -w # -*- perl -*-
+
+BEGIN {
+ require "t/pod2html-lib.pl";
+}
+
+END {
+ rem_test_dir();
+}
+
+use strict;
+use Cwd;
+use File::Spec::Functions;
+use Test::More tests => 2;
+
+# XXX Separate tests that rely on test.lib from the others so they are the only
+# ones skipped (instead of all of them). This applies to htmldir{1,3,5}.t, and
+# crossref.t (as of 10/29/11).
+SKIP: {
+ my $output = make_test_dir();
+ skip "$output", 2 if $output;
+
+ my ($v, $d) = splitpath(cwd(), 1);
+ my @dirs = splitdir($d);
+ shift @dirs if $dirs[0] eq '';
+ my $relcwd = join '/', @dirs;
+
+ my $data_pos = tell DATA; # to read <DATA> twice
+
+
+ convert_n_test("htmldir1", "test --htmldir and --htmlroot 1a",
+ "--podpath=". File::Spec::Unix->catdir($relcwd, 't') . ":"
+ . File::Spec::Unix->catdir($relcwd, 'testdir/test.lib'),
+ "--podroot=". catpath($v, '/', ''),
+ "--htmldir=t",
+ "--quiet",
+ );
+
+ seek DATA, $data_pos, 0; # to read <DATA> twice (expected output is the same)
+
+ convert_n_test("htmldir1", "test --htmldir and --htmlroot 1b",
+ "--podpath=$relcwd",
+ "--podroot=". catpath($v, '/', ''),
+ "--htmldir=". catdir($relcwd, 't'),
+ "--htmlroot=/",
+ "--quiet",
+ );
+}
+
+__DATA__
+<?xml version="1.0" ?>
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
+<html xmlns="http://www.w3.org/1999/xhtml">
+<head>
+<title></title>
+<meta http-equiv="content-type" content="text/html; charset=utf-8" />
+<link rev="made" href="mailto:[PERLADMIN]" />
+</head>
+
+<body style="background-color: white">
+
+
+
+<ul id="index">
+ <li><a href="#NAME">NAME</a></li>
+ <li><a href="#LINKS">LINKS</a></li>
+</ul>
+
+<h1 id="NAME">NAME</h1>
+
+<p>htmldir - Test --htmldir feature</p>
+
+<h1 id="LINKS">LINKS</h1>
+
+<pre><code> Verbatim B<means> verbatim.</code></pre>
+
+<p>Normal text, a <a>link</a> to nowhere,</p>
+
+<p>a link to <a href="/[RELCURRENTWORKINGDIRECTORY]/testdir/test.lib/var-copy.html">var-copy</a>,</p>
+
+<p><a href="/[RELCURRENTWORKINGDIRECTORY]/t/htmlescp.html">htmlescp</a>,</p>
+
+<p><a href="/[RELCURRENTWORKINGDIRECTORY]/t/feature.html#Another-Head-1">"Another Head 1" in feature</a>,</p>
+
+<p>and another <a href="/[RELCURRENTWORKINGDIRECTORY]/t/feature.html#Another-Head-1">"Another Head 1" in feature</a>.</p>
+
+
+</body>
+
+</html>
+
+
Copied: trunk/contrib/perl/ext/Pod-Html/t/htmldir2.pod (from rev 6437, vendor/perl/5.18.1/ext/Pod-Html/t/htmldir2.pod)
===================================================================
--- trunk/contrib/perl/ext/Pod-Html/t/htmldir2.pod (rev 0)
+++ trunk/contrib/perl/ext/Pod-Html/t/htmldir2.pod 2013-12-02 21:32:26 UTC (rev 6445)
@@ -0,0 +1,15 @@
+=head1 NAME
+
+htmldir - Test --htmldir feature
+
+=head1 LINKS
+
+Normal text, a L<link> to nowhere,
+
+a link to L<perlvar-copy>,
+
+L<htmlescp>,
+
+L<feature/Another Head 1>,
+
+and another L<feature/"Another Head 1">.
Copied: trunk/contrib/perl/ext/Pod-Html/t/htmldir2.t (from rev 6437, vendor/perl/5.18.1/ext/Pod-Html/t/htmldir2.t)
===================================================================
--- trunk/contrib/perl/ext/Pod-Html/t/htmldir2.t (rev 0)
+++ trunk/contrib/perl/ext/Pod-Html/t/htmldir2.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -0,0 +1,77 @@
+#!/usr/bin/perl -w # -*- perl -*-
+
+BEGIN {
+ require "t/pod2html-lib.pl";
+}
+
+use strict;
+use Cwd;
+use Test::More tests => 3;
+
+my $cwd = cwd();
+my $data_pos = tell DATA; # to read <DATA> twice
+
+convert_n_test("htmldir2", "test --htmldir and --htmlroot 2a",
+ "--podpath=t",
+ "--htmldir=t",
+ "--quiet",
+);
+
+seek DATA, $data_pos, 0; # to read <DATA> twice (expected output is the same)
+
+convert_n_test("htmldir2", "test --htmldir and --htmlroot 2b",
+ "--podpath=t",
+ "--quiet",
+);
+
+seek DATA, $data_pos, 0; # to read <DATA> thrice (expected output is the same)
+
+# this test makes sure paths are absolute unless --htmldir is specified
+convert_n_test("htmldir2", "test --htmldir and --htmlroot 2c",
+ "--podpath=t",
+ "--podroot=$cwd",
+ "--norecurse", # testing --norecurse, too
+ "--quiet",
+);
+
+__DATA__
+<?xml version="1.0" ?>
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
+<html xmlns="http://www.w3.org/1999/xhtml">
+<head>
+<title></title>
+<meta http-equiv="content-type" content="text/html; charset=utf-8" />
+<link rev="made" href="mailto:[PERLADMIN]" />
+</head>
+
+<body style="background-color: white">
+
+
+
+<ul id="index">
+ <li><a href="#NAME">NAME</a></li>
+ <li><a href="#LINKS">LINKS</a></li>
+</ul>
+
+<h1 id="NAME">NAME</h1>
+
+<p>htmldir - Test --htmldir feature</p>
+
+<h1 id="LINKS">LINKS</h1>
+
+<p>Normal text, a <a>link</a> to nowhere,</p>
+
+<p>a link to <a>perlvar-copy</a>,</p>
+
+<p><a href="/t/htmlescp.html">htmlescp</a>,</p>
+
+<p><a href="/t/feature.html#Another-Head-1">"Another Head 1" in feature</a>,</p>
+
+<p>and another <a href="/t/feature.html#Another-Head-1">"Another Head 1" in feature</a>.</p>
+
+
+</body>
+
+</html>
+
+
Copied: trunk/contrib/perl/ext/Pod-Html/t/htmldir3.pod (from rev 6437, vendor/perl/5.18.1/ext/Pod-Html/t/htmldir3.pod)
===================================================================
--- trunk/contrib/perl/ext/Pod-Html/t/htmldir3.pod (rev 0)
+++ trunk/contrib/perl/ext/Pod-Html/t/htmldir3.pod 2013-12-02 21:32:26 UTC (rev 6445)
@@ -0,0 +1,15 @@
+=head1 NAME
+
+htmldir - Test --htmldir feature
+
+=head1 LINKS
+
+Normal text, a L<link> to nowhere,
+
+a link to L<var-copy>,
+
+L<htmlescp>,
+
+L<feature/Another Head 1>,
+
+and another L<feature/"Another Head 1">.
Copied: trunk/contrib/perl/ext/Pod-Html/t/htmldir3.t (from rev 6437, vendor/perl/5.18.1/ext/Pod-Html/t/htmldir3.t)
===================================================================
--- trunk/contrib/perl/ext/Pod-Html/t/htmldir3.t (rev 0)
+++ trunk/contrib/perl/ext/Pod-Html/t/htmldir3.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -0,0 +1,86 @@
+#!/usr/bin/perl -w # -*- perl -*-
+
+BEGIN {
+ require "t/pod2html-lib.pl";
+}
+
+END {
+ rem_test_dir();
+}
+
+use strict;
+use Cwd;
+use File::Spec::Functions;
+use Test::More tests => 2;
+
+SKIP: {
+ my $output = make_test_dir();
+ skip "$output", 2 if $output;
+
+ my $cwd = cwd();
+ my ($v, $d) = splitpath($cwd, 1);
+ my @dirs = splitdir($d);
+ shift @dirs if $dirs[0] eq '';
+ my $relcwd = join '/', @dirs;
+
+ my $data_pos = tell DATA; # to read <DATA> twice
+
+ convert_n_test("htmldir3", "test --htmldir and --htmlroot 3a",
+ "--podpath=$relcwd",
+ "--podroot=". catpath($v, '/', ''),
+ "--htmldir=". catdir($cwd, 't', ''), # test removal trailing slash,
+ "--quiet",
+ );
+
+ seek DATA, $data_pos, 0; # to read <DATA> twice (expected output is the same)
+
+ convert_n_test("htmldir3", "test --htmldir and --htmlroot 3b",
+ "--podpath=". catdir($relcwd, 't'),
+ "--podroot=". catpath($v, '/', ''),
+ "--htmldir=t",
+ "--outfile=t/htmldir3.html",
+ "--quiet",
+ );
+}
+
+__DATA__
+<?xml version="1.0" ?>
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
+<html xmlns="http://www.w3.org/1999/xhtml">
+<head>
+<title></title>
+<meta http-equiv="content-type" content="text/html; charset=utf-8" />
+<link rev="made" href="mailto:[PERLADMIN]" />
+</head>
+
+<body style="background-color: white">
+
+
+
+<ul id="index">
+ <li><a href="#NAME">NAME</a></li>
+ <li><a href="#LINKS">LINKS</a></li>
+</ul>
+
+<h1 id="NAME">NAME</h1>
+
+<p>htmldir - Test --htmldir feature</p>
+
+<h1 id="LINKS">LINKS</h1>
+
+<p>Normal text, a <a>link</a> to nowhere,</p>
+
+<p>a link to <a href="[RELCURRENTWORKINGDIRECTORY]/testdir/test.lib/var-copy.html">var-copy</a>,</p>
+
+<p><a href="[RELCURRENTWORKINGDIRECTORY]/t/htmlescp.html">htmlescp</a>,</p>
+
+<p><a href="[RELCURRENTWORKINGDIRECTORY]/t/feature.html#Another-Head-1">"Another Head 1" in feature</a>,</p>
+
+<p>and another <a href="[RELCURRENTWORKINGDIRECTORY]/t/feature.html#Another-Head-1">"Another Head 1" in feature</a>.</p>
+
+
+</body>
+
+</html>
+
+
Copied: trunk/contrib/perl/ext/Pod-Html/t/htmldir4.pod (from rev 6437, vendor/perl/5.18.1/ext/Pod-Html/t/htmldir4.pod)
===================================================================
--- trunk/contrib/perl/ext/Pod-Html/t/htmldir4.pod (rev 0)
+++ trunk/contrib/perl/ext/Pod-Html/t/htmldir4.pod 2013-12-02 21:32:26 UTC (rev 6445)
@@ -0,0 +1,15 @@
+=head1 NAME
+
+htmldir - Test --htmldir feature
+
+=head1 LINKS
+
+Normal text, a L<link> to nowhere,
+
+a link to L<perlvar-copy>,
+
+L<htmlescp>,
+
+L<feature/Another Head 1>,
+
+and another L<feature/"Another Head 1">.
Copied: trunk/contrib/perl/ext/Pod-Html/t/htmldir4.t (from rev 6437, vendor/perl/5.18.1/ext/Pod-Html/t/htmldir4.t)
===================================================================
--- trunk/contrib/perl/ext/Pod-Html/t/htmldir4.t (rev 0)
+++ trunk/contrib/perl/ext/Pod-Html/t/htmldir4.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -0,0 +1,72 @@
+#!/usr/bin/perl -w # -*- perl -*-
+
+BEGIN {
+ require "t/pod2html-lib.pl";
+}
+
+use strict;
+use Cwd;
+use File::Spec::Functions ':ALL';
+use Test::More tests => 2;
+
+my $cwd = cwd();
+my $data_pos = tell DATA; # to read <DATA> twice
+
+convert_n_test("htmldir4", "test --htmldir and --htmlroot 4a",
+ "--podpath=t",
+ "--htmldir=t",
+ "--outfile=". catfile('t', 'htmldir4.html'),
+ "--quiet",
+);
+
+seek DATA, $data_pos, 0; # to read <DATA> twice (expected output is the same)
+
+convert_n_test("htmldir4", "test --htmldir and --htmlroot 4b",
+ "--podpath=t",
+ "--podroot=$cwd",
+ "--htmldir=". catdir($cwd, 't'),
+ "--norecurse",
+ "--quiet",
+);
+
+__DATA__
+<?xml version="1.0" ?>
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
+<html xmlns="http://www.w3.org/1999/xhtml">
+<head>
+<title></title>
+<meta http-equiv="content-type" content="text/html; charset=utf-8" />
+<link rev="made" href="mailto:[PERLADMIN]" />
+</head>
+
+<body style="background-color: white">
+
+
+
+<ul id="index">
+ <li><a href="#NAME">NAME</a></li>
+ <li><a href="#LINKS">LINKS</a></li>
+</ul>
+
+<h1 id="NAME">NAME</h1>
+
+<p>htmldir - Test --htmldir feature</p>
+
+<h1 id="LINKS">LINKS</h1>
+
+<p>Normal text, a <a>link</a> to nowhere,</p>
+
+<p>a link to <a>perlvar-copy</a>,</p>
+
+<p><a href="t/htmlescp.html">htmlescp</a>,</p>
+
+<p><a href="t/feature.html#Another-Head-1">"Another Head 1" in feature</a>,</p>
+
+<p>and another <a href="t/feature.html#Another-Head-1">"Another Head 1" in feature</a>.</p>
+
+
+</body>
+
+</html>
+
+
Copied: trunk/contrib/perl/ext/Pod-Html/t/htmldir5.pod (from rev 6437, vendor/perl/5.18.1/ext/Pod-Html/t/htmldir5.pod)
===================================================================
--- trunk/contrib/perl/ext/Pod-Html/t/htmldir5.pod (rev 0)
+++ trunk/contrib/perl/ext/Pod-Html/t/htmldir5.pod 2013-12-02 21:32:26 UTC (rev 6445)
@@ -0,0 +1,15 @@
+=head1 NAME
+
+htmldir - Test --htmldir feature
+
+=head1 LINKS
+
+Normal text, a L<link> to nowhere,
+
+a link to L<var-copy>,
+
+L<htmlescp>,
+
+L<feature/Another Head 1>,
+
+and another L<feature/"Another Head 1">.
Copied: trunk/contrib/perl/ext/Pod-Html/t/htmldir5.t (from rev 6437, vendor/perl/5.18.1/ext/Pod-Html/t/htmldir5.t)
===================================================================
--- trunk/contrib/perl/ext/Pod-Html/t/htmldir5.t (rev 0)
+++ trunk/contrib/perl/ext/Pod-Html/t/htmldir5.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -0,0 +1,75 @@
+#!/usr/bin/perl -w # -*- perl -*-
+
+BEGIN {
+ require "t/pod2html-lib.pl";
+}
+
+END {
+ rem_test_dir();
+}
+
+use strict;
+use Cwd;
+use File::Spec::Functions;
+use Test::More tests => 1;
+
+SKIP: {
+ my $output = make_test_dir();
+ skip "$output", 1 if $output;
+
+
+ my $cwd = catdir cwd(); # catdir converts path separators to that of the OS
+ # running the test
+ # XXX but why don't the other tests complain about
+ # this?
+
+ convert_n_test("htmldir5", "test --htmldir and --htmlroot 5",
+ "--podpath=t:testdir/test.lib",
+ "--podroot=$cwd",
+ "--htmldir=$cwd",
+ "--htmlroot=/",
+ "--quiet",
+ );
+}
+
+__DATA__
+<?xml version="1.0" ?>
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
+<html xmlns="http://www.w3.org/1999/xhtml">
+<head>
+<title></title>
+<meta http-equiv="content-type" content="text/html; charset=utf-8" />
+<link rev="made" href="mailto:[PERLADMIN]" />
+</head>
+
+<body style="background-color: white">
+
+
+
+<ul id="index">
+ <li><a href="#NAME">NAME</a></li>
+ <li><a href="#LINKS">LINKS</a></li>
+</ul>
+
+<h1 id="NAME">NAME</h1>
+
+<p>htmldir - Test --htmldir feature</p>
+
+<h1 id="LINKS">LINKS</h1>
+
+<p>Normal text, a <a>link</a> to nowhere,</p>
+
+<p>a link to <a href="../testdir/test.lib/var-copy.html">var-copy</a>,</p>
+
+<p><a href="./htmlescp.html">htmlescp</a>,</p>
+
+<p><a href="./feature.html#Another-Head-1">"Another Head 1" in feature</a>,</p>
+
+<p>and another <a href="./feature.html#Another-Head-1">"Another Head 1" in feature</a>.</p>
+
+
+</body>
+
+</html>
+
+
Index: trunk/contrib/perl/ext/Pod-Html/t/htmlescp.pod
===================================================================
--- trunk/contrib/perl/ext/Pod-Html/t/htmlescp.pod 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/Pod-Html/t/htmlescp.pod 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/Pod-Html/t/htmlescp.pod
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/ext/Pod-Html/t/htmlescp.t
===================================================================
--- trunk/contrib/perl/ext/Pod-Html/t/htmlescp.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/Pod-Html/t/htmlescp.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -14,7 +14,7 @@
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
<html xmlns="http://www.w3.org/1999/xhtml">
<head>
-<title>NAME</title>
+<title></title>
<meta http-equiv="content-type" content="text/html; charset=utf-8" />
<link rev="made" href="mailto:[PERLADMIN]" />
</head>
@@ -22,35 +22,27 @@
<body style="background-color: white">
-<!-- INDEX BEGIN -->
-<div name="index">
-<p><a name="__index__"></a></p>
-<ul>
-
- <li><a href="#name">NAME</a></li>
- <li><a href="#description">DESCRIPTION</a></li>
+<ul id="index">
+ <li><a href="#NAME">NAME</a></li>
+ <li><a href="#DESCRIPTION">DESCRIPTION</a></li>
</ul>
-<hr name="index" />
-</div>
-<!-- INDEX END -->
+<h1 id="NAME">NAME</h1>
-<p>
-</p>
-<h1><a name="name">NAME</a></h1>
<p>Escape Sequences Test</p>
-<p>
-</p>
-<hr />
-<h1><a name="description">DESCRIPTION</a></h1>
-<p>I am a stupid fool who puts naked < & > characters in my POD
-instead of escaping them as < and >.</p>
-<p>Here is some <strong>bold</strong> text, some <em>italic</em> plus <em class="file">/etc/fstab</em>
-file and something that looks like an <html> tag.
-This is some <code>$code($arg1)</code>.</p>
-<p>Some numeric escapes: P e r l</p>
+<h1 id="DESCRIPTION">DESCRIPTION</h1>
+
+<p>I am a stupid fool who puts naked < & > characters in my POD instead of escaping them as < and >.</p>
+
+<p>Here is some <b>bold</b> text, some <i>italic</i> plus <i>/etc/fstab</i> file and something that looks like an <html> tag. This is some <code>$code($arg1)</code>.</p>
+
+<p>Some numeric escapes: P e r l</p>
+
+
</body>
</html>
+
+
Property changes on: trunk/contrib/perl/ext/Pod-Html/t/htmlescp.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/Pod-Html/t/htmllink.pod
===================================================================
--- trunk/contrib/perl/ext/Pod-Html/t/htmllink.pod 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/Pod-Html/t/htmllink.pod 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/Pod-Html/t/htmllink.pod
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/ext/Pod-Html/t/htmllink.t
===================================================================
--- trunk/contrib/perl/ext/Pod-Html/t/htmllink.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/Pod-Html/t/htmllink.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -14,7 +14,7 @@
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
<html xmlns="http://www.w3.org/1999/xhtml">
<head>
-<title>htmllink - Test HTML links</title>
+<title></title>
<meta http-equiv="content-type" content="text/html; charset=utf-8" />
<link rev="made" href="mailto:[PERLADMIN]" />
</head>
@@ -22,106 +22,136 @@
<body style="background-color: white">
-<!-- INDEX BEGIN -->
-<div name="index">
-<p><a name="__index__"></a></p>
-<ul>
+<ul id="index">
+ <li><a href="#NAME">NAME</a></li>
+ <li><a href="#LINKS">LINKS</a></li>
+ <li><a href="#TARGETS">TARGETS</a>
+ <ul>
+ <li><a href="#section1">section1</a></li>
+ <li><a href="#section-2">section 2</a></li>
+ <li><a href="#section-three">section three</a></li>
+ </ul>
+ </li>
+</ul>
- <li><a href="#name">NAME</a></li>
- <li><a href="#links">LINKS</a></li>
- <li><a href="#targets">TARGETS</a></li>
- <ul>
+<h1 id="NAME">NAME</h1>
- <li><a href="#section1">section1</a></li>
- <li><a href="#section_2">section 2</a></li>
- <li><a href="#section_three">section three</a></li>
- </ul>
+<p>htmllink - Test HTML links</p>
-</ul>
+<h1 id="LINKS">LINKS</h1>
-<hr name="index" />
-</div>
-<!-- INDEX END -->
+<p><a href="#section1">"section1"</a></p>
-<p>
-</p>
-<h1><a name="name">NAME</a></h1>
-<p>htmllink - Test HTML links</p>
-<p>
-</p>
-<hr />
-<h1><a name="links">LINKS</a></h1>
-<p><a href="#section1">section1</a></p>
-<p><a href="#section_2">section 2</a></p>
-<p><a href="#section_three">section three</a></p>
-<p><a href="#item1">item1</a></p>
-<p><a href="#item_2">item 2</a></p>
-<p><a href="#item_three">item three</a></p>
-<p><a href="#section1">section1</a></p>
-<p><a href="#section_2">section 2</a></p>
-<p><a href="#section_three">section three</a></p>
-<p><a href="#item1">item1</a></p>
-<p><a href="#item_2">item 2</a></p>
-<p><a href="#item_three">item three</a></p>
-<p><a href="#section1">section1</a></p>
-<p><a href="#section_2">section 2</a></p>
-<p><a href="#section_three">section three</a></p>
-<p><a href="#item1">item1</a></p>
-<p><a href="#item_2">item 2</a></p>
-<p><a href="#item_three">item three</a></p>
+<p><a href="#section-2">"section 2"</a></p>
+
+<p><a href="#section-three">"section three"</a></p>
+
+<p><a href="#item1">"item1"</a></p>
+
+<p><a href="#item-2">"item 2"</a></p>
+
+<p><a href="#item-three">"item three"</a></p>
+
+<p><a href="#section1">"section1"</a></p>
+
+<p><a href="#section-2">"section 2"</a></p>
+
+<p><a href="#section-three">"section three"</a></p>
+
+<p><a href="#item1">"item1"</a></p>
+
+<p><a href="#item-2">"item 2"</a></p>
+
+<p><a href="#item-three">"item three"</a></p>
+
+<p><a href="#section1">"section1"</a></p>
+
+<p><a href="#section-2">"section 2"</a></p>
+
+<p><a href="#section-three">"section three"</a></p>
+
+<p><a href="#item1">"item1"</a></p>
+
+<p><a href="#item-2">"item 2"</a></p>
+
+<p><a href="#item-three">"item three"</a></p>
+
<p><a href="#section1">text</a></p>
-<p><a href="#section_2">text</a></p>
-<p><a href="#section_three">text</a></p>
+
+<p><a href="#section-2">text</a></p>
+
+<p><a href="#section-three">text</a></p>
+
<p><a href="#item1">text</a></p>
-<p><a href="#item_2">text</a></p>
-<p><a href="#item_three">text</a></p>
+
+<p><a href="#item-2">text</a></p>
+
+<p><a href="#item-three">text</a></p>
+
<p><a href="#section1">text</a></p>
-<p><a href="#section_2">text</a></p>
-<p><a href="#section_three">text</a></p>
+
+<p><a href="#section-2">text</a></p>
+
+<p><a href="#section-three">text</a></p>
+
<p><a href="#item1">text</a></p>
-<p><a href="#item_2">text</a></p>
-<p><a href="#item_three">text</a></p>
+
+<p><a href="#item-2">text</a></p>
+
+<p><a href="#item-three">text</a></p>
+
<p><a href="#section1">text</a></p>
-<p><a href="#section_2">text</a></p>
-<p><a href="#section_three">text</a></p>
+
+<p><a href="#section-2">text</a></p>
+
+<p><a href="#section-three">text</a></p>
+
<p><a href="#item1">text</a></p>
-<p><a href="#item_2">text</a></p>
-<p><a href="#item_three">text</a></p>
-<p>
-</p>
-<hr />
-<h1><a name="targets">TARGETS</a></h1>
-<p>
-</p>
-<h2><a name="section1">section1</a></h2>
+
+<p><a href="#item-2">text</a></p>
+
+<p><a href="#item-three">text</a></p>
+
+<h1 id="TARGETS">TARGETS</h1>
+
+<h2 id="section1">section1</h2>
+
<p>This is section one.</p>
-<p>
-</p>
-<h2><a name="section_2">section 2</a></h2>
+
+<h2 id="section-2">section 2</h2>
+
<p>This is section two.</p>
-<p>
-</p>
-<h2><a name="section_three">section three</a></h2>
+
+<h2 id="section-three">section three</h2>
+
<p>This is section three.</p>
+
<dl>
-<dt><strong><a name="item1" class="item">item1</a></strong></dt>
+<dt id="item1">item1 </dt>
<dd>
+
<p>This is item one.</p>
+
</dd>
-<dt><strong><a name="item_2" class="item">item 2</a></strong></dt>
+<dt id="item-2">item 2 </dt>
+<dd>
-<dd>
<p>This is item two.</p>
+
</dd>
-<dt><strong><a name="item_three" class="item">item three</a></strong></dt>
+<dt id="item-three">item three </dt>
+<dd>
-<dd>
<p>This is item three.</p>
+
</dd>
</dl>
+
</body>
</html>
+
+
Property changes on: trunk/contrib/perl/ext/Pod-Html/t/htmllink.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/ext/Pod-Html/t/htmlview.pod
===================================================================
--- trunk/contrib/perl/ext/Pod-Html/t/htmlview.pod 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/Pod-Html/t/htmlview.pod 2013-12-02 21:32:26 UTC (rev 6445)
@@ -17,10 +17,10 @@
This is some more regular text.
Here is some B<bold> text, some I<italic> and something that looks
-like an E<lt>htmlE<gt> tag. This is some C<$code($arg1)>.
+like an E<lt>htmlE<gt> tag. This is some C<$code($arg1)>.
-This C<text contains embedded B<bold> and I<italic> tags>. These can
-be nested, allowing B<bold and I<bold E<amp> italic> text>. The module also
+This C<text contains embedded B<bold> and I<italic> tags>. These can
+be nested, allowing B<bold and I<bold E<amp> italic> text>. The module also
supports the extended B<< syntax >> and permits I<< nested tags E<amp>
other B<<< cool >>> stuff >>
@@ -30,7 +30,7 @@
=head2 new()
-Constructor method. Accepts the following config options:
+Constructor method. Accepts the following config options:
=over 4
@@ -60,8 +60,18 @@
The baz item.
+=over 4
+
+=item *
+
+A correct list within a list
+
+=item * Boomerang
+
=back
+=back
+
Title on the same line as the =item + * bullets
=over
@@ -78,6 +88,24 @@
=over
+=item 1
+
+Cat
+
+=item 2
+
+Sat
+
+=item 3
+
+Mat
+
+=back
+
+Numbered list with text on the same line
+
+=over
+
=item 1 Cat
=item 2 Sat
Property changes on: trunk/contrib/perl/ext/Pod-Html/t/htmlview.pod
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/ext/Pod-Html/t/htmlview.t
===================================================================
--- trunk/contrib/perl/ext/Pod-Html/t/htmlview.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/Pod-Html/t/htmlview.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -7,7 +7,7 @@
use strict;
use Test::More tests => 1;
-convert_n_test("htmlview", "html rendering");
+convert_n_test("htmlview", "html rendering", "--quiet");
__DATA__
<?xml version="1.0" ?>
@@ -14,7 +14,7 @@
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
<html xmlns="http://www.w3.org/1999/xhtml">
<head>
-<title>NAME</title>
+<title></title>
<meta http-equiv="content-type" content="text/html; charset=utf-8" />
<link rev="made" href="mailto:[PERLADMIN]" />
</head>
@@ -22,162 +22,214 @@
<body style="background-color: white">
-<!-- INDEX BEGIN -->
-<div name="index">
-<p><a name="__index__"></a></p>
-<ul>
+<ul id="index">
+ <li><a href="#NAME">NAME</a></li>
+ <li><a href="#SYNOPSIS">SYNOPSIS</a></li>
+ <li><a href="#DESCRIPTION">DESCRIPTION</a></li>
+ <li><a href="#METHODS-OTHER-STUFF">METHODS => OTHER STUFF</a>
+ <ul>
+ <li><a href="#new">new()</a></li>
+ <li><a href="#old">old()</a></li>
+ </ul>
+ </li>
+ <li><a href="#TESTING-FOR-AND-BEGIN">TESTING FOR AND BEGIN</a></li>
+ <li><a href="#TESTING-URLs-hyperlinking">TESTING URLs hyperlinking</a></li>
+ <li><a href="#SEE-ALSO">SEE ALSO</a></li>
+ <li><a href="#POD-ERRORS">POD ERRORS</a></li>
+</ul>
- <li><a href="#name">NAME</a></li>
- <li><a href="#synopsis">SYNOPSIS</a></li>
- <li><a href="#description">DESCRIPTION</a></li>
- <li><a href="#methods____other_stuff">METHODS => OTHER STUFF</a></li>
- <ul>
+<h1 id="NAME">NAME</h1>
- <li><a href="#new__"><code>new()</code></a></li>
- <li><a href="#old__"><code>old()</code></a></li>
- </ul>
+<p>Test HTML Rendering</p>
- <li><a href="#testing_for_and_begin">TESTING FOR AND BEGIN</a></li>
- <li><a href="#testing_urls_hyperlinking">TESTING URLs hyperlinking</a></li>
- <li><a href="#see_also">SEE ALSO</a></li>
-</ul>
+<h1 id="SYNOPSIS">SYNOPSIS</h1>
-<hr name="index" />
-</div>
-<!-- INDEX END -->
+<pre><code> use My::Module;
-<p>
-</p>
-<h1><a name="name">NAME</a></h1>
-<p>Test HTML Rendering</p>
-<p>
-</p>
-<hr />
-<h1><a name="synopsis">SYNOPSIS</a></h1>
-<pre>
- use My::Module;</pre>
-<pre>
- my $module = My::Module->new();</pre>
-<p>
-</p>
-<hr />
-<h1><a name="description">DESCRIPTION</a></h1>
+ my $module = My::Module->new();</code></pre>
+
+<h1 id="DESCRIPTION">DESCRIPTION</h1>
+
<p>This is the description.</p>
-<pre>
- Here is a verbatim section.</pre>
+
+<pre><code> Here is a verbatim section.</code></pre>
+
<p>This is some more regular text.</p>
-<p>Here is some <strong>bold</strong> text, some <em>italic</em> and something that looks
-like an <html> tag. This is some <code>$code($arg1)</code>.</p>
-<p>This <code>text contains embedded bold and italic tags</code>. These can
-be nested, allowing <strong>bold and <em>bold & italic</em> text</strong>. The module also
-supports the extended <strong>syntax </strong>> and permits <em>nested tags &
-other <strong>cool </strong></em>> stuff >></p>
-<p>
-</p>
-<hr />
-<h1><a name="methods____other_stuff">METHODS => OTHER STUFF</a></h1>
+
+<p>Here is some <b>bold</b> text, some <i>italic</i> and something that looks like an <html> tag. This is some <code>$code($arg1)</code>.</p>
+
+<p>This <code>text contains embedded <b>bold</b> and <i>italic</i> tags</code>. These can be nested, allowing <b>bold and <i>bold & italic</i> text</b>. The module also supports the extended <b>syntax</b> and permits <i>nested tags & other <b>cool</b> stuff</i></p>
+
+<h1 id="METHODS-OTHER-STUFF">METHODS => OTHER STUFF</h1>
+
<p>Here is a list of methods</p>
-<p>
-</p>
-<h2><a name="new__"><code>new()</code></a></h2>
-<p>Constructor method. Accepts the following config options:</p>
+
+<h2 id="new">new()</h2>
+
+<p>Constructor method. Accepts the following config options:</p>
+
<dl>
-<dt><strong><a name="foo" class="item">foo</a></strong></dt>
+<dt id="foo">foo</dt>
<dd>
+
<p>The foo item.</p>
+
</dd>
-<dt><strong><a name="bar" class="item">bar</a></strong></dt>
+<dt id="bar">bar</dt>
+<dd>
-<dd>
<p>The bar item.</p>
+
+<ul>
+
<p>This is a list within a list</p>
-<ul>
-<li>
+
+<p>*</p>
+
<p>The wiz item.</p>
-</li>
-<li>
+
+<p>*</p>
+
<p>The waz item.</p>
-</li>
+
</ul>
+
</dd>
-<dt><strong><a name="baz" class="item">baz</a></strong></dt>
+<dt id="baz">baz</dt>
+<dd>
-<dd>
<p>The baz item.</p>
+
+<ul>
+
+<li><p>A correct list within a list</p>
+
+</li>
+<li><p>Boomerang</p>
+
+</li>
+</ul>
+
</dd>
</dl>
+
<p>Title on the same line as the =item + * bullets</p>
+
<ul>
-<li><strong><a name="black_cat" class="item"><code>Black</code> Cat</a></strong>
+<li><p><code>Black</code> Cat</p>
+
</li>
-<li><strong><a name="sat_on_the" class="item">Sat <em>on</em> the</a></strong>
+<li><p>Sat <span style="white-space: nowrap;"><i>on</i> the</span></p>
</li>
-<li><strong><a name="mat" class="item">Mat<!></a></strong>
+<li><p>Mat<!></p>
</li>
</ul>
+
<p>Title on the same line as the =item + numerical bullets</p>
+
<ol>
-<li><strong><a name="cat" class="item">Cat</a></strong>
+<li><p>Cat</p>
+
</li>
-<li><strong><a name="sat" class="item">Sat</a></strong>
+<li><p>Sat</p>
</li>
-<li><strong><a name="mat2" class="item">Mat</a></strong>
+<li><p>Mat</p>
</li>
</ol>
-<p>No bullets, no title</p>
+
+<p>Numbered list with text on the same line</p>
+
<dl>
-<dt>
+
+<dt id="Cat">1 Cat</dt>
<dd>
-<p>Cat</p>
+
</dd>
-<dt>
+<dt id="Sat">2 Sat</dt>
<dd>
-<p>Sat</p>
+
</dd>
-<dt>
+<dt id="Mat">3 Mat</dt>
<dd>
-<p>Mat</p>
+
</dd>
</dl>
-<p>
-</p>
-<h2><a name="old__"><code>old()</code></a></h2>
+
+<p>No bullets, no title</p>
+
+<ul>
+
+<li><p>Cat</p>
+
+</li>
+<li><p>Sat</p>
+
+</li>
+<li><p>Mat</p>
+
+</li>
+</ul>
+
+<h2 id="old">old()</h2>
+
<p>Destructor method</p>
-<p>
-</p>
-<hr />
-<h1><a name="testing_for_and_begin">TESTING FOR AND BEGIN</a></h1>
+
+<h1 id="TESTING-FOR-AND-BEGIN">TESTING FOR AND BEGIN</h1>
+
+
+
<br />
<p>
blah blah
-</p><p>intermediate text</p>
+</p>
+
+<p>intermediate text</p>
+
+
+
<more>
HTML
-</more>some text<p>
-</p>
-<hr />
-<h1><a name="testing_urls_hyperlinking">TESTING URLs hyperlinking</a></h1>
-<p>This is an href link1: <a href="http://example.com">http://example.com</a></p>
-<p>This is an href link2: <a href="http://example.com/foo/bar.html">http://example.com/foo/bar.html</a></p>
-<p>This is an email link: <a href="mailto:mailto:foo at bar.com">mailto:foo at bar.com</a></p>
-<pre>
- This is a link in a verbatim block <a href="<a href="http://perl.org">http://perl.org</a>"> Perl </a></pre>
-<p>
-</p>
-<hr />
-<h1><a name="see_also">SEE ALSO</a></h1>
-<p>See also <a href="/t/htmlescp.html">Test Page 2</a>, the <a href="/Your/Module.html">the Your::Module manpage</a> and <a href="/Their/Module.html">the Their::Module manpage</a>
-manpages and the other interesting file <em class="file">/usr/local/my/module/rocks</em>
-as well.</p>
+</more>some text
+<h1 id="TESTING-URLs-hyperlinking">TESTING URLs hyperlinking</h1>
+
+<p>This is an href link1: http://example.com</p>
+
+<p>This is an href link2: http://example.com/foo/bar.html</p>
+
+<p>This is an email link: mailto:foo at bar.com</p>
+
+<pre><code> This is a link in a verbatim block <a href="http://perl.org"> Perl </a></code></pre>
+
+<h1 id="SEE-ALSO">SEE ALSO</h1>
+
+<p>See also <a href="/t/htmlescp.html">Test Page 2</a>, the <a>Your::Module</a> and <a>Their::Module</a> manpages and the other interesting file <i>/usr/local/my/module/rocks</i> as well.</p>
+
+<h1 id="POD-ERRORS">POD ERRORS</h1>
+
+<p>Hey! <b>The above document had some coding errors, which are explained below:</b></p>
+
+<dl>
+
+<dt id="Around-line-45">Around line 45:</dt>
+<dd>
+
+<p>You can't have =items (as at line 49) unless the first thing after the =over is an =item</p>
+
+</dd>
+</dl>
+
+
</body>
</html>
+
+
Property changes on: trunk/contrib/perl/ext/Pod-Html/t/htmlview.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/ext/Pod-Html/t/pod2html-lib.pl
===================================================================
--- trunk/contrib/perl/ext/Pod-Html/t/pod2html-lib.pl 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/Pod-Html/t/pod2html-lib.pl 2013-12-02 21:32:26 UTC (rev 6445)
@@ -1,24 +1,57 @@
require Cwd;
require Pod::Html;
require Config;
-use File::Spec::Functions;
+use File::Spec::Functions ':ALL';
+use File::Path 'remove_tree';
+use File::Copy;
+# make_test_dir and rem_test_dir dynamically create and remove testdir/test.lib.
+# it is created dynamically to pass t/filenames.t, which does not allow '.'s in
+# filenames as '.' is the directory separator on VMS. All tests that require
+# testdir/test.lib to be present are skipped if test.lib cannot be created.
+sub make_test_dir {
+ if (-d 'testdir/test.lib') {
+ warn "Directory 'test.lib' exists (it shouldn't yet) - removing it";
+ rem_test_dir();
+ }
+ mkdir('testdir/test.lib') or return "Could not make test.lib directory: $!\n";
+ copy('testdir/perlpodspec-copy.pod', 'testdir/test.lib/podspec-copy.pod')
+ or return "Could not copy perlpodspec-copy: $!";
+ copy('testdir/perlvar-copy.pod', 'testdir/test.lib/var-copy.pod')
+ or return "Could not copy perlvar-copy: $!";
+ return 0;
+}
+
+sub rem_test_dir {
+ return unless -d 'testdir/test.lib';
+ remove_tree('testdir/test.lib')
+ or warn "Error removing temporary directory 'testdir/test.lib'";
+}
+
sub convert_n_test {
- my($podfile, $testname) = @_;
+ my($podfile, $testname, @p2h_args) = @_;
- my $cwd = Cwd::cwd();
- my $new_dir = catdir $cwd, "t";
- my $infile = catfile $new_dir, "$podfile.pod";
- my $outfile = catfile $new_dir, "$podfile.html";
+ my $cwd = Pod::Html::_unixify( Cwd::cwd() );
+ my ($vol, $dir) = splitpath($cwd, 1);
+ my @dirs = splitdir($dir);
+ shift @dirs if $dirs[0] eq '';
+ my $relcwd = join '/', @dirs;
+ my $new_dir = catdir $dir, "t";
+ my $infile = catpath $vol, $new_dir, "$podfile.pod";
+ my $outfile = catpath $vol, $new_dir, "$podfile.html";
+
+ # To add/modify args to p2h, use @p2h_args
Pod::Html::pod2html(
+ "--infile=$infile",
+ "--outfile=$outfile",
"--podpath=t",
+ "--htmlroot=/",
"--podroot=$cwd",
- "--htmlroot=/",
- "--infile=$infile",
- "--outfile=$outfile"
+ @p2h_args,
);
+ $cwd =~ s|\/$||;
my ($expect, $result);
{
@@ -26,6 +59,8 @@
# expected
$expect = <DATA>;
$expect =~ s/\[PERLADMIN\]/$Config::Config{perladmin}/;
+ $expect =~ s/\[RELCURRENTWORKINGDIRECTORY\]/$relcwd/g;
+ $expect =~ s/\[ABSCURRENTWORKINGDIRECTORY\]/$cwd/g;
if (ord("A") == 193) { # EBCDIC.
$expect =~ s/item_mat_3c_21_3e/item_mat_4c_5a_6e/;
}
@@ -36,26 +71,33 @@
close $in;
}
- ok($expect eq $result, $testname) or do {
- my $diff = '/bin/diff';
- -x $diff or $diff = '/usr/bin/diff';
- if (-x $diff) {
- my $expectfile = "pod2html-lib.tmp";
- open my $tmpfile, ">", $expectfile or die $!;
- print $tmpfile $expect;
- close $tmpfile;
- my $diffopt = $^O eq 'linux' ? 'u' : 'c';
- open my $diff, "diff -$diffopt $expectfile $outfile |" or die $!;
- print "# $_" while <$diff>;
- close $diff;
- unlink $expectfile;
- }
- };
+ my $diff = '/bin/diff';
+ -x $diff or $diff = '/usr/bin/diff';
+ -x $diff or $diff = undef;
+ my $diffopt = $diff ? $^O =~ m/(linux|darwin)/ ? '-u' : '-c'
+ : '';
+ $diff = 'fc/n' if $^O =~ /^MSWin/;
+ $diff = 'differences' if $^O eq 'VMS';
+ if ($diff) {
+ ok($expect eq $result, $testname) or do {
+ my $expectfile = "${podfile}_expected.tmp";
+ open my $tmpfile, ">", $expectfile or die $!;
+ print $tmpfile $expect;
+ close $tmpfile;
+ open my $diff_fh, "$diff $diffopt $expectfile $outfile |" or die $!;
+ print STDERR "# $_" while <$diff_fh>;
+ close $diff_fh;
+ unlink $expectfile;
+ };
+ } else {
+ # This is fairly evil, but lets us get detailed failure modes
+ # anywhere that we've failed to identify a diff program.
+ is($expect, $result, $testname);
+ }
# pod2html creates these
1 while unlink $outfile;
1 while unlink "pod2htmd.tmp";
- 1 while unlink "pod2htmi.tmp";
}
1;
Property changes on: trunk/contrib/perl/ext/Pod-Html/t/pod2html-lib.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Copied: trunk/contrib/perl/ext/Pod-Html/t/poderr.pod (from rev 6437, vendor/perl/5.18.1/ext/Pod-Html/t/poderr.pod)
===================================================================
--- trunk/contrib/perl/ext/Pod-Html/t/poderr.pod (rev 0)
+++ trunk/contrib/perl/ext/Pod-Html/t/poderr.pod 2013-12-02 21:32:26 UTC (rev 6445)
@@ -0,0 +1,19 @@
+=head1 NAME
+
+Test POD ERROR section
+
+=over 4
+
+This text is not allowed
+
+=item *
+
+The wiz item.
+
+=item *
+
+The waz item.
+
+=back
+
+=cut
Copied: trunk/contrib/perl/ext/Pod-Html/t/poderr.t (from rev 6437, vendor/perl/5.18.1/ext/Pod-Html/t/poderr.t)
===================================================================
--- trunk/contrib/perl/ext/Pod-Html/t/poderr.t (rev 0)
+++ trunk/contrib/perl/ext/Pod-Html/t/poderr.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -0,0 +1,68 @@
+#!/usr/bin/perl -w # -*- perl -*-
+
+BEGIN {
+ require "t/pod2html-lib.pl";
+}
+
+use strict;
+use Test::More tests => 1;
+
+convert_n_test("poderr", "pod error section");
+
+__DATA__
+<?xml version="1.0" ?>
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
+<html xmlns="http://www.w3.org/1999/xhtml">
+<head>
+<title></title>
+<meta http-equiv="content-type" content="text/html; charset=utf-8" />
+<link rev="made" href="mailto:[PERLADMIN]" />
+</head>
+
+<body style="background-color: white">
+
+
+
+<ul id="index">
+ <li><a href="#NAME">NAME</a></li>
+ <li><a href="#POD-ERRORS">POD ERRORS</a></li>
+</ul>
+
+<h1 id="NAME">NAME</h1>
+
+<p>Test POD ERROR section</p>
+
+<ul>
+
+<p>This text is not allowed</p>
+
+<p>*</p>
+
+<p>The wiz item.</p>
+
+<p>*</p>
+
+<p>The waz item.</p>
+
+</ul>
+
+<h1 id="POD-ERRORS">POD ERRORS</h1>
+
+<p>Hey! <b>The above document had some coding errors, which are explained below:</b></p>
+
+<dl>
+
+<dt id="Around-line-5">Around line 5:</dt>
+<dd>
+
+<p>You can't have =items (as at line 9) unless the first thing after the =over is an =item</p>
+
+</dd>
+</dl>
+
+
+</body>
+
+</html>
+
+
Copied: trunk/contrib/perl/ext/Pod-Html/t/podnoerr.pod (from rev 6437, vendor/perl/5.18.1/ext/Pod-Html/t/podnoerr.pod)
===================================================================
--- trunk/contrib/perl/ext/Pod-Html/t/podnoerr.pod (rev 0)
+++ trunk/contrib/perl/ext/Pod-Html/t/podnoerr.pod 2013-12-02 21:32:26 UTC (rev 6445)
@@ -0,0 +1,19 @@
+=head1 NAME
+
+Test POD ERROR section
+
+=over 4
+
+This text is not allowed
+
+=item *
+
+The wiz item.
+
+=item *
+
+The waz item.
+
+=back
+
+=cut
Copied: trunk/contrib/perl/ext/Pod-Html/t/podnoerr.t (from rev 6437, vendor/perl/5.18.1/ext/Pod-Html/t/podnoerr.t)
===================================================================
--- trunk/contrib/perl/ext/Pod-Html/t/podnoerr.t (rev 0)
+++ trunk/contrib/perl/ext/Pod-Html/t/podnoerr.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -0,0 +1,55 @@
+#!/usr/bin/perl -w # -*- perl -*-
+
+BEGIN {
+ require "t/pod2html-lib.pl";
+}
+
+use strict;
+use Test::More tests => 1;
+
+convert_n_test("podnoerr", "pod error section",
+ "--nopoderrors",
+);
+
+__DATA__
+<?xml version="1.0" ?>
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
+<html xmlns="http://www.w3.org/1999/xhtml">
+<head>
+<title></title>
+<meta http-equiv="content-type" content="text/html; charset=utf-8" />
+<link rev="made" href="mailto:[PERLADMIN]" />
+</head>
+
+<body style="background-color: white">
+
+
+
+<ul id="index">
+ <li><a href="#NAME">NAME</a></li>
+</ul>
+
+<h1 id="NAME">NAME</h1>
+
+<p>Test POD ERROR section</p>
+
+<ul>
+
+<p>This text is not allowed</p>
+
+<p>*</p>
+
+<p>The wiz item.</p>
+
+<p>*</p>
+
+<p>The waz item.</p>
+
+</ul>
+
+
+</body>
+
+</html>
+
+
Index: trunk/contrib/perl/ext/SDBM_File/Makefile.PL
===================================================================
--- trunk/contrib/perl/ext/SDBM_File/Makefile.PL 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/SDBM_File/Makefile.PL 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/SDBM_File/Makefile.PL
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/ext/SDBM_File/SDBM_File.pm
===================================================================
--- trunk/contrib/perl/ext/SDBM_File/SDBM_File.pm 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/SDBM_File/SDBM_File.pm 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/SDBM_File/SDBM_File.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/ext/SDBM_File/SDBM_File.xs
===================================================================
--- trunk/contrib/perl/ext/SDBM_File/SDBM_File.xs 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/SDBM_File/SDBM_File.xs 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/SDBM_File/SDBM_File.xs
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/ext/SDBM_File/sdbm/CHANGES
===================================================================
--- trunk/contrib/perl/ext/SDBM_File/sdbm/CHANGES 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/SDBM_File/sdbm/CHANGES 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/SDBM_File/sdbm/CHANGES
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/SDBM_File/sdbm/COMPARE
===================================================================
--- trunk/contrib/perl/ext/SDBM_File/sdbm/COMPARE 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/SDBM_File/sdbm/COMPARE 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/SDBM_File/sdbm/COMPARE
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/SDBM_File/sdbm/Makefile.PL
===================================================================
--- trunk/contrib/perl/ext/SDBM_File/sdbm/Makefile.PL 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/SDBM_File/sdbm/Makefile.PL 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/SDBM_File/sdbm/Makefile.PL
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/ext/SDBM_File/sdbm/README
===================================================================
--- trunk/contrib/perl/ext/SDBM_File/sdbm/README 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/SDBM_File/sdbm/README 2013-12-02 21:32:26 UTC (rev 6445)
@@ -32,7 +32,7 @@
software.
The sdbm implementation is based on a 1978 algorithm
-[Lar78] by P.-A. (Paul) Larson known as ``Dynamic Hashing''.
+[Lar78] by P.-A. (Paul) Larson known as "Dynamic Hashing".
In the course of searching for a substitute for ndbm, I pro-
totyped three different external-hashing algorithms [Lar78,
Fag79, Lit80] and ultimately chose Larson's algorithm as a
@@ -70,7 +70,7 @@
- 2 -
-store operation will not ``wander away'' trying to split its
+store operation will not "wander away" trying to split its
data pages to insert a datum that cannot (due to elaborate
worst-case situations) be inserted. (It will fail after a
pre-defined number of attempts.)
@@ -233,7 +233,7 @@
*/
long
dbm_hash(char *str, int len) {
- register unsigned long n = 0;
+ unsigned long n = 0;
while (len--)
n = n * 65599 + *str++;
@@ -298,7 +298,7 @@
[Lar78]
- P.-A. Larson, ``Dynamic Hashing'', BIT, vol. 18, pp.
+ P.-A. Larson, "Dynamic Hashing", BIT, vol. 18, pp.
184-201, 1978.
[Tho90]
@@ -305,23 +305,23 @@
Ken Thompson, private communication, Nov. 1990
[Lit80]
- W. Litwin, `` Linear Hashing: A new tool for file and
- table addressing'', Proceedings of the 6th Conference on
+ W. Litwin, "Linear Hashing: A new tool for file and
+ table addressing", Proceedings of the 6th Conference on
Very Large Dabatases (Montreal), pp. 212-223, Very
Large Database Foundation, Saratoga, Calif., 1980.
[Fag79]
R. Fagin, J. Nievergelt, N. Pippinger, and H. R.
- Strong, ``Extendible Hashing - A Fast Access Method for
- Dynamic Files'', ACM Trans. Database Syst., vol. 4,
+ Strong, "Extendible Hashing - A Fast Access Method for
+ Dynamic Files", ACM Trans. Database Syst., vol. 4,
no.3, pp. 315-344, Sept. 1979.
[Wal84]
- Rich Wales, ``Discussion of "dbm" data base system'',
+ Rich Wales, "Discussion of 'dbm' data base system",
USENET newsgroup unix.wizards, Jan. 1984.
[Tor87]
- Chris Torek, ``Re: dbm.a and ndbm.a archives'',
+ Chris Torek, "Re: dbm.a and ndbm.a archives",
@@ -337,13 +337,13 @@
USENET newsgroup comp.unix, 1987.
[Mar79]
- G. N. Martin, ``Spiral Storage: Incrementally Augment-
- able Hash Addressed Storage'', Technical Report #27,
+ G. N. Martin, "Spiral Storage: Incrementally Augment-
+ able Hash Addressed Storage", Technical Report #27,
University of Varwick, Coventry, U.K., 1979.
[Enb88]
- R. J. Enbody and H. C. Du, ``Dynamic Hashing
- Schemes'',ACM Computing Surveys, vol. 20, no. 2, pp.
+ R. J. Enbody and H. C. Du, "Dynamic Hashing
+ Schemes",ACM Computing Surveys, vol. 20, no. 2, pp.
85-113, June 1988.
Property changes on: trunk/contrib/perl/ext/SDBM_File/sdbm/README
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/SDBM_File/sdbm/README.too
===================================================================
--- trunk/contrib/perl/ext/SDBM_File/sdbm/README.too 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/SDBM_File/sdbm/README.too 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/SDBM_File/sdbm/README.too
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/SDBM_File/sdbm/biblio
===================================================================
--- trunk/contrib/perl/ext/SDBM_File/sdbm/biblio 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/SDBM_File/sdbm/biblio 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/SDBM_File/sdbm/biblio
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/ext/SDBM_File/sdbm/dba.c
===================================================================
--- trunk/contrib/perl/ext/SDBM_File/sdbm/dba.c 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/SDBM_File/sdbm/dba.c 2013-12-02 21:32:26 UTC (rev 6445)
@@ -42,11 +42,11 @@
void
sdump(int pagf)
{
- register b;
- register n = 0;
- register t = 0;
- register o = 0;
- register e;
+ int b;
+ int n = 0;
+ int t = 0;
+ int o = 0;
+ int e;
char pag[PBLKSIZ];
while ((b = read(pagf, pag, PBLKSIZ)) > 0) {
@@ -72,9 +72,9 @@
int
pagestat(char *pag)
{
- register n;
- register free;
- register short *ino = (short *) pag;
+ int n;
+ int free;
+ short *ino = (short *) pag;
if (!(n = ino[0]))
printf("no entries.\n");
Property changes on: trunk/contrib/perl/ext/SDBM_File/sdbm/dba.c
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/ext/SDBM_File/sdbm/dbd.c
===================================================================
--- trunk/contrib/perl/ext/SDBM_File/sdbm/dbd.c 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/SDBM_File/sdbm/dbd.c 2013-12-02 21:32:26 UTC (rev 6445)
@@ -44,9 +44,9 @@
void
sdump(int pagf)
{
- register r;
- register n = 0;
- register o = 0;
+ int r;
+ int n = 0;
+ int o = 0;
char pag[PBLKSIZ];
while ((r = read(pagf, pag, PBLKSIZ)) > 0) {
@@ -70,9 +70,9 @@
int
dispage(char *pag)
{
- register i, n;
- register off;
- register short *ino = (short *) pag;
+ int i, n;
+ int off;
+ int short *ino = (short *) pag;
off = PBLKSIZ;
for (i = 1; i < ino[0]; i += 2) {
@@ -92,9 +92,9 @@
void
dispage(char *pag)
{
- register i, n;
- register off;
- register short *ino = (short *) pag;
+ int i, n;
+ int off;
+ short *ino = (short *) pag;
off = PBLKSIZ;
for (i = 1; i < ino[0]; i += 2) {
Property changes on: trunk/contrib/perl/ext/SDBM_File/sdbm/dbd.c
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/SDBM_File/sdbm/dbe.1
===================================================================
--- trunk/contrib/perl/ext/SDBM_File/sdbm/dbe.1 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/SDBM_File/sdbm/dbe.1 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/SDBM_File/sdbm/dbe.1
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/ext/SDBM_File/sdbm/dbe.c
===================================================================
--- trunk/contrib/perl/ext/SDBM_File/sdbm/dbe.c 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/SDBM_File/sdbm/dbe.c 2013-12-02 21:32:26 UTC (rev 6445)
@@ -54,8 +54,8 @@
char
getopt(int argc, char **argv, char *optstring)
{
- register int c;
- register char *place;
+ int c;
+ char *place;
extern char *index();
static int optind = 0;
static char *scan = NULL;
Property changes on: trunk/contrib/perl/ext/SDBM_File/sdbm/dbe.c
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/ext/SDBM_File/sdbm/dbu.c
===================================================================
--- trunk/contrib/perl/ext/SDBM_File/sdbm/dbu.c 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/SDBM_File/sdbm/dbu.c 2013-12-02 21:32:26 UTC (rev 6445)
@@ -68,7 +68,7 @@
main(int argc, char **argv)
{
int c;
- register cmd *act;
+ cmd *act;
extern int optind;
extern char *optarg;
@@ -96,13 +96,13 @@
}
static void
-doit(register cmd *act, char *file)
+doit(cmd *act, char *file)
{
datum key;
datum val;
- register DBM *db;
- register char *op;
- register int n;
+ DBM *db;
+ char *op;
+ int n;
char *line;
#ifdef TIME
long start;
@@ -195,7 +195,7 @@
static void
badk(char *word)
{
- register int i;
+ int i;
if (progname)
fprintf(stderr, "%s: ", progname);
@@ -209,10 +209,10 @@
}
static cmd *
-parse(register char *str)
+parse(char *str)
{
- register int i = CTABSIZ;
- register cmd *p;
+ int i = CTABSIZ;
+ cmd *p;
for (p = cmds; i--; p++)
if (strcmp(p->sname, str) == 0)
@@ -223,9 +223,9 @@
static void
prdatum(FILE *stream, datum d)
{
- register int c;
- register char *p = d.dptr;
- register int n = d.dsize;
+ int c;
+ char *p = d.dptr;
+ int n = d.dsize;
while (n--) {
c = *p++ & 0377;
Property changes on: trunk/contrib/perl/ext/SDBM_File/sdbm/dbu.c
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/SDBM_File/sdbm/grind
===================================================================
--- trunk/contrib/perl/ext/SDBM_File/sdbm/grind 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/SDBM_File/sdbm/grind 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/SDBM_File/sdbm/grind
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/ext/SDBM_File/sdbm/hash.c
===================================================================
--- trunk/contrib/perl/ext/SDBM_File/sdbm/hash.c 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/SDBM_File/sdbm/hash.c 2013-12-02 21:32:26 UTC (rev 6445)
@@ -18,9 +18,9 @@
* 65587 even better.
*/
long
-sdbm_hash(register const char *str, register int len)
+sdbm_hash(const char *str, int len)
{
- register unsigned long n = 0;
+ unsigned long n = 0;
#ifdef DUFF
@@ -27,7 +27,7 @@
#define HASHC n = *str++ + 65599 * n
if (len > 0) {
- register int loop = (len + 8 - 1) >> 3;
+ int loop = (len + 8 - 1) >> 3;
switch(len & (8 - 1)) {
case 0: do {
Property changes on: trunk/contrib/perl/ext/SDBM_File/sdbm/hash.c
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/ext/SDBM_File/sdbm/linux.patches
===================================================================
--- trunk/contrib/perl/ext/SDBM_File/sdbm/linux.patches 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/SDBM_File/sdbm/linux.patches 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/SDBM_File/sdbm/linux.patches
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/SDBM_File/sdbm/makefile.sdbm
===================================================================
--- trunk/contrib/perl/ext/SDBM_File/sdbm/makefile.sdbm 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/SDBM_File/sdbm/makefile.sdbm 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/SDBM_File/sdbm/makefile.sdbm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/ext/SDBM_File/sdbm/pair.c
===================================================================
--- trunk/contrib/perl/ext/SDBM_File/sdbm/pair.c 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/SDBM_File/sdbm/pair.c 2013-12-02 21:32:26 UTC (rev 6445)
@@ -47,10 +47,10 @@
int
fitpair(char *pag, int need)
{
- register int n;
- register int off;
- register int free;
- register short *ino = (short *) pag;
+ int n;
+ int off;
+ int free;
+ short *ino = (short *) pag;
off = ((n = ino[0]) > 0) ? ino[n] : PBLKSIZ;
free = off - (n + 1) * sizeof(short);
@@ -64,9 +64,9 @@
void
putpair(char *pag, datum key, datum val)
{
- register int n;
- register int off;
- register short *ino = (short *) pag;
+ int n;
+ int off;
+ short *ino = (short *) pag;
off = ((n = ino[0]) > 0) ? ino[n] : PBLKSIZ;
/*
@@ -90,10 +90,10 @@
datum
getpair(char *pag, datum key)
{
- register int i;
- register int n;
+ int i;
+ int n;
datum val;
- register short *ino = (short *) pag;
+ short *ino = (short *) pag;
if ((n = ino[0]) == 0)
return nullitem;
@@ -109,7 +109,7 @@
int
exipair(char *pag, datum key)
{
- register short *ino = (short *) pag;
+ short *ino = (short *) pag;
if (ino[0] == 0)
return 0;
@@ -121,7 +121,7 @@
int
duppair(char *pag, datum key)
{
- register short *ino = (short *) pag;
+ short *ino = (short *) pag;
return ino[0] > 0 && seepair(pag, ino[0], key.dptr, key.dsize) > 0;
}
#endif
@@ -130,8 +130,8 @@
getnkey(char *pag, int num)
{
datum key;
- register int off;
- register short *ino = (short *) pag;
+ int off;
+ short *ino = (short *) pag;
num = num * 2 - 1;
if (ino[0] == 0 || num > ino[0])
@@ -148,9 +148,9 @@
int
delpair(char *pag, datum key)
{
- register int n;
- register int i;
- register short *ino = (short *) pag;
+ int n;
+ int i;
+ short *ino = (short *) pag;
if ((n = ino[0]) == 0)
return 0;
@@ -165,10 +165,10 @@
* [note: 0 < i < n]
*/
if (i < n - 1) {
- register int m;
- register char *dst = pag + (i == 1 ? PBLKSIZ : ino[i - 1]);
- register char *src = pag + ino[i + 1];
- register int zoo = dst - src;
+ int m;
+ char *dst = pag + (i == 1 ? PBLKSIZ : ino[i - 1]);
+ char *src = pag + ino[i + 1];
+ int zoo = dst - src;
debug(("free-up %d ", zoo));
/*
@@ -179,7 +179,7 @@
#define MOVB *--dst = *--src
if (m > 0) {
- register int loop = (m + 8 - 1) >> 3;
+ int loop = (m + 8 - 1) >> 3;
switch (m & (8 - 1)) {
case 0: do {
@@ -218,11 +218,11 @@
* return 0 if not found.
*/
static int
-seepair(char *pag, register int n, register const char *key, register int siz)
+seepair(char *pag, int n, const char *key, int siz)
{
- register int i;
- register int off = PBLKSIZ;
- register short *ino = (short *) pag;
+ int i;
+ int off = PBLKSIZ;
+ short *ino = (short *) pag;
for (i = 1; i < n; i += 2) {
if (siz == off - ino[i] &&
@@ -239,10 +239,10 @@
datum key;
datum val;
- register int n;
- register int off = PBLKSIZ;
+ int n;
+ int off = PBLKSIZ;
char cur[PBLKSIZ];
- register short *ino = (short *) cur;
+ short *ino = (short *) cur;
(void) memcpy(cur, pag, PBLKSIZ);
(void) memset(pag, 0, PBLKSIZ);
@@ -277,9 +277,9 @@
int
chkpage(char *pag)
{
- register int n;
- register int off;
- register short *ino = (short *) pag;
+ int n;
+ int off;
+ short *ino = (short *) pag;
if ((n = ino[0]) < 0 || n > (int)(PBLKSIZ / sizeof(short)))
return 0;
Property changes on: trunk/contrib/perl/ext/SDBM_File/sdbm/pair.c
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Index: trunk/contrib/perl/ext/SDBM_File/sdbm/pair.h
===================================================================
--- trunk/contrib/perl/ext/SDBM_File/sdbm/pair.h 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/SDBM_File/sdbm/pair.h 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/SDBM_File/sdbm/pair.h
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/ext/SDBM_File/sdbm/readme.ms
===================================================================
--- trunk/contrib/perl/ext/SDBM_File/sdbm/readme.ms 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/SDBM_File/sdbm/readme.ms 2013-12-02 21:32:26 UTC (rev 6445)
@@ -1,7 +1,7 @@
.\" tbl | readme.ms | [tn]roff -ms | ...
.\" note the "C" (courier) and "CB" fonts: you will probably have to
.\" change these.
-.\" $Id: readme.ms,v 1.1.1.1 2009-03-15 19:18:42 ctriv Exp $
+.\" $Id: readme.ms,v 1.1 90/12/13 13:09:15 oz Exp Locker: oz $
.de P1
.br
@@ -70,7 +70,7 @@
copyrighted software.
.PP
The \fIsdbm\fP implementation is based on a 1978 algorithm
-[Lar78] by P.-A. (Paul) Larson known as ``Dynamic Hashing''.
+[Lar78] by P.-A. (Paul) Larson known as "Dynamic Hashing".
In the course of searching for a substitute for \fIndbm\fP, I
prototyped three different external-hashing algorithms [Lar78, Fag79, Lit80]
and ultimately chose Larson's algorithm as a basis of the \fIsdbm\fP
@@ -94,7 +94,7 @@
in database creation.
Unlike the \fIndbm\fP, the \fIsdbm\fP
.CW store
-operation will not ``wander away'' trying to split its
+operation will not "wander away" trying to split its
data pages to insert a datum that \fIcannot\fP (due to elaborate worst-case
situations) be inserted. (It will fail after a pre-defined number of attempts.)
.SH
@@ -263,7 +263,7 @@
*/
long
dbm_hash(char *str, int len) {
- register unsigned long n = 0;
+ unsigned long n = 0;
while (len--)
n = n * 65599 + *str++;
@@ -323,31 +323,31 @@
.LP
.IP [Lar78] 4m
P.-A. Larson,
-``Dynamic Hashing'', \fIBIT\fP, vol. 18, pp. 184-201, 1978.
+"Dynamic Hashing", \fIBIT\fP, vol. 18, pp. 184-201, 1978.
.IP [Tho90] 4m
Ken Thompson, \fIprivate communication\fP, Nov. 1990
.IP [Lit80] 4m
W. Litwin,
-`` Linear Hashing: A new tool for file and table addressing'',
+"Linear Hashing: A new tool for file and table addressing",
\fIProceedings of the 6th Conference on Very Large Dabatases (Montreal)\fP,
pp. 212-223, Very Large Database Foundation, Saratoga, Calif., 1980.
.IP [Fag79] 4m
R. Fagin, J. Nievergelt, N. Pippinger, and H. R. Strong,
-``Extendible Hashing - A Fast Access Method for Dynamic Files'',
+"Extendible Hashing - A Fast Access Method for Dynamic Files",
\fIACM Trans. Database Syst.\fP, vol. 4, no.3, pp. 315-344, Sept. 1979.
.IP [Wal84] 4m
Rich Wales,
-``Discussion of "dbm" data base system'', \fIUSENET newsgroup unix.wizards\fP,
+"Discussion of 'dbm' data base system", \fIUSENET newsgroup unix.wizards\fP,
Jan. 1984.
.IP [Tor87] 4m
Chris Torek,
-``Re: dbm.a and ndbm.a archives'', \fIUSENET newsgroup comp.unix\fP,
+"Re: dbm.a and ndbm.a archives", \fIUSENET newsgroup comp.unix\fP,
1987.
.IP [Mar79] 4m
G. N. Martin,
-``Spiral Storage: Incrementally Augmentable Hash Addressed Storage'',
+"Spiral Storage: Incrementally Augmentable Hash Addressed Storage",
\fITechnical Report #27\fP, University of Varwick, Coventry, U.K., 1979.
.IP [Enb88] 4m
R. J. Enbody and H. C. Du,
-``Dynamic Hashing Schemes'',\fIACM Computing Surveys\fP,
+"Dynamic Hashing Schemes",\fIACM Computing Surveys\fP,
vol. 20, no. 2, pp. 85-113, June 1988.
Property changes on: trunk/contrib/perl/ext/SDBM_File/sdbm/readme.ms
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/ext/SDBM_File/sdbm/sdbm.3
===================================================================
--- trunk/contrib/perl/ext/SDBM_File/sdbm/sdbm.3 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/SDBM_File/sdbm/sdbm.3 2013-12-02 21:32:26 UTC (rev 6445)
@@ -1,4 +1,4 @@
-.\" $Id: sdbm.3,v 1.1.1.2 2011-05-18 13:33:26 laffer1 Exp $
+.\" $Id: sdbm.3,v 1.2 90/12/13 13:00:57 oz Exp $
.TH SDBM 3 "1 March 1990"
.SH NAME
sdbm, sdbm_open, sdbm_prep, sdbm_close, sdbm_fetch, sdbm_store, sdbm_delete, sdbm_exists, sdbm_firstkey, sdbm_nextkey, sdbm_hash, sdbm_rdonly, sdbm_error, sdbm_clearerr, sdbm_dirfno, sdbm_pagfno \- data base subroutines
Property changes on: trunk/contrib/perl/ext/SDBM_File/sdbm/sdbm.3
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/ext/SDBM_File/sdbm/sdbm.c
===================================================================
--- trunk/contrib/perl/ext/SDBM_File/sdbm/sdbm.c 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/SDBM_File/sdbm/sdbm.c 2013-12-02 21:32:26 UTC (rev 6445)
@@ -37,10 +37,17 @@
#include <errno.h> /* See notes in perl.h about avoiding
extern int errno; */
+#ifdef __cplusplus
+extern "C" {
+#endif
extern Malloc_t malloc proto((MEM_SIZE));
extern Free_t free proto((Malloc_t));
+#ifdef __cplusplus
+}
+#endif
+
/*
* forward
*/
@@ -72,14 +79,14 @@
};
DBM *
-sdbm_open(register char *file, register int flags, register int mode)
+sdbm_open(char *file, int flags, int mode)
{
- register DBM *db;
- register char *dirname;
- register char *pagname;
+ DBM *db;
+ char *dirname;
+ char *pagname;
size_t filelen;
- const size_t dirfext_len = sizeof(DIRFEXT "");
- const size_t pagfext_len = sizeof(PAGFEXT "");
+ const size_t dirfext_size = sizeof(DIRFEXT "");
+ const size_t pagfext_size = sizeof(PAGFEXT "");
if (file == NULL || !*file)
return errno = EINVAL, (DBM *) NULL;
@@ -88,17 +95,17 @@
*/
filelen = strlen(file);
- if ((dirname = (char *) malloc(filelen + dirfext_len + 1
- + filelen + pagfext_len + 1)) == NULL)
+ if ((dirname = (char *) malloc(filelen + dirfext_size
+ + filelen + pagfext_size)) == NULL)
return errno = ENOMEM, (DBM *) NULL;
/*
* build the file names
*/
memcpy(dirname, file, filelen);
- memcpy(dirname + filelen, DIRFEXT, dirfext_len + 1);
- pagname = dirname + filelen + dirfext_len + 1;
+ memcpy(dirname + filelen, DIRFEXT, dirfext_size);
+ pagname = dirname + filelen + dirfext_size;
memcpy(pagname, file, filelen);
- memcpy(pagname + filelen, PAGFEXT, pagfext_len + 1);
+ memcpy(pagname + filelen, PAGFEXT, pagfext_size);
db = sdbm_prep(dirname, pagname, flags, mode);
free((char *) dirname);
@@ -108,7 +115,7 @@
DBM *
sdbm_prep(char *dirname, char *pagname, int flags, int mode)
{
- register DBM *db;
+ DBM *db;
struct stat dstat;
if ((db = (DBM *) malloc(sizeof(DBM))) == NULL)
@@ -165,7 +172,7 @@
}
void
-sdbm_close(register DBM *db)
+sdbm_close(DBM *db)
{
if (db == NULL)
errno = EINVAL;
@@ -177,7 +184,7 @@
}
datum
-sdbm_fetch(register DBM *db, datum key)
+sdbm_fetch(DBM *db, datum key)
{
if (db == NULL || bad(key))
return errno = EINVAL, nullitem;
@@ -189,7 +196,7 @@
}
int
-sdbm_exists(register DBM *db, datum key)
+sdbm_exists(DBM *db, datum key)
{
if (db == NULL || bad(key))
return errno = EINVAL, -1;
@@ -201,7 +208,7 @@
}
int
-sdbm_delete(register DBM *db, datum key)
+sdbm_delete(DBM *db, datum key)
{
if (db == NULL || bad(key))
return errno = EINVAL, -1;
@@ -225,10 +232,10 @@
}
int
-sdbm_store(register DBM *db, datum key, datum val, int flags)
+sdbm_store(DBM *db, datum key, datum val, int flags)
{
int need;
- register long hash;
+ long hash;
if (db == NULL || bad(key))
return errno = EINVAL, -1;
@@ -283,7 +290,7 @@
* giving up.
*/
static int
-makroom(register DBM *db, long int hash, int need)
+makroom(DBM *db, long int hash, int need)
{
long newp;
char twin[PBLKSIZ];
@@ -293,7 +300,7 @@
#endif
char *pag = db->pagbuf;
char *New = twin;
- register int smax = SPLTMAX;
+ int smax = SPLTMAX;
do {
/*
@@ -379,7 +386,7 @@
* deletions aren't taken into account. (ndbm bug)
*/
datum
-sdbm_firstkey(register DBM *db)
+sdbm_firstkey(DBM *db)
{
if (db == NULL)
return errno = EINVAL, nullitem;
@@ -397,7 +404,7 @@
}
datum
-sdbm_nextkey(register DBM *db)
+sdbm_nextkey(DBM *db)
{
if (db == NULL)
return errno = EINVAL, nullitem;
@@ -408,11 +415,11 @@
* all important binary trie traversal
*/
static int
-getpage(register DBM *db, register long int hash)
+getpage(DBM *db, long int hash)
{
- register int hbit;
- register long dbit;
- register long pagb;
+ int hbit;
+ long dbit;
+ long pagb;
dbit = 0;
hbit = 0;
@@ -447,10 +454,10 @@
}
static int
-getdbit(register DBM *db, register long int dbit)
+getdbit(DBM *db, long int dbit)
{
- register long c;
- register long dirb;
+ long c;
+ long dirb;
c = dbit / BYTESIZ;
dirb = c / DBLKSIZ;
@@ -471,10 +478,10 @@
}
static int
-setdbit(register DBM *db, register long int dbit)
+setdbit(DBM *db, long int dbit)
{
- register long c;
- register long dirb;
+ long c;
+ long dirb;
c = dbit / BYTESIZ;
dirb = c / DBLKSIZ;
@@ -513,7 +520,7 @@
* the page, try the next page in sequence
*/
static datum
-getnext(register DBM *db)
+getnext(DBM *db)
{
datum key;
Property changes on: trunk/contrib/perl/ext/SDBM_File/sdbm/sdbm.c
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/ext/SDBM_File/sdbm/sdbm.h
===================================================================
--- trunk/contrib/perl/ext/SDBM_File/sdbm/sdbm.h 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/SDBM_File/sdbm/sdbm.h 2013-12-02 21:32:26 UTC (rev 6445)
@@ -179,10 +179,19 @@
# define realloc Perl_realloc
# define free Perl_mfree
+#ifdef __cplusplus
+extern "C" {
+#endif
+
Malloc_t Perl_malloc proto((MEM_SIZE nbytes));
Malloc_t Perl_calloc proto((MEM_SIZE elements, MEM_SIZE size));
Malloc_t Perl_realloc proto((Malloc_t where, MEM_SIZE nbytes));
Free_t Perl_mfree proto((Malloc_t where));
+
+#ifdef __cplusplus
+}
+#endif
+
#endif /* MYMALLOC */
#ifdef I_STRING
@@ -250,11 +259,7 @@
#else
# ifndef memcmp
/* maybe we should have included the full embedding header... */
-# ifdef NO_EMBED
-# define memcmp my_memcmp
-# else
-# define memcmp Perl_my_memcmp
-# endif
+# define memcmp Perl_my_memcmp
#ifndef __cplusplus
extern int memcmp proto((char*, char*, int));
#endif
Property changes on: trunk/contrib/perl/ext/SDBM_File/sdbm/sdbm.h
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/ext/SDBM_File/sdbm/tune.h
===================================================================
--- trunk/contrib/perl/ext/SDBM_File/sdbm/tune.h 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/SDBM_File/sdbm/tune.h 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/SDBM_File/sdbm/tune.h
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/ext/SDBM_File/sdbm/util.c
===================================================================
--- trunk/contrib/perl/ext/SDBM_File/sdbm/util.c 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/SDBM_File/sdbm/util.c 2013-12-02 21:32:26 UTC (rev 6445)
@@ -6,7 +6,7 @@
#endif
void
-oops(register char *s1, register char *s2)
+oops(char *s1, char *s2)
{
extern int errno, sys_nerr;
extern char *sys_errlist[];
@@ -24,9 +24,9 @@
int
okpage(char *pag)
{
- register unsigned n;
- register off;
- register short *ino = (short *) pag;
+ unsigned n;
+ int off;
+ short *ino = (short *) pag;
if ((n = ino[0]) > PBLKSIZ / sizeof(short))
return 0;
Property changes on: trunk/contrib/perl/ext/SDBM_File/sdbm/util.c
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/SDBM_File/t/sdbm.t
===================================================================
--- trunk/contrib/perl/ext/SDBM_File/t/sdbm.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/SDBM_File/t/sdbm.t 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/SDBM_File/t/sdbm.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/ext/SDBM_File/typemap
===================================================================
--- trunk/contrib/perl/ext/SDBM_File/typemap 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/SDBM_File/typemap 2013-12-02 21:32:26 UTC (rev 6445)
@@ -11,7 +11,6 @@
ODBM_File T_PTROBJ
DB_File T_PTROBJ
DBZ_File T_PTROBJ
-FATALFUNC T_OPAQUEPTR
INPUT
T_DATUM_K
Property changes on: trunk/contrib/perl/ext/SDBM_File/typemap
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Index: trunk/contrib/perl/ext/Socket/Makefile.PL
===================================================================
--- trunk/contrib/perl/ext/Socket/Makefile.PL 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/Socket/Makefile.PL 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/Socket/Makefile.PL
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Index: trunk/contrib/perl/ext/Socket/Socket.pm
===================================================================
--- trunk/contrib/perl/ext/Socket/Socket.pm 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/Socket/Socket.pm 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/Socket/Socket.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Index: trunk/contrib/perl/ext/Socket/Socket.xs
===================================================================
--- trunk/contrib/perl/ext/Socket/Socket.xs 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/Socket/Socket.xs 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/Socket/Socket.xs
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Index: trunk/contrib/perl/ext/Socket/t/Socket.t
===================================================================
--- trunk/contrib/perl/ext/Socket/t/Socket.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/Socket/t/Socket.t 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/Socket/t/Socket.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/ext/Socket/t/getaddrinfo.t
===================================================================
--- trunk/contrib/perl/ext/Socket/t/getaddrinfo.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/Socket/t/getaddrinfo.t 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/Socket/t/getaddrinfo.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/ext/Socket/t/getnameinfo.t
===================================================================
--- trunk/contrib/perl/ext/Socket/t/getnameinfo.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/Socket/t/getnameinfo.t 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/Socket/t/getnameinfo.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/Socket/t/socketpair.t
===================================================================
--- trunk/contrib/perl/ext/Socket/t/socketpair.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/Socket/t/socketpair.t 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/Socket/t/socketpair.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/ext/Sys-Hostname/Hostname.pm
===================================================================
--- trunk/contrib/perl/ext/Sys-Hostname/Hostname.pm 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/Sys-Hostname/Hostname.pm 2013-12-02 21:32:26 UTC (rev 6445)
@@ -14,7 +14,7 @@
our $host;
BEGIN {
- $VERSION = '1.16';
+ $VERSION = '1.17';
{
local $SIG{__DIE__};
eval {
@@ -64,10 +64,6 @@
chomp($host = `hostname 2> NUL`) unless defined $host;
return $host;
}
- elsif ($^O eq 'epoc') {
- $host = 'localhost';
- return $host;
- }
else { # Unix
# is anyone going to make it here?
Property changes on: trunk/contrib/perl/ext/Sys-Hostname/Hostname.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/ext/Sys-Hostname/Hostname.xs
===================================================================
--- trunk/contrib/perl/ext/Sys-Hostname/Hostname.xs 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/Sys-Hostname/Hostname.xs 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/Sys-Hostname/Hostname.xs
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/ext/Sys-Hostname/t/Hostname.t
===================================================================
--- trunk/contrib/perl/ext/Sys-Hostname/t/Hostname.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/Sys-Hostname/t/Hostname.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -18,6 +18,6 @@
print "1..0\n" if $@ =~ /Cannot get host name/;
} else {
print "1..1\n";
- print "# \$host = `$host'\n";
+ print "# \$host = '$host'\n";
print "ok 1\n";
}
Property changes on: trunk/contrib/perl/ext/Sys-Hostname/t/Hostname.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/ext/Tie-Hash-NamedCapture/NamedCapture.pm
===================================================================
--- trunk/contrib/perl/ext/Tie-Hash-NamedCapture/NamedCapture.pm 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/Tie-Hash-NamedCapture/NamedCapture.pm 2013-12-02 21:32:26 UTC (rev 6445)
@@ -1,7 +1,7 @@
use strict;
package Tie::Hash::NamedCapture;
-our $VERSION = "0.08";
+our $VERSION = "0.09";
require XSLoader;
XSLoader::load(); # This returns true, which makes require happy.
Property changes on: trunk/contrib/perl/ext/Tie-Hash-NamedCapture/NamedCapture.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/ext/Tie-Hash-NamedCapture/NamedCapture.xs
===================================================================
--- trunk/contrib/perl/ext/Tie-Hash-NamedCapture/NamedCapture.xs 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/Tie-Hash-NamedCapture/NamedCapture.xs 2013-12-02 21:32:26 UTC (rev 6445)
@@ -84,7 +84,7 @@
if (!rx || !SvROK(ST(0))) {
if (ix & UNDEF_FATAL)
- Perl_croak_no_modify(aTHX);
+ Perl_croak_no_modify();
else
XSRETURN_UNDEF;
}
Property changes on: trunk/contrib/perl/ext/Tie-Hash-NamedCapture/NamedCapture.xs
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/Tie-Hash-NamedCapture/t/tiehash.t
===================================================================
--- trunk/contrib/perl/ext/Tie-Hash-NamedCapture/t/tiehash.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/Tie-Hash-NamedCapture/t/tiehash.t 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/Tie-Hash-NamedCapture/t/tiehash.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/Tie-Memoize/lib/Tie/Memoize.pm
===================================================================
--- trunk/contrib/perl/ext/Tie-Memoize/lib/Tie/Memoize.pm 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/Tie-Memoize/lib/Tie/Memoize.pm 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/Tie-Memoize/lib/Tie/Memoize.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/Tie-Memoize/t/Tie-Memoize.t
===================================================================
--- trunk/contrib/perl/ext/Tie-Memoize/t/Tie-Memoize.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/Tie-Memoize/t/Tie-Memoize.t 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/Tie-Memoize/t/Tie-Memoize.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/VMS-DCLsym/0README.txt
===================================================================
--- trunk/contrib/perl/ext/VMS-DCLsym/0README.txt 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/VMS-DCLsym/0README.txt 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/VMS-DCLsym/0README.txt
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/VMS-DCLsym/DCLsym.pm
===================================================================
--- trunk/contrib/perl/ext/VMS-DCLsym/DCLsym.pm 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/VMS-DCLsym/DCLsym.pm 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/VMS-DCLsym/DCLsym.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/VMS-DCLsym/DCLsym.xs
===================================================================
--- trunk/contrib/perl/ext/VMS-DCLsym/DCLsym.xs 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/VMS-DCLsym/DCLsym.xs 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/VMS-DCLsym/DCLsym.xs
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/VMS-DCLsym/Makefile.PL
===================================================================
--- trunk/contrib/perl/ext/VMS-DCLsym/Makefile.PL 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/VMS-DCLsym/Makefile.PL 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/VMS-DCLsym/Makefile.PL
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/VMS-DCLsym/t/vms_dclsym.t
===================================================================
--- trunk/contrib/perl/ext/VMS-DCLsym/t/vms_dclsym.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/VMS-DCLsym/t/vms_dclsym.t 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/VMS-DCLsym/t/vms_dclsym.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/VMS-Stdio/0README.txt
===================================================================
--- trunk/contrib/perl/ext/VMS-Stdio/0README.txt 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/VMS-Stdio/0README.txt 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/VMS-Stdio/0README.txt
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/VMS-Stdio/Makefile.PL
===================================================================
--- trunk/contrib/perl/ext/VMS-Stdio/Makefile.PL 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/VMS-Stdio/Makefile.PL 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/VMS-Stdio/Makefile.PL
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/VMS-Stdio/Stdio.pm
===================================================================
--- trunk/contrib/perl/ext/VMS-Stdio/Stdio.pm 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/VMS-Stdio/Stdio.pm 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/VMS-Stdio/Stdio.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/ext/VMS-Stdio/Stdio.xs
===================================================================
--- trunk/contrib/perl/ext/VMS-Stdio/Stdio.xs 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/VMS-Stdio/Stdio.xs 2013-12-02 21:32:26 UTC (rev 6445)
@@ -1,8 +1,6 @@
/* VMS::Stdio - VMS extensions to stdio routines
*
- * Version: 2.3
* Author: Charles Bailey bailey at newman.upenn.edu
- * Revised: 14-Jun-2007
*
*/
@@ -15,9 +13,7 @@
#include <starlet.h>
static bool
-constant(name, pval)
-char *name;
-IV *pval;
+constant(char *name, IV *pval)
{
if (strnNE(name, "O_", 2)) return FALSE;
@@ -295,7 +291,7 @@
PROTOTYPE: @
CODE:
char *args[8],mode[3] = {'r','\0','\0'}, type = '<';
- register int i, myargc;
+ int i, myargc;
FILE *fp;
SV *fh;
PerlIO *pio_fp;
Property changes on: trunk/contrib/perl/ext/VMS-Stdio/Stdio.xs
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/VMS-Stdio/t/vms_stdio.t
===================================================================
--- trunk/contrib/perl/ext/VMS-Stdio/t/vms_stdio.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/VMS-Stdio/t/vms_stdio.t 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/VMS-Stdio/t/vms_stdio.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/Win32CORE/Makefile.PL
===================================================================
--- trunk/contrib/perl/ext/Win32CORE/Makefile.PL 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/Win32CORE/Makefile.PL 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/Win32CORE/Makefile.PL
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/ext/Win32CORE/Win32CORE.c
===================================================================
--- trunk/contrib/perl/ext/Win32CORE/Win32CORE.c 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/Win32CORE/Win32CORE.c 2013-12-02 21:32:26 UTC (rev 6445)
@@ -13,6 +13,7 @@
#if defined(__CYGWIN__) && !defined(USEIMPORTLIB)
#undef WIN32
#endif
+#define PERL_NO_GET_CONTEXT
#include "EXTERN.h"
#if defined(__CYGWIN__) && !defined(USEIMPORTLIB)
#define EXTCONST extern const
@@ -20,11 +21,15 @@
#include "perl.h"
#include "XSUB.h"
-static void
-forward(pTHX_ const char *function)
-{
+
+XS(w32_CORE_all){
dXSARGS;
DWORD err = GetLastError();
+ /* capture the XSANY value before Perl_load_module, the CV's any member will
+ * be overwritten by Perl_load_module and subsequent newXSes or pure perl
+ * subs
+ */
+ const char *function = (const char *) XSANY.any_ptr;
Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn("Win32",5), newSVnv(0.27));
SetLastError(err);
SPAGAIN;
@@ -32,36 +37,7 @@
call_pv(function, GIMME_V);
}
-#define FORWARD(function) XS(w32_##function){ forward(aTHX_ "Win32::"#function); }
-FORWARD(GetCwd)
-FORWARD(SetCwd)
-FORWARD(GetNextAvailDrive)
-FORWARD(GetLastError)
-FORWARD(SetLastError)
-FORWARD(LoginName)
-FORWARD(NodeName)
-FORWARD(DomainName)
-FORWARD(FsType)
-FORWARD(GetOSVersion)
-FORWARD(IsWinNT)
-FORWARD(IsWin95)
-FORWARD(FormatMessage)
-FORWARD(Spawn)
-FORWARD(GetTickCount)
-FORWARD(GetShortPathName)
-FORWARD(GetFullPathName)
-FORWARD(GetLongPathName)
-FORWARD(CopyFile)
-FORWARD(Sleep)
-
-/* Don't forward Win32::SetChildShowWindow(). It accesses the internal variable
- * w32_showwindow in thread_intern and is therefore not implemented in Win32.xs.
- */
-/* FORWARD(SetChildShowWindow) */
-
-#undef FORWARD
-
-XS(boot_Win32CORE)
+XS_EXTERNAL(boot_Win32CORE)
{
/* This function only exists because writemain.SH, lib/ExtUtils/Embed.pm
* and win32/buildext.pl will all generate references to it. The function
@@ -78,27 +54,84 @@
* is not yet fully initialized, so don't do anything fancy in here.
*/
- char *file = __FILE__;
+ static const struct {
+ char Win32__GetCwd [sizeof("Win32::GetCwd")];
+ char Win32__SetCwd [sizeof("Win32::SetCwd")];
+ char Win32__GetNextAvailDrive [sizeof("Win32::GetNextAvailDrive")];
+ char Win32__GetLastError [sizeof("Win32::GetLastError")];
+ char Win32__SetLastError [sizeof("Win32::SetLastError")];
+ char Win32__LoginName [sizeof("Win32::LoginName")];
+ char Win32__NodeName [sizeof("Win32::NodeName")];
+ char Win32__DomainName [sizeof("Win32::DomainName")];
+ char Win32__FsType [sizeof("Win32::FsType")];
+ char Win32__GetOSVersion [sizeof("Win32::GetOSVersion")];
+ char Win32__IsWinNT [sizeof("Win32::IsWinNT")];
+ char Win32__IsWin95 [sizeof("Win32::IsWin95")];
+ char Win32__FormatMessage [sizeof("Win32::FormatMessage")];
+ char Win32__Spawn [sizeof("Win32::Spawn")];
+ char Win32__GetTickCount [sizeof("Win32::GetTickCount")];
+ char Win32__GetShortPathName [sizeof("Win32::GetShortPathName")];
+ char Win32__GetFullPathName [sizeof("Win32::GetFullPathName")];
+ char Win32__GetLongPathName [sizeof("Win32::GetLongPathName")];
+ char Win32__CopyFile [sizeof("Win32::CopyFile")];
+ char Win32__Sleep [sizeof("Win32::Sleep")];
+ } fnname_table = {
+ "Win32::GetCwd",
+ "Win32::SetCwd",
+ "Win32::GetNextAvailDrive",
+ "Win32::GetLastError",
+ "Win32::SetLastError",
+ "Win32::LoginName",
+ "Win32::NodeName",
+ "Win32::DomainName",
+ "Win32::FsType",
+ "Win32::GetOSVersion",
+ "Win32::IsWinNT",
+ "Win32::IsWin95",
+ "Win32::FormatMessage",
+ "Win32::Spawn",
+ "Win32::GetTickCount",
+ "Win32::GetShortPathName",
+ "Win32::GetFullPathName",
+ "Win32::GetLongPathName",
+ "Win32::CopyFile",
+ "Win32::Sleep"
+ };
- newXS("Win32::GetCwd", w32_GetCwd, file);
- newXS("Win32::SetCwd", w32_SetCwd, file);
- newXS("Win32::GetNextAvailDrive", w32_GetNextAvailDrive, file);
- newXS("Win32::GetLastError", w32_GetLastError, file);
- newXS("Win32::SetLastError", w32_SetLastError, file);
- newXS("Win32::LoginName", w32_LoginName, file);
- newXS("Win32::NodeName", w32_NodeName, file);
- newXS("Win32::DomainName", w32_DomainName, file);
- newXS("Win32::FsType", w32_FsType, file);
- newXS("Win32::GetOSVersion", w32_GetOSVersion, file);
- newXS("Win32::IsWinNT", w32_IsWinNT, file);
- newXS("Win32::IsWin95", w32_IsWin95, file);
- newXS("Win32::FormatMessage", w32_FormatMessage, file);
- newXS("Win32::Spawn", w32_Spawn, file);
- newXS("Win32::GetTickCount", w32_GetTickCount, file);
- newXS("Win32::GetShortPathName", w32_GetShortPathName, file);
- newXS("Win32::GetFullPathName", w32_GetFullPathName, file);
- newXS("Win32::GetLongPathName", w32_GetLongPathName, file);
- newXS("Win32::CopyFile", w32_CopyFile, file);
- newXS("Win32::Sleep", w32_Sleep, file);
+ static const unsigned char fnname_lens [] = {
+ sizeof("Win32::GetCwd"),
+ sizeof("Win32::SetCwd"),
+ sizeof("Win32::GetNextAvailDrive"),
+ sizeof("Win32::GetLastError"),
+ sizeof("Win32::SetLastError"),
+ sizeof("Win32::LoginName"),
+ sizeof("Win32::NodeName"),
+ sizeof("Win32::DomainName"),
+ sizeof("Win32::FsType"),
+ sizeof("Win32::GetOSVersion"),
+ sizeof("Win32::IsWinNT"),
+ sizeof("Win32::IsWin95"),
+ sizeof("Win32::FormatMessage"),
+ sizeof("Win32::Spawn"),
+ sizeof("Win32::GetTickCount"),
+ sizeof("Win32::GetShortPathName"),
+ sizeof("Win32::GetFullPathName"),
+ sizeof("Win32::GetLongPathName"),
+ sizeof("Win32::CopyFile"),
+ sizeof("Win32::Sleep")
+ };
+ const unsigned char * len = (const unsigned char *)&fnname_lens;
+ const char * function = (char *)&fnname_table;
+ while (function < (char *)&fnname_table + sizeof(fnname_table)) {
+ const char * const file = __FILE__;
+ CV * const cv = newXS(function, w32_CORE_all, file);
+ XSANY.any_ptr = (void *)function;
+ function += *len++;
+ }
+
+
+ /* Don't forward Win32::SetChildShowWindow(). It accesses the internal variable
+ * w32_showwindow in thread_intern and is therefore not implemented in Win32.xs.
+ */
/* newXS("Win32::SetChildShowWindow", w32_SetChildShowWindow, file); */
}
Property changes on: trunk/contrib/perl/ext/Win32CORE/Win32CORE.c
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/ext/Win32CORE/Win32CORE.pm
===================================================================
--- trunk/contrib/perl/ext/Win32CORE/Win32CORE.pm 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/Win32CORE/Win32CORE.pm 2013-12-02 21:32:26 UTC (rev 6445)
@@ -1,6 +1,6 @@
package Win32CORE;
-$VERSION = '0.02';
+$VERSION = '0.04';
# There is no reason to load this module explicitly. It will be
# initialized using xs_init() when the interpreter is constructed.
Property changes on: trunk/contrib/perl/ext/Win32CORE/Win32CORE.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/Win32CORE/t/win32core.t
===================================================================
--- trunk/contrib/perl/ext/Win32CORE/t/win32core.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/Win32CORE/t/win32core.t 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/Win32CORE/t/win32core.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/ext/XS-APItest/APItest.pm
===================================================================
--- trunk/contrib/perl/ext/XS-APItest/APItest.pm 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/XS-APItest/APItest.pm 2013-12-02 21:32:26 UTC (rev 6445)
@@ -5,6 +5,8 @@
use warnings;
use Carp;
+our $VERSION = '0.51';
+
require XSLoader;
# Export everything since these functions are only used by a test script
@@ -24,6 +26,8 @@
if ($sym_name =~ /::$/) {
# Skip any subpackages that are clearly OO
next if *{$glob}{HASH}{'new'};
+ # and any that have AUTOLOAD
+ next if *{$glob}{HASH}{AUTOLOAD};
push @stashes, "$stash_name$sym_name", *{$glob}{HASH};
} elsif (ref $glob eq 'SCALAR' || *{$glob}{CODE}) {
if ($exports) {
@@ -50,8 +54,6 @@
}
}
-our $VERSION = '0.28';
-
use vars '$WARNINGS_ON_BOOTSTRAP';
use vars map "\$${_}_called_PP", qw(BEGIN UNITCHECK CHECK INIT END);
@@ -94,6 +96,9 @@
XSLoader::load();
}
+# This XS function needs the lvalue attr applied.
+eval 'use attributes __PACKAGE__, \\&lv_temp_object, "lvalue"; 1' or die;
+
1;
__END__
Property changes on: trunk/contrib/perl/ext/XS-APItest/APItest.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/ext/XS-APItest/APItest.xs
===================================================================
--- trunk/contrib/perl/ext/XS-APItest/APItest.xs 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/XS-APItest/APItest.xs 2013-12-02 21:32:26 UTC (rev 6445)
@@ -78,7 +78,7 @@
/* A routine to test hv_delayfree_ent
(which itself is tested by testing on hv_free_ent */
-typedef void (freeent_function)(pTHX_ HV *, register HE *);
+typedef void (freeent_function)(pTHX_ HV *, HE *);
void
test_freeent(freeent_function *f) {
@@ -148,7 +148,7 @@
const char *const end = p + len;
while (p < end) {
STRLEN len;
- UV chr = utf8_to_uvuni((U8 *)p, &len);
+ UV chr = utf8_to_uvuni_buf((U8 *)p, (U8 *) end, &len);
new_p = (char *)uvuni_to_utf8((U8 *)new_p, chr ^ 32);
p += len;
}
@@ -587,6 +587,58 @@
op_lvalue(op_contextualize(argop, G_SCALAR), OP_POSTINC));
}
+STATIC OP *
+THX_ck_entersub_pad_scalar(pTHX_ OP *entersubop, GV *namegv, SV *ckobj)
+{
+ OP *pushop, *argop;
+ PADOFFSET padoff = NOT_IN_PAD;
+ SV *a0, *a1;
+ ck_entersub_args_proto(entersubop, namegv, ckobj);
+ pushop = cUNOPx(entersubop)->op_first;
+ if(!pushop->op_sibling) pushop = cUNOPx(pushop)->op_first;
+ argop = pushop->op_sibling;
+ if(argop->op_type != OP_CONST || argop->op_sibling->op_type != OP_CONST)
+ croak("bad argument expression type for pad_scalar()");
+ a0 = cSVOPx_sv(argop);
+ a1 = cSVOPx_sv(argop->op_sibling);
+ switch(SvIV(a0)) {
+ case 1: {
+ SV *namesv = sv_2mortal(newSVpvs("$"));
+ sv_catsv(namesv, a1);
+ padoff = pad_findmy_sv(namesv, 0);
+ } break;
+ case 2: {
+ char *namepv;
+ STRLEN namelen;
+ SV *namesv = sv_2mortal(newSVpvs("$"));
+ sv_catsv(namesv, a1);
+ namepv = SvPV(namesv, namelen);
+ padoff = pad_findmy_pvn(namepv, namelen, SvUTF8(namesv));
+ } break;
+ case 3: {
+ char *namepv;
+ SV *namesv = sv_2mortal(newSVpvs("$"));
+ sv_catsv(namesv, a1);
+ namepv = SvPV_nolen(namesv);
+ padoff = pad_findmy_pv(namepv, SvUTF8(namesv));
+ } break;
+ case 4: {
+ padoff = pad_findmy_pvs("$foo", 0);
+ } break;
+ default: croak("bad type value for pad_scalar()");
+ }
+ op_free(entersubop);
+ if(padoff == NOT_IN_PAD) {
+ return newSVOP(OP_CONST, 0, newSVpvs("NOT_IN_PAD"));
+ } else if(PAD_COMPNAME_FLAGS_isOUR(padoff)) {
+ return newSVOP(OP_CONST, 0, newSVpvs("NOT_MY"));
+ } else {
+ OP *padop = newOP(OP_PADSV, 0);
+ padop->op_targ = padoff;
+ return padop;
+ }
+}
+
/** RPN keyword parser **/
#define sv_is_glob(sv) (SvTYPE(sv) == SVt_PVGV)
@@ -627,11 +679,7 @@
}
if(s-start < 2) croak("RPN syntax error");
lex_read_to(s);
- {
- /* because pad_findmy() doesn't really use length yet */
- SV *namesv = sv_2mortal(newSVpvn(start, s-start));
- varpos = pad_findmy(SvPVX(namesv), s-start, 0);
- }
+ varpos = pad_findmy_pvn(start, s-start, 0);
if(varpos == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(varpos))
croak("RPN only supports \"my\" variables");
padop = newOP(OP_PADSV, 0);
@@ -843,7 +891,9 @@
OP *sop = parse_barestmt(0);
SV *label = parse_label(PARSE_OPTIONAL);
if (label) sv_2mortal(label);
- return newSTATEOP(0, label ? savepv(SvPVX(label)) : NULL, sop);
+ return newSTATEOP(label ? SvUTF8(label) : 0,
+ label ? savepv(SvPVX(label)) : NULL,
+ sop);
}
#define parse_keyword_labelconst() THX_parse_keyword_labelconst(aTHX)
@@ -1015,11 +1065,65 @@
return SvCUR(buf_sv);
}
+static AV *
+myget_linear_isa(pTHX_ HV *stash, U32 level) {
+ GV **gvp = (GV **)hv_fetchs(stash, "ISA", 0);
+ PERL_UNUSED_ARG(level);
+ return gvp && *gvp && GvAV(*gvp)
+ ? GvAV(*gvp)
+ : (AV *)sv_2mortal((SV *)newAV());
+}
-XS(XS_XS__APItest__XSUB_XS_VERSION_undef);
-XS(XS_XS__APItest__XSUB_XS_VERSION_empty);
-XS(XS_XS__APItest__XSUB_XS_APIVERSION_invalid);
+XS_EXTERNAL(XS_XS__APItest__XSUB_XS_VERSION_undef);
+XS_EXTERNAL(XS_XS__APItest__XSUB_XS_VERSION_empty);
+XS_EXTERNAL(XS_XS__APItest__XSUB_XS_APIVERSION_invalid);
+
+static struct mro_alg mymro;
+
+static Perl_check_t addissub_nxck_add;
+
+static OP *
+addissub_myck_add(pTHX_ OP *op)
+{
+ SV **flag_svp = hv_fetchs(GvHV(PL_hintgv), "XS::APItest/addissub", 0);
+ OP *aop, *bop;
+ U8 flags;
+ if (!(flag_svp && SvTRUE(*flag_svp) && (op->op_flags & OPf_KIDS) &&
+ (aop = cBINOPx(op)->op_first) && (bop = aop->op_sibling) &&
+ !bop->op_sibling))
+ return addissub_nxck_add(aTHX_ op);
+ aop->op_sibling = NULL;
+ cBINOPx(op)->op_first = NULL;
+ op->op_flags &= ~OPf_KIDS;
+ flags = op->op_flags;
+ op_free(op);
+ return newBINOP(OP_SUBTRACT, flags, aop, bop);
+}
+
+static Perl_check_t old_ck_rv2cv;
+
+static OP *
+my_ck_rv2cv(pTHX_ OP *o)
+{
+ SV *ref;
+ SV **flag_svp = hv_fetchs(GvHV(PL_hintgv), "XS::APItest/addunder", 0);
+ OP *aop;
+
+ if (flag_svp && SvTRUE(*flag_svp) && (o->op_flags & OPf_KIDS)
+ && (aop = cUNOPx(o)->op_first) && aop->op_type == OP_CONST
+ && aop->op_private & (OPpCONST_ENTERED|OPpCONST_BARE)
+ && (ref = cSVOPx(aop)->op_sv) && SvPOK(ref) && SvCUR(ref)
+ && *(SvEND(ref)-1) == 'o')
+ {
+ SvGROW(ref, SvCUR(ref)+2);
+ *SvEND(ref) = '_';
+ SvCUR(ref)++;
+ *SvEND(ref) = '\0';
+ }
+ return old_ck_rv2cv(aTHX_ o);
+}
+
#include "const-c.inc"
MODULE = XS::APItest PACKAGE = XS::APItest
@@ -1046,6 +1150,41 @@
OUTPUT:
RETVAL
+AV *
+test_utf8n_to_uvuni(s, len, flags)
+
+ SV *s
+ SV *len
+ SV *flags
+ PREINIT:
+ STRLEN retlen;
+ UV ret;
+ STRLEN slen;
+
+ CODE:
+ /* Call utf8n_to_uvuni() with the inputs. It always asks for the
+ * actual length to be returned
+ *
+ * Length to assume <s> is; not checked, so could have buffer overflow
+ */
+ RETVAL = newAV();
+ sv_2mortal((SV*)RETVAL);
+
+ ret
+ = utf8n_to_uvuni((U8*) SvPV(s, slen), SvUV(len), &retlen, SvUV(flags));
+
+ /* Returns the return value in [0]; <retlen> in [1] */
+ av_push(RETVAL, newSVuv(ret));
+ if (retlen == (STRLEN) -1) {
+ av_push(RETVAL, newSViv(-1));
+ }
+ else {
+ av_push(RETVAL, newSVuv(retlen));
+ }
+
+ OUTPUT:
+ RETVAL
+
MODULE = XS::APItest:Overload PACKAGE = XS::APItest::Overload
void
@@ -1469,10 +1608,36 @@
ptr_table_clear(table)
XS::APItest::PtrTable table
+MODULE = XS::APItest::AutoLoader PACKAGE = XS::APItest::AutoLoader
+
+SV *
+AUTOLOAD()
+ CODE:
+ RETVAL = newSVpvn_flags(SvPVX(cv), SvCUR(cv), SvUTF8(cv));
+ OUTPUT:
+ RETVAL
+
+SV *
+AUTOLOADp(...)
+ PROTOTYPE: *$
+ CODE:
+ RETVAL = newSVpvn_flags(SvPVX(cv), SvCUR(cv), SvUTF8(cv));
+ OUTPUT:
+ RETVAL
+
+
MODULE = XS::APItest PACKAGE = XS::APItest
PROTOTYPES: DISABLE
+BOOT:
+ mymro.resolve = myget_linear_isa;
+ mymro.name = "justisa";
+ mymro.length = 7;
+ mymro.kflags = 0;
+ mymro.hash = 0;
+ Perl_mro_register(aTHX_ &mymro);
+
HV *
xop_custom_ops ()
CODE:
@@ -1792,6 +1957,200 @@
PUSHs(sv_2mortal(newSViv(i)));
void
+newCONSTSUB(stash, name, flags, sv)
+ HV* stash
+ SV* name
+ I32 flags
+ SV* sv
+ ALIAS:
+ newCONSTSUB_flags = 1
+ PREINIT:
+ CV* mycv;
+ STRLEN len;
+ const char *pv = SvPV(name, len);
+ PPCODE:
+ switch (ix) {
+ case 0:
+ mycv = newCONSTSUB(stash, pv, SvOK(sv) ? SvREFCNT_inc(sv) : NULL);
+ break;
+ case 1:
+ mycv = newCONSTSUB_flags(
+ stash, pv, len, flags | SvUTF8(name), SvOK(sv) ? SvREFCNT_inc(sv) : NULL
+ );
+ break;
+ }
+ EXTEND(SP, 2);
+ PUSHs( CvCONST(mycv) ? &PL_sv_yes : &PL_sv_no );
+ PUSHs((SV*)CvGV(mycv));
+
+void
+gv_init_type(namesv, multi, flags, type)
+ SV* namesv
+ int multi
+ I32 flags
+ int type
+ PREINIT:
+ STRLEN len;
+ const char * const name = SvPV_const(namesv, len);
+ GV *gv = *(GV**)hv_fetch(PL_defstash, name, len, TRUE);
+ PPCODE:
+ if (SvTYPE(gv) == SVt_PVGV)
+ Perl_croak(aTHX_ "GV is already a PVGV");
+ if (multi) flags |= GV_ADDMULTI;
+ switch (type) {
+ case 0:
+ gv_init(gv, PL_defstash, name, len, multi);
+ break;
+ case 1:
+ gv_init_sv(gv, PL_defstash, namesv, flags);
+ break;
+ case 2:
+ gv_init_pv(gv, PL_defstash, name, flags | SvUTF8(namesv));
+ break;
+ case 3:
+ gv_init_pvn(gv, PL_defstash, name, len, flags | SvUTF8(namesv));
+ break;
+ }
+ XPUSHs( gv ? (SV*)gv : &PL_sv_undef);
+
+void
+gv_fetchmeth_type(stash, methname, type, level, flags)
+ HV* stash
+ SV* methname
+ int type
+ I32 level
+ I32 flags
+ PREINIT:
+ STRLEN len;
+ const char * const name = SvPV_const(methname, len);
+ GV* gv;
+ PPCODE:
+ switch (type) {
+ case 0:
+ gv = gv_fetchmeth(stash, name, len, level);
+ break;
+ case 1:
+ gv = gv_fetchmeth_sv(stash, methname, level, flags);
+ break;
+ case 2:
+ gv = gv_fetchmeth_pv(stash, name, level, flags | SvUTF8(methname));
+ break;
+ case 3:
+ gv = gv_fetchmeth_pvn(stash, name, len, level, flags | SvUTF8(methname));
+ break;
+ }
+ XPUSHs( gv ? MUTABLE_SV(gv) : &PL_sv_undef );
+
+void
+gv_fetchmeth_autoload_type(stash, methname, type, level, flags)
+ HV* stash
+ SV* methname
+ int type
+ I32 level
+ I32 flags
+ PREINIT:
+ STRLEN len;
+ const char * const name = SvPV_const(methname, len);
+ GV* gv;
+ PPCODE:
+ switch (type) {
+ case 0:
+ gv = gv_fetchmeth_autoload(stash, name, len, level);
+ break;
+ case 1:
+ gv = gv_fetchmeth_sv_autoload(stash, methname, level, flags);
+ break;
+ case 2:
+ gv = gv_fetchmeth_pv_autoload(stash, name, level, flags | SvUTF8(methname));
+ break;
+ case 3:
+ gv = gv_fetchmeth_pvn_autoload(stash, name, len, level, flags | SvUTF8(methname));
+ break;
+ }
+ XPUSHs( gv ? MUTABLE_SV(gv) : &PL_sv_undef );
+
+void
+gv_fetchmethod_flags_type(stash, methname, type, flags)
+ HV* stash
+ SV* methname
+ int type
+ I32 flags
+ PREINIT:
+ GV* gv;
+ PPCODE:
+ switch (type) {
+ case 0:
+ gv = gv_fetchmethod_flags(stash, SvPVX_const(methname), flags);
+ break;
+ case 1:
+ gv = gv_fetchmethod_sv_flags(stash, methname, flags);
+ break;
+ case 2:
+ gv = gv_fetchmethod_pv_flags(stash, SvPV_nolen(methname), flags | SvUTF8(methname));
+ break;
+ case 3: {
+ STRLEN len;
+ const char * const name = SvPV_const(methname, len);
+ gv = gv_fetchmethod_pvn_flags(stash, name, len, flags | SvUTF8(methname));
+ break;
+ }
+ }
+ XPUSHs( gv ? (SV*)gv : &PL_sv_undef);
+
+void
+gv_autoload_type(stash, methname, type, method)
+ HV* stash
+ SV* methname
+ int type
+ I32 method
+ PREINIT:
+ STRLEN len;
+ const char * const name = SvPV_const(methname, len);
+ GV* gv;
+ I32 flags = method ? GV_AUTOLOAD_ISMETHOD : 0;
+ PPCODE:
+ switch (type) {
+ case 0:
+ gv = gv_autoload4(stash, name, len, method);
+ break;
+ case 1:
+ gv = gv_autoload_sv(stash, methname, flags);
+ break;
+ case 2:
+ gv = gv_autoload_pv(stash, name, flags | SvUTF8(methname));
+ break;
+ case 3:
+ gv = gv_autoload_pvn(stash, name, len, flags | SvUTF8(methname));
+ break;
+ }
+ XPUSHs( gv ? (SV*)gv : &PL_sv_undef);
+
+void
+whichsig_type(namesv, type)
+ SV* namesv
+ int type
+ PREINIT:
+ STRLEN len;
+ const char * const name = SvPV_const(namesv, len);
+ I32 i;
+ PPCODE:
+ switch (type) {
+ case 0:
+ i = whichsig(name);
+ break;
+ case 1:
+ i = whichsig_sv(namesv);
+ break;
+ case 2:
+ i = whichsig_pv(name);
+ break;
+ case 3:
+ i = whichsig_pvn(name, len);
+ break;
+ }
+ XPUSHs(sv_2mortal(newSViv(i)));
+
+void
eval_sv(sv, flags)
SV* sv
I32 flags
@@ -1883,6 +2242,21 @@
sv_setsv_cow_hashkey_notcore()
void
+sv_set_deref(SV *sv, SV *sv2, int which)
+ CODE:
+ {
+ STRLEN len;
+ const char *pv = SvPV(sv2,len);
+ if (!SvROK(sv)) croak("Not a ref");
+ sv = SvRV(sv);
+ switch (which) {
+ case 0: sv_setsv(sv,sv2); break;
+ case 1: sv_setpv(sv,pv); break;
+ case 2: sv_setpvn(sv,pv,len); break;
+ }
+ }
+
+void
rmagical_cast(sv, type)
SV *sv;
SV *type;
@@ -2348,6 +2722,28 @@
#undef msvpvs
#undef msviv
+void
+test_coplabel()
+ PREINIT:
+ COP *cop;
+ const char *label;
+ STRLEN len;
+ U32 utf8;
+ CODE:
+ cop = &PL_compiling;
+ Perl_cop_store_label(aTHX_ cop, "foo", 3, 0);
+ label = Perl_cop_fetch_label(aTHX_ cop, &len, &utf8);
+ if (strcmp(label,"foo")) croak("fail # cop_fetch_label label");
+ if (len != 3) croak("fail # cop_fetch_label len");
+ if (utf8) croak("fail # cop_fetch_label utf8");
+ /* SMALL GERMAN UMLAUT A */
+ Perl_cop_store_label(aTHX_ cop, "fo\xc3\xa4", 4, SVf_UTF8);
+ label = Perl_cop_fetch_label(aTHX_ cop, &len, &utf8);
+ if (strcmp(label,"fo\xc3\xa4")) croak("fail # cop_fetch_label label");
+ if (len != 4) croak("fail # cop_fetch_label len");
+ if (!utf8) croak("fail # cop_fetch_label utf8");
+
+
HV *
example_cophh_2hv()
PREINIT:
@@ -2682,7 +3078,63 @@
XSRETURN_UNDEF;
}
+#ifdef USE_ITHREADS
+void
+clone_with_stack()
+CODE:
+{
+ PerlInterpreter *interp = aTHX; /* The original interpreter */
+ PerlInterpreter *interp_dup; /* The duplicate interpreter */
+ int oldscope = 1; /* We are responsible for all scopes */
+
+ interp_dup = perl_clone(interp, CLONEf_COPY_STACKS | CLONEf_CLONE_HOST );
+
+ /* destroy old perl */
+ PERL_SET_CONTEXT(interp);
+
+ POPSTACK_TO(PL_mainstack);
+ dounwind(-1);
+ LEAVE_SCOPE(0);
+
+ while (interp->Iscopestack_ix > 1)
+ LEAVE;
+ FREETMPS;
+
+ perl_destruct(interp);
+ perl_free(interp);
+
+ /* switch to new perl */
+ PERL_SET_CONTEXT(interp_dup);
+
+ /* continue after 'clone_with_stack' */
+ if (interp_dup->Iop)
+ interp_dup->Iop = interp_dup->Iop->op_next;
+
+ /* run with new perl */
+ Perl_runops_standard(interp_dup);
+
+ /* We may have additional unclosed scopes if fork() was called
+ * from within a BEGIN block. See perlfork.pod for more details.
+ * We cannot clean up these other scopes because they belong to a
+ * different interpreter, but we also cannot leave PL_scopestack_ix
+ * dangling because that can trigger an assertion in perl_destruct().
+ */
+ if (PL_scopestack_ix > oldscope) {
+ PL_scopestack[oldscope-1] = PL_scopestack[PL_scopestack_ix-1];
+ PL_scopestack_ix = oldscope;
+ }
+
+ perl_destruct(interp_dup);
+ perl_free(interp_dup);
+
+ /* call the real 'exit' not PerlProc_exit */
+#undef exit
+ exit(0);
+}
+
+#endif /* USE_ITHREDS */
+
SV*
take_svref(SVREF sv)
CODE:
@@ -2781,6 +3233,255 @@
cv_set_call_checker(asscv, THX_ck_entersub_postinc, (SV*)asscv);
}
+SV *
+lv_temp_object()
+CODE:
+ RETVAL =
+ sv_bless(
+ newRV_noinc(newSV(0)),
+ gv_stashpvs("XS::APItest::TempObj",GV_ADD)
+ ); /* Package defined in test script */
+OUTPUT:
+ RETVAL
+
+void
+fill_hash_with_nulls(HV *hv)
+PREINIT:
+ UV i = 0;
+CODE:
+ for(; i < 1000; ++i) {
+ HE *entry = hv_fetch_ent(hv, sv_2mortal(newSVuv(i)), 1, 0);
+ SvREFCNT_dec(HeVAL(entry));
+ HeVAL(entry) = NULL;
+ }
+
+HV *
+newHVhv(HV *hv)
+CODE:
+ RETVAL = newHVhv(hv);
+OUTPUT:
+ RETVAL
+
+U32
+SvIsCOW(SV *sv)
+CODE:
+ RETVAL = SvIsCOW(sv);
+OUTPUT:
+ RETVAL
+
+void
+pad_scalar(...)
+PROTOTYPE: $$
+CODE:
+ PERL_UNUSED_VAR(items);
+ croak("pad_scalar called as a function");
+
+BOOT:
+{
+ CV *pscv = get_cv("XS::APItest::pad_scalar", 0);
+ cv_set_call_checker(pscv, THX_ck_entersub_pad_scalar, (SV*)pscv);
+}
+
+SV*
+fetch_pad_names( cv )
+CV* cv
+ PREINIT:
+ I32 i;
+ PADNAMELIST *pad_namelist;
+ AV *retav = newAV();
+ CODE:
+ pad_namelist = PadlistNAMES(CvPADLIST(cv));
+
+ for ( i = PadnamelistMAX(pad_namelist); i >= 0; i-- ) {
+ PADNAME* name = PadnamelistARRAY(pad_namelist)[i];
+
+ if (SvPOKp(name)) {
+ av_push(retav, newSVpadname(name));
+ }
+ }
+ RETVAL = newRV_noinc((SV*)retav);
+ OUTPUT:
+ RETVAL
+
+STRLEN
+underscore_length()
+PROTOTYPE:
+PREINIT:
+ SV *u;
+ U8 *pv;
+ STRLEN bytelen;
+CODE:
+ u = find_rundefsv();
+ pv = (U8*)SvPV(u, bytelen);
+ RETVAL = SvUTF8(u) ? utf8_length(pv, pv+bytelen) : bytelen;
+OUTPUT:
+ RETVAL
+
+void
+stringify(SV *sv)
+PREINIT:
+ const char *pv;
+CODE:
+ pv = SvPV_nolen(sv);
+
+SV *
+HvENAME(HV *hv)
+CODE:
+ RETVAL = hv && HvENAME(hv)
+ ? newSVpvn_flags(
+ HvENAME(hv),HvENAMELEN(hv),
+ (HvENAMEUTF8(hv) ? SVf_UTF8 : 0)
+ )
+ : NULL;
+OUTPUT:
+ RETVAL
+
+int
+xs_cmp(int a, int b)
+CODE:
+ /* Odd sorting (odd numbers first), to make sure we are actually
+ being called */
+ RETVAL = a % 2 != b % 2
+ ? a % 2 ? -1 : 1
+ : a < b ? -1 : a == b ? 0 : 1;
+OUTPUT:
+ RETVAL
+
+SV *
+xs_cmp_undef(SV *a, SV *b)
+CODE:
+ RETVAL = &PL_sv_undef;
+OUTPUT:
+ RETVAL
+
+char *
+SvPVbyte(SV *sv)
+CODE:
+ RETVAL = SvPVbyte_nolen(sv);
+OUTPUT:
+ RETVAL
+
+char *
+SvPVutf8(SV *sv)
+CODE:
+ RETVAL = SvPVutf8_nolen(sv);
+OUTPUT:
+ RETVAL
+
+void
+setup_addissub()
+CODE:
+ wrap_op_checker(OP_ADD, addissub_myck_add, &addissub_nxck_add);
+
+void
+setup_rv2cv_addunderbar()
+CODE:
+ wrap_op_checker(OP_RV2CV, my_ck_rv2cv, &old_ck_rv2cv);
+
+#ifdef USE_ITHREADS
+
+bool
+test_alloccopstash()
+CODE:
+ RETVAL = PL_stashpad[alloccopstash(PL_defstash)] == PL_defstash;
+OUTPUT:
+ RETVAL
+
+#endif
+
+bool
+test_newFOROP_without_slab()
+CODE:
+ {
+ const I32 floor = start_subparse(0,0);
+ CV * const cv = PL_compcv;
+ /* The slab allocator does not like CvROOT being set. */
+ CvROOT(PL_compcv) = (OP *)1;
+ op_free(newFOROP(0, 0, newOP(OP_PUSHMARK, 0), 0, 0));
+ CvROOT(PL_compcv) = NULL;
+ SvREFCNT_dec(PL_compcv);
+ LEAVE_SCOPE(floor);
+ /* If we have not crashed yet, then the test passes. */
+ RETVAL = TRUE;
+ }
+OUTPUT:
+ RETVAL
+
+ # provide access to CALLREGEXEC, except replace pointers within the
+ # string with offsets from the start of the string
+
+I32
+callregexec(SV *prog, STRLEN stringarg, STRLEN strend, I32 minend, SV *sv, U32 nosave)
+CODE:
+ {
+ STRLEN len;
+ char *strbeg;
+ if (SvROK(prog))
+ prog = SvRV(prog);
+ strbeg = SvPV_force(sv, len);
+ RETVAL = CALLREGEXEC((REGEXP *)prog,
+ strbeg + stringarg,
+ strbeg + strend,
+ strbeg,
+ minend,
+ sv,
+ NULL, /* data */
+ nosave);
+ }
+OUTPUT:
+ RETVAL
+
+void
+lexical_import(SV *name, CV *cv)
+ CODE:
+ {
+ PADLIST *pl;
+ PADOFFSET off;
+ if (!PL_compcv)
+ Perl_croak(aTHX_
+ "lexical_import can only be called at compile time");
+ pl = CvPADLIST(PL_compcv);
+ ENTER;
+ SAVESPTR(PL_comppad_name); PL_comppad_name = PadlistNAMES(pl);
+ SAVESPTR(PL_comppad); PL_comppad = PadlistARRAY(pl)[1];
+ SAVESPTR(PL_curpad); PL_curpad = PadARRAY(PL_comppad);
+ off = pad_add_name_sv(sv_2mortal(newSVpvf("&%"SVf,name)),
+ padadd_STATE, 0, 0);
+ SvREFCNT_dec(PL_curpad[off]);
+ PL_curpad[off] = SvREFCNT_inc(cv);
+ LEAVE;
+ }
+
+SV *
+sv_mortalcopy(SV *sv)
+ CODE:
+ RETVAL = SvREFCNT_inc(sv_mortalcopy(sv));
+ OUTPUT:
+ RETVAL
+
+MODULE = XS::APItest PACKAGE = XS::APItest::AUTOLOADtest
+
+int
+AUTOLOAD(...)
+ INIT:
+ SV* comms;
+ SV* class_and_method;
+ CODE:
+ class_and_method = GvSV(CvGV(cv));
+ comms = get_sv("main::the_method", 1);
+ if (class_and_method == NULL) {
+ RETVAL = 1;
+ } else if (!SvOK(class_and_method)) {
+ RETVAL = 2;
+ } else if (!SvPOK(class_and_method)) {
+ RETVAL = 3;
+ } else {
+ sv_setsv(comms, class_and_method);
+ RETVAL = 0;
+ }
+ OUTPUT: RETVAL
+
+
MODULE = XS::APItest PACKAGE = XS::APItest::Magic
PROTOTYPES: DISABLE
@@ -2808,3 +3509,937 @@
sv_unmagic_bar = 1
CODE:
sv_unmagicext(SvRV(sv), PERL_MAGIC_ext, ix ? &vtbl_bar : &vtbl_foo);
+
+UV
+test_get_vtbl()
+ PREINIT:
+ MGVTBL *have;
+ MGVTBL *want;
+ CODE:
+#define test_get_this_vtable(name) \
+ want = CAT2(&PL_vtbl_, name); \
+ have = get_vtbl(CAT2(want_vtbl_, name)); \
+ if (have != want) \
+ croak("fail %p!=%p for get_vtbl(want_vtbl_" STRINGIFY(name) ") at " __FILE__ " line %d", have, want, __LINE__)
+
+ test_get_this_vtable(sv);
+ test_get_this_vtable(env);
+ test_get_this_vtable(envelem);
+ test_get_this_vtable(sigelem);
+ test_get_this_vtable(pack);
+ test_get_this_vtable(packelem);
+ test_get_this_vtable(dbline);
+ test_get_this_vtable(isa);
+ test_get_this_vtable(isaelem);
+ test_get_this_vtable(arylen);
+ test_get_this_vtable(mglob);
+ test_get_this_vtable(nkeys);
+ test_get_this_vtable(taint);
+ test_get_this_vtable(substr);
+ test_get_this_vtable(vec);
+ test_get_this_vtable(pos);
+ test_get_this_vtable(bm);
+ test_get_this_vtable(fm);
+ test_get_this_vtable(uvar);
+ test_get_this_vtable(defelem);
+ test_get_this_vtable(regexp);
+ test_get_this_vtable(regdata);
+ test_get_this_vtable(regdatum);
+#ifdef USE_LOCALE_COLLATE
+ test_get_this_vtable(collxfrm);
+#endif
+ test_get_this_vtable(backref);
+ test_get_this_vtable(utf8);
+
+ RETVAL = PTR2UV(get_vtbl(-1));
+ OUTPUT:
+ RETVAL
+
+bool
+test_isBLANK_uni(UV ord)
+ CODE:
+ RETVAL = isBLANK_uni(ord);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isBLANK_LC_uvchr(UV ord)
+ CODE:
+ RETVAL = isBLANK_LC_uvchr(ord);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isBLANK_A(UV ord)
+ CODE:
+ RETVAL = isBLANK_A(ord);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isBLANK_L1(UV ord)
+ CODE:
+ RETVAL = isBLANK_L1(ord);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isBLANK_LC(UV ord)
+ CODE:
+ RETVAL = isBLANK_LC(ord);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isBLANK_utf8(unsigned char * p)
+ CODE:
+ RETVAL = isBLANK_utf8(p);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isBLANK_LC_utf8(unsigned char * p)
+ CODE:
+ RETVAL = isBLANK_LC_utf8(p);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isVERTWS_uni(UV ord)
+ CODE:
+ RETVAL = isVERTWS_uni(ord);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isVERTWS_utf8(unsigned char * p)
+ CODE:
+ RETVAL = isVERTWS_utf8(p);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isUPPER_uni(UV ord)
+ CODE:
+ RETVAL = isUPPER_uni(ord);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isUPPER_LC_uvchr(UV ord)
+ CODE:
+ RETVAL = isUPPER_LC_uvchr(ord);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isUPPER_A(UV ord)
+ CODE:
+ RETVAL = isUPPER_A(ord);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isUPPER_L1(UV ord)
+ CODE:
+ RETVAL = isUPPER_L1(ord);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isUPPER_LC(UV ord)
+ CODE:
+ RETVAL = isUPPER_LC(ord);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isUPPER_utf8(unsigned char * p)
+ CODE:
+ RETVAL = isUPPER_utf8( p);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isUPPER_LC_utf8(unsigned char * p)
+ CODE:
+ RETVAL = isUPPER_LC_utf8( p);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isLOWER_uni(UV ord)
+ CODE:
+ RETVAL = isLOWER_uni(ord);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isLOWER_LC_uvchr(UV ord)
+ CODE:
+ RETVAL = isLOWER_LC_uvchr(ord);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isLOWER_A(UV ord)
+ CODE:
+ RETVAL = isLOWER_A(ord);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isLOWER_L1(UV ord)
+ CODE:
+ RETVAL = isLOWER_L1(ord);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isLOWER_LC(UV ord)
+ CODE:
+ RETVAL = isLOWER_LC(ord);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isLOWER_utf8(unsigned char * p)
+ CODE:
+ RETVAL = isLOWER_utf8( p);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isLOWER_LC_utf8(unsigned char * p)
+ CODE:
+ RETVAL = isLOWER_LC_utf8( p);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isALPHA_uni(UV ord)
+ CODE:
+ RETVAL = isALPHA_uni(ord);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isALPHA_LC_uvchr(UV ord)
+ CODE:
+ RETVAL = isALPHA_LC_uvchr(ord);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isALPHA_A(UV ord)
+ CODE:
+ RETVAL = isALPHA_A(ord);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isALPHA_L1(UV ord)
+ CODE:
+ RETVAL = isALPHA_L1(ord);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isALPHA_LC(UV ord)
+ CODE:
+ RETVAL = isALPHA_LC(ord);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isALPHA_utf8(unsigned char * p)
+ CODE:
+ RETVAL = isALPHA_utf8( p);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isALPHA_LC_utf8(unsigned char * p)
+ CODE:
+ RETVAL = isALPHA_LC_utf8( p);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isWORDCHAR_uni(UV ord)
+ CODE:
+ RETVAL = isWORDCHAR_uni(ord);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isWORDCHAR_LC_uvchr(UV ord)
+ CODE:
+ RETVAL = isWORDCHAR_LC_uvchr(ord);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isWORDCHAR_A(UV ord)
+ CODE:
+ RETVAL = isWORDCHAR_A(ord);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isWORDCHAR_L1(UV ord)
+ CODE:
+ RETVAL = isWORDCHAR_L1(ord);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isWORDCHAR_LC(UV ord)
+ CODE:
+ RETVAL = isWORDCHAR_LC(ord);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isWORDCHAR_utf8(unsigned char * p)
+ CODE:
+ RETVAL = isWORDCHAR_utf8( p);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isWORDCHAR_LC_utf8(unsigned char * p)
+ CODE:
+ RETVAL = isWORDCHAR_LC_utf8( p);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isALPHANUMERIC_uni(UV ord)
+ CODE:
+ RETVAL = isALPHANUMERIC_uni(ord);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isALPHANUMERIC_LC_uvchr(UV ord)
+ CODE:
+ RETVAL = isALPHANUMERIC_LC_uvchr(ord);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isALPHANUMERIC_A(UV ord)
+ CODE:
+ RETVAL = isALPHANUMERIC_A(ord);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isALPHANUMERIC_L1(UV ord)
+ CODE:
+ RETVAL = isALPHANUMERIC_L1(ord);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isALPHANUMERIC_LC(UV ord)
+ CODE:
+ RETVAL = isALPHANUMERIC_LC(ord);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isALPHANUMERIC_utf8(unsigned char * p)
+ CODE:
+ RETVAL = isALPHANUMERIC_utf8( p);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isALPHANUMERIC_LC_utf8(unsigned char * p)
+ CODE:
+ RETVAL = isALPHANUMERIC_LC_utf8( p);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isALNUM_uni(UV ord)
+ CODE:
+ RETVAL = isALNUM_uni(ord);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isALNUM_LC_uvchr(UV ord)
+ CODE:
+ RETVAL = isALNUM_LC_uvchr(ord);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isALNUM_LC(UV ord)
+ CODE:
+ RETVAL = isALNUM_LC(ord);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isALNUM_utf8(unsigned char * p)
+ CODE:
+ RETVAL = isALNUM_utf8( p);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isALNUM_LC_utf8(unsigned char * p)
+ CODE:
+ RETVAL = isALNUM_LC_utf8( p);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isDIGIT_uni(UV ord)
+ CODE:
+ RETVAL = isDIGIT_uni(ord);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isDIGIT_LC_uvchr(UV ord)
+ CODE:
+ RETVAL = isDIGIT_LC_uvchr(ord);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isDIGIT_utf8(unsigned char * p)
+ CODE:
+ RETVAL = isDIGIT_utf8( p);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isDIGIT_LC_utf8(unsigned char * p)
+ CODE:
+ RETVAL = isDIGIT_LC_utf8( p);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isDIGIT_A(UV ord)
+ CODE:
+ RETVAL = isDIGIT_A(ord);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isDIGIT_L1(UV ord)
+ CODE:
+ RETVAL = isDIGIT_L1(ord);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isDIGIT_LC(UV ord)
+ CODE:
+ RETVAL = isDIGIT_LC(ord);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isIDFIRST_uni(UV ord)
+ CODE:
+ RETVAL = isIDFIRST_uni(ord);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isIDFIRST_LC_uvchr(UV ord)
+ CODE:
+ RETVAL = isIDFIRST_LC_uvchr(ord);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isIDFIRST_A(UV ord)
+ CODE:
+ RETVAL = isIDFIRST_A(ord);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isIDFIRST_L1(UV ord)
+ CODE:
+ RETVAL = isIDFIRST_L1(ord);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isIDFIRST_LC(UV ord)
+ CODE:
+ RETVAL = isIDFIRST_LC(ord);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isIDFIRST_utf8(unsigned char * p)
+ CODE:
+ RETVAL = isIDFIRST_utf8( p);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isIDFIRST_LC_utf8(unsigned char * p)
+ CODE:
+ RETVAL = isIDFIRST_LC_utf8( p);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isIDCONT_uni(UV ord)
+ CODE:
+ RETVAL = isIDCONT_uni(ord);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isIDCONT_LC_uvchr(UV ord)
+ CODE:
+ RETVAL = isIDCONT_LC_uvchr(ord);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isIDCONT_A(UV ord)
+ CODE:
+ RETVAL = isIDCONT_A(ord);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isIDCONT_L1(UV ord)
+ CODE:
+ RETVAL = isIDCONT_L1(ord);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isIDCONT_LC(UV ord)
+ CODE:
+ RETVAL = isIDCONT_LC(ord);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isIDCONT_utf8(unsigned char * p)
+ CODE:
+ RETVAL = isIDCONT_utf8( p);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isIDCONT_LC_utf8(unsigned char * p)
+ CODE:
+ RETVAL = isIDCONT_LC_utf8( p);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isSPACE_uni(UV ord)
+ CODE:
+ RETVAL = isSPACE_uni(ord);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isSPACE_LC_uvchr(UV ord)
+ CODE:
+ RETVAL = isSPACE_LC_uvchr(ord);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isSPACE_A(UV ord)
+ CODE:
+ RETVAL = isSPACE_A(ord);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isSPACE_L1(UV ord)
+ CODE:
+ RETVAL = isSPACE_L1(ord);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isSPACE_LC(UV ord)
+ CODE:
+ RETVAL = isSPACE_LC(ord);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isSPACE_utf8(unsigned char * p)
+ CODE:
+ RETVAL = isSPACE_utf8( p);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isSPACE_LC_utf8(unsigned char * p)
+ CODE:
+ RETVAL = isSPACE_LC_utf8( p);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isASCII_uni(UV ord)
+ CODE:
+ RETVAL = isASCII_uni(ord);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isASCII_LC_uvchr(UV ord)
+ CODE:
+ RETVAL = isASCII_LC_uvchr(ord);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isASCII_A(UV ord)
+ CODE:
+ RETVAL = isASCII_A(ord);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isASCII_L1(UV ord)
+ CODE:
+ RETVAL = isASCII_L1(ord);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isASCII_LC(UV ord)
+ CODE:
+ RETVAL = isASCII_LC(ord);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isASCII_utf8(unsigned char * p)
+ CODE:
+ RETVAL = isASCII_utf8( p);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isASCII_LC_utf8(unsigned char * p)
+ CODE:
+ RETVAL = isASCII_LC_utf8( p);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isCNTRL_uni(UV ord)
+ CODE:
+ RETVAL = isCNTRL_uni(ord);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isCNTRL_LC_uvchr(UV ord)
+ CODE:
+ RETVAL = isCNTRL_LC_uvchr(ord);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isCNTRL_A(UV ord)
+ CODE:
+ RETVAL = isCNTRL_A(ord);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isCNTRL_L1(UV ord)
+ CODE:
+ RETVAL = isCNTRL_L1(ord);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isCNTRL_LC(UV ord)
+ CODE:
+ RETVAL = isCNTRL_LC(ord);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isCNTRL_utf8(unsigned char * p)
+ CODE:
+ RETVAL = isCNTRL_utf8( p);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isCNTRL_LC_utf8(unsigned char * p)
+ CODE:
+ RETVAL = isCNTRL_LC_utf8( p);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isPRINT_uni(UV ord)
+ CODE:
+ RETVAL = isPRINT_uni(ord);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isPRINT_LC_uvchr(UV ord)
+ CODE:
+ RETVAL = isPRINT_LC_uvchr(ord);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isPRINT_A(UV ord)
+ CODE:
+ RETVAL = isPRINT_A(ord);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isPRINT_L1(UV ord)
+ CODE:
+ RETVAL = isPRINT_L1(ord);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isPRINT_LC(UV ord)
+ CODE:
+ RETVAL = isPRINT_LC(ord);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isPRINT_utf8(unsigned char * p)
+ CODE:
+ RETVAL = isPRINT_utf8( p);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isPRINT_LC_utf8(unsigned char * p)
+ CODE:
+ RETVAL = isPRINT_LC_utf8( p);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isGRAPH_uni(UV ord)
+ CODE:
+ RETVAL = isGRAPH_uni(ord);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isGRAPH_LC_uvchr(UV ord)
+ CODE:
+ RETVAL = isGRAPH_LC_uvchr(ord);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isGRAPH_A(UV ord)
+ CODE:
+ RETVAL = isGRAPH_A(ord);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isGRAPH_L1(UV ord)
+ CODE:
+ RETVAL = isGRAPH_L1(ord);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isGRAPH_LC(UV ord)
+ CODE:
+ RETVAL = isGRAPH_LC(ord);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isGRAPH_utf8(unsigned char * p)
+ CODE:
+ RETVAL = isGRAPH_utf8( p);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isGRAPH_LC_utf8(unsigned char * p)
+ CODE:
+ RETVAL = isGRAPH_LC_utf8( p);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isPUNCT_uni(UV ord)
+ CODE:
+ RETVAL = isPUNCT_uni(ord);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isPUNCT_LC_uvchr(UV ord)
+ CODE:
+ RETVAL = isPUNCT_LC_uvchr(ord);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isPUNCT_A(UV ord)
+ CODE:
+ RETVAL = isPUNCT_A(ord);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isPUNCT_L1(UV ord)
+ CODE:
+ RETVAL = isPUNCT_L1(ord);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isPUNCT_LC(UV ord)
+ CODE:
+ RETVAL = isPUNCT_LC(ord);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isPUNCT_utf8(unsigned char * p)
+ CODE:
+ RETVAL = isPUNCT_utf8( p);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isPUNCT_LC_utf8(unsigned char * p)
+ CODE:
+ RETVAL = isPUNCT_LC_utf8( p);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isXDIGIT_uni(UV ord)
+ CODE:
+ RETVAL = isXDIGIT_uni(ord);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isXDIGIT_LC_uvchr(UV ord)
+ CODE:
+ RETVAL = isXDIGIT_LC_uvchr(ord);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isXDIGIT_A(UV ord)
+ CODE:
+ RETVAL = isXDIGIT_A(ord);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isXDIGIT_L1(UV ord)
+ CODE:
+ RETVAL = isXDIGIT_L1(ord);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isXDIGIT_LC(UV ord)
+ CODE:
+ RETVAL = isXDIGIT_LC(ord);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isXDIGIT_utf8(unsigned char * p)
+ CODE:
+ RETVAL = isXDIGIT_utf8( p);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isXDIGIT_LC_utf8(unsigned char * p)
+ CODE:
+ RETVAL = isXDIGIT_LC_utf8( p);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isPSXSPC_uni(UV ord)
+ CODE:
+ RETVAL = isPSXSPC_uni(ord);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isPSXSPC_LC_uvchr(UV ord)
+ CODE:
+ RETVAL = isPSXSPC_LC_uvchr(ord);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isPSXSPC_A(UV ord)
+ CODE:
+ RETVAL = isPSXSPC_A(ord);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isPSXSPC_L1(UV ord)
+ CODE:
+ RETVAL = isPSXSPC_L1(ord);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isPSXSPC_LC(UV ord)
+ CODE:
+ RETVAL = isPSXSPC_LC(ord);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isPSXSPC_utf8(unsigned char * p)
+ CODE:
+ RETVAL = isPSXSPC_utf8( p);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isPSXSPC_LC_utf8(unsigned char * p)
+ CODE:
+ RETVAL = isPSXSPC_LC_utf8( p);
+ OUTPUT:
+ RETVAL
+
+bool
+test_isQUOTEMETA(UV ord)
+ CODE:
+ RETVAL = _isQUOTEMETA(ord);
+ OUTPUT:
+ RETVAL
Property changes on: trunk/contrib/perl/ext/XS-APItest/APItest.xs
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/ext/XS-APItest/MANIFEST
===================================================================
--- trunk/contrib/perl/ext/XS-APItest/MANIFEST 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/XS-APItest/MANIFEST 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/XS-APItest/MANIFEST
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/ext/XS-APItest/Makefile.PL
===================================================================
--- trunk/contrib/perl/ext/XS-APItest/Makefile.PL 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/XS-APItest/Makefile.PL 2013-12-02 21:32:26 UTC (rev 6445)
@@ -14,6 +14,8 @@
realclean => {FILES => 'const-c.inc const-xs.inc'},
($Config{gccversion} && $Config{d_attribute_deprecated} ?
(CCFLAGS => $Config{ccflags} . ' -Wno-deprecated-declarations') : ()),
+ depend => { 'core.o' => 'core_or_not.inc',
+ 'notcore.o' => 'core_or_not.inc' },
);
my @names = (qw(HV_DELETE HV_DISABLE_UVAR_XKEY HV_FETCH_ISSTORE
Property changes on: trunk/contrib/perl/ext/XS-APItest/Makefile.PL
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/ext/XS-APItest/README
===================================================================
--- trunk/contrib/perl/ext/XS-APItest/README 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/XS-APItest/README 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/XS-APItest/README
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/ext/XS-APItest/XSUB-redefined-macros.xs
===================================================================
--- trunk/contrib/perl/ext/XS-APItest/XSUB-redefined-macros.xs 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/XS-APItest/XSUB-redefined-macros.xs 2013-12-02 21:32:26 UTC (rev 6445)
@@ -14,6 +14,8 @@
PROTOTYPES: DISABLE
+EXPORT_XSUB_SYMBOLS: ENABLE
+
void
XS_VERSION_empty(...)
PPCODE:
Property changes on: trunk/contrib/perl/ext/XS-APItest/XSUB-redefined-macros.xs
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/ext/XS-APItest/XSUB-undef-XS_VERSION.xs
===================================================================
--- trunk/contrib/perl/ext/XS-APItest/XSUB-undef-XS_VERSION.xs 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/XS-APItest/XSUB-undef-XS_VERSION.xs 2013-12-02 21:32:26 UTC (rev 6445)
@@ -11,6 +11,8 @@
PROTOTYPES: DISABLE
+EXPORT_XSUB_SYMBOLS: ENABLE
+
void
XS_VERSION_undef(...)
PPCODE:
Property changes on: trunk/contrib/perl/ext/XS-APItest/XSUB-undef-XS_VERSION.xs
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/XS-APItest/core.c
===================================================================
--- trunk/contrib/perl/ext/XS-APItest/core.c 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/XS-APItest/core.c 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/XS-APItest/core.c
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/ext/XS-APItest/core_or_not.inc
===================================================================
--- trunk/contrib/perl/ext/XS-APItest/core_or_not.inc 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/XS-APItest/core_or_not.inc 2013-12-02 21:32:26 UTC (rev 6445)
@@ -16,7 +16,7 @@
SV *destination = newSV(0);
bool result;
- if(!SvREADONLY(source) && !SvFAKE(source)) {
+ if(!SvIsCOW(source)) {
SvREFCNT_dec(source);
Perl_croak(aTHX_ "Creating a shared hash key scalar failed when "
STRINGIFY(SUFFIX) " got flags %"UVxf, (UV)SvFLAGS(source));
@@ -24,7 +24,7 @@
sv_setsv(destination, source);
- result = SvREADONLY(destination) && SvFAKE(destination);
+ result = !!SvIsCOW(destination);
SvREFCNT_dec(source);
SvREFCNT_dec(destination);
@@ -37,8 +37,8 @@
* mode: c
* c-indentation-style: bsd
* c-basic-offset: 4
- * indent-tabs-mode: t
+ * indent-tabs-mode: nil
* End:
*
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
*/
Property changes on: trunk/contrib/perl/ext/XS-APItest/core_or_not.inc
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/XS-APItest/exception.c
===================================================================
--- trunk/contrib/perl/ext/XS-APItest/exception.c 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/XS-APItest/exception.c 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/XS-APItest/exception.c
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/ext/XS-APItest/notcore.c
===================================================================
--- trunk/contrib/perl/ext/XS-APItest/notcore.c 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/XS-APItest/notcore.c 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/XS-APItest/notcore.c
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/XS-APItest/numeric.xs
===================================================================
--- trunk/contrib/perl/ext/XS-APItest/numeric.xs 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/XS-APItest/numeric.xs 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/XS-APItest/numeric.xs
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/XS-APItest/t/BHK.pm
===================================================================
--- trunk/contrib/perl/ext/XS-APItest/t/BHK.pm 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/XS-APItest/t/BHK.pm 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/XS-APItest/t/BHK.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/XS-APItest/t/Block.pm
===================================================================
--- trunk/contrib/perl/ext/XS-APItest/t/Block.pm 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/XS-APItest/t/Block.pm 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/XS-APItest/t/Block.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/XS-APItest/t/Markers.pm
===================================================================
--- trunk/contrib/perl/ext/XS-APItest/t/Markers.pm 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/XS-APItest/t/Markers.pm 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/XS-APItest/t/Markers.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/XS-APItest/t/Null.pm
===================================================================
--- trunk/contrib/perl/ext/XS-APItest/t/Null.pm 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/XS-APItest/t/Null.pm 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/XS-APItest/t/Null.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Copied: trunk/contrib/perl/ext/XS-APItest/t/addissub.t (from rev 6437, vendor/perl/5.18.1/ext/XS-APItest/t/addissub.t)
===================================================================
--- trunk/contrib/perl/ext/XS-APItest/t/addissub.t (rev 0)
+++ trunk/contrib/perl/ext/XS-APItest/t/addissub.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -0,0 +1,19 @@
+use warnings;
+use strict;
+
+use Test::More tests => 9;
+use XS::APItest ();
+
+alarm 10; # likely failure mode is an infinite loop
+
+ok 1;
+is eval q{ 3 + 1 }, 4;
+is eval q{ BEGIN { $^H{"XS::APItest/addissub"} = 1; } 3 + 1 }, 4;
+XS::APItest::setup_addissub(); ok 1;
+is eval q{ 3 + 1 }, 4;
+is eval q{ BEGIN { $^H{"XS::APItest/addissub"} = 1; } 3 + 1 }, 2;
+XS::APItest::setup_addissub(); ok 1;
+is eval q{ 3 + 1 }, 4;
+is eval q{ BEGIN { $^H{"XS::APItest/addissub"} = 1; } 3 + 1 }, 2;
+
+1;
Index: trunk/contrib/perl/ext/XS-APItest/t/arrayexpr.t
===================================================================
--- trunk/contrib/perl/ext/XS-APItest/t/arrayexpr.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/XS-APItest/t/arrayexpr.t 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/XS-APItest/t/arrayexpr.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Copied: trunk/contrib/perl/ext/XS-APItest/t/autoload.t (from rev 6437, vendor/perl/5.18.1/ext/XS-APItest/t/autoload.t)
===================================================================
--- trunk/contrib/perl/ext/XS-APItest/t/autoload.t (rev 0)
+++ trunk/contrib/perl/ext/XS-APItest/t/autoload.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -0,0 +1,132 @@
+#!perl
+
+# This script tests not only the interface for XS AUTOLOAD routines to find
+# out the sub name, but also that that interface does not interfere with
+# prototypes, the way it did before 5.15.4.
+
+use strict;
+use warnings;
+
+use Test::More tests => 26;
+
+use XS::APItest;
+
+is XS::APItest::AutoLoader::frob(), 'frob', 'name passed to XS AUTOLOAD';
+is "XS::APItest::AutoLoader::fr\0b"->(), "fr\0b",
+ 'name with embedded null passed to XS AUTOLOAD';
+is "XS::APItest::AutoLoader::fr\x{1ed9}b"->(), "fr\x{1ed9}b",
+ 'Unicode name passed to XS AUTOLOAD';
+
+*AUTOLOAD = *XS::APItest::AutoLoader::AUTOLOADp;
+
+is frob(), 'frob', 'name passed to XS AUTOLOAD with proto';
+is prototype \&AUTOLOAD, '*$', 'prototype is unchanged';
+is "fr\0b"->(), "fr\0b",
+ 'name with embedded null passed to XS AUTOLOAD with proto';
+is prototype \&AUTOLOAD, '*$', 'proto unchanged after embedded-null call';
+is "fr\x{1ed9}b"->(), "fr\x{1ed9}b",
+ 'Unicode name passed to XS AUTOLOAD with proto';
+is prototype \&AUTOLOAD, '*$', 'prototype is unchanged after Unicode call';
+
+# Test that the prototype was preserved from the parser’s point of view
+
+ok !eval "sub { ::AUTOLOAD(1) }",
+ 'parse failure due to AUTOLOAD prototype';
+ok eval "sub { ::AUTOLOAD(1,2) }", 'successful parse respecting prototype'
+ or diag $@;
+
+package fribble { sub a { return 7 } }
+no warnings 'once';
+*a = \&AUTOLOAD;
+'$'->();
+# &a('fribble') will return '$'
+# But if intuit_method does not see the (*...) proto, this compiles as
+# fribble->a
+no strict;
+is eval 'a fribble, 3', '$', 'intuit_method sees * in AUTOLOAD proto'
+ or diag $@;
+
+# precedence check
+# *$ should parse as a list operator, but right now the AUTOLOAD
+# sub name is $
+is join(" ", eval 'a "b", "c"'), '$',
+ 'precedence determination respects prototype of AUTOLOAD sub';
+
+{
+ my $w;
+ local $SIG{__WARN__} = sub { $w .= shift };
+ eval 'sub a($){}';
+ like $w, qr/^Prototype mismatch: sub main::a \(\*\$\) vs \(\$\)/m,
+ 'proto warnings respect AUTOLOAD prototypes';
+ undef $w;
+ *a = \&AUTOLOAD;
+ like $w, qr/^Prototype mismatch: sub main::a \(\$\) vs \(\*\$\)/m,
+ 'GV assignment proto warnings respect AUTOLOAD prototypes';
+}
+
+
+#
+# This is a test for AUTOLOAD implemented as an XSUB.
+# It tests that $AUTOLOAD is set correctly, including the
+# case of inheritance.
+#
+# Rationale: Due to change ed850460, $AUTOLOAD is not currently set
+# for XSUB AUTOLOADs at all. Instead, as of adb5a9ae the PV of the
+# AUTOLOAD XSUB is set to the name of the method. We cruelly test it
+# regardless.
+#
+
+# First, make sure we have the XS AUTOLOAD available for testing
+ok(XS::APItest::AUTOLOADtest->can('AUTOLOAD'), 'Test class ->can AUTOLOAD');
+
+# Used to communicate from the XS AUTOLOAD to Perl land
+use vars '$the_method';
+
+# First, set up the Perl equivalent to what we're testing in
+# XS so we have a comparison
+package PerlBase;
+use vars '$AUTOLOAD';
+sub AUTOLOAD {
+ Test::More::ok(defined $AUTOLOAD);
+ return 1 if not defined $AUTOLOAD;
+ $main::the_method = $AUTOLOAD;
+ return 0;
+}
+
+package PerlDerived;
+use vars '@ISA';
+ at ISA = qw(PerlBase);
+
+package Derived;
+use vars '@ISA';
+ at ISA = qw(XS::APItest::AUTOLOADtest);
+
+package main;
+
+# Test Perl AUTOLOAD in base class directly
+$the_method = undef;
+is(PerlBase->Blah(), 0,
+ "Perl AUTOLOAD gets called and returns success");
+is($the_method, 'PerlBase::Blah',
+ 'Scalar set to correct class/method name');
+
+# Test Perl AUTOLOAD in derived class
+$the_method = undef;
+is(PerlDerived->Boo(), 0,
+ 'Perl AUTOLOAD on derived class gets called and returns success');
+is($the_method, 'PerlDerived::Boo',
+ 'Scalar set to correct class/method name');
+
+# Test XS AUTOLOAD in base class directly
+$the_method = undef;
+is(XS::APItest::AUTOLOADtest->Blah(), 0,
+ 'XS AUTOLOAD gets called and returns success');
+is($the_method, 'XS::APItest::AUTOLOADtest::Blah',
+ 'Scalar set to correct class/method name');
+
+# Test XS AUTOLOAD in derived class directly
+$the_method = undef;
+is(Derived->Foo(), 0,
+ 'XS AUTOLOAD gets called and returns success');
+is($the_method, 'Derived::Foo',
+ 'Scalar set to correct class/method name');
Index: trunk/contrib/perl/ext/XS-APItest/t/blockasexpr.t
===================================================================
--- trunk/contrib/perl/ext/XS-APItest/t/blockasexpr.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/XS-APItest/t/blockasexpr.t 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/XS-APItest/t/blockasexpr.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/XS-APItest/t/blockhooks-csc.t
===================================================================
--- trunk/contrib/perl/ext/XS-APItest/t/blockhooks-csc.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/XS-APItest/t/blockhooks-csc.t 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/XS-APItest/t/blockhooks-csc.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/XS-APItest/t/blockhooks.t
===================================================================
--- trunk/contrib/perl/ext/XS-APItest/t/blockhooks.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/XS-APItest/t/blockhooks.t 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/XS-APItest/t/blockhooks.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/ext/XS-APItest/t/call.t
===================================================================
--- trunk/contrib/perl/ext/XS-APItest/t/call.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/XS-APItest/t/call.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -186,9 +186,10 @@
}
{
+ no warnings "misc";
my $warn = "";
local $SIG{__WARN__} = sub { $warn .= $_[0] };
- call_sv(sub { no warnings "misc"; die "aa\n" }, G_VOID|G_EVAL|G_KEEPERR);
+ call_sv(sub { use warnings "misc"; die "aa\n" }, G_VOID|G_EVAL|G_KEEPERR);
is $warn, "\t(in cleanup) aa\n";
}
Property changes on: trunk/contrib/perl/ext/XS-APItest/t/call.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/ext/XS-APItest/t/call_checker.t
===================================================================
--- trunk/contrib/perl/ext/XS-APItest/t/call_checker.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/XS-APItest/t/call_checker.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -1,6 +1,6 @@
use warnings;
use strict;
-use Test::More tests => 64;
+use Test::More tests => 76;
use XS::APItest;
@@ -158,4 +158,52 @@
is_deeply $foo_got, undef;
is $foo_ret, 9;
+sub MODIFY_CODE_ATTRIBUTES { cv_set_call_checker_lists($_[1]); () }
+BEGIN {
+ *foo2 = sub($$) :Attr { $foo_got = [ @_ ]; return "z"; };
+}
+
+$foo_got = undef;
+eval q{$foo_ret = foo2(@b, @c);};
+is $@, "";
+is_deeply $foo_got, [ qw(a b), qw(a b c) ];
+is $foo_ret, "z";
+
+cv_set_call_checker_lists(\&foo);
+undef &foo;
+$foo_got = undef;
+eval 'sub foo($@) { $foo_got = [ @_ ]; return "z"; }
+ $foo_ret = foo(@b, @c);';
+is $@, "";
+is_deeply $foo_got, [ 2, qw(a b c) ], 'undef clears call checkers';
+is $foo_ret, "z";
+
+my %got;
+
+sub g {
+ my $name = shift;
+ my $sub = sub ($\@) {
+ $got{$name} = [ @_ ];
+ return $name;
+ };
+ cv_set_call_checker_scalars($sub);
+ return $sub;
+}
+
+BEGIN {
+ *whack = g("whack");
+ *glurp = g("glurp");
+}
+
+%got = ();
+my $whack_ret = whack(@b, @c);
+is $@, "";
+is_deeply $got{whack}, [ 2, 3 ];
+is $whack_ret, "whack";
+
+my $glurp_ret = glurp(@b, @c);
+is $@, "";
+is_deeply $got{glurp}, [ 2, 3 ];
+is $glurp_ret, "glurp";
+
1;
Property changes on: trunk/contrib/perl/ext/XS-APItest/t/call_checker.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/XS-APItest/t/caller.t
===================================================================
--- trunk/contrib/perl/ext/XS-APItest/t/caller.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/XS-APItest/t/caller.t 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/XS-APItest/t/caller.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Copied: trunk/contrib/perl/ext/XS-APItest/t/callregexec.t (from rev 6437, vendor/perl/5.18.1/ext/XS-APItest/t/callregexec.t)
===================================================================
--- trunk/contrib/perl/ext/XS-APItest/t/callregexec.t (rev 0)
+++ trunk/contrib/perl/ext/XS-APItest/t/callregexec.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -0,0 +1,66 @@
+#!perl
+
+# test CALLREGEXEC()
+# (currently it just checks that it handles non-\0 terminated strings;
+# full tests haven't been added yet)
+
+use warnings;
+use strict;
+
+use XS::APItest;
+*callregexec = *XS::APItest::callregexec;
+
+use Test::More tests => 50;
+
+# Test that the regex engine can handle strings without terminating \0
+# XXX This is by no means comprehensive; it doesn't test all ops, nor all
+# code paths within those ops (especially not utf8).
+
+
+# this sub takes a string that has an extraneous char at the end.
+# First see if the string (less the last char) matches the regex;
+# then see if that string (including the last char) matches when
+# calling callregexec(), but with the length arg set to 1 char less than
+# the length of the string.
+# In theory the result should be the same for both matches, since
+# they should both not 'see' the final char.
+
+sub try {
+ my ($str, $re, $exp, $desc) = @_;
+
+ my $str1 = substr($str, 0, -1);
+ ok !!$exp == !!($str1 =~ $re), "$desc str =~ qr";
+
+ my $bytes = do { use bytes; length $str1 };
+ ok !!$exp == !!callregexec($re, 0, $bytes, 0, $str, 0),
+ "$desc callregexec";
+}
+
+
+{
+ try "\nx", qr/\n^/m, 0, 'MBOL';
+ try "ax", qr/a$/m, 1, 'MEOL';
+ try "ax", qr/a$/s, 1, 'SEOL';
+ try "abx", qr/^(ab|X)./s, 0, 'SANY';
+ try "abx", qr/^(ab|X)\C/, 0, 'CANY';
+ try "abx", qr/^(ab|X)./, 0, 'REG_ANY';
+ try "abx", qr/^ab(c|d|e|x)/, 0, 'TRIE/TRIEC';
+ try "abx", qr/^abx/, 0, 'EXACT';
+ try "abx", qr/^ABX/i, 0, 'EXACTF';
+ try "abx", qr/^ab\b/, 1, 'BOUND';
+ try "ab-", qr/^ab\B/, 0, 'NBOUND';
+ try "aas", qr/a[st]/, 0, 'ANYOF';
+ try "aas", qr/a[s\xDF]/i, 0, 'ANYOFV';
+ try "ab1", qr/ab\d/, 0, 'DIGIT';
+ try "ab\n", qr/ab[[:ascii:]]/, 0, 'POSIX';
+ try "aP\x{307}", qr/^a\X/, 1, 'CLUMP 1';
+ try "aP\x{307}x", qr/^a\X/, 1, 'CLUMP 2';
+ try "\x{100}\r\n", qr/^\x{100}\X/, 1, 'CLUMP 3';
+ try "abb", qr/^a(b)\1/, 0, 'REF';
+ try "ab\n", qr/^.+\R/, 0, 'LNBREAK';
+ try "ab\n", qr/^.+\v/, 0, 'VERTWS';
+ try "abx", qr/^.+\V/, 1, 'NVERTWS';
+ try "ab\t", qr/^.+\h/, 0, 'HORIZWS';
+ try "abx", qr/^.+\H/, 1, 'NHORIZWS';
+ try "abx", qr/a.*x/, 0, 'CURLY';
+}
Copied: trunk/contrib/perl/ext/XS-APItest/t/check_warnings.t (from rev 6437, vendor/perl/5.18.1/ext/XS-APItest/t/check_warnings.t)
===================================================================
--- trunk/contrib/perl/ext/XS-APItest/t/check_warnings.t (rev 0)
+++ trunk/contrib/perl/ext/XS-APItest/t/check_warnings.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -0,0 +1,20 @@
+#!perl
+
+# This test checks to make sure that a BEGIN block created from an XS call
+# does not implicitly change the current warning scope, causing a CHECK
+# or INIT block created after the corresponding phase to warn when it
+# shouldn’t.
+
+use Test::More tests => 1;
+
+$SIG{__WARN__} = sub { $w .= shift };
+
+use warnings;
+eval q|
+ BEGIN{
+ no warnings;
+ package XS::APItest; require XSLoader; XSLoader::load()
+ }
+|;
+
+is $w, undef, 'No warnings about CHECK and INIT in warningless scope';
Index: trunk/contrib/perl/ext/XS-APItest/t/cleanup.t
===================================================================
--- trunk/contrib/perl/ext/XS-APItest/t/cleanup.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/XS-APItest/t/cleanup.t 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/XS-APItest/t/cleanup.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Copied: trunk/contrib/perl/ext/XS-APItest/t/clone-with-stack.t (from rev 6437, vendor/perl/5.18.1/ext/XS-APItest/t/clone-with-stack.t)
===================================================================
--- trunk/contrib/perl/ext/XS-APItest/t/clone-with-stack.t (rev 0)
+++ trunk/contrib/perl/ext/XS-APItest/t/clone-with-stack.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -0,0 +1,67 @@
+#!perl
+
+use strict;
+use warnings;
+
+require "../../t/test.pl";
+
+use XS::APItest;
+
+# clone_with_stack creates a clone of the perl interpreter including
+# the stack, then destroys the original interpreter and runs the
+# remaining code using the new one.
+# This is like doing a psuedo-fork and exiting the parent.
+
+use Config;
+if (not $Config{'useithreads'}) {
+ skip_all("clone_with_stack requires threads");
+}
+
+plan(4);
+
+fresh_perl_is( <<'----', <<'====', undef, "minimal clone_with_stack" );
+use XS::APItest;
+clone_with_stack();
+print "ok\n";
+----
+ok
+====
+
+fresh_perl_is( <<'----', <<'====', undef, "inside a subroutine" );
+use XS::APItest;
+sub f {
+ clone_with_stack();
+}
+f();
+print "ok\n";
+----
+ok
+====
+
+{
+ local our $TODO = "clone_with_stack inside a begin block";
+ fresh_perl_is( <<'----', <<'====', undef, "inside a BEGIN block" );
+use XS::APItest;
+BEGIN {
+ clone_with_stack();
+}
+print "ok\n";
+----
+ok
+====
+
+}
+
+{
+ fresh_perl_is( <<'----', <<'====', undef, "clone stack" );
+use XS::APItest;
+sub f {
+ clone_with_stack();
+ 0..4;
+}
+print 'X-', 'Y-', join(':', f()), "-Z\n";
+----
+X-Y-0:1:2:3:4-Z
+====
+
+}
Index: trunk/contrib/perl/ext/XS-APItest/t/cophh.t
===================================================================
--- trunk/contrib/perl/ext/XS-APItest/t/cophh.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/XS-APItest/t/cophh.t 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/XS-APItest/t/cophh.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Copied: trunk/contrib/perl/ext/XS-APItest/t/coplabel.t (from rev 6437, vendor/perl/5.18.1/ext/XS-APItest/t/coplabel.t)
===================================================================
--- trunk/contrib/perl/ext/XS-APItest/t/coplabel.t (rev 0)
+++ trunk/contrib/perl/ext/XS-APItest/t/coplabel.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -0,0 +1,10 @@
+use warnings;
+use strict;
+use Test::More tests => 1;
+
+use XS::APItest;
+
+XS::APItest::test_coplabel();
+ok 1;
+
+1;
Copied: trunk/contrib/perl/ext/XS-APItest/t/copstash.t (from rev 6437, vendor/perl/5.18.1/ext/XS-APItest/t/copstash.t)
===================================================================
--- trunk/contrib/perl/ext/XS-APItest/t/copstash.t (rev 0)
+++ trunk/contrib/perl/ext/XS-APItest/t/copstash.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -0,0 +1,9 @@
+use Config;
+use Test::More;
+BEGIN { plan skip_all => 'no threads' unless $Config{useithreads} }
+
+plan tests => 1;
+
+use XS::APItest;
+
+ok test_alloccopstash;
Index: trunk/contrib/perl/ext/XS-APItest/t/copyhints.t
===================================================================
--- trunk/contrib/perl/ext/XS-APItest/t/copyhints.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/XS-APItest/t/copyhints.t 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/XS-APItest/t/copyhints.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/XS-APItest/t/customop.t
===================================================================
--- trunk/contrib/perl/ext/XS-APItest/t/customop.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/XS-APItest/t/customop.t 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/XS-APItest/t/customop.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/ext/XS-APItest/t/eval-filter.t
===================================================================
--- trunk/contrib/perl/ext/XS-APItest/t/eval-filter.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/XS-APItest/t/eval-filter.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -1,9 +1,27 @@
#!perl -w
use strict;
-use Test::More tests => 1;
+use Test::More tests => 5;
use XS::APItest;
+{
+ use feature "unicode_eval";
+ my $unfiltered_foo = "foo";
+ BEGIN {
+ eval "BEGIN { filter() }";
+ like $@, qr/^Source filters apply only to byte streams at /,
+ 'filters die under unicode_eval';
+ }
+ is "foo", $unfiltered_foo, 'filters leak not out of unicode evals';
+
+ use feature "evalbytes";
+ our $thingy;
+ BEGIN { evalbytes "BEGIN { filter() }\n\$thingy = 'foo'" }
+ is $thingy, "fee",
+ "source filters apply to evalbytten strings";
+ is "foo", $unfiltered_foo, 'filters leak not out of byte evals';
+}
+
BEGIN { eval "BEGIN{ filter() }" }
is "foo", "fee", "evals share filters with the currently compiling scope";
Property changes on: trunk/contrib/perl/ext/XS-APItest/t/eval-filter.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/XS-APItest/t/exception.t
===================================================================
--- trunk/contrib/perl/ext/XS-APItest/t/exception.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/XS-APItest/t/exception.t 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/XS-APItest/t/exception.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Copied: trunk/contrib/perl/ext/XS-APItest/t/fetch_pad_names.t (from rev 6437, vendor/perl/5.18.1/ext/XS-APItest/t/fetch_pad_names.t)
===================================================================
--- trunk/contrib/perl/ext/XS-APItest/t/fetch_pad_names.t (rev 0)
+++ trunk/contrib/perl/ext/XS-APItest/t/fetch_pad_names.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -0,0 +1,322 @@
+use strict;
+use warnings;
+use Encode ();
+
+use Test::More tests => 77;
+
+use XS::APItest qw( fetch_pad_names pad_scalar );
+
+local $SIG{__WARN__} = sub { warn $_[0] unless $_[0] =~ /Wide character in print at/ };
+
+ok defined &fetch_pad_names, "sub imported";
+ok defined &pad_scalar;
+
+my $cv = sub {
+ my $test;
+};
+
+ok fetch_pad_names($cv), "Fetch working.";
+is ref fetch_pad_names($cv), ref [], 'Fetch returns an arrayref';
+is @{fetch_pad_names($cv)}, 1, 'Sub has one lexical.';
+is fetch_pad_names($cv)->[0], '$test', "Fetching a simple scalar works.";
+
+$cv = sub {
+ use utf8;
+
+ my $zest = 'invariant';
+ my $zèst = 'latin-1';
+
+ return [pad_scalar(1, "zèst"), pad_scalar(1, "z\350st"), pad_scalar(1, "z\303\250st")];
+};
+
+my $names_av = fetch_pad_names($cv);
+my $flagged = my $unflagged = "\$z\x{c3}\x{a8}st";
+Encode::_utf8_on($flagged);
+
+general_tests( $cv->(), $names_av, {
+ results => [
+ { cmp => 'latin-1', msg => 'Fetches through UTF-8.' },
+ { cmp => 'latin-1', msg => 'Fetches through Latin-1.' },
+ { cmp => 'NOT_IN_PAD', msg => "Doesn't fetch using octets." },
+ ],
+ pad_size => {
+ total => { cmp => 2, msg => 'Sub has two lexicals.' },
+ utf8 => { cmp => 0, msg => 'Sub has no UTF-8 encoded vars.' },
+ invariant => { cmp => 2, msg => 'Sub has two invariant vars.' },
+ },
+ vars => [
+ { name => '$zest', msg => 'Sub has [\$zest].', type => 'ok' },
+ { name => "\$z\x{e8}st", msg => "Sub has [\$t\x{e8}st].", type => 'ok' },
+ { name => $unflagged, msg => "Sub doesn't have [$unflagged].", type => 'not ok' },
+ { name => $flagged, msg => "But does have it when flagged.", type => 'ok' },
+ ],
+});
+
+$cv = do {
+ my $ascii = 'Defined';
+ sub {
+ use utf8;
+ my $партнеры = $ascii;
+ return [$партнеры, pad_scalar(1, "партнеры"), pad_scalar(1, "\320\277\320\260\321\200\321\202\320\275\320\265\321\200\321\213")];
+ };
+};
+
+$names_av = fetch_pad_names($cv);
+my $hex_var = "\$\x{43f}\x{430}\x{440}\x{442}\x{43d}\x{435}\x{440}\x{44b}";
+$flagged = $unflagged = "\$\320\277\320\260\321\200\321\202\320\275\320\265\321\200\321\213";
+Encode::_utf8_on($flagged);
+
+my $russian_var = do {
+ use utf8;
+ '$партнеры';
+};
+
+general_tests( $cv->(), $names_av, {
+ results => [
+ { cmp => 'Defined', msg => 'UTF-8 fetching works.' },
+ { cmp => 'Defined', msg => 'pad_scalar fetch.' },
+ { cmp => 'NOT_IN_PAD', msg => "Doesn't fetch using octets." },
+ ],
+ pad_size => {
+ total => { cmp => 2, msg => 'Sub has two lexicals, including those it closed over.' },
+ utf8 => { cmp => 1, msg => 'UTF-8 in the pad.' },
+ invariant => { cmp => 1, msg => '' },
+ },
+ vars => [
+ { name => '$ascii', msg => 'Sub has [$ascii].', type => 'ok' },
+ { name => $russian_var, msg => "Sub has [$russian_var].", type => 'ok' },
+ { name => $hex_var, msg => "Sub has [$hex_var].", type => 'ok' },
+ { name => $unflagged, msg => "Sub doesn't have [$unflagged]", type => 'not ok' },
+ { name => $flagged, msg => "But does have it when flagged.", type => 'ok' },
+ ],
+});
+
+my $leon1 = "\$L\x{e9}on";
+my $leon2 = my $leon3 = "\$L\x{c3}\x{a9}on";
+Encode::_utf8_on($leon2);
+
+local $@;
+$cv = eval <<"END";
+ sub {
+ use utf8;
+ my \$Leon = 'Invariant';
+ my $leon1 = 'Latin-1';
+ return [ \$Leon, $leon1, $leon2, pad_scalar(1, "L\x{e9}on"), pad_scalar(1, "L\x{c3}\x{a9}on")];
+ };
+END
+
+my $err = $@;
+ok !$err, $@;
+
+$names_av = fetch_pad_names($cv);
+
+general_tests( $cv->(), $names_av, {
+ results => [
+ { cmp => 'Invariant', msg => '' },
+ { cmp => 'Latin-1', msg => "Fetched through [$leon1]" },
+ { cmp => 'Latin-1', msg => "Fetched through [$leon2]" },
+ { cmp => 'Latin-1', msg => 'pad_scalar fetch.' },
+ { cmp => 'NOT_IN_PAD', msg => "Doesn't fetch using octets." },
+ ],
+ pad_size => {
+ total => { cmp => 2, msg => 'Sub has two lexicals' },
+ utf8 => { cmp => 0, msg => 'Latin-1 not upgraded to UTF-8.' },
+ invariant => { cmp => 2, msg => '' },
+ },
+ vars => [
+ { name => '$Leon', msg => 'Sub has [$Leon].', type => 'ok' },
+ { name => $leon1, msg => "Sub has [$leon1].", type => 'ok' },
+ { name => $leon2, msg => "Sub has [$leon2].", type => 'ok' },
+ { name => $leon3, msg => "Sub doesn't have [$leon3]", type => 'not ok' },
+ ],
+});
+
+
+{
+ use utf8;
+ my $Cèon = 4;
+ my $str1 = "\$C\x{e8}on";
+ my $str2 = my $str3 = "\$C\x{c3}\x{a8}on";
+ Encode::_utf8_on($str2);
+
+ local $@;
+ $cv = eval <<"END_EVAL";
+ sub { [ \$Cèon, $str1, $str2 ] };
+END_EVAL
+
+ $err = $@;
+ ok !$err;
+
+ $names_av = fetch_pad_names($cv);
+
+ general_tests( $cv->(), $names_av, {
+ results => [ ({ SKIP => 1 }) x 3 ],
+ pad_size => {
+ total => { cmp => 1, msg => 'Sub has one lexical, which it closed over.' },
+ utf8 => { cmp => 0, msg => '' },
+ invariant => { cmp => 1, msg => '' },
+ },
+ vars => [
+ { name => '$Ceon', msg => "Sub doesn't have [\$Ceon].", type => 'not ok' },
+ map({ { name => $_, msg => "Sub has [$_].", type => 'ok' } } $str1, $str2 ),
+ { name => $str3, msg => "Sub doesn't have [$str3]", type => 'not ok' },
+ ],
+ });
+
+}
+
+$cv = sub {
+ use utf8;
+ our $戦国 = 10;
+ {
+ no strict 'refs';
+ my ($symref, $encoded_sym) = (__PACKAGE__ . "::戦国") x 2;
+ utf8::encode($encoded_sym);
+ return [ $戦国, ${$symref}, ${$encoded_sym} ];
+ }
+};
+
+my $flagged_our = my $unflagged_our = "\$\346\210\246\345\233\275";
+Encode::_utf8_on($flagged_our);
+
+$names_av = fetch_pad_names($cv);
+
+general_tests( $cv->(), $names_av, {
+ results => [
+ { cmp => '10', msg => 'Fetched UTF-8 our var.' },
+ { cmp => '10', msg => "Symref fetch of an our works." },
+ { cmp => undef, msg => "..and using the encoded form yields undef." },
+ ],
+ pad_size => {
+ total => { cmp => 3, msg => 'Sub has three lexicals.' },
+ utf8 => { cmp => 1, msg => 'Japanese stored as UTF-8.' },
+ invariant => { cmp => 2, msg => '' },
+ },
+ vars => [
+ { name => "\$\x{6226}\x{56fd}", msg => "Sub has [\$\x{6226}\x{56fd}].", type => 'ok' },
+ { name => $flagged_our, msg => "Sub has [$flagged_our].", type => 'ok' },
+ { name => $unflagged_our, msg => "Sub doesn't have [$unflagged_our]", type => 'not ok' },
+ ],
+});
+
+
+{
+
+use utf8;
+{
+ my $test;
+ BEGIN {
+ $test = "t\x{c3}\x{a8}st";
+ Encode::_utf8_on($test);
+ }
+ use constant test => $test;
+}
+
+$cv = sub {
+ my $tèst = 'Good';
+
+ return [
+ $tèst,
+ pad_scalar(1, "tèst"), #"UTF-8"
+ pad_scalar(1, "t\350st"), #"Latin-1"
+ pad_scalar(1, "t\x{c3}\x{a8}st"), #"Octal"
+ pad_scalar(1, test()), #'UTF-8 enc'
+ ];
+};
+
+$names_av = fetch_pad_names($cv);
+
+general_tests( $cv->(), $names_av, {
+ results => [
+ { cmp => 'Good', msg => 'Fetched through Perl.' },
+ { cmp => 'Good', msg => "pad_scalar: UTF-8 works." },
+ { cmp => 'Good', msg => "pad_scalar: Latin-1 works." },
+ { cmp => 'NOT_IN_PAD', msg => "pad_scalar: Doesn't fetch through octets." },
+ { cmp => 'Good', msg => "pad_scalar: UTF-8-through-encoding works." },
+ ],
+ pad_size => {
+ total => { cmp => 1, msg => 'Sub has one lexical.' },
+ utf8 => { cmp => 0, msg => '' },
+ invariant => { cmp => 1, msg => '' },
+ },
+ vars => [],
+});
+
+}
+
+$cv = do {
+ use utf8;
+ sub {
+ my $ニコニコ = 'katakana';
+ my $にこにこ = 'hiragana';
+
+ return [
+ $ニコニコ,
+ $にこにこ,
+ pad_scalar(1, "にこにこ"),
+ pad_scalar(1, "\x{306b}\x{3053}\x{306b}\x{3053}"),
+ pad_scalar(1, "\343\201\253\343\201\223\343\201\253\343\201\223"),
+ pad_scalar(1, "ニコニコ"),
+ pad_scalar(1, "\x{30cb}\x{30b3}\x{30cb}\x{30b3}"),
+ pad_scalar(1, "\343\203\213\343\202\263\343\203\213\343\202\263"),
+ ];
+ }
+};
+
+$names_av = fetch_pad_names($cv);
+
+general_tests( $cv->(), $names_av, {
+ results => [
+ { cmp => 'katakana', msg => '' },
+ { cmp => 'hiragana', msg => '' },
+ { cmp => 'hiragana', msg => '' },
+ { cmp => 'hiragana', msg => '' },
+ { cmp => 'NOT_IN_PAD', msg => '' },
+ { cmp => 'katakana', msg => '' },
+ { cmp => 'katakana', msg => '' },
+ { cmp => 'NOT_IN_PAD', msg => '' },
+ ],
+ pad_size => {
+ total => { cmp => 2, msg => 'Sub has two lexicals.' },
+ utf8 => { cmp => 2, msg => '' },
+ invariant => { cmp => 0, msg => '' },
+ },
+ vars => [],
+});
+
+{
+ {
+ my $utf8_e;
+ BEGIN {
+ $utf8_e = "e";
+ Encode::_utf8_on($utf8_e);
+ }
+ use constant utf8_e => $utf8_e;
+ }
+ my $e = 'Invariant';
+ is pad_scalar(1, "e"), pad_scalar(1, utf8_e), 'Fetches the same thing, even if invariant but with differing utf8ness.';
+}
+
+
+sub general_tests {
+ my ($results, $names_av, $tests) = @_;
+
+ for my $i (0..$#$results) {
+ next if $tests->{results}[$i]{SKIP};
+ is $results->[$i], $tests->{results}[$i]{cmp}, $tests->{results}[$i]{msg};
+ }
+
+ is @$names_av, $tests->{pad_size}{total}{cmp}, $tests->{pad_size}{total}{msg};
+ is grep( Encode::is_utf8($_), @$names_av), $tests->{pad_size}{utf8}{cmp};
+ is grep( !Encode::is_utf8($_), @$names_av), $tests->{pad_size}{invariant}{cmp};
+
+ for my $var (@{$tests->{vars}}) {
+ no warnings 'experimental::smartmatch';
+ if ($var->{type} eq 'ok') {
+ ok $var->{name} ~~ $names_av, $var->{msg};
+ } else {
+ ok !($var->{name} ~~ $names_av), $var->{msg};
+ }
+ }
+
+}
Copied: trunk/contrib/perl/ext/XS-APItest/t/gotosub.t (from rev 6437, vendor/perl/5.18.1/ext/XS-APItest/t/gotosub.t)
===================================================================
--- trunk/contrib/perl/ext/XS-APItest/t/gotosub.t (rev 0)
+++ trunk/contrib/perl/ext/XS-APItest/t/gotosub.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -0,0 +1,17 @@
+#!perl -w
+
+# Test that goto &xsub provides the right lexical environment.
+
+use strict;
+
+use Test::More tests => 1;
+use XS::APItest;
+
+# This sub must remain outside the ‘use warnings’ scope.
+sub no_warnings { goto &stringify }
+
+use warnings;
+
+$SIG{__WARN__} = sub { like shift, qr\^Use of uninitialized\ };
+
+no_warnings(my $x) # undefined variable
Modified: trunk/contrib/perl/ext/XS-APItest/t/grok.t
===================================================================
--- trunk/contrib/perl/ext/XS-APItest/t/grok.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/XS-APItest/t/grok.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -5,6 +5,7 @@
use Config;
use XS::APItest;
use feature 'switch';
+no warnings 'experimental::smartmatch';
use constant TRUTH => '0 but true';
# Tests for grok_number. Not yet comprehensive.
Property changes on: trunk/contrib/perl/ext/XS-APItest/t/grok.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Copied: trunk/contrib/perl/ext/XS-APItest/t/gv_autoload4.t (from rev 6437, vendor/perl/5.18.1/ext/XS-APItest/t/gv_autoload4.t)
===================================================================
--- trunk/contrib/perl/ext/XS-APItest/t/gv_autoload4.t (rev 0)
+++ trunk/contrib/perl/ext/XS-APItest/t/gv_autoload4.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -0,0 +1,62 @@
+#!perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 31;
+
+use_ok('XS::APItest');
+
+my $method = 0;
+my @types = map { 'gv_autoload' . $_ } qw( 4 _sv _pv _pvn );
+
+sub AUTOLOAD {
+ our $AUTOLOAD;
+ my ($subname, $message) = @_;
+ is $subname, $AUTOLOAD, $message;
+}
+
+my $sub = "nothing";
+
+ok my $glob = XS::APItest::gv_autoload_type(\%::, $sub, 1, $method);
+*{$glob}{CODE}->( __PACKAGE__ . "::" . $sub, '$AUTOLOAD set correctly' );
+
+$sub = "some_sub";
+for my $type ( 0..3 ) {
+ is $glob = XS::APItest::gv_autoload_type(\%::, $sub, $type, $method), "*main::AUTOLOAD", "*main::AUTOLOAD if autoload is true in $types[$type].";
+ *{$glob}{CODE}->( __PACKAGE__ . "::" . $sub, '$AUTOLOAD set correctly' );
+}
+
+$sub = "method\0not quite!";
+
+ok $glob = XS::APItest::gv_autoload_type(\%::, $sub, 0, $method);
+*{$glob}{CODE}->( __PACKAGE__ . "::" . $sub, "gv_autoload4() is nul-clean");
+
+ok $glob = XS::APItest::gv_autoload_type(\%::, $sub, 1, $method);
+*{$glob}{CODE}->( __PACKAGE__ . "::" . $sub, "gv_autoload_sv() is nul-clean");
+
+ok $glob = XS::APItest::gv_autoload_type(\%::, $sub, 2, $method);
+*{$glob}{CODE}->( __PACKAGE__ . "::" . ($sub =~ s/\0.*//r), "gv_autoload_pv() is not nul-clean");
+
+ok $glob = XS::APItest::gv_autoload_type(\%::, $sub, 3, $method);
+*{$glob}{CODE}->( __PACKAGE__ . "::" . $sub, "gv_autoload_pvn() is nul-clean");
+
+{
+ use utf8;
+ use open qw( :utf8 :std );
+
+ package ｍａｉｎ;
+
+ sub AUTOLOAD {
+ our $AUTOLOAD;
+ my ($subname, $message) = @_;
+ ::is $subname, $AUTOLOAD, $message;
+ }
+
+ for my $type ( 1..3 ) {
+ ::ok $glob = XS::APItest::gv_autoload_type(\%ｍａｉｎ::, $sub = "ｍｅｔｈｏｄ", $type, $method);
+ *{$glob}{CODE}->( "ｍａｉｎ::" . $sub, "$types[$type]() is UTF8-clean when both the stash and the sub are in UTF-8");
+ ::ok $glob = XS::APItest::gv_autoload_type(\%ｍａｉｎ::, $sub = "method", $type, $method);
+ *{$glob}{CODE}->( "ｍａｉｎ::" . $sub, "$types[$type]() is UTF8-clean when only the stash is in UTF-8");
+ }
+}
Copied: trunk/contrib/perl/ext/XS-APItest/t/gv_fetchmeth.t (from rev 6437, vendor/perl/5.18.1/ext/XS-APItest/t/gv_fetchmeth.t)
===================================================================
--- trunk/contrib/perl/ext/XS-APItest/t/gv_fetchmeth.t (rev 0)
+++ trunk/contrib/perl/ext/XS-APItest/t/gv_fetchmeth.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -0,0 +1,67 @@
+#!perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 40;
+
+use_ok('XS::APItest');
+
+my $level = -1;
+my @types = map { 'gv_fetchmeth' . $_ } '', qw( _sv _pv _pvn );
+
+sub test { "Sanity check" }
+
+for my $type ( 0..3 ) {
+ is *{
+ XS::APItest::gv_fetchmeth_type(\%::, "test", $type, $level, 0)
+ }{CODE}->(), "Sanity check";
+}
+
+for my $type ( 0..3 ) {
+ my $meth = "gen$type";
+ ok !XS::APItest::gv_fetchmeth_type(\%::, $meth, $type, -1, 0), "With level = -1, $types[$type] returns false.";
+ ok !$::{$meth}, "...and doesn't vivify the glob.";
+
+ ok !XS::APItest::gv_fetchmeth_type(\%::, $meth, $type, 0, 0), "With level = 0, $types[$type] still returns false.";
+ ok $::{$meth}, "...but does vivify the glob.";
+}
+
+{
+ no warnings 'once';
+ *method = sub { 1 };
+}
+
+ok !XS::APItest::gv_fetchmeth_type(\%::, "method\0not quite!", 0, $level, 0), "gv_fetchmeth() is nul-clean";
+ok !XS::APItest::gv_fetchmeth_type(\%::, "method\0not quite!", 1, $level, 0), "gv_fetchmeth_sv() is nul-clean";
+is XS::APItest::gv_fetchmeth_type(\%::, "method\0not quite!", 2, $level, 0), "*main::method", "gv_fetchmeth_pv() is not nul-clean";
+ok !XS::APItest::gv_fetchmeth_type(\%::, "method\0not quite!", 3, $level, 0), "gv_fetchmeth_pvn() is nul-clean";
+
+{
+ use utf8;
+ use open qw( :utf8 :std );
+
+ package ｍａｉｎ;
+
+ sub ｍｅｔｈｏｄ { 1 }
+
+ my $meth_as_octets =
+ "\357\275\215\357\275\205\357\275\224\357\275\210\357\275\217\357\275\204";
+
+ $level = 1;
+ for my $type ( 1..3 ) {
+ ::is XS::APItest::gv_fetchmeth_type(\%ｍａｉｎ::, "ｍｅｔｈｏｄ", $type, $level, 0), "*ｍａｉｎ::ｍｅｔｈｏｄ", "$types[$type] is UTF-8 clean";
+ ::ok !XS::APItest::gv_fetchmeth_type(\%ｍａｉｎ::, $meth_as_octets, $type, $level, 0);
+ ::ok !XS::APItest::gv_fetchmeth_type(\%ｍａｉｎ::, "method", $type, $level, 0);
+
+ {
+ no strict 'refs';
+ ::ok !XS::APItest::gv_fetchmeth_type(
+ \%{"\357\275\215\357\275\201\357\275\211\357\275\216::"},
+ "ｍｅｔｈｏｄ", $type, $level, 0);
+ ::ok !XS::APItest::gv_fetchmeth_type(
+ \%{"\357\275\215\357\275\201\357\275\211\357\275\216::"},
+ "method", $type, $level, 0);
+ }
+ }
+}
Copied: trunk/contrib/perl/ext/XS-APItest/t/gv_fetchmeth_autoload.t (from rev 6437, vendor/perl/5.18.1/ext/XS-APItest/t/gv_fetchmeth_autoload.t)
===================================================================
--- trunk/contrib/perl/ext/XS-APItest/t/gv_fetchmeth_autoload.t (rev 0)
+++ trunk/contrib/perl/ext/XS-APItest/t/gv_fetchmeth_autoload.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -0,0 +1,83 @@
+#!perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 53;
+
+use_ok('XS::APItest');
+
+my $level = -1;
+my @types = map { 'gv_fetchmeth' . $_ . "_autoload" } '', qw( _sv _pv _pvn );
+
+sub test { "Sanity check" }
+
+for my $type ( 0..3 ) {
+ is *{XS::APItest::gv_fetchmeth_autoload_type(
+ \%::, "test", $type, $level, 0
+ )}{CODE}->(), "Sanity check";
+}
+
+{
+ ok !XS::APItest::gv_fetchmeth_autoload_type(\%::, "etc", 1, $level, 0), "fails when the glob doesn't exist and AUTOLOAD is undefined,";
+ local *AUTOLOAD = sub { 1 };
+ is XS::APItest::gv_fetchmeth_autoload_type(\%::, "etc", 1, $level, 0), "*main::etc", "..but defining AUTOLOAD makes it succeed.";
+}
+
+for my $type ( 0..3 ) {
+ my $meth = "gen$type";
+ ok !XS::APItest::gv_fetchmeth_autoload_type(\%::, $meth, $type, -1, 0), "With level = -1, $types[$type] returns false.";
+ ok !$::{$meth}, "...and doesn't vivify the glob.";
+
+ ok !XS::APItest::gv_fetchmeth_autoload_type(\%::, $meth, $type, 0, 0), "With level = 0, $types[$type] still returns false.";
+ ok $::{$meth}, "...but does vivify the glob.";
+
+ ok !XS::APItest::gv_fetchmeth_autoload_type(\%::, $meth . $type, $type, $level, 0), "$types[$type] fails when the glob doesn't exist and AUTOLOAD is undefined,";
+ local *AUTOLOAD = sub { 1 };
+ is XS::APItest::gv_fetchmeth_autoload_type(\%::, $meth . $type, $type, $level, 0), "*main::$meth$type", "..but defining AUTOLOAD makes it succeed.";
+}
+
+{
+ no warnings 'once';
+ *method = sub { 1 };
+}
+
+ok !XS::APItest::gv_fetchmeth_autoload_type(\%::, "method\0not quite!", 0, $level, 0), "gv_fetchmeth() is nul-clean";
+ok !XS::APItest::gv_fetchmeth_autoload_type(\%::, "method\0not quite!", 1, $level, 0), "gv_fetchmeth_autoload_sv() is nul-clean";
+is XS::APItest::gv_fetchmeth_autoload_type(\%::, "method\0not quite!", 2, $level, 0), "*main::method", "gv_fetchmeth_autoload_pv() is not nul-clean";
+ok !XS::APItest::gv_fetchmeth_autoload_type(\%::, "method\0not quite!", 3, $level, 0), "gv_fetchmeth_autoload_pvn() is nul-clean";
+
+{
+ use utf8;
+ use open qw( :utf8 :std );
+
+ package ｍａｉｎ;
+
+ sub ｍｅｔｈｏｄ { 1 }
+
+ my $meth_as_octets =
+ "\357\275\215\357\275\205\357\275\224\357\275\210\357\275\217\357\275\204";
+
+ $level = -1;
+ for my $type ( 1..3 ) {
+ ::is XS::APItest::gv_fetchmeth_autoload_type(\%ｍａｉｎ::, "ｍｅｔｈｏｄ", $type, $level, 0), "*ｍａｉｎ::ｍｅｔｈｏｄ", "$types[$type] is UTF-8 clean";
+ ::ok !XS::APItest::gv_fetchmeth_autoload_type(\%ｍａｉｎ::, $meth_as_octets, $type, $level, 0);
+ ::ok !XS::APItest::gv_fetchmeth_autoload_type(\%ｍａｉｎ::, "method", $type, $level, 0);
+
+ {
+ no warnings 'once';
+ local *AUTOLOAD = sub { 1 };
+ ::is XS::APItest::gv_fetchmeth_autoload_type(\%ｍａｉｎ::, "ｍｅｔｈｏｄ$type", $type, $level, 0), "*ｍａｉｎ::ｍｅｔｈｏｄ$type", "Autoloading UTF-8 subs works";
+ }
+
+ {
+ no strict 'refs';
+ ::ok !XS::APItest::gv_fetchmeth_autoload_type(
+ \%{"\357\275\215\357\275\201\357\275\211\357\275\216::"},
+ "ｍｅｔｈｏｄ", $type, $level, 0);
+ ::ok !XS::APItest::gv_fetchmeth_autoload_type(
+ \%{"\357\275\215\357\275\201\357\275\211\357\275\216::"},
+ "method", $type, $level, 0);
+ }
+ }
+}
Copied: trunk/contrib/perl/ext/XS-APItest/t/gv_fetchmethod_flags.t (from rev 6437, vendor/perl/5.18.1/ext/XS-APItest/t/gv_fetchmethod_flags.t)
===================================================================
--- trunk/contrib/perl/ext/XS-APItest/t/gv_fetchmethod_flags.t (rev 0)
+++ trunk/contrib/perl/ext/XS-APItest/t/gv_fetchmethod_flags.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -0,0 +1,51 @@
+#!perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 24;
+
+use_ok('XS::APItest');
+
+sub method { 1 }
+
+ok !XS::APItest::gv_fetchmethod_flags_type(\%::, "nothing", 1, 0);
+
+for my $type ( 1..3 ) {
+ is XS::APItest::gv_fetchmethod_flags_type(\%::, "method", $type, 0), "*main::method", "Sanity check";
+}
+
+ok !XS::APItest::gv_fetchmethod_flags_type(\%::, "method\0not quite!", 1, 0), "gv_fetchmethod_flags_sv() is nul-clean";
+ok !XS::APItest::gv_fetchmethod_flags_type(\%::, "method\0not quite!", 3, 0), "gv_fetchmethod_flags_pvn() is nul-clean";
+
+ok XS::APItest::gv_fetchmethod_flags_type(\%::, "method\0not quite!", 0, 0), "gv_fetchmethod_flags() is not nul-clean";
+is XS::APItest::gv_fetchmethod_flags_type(\%::, "method\0not quite!", 2, 0), "*main::method", "gv_fetchmethod_flags_pv() is not nul-clean";
+
+{
+ use utf8;
+ use open qw( :utf8 :std );
+
+ package ｍａｉｎ;
+
+ sub ｍｅｔｈｏｄ { 1 }
+ sub method { 1 }
+
+ my $meth_as_octets =
+ "\357\275\215\357\275\205\357\275\224\357\275\210\357\275\217\357\275\204";
+
+ for my $type ( 1..3 ) {
+ ::is XS::APItest::gv_fetchmethod_flags_type(\%ｍａｉｎ::, "ｍｅｔｈｏｄ", $type, 0), "*ｍａｉｎ::ｍｅｔｈｏｄ";
+ ::ok !XS::APItest::gv_fetchmethod_flags_type(\%ｍａｉｎ::, $meth_as_octets, $type, 0);
+ ::is XS::APItest::gv_fetchmethod_flags_type(\%ｍａｉｎ::, "method", $type, 0), "*ｍａｉｎ::method";
+
+ {
+ no strict 'refs';
+ ::ok !XS::APItest::gv_fetchmethod_flags_type(
+ \%{"\357\275\215\357\275\201\357\275\211\357\275\216::"},
+ "ｍｅｔｈｏｄ", $type, 0);
+ ::ok !XS::APItest::gv_fetchmethod_flags_type(
+ \%{"\357\275\215\357\275\201\357\275\211\357\275\216::"},
+ "method", $type, 0);
+ }
+ }
+}
Copied: trunk/contrib/perl/ext/XS-APItest/t/gv_init.t (from rev 6437, vendor/perl/5.18.1/ext/XS-APItest/t/gv_init.t)
===================================================================
--- trunk/contrib/perl/ext/XS-APItest/t/gv_init.t (rev 0)
+++ trunk/contrib/perl/ext/XS-APItest/t/gv_init.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -0,0 +1,21 @@
+#!perl
+
+use strict;
+use warnings;
+use Test::More tests => 12;
+
+use XS::APItest;
+
+is XS::APItest::gv_init_type("sanity_check", 0, 0, 0), "*main::sanity_check";
+ok $::{sanity_check};
+
+for my $type (0..3) {
+ is XS::APItest::gv_init_type("test$type", 0, 0, $type), "*main::test$type";
+ ok $::{"test$type"};
+}
+
+my $latin_1 = "è";
+my $utf8 = "\x{30cb}";
+
+is XS::APItest::gv_init_type($latin_1, 0, 0, 1), "*main::$latin_1";
+is XS::APItest::gv_init_type($utf8, 0, 0, 1), "*main::$utf8";
Copied: trunk/contrib/perl/ext/XS-APItest/t/handy.t (from rev 6437, vendor/perl/5.18.1/ext/XS-APItest/t/handy.t)
===================================================================
--- trunk/contrib/perl/ext/XS-APItest/t/handy.t (rev 0)
+++ trunk/contrib/perl/ext/XS-APItest/t/handy.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -0,0 +1,212 @@
+#!perl -w
+
+use strict;
+use Test::More;
+use Config;
+
+use XS::APItest;
+
+use Unicode::UCD qw(prop_invlist);
+
+sub truth($) { # Converts values so is() works
+ return (shift) ? 1 : 0;
+}
+
+my $locale;
+if($Config{d_setlocale}) {
+ require POSIX;
+ $locale = POSIX::setlocale( &POSIX::LC_ALL, "C");
+ if (defined $locale && $locale eq 'C') {
+ BEGIN {
+ if($Config{d_setlocale}) {
+ require locale; import locale; # make \w work right in non-ASCII lands
+ }
+ }
+
+ # Some locale implementations don't have the 128-255 characters all
+ # mean nothing. Skip the locale tests in that situation
+ for my $i (128 .. 255) {
+ if (chr($i) =~ /[[:print:]]/) {
+ undef $locale;
+ last;
+ }
+ }
+ }
+}
+
+my %properties = (
+ # name => Lookup-property name
+ alnum => 'Word',
+ wordchar => 'Word',
+ alphanumeric => 'Alnum',
+ alpha => 'Alpha',
+ ascii => 'ASCII',
+ blank => 'Blank',
+ cntrl => 'Control',
+ digit => 'Digit',
+ graph => 'Graph',
+ idfirst => '_Perl_IDStart',
+ idcont => '_Perl_IDCont',
+ lower => 'Lower',
+ print => 'Print',
+ psxspc => 'XPosixSpace',
+ punct => 'XPosixPunct',
+ quotemeta => '_Perl_Quotemeta',
+ space => 'XPerlSpace',
+ vertws => 'VertSpace',
+ upper => 'Upper',
+ xdigit => 'XDigit',
+ );
+
+my @warnings;
+local $SIG{__WARN__} = sub { push @warnings, @_ };
+
+use charnames ();
+foreach my $name (sort keys %properties) {
+ my $property = $properties{$name};
+ my @invlist = prop_invlist($property, '_perl_core_internal_ok');
+ if (! @invlist) {
+ fail("No inversion list found for $property");
+ next;
+ }
+
+ # Include all the Latin1 code points, plus 0x100.
+ my @code_points = (0 .. 256);
+
+ # Then include the next few boundaries above those from this property
+ my $above_latins = 0;
+ foreach my $range_start (@invlist) {
+ next if $range_start < 257;
+ push @code_points, $range_start - 1, $range_start;
+ $above_latins++;
+ last if $above_latins > 5;
+ }
+
+ # This makes sure we are using the Perl definition of idfirst and idcont,
+ # and not the Unicode. There are a few differences.
+ push @code_points, ord "\N{ESTIMATED SYMBOL}" if $name =~ /^id(first|cont)/;
+ if ($name eq "idcont") { # And some that are continuation but not start
+ push @code_points, ord("\N{GREEK ANO TELEIA}"),
+ ord("\N{COMBINING GRAVE ACCENT}");
+ }
+
+ # And finally one non-Unicode code point.
+ push @code_points, 0x110000; # Above Unicode, no prop should match
+ no warnings 'non_unicode';
+
+ for my $i (@code_points) {
+ my $function = uc($name);
+
+ my $matches = Unicode::UCD::_search_invlist(\@invlist, $i);
+ if (! defined $matches) {
+ $matches = 0;
+ }
+ else {
+ $matches = truth(! ($matches % 2));
+ }
+
+ my $ret;
+ my $char_name = charnames::viacode($i) // "No name";
+ my $display_name = sprintf "\\N{U+%02X, %s}", $i, $char_name;
+
+ if ($name eq 'quotemeta') { # There is only one macro for this, and is
+ # defined only for Latin1 range
+ $ret = truth eval "test_is${function}($i)";
+ if ($@) {
+ fail $@;
+ }
+ else {
+ my $truth = truth($matches && $i < 256);
+ is ($ret, $truth, "is${function}( $display_name ) == $truth");
+ }
+ next;
+ }
+
+ # vertws is always all of Unicode; ALNUM_A and ALNUM_L1 are not
+ # defined as they were added later, after WORDCHAR was created to be a
+ # clearer synonym for ALNUM
+ if ($name ne 'vertws') {
+ if ($name ne 'alnum') {
+ $ret = truth eval "test_is${function}_A($i)";
+ if ($@) {
+ fail($@);
+ }
+ else {
+ my $truth = truth($matches && $i < 128);
+ is ($ret, $truth, "is${function}_A( $display_name ) == $truth");
+ }
+ $ret = truth eval "test_is${function}_L1($i)";
+ if ($@) {
+ fail($@);
+ }
+ else {
+ my $truth = truth($matches && $i < 256);
+ is ($ret, $truth, "is${function}_L1( $display_name ) == $truth");
+ }
+ }
+
+ if (defined $locale) {
+ require locale; import locale;
+
+ $ret = truth eval "test_is${function}_LC($i)";
+ if ($@) {
+ fail($@);
+ }
+ else {
+ my $truth = truth($matches && $i < 128);
+ is ($ret, $truth, "is${function}_LC( $display_name ) == $truth");
+ }
+ }
+ }
+
+ $ret = truth eval "test_is${function}_uni($i)";
+ if ($@) {
+ fail($@);
+ }
+ else {
+ is ($ret, $matches, "is${function}_uni( $display_name ) == $matches");
+ }
+
+ if (defined $locale && $name ne 'vertws') {
+ require locale; import locale;
+
+ $ret = truth eval "test_is${function}_LC_uvchr('$i')";
+ if ($@) {
+ fail($@);
+ }
+ else {
+ my $truth = truth($matches && ($i < 128 || $i > 255));
+ is ($ret, $truth, "is${function}_LC_uvchr( $display_name ) == $truth");
+ }
+ }
+
+ my $char = chr($i);
+ utf8::upgrade($char);
+ $char = quotemeta $char if $char eq '\\' || $char eq "'";
+ $ret = truth eval "test_is${function}_utf8('$char')";
+ if ($@) {
+ fail($@);
+ }
+ else {
+ is ($ret, $matches, "is${function}_utf8( $display_name ) == $matches");
+ }
+
+ if ($name ne 'vertws' && defined $locale) {
+ require locale; import locale;
+
+ $ret = truth eval "test_is${function}_LC_utf8('$char')";
+ if ($@) {
+ fail($@);
+ }
+ else {
+ my $truth = truth($matches && ($i < 128 || $i > 255));
+ is ($ret, $truth, "is${function}_LC_utf8( $display_name ) == $truth");
+ }
+ }
+ }
+}
+
+# This is primarily to make sure that no non-Unicode warnings get generated
+is(scalar @warnings, 0, "No warnings were generated " . join ", ", @warnings);
+
+done_testing;
Modified: trunk/contrib/perl/ext/XS-APItest/t/hash.t
===================================================================
--- trunk/contrib/perl/ext/XS-APItest/t/hash.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/XS-APItest/t/hash.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -180,6 +180,100 @@
}
}
+{
+ use Scalar::Util 'weaken';
+ my %h;
+ fill_hash_with_nulls(\%h);
+ my @objs;
+ for("a".."z","A".."Z") {
+ weaken($objs[@objs] = $h{$_} = []);
+ }
+ undef %h;
+ no warnings 'uninitialized';
+ local $" = "";
+ is "@objs", "",
+ 'explicitly undeffing a hash with nulls frees all entries';
+
+ my $h = {};
+ fill_hash_with_nulls($h);
+ @objs = ();
+ for("a".."z","A".."Z") {
+ weaken($objs[@objs] = $$h{$_} = []);
+ }
+ undef $h;
+ is "@objs", "", 'freeing a hash with nulls frees all entries';
+}
+
+# Tests for HvENAME and UTF8
+{
+ no strict;
+ no warnings 'void';
+ my $hvref;
+
+ *{"\xff::bar"}; # autovivify %ÿ:: without UTF8
+ *{"\xff::bαr::"} = $hvref = \%foo::;
+ undef *foo::;
+ is HvENAME($hvref), "\xff::bαr",
+ 'stash alias (utf8 inside bytes) does not create malformed UTF8';
+
+ *{"é::foo"}; # autovivify %é:: with UTF8
+ *{"\xe9::\xe9::"} = $hvref = \%bar::;
+ undef *bar::;
+ is HvENAME($hvref), "\xe9::\xe9",
+ 'stash alias (bytes inside utf8) does not create malformed UTF8';
+
+ *{"\xfe::bar"}; *{"\xfd::bar"};
+ *{"\xfe::bαr::"} = \%goo::;
+ *{"\xfd::bαr::"} = $hvref = \%goo::;
+ undef *goo::;
+ like HvENAME($hvref), qr/^[\xfe\xfd]::bαr\z/,
+ 'multiple stash aliases (utf8 inside bytes) do not cause bad UTF8';
+
+ *{"è::foo"}; *{"ë::foo"};
+ *{"\xe8::\xe9::"} = $hvref = \%bear::;
+ *{"\xeb::\xe9::"} = \%bear::;
+ undef *bear::;
+ like HvENAME($hvref), qr"^[\xe8\xeb]::\xe9\z",
+ 'multiple stash aliases (bytes inside utf8) do not cause bad UTF8';
+}
+
+{ # newHVhv
+ use Tie::Hash;
+ tie my %h, 'Tie::StdHash';
+ %h = 1..10;
+ is join(' ', sort %{newHVhv \%h}), '1 10 2 3 4 5 6 7 8 9',
+ 'newHVhv on tied hash';
+}
+
+# helem and hslice on entry with null value
+# This is actually a test for a Perl operator, not an XS API test. But it
+# requires a hash that can only be produced by XS (although recently it
+# could be encountered when tying hint hashes).
+{
+ my %h;
+ fill_hash_with_nulls(\%h);
+ eval{ $h{84} = 1 };
+ pass 'no crash when writing to hash elem with null value';
+ eval{ no # silly
+ warnings; # thank you!
+ @h{85} = 1 };
+ pass 'no crash when writing to hash elem with null value via slice';
+ eval { delete local $h{86} };
+ pass 'no crash during local deletion of hash elem with null value';
+ eval { delete local @h{87,88} };
+ pass 'no crash during local deletion of hash slice with null values';
+}
+
+# [perl #111000] Bug number eleventy-one thousand:
+# hv_store should work on hint hashes
+eval q{
+ BEGIN {
+ XS::APItest::Hash::store \%^H, "XS::APItest/hash.t", undef;
+ delete $^H{"XS::APItest/hash.t"};
+ }
+};
+pass("hv_store works on the hint hash");
+
done_testing;
exit;
Property changes on: trunk/contrib/perl/ext/XS-APItest/t/hash.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/ext/XS-APItest/t/keyword_multiline.t
===================================================================
--- trunk/contrib/perl/ext/XS-APItest/t/keyword_multiline.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/XS-APItest/t/keyword_multiline.t 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/XS-APItest/t/keyword_multiline.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/XS-APItest/t/keyword_plugin.t
===================================================================
--- trunk/contrib/perl/ext/XS-APItest/t/keyword_plugin.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/XS-APItest/t/keyword_plugin.t 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/XS-APItest/t/keyword_plugin.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/XS-APItest/t/labelconst.aux
===================================================================
--- trunk/contrib/perl/ext/XS-APItest/t/labelconst.aux 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/XS-APItest/t/labelconst.aux 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/XS-APItest/t/labelconst.aux
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/ext/XS-APItest/t/labelconst.t
===================================================================
--- trunk/contrib/perl/ext/XS-APItest/t/labelconst.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/XS-APItest/t/labelconst.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -1,7 +1,7 @@
use warnings;
use strict;
-use Test::More tests => 18;
+use Test::More tests => 32;
BEGIN { $^H |= 0x20000; }
@@ -93,4 +93,79 @@
is $@, "";
is $t, "FOOBARBAZQUUX";
+{
+ use utf8;
+ use open qw( :utf8 :std );
+
+ $t = "";
+ eval q{
+ use XS::APItest qw(labelconst);
+ $t .= "ㅏ";
+ $t .= labelconst ᛒ:;
+ $t .= "ḉ";
+ };
+ is $@, "";
+ is $t, "ㅏᛒḉ";
+
+ $t = "";
+ eval q{
+ use XS::APItest qw(labelconst);
+ $t .= "ㅏ";
+ $t .= "ᛒ" . labelconst ＦǑǑ: . "ḉ";
+ $t .= "ｄ";
+ };
+ is $@, "";
+ is $t, "ㅏᛒＦǑǑḉｄ";
+
+ $t = "";
+ eval q{
+ use XS::APItest qw(labelconst);
+ $t .= "ㅏ";
+ $t .= labelconst ＦǑǑ :;
+ $t .= "ᛒ";
+ };
+ is $@, "";
+ is $t, "ㅏＦǑǑᛒ";
+
+ $t = "";
+ eval q{
+ use XS::APItest qw(labelconst);
+ $t .= "ㅏ";
+ $t .= labelconst Ｆ_1Ḅ:;
+ $t .= "ᛒ";
+ };
+ is $@, "";
+ is $t, "ㅏＦ_1Ḅᛒ";
+
+ $t = "";
+ eval q{
+ use XS::APItest qw(labelconst);
+ $t .= "ㅏ";
+ $t .= labelconst _AḄ:;
+ $t .= "ᛒ";
+ };
+ is $@, "";
+ is $t, "ㅏ_AḄᛒ";
+
+ $t = "";
+ eval q{
+ use XS::APItest qw(labelconst);
+ no warnings;
+ $t .= "ㅏ";
+ $t .= labelconst 1AḄ:;
+ $t .= "ᛒ";
+ };
+ isnt $@, "";
+ is $t, "";
+
+}
+
+{
+ use utf8;
+ $t = "";
+ $t = do("t/labelconst_utf8.aux");
+ is $@, "";
+ is $t, "ＦǑǑBÀRᛒÀZQÙÙX";
+}
+
1;
Property changes on: trunk/contrib/perl/ext/XS-APItest/t/labelconst.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Copied: trunk/contrib/perl/ext/XS-APItest/t/labelconst_utf8.aux (from rev 6437, vendor/perl/5.18.1/ext/XS-APItest/t/labelconst_utf8.aux)
===================================================================
--- trunk/contrib/perl/ext/XS-APItest/t/labelconst_utf8.aux (rev 0)
+++ trunk/contrib/perl/ext/XS-APItest/t/labelconst_utf8.aux 2013-12-02 21:32:26 UTC (rev 6445)
@@ -0,0 +1,13 @@
+use utf8;
+use open qw( :utf8 :std );
+
+use XS::APItest qw(labelconst);
+my $z = "";
+$z .= labelconst ＦǑǑ:;
+$z .= labelconst BÀR:
+ ;
+$z .= labelconst ᛒÀZ
+ :;
+$z .= labelconst
+ QÙÙX:;
+$z;
Copied: trunk/contrib/perl/ext/XS-APItest/t/lexsub.t (from rev 6437, vendor/perl/5.18.1/ext/XS-APItest/t/lexsub.t)
===================================================================
--- trunk/contrib/perl/ext/XS-APItest/t/lexsub.t (rev 0)
+++ trunk/contrib/perl/ext/XS-APItest/t/lexsub.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -0,0 +1,19 @@
+use Test::More tests => 4;
+use XS::APItest;
+
+
+sub fribbler { 2*shift }
+{
+ BEGIN { lexical_import fribbler => sub { 3*shift } }
+ is fribbler(15), 45, 'lexical subs via pad_add_name';
+}
+is fribbler(15), 30, 'XS-allocated lexical subs falling out of scope';
+
+{
+ BEGIN { lexical_import fribbler => sub { 3*shift } }
+ is fribbler(15), 45, 'lexical subs via pad_add_name';
+ no warnings;
+ use feature 'lexical_subs';
+ our sub fribbler;
+ is fribbler(15), 30, 'our sub overrides XS-registered lexical sub';
+}
Index: trunk/contrib/perl/ext/XS-APItest/t/loopblock.t
===================================================================
--- trunk/contrib/perl/ext/XS-APItest/t/loopblock.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/XS-APItest/t/loopblock.t 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/XS-APItest/t/loopblock.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/XS-APItest/t/looprest.t
===================================================================
--- trunk/contrib/perl/ext/XS-APItest/t/looprest.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/XS-APItest/t/looprest.t 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/XS-APItest/t/looprest.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Copied: trunk/contrib/perl/ext/XS-APItest/t/lvalue.t (from rev 6437, vendor/perl/5.18.1/ext/XS-APItest/t/lvalue.t)
===================================================================
--- trunk/contrib/perl/ext/XS-APItest/t/lvalue.t (rev 0)
+++ trunk/contrib/perl/ext/XS-APItest/t/lvalue.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -0,0 +1,32 @@
+# Miscellaneous tests for XS lvalue functions
+
+use warnings;
+use strict;
+
+use Test::More tests => 4;
+
+use XS::APItest 'lv_temp_object';
+
+
+{
+ my $w;
+ local $SIG{__WARN__} = sub { $w = shift };
+
+ # [perl #31946]
+ lv_temp_object() = 75;
+ like $w, qr/Useless assignment to a temporary at/,
+ 'warning when assigning to temp returned from XS lv sub';
+ undef $w;
+ (lv_temp_object()) = 75;
+ like $w, qr/Useless assignment to a temporary at/,
+ 'warning when list-assigning to temp returned from XS lv sub';
+
+ $w = undef;
+ {
+ package XS::APItest::TempObj;
+ use overload '.=' => sub { $::assigned = $_[1] };
+ }
+ lv_temp_object() .= 63;
+ is $::assigned, 63, 'overloaded .= on temp obj returned from lv sub';
+ is $w, undef, 'no warning from overloaded .= on temp obj';
+}
Modified: trunk/contrib/perl/ext/XS-APItest/t/magic.t
===================================================================
--- trunk/contrib/perl/ext/XS-APItest/t/magic.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/XS-APItest/t/magic.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -27,4 +27,6 @@
ok !mg_find_foo($sv), 'foo magic still removed';
ok !mg_find_bar($sv), '... and bar magic is removed too';
+is(test_get_vtbl(), 0, 'get_vtbl(-1) returns NULL');
+
done_testing;
Property changes on: trunk/contrib/perl/ext/XS-APItest/t/magic.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/XS-APItest/t/magic_chain.t
===================================================================
--- trunk/contrib/perl/ext/XS-APItest/t/magic_chain.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/XS-APItest/t/magic_chain.t 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/XS-APItest/t/magic_chain.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Copied: trunk/contrib/perl/ext/XS-APItest/t/mro.t (from rev 6437, vendor/perl/5.18.1/ext/XS-APItest/t/mro.t)
===================================================================
--- trunk/contrib/perl/ext/XS-APItest/t/mro.t (rev 0)
+++ trunk/contrib/perl/ext/XS-APItest/t/mro.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -0,0 +1,16 @@
+#!perl
+
+use XS::APItest;
+use Test::More;
+
+plan tests => 1;
+
+use mro;
+mro::set_mro(AA => 'justisa');
+
+ at AA::ISA = qw "BB CC";
+
+sub BB::fromp { "bb" }
+sub CC::fromp { "cc" }
+
+is fromp AA, 'bb', 'first elem of linearisation is not ignored';
Modified: trunk/contrib/perl/ext/XS-APItest/t/multicall.t
===================================================================
--- trunk/contrib/perl/ext/XS-APItest/t/multicall.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/XS-APItest/t/multicall.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -7,7 +7,7 @@
use warnings;
use strict;
-use Test::More tests => 6;
+use Test::More tests => 7;
use XS::APItest;
@@ -48,3 +48,16 @@
is($destroyed, 1, "f now destroyed");
}
+
+# [perl #115602]
+# deep recursion realloced the CX stack, but the dMULTICALL local var
+# 'cx' still pointed to the old one.
+# Thius doesn;t actually test the failure (I couldn't think of a way to
+# get the failure to show at the perl level) but it allows valgribnd or
+# similar to spot any errors.
+
+{
+ sub rec { my $c = shift; rec($c-1) if $c > 0 };
+ my @r = XS::APItest::multicall_each { rec(90) } 1,2,3;
+ pass("recursion");
+}
Property changes on: trunk/contrib/perl/ext/XS-APItest/t/multicall.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/XS-APItest/t/my_cxt.t
===================================================================
--- trunk/contrib/perl/ext/XS-APItest/t/my_cxt.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/XS-APItest/t/my_cxt.t 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/XS-APItest/t/my_cxt.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/ext/XS-APItest/t/my_exit.t
===================================================================
--- trunk/contrib/perl/ext/XS-APItest/t/my_exit.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/XS-APItest/t/my_exit.t 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/XS-APItest/t/my_exit.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Copied: trunk/contrib/perl/ext/XS-APItest/t/newCONSTSUB.t (from rev 6437, vendor/perl/5.18.1/ext/XS-APItest/t/newCONSTSUB.t)
===================================================================
--- trunk/contrib/perl/ext/XS-APItest/t/newCONSTSUB.t (rev 0)
+++ trunk/contrib/perl/ext/XS-APItest/t/newCONSTSUB.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -0,0 +1,102 @@
+#!perl
+
+use strict;
+use utf8;
+use open qw( :utf8 :std );
+use Test::More tests => 22;
+
+use XS::APItest;
+
+# This test must happen outside of any warnings scope
+{
+ local $^W;
+ my $w;
+ local $SIG{__WARN__} = sub { $w .= shift };
+ sub frimple() { 78 }
+ newCONSTSUB_flags(\%::, "frimple", 0, undef);
+ like $w, qr/Constant subroutine frimple redefined at /,
+ 'newCONSTSUB constant redefinition warning is unaffected by $^W=0';
+ undef $w;
+ newCONSTSUB_flags(\%::, "frimple", 0, undef);
+ is $w, undef, '...unless the const SVs are the same';
+ eval 'sub frimple() { 78 }';
+ undef $w;
+ newCONSTSUB_flags(\%::, "frimple", 0, "78");
+ is $w, undef, '...or the const SVs have the same value';
+}
+
+use warnings;
+
+my ($const, $glob) =
+ XS::APItest::newCONSTSUB(\%::, "sanity_check", 0, undef);
+
+ok $const;
+ok *{$glob}{CODE};
+
+($const, $glob) =
+ XS::APItest::newCONSTSUB(\%::, "\x{30cb}", 0, undef);
+ok $const, "newCONSTSUB generates the constant,";
+ok *{$glob}{CODE}, "..and the glob,";
+ok !$::{"\x{30cb}"}, "...but not the right one";
+
+($const, $glob) =
+ XS::APItest::newCONSTSUB_flags(\%::, "\x{30cd}", 0, undef);
+ok $const, "newCONSTSUB_flags generates the constant,";
+ok *{$glob}{CODE}, "..and the glob,";
+ok $::{"\x{30cd}"}, "...the right one!";
+
+eval q{
+ BEGIN {
+ no warnings;
+ my $w;
+ local $SIG{__WARN__} = sub { $w .= shift };
+ *foo = sub(){123};
+ newCONSTSUB_flags(\%::, "foo", 0, undef);
+ is $w, undef, 'newCONSTSUB uses calling scope for redefinition warnings';
+ }
+};
+
+{
+ no strict 'refs';
+ *{"foo::\x{100}"} = sub(){return 123};
+ my $w;
+ local $SIG{__WARN__} = sub { $w .= shift };
+ newCONSTSUB_flags(\%foo::, "\x{100}", 0, undef);
+ like $w, qr/Subroutine \x{100} redefined at /,
+ 'newCONSTSUB redefinition warning + utf8';
+ undef $w;
+ newCONSTSUB_flags(\%foo::, "\x{100}", 0, 54);
+ like $w, qr/Constant subroutine \x{100} redefined at /,
+ 'newCONSTSUB constant redefinition warning + utf8';
+}
+
+# XS::APItest was not handling references correctly here
+
+package Counter {
+ our $count = 0;
+
+ sub new {
+ ++$count;
+ my $o = bless [];
+ return $o;
+ }
+
+ sub DESTROY {
+ --$count;
+ }
+};
+
+foreach (['newCONSTSUB', 'ZZIP'],
+ ['newCONSTSUB_flags', 'BRRRAPP']) {
+ my ($using, $name) = @$_;
+ is($Counter::count, 0, 'No objects exist before we start');
+ my $sub = XS::APItest->can($using);
+ ($const, $glob) = $sub->(\%::, $name, 0, Counter->new());
+ is($const, 1, "subroutine generated by $using is CvCONST");
+ is($Counter::count, 1, '1 object now exists');
+ {
+ no warnings 'redefine';
+ *$glob = sub () {};
+ }
+ is($Counter::count, 0, 'no objects remain');
+}
Modified: trunk/contrib/perl/ext/XS-APItest/t/op.t
===================================================================
--- trunk/contrib/perl/ext/XS-APItest/t/op.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/XS-APItest/t/op.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -10,3 +10,6 @@
*hint_fetch = *hint_fetch = \&XS::APItest::Hash::refcounted_he_fetch;
require '../../t/op/caller.pl';
+
+ok test_newFOROP_without_slab(),
+ 'no assertion failures when allocating FOROP without slab';
Property changes on: trunk/contrib/perl/ext/XS-APItest/t/op.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/ext/XS-APItest/t/op_contextualize.t
===================================================================
--- trunk/contrib/perl/ext/XS-APItest/t/op_contextualize.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/XS-APItest/t/op_contextualize.t 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/XS-APItest/t/op_contextualize.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/XS-APItest/t/op_list.t
===================================================================
--- trunk/contrib/perl/ext/XS-APItest/t/op_list.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/XS-APItest/t/op_list.t 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/XS-APItest/t/op_list.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/XS-APItest/t/overload.t
===================================================================
--- trunk/contrib/perl/ext/XS-APItest/t/overload.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/XS-APItest/t/overload.t 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/XS-APItest/t/overload.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Copied: trunk/contrib/perl/ext/XS-APItest/t/pad_scalar.t (from rev 6437, vendor/perl/5.18.1/ext/XS-APItest/t/pad_scalar.t)
===================================================================
--- trunk/contrib/perl/ext/XS-APItest/t/pad_scalar.t (rev 0)
+++ trunk/contrib/perl/ext/XS-APItest/t/pad_scalar.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -0,0 +1,75 @@
+use warnings;
+use strict;
+
+use Test::More tests => 76;
+
+use XS::APItest qw(pad_scalar);
+
+is pad_scalar(1, "foo"), "NOT_IN_PAD";
+is pad_scalar(2, "foo"), "NOT_IN_PAD";
+is pad_scalar(3, "foo"), "NOT_IN_PAD";
+is pad_scalar(4, "foo"), "NOT_IN_PAD";
+is pad_scalar(1, "bar"), "NOT_IN_PAD";
+is pad_scalar(2, "bar"), "NOT_IN_PAD";
+is pad_scalar(3, "bar"), "NOT_IN_PAD";
+
+our $foo = "wibble";
+my $bar = "wobble";
+is pad_scalar(1, "foo"), "NOT_MY";
+is pad_scalar(2, "foo"), "NOT_MY";
+is pad_scalar(3, "foo"), "NOT_MY";
+is pad_scalar(4, "foo"), "NOT_MY";
+is pad_scalar(1, "bar"), "wobble";
+is pad_scalar(2, "bar"), "wobble";
+is pad_scalar(3, "bar"), "wobble";
+
+sub aa($);
+sub aa($) {
+ my $xyz;
+ ok \pad_scalar(1, "xyz") == \$xyz;
+ ok \pad_scalar(2, "xyz") == \$xyz;
+ ok \pad_scalar(3, "xyz") == \$xyz;
+ aa(0) if $_[0];
+ ok \pad_scalar(1, "xyz") == \$xyz;
+ ok \pad_scalar(2, "xyz") == \$xyz;
+ ok \pad_scalar(3, "xyz") == \$xyz;
+ is pad_scalar(1, "bar"), "wobble";
+ is pad_scalar(2, "bar"), "wobble";
+ is pad_scalar(3, "bar"), "wobble";
+}
+aa(1);
+
+sub bb() {
+ my $counter = 0;
+ my $foo = \$counter;
+ return sub {
+ ok pad_scalar(1, "foo") == \pad_scalar(1, "counter");
+ ok pad_scalar(2, "foo") == \pad_scalar(1, "counter");
+ ok pad_scalar(3, "foo") == \pad_scalar(1, "counter");
+ ok pad_scalar(4, "foo") == \pad_scalar(1, "counter");
+ if(pad_scalar(1, "counter") % 3 == 0) {
+ return pad_scalar(1, "counter")++;
+ } elsif(pad_scalar(1, "counter") % 3 == 0) {
+ return pad_scalar(2, "counter")++;
+ } else {
+ return pad_scalar(3, "counter")++;
+ }
+ };
+}
+my $a = bb();
+my $b = bb();
+is $a->(), 0;
+is $a->(), 1;
+is $a->(), 2;
+is $a->(), 3;
+is $b->(), 0;
+is $b->(), 1;
+is $a->(), 4;
+is $b->(), 2;
+
+is pad_scalar(1, "foo"), "NOT_MY";
+is pad_scalar(2, "foo"), "NOT_MY";
+is pad_scalar(3, "foo"), "NOT_MY";
+is pad_scalar(4, "foo"), "NOT_MY";
+
+1;
Modified: trunk/contrib/perl/ext/XS-APItest/t/peep.t
===================================================================
--- trunk/contrib/perl/ext/XS-APItest/t/peep.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/XS-APItest/t/peep.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -2,7 +2,7 @@
use strict;
use warnings;
-use Test::More tests => 9;
+use Test::More tests => 6;
use XS::APItest;
@@ -20,14 +20,19 @@
is($rrecord->[0], 'affe');
-# peep got called for each root op of the branch
-$::moo = $::moo = 0;
+# A deep-enough nesting of conditionals defeats the deferring mechanism
+# and triggers recursion. Note that this test is sensitive to the details
+# rpeep: the main thing it is testing is that rpeep is called more than
+# peep, and that all branches are covered; the order of branch calling is
+# less important.
+
+my $code = q[my ($a,$b); $a =];
+$code .= qq{ \$b ? "foo$_" :} for (1..10);
+$code .= qq{ "foo11" };
XS::APItest::peep_enable;
-eval q[my $foo = $::moo ? q/x/ : q/y/];
+eval $code;
XS::APItest::peep_disable;
-is(scalar @{ $record }, 1);
-is(scalar @{ $rrecord }, 2);
-is($record->[0], 'y');
-is($rrecord->[0], 'x');
-is($rrecord->[1], 'y');
+is_deeply($record, [ "foo11" ]);
+is_deeply($rrecord, [
+ qw(foo1 foo2 foo3 foo4 foo5 foo6 foo10 foo9 foo8 foo7 foo11) ]);
Property changes on: trunk/contrib/perl/ext/XS-APItest/t/peep.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/XS-APItest/t/pmflag.t
===================================================================
--- trunk/contrib/perl/ext/XS-APItest/t/pmflag.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/XS-APItest/t/pmflag.t 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/XS-APItest/t/pmflag.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/XS-APItest/t/postinc.t
===================================================================
--- trunk/contrib/perl/ext/XS-APItest/t/postinc.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/XS-APItest/t/postinc.t 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/XS-APItest/t/postinc.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/XS-APItest/t/printf.t
===================================================================
--- trunk/contrib/perl/ext/XS-APItest/t/printf.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/XS-APItest/t/printf.t 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/XS-APItest/t/printf.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/ext/XS-APItest/t/ptr_table.t
===================================================================
--- trunk/contrib/perl/ext/XS-APItest/t/ptr_table.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/XS-APItest/t/ptr_table.t 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/XS-APItest/t/ptr_table.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/XS-APItest/t/push.t
===================================================================
--- trunk/contrib/perl/ext/XS-APItest/t/push.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/XS-APItest/t/push.t 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/XS-APItest/t/push.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/ext/XS-APItest/t/refs.t
===================================================================
--- trunk/contrib/perl/ext/XS-APItest/t/refs.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/XS-APItest/t/refs.t 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/XS-APItest/t/refs.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/XS-APItest/t/rmagical.t
===================================================================
--- trunk/contrib/perl/ext/XS-APItest/t/rmagical.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/XS-APItest/t/rmagical.t 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/XS-APItest/t/rmagical.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/XS-APItest/t/rv2cv_op_cv.t
===================================================================
--- trunk/contrib/perl/ext/XS-APItest/t/rv2cv_op_cv.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/XS-APItest/t/rv2cv_op_cv.t 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/XS-APItest/t/rv2cv_op_cv.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/XS-APItest/t/savehints.t
===================================================================
--- trunk/contrib/perl/ext/XS-APItest/t/savehints.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/XS-APItest/t/savehints.t 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/XS-APItest/t/savehints.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/XS-APItest/t/scopelessblock.t
===================================================================
--- trunk/contrib/perl/ext/XS-APItest/t/scopelessblock.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/XS-APItest/t/scopelessblock.t 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/XS-APItest/t/scopelessblock.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Copied: trunk/contrib/perl/ext/XS-APItest/t/sort.t (from rev 6437, vendor/perl/5.18.1/ext/XS-APItest/t/sort.t)
===================================================================
--- trunk/contrib/perl/ext/XS-APItest/t/sort.t (rev 0)
+++ trunk/contrib/perl/ext/XS-APItest/t/sort.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -0,0 +1,17 @@
+#!perl -w
+
+use strict;
+use warnings;
+use Test::More tests => 2;
+
+use XS::APItest;
+
+is join("", sort xs_cmp split//, '1415926535'), '1135559246',
+ 'sort treats XS cmp routines as having implicit ($$)';
+{
+ my $w;
+ local $SIG{__WARN__} = sub { $w .= shift };
+ () = sort xs_cmp_undef 1,2;
+ like $w, qr/^Use of uninitialized value in sort at /,
+ 'warning about undef retval from cmp routine mentions sort';
+}
Index: trunk/contrib/perl/ext/XS-APItest/t/stmtasexpr.t
===================================================================
--- trunk/contrib/perl/ext/XS-APItest/t/stmtasexpr.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/XS-APItest/t/stmtasexpr.t 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/XS-APItest/t/stmtasexpr.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/XS-APItest/t/stmtsasexpr.t
===================================================================
--- trunk/contrib/perl/ext/XS-APItest/t/stmtsasexpr.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/XS-APItest/t/stmtsasexpr.t 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/XS-APItest/t/stmtsasexpr.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/XS-APItest/t/stuff_modify_bug.t
===================================================================
--- trunk/contrib/perl/ext/XS-APItest/t/stuff_modify_bug.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/XS-APItest/t/stuff_modify_bug.t 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/XS-APItest/t/stuff_modify_bug.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/XS-APItest/t/stuff_svcur_bug.t
===================================================================
--- trunk/contrib/perl/ext/XS-APItest/t/stuff_svcur_bug.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/XS-APItest/t/stuff_svcur_bug.t 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/XS-APItest/t/stuff_svcur_bug.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Copied: trunk/contrib/perl/ext/XS-APItest/t/sviscow.t (from rev 6437, vendor/perl/5.18.1/ext/XS-APItest/t/sviscow.t)
===================================================================
--- trunk/contrib/perl/ext/XS-APItest/t/sviscow.t (rev 0)
+++ trunk/contrib/perl/ext/XS-APItest/t/sviscow.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -0,0 +1,13 @@
+use strict;
+use warnings; no warnings 'once';
+
+use Test::More tests => 1;
+
+use XS::APItest;
+use Hash::Util 'lock_value';
+
+my %h;
+$h{g} = *foo;
+lock_value %h, 'g';
+
+ok(!SvIsCOW($h{g}), 'SvIsCOW is honest when it comes to globs');
Index: trunk/contrib/perl/ext/XS-APItest/t/svpeek.t
===================================================================
--- trunk/contrib/perl/ext/XS-APItest/t/svpeek.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/XS-APItest/t/svpeek.t 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/XS-APItest/t/svpeek.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Copied: trunk/contrib/perl/ext/XS-APItest/t/svpv.t (from rev 6437, vendor/perl/5.18.1/ext/XS-APItest/t/svpv.t)
===================================================================
--- trunk/contrib/perl/ext/XS-APItest/t/svpv.t (rev 0)
+++ trunk/contrib/perl/ext/XS-APItest/t/svpv.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -0,0 +1,25 @@
+#!perl -w
+
+use Test::More tests => 18;
+
+use XS::APItest;
+
+for my $func ('SvPVbyte', 'SvPVutf8') {
+ $g = *glob;
+ $r = \1;
+ is &$func($g), '*main::glob', "$func(\$glob_copy)";
+ is ref\$g, 'GLOB', "$func(\$glob_copy) does not flatten the glob";
+ is &$func($r), "$r", "$func(\$ref)";
+ is ref\$r, 'REF', "$func(\$ref) does not flatten the ref";
+
+ is &$func(*glob), '*main::glob', "$func(*glob)";
+ is ref\$::{glob}, 'GLOB', "$func(*glob) does not flatten the glob";
+ is &$func($^V), "$^V", "$func(\$ro_ref)";
+ is ref\$^V, 'REF', "$func(\$ro_ref) does not flatten the ref";
+}
+
+eval 'SvPVbyte(*{chr 256})';
+like $@, qr/^Wide character/, 'SvPVbyte fails on Unicode glob';
+package r { use overload '""' => sub { substr "\x{100}\xff", -1 } }
+is SvPVbyte(bless [], r::), "\xff",
+ 'SvPVbyte on ref returning downgradable utf8 string';
Modified: trunk/contrib/perl/ext/XS-APItest/t/svpv_magic.t
===================================================================
--- trunk/contrib/perl/ext/XS-APItest/t/svpv_magic.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/XS-APItest/t/svpv_magic.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -1,6 +1,6 @@
#!perl -w
-use Test::More tests => 5;
+use Test::More tests => 10;
BEGIN {
use_ok('XS::APItest')
@@ -28,3 +28,23 @@
is(eval { XS::APItest::first_byte($1) } || $@, 0303,
"utf8 flag fetched correctly without stringification");
+
+sub TIESCALAR { bless [], shift }
+sub FETCH { ++$f; *{chr 255} }
+tie $t, "main";
+is SvPVutf8($t), "*main::\xc3\xbf",
+ 'SvPVutf8 works with get-magic changing the SV type';
+is $f, 1, 'SvPVutf8 calls get-magic once';
+
+package t {
+ @ISA = 'main';
+ sub FETCH { ++$::f; chr 255 }
+ sub STORE { }
+}
+tie $t, "t";
+undef $f;
+is SvPVutf8($t), "\xc3\xbf",
+ 'SvPVutf8 works with get-magic downgrading the SV';
+is $f, 1, 'SvPVutf8 calls get-magic once';
+()="$t";
+is $f, 2, 'SvPVutf8 does not stop stringification from calling FETCH';
Property changes on: trunk/contrib/perl/ext/XS-APItest/t/svpv_magic.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/ext/XS-APItest/t/svsetsv.t
===================================================================
--- trunk/contrib/perl/ext/XS-APItest/t/svsetsv.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/XS-APItest/t/svsetsv.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -1,7 +1,7 @@
use strict;
use warnings;
-use Test::More tests => 3;
+use Test::More tests => 7;
BEGIN { use_ok('XS::APItest') };
@@ -12,3 +12,16 @@
ok(!sv_setsv_cow_hashkey_notcore,
"Without PERL_CORE sv_setsv doesn't COW for shared hash key scalars");
+
+*AUTOLOAD = \&XS::APItest::AutoLoader::AUTOLOADp;
+foo(\1); sv_set_deref(\&AUTOLOAD, '$', 0);
+is prototype(\&AUTOLOAD), '$', 'sv_setsv(cv,...) sets prototype';
+foo(\1); sv_set_deref(\&AUTOLOAD, '$', 1);
+is prototype(\&AUTOLOAD), '$', 'sv_setpv(cv,...) sets prototype';
+foo(\1); sv_set_deref(\&AUTOLOAD, '$', 2);
+is prototype(\&AUTOLOAD), '$', 'sv_setpvn(cv,...) sets prototype';
+
+# Perhaps this does not belong here? But it is at least testing that
+# sv_mortalcopy uses sv_setsv in an unsurprising way.
+ok !SvIsCOW(sv_mortalcopy(__PACKAGE__)),
+ 'sv_mortalcopy does not COW for extensions [perl #79824]';
Property changes on: trunk/contrib/perl/ext/XS-APItest/t/svsetsv.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/ext/XS-APItest/t/swaplabel.t
===================================================================
--- trunk/contrib/perl/ext/XS-APItest/t/swaplabel.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/XS-APItest/t/swaplabel.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -1,7 +1,7 @@
use warnings;
use strict;
-use Test::More tests => 28;
+use Test::More tests => 56;
BEGIN { $^H |= 0x20000; }
@@ -179,4 +179,181 @@
isnt $@, "";
is $t, "";
+{
+ use utf8;
+ use open qw( :utf8 :std );
+
+ $t = "";
+ eval q{
+ use XS::APItest qw(swaplabel);
+ $t .= "ㅏ";
+ $t .= "Ḇ";
+ swaplabel $t .= "ᶜ";
+ swaplabel $t .= "ᛑ";
+ $t .= "ᶟ";
+ };
+ is $@, "";
+ is $t, "ㅏḆᶜᛑᶟ";
+
+ $t = "";
+ eval q{
+ use XS::APItest qw(swaplabel);
+ $t .= "ㅏ";
+ LḆ: $t .= "Ḇ";
+ swaplabel $t .= "ᶜ"; Lᶜ:
+ swaplabel $t .= "ᛑ"; Lᛑ:
+ Lᶟ: $t .= "ᶟ";
+ };
+ is $@, "";
+ is $t, "ㅏḆᶜᛑᶟ";
+
+ $t = "";
+ eval q{
+ use XS::APItest qw(swaplabel);
+ $t .= "ㅏ";
+ goto LḆ;
+ LḆ: $t .= "Ḇ";
+ swaplabel $t .= "ᶜ"; Lᶜ:
+ swaplabel $t .= "ᛑ"; Lᛑ:
+ Lᶟ: $t .= "ᶟ";
+ };
+ is $@, "";
+ is $t, "ㅏḆᶜᛑᶟ";
+
+ $t = "";
+ eval q{
+ use XS::APItest qw(swaplabel);
+ $t .= "ㅏ";
+ goto Lᶜ;
+ LḆ: $t .= "Ḇ";
+ swaplabel $t .= "ᶜ"; Lᶜ:
+ swaplabel $t .= "ᛑ"; Lᛑ:
+ Lᶟ: $t .= "ᶟ";
+ };
+ is $@, "";
+ is $t, "ㅏᶜᛑᶟ";
+
+ $t = "";
+ eval q{
+ use XS::APItest qw(swaplabel);
+ $t .= "ㅏ";
+ goto Lᛑ;
+ LḆ: $t .= "Ḇ";
+ swaplabel $t .= "ᶜ"; Lᶜ:
+ swaplabel $t .= "ᛑ"; Lᛑ:
+ Lᶟ: $t .= "ᶟ";
+ };
+ is $@, "";
+ is $t, "ㅏᛑᶟ";
+
+ $t = "";
+ eval q{
+ use XS::APItest qw(swaplabel);
+ $t .= "ㅏ";
+ goto Lᶟ;
+ LḆ: $t .= "Ḇ";
+ swaplabel $t .= "ᶜ"; Lᶜ:
+ swaplabel $t .= "ᛑ"; Lᛑ:
+ Lᶟ: $t .= "ᶟ";
+ };
+ is $@, "";
+ is $t, "ㅏᶟ";
+
+ $t = "";
+ eval q{
+ use XS::APItest qw(swaplabel);
+ $t .= "ㅏ";
+ swaplabel $t .= "Ḇ"; y:
+ $t .= "ᶜ";
+ };
+ isnt $@, "";
+ is $t, "";
+
+ $t = "";
+ eval q{
+ use XS::APItest qw(swaplabel);
+ if(1) { $t .= "ㅏ"; }
+ if(1) { $t .= "Ḇ"; }
+ swaplabel if(1) { $t .= "ᶜ"; }
+ swaplabel if(1) { $t .= "ᛑ"; }
+ if(1) { $t .= "ᶟ"; }
+ };
+ is $@, "";
+ is $t, "ㅏḆᶜᛑᶟ";
+
+ $t = "";
+ eval q{
+ use XS::APItest qw(swaplabel);
+ if(1) { $t .= "ㅏ"; }
+ LḆ: if(1) { $t .= "Ḇ"; }
+ swaplabel if(1) { $t .= "ᶜ"; } Lᶜ:
+ swaplabel if(1) { $t .= "ᛑ"; } Lᛑ:
+ Lᶟ: if(1) { $t .= "ᶟ"; }
+ };
+ is $@, "";
+ is $t, "ㅏḆᶜᛑᶟ";
+
+ $t = "";
+ eval q{
+ use XS::APItest qw(swaplabel);
+ if(1) { $t .= "ㅏ"; }
+ goto LḆ;
+ LḆ: if(1) { $t .= "Ḇ"; }
+ swaplabel if(1) { $t .= "ᶜ"; } Lᶜ:
+ swaplabel if(1) { $t .= "ᛑ"; } Lᛑ:
+ Lᶟ: if(1) { $t .= "ᶟ"; }
+ };
+ is $@, "";
+ is $t, "ㅏḆᶜᛑᶟ";
+
+ $t = "";
+ eval q{
+ use XS::APItest qw(swaplabel);
+ if(1) { $t .= "ㅏ"; }
+ goto Lᶜ;
+ LḆ: if(1) { $t .= "Ḇ"; }
+ swaplabel if(1) { $t .= "ᶜ"; } Lᶜ:
+ swaplabel if(1) { $t .= "ᛑ"; } Lᛑ:
+ Lᶟ: if(1) { $t .= "ᶟ"; }
+ };
+ is $@, "";
+ is $t, "ㅏᶜᛑᶟ";
+
+ $t = "";
+ eval q{
+ use XS::APItest qw(swaplabel);
+ if(1) { $t .= "ㅏ"; }
+ goto Lᛑ;
+ LḆ: if(1) { $t .= "Ḇ"; }
+ swaplabel if(1) { $t .= "ᶜ"; } Lᶜ:
+ swaplabel if(1) { $t .= "ᛑ"; } Lᛑ:
+ Lᶟ: if(1) { $t .= "ᶟ"; }
+ };
+ is $@, "";
+ is $t, "ㅏᛑᶟ";
+
+ $t = "";
+ eval q{
+ use XS::APItest qw(swaplabel);
+ if(1) { $t .= "ㅏ"; }
+ goto Lᶟ;
+ LḆ: if(1) { $t .= "Ḇ"; }
+ swaplabel if(1) { $t .= "ᶜ"; } Lᶜ:
+ swaplabel if(1) { $t .= "ᛑ"; } Lᛑ:
+ Lᶟ: if(1) { $t .= "ᶟ"; }
+ };
+ is $@, "";
+ is $t, "ㅏᶟ";
+
+ $t = "";
+ eval q{
+ use XS::APItest qw(swaplabel);
+ if(1) { $t .= "ㅏ"; }
+ swaplabel if(1) { $t .= "Ḇ"; } y:
+ if(1) { $t .= "ᶜ"; }
+ };
+ isnt $@, "";
+ is $t, "";
+}
+
1;
Property changes on: trunk/contrib/perl/ext/XS-APItest/t/swaplabel.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/XS-APItest/t/swaptwostmts.t
===================================================================
--- trunk/contrib/perl/ext/XS-APItest/t/swaptwostmts.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/XS-APItest/t/swaptwostmts.t 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/XS-APItest/t/swaptwostmts.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Copied: trunk/contrib/perl/ext/XS-APItest/t/sym-hook.t (from rev 6437, vendor/perl/5.18.1/ext/XS-APItest/t/sym-hook.t)
===================================================================
--- trunk/contrib/perl/ext/XS-APItest/t/sym-hook.t (rev 0)
+++ trunk/contrib/perl/ext/XS-APItest/t/sym-hook.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -0,0 +1,32 @@
+
+# Test that PL_check hooks for RV2*V can override symbol lookups.
+
+# So far we only test RV2CV.
+
+use XS::APItest;
+use Test::More tests => 4;
+
+BEGIN {
+ setup_rv2cv_addunderbar;
+ $^H{'XS::APItest/addunder'} = 1; # make foo() actually call foo_()
+}
+
+sub foo_ { @_ ? shift . "___" : "phew" }
+
+is(foo(), "phew");
+
+# Make sure subs looked up via rv2cv check hooks are not treated as second-
+# class subs.
+
+BEGIN { # If there is a foo symbol, this test will not be testing anything.
+ delete $::{foo};
+ delete $::{goo};
+}
+is((foo bar), 'bar___');
+$bar = "baz";
+is((foo $bar), 'baz___');
+
+# Proto should cause goo() to override Foo->goo interpretation.
+{package Foom}
+sub goo_ (*) { shift . "===" }
+is((goo Foom), "Foom===");
Index: trunk/contrib/perl/ext/XS-APItest/t/temp_lv_sub.t
===================================================================
--- trunk/contrib/perl/ext/XS-APItest/t/temp_lv_sub.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/XS-APItest/t/temp_lv_sub.t 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/XS-APItest/t/temp_lv_sub.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Copied: trunk/contrib/perl/ext/XS-APItest/t/underscore_length.t (from rev 6437, vendor/perl/5.18.1/ext/XS-APItest/t/underscore_length.t)
===================================================================
--- trunk/contrib/perl/ext/XS-APItest/t/underscore_length.t (rev 0)
+++ trunk/contrib/perl/ext/XS-APItest/t/underscore_length.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -0,0 +1,20 @@
+use warnings; no warnings 'experimental::lexical_topic';
+use strict;
+
+use Test::More tests => 4;
+
+use XS::APItest qw(underscore_length);
+
+$_ = "foo";
+is underscore_length(), 3;
+
+$_ = "snowman \x{2603}";
+is underscore_length(), 9;
+
+my $_ = "xyzzy";
+is underscore_length(), 5;
+
+$_ = "pile of poo \x{1f4a9}";
+is underscore_length(), 13;
+
+1;
Index: trunk/contrib/perl/ext/XS-APItest/t/utf16_to_utf8.t
===================================================================
--- trunk/contrib/perl/ext/XS-APItest/t/utf16_to_utf8.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/XS-APItest/t/utf16_to_utf8.t 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/XS-APItest/t/utf16_to_utf8.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/ext/XS-APItest/t/utf8.t
===================================================================
--- trunk/contrib/perl/ext/XS-APItest/t/utf8.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/XS-APItest/t/utf8.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -24,4 +24,268 @@
is(bytes_cmp_utf8($right, $left), -$expect, "$desc reversed");
}
+# Test uft8n_to_uvuni(). These provide essentially complete code coverage.
+
+# Copied from utf8.h
+my $UTF8_ALLOW_EMPTY = 0x0001;
+my $UTF8_ALLOW_CONTINUATION = 0x0002;
+my $UTF8_ALLOW_NON_CONTINUATION = 0x0004;
+my $UTF8_ALLOW_SHORT = 0x0008;
+my $UTF8_ALLOW_LONG = 0x0010;
+my $UTF8_DISALLOW_SURROGATE = 0x0020;
+my $UTF8_WARN_SURROGATE = 0x0040;
+my $UTF8_DISALLOW_NONCHAR = 0x0080;
+my $UTF8_WARN_NONCHAR = 0x0100;
+my $UTF8_DISALLOW_SUPER = 0x0200;
+my $UTF8_WARN_SUPER = 0x0400;
+my $UTF8_DISALLOW_FE_FF = 0x0800;
+my $UTF8_WARN_FE_FF = 0x1000;
+my $UTF8_CHECK_ONLY = 0x2000;
+
+my $REPLACEMENT = 0xFFFD;
+
+my @warnings;
+
+use warnings 'utf8';
+local $SIG{__WARN__} = sub { push @warnings, @_ };
+
+# First test the malformations. All these raise category utf8 warnings.
+foreach my $test (
+ [ "zero length string malformation", "", 0,
+ $UTF8_ALLOW_EMPTY, 0, 0,
+ qr/empty string/
+ ],
+ [ "orphan continuation byte malformation", "\x80a", 2,
+ $UTF8_ALLOW_CONTINUATION, $REPLACEMENT, 1,
+ qr/unexpected continuation byte/
+ ],
+ [ "premature next character malformation (immediate)", "\xc2a", 2,
+ $UTF8_ALLOW_NON_CONTINUATION, $REPLACEMENT, 1,
+ qr/unexpected non-continuation byte.*immediately after start byte/
+ ],
+ [ "premature next character malformation (non-immediate)", "\xf0\x80a", 3,
+ $UTF8_ALLOW_NON_CONTINUATION, $REPLACEMENT, 2,
+ qr/unexpected non-continuation byte .* 2 bytes after start byte/
+ ],
+ [ "too short malformation", "\xf0\x80a", 2,
+ # Having the 'a' after this, but saying there are only 2 bytes also
+ # tests that we pay attention to the passed in length
+ $UTF8_ALLOW_SHORT, $REPLACEMENT, 2,
+ qr/2 bytes, need 4/
+ ],
+ [ "overlong malformation", "\xc1\xaf", 2,
+ $UTF8_ALLOW_LONG, ord('o'), 2,
+ qr/2 bytes, need 1/
+ ],
+ [ "overflow malformation", "\xff\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf", 13,
+ 0, # There is no way to allow this malformation
+ $REPLACEMENT, 13,
+ qr/overflow/
+ ],
+) {
+ my ($testname, $bytes, $length, $allow_flags, $allowed_uv, $expected_len, $message ) = @$test;
+
+ next if ! ok(length($bytes) >= $length, "$testname: Make sure won't read beyond buffer: " . length($bytes) . " >= $length");
+
+ # Test what happens when this malformation is not allowed
+ undef @warnings;
+ my $ret_ref = test_utf8n_to_uvuni($bytes, $length, 0);
+ is($ret_ref->[0], 0, "$testname: disallowed: Returns 0");
+ is($ret_ref->[1], $expected_len, "$testname: disallowed: Returns expected length");
+ if (is(scalar @warnings, 1, "$testname: disallowed: Got a single warning ")) {
+ like($warnings[0], $message, "$testname: disallowed: Got expected warning");
+ }
+ else {
+ if (scalar @warnings) {
+ note "The warnings were: " . join(", ", @warnings);
+ }
+ }
+
+ { # Next test when disallowed, and warnings are off.
+ undef @warnings;
+ no warnings 'utf8';
+ my $ret_ref = test_utf8n_to_uvuni($bytes, $length, 0);
+ is($ret_ref->[0], 0, "$testname: disallowed: no warnings 'utf8': Returns 0");
+ is($ret_ref->[1], $expected_len, "$testname: disallowed: no warnings 'utf8': Returns expected length");
+ if (!is(scalar @warnings, 0, "$testname: disallowed: no warnings 'utf8': no warnings generated")) {
+ note "The warnings were: " . join(", ", @warnings);
+ }
+ }
+
+ # Test with CHECK_ONLY
+ undef @warnings;
+ $ret_ref = test_utf8n_to_uvuni($bytes, $length, $UTF8_CHECK_ONLY);
+ is($ret_ref->[0], 0, "$testname: CHECK_ONLY: Returns 0");
+ is($ret_ref->[1], -1, "$testname: CHECK_ONLY: returns expected length");
+ if (! is(scalar @warnings, 0, "$testname: CHECK_ONLY: no warnings generated")) {
+ note "The warnings were: " . join(", ", @warnings);
+ }
+
+ next if $allow_flags == 0; # Skip if can't allow this malformation
+
+ # Test when the malformation is allowed
+ undef @warnings;
+ $ret_ref = test_utf8n_to_uvuni($bytes, $length, $allow_flags);
+ is($ret_ref->[0], $allowed_uv, "$testname: allowed: Returns expected uv");
+ is($ret_ref->[1], $expected_len, "$testname: allowed: Returns expected length");
+ if (!is(scalar @warnings, 0, "$testname: allowed: no warnings generated"))
+ {
+ note "The warnings were: " . join(", ", @warnings);
+ }
+}
+
+my $FF_ret;
+
+use Unicode::UCD;
+my $has_quad = ($Unicode::UCD::MAX_CP > 0xFFFF_FFFF);
+if ($has_quad) {
+ no warnings qw{portable overflow};
+ $FF_ret = 0x1000000000;
+}
+else { # The above overflows unless a quad platform
+ $FF_ret = 0;
+}
+
+# Now test the cases where a legal code point is generated, but may or may not
+# be allowed/warned on.
+my @tests = (
+ [ "surrogate", "\xed\xa4\x8d",
+ $UTF8_WARN_SURROGATE, $UTF8_DISALLOW_SURROGATE, 'surrogate', 0xD90D, 3,
+ qr/surrogate/
+ ],
+ [ "non_unicode", "\xf4\x90\x80\x80",
+ $UTF8_WARN_SUPER, $UTF8_DISALLOW_SUPER, 'non_unicode', 0x110000, 4,
+ qr/not Unicode/
+ ],
+ [ "non-character code point", "\xEF\xB7\x90",
+ $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, 'nonchar', 0xFDD0, 3,
+ qr/Unicode non-character.*is illegal for open interchange/
+ ],
+ [ "begins with FE", "\xfe\x82\x80\x80\x80\x80\x80",
+
+ # This code point is chosen so that it is representable in a UV on
+ # 32-bit machines
+ $UTF8_WARN_FE_FF, $UTF8_DISALLOW_FE_FF, 'utf8', 0x80000000, 7,
+ qr/Code point beginning with byte .* is not Unicode, and not portable/
+ ],
+ [ "overflow with FE/FF",
+ # This tests the interaction of WARN_FE_FF/DISALLOW_FE_FF with
+ # overflow. The overflow malformation is never allowed, so preventing
+ # it takes precedence if the FE_FF options would otherwise allow in an
+ # overflowing value. These two code points (1 for 32-bits; 1 for 64)
+ # were chosen because the old overflow detection algorithm did not
+ # catch them; this means this test also checks for that fix.
+ ($has_quad)
+ ? "\xff\x80\x90\x90\x90\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf"
+ : "\xfe\x86\x80\x80\x80\x80\x80",
+ $UTF8_WARN_FE_FF, $UTF8_DISALLOW_FE_FF, 'utf8', 0,
+ ($has_quad) ? 13 : 7,
+ qr/Code point beginning with byte .* is not Unicode, and not portable/
+ ],
+);
+
+if ($has_quad) { # All FF's will overflow on 32 bit
+ push @tests,
+ [ "begins with FF", "\xff\x80\x80\x80\x80\x80\x81\x80\x80\x80\x80\x80\x80",
+ $UTF8_WARN_FE_FF, $UTF8_DISALLOW_FE_FF, 'utf8', $FF_ret, 13,
+ qr/Code point beginning with byte .* is not Unicode, and not portable/
+ ];
+}
+
+foreach my $test (@tests) {
+ my ($testname, $bytes, $warn_flags, $disallow_flags, $category, $allowed_uv, $expected_len, $message ) = @$test;
+
+ my $length = length $bytes;
+ my $will_overflow = $testname =~ /overflow/;
+
+ # This is more complicated than the malformations tested earlier, as there
+ # are several orthogonal variables involved. We test all the subclasses
+ # of utf8 warnings to verify they work with and without the utf8 class,
+ # and don't have effects on other sublass warnings
+ foreach my $warning (0, 'utf8', 'surrogate', 'nonchar', 'non_unicode') {
+ foreach my $warn_flag (0, $warn_flags) {
+ foreach my $disallow_flag (0, $disallow_flags) {
+
+ no warnings 'utf8';
+ my $eval_warn = $warning eq 0 ? "no warnings" : "use warnings '$warning'";
+
+ # is effectively disallowed if will overflow, even if the flag
+ # indicates it is allowed, fix up test name to indicate this
+ # as well
+ my $disallowed = $disallow_flag || $will_overflow;
+
+ my $this_name = "$testname: " . (($disallow_flag)
+ ? 'disallowed'
+ : ($disallowed)
+ ? 'FE_FF allowed'
+ : 'allowed');
+ $this_name .= ", $eval_warn";
+ $this_name .= ", " . (($warn_flag) ? 'with warning flag' : 'no warning flag');
+
+ undef @warnings;
+ my $ret_ref;
+ #note __LINE__ . ": $eval_warn; \$ret_ref = test_utf8n_to_uvuni('$bytes', $length, $warn_flag|$disallow_flag)";
+ my $eval_text = "$eval_warn; \$ret_ref = test_utf8n_to_uvuni('$bytes', $length, $warn_flag|$disallow_flag)";
+ eval "$eval_text";
+ if (! ok ("$@ eq ''", "$this_name: eval succeeded")) {
+ note "\$!='$!'; eval'd=\"$eval_text\"";
+ next;
+ }
+ if ($disallowed) {
+ is($ret_ref->[0], 0, "$this_name: Returns 0");
+ }
+ else {
+ is($ret_ref->[0], $allowed_uv, "$this_name: Returns expected uv");
+ }
+ is($ret_ref->[1], $expected_len, "$this_name: Returns expected length");
+
+ if ($will_overflow && ! $disallow_flag && $warning eq 'utf8') {
+
+ # Will get the overflow message instead of the expected
+ # message under these circumstances, as they would
+ # otherwise accept an overflowed value, which the code
+ # should not allow, so falls back to overflow.
+ if (is(scalar @warnings, 1, "$this_name: Got a single warning ")) {
+ like($warnings[0], qr/overflow/, "$this_name: Got overflow warning");
+ }
+ else {
+ if (scalar @warnings) {
+ note "The warnings were: " . join(", ", @warnings);
+ }
+ }
+ }
+ elsif ($warn_flag && ($warning eq 'utf8' || $warning eq $category)) {
+ if (is(scalar @warnings, 1, "$this_name: Got a single warning ")) {
+ like($warnings[0], $message, "$this_name: Got expected warning");
+ }
+ else {
+ if (scalar @warnings) {
+ note "The warnings were: " . join(", ", @warnings);
+ }
+ }
+ }
+ else {
+ if (!is(scalar @warnings, 0, "$this_name: No warnings generated"))
+ {
+ note "The warnings were: " . join(", ", @warnings);
+ }
+ }
+
+ # Check CHECK_ONLY results when the input is disallowed. Do
+ # this when actually disallowed, not just when the
+ # $disallow_flag is set
+ if ($disallowed) {
+ undef @warnings;
+ $ret_ref = test_utf8n_to_uvuni($bytes, $length, $disallow_flag|$UTF8_CHECK_ONLY);
+ is($ret_ref->[0], 0, "$this_name, CHECK_ONLY: Returns 0");
+ is($ret_ref->[1], -1, "$this_name: CHECK_ONLY: returns expected length");
+ if (! is(scalar @warnings, 0, "$this_name, CHECK_ONLY: no warnings generated")) {
+ note "The warnings were: " . join(", ", @warnings);
+ }
+ }
+ }
+ }
+ }
+}
+
done_testing;
Property changes on: trunk/contrib/perl/ext/XS-APItest/t/utf8.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Copied: trunk/contrib/perl/ext/XS-APItest/t/whichsig.t (from rev 6437, vendor/perl/5.18.1/ext/XS-APItest/t/whichsig.t)
===================================================================
--- trunk/contrib/perl/ext/XS-APItest/t/whichsig.t (rev 0)
+++ trunk/contrib/perl/ext/XS-APItest/t/whichsig.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -0,0 +1,26 @@
+#!perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 9;
+
+use_ok('XS::APItest');
+
+my @types = map { 'whichsig' . $_ } '', qw( _sv _pv _pvn );
+
+sub test { "Sanity check" }
+
+{
+ for my $type ( 0..3 ) {
+ is XS::APItest::whichsig_type("KILL", $type), 9, "Sanity check, $types[$type] works";
+ }
+}
+
+is XS::APItest::whichsig_type("KILL\0whoops", 0), 9, "whichsig() is not nul-clean";
+
+is XS::APItest::whichsig_type("KILL\0whoops", 1), -1, "whichsig_sv() is nul-clean";
+
+is XS::APItest::whichsig_type("KILL\0whoops", 2), 9, "whichsig_pv() is not nul-clean";
+
+is XS::APItest::whichsig_type("KILL\0whoops", 3), -1, "whichsig_pvn() is nul-clean";
Index: trunk/contrib/perl/ext/XS-APItest/t/xs_special_subs.t
===================================================================
--- trunk/contrib/perl/ext/XS-APItest/t/xs_special_subs.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/XS-APItest/t/xs_special_subs.t 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/XS-APItest/t/xs_special_subs.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/ext/XS-APItest/t/xs_special_subs_require.t
===================================================================
--- trunk/contrib/perl/ext/XS-APItest/t/xs_special_subs_require.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/XS-APItest/t/xs_special_subs_require.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -86,8 +86,8 @@
@trap = sort @trap;
is(scalar @trap, 2, "There were 2 warnings");
- is($trap[0], "Too late to run CHECK block.\n");
- is($trap[1], "Too late to run INIT block.\n");
+ like($trap[0], qr "^Too late to run CHECK block");
+ like($trap[1], qr "^Too late to run INIT block");
}
print "# Second body\n";
Property changes on: trunk/contrib/perl/ext/XS-APItest/t/xs_special_subs_require.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/ext/XS-APItest/t/xsub_h.t
===================================================================
--- trunk/contrib/perl/ext/XS-APItest/t/xsub_h.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/XS-APItest/t/xsub_h.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -18,7 +18,7 @@
sub expect_good {
my $package = $_[0];
- my $version = exists $_[1] ? ", $_[1]" : '';
+ my $version = @_ >= 2 ? ", $_[1]" : '';
local $Test::Builder::Level = $Test::Builder::Level + 1;
is_deeply([XS_VERSION_defined(@_)], [],
"Is good for $package$version");
@@ -37,7 +37,7 @@
} else {
$what = 'bootstrap parameter';
}
- if (exists $_[1]) {
+ if (@_ >= 2) {
$desc = "$_[0], $_[1]";
} else {
$desc = $_[0];
Property changes on: trunk/contrib/perl/ext/XS-APItest/t/xsub_h.t
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/XS-APItest/typemap
===================================================================
--- trunk/contrib/perl/ext/XS-APItest/typemap 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/XS-APItest/typemap 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/XS-APItest/typemap
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/XS-Typemap/Makefile.PL
===================================================================
--- trunk/contrib/perl/ext/XS-Typemap/Makefile.PL 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/XS-Typemap/Makefile.PL 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/XS-Typemap/Makefile.PL
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/ext/XS-Typemap/README
===================================================================
--- trunk/contrib/perl/ext/XS-Typemap/README 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/XS-Typemap/README 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/XS-Typemap/README
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/ext/XS-Typemap/Typemap.pm
===================================================================
--- trunk/contrib/perl/ext/XS-Typemap/Typemap.pm 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/XS-Typemap/Typemap.pm 2013-12-02 21:32:26 UTC (rev 6445)
@@ -36,14 +36,18 @@
use vars qw/ $VERSION @EXPORT /;
-$VERSION = '0.05';
+$VERSION = '0.10';
@EXPORT = (qw/
T_SV
T_SVREF
+ T_SVREF_REFCOUNT_FIXED
T_AVREF
+ T_AVREF_REFCOUNT_FIXED
T_HVREF
+ T_HVREF_REFCOUNT_FIXED
T_CVREF
+ T_CVREF_REFCOUNT_FIXED
T_SYSRET_fail T_SYSRET_pass
T_UV
T_IV
@@ -50,6 +54,8 @@
T_INT
T_ENUM
T_BOOL
+ T_BOOL_2
+ T_BOOL_OUT
T_U_INT
T_SHORT
T_U_SHORT
@@ -71,6 +77,9 @@
T_OPAQUEPTR_IN_struct T_OPAQUEPTR_OUT_struct
T_ARRAY
T_STDIO_open T_STDIO_close T_STDIO_print
+ T_PACKED_in T_PACKED_out
+ T_PACKEDARRAY_in T_PACKEDARRAY_out
+ T_INOUT T_IN T_OUT
/);
XSLoader::load();
Property changes on: trunk/contrib/perl/ext/XS-Typemap/Typemap.pm
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/ext/XS-Typemap/Typemap.xs
===================================================================
--- trunk/contrib/perl/ext/XS-Typemap/Typemap.xs 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/XS-Typemap/Typemap.xs 2013-12-02 21:32:26 UTC (rev 6445)
@@ -25,10 +25,15 @@
typedef int intObj; /* T_PTROBJ */
typedef int intRefIv; /* T_REF_IV_PTR */
typedef int intArray; /* T_ARRAY */
+typedef int intTINT; /* T_INT */
+typedef int intTLONG; /* T_LONG */
typedef short shortOPQ; /* T_OPAQUE */
typedef int intOpq; /* T_OPAQUEPTR */
+typedef unsigned intUnsigned; /* T_U_INT */
+typedef PerlIO * inputfh; /* T_IN */
+typedef PerlIO * outputfh; /* T_OUT */
-/* A structure to test T_OPAQUEPTR */
+/* A structure to test T_OPAQUEPTR and T_PACKED */
struct t_opaqueptr {
int a;
int b;
@@ -36,6 +41,7 @@
};
typedef struct t_opaqueptr astruct;
+typedef struct t_opaqueptr anotherstruct;
/* Some static memory for the tests */
static I32 xst_anint;
@@ -44,6 +50,13 @@
static intRefIv xst_anintrefiv;
static intOpq xst_anintopq;
+/* A different type to refer to for testing the different
+ * AV*, HV*, etc typemaps */
+typedef AV AV_FIXED;
+typedef HV HV_FIXED;
+typedef CV CV_FIXED;
+typedef SVREF SVREF_FIXED;
+
/* Helper functions */
/* T_ARRAY - allocate some memory */
@@ -53,26 +66,190 @@
return array;
}
+/* test T_PACKED */
+STATIC void
+XS_pack_anotherstructPtr(SV *out, anotherstruct *in)
+{
+ dTHX;
+ HV *hash = newHV();
+ if (NULL == hv_stores(hash, "a", newSViv(in->a)))
+ croak("Failed to store data in hash");
+ if (NULL == hv_stores(hash, "b", newSViv(in->b)))
+ croak("Failed to store data in hash");
+ if (NULL == hv_stores(hash, "c", newSVnv(in->c)))
+ croak("Failed to store data in hash");
+ sv_setsv(out, sv_2mortal(newRV_noinc((SV*)hash)));
+}
+STATIC anotherstruct *
+XS_unpack_anotherstructPtr(SV *in)
+{
+ dTHX; /* rats, this is expensive */
+ /* this is similar to T_HVREF since we chose to use a hash */
+ HV *inhash;
+ SV **elem;
+ anotherstruct *out;
+ SV *const tmp = in;
+ SvGETMAGIC(tmp);
+ if (SvROK(tmp) && SvTYPE(SvRV(tmp)) == SVt_PVHV)
+ inhash = (HV*)SvRV(tmp);
+ else
+ Perl_croak(aTHX_ "Argument is not a HASH reference");
+
+ /* FIXME dunno if supposed to use perl mallocs here */
+ Newxz(out, 1, anotherstruct);
+
+ elem = hv_fetchs(inhash, "a", 0);
+ if (elem == NULL)
+ Perl_croak(aTHX_ "Shouldn't happen: hv_fetchs returns NULL");
+ out->a = SvIV(*elem);
+
+ elem = hv_fetchs(inhash, "b", 0);
+ if (elem == NULL)
+ Perl_croak(aTHX_ "Shouldn't happen: hv_fetchs returns NULL");
+ out->b = SvIV(*elem);
+
+ elem = hv_fetchs(inhash, "c", 0);
+ if (elem == NULL)
+ Perl_croak(aTHX_ "Shouldn't happen: hv_fetchs returns NULL");
+ out->c = SvNV(*elem);
+
+ return out;
+}
+
+/* test T_PACKEDARRAY */
+STATIC void
+XS_pack_anotherstructPtrPtr(SV *out, anotherstruct **in, UV cnt)
+{
+ dTHX;
+ UV i;
+ AV *ary = newAV();
+ for (i = 0; i < cnt; ++i) {
+ HV *hash = newHV();
+ if (NULL == hv_stores(hash, "a", newSViv(in[i]->a)))
+ croak("Failed to store data in hash");
+ if (NULL == hv_stores(hash, "b", newSViv(in[i]->b)))
+ croak("Failed to store data in hash");
+ if (NULL == hv_stores(hash, "c", newSVnv(in[i]->c)))
+ croak("Failed to store data in hash");
+ av_push(ary, newRV_noinc((SV*)hash));
+ }
+ sv_setsv(out, sv_2mortal(newRV_noinc((SV*)ary)));
+}
+
+STATIC anotherstruct **
+XS_unpack_anotherstructPtrPtr(SV *in)
+{
+ dTHX; /* rats, this is expensive */
+ /* this is similar to T_HVREF since we chose to use a hash */
+ HV *inhash;
+ AV *inary;
+ SV **elem;
+ anotherstruct **out;
+ UV nitems, i;
+ SV *tmp;
+
+ /* safely deref the input array ref */
+ tmp = in;
+ SvGETMAGIC(tmp);
+ if (SvROK(tmp) && SvTYPE(SvRV(tmp)) == SVt_PVAV)
+ inary = (AV*)SvRV(tmp);
+ else
+ Perl_croak(aTHX_ "Argument is not an ARRAY reference");
+
+ nitems = av_len(inary) + 1;
+
+ /* FIXME dunno if supposed to use perl mallocs here */
+ /* N+1 elements so we know the last one is NULL */
+ Newxz(out, nitems+1, anotherstruct*);
+
+ /* WARNING: in real code, we'd have to Safefree() on exception, but
+ * since we're testing perl, if we croak() here, stuff is
+ * rotten anyway! */
+ for (i = 0; i < nitems; ++i) {
+ Newxz(out[i], 1, anotherstruct);
+ elem = av_fetch(inary, i, 0);
+ if (elem == NULL)
+ Perl_croak(aTHX_ "Shouldn't happen: av_fetch returns NULL");
+ tmp = *elem;
+ SvGETMAGIC(tmp);
+ if (SvROK(tmp) && SvTYPE(SvRV(tmp)) == SVt_PVHV)
+ inhash = (HV*)SvRV(tmp);
+ else
+ Perl_croak(aTHX_ "Array element %"UVuf" is not a HASH reference", i);
+
+ elem = hv_fetchs(inhash, "a", 0);
+ if (elem == NULL)
+ Perl_croak(aTHX_ "Shouldn't happen: hv_fetchs returns NULL");
+ out[i]->a = SvIV(*elem);
+
+ elem = hv_fetchs(inhash, "b", 0);
+ if (elem == NULL)
+ Perl_croak(aTHX_ "Shouldn't happen: hv_fetchs returns NULL");
+ out[i]->b = SvIV(*elem);
+
+ elem = hv_fetchs(inhash, "c", 0);
+ if (elem == NULL)
+ Perl_croak(aTHX_ "Shouldn't happen: hv_fetchs returns NULL");
+ out[i]->c = SvNV(*elem);
+ }
+
+ return out;
+}
+
+/* no special meaning as far as typemaps are concerned,
+ * just for convenience */
+void
+XS_release_anotherstructPtrPtr(anotherstruct **in)
+{
+ unsigned int i = 0;
+ while (in[i] != NULL)
+ Safefree(in[i++]);
+ Safefree(in);
+}
+
+
MODULE = XS::Typemap PACKAGE = XS::Typemap
PROTOTYPES: DISABLE
-=head1 TYPEMAPS
+TYPEMAP: <<END_OF_TYPEMAP
-Each C type is represented by an entry in the typemap file that
-is responsible for converting perl variables (SV, AV, HV and CV) to
-and from that type.
+# Typemap file for typemap testing
+# includes bonus typemap entries
+# Mainly so that all the standard typemaps can be exercised even when
+# there is not a corresponding type explicitly identified in the standard
+# typemap
-=over 4
+svtype T_ENUM
+intRef * T_PTRREF
+intRef T_IV
+intObj * T_PTROBJ
+intObj T_IV
+intRefIv * T_REF_IV_PTR
+intRefIv T_IV
+intArray * T_ARRAY
+intOpq T_IV
+intOpq * T_OPAQUEPTR
+intUnsigned T_U_INT
+intTINT T_INT
+intTLONG T_LONG
+shortOPQ T_OPAQUE
+shortOPQ * T_OPAQUEPTR
+astruct * T_OPAQUEPTR
+anotherstruct * T_PACKED
+anotherstruct ** T_PACKEDARRAY
+AV_FIXED * T_AVREF_REFCOUNT_FIXED
+HV_FIXED * T_HVREF_REFCOUNT_FIXED
+CV_FIXED * T_CVREF_REFCOUNT_FIXED
+SVREF_FIXED T_SVREF_REFCOUNT_FIXED
+inputfh T_IN
+outputfh T_OUT
-=item T_SV
+END_OF_TYPEMAP
-This simply passes the C representation of the Perl variable (an SV*)
-in and out of the XS layer. This can be used if the C code wants
-to deal directly with the Perl variable.
-=cut
+## T_SV
SV *
T_SV( sv )
@@ -89,12 +266,9 @@
OUTPUT:
RETVAL
-=item T_SVREF
-Used to pass in and return a reference to an SV.
+## T_SVREF
-=cut
-
SVREF
T_SVREF( svref )
SVREF svref
@@ -103,13 +277,21 @@
OUTPUT:
RETVAL
-=item T_AVREF
-From the perl level this is a reference to a perl array.
-From the C level this is a pointer to an AV.
+## T_SVREF_FIXED
-=cut
+SVREF_FIXED
+T_SVREF_REFCOUNT_FIXED( svref )
+ SVREF_FIXED svref
+ CODE:
+ SvREFCNT_inc(svref);
+ RETVAL = svref;
+ OUTPUT:
+ RETVAL
+
+## T_AVREF
+
AV *
T_AVREF( av )
AV * av
@@ -118,13 +300,21 @@
OUTPUT:
RETVAL
-=item T_HVREF
-From the perl level this is a reference to a perl hash.
-From the C level this is a pointer to an HV.
+## T_AVREF_REFCOUNT_FIXED
-=cut
+AV_FIXED*
+T_AVREF_REFCOUNT_FIXED( av )
+ AV_FIXED * av
+ CODE:
+ SvREFCNT_inc(av);
+ RETVAL = av;
+ OUTPUT:
+ RETVAL
+
+## T_HVREF
+
HV *
T_HVREF( hv )
HV * hv
@@ -133,14 +323,21 @@
OUTPUT:
RETVAL
-=item T_CVREF
-From the perl level this is a reference to a perl subroutine
-(e.g. $sub = sub { 1 };). From the C level this is a pointer
-to a CV.
+## T_HVREF_REFCOUNT_FIXED
-=cut
+HV_FIXED*
+T_HVREF_REFCOUNT_FIXED( hv )
+ HV_FIXED * hv
+ CODE:
+ SvREFCNT_inc(hv);
+ RETVAL = hv;
+ OUTPUT:
+ RETVAL
+
+## T_CVREF
+
CV *
T_CVREF( cv )
CV * cv
@@ -150,23 +347,20 @@
RETVAL
-=item T_SYSRET
+## T_CVREF_REFCOUNT_FIXED
-The T_SYSRET typemap is used to process return values from system calls.
-It is only meaningful when passing values from C to perl (there is
-no concept of passing a system return value from Perl to C).
+CV_FIXED *
+T_CVREF_REFCOUNT_FIXED( cv )
+ CV_FIXED * cv
+ CODE:
+ SvREFCNT_inc(cv);
+ RETVAL = cv;
+ OUTPUT:
+ RETVAL
-System calls return -1 on error (setting ERRNO with the reason)
-and (usually) 0 on success. If the return value is -1 this typemap
-returns C<undef>. If the return value is not -1, this typemap
-translates a 0 (perl false) to "0 but true" (which
-is perl true) or returns the value itself, to indicate that the
-command succeeded.
-The L<POSIX|POSIX> module makes extensive use of this type.
+## T_SYSRET
-=cut
-
# Test a successful return
SysRet
@@ -185,12 +379,8 @@
OUTPUT:
RETVAL
-=item T_UV
+## T_UV
-An unsigned integer.
-
-=cut
-
unsigned int
T_UV( uv )
unsigned int uv
@@ -199,13 +389,9 @@
OUTPUT:
RETVAL
-=item T_IV
-A signed integer. This is cast to the required integer type when
-passed to C and converted to an IV when passed back to Perl.
+## T_IV
-=cut
-
long
T_IV( iv )
long iv
@@ -214,22 +400,20 @@
OUTPUT:
RETVAL
-=item T_INT
-A signed integer. This typemap converts the Perl value to a native
-integer type (the C<int> type on the current platform). When returning
-the value to perl it is processed in the same way as for T_IV.
+## T_INT
-Its behaviour is identical to using an C<int> type in XS with T_IV.
+intTINT
+T_INT( i )
+ intTINT i
+ CODE:
+ RETVAL = i;
+ OUTPUT:
+ RETVAL
-=item T_ENUM
-An enum value. Used to transfer an enum component
-from C. There is no reason to pass an enum value to C since
-it is stored as an IV inside perl.
+## T_ENUM
-=cut
-
# The test should return the value for SVt_PVHV.
# 11 at the present time but we can't not rely on this
# for testing purposes.
@@ -241,13 +425,9 @@
OUTPUT:
RETVAL
-=item T_BOOL
-A boolean type. This can be used to pass true and false values to and
-from C.
+## T_BOOL
-=cut
-
bool
T_BOOL( in )
bool in
@@ -256,28 +436,46 @@
OUTPUT:
RETVAL
-=item T_U_INT
+bool
+T_BOOL_2( in )
+ bool in
+ CODE:
+ OUTPUT:
+ in
-This is for unsigned integers. It is equivalent to using T_UV
-but explicitly casts the variable to type C<unsigned int>.
-The default type for C<unsigned int> is T_UV.
+void
+T_BOOL_OUT( out, in )
+ bool out
+ bool in
+ CODE:
+ out = in;
+ OUTPUT:
+ out
-=item T_SHORT
+## T_U_INT
-Short integers. This is equivalent to T_IV but explicitly casts
-the return to type C<short>. The default typemap for C<short>
-is T_IV.
+intUnsigned
+T_U_INT( uint )
+ intUnsigned uint
+ CODE:
+ RETVAL = uint;
+ OUTPUT:
+ RETVAL
-=item T_U_SHORT
-Unsigned short integers. This is equivalent to T_UV but explicitly
-casts the return to type C<unsigned short>. The default typemap for
-C<unsigned short> is T_UV.
+## T_SHORT
-T_U_SHORT is used for type C<U16> in the standard typemap.
+short
+T_SHORT( s )
+ short s
+ CODE:
+ RETVAL = s;
+ OUTPUT:
+ RETVAL
-=cut
+## T_U_SHORT
+
U16
T_U_SHORT( in )
U16 in
@@ -287,22 +485,18 @@
RETVAL
-=item T_LONG
+## T_LONG
-Long integers. This is equivalent to T_IV but explicitly casts
-the return to type C<long>. The default typemap for C<long>
-is T_IV.
+intTLONG
+T_LONG( in )
+ intTLONG in
+ CODE:
+ RETVAL = in;
+ OUTPUT:
+ RETVAL
-=item T_U_LONG
+## T_U_LONG
-Unsigned long integers. This is equivalent to T_UV but explicitly
-casts the return to type C<unsigned long>. The default typemap for
-C<unsigned long> is T_UV.
-
-T_U_LONG is used for type C<U32> in the standard typemap.
-
-=cut
-
U32
T_U_LONG( in )
U32 in
@@ -311,12 +505,9 @@
OUTPUT:
RETVAL
-=item T_CHAR
-Single 8-bit characters.
+## T_CHAR
-=cut
-
char
T_CHAR( in );
char in
@@ -326,12 +517,8 @@
RETVAL
-=item T_U_CHAR
+## T_U_CHAR
-An unsigned byte.
-
-=cut
-
unsigned char
T_U_CHAR( in );
unsigned char in
@@ -341,13 +528,8 @@
RETVAL
-=item T_FLOAT
+## T_FLOAT
-A floating point number. This typemap guarantees to return a variable
-cast to a C<float>.
-
-=cut
-
float
T_FLOAT( in )
float in
@@ -356,14 +538,9 @@
OUTPUT:
RETVAL
-=item T_NV
-A Perl floating point number. Similar to T_IV and T_UV in that the
-return type is cast to the requested numeric type rather than
-to a specific type.
+## T_NV
-=cut
-
NV
T_NV( in )
NV in
@@ -372,13 +549,9 @@
OUTPUT:
RETVAL
-=item T_DOUBLE
-A double precision floating point number. This typemap guarantees to
-return a variable cast to a C<double>.
+## T_DOUBLE
-=cut
-
double
T_DOUBLE( in )
double in
@@ -387,12 +560,9 @@
OUTPUT:
RETVAL
-=item T_PV
-A string (char *).
+## T_PV
-=cut
-
char *
T_PV( in )
char * in
@@ -401,13 +571,9 @@
OUTPUT:
RETVAL
-=item T_PTR
-A memory address (pointer). Typically associated with a C<void *>
-type.
+## T_PTR
-=cut
-
# Pass in a value. Store the value in some static memory and
# then return the pointer
@@ -430,17 +596,9 @@
OUTPUT:
RETVAL
-=item T_PTRREF
-Similar to T_PTR except that the pointer is stored in a scalar and the
-reference to that scalar is returned to the caller. This can be used
-to hide the actual pointer value from the programmer since it is usually
-not required directly from within perl.
+## T_PTRREF
-The typemap checks that a scalar reference is passed from perl to XS.
-
-=cut
-
# Similar test to T_PTR
# Pass in a value. Store the value in some static memory and
# then return the pointer
@@ -465,20 +623,8 @@
RETVAL
+## T_PTROBJ
-=item T_PTROBJ
-
-Similar to T_PTRREF except that the reference is blessed into a class.
-This allows the pointer to be used as an object. Most commonly used to
-deal with C structs. The typemap checks that the perl object passed
-into the XS routine is of the correct class (or part of a subclass).
-
-The pointer is blessed into a class that is derived from the name
-of type of the pointer but with all '*' in the name replaced with
-'Ptr'.
-
-=cut
-
# Similar test to T_PTRREF
# Pass in a value. Store the value in some static memory and
# then return the pointer
@@ -506,22 +652,13 @@
MODULE = XS::Typemap PACKAGE = XS::Typemap
-=item T_REF_IV_REF
-NOT YET
+## T_REF_IV_REF
+## NOT YET
-=item T_REF_IV_PTR
-Similar to T_PTROBJ in that the pointer is blessed into a scalar object.
-The difference is that when the object is passed back into XS it must be
-of the correct type (inheritance is not supported).
+## T_REF_IV_PTR
-The pointer is blessed into a class that is derived from the name
-of type of the pointer but with all '*' in the name replaced with
-'Ptr'.
-
-=cut
-
# Similar test to T_PTROBJ
# Pass in a value. Store the value in some static memory and
# then return the pointer
@@ -550,38 +687,20 @@
MODULE = XS::Typemap PACKAGE = XS::Typemap
-=item T_PTRDESC
+## T_PTRDESC
+## NOT YET
-NOT YET
-=item T_REFREF
+## T_REFREF
+## NOT YET
-NOT YET
-=item T_REFOBJ
+## T_REFOBJ
+## NOT YET
-NOT YET
-=item T_OPAQUEPTR
+## T_OPAQUEPTR
-This can be used to store bytes in the string component of the
-SV. Here the representation of the data is irrelevant to perl and the
-bytes themselves are just stored in the SV. It is assumed that the C
-variable is a pointer (the bytes are copied from that memory
-location). If the pointer is pointing to something that is
-represented by 8 bytes then those 8 bytes are stored in the SV (and
-length() will report a value of 8). This entry is similar to T_OPAQUE.
-
-In principal the unpack() command can be used to convert the bytes
-back to a number (if the underlying type is known to be a number).
-
-This entry can be used to store a C structure (the number
-of bytes to be copied is calculated using the C C<sizeof> function)
-and can be used as an alternative to T_PTRREF without having to worry
-about a memory leak (since Perl will clean up the SV).
-
-=cut
-
intOpq *
T_OPAQUEPTR_IN( val )
intOpq val
@@ -632,25 +751,8 @@
XPUSHs(sv_2mortal(newSVnv(test->c)));
-=item T_OPAQUE
+## T_OPAQUE
-This can be used to store data from non-pointer types in the string
-part of an SV. It is similar to T_OPAQUEPTR except that the
-typemap retrieves the pointer directly rather than assuming it
-is being supplied. For example if an integer is imported into
-Perl using T_OPAQUE rather than T_IV the underlying bytes representing
-the integer will be stored in the SV but the actual integer value will not
-be available. i.e. The data is opaque to perl.
-
-The data may be retrieved using the C<unpack> function if the
-underlying type of the byte stream is known.
-
-T_OPAQUE supports input and output of simple types.
-T_OPAQUEPTR can be used to pass these bytes back into C if a pointer
-is acceptable.
-
-=cut
-
shortOPQ
T_OPAQUE_IN( val )
int val
@@ -667,25 +769,6 @@
OUTPUT:
RETVAL
-=item Implicit array
-
-xsubpp supports a special syntax for returning
-packed C arrays to perl. If the XS return type is given as
-
- array(type, nelem)
-
-xsubpp will copy the contents of C<nelem * sizeof(type)> bytes from
-RETVAL to an SV and push it onto the stack. This is only really useful
-if the number of items to be returned is known at compile time and you
-don't mind having a string of bytes in your SV. Use T_ARRAY to push a
-variable number of arguments onto the return stack (they won't be
-packed as a single string though).
-
-This is similar to using T_OPAQUEPTR but can be used to process more than
-one element.
-
-=cut
-
array(int,3)
T_OPAQUE_array( a,b,c)
int a
@@ -702,58 +785,80 @@
RETVAL
-=item T_PACKED
+## T_PACKED
-NOT YET
+void
+T_PACKED_in(in)
+ anotherstruct *in;
+ PPCODE:
+ mXPUSHi(in->a);
+ mXPUSHi(in->b);
+ mXPUSHn(in->c);
+ Safefree(in);
+ XSRETURN(3);
-=item T_PACKEDARRAY
+anotherstruct *
+T_PACKED_out(a, b ,c)
+ int a;
+ int b;
+ double c;
+ CODE:
+ Newxz(RETVAL, 1, anotherstruct);
+ RETVAL->a = a;
+ RETVAL->b = b;
+ RETVAL->c = c;
+ OUTPUT: RETVAL
+ CLEANUP:
+ Safefree(RETVAL);
-NOT YET
+## T_PACKEDARRAY
-=item T_DATAUNIT
+void
+T_PACKEDARRAY_in(in)
+ anotherstruct **in;
+ PREINIT:
+ unsigned int i = 0;
+ PPCODE:
+ while (in[i] != NULL) {
+ mXPUSHi(in[i]->a);
+ mXPUSHi(in[i]->b);
+ mXPUSHn(in[i]->c);
+ ++i;
+ }
+ XS_release_anotherstructPtrPtr(in);
+ XSRETURN(3*i);
-NOT YET
+anotherstruct **
+T_PACKEDARRAY_out(...)
+ PREINIT:
+ unsigned int i, nstructs, count_anotherstructPtrPtr;
+ CODE:
+ if ((items % 3) != 0)
+ croak("Need nitems divisible by 3");
+ nstructs = (unsigned int)(items / 3);
+ count_anotherstructPtrPtr = nstructs;
+ Newxz(RETVAL, nstructs+1, anotherstruct *);
+ for (i = 0; i < nstructs; ++i) {
+ Newxz(RETVAL[i], 1, anotherstruct);
+ RETVAL[i]->a = SvIV(ST(3*i));
+ RETVAL[i]->b = SvIV(ST(3*i+1));
+ RETVAL[i]->c = SvNV(ST(3*i+2));
+ }
+ OUTPUT: RETVAL
+ CLEANUP:
+ XS_release_anotherstructPtrPtr(RETVAL);
-=item T_CALLBACK
-NOT YET
+## T_DATAUNIT
+## NOT YET
-=item T_ARRAY
-This is used to convert the perl argument list to a C array
-and for pushing the contents of a C array onto the perl
-argument stack.
+## T_CALLBACK
+## NOT YET
-The usual calling signature is
- @out = array_func( @in );
+## T_ARRAY
-Any number of arguments can occur in the list before the array but
-the input and output arrays must be the last elements in the list.
-
-When used to pass a perl list to C the XS writer must provide a
-function (named after the array type but with 'Ptr' substituted for
-'*') to allocate the memory required to hold the list. A pointer
-should be returned. It is up to the XS writer to free the memory on
-exit from the function. The variable C<ix_$var> is set to the number
-of elements in the new array.
-
-When returning a C array to Perl the XS writer must provide an integer
-variable called C<size_$var> containing the number of elements in the
-array. This is used to determine how many elements should be pushed
-onto the return argument stack. This is not required on input since
-Perl knows how many arguments are on the stack when the routine is
-called. Ordinarily this variable would be called C<size_RETVAL>.
-
-Additionally, the type of each element is determined from the type of
-the array. If the array uses type C<intArray *> xsubpp will
-automatically work out that it contains variables of type C<int> and
-use that typemap entry to perform the copy of each element. All
-pointer '*' and 'Array' tags are removed from the name to determine
-the subtype.
-
-=cut
-
# Test passes in an integer array and returns it along with
# the number of elements
# Pass in a dummy value to test offsetting
@@ -762,6 +867,9 @@
# using PPCODE. This means that only the first element
# is returned. KLUGE this by using CLEANUP to return before the
# end.
+# Note: I read this as: The "T_ARRAY" typemap is really rather broken,
+# at least for OUTPUT. That is apart from the general design
+# weaknesses. --Steffen
intArray *
T_ARRAY( dummy, array, ... )
@@ -780,13 +888,8 @@
XSRETURN(size_RETVAL);
-=item T_STDIO
+## T_STDIO
-This is used for passing perl filehandles to and from C using
-C<FILE *> structures.
-
-=cut
-
FILE *
T_STDIO_open( file )
const char * file
@@ -821,24 +924,32 @@
RETVAL
-=item T_IN
+## T_INOUT
-NOT YET
+PerlIO *
+T_INOUT(in)
+ PerlIO *in;
+ CODE:
+ RETVAL = in; /* silly test but better than nothing */
+ OUTPUT: RETVAL
-=item T_INOUT
-This is used for passing perl filehandles to and from C using
-C<PerlIO *> structures. The file handle can used for reading and
-writing.
+## T_IN
-See L<perliol> for more information on the Perl IO abstraction
-layer. Perl must have been built with C<-Duseperlio>.
+inputfh
+T_IN(in)
+ inputfh in;
+ CODE:
+ RETVAL = in; /* silly test but better than nothing */
+ OUTPUT: RETVAL
-=item T_OUT
-NOT YET
+## T_OUT
-=back
+outputfh
+T_OUT(in)
+ outputfh in;
+ CODE:
+ RETVAL = in; /* silly test but better than nothing */
+ OUTPUT: RETVAL
-=cut
-
Property changes on: trunk/contrib/perl/ext/XS-Typemap/Typemap.xs
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/ext/XS-Typemap/stdio.c
===================================================================
--- trunk/contrib/perl/ext/XS-Typemap/stdio.c 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/XS-Typemap/stdio.c 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/XS-Typemap/stdio.c
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/ext/XS-Typemap/t/Typemap.t
===================================================================
--- trunk/contrib/perl/ext/XS-Typemap/t/Typemap.t 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/XS-Typemap/t/Typemap.t 2013-12-02 21:32:26 UTC (rev 6445)
@@ -6,7 +6,7 @@
}
}
-use Test::More tests => 84;
+use Test::More tests => 146;
use strict;
use warnings;
@@ -28,17 +28,16 @@
}
# T_SV - standard perl scalar value
-print "# T_SV\n";
-
+note("T_SV");
my $sv = "Testing T_SV";
is( T_SV($sv), $sv);
# T_SVREF - reference to Scalar
-print "# T_SVREF\n";
-
+note("T_SVREF");
$sv .= "REF";
my $svref = \$sv;
is( T_SVREF($svref), $svref );
+is( ${ T_SVREF($svref) }, $$svref );
# Now test that a non reference is rejected
# the typemaps croak
@@ -45,70 +44,106 @@
eval { T_SVREF( "fail - not ref" ) };
ok( $@ );
+note("T_SVREF_REFCOUNT_FIXED");
+is( T_SVREF_REFCOUNT_FIXED($svref), $svref );
+is( ${ T_SVREF_REFCOUNT_FIXED($svref) }, $$svref );
+eval { T_SVREF_REFCOUNT_FIXED( "fail - not ref" ) };
+ok( $@ );
+
+
# T_AVREF - reference to a perl Array
-print "# T_AVREF\n";
-
+note("T_AVREF");
my @array;
is( T_AVREF(\@array), \@array);
-
# Now test that a non array ref is rejected
eval { T_AVREF( \$sv ) };
ok( $@ );
+# T_AVREF_REFCOUNT_FIXED - reference to a perl Array, refcount fixed
+note("T_AVREF_REFCOUNT_FIXED");
+is( T_AVREF_REFCOUNT_FIXED(\@array), \@array);
+# Now test that a non array ref is rejected
+eval { T_AVREF_REFCOUNT_FIXED( \$sv ) };
+ok( $@ );
+
+
# T_HVREF - reference to a perl Hash
-print "# T_HVREF\n";
-
+note("T_HVREF");
my %hash;
is( T_HVREF(\%hash), \%hash);
-
# Now test that a non hash ref is rejected
eval { T_HVREF( \@array ) };
ok( $@ );
+# T_HVREF_REFCOUNT_FIXED - reference to a perl Hash, refcount fixed
+note("T_HVREF_REFCOUNT_FIXED");
+is( T_HVREF_REFCOUNT_FIXED(\%hash), \%hash);
+# Now test that a non hash ref is rejected
+eval { T_HVREF_REFCOUNT_FIXED( \@array ) };
+ok( $@ );
+
+
# T_CVREF - reference to perl subroutine
-print "# T_CVREF\n";
+note("T_CVREF");
my $sub = sub { 1 };
is( T_CVREF($sub), $sub );
-
# Now test that a non code ref is rejected
eval { T_CVREF( \@array ) };
ok( $@ );
+is( T_CVREF_REFCOUNT_FIXED($sub), $sub );
+# Now test that a non code ref is rejected
+eval { T_CVREF_REFCOUNT_FIXED( \@array ) };
+ok( $@ );
+
+
# T_SYSRET - system return values
-print "# T_SYSRET\n";
-
+note("T_SYSRET");
# first check success
ok( T_SYSRET_pass );
-
# ... now failure
is( T_SYSRET_fail, undef);
# T_UV - unsigned integer
-print "# T_UV\n";
-
+note("T_UV");
is( T_UV(5), 5 ); # pass
isnt( T_UV(-4), -4); # fail
+# T_U_INT - unsigned integer with (unsigned int) cast
+note("T_U_INT");
+is( T_U_INT(5), 5 ); # pass
+isnt( T_U_INT(-4), -4); # fail
+
# T_IV - signed integer
-print "# T_IV\n";
+# T_INT - signed integer with cast
+# T_LONG - signed integer with cast to IV
+# T_SHORT - signed short
+for my $t (['T_IV', \&T_IV],
+ ['T_INT', \&T_INT],
+ ['T_LONG', \&T_LONG],
+ ['T_SHORT', \&T_SHORT])
+{
+ note($t->[0]);
+ is( $t->[1]->(5), 5);
+ is( $t->[1]->(-4), -4);
+ is( $t->[1]->(4.1), int(4.1));
+ is( $t->[1]->("52"), "52");
+ isnt( $t->[1]->(4.5), 4.5); # failure
+}
-is( T_IV(5), 5);
-is( T_IV(-4), -4);
-is( T_IV(4.1), int(4.1));
-is( T_IV("52"), "52");
-isnt( T_IV(4.5), 4.5); # failure
+if ($Config{shortsize} == 2) {
+ isnt( T_SHORT(32801), 32801 );
+}
+else {
+ pass(); # e.g. Crays have shortsize 4 (T3X) or 8 (CXX and SVX)
+}
-
-# Skip T_INT
-
# T_ENUM - enum list
-print "# T_ENUM\n";
+ok( T_ENUM(), 'T_ENUM' ); # just hope for a true value
-ok( T_ENUM() ); # just hope for a true value
-
# T_BOOL - boolean
-print "# T_BOOL\n";
+note("T_BOOL");
ok( T_BOOL(52) );
ok( ! T_BOOL(0) );
@@ -115,14 +150,27 @@
ok( ! T_BOOL('') );
ok( ! T_BOOL(undef) );
-# Skip T_U_INT
+{
+ # these attempt to modify a read-only value
+ ok( !eval { T_BOOL_2(52); 1 } );
+ ok( !eval { T_BOOL_2(0); 1 } );
+ ok( !eval { T_BOOL_2(''); 1 } );
+ ok( !eval { T_BOOL_2(undef); 1 } );
+}
-# Skip T_SHORT
+{
+ my ($in, $out);
+ $in = 1;
+ T_BOOL_OUT($out, $in);
+ ok($out, "T_BOOL_OUT, true in");
+ $in = 0;
+ $out = 1;
+ T_BOOL_OUT($out, $in);
+ ok(!$out, "T_BOOL_OUT, false in");
+}
# T_U_SHORT aka U16
-
-print "# T_U_SHORT\n";
-
+note("T_U_SHORT");
is( T_U_SHORT(32000), 32000);
if ($Config{shortsize} == 2) {
isnt( T_U_SHORT(65536), 65536); # probably dont want to test edge cases
@@ -131,16 +179,12 @@
}
# T_U_LONG aka U32
-
-print "# T_U_LONG\n";
-
+note("T_U_LONG");
is( T_U_LONG(65536), 65536);
isnt( T_U_LONG(-1), -1);
# T_CHAR
-
-print "# T_CHAR\n";
-
+note("T_CHAR");
is( T_CHAR("a"), "a");
is( T_CHAR("-"), "-");
is( T_CHAR(chr(128)),chr(128));
@@ -147,9 +191,7 @@
isnt( T_CHAR(chr(256)), chr(256));
# T_U_CHAR
-
-print "# T_U_CHAR\n";
-
+note("T_U_CHAR");
is( T_U_CHAR(127), 127);
is( T_U_CHAR(128), 128);
isnt( T_U_CHAR(-1), -1);
@@ -156,37 +198,27 @@
isnt( T_U_CHAR(300), 300);
# T_FLOAT
-print "# T_FLOAT\n";
-
# limited precision
-is( sprintf("%6.3f",T_FLOAT(52.345)), sprintf("%6.3f",52.345));
+is( sprintf("%6.3f",T_FLOAT(52.345)), sprintf("%6.3f",52.345), "T_FLOAT");
# T_NV
-print "# T_NV\n";
+is( T_NV(52.345), 52.345, "T_NV" );
-is( T_NV(52.345), 52.345);
-
# T_DOUBLE
-print "# T_DOUBLE\n";
+is( sprintf("%6.3f",T_DOUBLE(52.345)), sprintf("%6.3f",52.345), "T_DOUBLE" );
-is( sprintf("%6.3f",T_DOUBLE(52.345)), sprintf("%6.3f",52.345));
-
# T_PV
-print "# T_PV\n";
-
+note("T_PV");
is( T_PV("a string"), "a string");
is( T_PV(52), 52);
# T_PTR
-print "# T_PTR\n";
-
my $t = 5;
my $ptr = T_PTR_OUT($t);
-is( T_PTR_IN( $ptr ), $t );
+is( T_PTR_IN( $ptr ), $t, "T_PTR" );
# T_PTRREF
-print "# T_PTRREF\n";
-
+note("T_PTRREF");
$t = -52;
$ptr = T_PTRREF_OUT( $t );
is( ref($ptr), "SCALAR");
@@ -197,8 +229,7 @@
ok( $@ );
# T_PTROBJ
-print "# T_PTROBJ\n";
-
+note("T_PTROBJ");
$t = 256;
$ptr = T_PTROBJ_OUT( $t );
is( ref($ptr), "intObjPtr");
@@ -216,8 +247,7 @@
# Skip T_REF_IV_REF
# T_REF_IV_PTR
-print "# T_REF_IV_PTR\n";
-
+note("T_REF_IV_PTR");
$t = -365;
$ptr = T_REF_IV_PTR_OUT( $t );
is( ref($ptr), "intRefIvPtr");
@@ -235,15 +265,13 @@
# Skip T_REFOBJ
# T_OPAQUEPTR
-print "# T_OPAQUEPTR\n";
-
+note("T_OPAQUEPTR");
$t = 22;
my $p = T_OPAQUEPTR_IN( $t );
is( T_OPAQUEPTR_OUT($p), $t);
# T_OPAQUEPTR with a struct
-print "# T_OPAQUEPTR with a struct\n";
-
+note("T_OPAQUEPTR with a struct");
my @test = (5,6,7);
$p = T_OPAQUEPTR_IN_struct(@test);
my @result = T_OPAQUEPTR_OUT_struct($p);
@@ -253,8 +281,7 @@
}
# T_OPAQUE
-print "# T_OPAQUE\n";
-
+note("T_OPAQUE");
$t = 48;
$p = T_OPAQUE_IN( $t );
is(T_OPAQUEPTR_OUT_short( $p ), $t); # Test using T_OPAQUEPTR
@@ -261,7 +288,7 @@
is(T_OPAQUE_OUT( $p ), $t ); # Test using T_OPQAQUE
# T_OPAQUE_array
-print "# A packed array\n";
+note("T_OPAQUE: A packed array");
my @opq = (2,4,8);
my $packed = T_OPAQUE_array(@opq);
@@ -271,9 +298,45 @@
is( $uopq[$_], $opq[$_]);
}
-# Skip T_PACKED
+# T_PACKED
+note("T_PACKED");
+my $struct = T_PACKED_out(-4, 3, 2.1);
+ok(ref($struct) eq 'HASH');
+is_approx($struct->{a}, -4);
+is_approx($struct->{b}, 3);
+is_approx($struct->{c}, 2.1);
+my @rv = T_PACKED_in($struct);
+is(scalar(@rv), 3);
+is_approx($rv[0], -4);
+is_approx($rv[1], 3);
+is_approx($rv[2], 2.1);
-# Skip T_PACKEDARRAY
+# T_PACKEDARRAY
+SCOPE: {
+ note("T_PACKED_ARRAY");
+ my @d = (
+ -4, 3, 2.1,
+ 2, 1, -15.3,
+ 1,1,1
+ );
+ my @out;
+ push @out, {a => $d[$_*3], b => $d[$_*3+1], c => $d[$_*3+2]} for (0..2);
+ my $structs = T_PACKEDARRAY_out(@d);
+ ok(ref($structs) eq 'ARRAY');
+ is(scalar(@$structs), 3);
+ foreach my $i (0..2) {
+ my $s = $structs->[$i];
+ is(ref($s), 'HASH');
+ is_approx($s->{a}, $d[$i*3+0]);
+ is_approx($s->{b}, $d[$i*3+1]);
+ is_approx($s->{c}, $d[$i*3+2]);
+ }
+ my @rv = T_PACKEDARRAY_in($structs);
+ is(scalar(@rv), scalar(@d));
+ foreach my $i (0..$#d) {
+ is_approx($rv[$i], $d[$i]);
+ }
+}
# Skip T_DATAUNIT
@@ -280,19 +343,12 @@
# Skip T_CALLBACK
# T_ARRAY
-print "# T_ARRAY\n";
my @inarr = (1,2,3,4,5,6,7,8,9,10);
my @outarr = T_ARRAY( 5, @inarr );
-is(scalar(@outarr), scalar(@inarr));
+is_deeply(\@outarr, \@inarr, "T_ARRAY");
-for (0..$#inarr) {
- is($outarr[$_], $inarr[$_]);
-}
-
-
-
# T_STDIO
-print "# T_STDIO\n";
+note("T_STDIO");
# open a file in XS for write
my $testfile= "stdio.tmp";
@@ -330,3 +386,53 @@
}
}
+# T_INOUT
+note("T_INOUT");
+SCOPE: {
+ my $buf = '';
+ local $| = 1;
+ open my $fh, "+<", \$buf or die $!;
+ my $str = "Fooo!\n";
+ print $fh $str;
+ my $fh2 = T_INOUT($fh);
+ seek($fh2, 0, 0);
+ is(readline($fh2), $str);
+ ok(print $fh2 "foo\n");
+}
+
+# T_IN
+note("T_IN");
+SCOPE: {
+ my $buf = "Hello!\n";
+ local $| = 1;
+ open my $fh, "<", \$buf or die $!;
+ my $fh2 = T_IN($fh);
+ is(readline($fh2), $buf);
+ local $SIG{__WARN__} = sub {die};
+ ok(not(eval {print $fh2 "foo\n"; 1}));
+}
+
+# T_OUT
+note("T_OUT");
+SCOPE: {
+ my $buf = '';
+ local $| = 1;
+ open my $fh, "+<", \$buf or die $!;
+ my $str = "Fooo!\n";
+ print $fh $str;
+ my $fh2 = T_OUT($fh);
+ seek($fh2, 0, 0);
+ is(readline($fh2), $str);
+ ok(eval {print $fh2 "foo\n"; 1});
+}
+
+sub is_approx {
+ my ($l, $r, $n) = @_;
+ if (not defined $l or not defined $r) {
+ fail(defined($n) ? $n : ());
+ }
+ else {
+ ok($l < $r+1e-6 && $r < $l+1e-6, defined($n) ? $n : ())
+ or note("$l and $r seem to be different given a fuzz of 1e-6");
+ }
+}
Property changes on: trunk/contrib/perl/ext/XS-Typemap/t/Typemap.t
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Index: trunk/contrib/perl/ext/XS-Typemap/typemap
===================================================================
--- trunk/contrib/perl/ext/XS-Typemap/typemap 2013-12-02 21:30:11 UTC (rev 6444)
+++ trunk/contrib/perl/ext/XS-Typemap/typemap 2013-12-02 21:32:26 UTC (rev 6445)
Property changes on: trunk/contrib/perl/ext/XS-Typemap/typemap
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
More information about the Midnightbsd-cvs
mailing list